;;;;
;;;; $Id$
;;;;
-;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;; This file, part of UFFI, is Copyright (c) 2005 by Kevin M. Rosenberg
;;;;
-;;;; UFFI users are granted the rights to distribute and use this software
-;;;; as governed by the terms of the Lisp Lesser GNU Public License
-;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
;;;; *************************************************************************
(in-package #:uffi)
(defun process-function-args (args)
(if (null args)
- #+(or lispworks cmu sbcl scl cormanlisp (and mcl (not openmcl))) nil
+ #+(or lispworks cmu sbcl scl cormanlisp digitool) nil
#+allegro '(:void)
#+openmcl (values nil nil)
;; args not null
- #+(or lispworks allegro cmu sbcl scl (and mcl (not openmcl)) cormanlisp)
+ #+(or lispworks allegro cmu sbcl scl digitool cormanlisp)
(let (processed)
(dolist (arg args)
(push (process-one-function-arg arg) processed))
#+(or cmu sbcl scl)
;(list name type :in)
`(,name ,type ,@(if (= (length arg) 3) (list (third arg)) (values)))
- #+(or allegro lispworks (and mcl (not openmcl)))
+ #+(or allegro lispworks digitool)
(if (and (listp type) (listp (car type)))
(append (list name) type)
(list name type))
(push (list (first arg)
(list :reference-return (second arg))) processed)
(push (subseq arg 0 2) processed))
- finally (return processed)))
+ finally (return (nreverse processed))))
(defun preprocess-names (names)
(let ((fname (gensym)))
(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))
#+(or cmu scl sbcl)
`(%def-function ,names ,args
,@(if returning (list :returning returning) (values)))
- #+lispworks
- `(%def-function ,names ,(convert-lispworks-args args)
+ #+(and lispworks lispworks5)
+ (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))
+ `(%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)
- `(prog1
+ `(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)
+ ,@(mapcar #'(lambda (arg)
(list 'deref-pointer
(first arg)
(second arg))) out))))))
;; 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 sbcl scl allegro mcl cormanlisp) (declare (ignore module))
+ #+(or cmu sbcl scl allegro openmcl digitool cormanlisp) (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))))
-
;; todo: calling-convention :stdcall for cormanlisp
#+allegro
`(ff:def-foreign-call (,lisp-name ,foreign-name)
,@(if module (list :module module) (values))
:result-type ,result-type
:language :ansi-c
- #-macosx :calling-convention #-macosx :cdecl)
- #+(and mcl (not openmcl))
+ #+:win32 :calling-convention #+:win32 :cdecl)
+ #+digitool
`(eval-when (:compile-toplevel :load-toplevel :execute)
(ccl:define-entry-point (,lisp-name ,foreign-name)
,function-args