+(defun funcallable-lambda-list (args)
+ (let ((ll nil))
+ (dolist (arg args)
+ (push (car arg) ll))
+ (nreverse ll)))
+
+#|
+(defmacro def-funcallable (name args &key returning)
+ (let ((result-type (convert-from-uffi-type returning :return))
+ (function-args (process-function-args args)))
+ #+lispworks
+ `(fli:define-foreign-funcallable ,name ,function-args
+ :result-type ,result-type
+ :language :ansi-c
+ :calling-convention :cdecl)
+ #+(or cmu scl sbcl)
+ ;; requires the type of the function pointer be declared correctly!
+ (let* ((ptrsym (gensym))
+ (ll (funcallable-lambda-list args)))
+ `(defun ,name ,(cons ptrsym ll)
+ (alien::alien-funcall ,ptrsym ,@ll)))
+ #+openmcl
+ (multiple-value-bind (params args) (process-function-args args)
+ (let ((ptrsym (gensym)))
+ `(defun ,name ,(cons ptrsym params)
+ (ccl::ff-call ,ptrsym ,@args ,result-type))))
+ #+allegro
+ ;; this is most definitely wrong
+ (let* ((ptrsym (gensym))
+ (ll (funcallable-lambda-list args)))
+ `(defun ,name ,(cons ptrsym ll)
+ (system::ff-funcall ,ptrsym ,@ll)))
+ ))
+|#
+
+(defun convert-lispworks-args (args)
+ (loop for arg in args
+ with processed = nil
+ do
+ (if (and (= (length arg) 3) (eq (third arg) :out))
+ (push (list (first arg)
+ (list :reference-return (second arg))) processed)
+ (push (subseq arg 0 2) processed))
+ finally (return (nreverse processed))))
+
+(defun preprocess-names (names)
+ (let ((fname (gensym)))
+ (if (atom names)
+ (values (list names fname) fname (uffi::make-lisp-name names))
+ (values (list (first names) fname) fname (second names)))))
+
+(defun preprocess-args (args)
+ (loop for arg in args
+ with lisp-args = nil and out = nil and processed = nil
+ do
+ (if (= (length arg) 3)
+ (ecase (third arg)
+ (:in
+ (progn
+ (push (first arg) lisp-args)
+ (push (list (first arg) (second arg)) processed)))
+ (:out
+ (progn
+ (push (list (first arg) (second arg)) out)
+ (push (list (first arg) (list '* (second arg))) processed))))
+ (progn
+ (push (first arg) lisp-args)
+ (push arg processed)))
+ finally (return (values (nreverse lisp-args)
+ (nreverse out)
+ (nreverse processed)))))
+
+
+(defmacro def-function (names args &key module returning)
+ (multiple-value-bind (lisp-args out processed)
+ (preprocess-args args)
+ (declare (ignorable lisp-args processed))
+ (if (= (length out) 0)
+ `(%def-function ,names ,args
+ ,@(if module (list :module module) (values))
+ ,@(if returning (list :returning returning) (values)))
+
+ #+(or cmu scl sbcl)
+ `(%def-function ,names ,args
+ ,@(if returning (list :returning returning) (values)))
+ #+(or lispworks5 lispworks6)
+ (multiple-value-bind (name-pair fname lisp-name)
+ (preprocess-names names)
+ `(progn
+ (%def-function ,name-pair ,(convert-lispworks-args args)
+ ,@(if module (list :module module) (values))
+ ,@(if returning (list :returning returning) (values)))
+ (defun ,lisp-name ,lisp-args
+ (,fname ,@(mapcar
+ #'(lambda (arg)
+ (cond ((member (first arg) lisp-args)
+ (first arg))
+ ((member (first arg) out :key #'first)
+ t)))
+ args)))))
+ #+(and lispworks (not lispworks5) (not lispworks 6))
+ `(%def-function ,names ,(convert-lispworks-args args)
+ ,@(if module (list :module module) (values))
+ ,@(if returning (list :returning returning) (values)))
+ #-(or cmu scl sbcl lispworks)
+ (multiple-value-bind (name-pair fname lisp-name)
+ (preprocess-names names)
+ `(progn
+ (%def-function ,name-pair ,processed
+ :module ,module :returning ,returning)
+ ;(declaim (inline ,fname))
+ (defun ,lisp-name ,lisp-args
+ (with-foreign-objects ,out
+ (values (,fname ,@(mapcar #'first args))
+ ,@(mapcar #'(lambda (arg)
+ (list 'deref-pointer
+ (first arg)
+ (second arg))) out))))))
+ )))
+
+