X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftarget-alieneval.lisp;h=a2e8324871f7a2d54b46ce75e4cefbffd8e8c76d;hb=791e9d15abba835457b308121668a0ce75386a03;hp=3150c14febe167d5d5b2c22f9d59450de96427b3;hpb=e0814eee6f6dea52db010b45a330100f2fe65832;p=sbcl.git diff --git a/src/code/target-alieneval.lisp b/src/code/target-alieneval.lisp index 3150c14..a2e8324 100644 --- a/src/code/target-alieneval.lisp +++ b/src/code/target-alieneval.lisp @@ -73,19 +73,20 @@ (clear-info :variable :constant-value lisp-name) (setf (info :variable :alien-info lisp-name) (make-heap-alien-info :type type - :sap-form `(foreign-symbol-address - ',alien-name))))) + :sap-form `(foreign-symbol-address ',alien-name t))))) (defmacro extern-alien (name type &environment env) #!+sb-doc "Access the alien variable named NAME, assuming it is of type TYPE. This is SETFable." - (let ((alien-name (etypecase name - (symbol (guess-alien-name-from-lisp-name name)) - (string name)))) + (let* ((alien-name (etypecase name + (symbol (guess-alien-name-from-lisp-name name)) + (string name))) + (alien-type (parse-alien-type type env)) + (datap (not (alien-fun-type-p alien-type)))) `(%heap-alien ',(make-heap-alien-info - :type (parse-alien-type type env) - :sap-form `(foreign-symbol-address ',alien-name))))) + :type alien-type + :sap-form `(foreign-symbol-address ',alien-name ,datap))))) (defmacro with-alien (bindings &body body &environment env) #!+sb-doc @@ -109,7 +110,8 @@ (symbol type &optional (opt1 nil opt1p) (opt2 nil opt2p)) binding (/show symbol type opt1 opt2) - (let ((alien-type (parse-alien-type type env))) + (let* ((alien-type (parse-alien-type type env)) + (datap (not (alien-fun-type-p alien-type)))) (/show alien-type) (multiple-value-bind (allocation initial-value) (if opt2p @@ -137,16 +139,17 @@ `((setq ,symbol ,initial-value))) ,@body))))) (:extern - (/show ":EXTERN case") + (/show0 ":EXTERN case") (let ((info (make-heap-alien-info :type alien-type :sap-form `(foreign-symbol-address - ',initial-value)))) + ',initial-value + ,datap)))) `((symbol-macrolet ((,symbol (%heap-alien ',info))) ,@body)))) (:local - (/show ":LOCAL case") + (/show0 ":LOCAL case") (let ((var (gensym)) (initval (if initial-value (gensym))) (info (make-local-alien-info :type alien-type))) @@ -164,7 +167,7 @@ (dispose-local-alien ',info ,var)))))))))))) (/show "revised" body) (verify-local-auxiliaries-okay) - (/show "back from VERIFY-LOCAL-AUXILIARIES-OK, returning") + (/show0 "back from VERIFY-LOCAL-AUXILIARIES-OK, returning") `(symbol-macrolet ((&auxiliary-type-definitions& ,(append *new-auxiliary-types* (auxiliary-type-definitions env)))) @@ -178,9 +181,10 @@ (def!method print-object ((value alien-value) stream) (print-unreadable-object (value stream) (format stream - "~S :SAP #X~8,'0X" + "~S ~S #X~8,'0X ~S ~S" 'alien-value - (sap-int (alien-value-sap value))))) + :sap (sap-int (alien-value-sap value)) + :type (unparse-alien-type (alien-value-type value))))) #!-sb-fluid (declaim (inline null-alien)) (defun null-alien (x) @@ -195,7 +199,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) @@ -626,7 +630,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) @@ -634,50 +648,67 @@ (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)