0.8.15.15: Removing non-ANSI FTYPE proclaims and TYPE declarares from PCL

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

diff --git a/src/code/target-alieneval.lisp b/src/code/target-alieneval.lisp
index cb061ee..a2e8324 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)
@@ -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)