0.pre7.20:

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

diff --git a/src/code/target-alieneval.lisp b/src/code/target-alieneval.lisp
index 8665ecf..c935165 100644 (file)
--- a/src/code/target-alieneval.lisp
+++ b/src/code/target-alieneval.lisp
@@ -12,8 +12,7 @@
 
 (in-package "SB!ALIEN")
 
-(file-comment
-  "$Header$")
+(/show0 "target-alieneval.lisp 15")
 \f
 ;;;; alien variables
 
@@ -98,12 +97,16 @@
      :EXTERN
        No alien is allocated, but VAR is established as a local name for
        the external alien given by EXTERNAL-NAME."
+  (/show "entering WITH-ALIEN" bindings)
   (with-auxiliary-alien-types env
     (dolist (binding (reverse bindings))
+      (/show binding)
       (destructuring-bind
          (symbol type &optional (opt1 nil opt1p) (opt2 nil opt2p))
          binding
+       (/show symbol type opt1 opt2)
        (let ((alien-type (parse-alien-type type env)))
+         (/show alien-type)
          (multiple-value-bind (allocation initial-value)
              (if opt2p
                  (values opt1 opt2)
@@ -114,6 +117,7 @@
                     (values opt1 nil))
                    (t
                     (values :local opt1))))
+           (/show allocation initial-value)
            (setf body
                  (ecase allocation
                    #+nil
@@ -129,6 +133,7 @@
                                `((setq ,symbol ,initial-value)))
                            ,@body)))))
                    (:extern
+                    (/show ":EXTERN case")
                     (let ((info (make-heap-alien-info
                                  :type alien-type
                                  :sap-form `(foreign-symbol-address
@@ -137,9 +142,11 @@
                          ((,symbol (%heap-alien ',info)))
                          ,@body))))
                    (:local
+                    (/show ":LOCAL case")
                     (let ((var (gensym))
                           (initval (if initial-value (gensym)))
                           (info (make-local-alien-info :type alien-type)))
+                      (/show var initval info)
                       `((let ((,var (make-local-alien ',info))
                               ,@(when initial-value
                                   `((,initval ,initial-value))))
@@ -151,7 +158,9 @@
                                    `((setq ,symbol ,initval)))
                                ,@body)
                               (dispose-local-alien ',info ,var))))))))))))
+    (/show "revised" body)
     (verify-local-auxiliaries-okay)
+    (/show "back from VERIFY-LOCAL-AUXILIARIES-OK, returning")
     `(symbol-macrolet ((&auxiliary-type-definitions&
                        ,(append *new-auxiliary-types*
                                 (auxiliary-type-definitions env))))
@@ -159,8 +168,6 @@
 \f
 ;;;; runtime C values that don't correspond directly to Lisp types
 
-;;; ALIEN-VALUE
-;;;
 ;;; Note: The DEFSTRUCT for ALIEN-VALUE lives in a separate file
 ;;; 'cause it has to be real early in the cold-load order.
 #!-sb-fluid (declaim (freeze-type alien-value))
@@ -245,15 +252,16 @@
 ;;; system area pointer to it.
 #!-sb-fluid (declaim (inline %make-alien))
 (defun %make-alien (bits)
-  (declare (type sb!kernel:index bits) (optimize-interface (safety 2)))
-  (alien-funcall (extern-alien "malloc" (function system-area-pointer unsigned))
-                (ash (the sb!kernel:index (+ bits 7)) -3)))
+  (declare (type index bits))
+  (alien-funcall (extern-alien "malloc"
+                              (function system-area-pointer unsigned))
+                (ash (the index (+ bits 7)) -3)))
 
 #!-sb-fluid (declaim (inline free-alien))
 (defun free-alien (alien)
   #!+sb-doc
   "Dispose of the storage pointed to by ALIEN. ALIEN must have been allocated
-   by MAKE-ALIEN or ``malloc''."
+   by MAKE-ALIEN or malloc(3)."
   (alien-funcall (extern-alien "free" (function (values) system-area-pointer))
                 (alien-sap alien))
   nil)
@@ -266,7 +274,7 @@
           (type symbol slot))
   (or (find slot (alien-record-type-fields type)
            :key #'alien-record-field-name)
-      (error "There is no slot named ~S in ~S" slot type)))
+      (error "There is no slot named ~S in ~S." slot type)))
 
 ;;; Extract the value from the named slot from the record ALIEN. If
 ;;; ALIEN is actually a pointer, then DEREF it first.
@@ -322,8 +330,9 @@
 \f
 ;;;; the DEREF operator
 
-;;; Does most of the work of the different DEREF methods. Returns two values:
-;;; the type and the offset (in bits) of the refered to alien.
+;;; This function does most of the work of the different DEREF
+;;; methods. It returns two values: the type and the offset (in bits)
+;;; of the referred-to alien.
 (defun deref-guts (alien indices)
   (declare (type alien-value alien)
           (type list indices)
@@ -451,12 +460,10 @@
     (values nil
            nil
            (list value)
-           (if sb!c:*converting-for-interpreter*
-               `(%set-local-alien ',info ,alien ,value)
-               `(if (%local-alien-forced-to-memory-p ',info)
-                    (%set-local-alien ',info ,alien ,value)
-                    (setf ,alien
-                          (deport ,value ',(local-alien-info-type info)))))
+           `(if (%local-alien-forced-to-memory-p ',info)
+                (%set-local-alien ',info ,alien ,value)
+                (setf ,alien
+                      (deport ,value ',(local-alien-info-type info))))
            whole)))
 
 (defun %local-alien-forced-to-memory-p (info)
@@ -484,7 +491,7 @@
 (defun %cast (alien target-type)
   (declare (type alien-value alien)
           (type alien-type target-type)
-          (optimize-interface (safety 2))
+          (optimize (safety 2))
           (optimize (inhibit-warnings 3)))
   (if (or (alien-pointer-type-p target-type)
          (alien-array-type-p target-type)
@@ -562,7 +569,7 @@
         (unless stub
           (setf stub
                 (let ((fun (gensym))
-                      (parms (loop repeat (length args) collect (gensym))))
+                      (parms (make-gensym-list (length args))))
                   (compile nil
                            `(lambda (,fun ,@parms)
                               (declare (type (alien ,type) ,fun))
@@ -643,10 +650,9 @@
                          :extern ,alien-name)
              ,@(alien-vars))
             ,(if (alien-values-type-p result-type)
-                 (let ((temps (loop
-                                repeat (length (alien-values-type-values
-                                                result-type))
-                                collect (gensym))))
+                 (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))))