0.8.16.6:

[sbcl.git] / src / code / target-alieneval.lisp

diff --git a/src/code/target-alieneval.lisp b/src/code/target-alieneval.lisp
index cb061ee..2f62bfc 100644 (file)
--- 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)
@@ -603,25 +607,25 @@
   way that the argument is passed.
 
   :IN
-       An :IN argument is simply passed by value. The value to be passed is
-       obtained from argument(s) to the interface function. No values are
-       returned for :In arguments. This is the default mode.
+        An :IN argument is simply passed by value. The value to be passed is
+        obtained from argument(s) to the interface function. No values are
+        returned for :In arguments. This is the default mode.
 
   :OUT
-       The specified argument type must be a pointer to a fixed sized object.
-       A pointer to a preallocated object is passed to the routine, and the
-       the object is accessed on return, with the value being returned from
-       the interface function. :OUT and :IN-OUT cannot be used with pointers
-       to arrays, records or functions.
+        The specified argument type must be a pointer to a fixed sized object.
+        A pointer to a preallocated object is passed to the routine, and the
+        the object is accessed on return, with the value being returned from
+        the interface function. :OUT and :IN-OUT cannot be used with pointers
+        to arrays, records or functions.
 
   :COPY
-       This is similar to :IN, except that the argument values are stored
+        This is similar to :IN, except that the argument values are stored
         on the stack, and a pointer to the object is passed instead of
-       the value itself.
+        the value itself.
 
   :IN-OUT
-       This is a combination of :OUT and :COPY. A pointer to the argument is
-        passed,        with the object being initialized from the supplied argument
+        This is a combination of :OUT and :COPY. A pointer to the argument is
+        passed, with the object being initialized from the supplied argument
         and the return value being determined by accessing the object on
         return."
   (multiple-value-bind (lisp-name alien-name)
@@ -678,7 +682,7 @@
         ;; alien values) both messy to do by hand and very important
         ;; for performance of later code which uses the return value.
         (declaim (ftype (function ,(lisp-arg-types)
-                                   (values ,@(lisp-result-types)))
+                                   (values ,@(lisp-result-types) &optional))
                          ,lisp-name))
         (defun ,lisp-name ,(lisp-args)
           ,@(docs)