X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftarget-alieneval.lisp;h=fe4aff5e366ca94201a467242aafa0edf760d8e4;hb=f409f90c5e8c4c87ed9fa6efdc0e5c1952d94602;hp=e8de84dac42d15104b43da215f841ea2bc45ec01;hpb=50305b602c3953440af716137a56f50cd204375d;p=sbcl.git diff --git a/src/code/target-alieneval.lisp b/src/code/target-alieneval.lisp index e8de84d..fe4aff5 100644 --- a/src/code/target-alieneval.lisp +++ b/src/code/target-alieneval.lisp @@ -45,7 +45,7 @@ (error "badly formed alien name")) (values (cadr name) (car name)))))) -(defmacro def-alien-variable (name type &environment env) +(defmacro define-alien-variable (name type &environment env) #!+sb-doc "Define NAME as an external alien variable of type TYPE. NAME should be a list of a string holding the alien name and a symbol to use as the Lisp @@ -57,13 +57,17 @@ `(eval-when (:compile-toplevel :load-toplevel :execute) ,@(when *new-auxiliary-types* `((%def-auxiliary-alien-types ',*new-auxiliary-types*))) - (%def-alien-variable ',lisp-name - ',alien-name - ',alien-type)))))) + (%define-alien-variable ',lisp-name + ',alien-name + ',alien-type)))))) -;;; Do the actual work of DEF-ALIEN-VARIABLE. +(defmacro def-alien-variable (&rest rest) + (deprecation-warning 'def-alien-variable 'define-alien-variable) + `(define-alien-variable ,@rest)) + +;;; Do the actual work of DEFINE-ALIEN-VARIABLE. (eval-when (:compile-toplevel :load-toplevel :execute) - (defun %def-alien-variable (lisp-name alien-name type) + (defun %define-alien-variable (lisp-name alien-name type) (setf (info :variable :kind lisp-name) :alien) (setf (info :variable :where-from lisp-name) :defined) (clear-info :variable :constant-value lisp-name) @@ -191,7 +195,7 @@ (let ((alien-type (parse-alien-type type env))) (if (eq (compute-alien-rep-type alien-type) 'system-area-pointer) `(%sap-alien ,sap ',alien-type) - (error "cannot make aliens of type ~S out of SAPs" type)))) + (error "cannot make an alien of type ~S out of a SAP" type)))) (defun %sap-alien (sap type) (declare (type system-area-pointer sap) @@ -341,7 +345,7 @@ (etypecase type (alien-pointer-type (when (cdr indices) - (error "too many indices when derefing ~S: ~D" + (error "too many indices when DEREF'ing ~S: ~W" type (length indices))) (let ((element-type (alien-pointer-type-to type))) @@ -353,7 +357,7 @@ 0)))) (alien-array-type (unless (= (length indices) (length (alien-array-type-dimensions type))) - (error "incorrect number of indices when derefing ~S: ~D" + (error "incorrect number of indices when DEREF'ing ~S: ~W" type (length indices))) (labels ((frob (dims indices offset) (if (null dims) @@ -432,10 +436,10 @@ (alien-sap (alien-sap alien))) (finalize alien - #'(lambda () - (alien-funcall - (extern-alien "free" (function (values) system-area-pointer)) - alien-sap))) + (lambda () + (alien-funcall + (extern-alien "free" (function (values) system-area-pointer)) + alien-sap))) alien)) (defun note-local-alien-type (info alien) @@ -547,7 +551,7 @@ (funcall (coerce (compute-deposit-lambda type) 'function) sap offset type value)) -;;;; ALIEN-FUNCALL, DEF-ALIEN-ROUTINE +;;;; ALIEN-FUNCALL, DEFINE-ALIEN-ROUTINE (defun alien-funcall (alien &rest args) #!+sb-doc @@ -561,7 +565,7 @@ (alien-fun-type (unless (= (length (alien-fun-type-arg-types type)) (length args)) - (error "wrong number of arguments for ~S~%expected ~D, got ~D" + (error "wrong number of arguments for ~S~%expected ~W, got ~W" type (length (alien-fun-type-arg-types type)) (length args))) @@ -579,9 +583,11 @@ (t (error "~S is not an alien function." alien))))) -(defmacro def-alien-routine (name result-type &rest args &environment lexenv) +(defmacro define-alien-routine (name result-type + &rest args + &environment lexenv) #!+sb-doc - "DEF-ALIEN-ROUTINE Name Result-Type {(Arg-Name Arg-Type [Style])}* + "DEFINE-ALIEN-ROUTINE Name Result-Type {(Arg-Name Arg-Type [Style])}* Define a foreign interface function for the routine with the specified NAME. Also automatically DECLAIM the FTYPE of the defined function. @@ -620,7 +626,17 @@ return." (multiple-value-bind (lisp-name alien-name) (pick-lisp-and-alien-names name) - (collect ((docs) (lisp-args) (arg-types) (alien-vars) + (collect ((docs) (lisp-args) (lisp-arg-types) + (lisp-result-types + (cond ((eql result-type 'void) + ;; What values does a function return, if it + ;; returns no values? Exactly one - NIL. -- APD, + ;; 2003-03-02 + (list 'null)) + (t + ;; FIXME: Check for VALUES. + (list `(alien ,result-type))))) + (arg-types) (alien-vars) (alien-args) (results)) (dolist (arg args) (if (stringp arg) @@ -628,50 +644,71 @@ (destructuring-bind (name type &optional (style :in)) arg (unless (member style '(:in :copy :out :in-out)) (error "bogus argument style ~S in ~S" style arg)) - (unless (eq style :out) - (lisp-args name)) (when (and (member style '(:out :in-out)) (typep (parse-alien-type type lexenv) 'alien-pointer-type)) (error "can't use :OUT or :IN-OUT on pointer-like type:~% ~S" type)) - (cond ((eq style :in) - (arg-types type) - (alien-args name)) - (t - (arg-types `(* ,type)) - (if (eq style :out) - (alien-vars `(,name ,type)) - (alien-vars `(,name ,type ,name))) - (alien-args `(addr ,name)))) + (let (arg-type) + (cond ((eq style :in) + (setq arg-type type) + (alien-args name)) + (t + (setq arg-type `(* ,type)) + (if (eq style :out) + (alien-vars `(,name ,type)) + (alien-vars `(,name ,type ,name))) + (alien-args `(addr ,name)))) + (arg-types arg-type) + (unless (eq style :out) + (lisp-args name) + (lisp-arg-types t + ;; FIXME: It should be something + ;; like `(ALIEN ,ARG-TYPE), except + ;; for we also accept SAPs where + ;; pointers are required. + ))) (when (or (eq style :out) (eq style :in-out)) - (results name))))) + (results name) + (lisp-result-types `(alien ,type)))))) `(progn - ;; The theory behind this automatic DECLAIM is that (1) if ;; you're calling C, static typing is what you're doing ;; anyway, and (2) such a declamation can be (especially for ;; alien values) both messy to do by hand and very important ;; for performance of later code which uses the return value. - (declaim (ftype (function (mapcar (constantly t) ',args) - (alien ,result-type)) - ,lisp-name)) - + (declaim (ftype (function ,(lisp-arg-types) + (values ,@(lisp-result-types) &optional)) + ,lisp-name)) (defun ,lisp-name ,(lisp-args) ,@(docs) (with-alien ((,lisp-name (function ,result-type ,@(arg-types)) :extern ,alien-name) ,@(alien-vars)) - ,(if (alien-values-type-p result-type) + #-nil + (values (alien-funcall ,lisp-name ,@(alien-args)) + ,@(results)) + #+nil + (if (alien-values-type-p result-type) + ;; FIXME: RESULT-TYPE is a type specifier, so it + ;; cannot be of type ALIEN-VALUES-TYPE. Also note, + ;; that if RESULT-TYPE is VOID, then this code + ;; disagrees with the computation of the return type + ;; and with all usages of this macro. -- APD, + ;; 2002-03-02 (let ((temps (make-gensym-list (length (alien-values-type-values result-type))))) `(multiple-value-bind ,temps (alien-funcall ,lisp-name ,@(alien-args)) (values ,@temps ,@(results)))) - `(values (alien-funcall ,lisp-name ,@(alien-args)) - ,@(results))))))))) + (values (alien-funcall ,lisp-name ,@(alien-args)) + ,@(results))))))))) + +(defmacro def-alien-routine (&rest rest) + (deprecation-warning 'def-alien-routine 'define-alien-routine) + `(define-alien-routine ,@rest)) (defun alien-typep (object type) #!+sb-doc