;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
-;; $Id: interface.lisp,v 1.1 2006-04-25 20:36:05 espen Exp $
+;; $Id: interface.lisp,v 1.10 2008-12-10 02:40:18 espen Exp $
(in-package "GFFI")
(defun default-alien-fname (lisp-name)
(let* ((name (substitute #\_ #\- (string-downcase lisp-name)))
- (stripped-name
- (cond
- ((and
- (char= (char name 0) #\%)
- (string= "_p" name :start2 (- (length name) 2)))
- (subseq name 1 (- (length name) 2)))
- ((char= (char name 0) #\%)
- (subseq name 1))
- ((string= "_p" name :start2 (- (length name) 2))
- (subseq name 0 (- (length name) 2)))
- (name)))
+ (start (position-if-not #'(lambda (char) (char= char #\%)) name))
+ (end (if (string= "_p" name :start2 (- (length name) 2))
+ (- (length name) 2)
+ (length name)))
+ (stripped-name (subseq name start end))
(prefix (package-prefix *package*)))
(if (or (not prefix) (string= prefix ""))
stripped-name
#'string-capitalize
(cons prefix (split-string (symbol-name type-name) :delimiter #\-))))))
-(defun default-type-name (alien-name)
- (let ((parts
- (mapcar
- #'string-upcase
- (split-string-if alien-name #'upper-case-p))))
- (intern
- (concatenate-strings (rest parts) #\-)
- (find-prefix-package (first parts)))))
+(defun split-alien-name (alien-name)
+ (let ((parts (split-string-if alien-name #'upper-case-p)))
+ (do ((prefix (first parts) (concatenate 'string prefix (first rest)))
+ (rest (rest parts) (cdr rest)))
+ ((null rest)
+ (error "Couldn't split alien name '~A' to find a registered prefix"
+ alien-name))
+ (when (find-prefix-package prefix)
+ (return (values (string-upcase (concatenate-strings rest #\-))
+ (find-prefix-package prefix)))))))
+(defun default-type-name (alien-name)
+ (multiple-value-call #'intern (split-alien-name alien-name)))
(defun in-arg-p (style)
(find style '(:in :in/out :in/return :in-out :return)))
(let* ((lambda-list-supplied-p lambda-list)
(lambda-list (unless (equal lambda-list '(nil)) lambda-list))
- (aux-vars ())
+ (arg-types ())
+ (aux-bindings ())
(doc-string (when (stringp (first args)) (pop args)))
(parsed-args
(mapcar
#'(lambda (arg)
(destructuring-bind
- (expr type &optional (style :in) (out-type type)) arg
+ (expr type &optional (style :in) (out-type type))
+ (if (atom arg)
+ (list arg arg)
+ arg)
(cond
((find style '(:in-out :return))
(warn "Deprecated argument style: ~S" style))
(error "Bogus argument style: ~S" style)))
(when (and
(not lambda-list-supplied-p)
- (namep expr) (in-arg-p style))
- (push expr lambda-list))
+ (namep expr) (in-arg-p style)
+ (not (find expr lambda-list)))
+ (push expr lambda-list)
+ (push type arg-types))
(let ((aux (unless (or (not (in-arg-p style)) (namep expr))
(gensym))))
(when aux
- (push `(,aux ,expr) aux-vars))
+ (push (list aux expr) aux-bindings))
(list
(cond
((and (namep expr) (not (in-arg-p style))) expr)
- ((namep expr) (make-symbol (string expr)))
- ((gensym)))
+ ((namep expr)
+ #-clisp(make-symbol (string expr))
+ ;; The above used to work in CLISP, but I'm
+ ;; not sure exactly at which version it
+ ;; broke. The following could potentially
+ ;; cause variable capturing
+ #+clisp(intern (format nil "~A-~A" (string expr) (gensym))))
+ (#-clisp(gensym)
+ #+clisp(intern (string (gensym)))))
(or aux expr) type style out-type))))
args)))
(%defbinding c-name lisp-name
(if lambda-list-supplied-p lambda-list (nreverse lambda-list))
- aux-vars return-type doc-string parsed-args))))
+ (not lambda-list-supplied-p) (nreverse arg-types)
+ aux-bindings return-type doc-string parsed-args))))
#+(or cmu sbcl)
(:language :stdc))))
`(funcall
(load-time-value
- (ffi::foreign-library-function ,cname (ffi::foreign-library :default)
+ (ffi::foreign-library-function
+ ,cname (ffi::foreign-library :default) #?(clisp>= 2 40)nil
nil (ffi:parse-c-type ',c-function)))
,@fparams)))
;; TODO: check if in and out types (if different) translates to same
;; alien type
-(defun %defbinding (cname lisp-name lambda-list aux-vars return-type doc args)
+(defun %defbinding (cname lisp-name lambda-list declare-p arg-types aux-bindings return-type doc args)
(let ((out (loop
for (var expr type style out-type) in args
when (or (out-arg-p style) (return-arg-p style))
(alien-arg-wrapper type var expr style
(create-wrapper (rest args) body)))
body)))
- `(defun ,lisp-name ,lambda-list
+ `(progn
+ ,(when declare-p
+ `(declaim
+ (ftype
+ (function
+ ,(mapcar #'argument-type arg-types)
+ (values
+ ,@(when return-type (list (return-type return-type)))
+ ,@(loop
+ for (var expr type style out-type) in args
+ when (out-arg-p style)
+ collect (return-type out-type)
+ when (return-arg-p style)
+ collect (return-type type))))
+ ,lisp-name)))
+ (defun ,lisp-name ,lambda-list
,doc
- (let ,aux-vars
+ (let ,aux-bindings
,(if return-type
(create-wrapper args `(values ,fcall ,@out))
- (create-wrapper args `(progn ,fcall (values ,@out)))))))))
+ (create-wrapper args `(progn ,fcall (values ,@out))))))))))
(system-area-pointer address))))))
#+clisp
(ffi::foreign-library-function name
- (ffi::foreign-library :default)
+ (ffi::foreign-library :default) #?(clisp>= 2 40)nil
nil (ffi:parse-c-type c-function)))
(return-value-translator (from-alien-function return-type)))
(multiple-value-bind (arg-translators cleanup-funcs)
(let ((define-callback
#+cmu'alien:def-callback
#+(and sbcl alien-callbacks)'sb-alien::define-alien-callback
- #+(and sbcl (not alien-callbacks))'sb-alien:define-alien-function))
+ #+(and sbcl (not alien-callbacks))'sb-alien:define-alien-function)
+ (args (mapcar #'(lambda (arg)
+ (if (atom arg) (list arg arg) arg))
+ args)))
`(progn
#+cmu(defparameter ,name nil)
(,define-callback ,name
;;; translated according to RETTYPE. Obtain a pointer that can be
;;; passed to C code for this callback by calling %CALLBACK.
(defmacro define-callback (name return-type args &body body)
- (let ((arg-names (mapcar #'first args))
- (arg-types (mapcar #'second args)))
+ (let* ((args (mapcar #'(lambda (arg)
+ (if (atom arg) (list arg arg) arg))
+ args))
+ (arg-names (mapcar #'first args))
+ (arg-types (mapcar #'second args)))
`(progn
(defvar ,name ',name)
(register-callback ',name
;;;; Type expansion
+;; A hack to make the TYPE-EXPAND code for SBCL work.
+#?+(pkg-config:sbcl>= 1 0 35 15)
+(sb-ext:without-package-locks
+ (setf (symbol-function 'sb-kernel::type-expand)
+ (lambda (form) (typexpand form))))
+
(defun type-expand-1 (form)
#+(or cmu sbcl)
(let ((def (cond ((symbolp form)
(error "~A can not be expanded to ~A" form type))))))
(expand form)))
+(defun type-equal-p (type1 type2)
+ (and (subtypep type1 type2) (subtypep type2 type1)))
;;;; Type methods
+(defun find-type-method (name type-spec &optional (error-p t))
+ (let ((type-methods (get name 'type-methods))
+ (specifier (if (atom type-spec)
+ type-spec
+ (first type-spec))))
+ (or
+ (gethash specifier type-methods)
+ (when error-p
+ (error
+ "No explicit type method for ~A when call width type specifier ~A found"
+ name type-spec)))))
+
(defun find-next-type-method (name type-spec &optional (error-p t))
(let ((type-methods (get name 'type-methods)))
(labels ((search-method-in-cpl-order (classes)
(lookup-method (type-spec)
(if (and (symbolp type-spec) (find-class type-spec nil))
(let ((class (find-class type-spec)))
- #+clisp
+ #?(or (sbcl>= 0 9 15) (featurep :clisp))
(unless (class-finalized-p class)
(finalize-inheritance class))
(search-method-in-cpl-order
;; This is to handle unexpandable types whichs doesn't name a
;; class. It may cause infinite loops with illegal
;; call-next-method calls
- (unless (and (symbolp type-spec) (find-class type-spec nil))
+ (unless (or
+ (null type-spec)
+ (and (symbolp type-spec) (find-class type-spec nil)))
(search-nodes (get name 'built-in-type-hierarchy)))
(when error-p
(error "No next type method ~A for type specifier ~A"
name type-spec))))))
(defun find-applicable-type-method (name type-spec &optional (error-p t))
- (let ((type-methods (get name 'type-methods))
- (specifier (if (atom type-spec)
- type-spec
- (first type-spec))))
- (or
- (gethash specifier type-methods)
- (find-next-type-method name type-spec nil)
- (when error-p
- (error
- "No applicable type method for ~A when call width type specifier ~A"
- name type-spec)))))
+ (or
+ (find-type-method name type-spec nil)
+ (find-next-type-method name type-spec nil)
+ (when error-p
+ (error
+ "No applicable type method for ~A when call width type specifier ~A"
+ name type-spec))))
+
(defun insert-type-in-hierarchy (specifier function nodes)
(cond
~mdw / clg / blobdiff