1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: UFFI -*-
2 ;;;; *************************************************************************
3 ;;;; FILE IDENTIFICATION
5 ;;;; Name: function.lisp
6 ;;;; Purpose: UFFI source to C function definitions
7 ;;;; Programmer: Kevin M. Rosenberg
8 ;;;; Date Started: Feb 2002
12 ;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
14 ;;;; UFFI users are granted the rights to distribute and use this software
15 ;;;; as governed by the terms of the Lisp Lesser GNU Public License
16 ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
17 ;;;; *************************************************************************
21 (defun process-function-args (args)
23 #+(or lispworks cmu sbcl scl cormanlisp (and mcl (not openmcl))) nil
25 #+openmcl (values nil nil)
28 #+(or lispworks allegro cmu sbcl scl (and mcl (not openmcl)) cormanlisp)
31 (push (process-one-function-arg arg) processed))
37 (let ((name (car arg))
38 (type (convert-from-uffi-type (cadr arg) :routine)))
39 ;;(when (and (listp type) (eq (car type) :address))
40 ;;(setf type :address))
43 (push name processed)))
44 (values (nreverse params) (nreverse processed)))
47 (defun process-one-function-arg (arg)
48 (let ((name (car arg))
49 (type (convert-from-uffi-type (cadr arg) :routine)))
52 `(,name ,type ,@(if (= (length arg) 3) (list (third arg)) (values)))
53 #+(or allegro lispworks (and mcl (not openmcl)))
54 (if (and (listp type) (listp (car type)))
55 (append (list name) type)
58 (declare (ignore name type))
62 (defun allegro-convert-return-type (type)
63 (if (and (listp type) (not (listp (car type))))
67 (defun funcallable-lambda-list (args)
74 (defmacro def-funcallable (name args &key returning)
75 (let ((result-type (convert-from-uffi-type returning :return))
76 (function-args (process-function-args args)))
78 `(fli:define-foreign-funcallable ,name ,function-args
79 :result-type ,result-type
81 :calling-convention :cdecl)
83 ;; requires the type of the function pointer be declared correctly!
84 (let* ((ptrsym (gensym))
85 (ll (funcallable-lambda-list args)))
86 `(defun ,name ,(cons ptrsym ll)
87 (alien::alien-funcall ,ptrsym ,@ll)))
89 (multiple-value-bind (params args) (process-function-args args)
90 (let ((ptrsym (gensym)))
91 `(defun ,name ,(cons ptrsym params)
92 (ccl::ff-call ,ptrsym ,@args ,result-type))))
94 ;; this is most definitely wrong
95 (let* ((ptrsym (gensym))
96 (ll (funcallable-lambda-list args)))
97 `(defun ,name ,(cons ptrsym ll)
98 (system::ff-funcall ,ptrsym ,@ll)))
102 (defun convert-lispworks-args (args)
103 (loop for arg in args
106 (if (and (= (length arg) 3) (eq (third arg) :out))
107 (push (list (first arg)
108 (list :reference-return (second arg))) processed)
109 (push (subseq arg 0 2) processed))
110 finally (return processed)))
112 (defun preprocess-names (names)
113 (let ((fname (gensym)))
115 (values (list names fname) fname (uffi::make-lisp-name names))
116 (values (list (first names) fname) fname (second names)))))
118 (defun preprocess-args (args)
119 (loop for arg in args
120 with lisp-args = nil and out = nil and processed = nil
122 (if (= (length arg) 3)
126 (push (first arg) lisp-args)
127 (push (list (first arg) (second arg)) processed)))
130 (push (list (first arg) (second arg)) out)
131 (push (list (first arg) (list '* (second arg))) processed))))
133 (push (first arg) lisp-args)
134 (push arg processed)))
135 finally (return (values (nreverse lisp-args)
137 (nreverse processed)))))
140 (defmacro def-function (names args &key module returning)
141 (multiple-value-bind (lisp-args out processed)
142 (preprocess-args args)
143 (if (= (length out) 0)
144 `(%def-function ,names ,args
145 ,@(if module (list :module module) (values))
146 ,@(if returning (list :returning returning) (values)))
149 `(%def-function ,names ,args
150 ,@(if returning (list :returning returning) (values)))
152 `(%def-function ,names ,(convert-lispworks-args args)
153 ,@(if module (list :module module) (values))
154 ,@(if returning (list :returning returning) (values)))
155 #-(or cmu scl sbcl lispworks)
156 (multiple-value-bind (name-pair fname lisp-name)
157 (preprocess-names names)
159 (%def-function ,name-pair ,processed
160 :module ,module :returning ,returning)
161 ;(declaim (inline ,fname))
162 (defun ,lisp-name ,lisp-args
163 (with-foreign-objects ,out
164 (values (,fname ,@(mapcar #'first args))
165 ,@(mapcar #'(lambda (arg)
168 (second arg))) out))))))
172 ;; name is either a string representing foreign name, or a list
173 ;; of foreign-name as a string and lisp name as a symbol
174 (defmacro %def-function (names args &key module returning)
175 #+(or cmu sbcl scl allegro mcl cormanlisp) (declare (ignore module))
177 (let* ((result-type (convert-from-uffi-type returning :return))
178 (function-args (process-function-args args))
179 (foreign-name (if (atom names) names (car names)))
180 (lisp-name (if (atom names) (make-lisp-name names) (cadr names))))
182 ;; todo: calling-convention :stdcall for cormanlisp
184 `(ff:def-foreign-call (,lisp-name ,foreign-name)
186 :returning ,(allegro-convert-return-type result-type)
188 :strings-convert nil)
190 `(alien:def-alien-routine (,foreign-name ,lisp-name)
194 `(sb-alien:define-alien-routine (,foreign-name ,lisp-name)
198 `(fli:define-foreign-function (,lisp-name ,foreign-name :source)
200 ,@(if module (list :module module) (values))
201 :result-type ,result-type
203 :calling-convention :cdecl)
204 #+(and mcl (not openmcl))
205 `(eval-when (:compile-toplevel :load-toplevel :execute)
206 (ccl:define-entry-point (,lisp-name ,foreign-name)
210 (declare (ignore function-args))
211 #+(and openmcl darwinppc-target)
212 (setf foreign-name (concatenate 'string "_" foreign-name))
214 (multiple-value-bind (params args) (process-function-args args)
215 `(defun ,lisp-name ,params
216 (ccl::external-call ,foreign-name ,@args ,result-type)))
218 `(ct:defun-dll ,lisp-name (,function-args)
219 :return-type ,result-type
220 ,@(if module (list :library-name module) (values))
221 :entry-name ,foreign-name
222 :linkage-type ,calling-convention) ; we need :pascal