+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: function.cl
+;;;; Purpose: UFFI source to C function defintions
+;;;; Programmer: Kevin M. Rosenberg
+;;;; Date Started: Feb 2002
+;;;;
+;;;; Copyright (c) 2002 Kevin M. Rosenberg
+;;;;
+;;;; $Id: functions.cl,v 1.1 2002/03/09 21:53:58 kevin Exp $
+;;;;
+;;;; This file is part of the UFFI.
+;;;;
+;;;; UFFI is free software; you can redistribute it and/or modify
+;;;; it under the terms of the GNU General Public License (version 2) as
+;;;; published by the Free Software Foundation.
+;;;;
+;;;; UFFI is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;;; GNU General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU General Public License
+;;;; along with UFFI; if not, write to the Free Software
+;;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+;;;; *************************************************************************
+
+(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
+(in-package :uffi)
+
+(defun process-function-args (args)
+ (if (null args)
+ #+lispworks nil
+ #+allegro '(:void)
+ #+cmu nil
+ (let (processed)
+ (dolist (arg args)
+ (push (process-one-function-arg arg) processed))
+ (nreverse processed))))
+
+(defun process-one-function-arg (arg)
+ (let ((name (car arg))
+ (type (convert-from-uffi-type (cadr arg) :routine)))
+ #+cmu
+ (list name type :in)
+ #+(or allegro lispworks)
+ (if (and (listp type) (listp (car type)))
+ (append (list name) type)
+ (list name type))
+ ))
+
+(defun allegro-convert-return-type (type)
+ (if (and (listp type) (not (listp (car type))))
+ (list type)
+ type))
+
+;; name is either a string representing foreign name, or a list
+;; of foreign-name as a string and lisp name as a symbol
+(defmacro def-function (names args &key module returning)
+ #+(or cmu allegro) (declare (ignore module))
+
+ (let* ((result-type (convert-from-uffi-type returning :return))
+ (function-args (process-function-args args))
+ (foreign-name (if (atom names) names (car names)))
+ (lisp-name (if (atom names) (make-lisp-name names) (cadr names))))
+
+ #+allegro
+ `(ff:def-foreign-call (,lisp-name ,foreign-name)
+ ,function-args
+ :returning ,(allegro-convert-return-type result-type)
+ :call-direct t
+ :strings-convert nil)
+ #+cmu
+ `(alien:def-alien-routine (,foreign-name ,lisp-name)
+ ,result-type
+ ,@function-args)
+ #+lispworks
+ `(fli:define-foreign-function (,lisp-name ,foreign-name :object)
+ ,function-args
+ ,@(if module (list :module module) (values))
+ :result-type ,result-type
+ :calling-convention :cdecl)
+ ))
+
+
+(defun make-lisp-name (name)
+ (let ((converted (substitute #\- #\_ name)))
+ (intern
+ #+case-sensitive converted
+ #-case-sensitive (string-upcase converted))))
+
+