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
10 ;;;; This file, part of UFFI, is Copyright (c) 2002-2010 by Kevin M. Rosenberg
12 ;;;; *************************************************************************
16 (defun process-function-args (args)
18 #+(or lispworks cmu sbcl scl cormanlisp digitool) nil
20 #+openmcl (values nil nil)
23 #+(or lispworks allegro cmu sbcl scl digitool cormanlisp)
26 (push (process-one-function-arg arg) processed))
32 (let ((name (car arg))
33 (type (convert-from-uffi-type (cadr arg) :routine)))
34 ;;(when (and (listp type) (eq (car type) :address))
35 ;;(setf type :address))
38 (push name processed)))
39 (values (nreverse params) (nreverse processed)))
42 (defun process-one-function-arg (arg)
43 (let ((name (car arg))
44 (type (convert-from-uffi-type (cadr arg) :routine)))
47 `(,name ,type ,@(if (= (length arg) 3) (list (third arg)) (values)))
48 #+(or allegro lispworks digitool)
49 (if (and (listp type) (listp (car type)))
50 (append (list name) type)
53 (declare (ignore name type))
57 (defun allegro-convert-return-type (type)
58 (if (and (listp type) (not (listp (car type))))
62 (defun funcallable-lambda-list (args)
69 (defmacro def-funcallable (name args &key returning)
70 (let ((result-type (convert-from-uffi-type returning :return))
71 (function-args (process-function-args args)))
73 `(fli:define-foreign-funcallable ,name ,function-args
74 :result-type ,result-type
76 :calling-convention :cdecl)
78 ;; requires the type of the function pointer be declared correctly!
79 (let* ((ptrsym (gensym))
80 (ll (funcallable-lambda-list args)))
81 `(defun ,name ,(cons ptrsym ll)
82 (alien::alien-funcall ,ptrsym ,@ll)))
84 (multiple-value-bind (params args) (process-function-args args)
85 (let ((ptrsym (gensym)))
86 `(defun ,name ,(cons ptrsym params)
87 (ccl::ff-call ,ptrsym ,@args ,result-type))))
89 ;; this is most definitely wrong
90 (let* ((ptrsym (gensym))
91 (ll (funcallable-lambda-list args)))
92 `(defun ,name ,(cons ptrsym ll)
93 (system::ff-funcall ,ptrsym ,@ll)))
97 (defun convert-lispworks-args (args)
101 (if (and (= (length arg) 3) (eq (third arg) :out))
102 (push (list (first arg)
103 (list :reference-return (second arg))) processed)
104 (push (subseq arg 0 2) processed))
105 finally (return (nreverse processed))))
107 (defun preprocess-names (names)
108 (let ((fname (gensym)))
110 (values (list names fname) fname (uffi::make-lisp-name names))
111 (values (list (first names) fname) fname (second names)))))
113 (defun preprocess-args (args)
114 (loop for arg in args
115 with lisp-args = nil and out = nil and processed = nil
117 (if (= (length arg) 3)
121 (push (first arg) lisp-args)
122 (push (list (first arg) (second arg)) processed)))
125 (push (list (first arg) (second arg)) out)
126 (push (list (first arg) (list '* (second arg))) processed))))
128 (push (first arg) lisp-args)
129 (push arg processed)))
130 finally (return (values (nreverse lisp-args)
132 (nreverse processed)))))
135 (defmacro def-function (names args &key module returning)
136 (multiple-value-bind (lisp-args out processed)
137 (preprocess-args args)
138 (declare (ignorable lisp-args processed))
139 (if (= (length out) 0)
140 `(%def-function ,names ,args
141 ,@(if module (list :module module) (values))
142 ,@(if returning (list :returning returning) (values)))
145 `(%def-function ,names ,args
146 ,@(if returning (list :returning returning) (values)))
147 #+(or lispworks5 lispworks6)
148 (multiple-value-bind (name-pair fname lisp-name)
149 (preprocess-names names)
151 (%def-function ,name-pair ,(convert-lispworks-args args)
152 ,@(if module (list :module module) (values))
153 ,@(if returning (list :returning returning) (values)))
154 (defun ,lisp-name ,lisp-args
157 (cond ((member (first arg) lisp-args)
159 ((member (first arg) out :key #'first)
162 #+(and lispworks (not lispworks5) (not lispworks 6))
163 `(%def-function ,names ,(convert-lispworks-args args)
164 ,@(if module (list :module module) (values))
165 ,@(if returning (list :returning returning) (values)))
166 #-(or cmu scl sbcl lispworks)
167 (multiple-value-bind (name-pair fname lisp-name)
168 (preprocess-names names)
170 (%def-function ,name-pair ,processed
171 :module ,module :returning ,returning)
172 ;(declaim (inline ,fname))
173 (defun ,lisp-name ,lisp-args
174 (with-foreign-objects ,out
175 (values (,fname ,@(mapcar #'first args))
176 ,@(mapcar #'(lambda (arg)
179 (second arg))) out))))))
183 ;; name is either a string representing foreign name, or a list
184 ;; of foreign-name as a string and lisp name as a symbol
185 (defmacro %def-function (names args &key module returning)
186 #+(or cmu sbcl scl allegro openmcl digitool cormanlisp) (declare (ignore module))
188 (let* ((result-type (convert-from-uffi-type returning :return))
189 (function-args (process-function-args args))
190 (foreign-name (if (atom names) names (car names)))
191 (lisp-name (if (atom names) (make-lisp-name names) (cadr names))))
192 ;; todo: calling-convention :stdcall for cormanlisp
194 `(ff:def-foreign-call (,lisp-name ,foreign-name)
196 :returning ,(allegro-convert-return-type result-type)
198 :strings-convert nil)
200 `(alien:def-alien-routine (,foreign-name ,lisp-name)
204 `(sb-alien:define-alien-routine (,foreign-name ,lisp-name)
208 `(fli:define-foreign-function (,lisp-name ,foreign-name :source)
210 ,@(if module (list :module module) (values))
211 :result-type ,result-type
213 #+:mswindows :calling-convention #+:mswindows :cdecl)
215 `(eval-when (:compile-toplevel :load-toplevel :execute)
216 (ccl:define-entry-point (,lisp-name ,foreign-name)
220 (declare (ignore function-args))
221 #+(and openmcl darwinppc-target)
222 (setf foreign-name (concatenate 'string "_" foreign-name))
224 (multiple-value-bind (params args) (process-function-args args)
225 `(defun ,lisp-name ,params
226 (ccl::external-call ,foreign-name ,@args ,result-type)))
228 `(ct:defun-dll ,lisp-name (,function-args)
229 :return-type ,result-type
230 ,@(if module (list :library-name module) (values))
231 :entry-name ,foreign-name
232 :linkage-type ,calling-convention) ; we need :pascal