X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftarget-alieneval.lisp;h=fec2359fbe4a35d3aab8d3671806cb17f8d9986e;hb=37200d73dfca16507809778574092cfb998711d5;hp=d674b648d87ed46bc765191a7fc60d57ece38112;hpb=7098f5fa693c5d5e57742cc1e91c0a04eba87dbb;p=sbcl.git

diff --git a/src/code/target-alieneval.lisp b/src/code/target-alieneval.lisp
index d674b64..fec2359 100644
--- a/src/code/target-alieneval.lisp
+++ b/src/code/target-alieneval.lisp
@@ -66,7 +66,6 @@
   (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)
     (setf (info :variable :alien-info lisp-name)
           (make-heap-alien-info :type type
                                 :sap-form `(foreign-symbol-sap ',alien-name t)))))
@@ -91,19 +90,20 @@
    ALLOCATION should be one of:
      :LOCAL (the default)
        The alien is allocated on the stack, and has dynamic extent.
-     :STATIC
-       The alien is allocated on the heap, and has infinite extent. The alien
-       is allocated at load time, so the same piece of memory is used each time
-       this form executes.
      :EXTERN
        No alien is allocated, but VAR is established as a local name for
        the external alien given by EXTERNAL-NAME."
+  ;; FIXME:
+  ;;      :STATIC
+  ;;        The alien is allocated on the heap, and has infinite extent. The alien
+  ;;        is allocated at load time, so the same piece of memory is used each time
+  ;;        this form executes.
   (/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))
+            (symbol type &optional (opt1 nil opt1p) (opt2 nil opt2p))
           binding
         (/show symbol type opt1 opt2)
         (let* ((alien-type (parse-alien-type type env))
@@ -130,10 +130,10 @@
                        `((let ((,sap (load-time-value (%make-alien ...))))
                            (declare (type system-area-pointer ,sap))
                            (symbol-macrolet
-                            ((,symbol (sap-alien ,sap ,type)))
-                            ,@(when initial-value
-                                `((setq ,symbol ,initial-value)))
-                            ,@body)))))
+                               ((,symbol (sap-alien ,sap ,type)))
+                             ,@(when initial-value
+                                 `((setq ,symbol ,initial-value)))
+                             ,@body)))))
                     (:extern
                      (/show0 ":EXTERN case")
                      (let ((info (make-heap-alien-info
@@ -141,31 +141,49 @@
                                   :sap-form `(foreign-symbol-sap ',initial-value
                                                                  ,datap))))
                        `((symbol-macrolet
-                          ((,symbol (%heap-alien ',info)))
-                          ,@body))))
+                             ((,symbol (%heap-alien ',info)))
+                           ,@body))))
                     (:local
                      (/show0 ":LOCAL case")
-                     (let ((var (gensym))
-                           (initval (if initial-value (gensym)))
-                           (info (make-local-alien-info :type alien-type)))
+                     (let* ((var (gensym))
+                            (initval (if initial-value (gensym)))
+                            (info (make-local-alien-info :type alien-type))
+                            (inner-body
+                             `((note-local-alien-type ',info ,var)
+                               (symbol-macrolet ((,symbol (local-alien ',info ,var)))
+                                 ,@(when initial-value
+                                     `((setq ,symbol ,initval)))
+                                 ,@body)))
+                            (body-forms
+                             (if initial-value
+                                 `((let ((,initval ,initial-value))
+                                     ,@inner-body))
+                                 inner-body)))
                        (/show var initval info)
-                       `((let ((,var (make-local-alien ',info))
-                               ,@(when initial-value
-                                   `((,initval ,initial-value))))
-                           (note-local-alien-type ',info ,var)
-                           (multiple-value-prog1
-                               (symbol-macrolet
-                                ((,symbol (local-alien ',info ,var)))
-                                ,@(when initial-value
-                                    `((setq ,symbol ,initval)))
-                                ,@body)
-                               (dispose-local-alien ',info ,var))))))))))))
+                       #!+(or x86 x86-64)
+                       `((let ((,var (make-local-alien ',info)))
+                           ,@body-forms))
+                       ;; FIXME: This version is less efficient then it needs to be, since
+                       ;; it could just save and restore the number-stack pointer once,
+                       ;; instead of doing multiple decrements if there are multiple bindings.
+                       #!-(or x86 x86-64)
+                       `((let (,var)
+                           (unwind-protect
+                               (progn
+                                 (setf ,var (make-local-alien ',info))
+                                 (let ((,var ,var))
+                                   ,@body-forms))
+                             (dispose-local-alien ',info ,var))))))))))))
     (/show "revised" body)
     (verify-local-auxiliaries-okay)
     (/show0 "back from VERIFY-LOCAL-AUXILIARIES-OK, returning")
     `(symbol-macrolet ((&auxiliary-type-definitions&
                         ,(append *new-auxiliary-types*
                                  (auxiliary-type-definitions env))))
+       #!+(or x86 x86-64)
+       (let ((sb!vm::*alien-stack* sb!vm::*alien-stack*))
+         ,@body)
+       #!-(or x86 x86-64)
        ,@body)))
 
 ;;;; runtime C values that don't correspond directly to Lisp types