X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftarget-alieneval.lisp;h=d674b648d87ed46bc765191a7fc60d57ece38112;hb=6d3b9d5de8a28cd92e280f3451b60ce412260c19;hp=2b133cd7d3373543cbbec29f6fb849762afadf5a;hpb=f4820c2cd6eb6af8f21312e2e2ca19af42de4be6;p=sbcl.git

diff --git a/src/code/target-alieneval.lisp b/src/code/target-alieneval.lisp
index 2b133cd..d674b64 100644
--- a/src/code/target-alieneval.lisp
+++ b/src/code/target-alieneval.lisp
@@ -61,10 +61,6 @@
                                    ',alien-name
                                    ',alien-type))))))
 
-(defmacro def-alien-variable (&rest rest)
-  (deprecation-warning 'def-alien-variable 'define-alien-variable)
-  `(define-alien-variable ,@rest))
-
 ;;; Do the actual work of DEFINE-ALIEN-VARIABLE.
 (eval-when (:compile-toplevel :load-toplevel :execute)
   (defun %define-alien-variable (lisp-name alien-name type)
@@ -446,7 +442,8 @@ allocated using ``malloc'', so it can be passed to foreign functions which use
      (lambda ()
        (alien-funcall
         (extern-alien "free" (function (values) system-area-pointer))
-        alien-sap)))
+        alien-sap))
+     :dont-save t)
     alien))
 
 (defun note-local-alien-type (info alien)
@@ -463,6 +460,8 @@ allocated using ``malloc'', so it can be passed to foreign functions which use
 
 (define-setf-expander local-alien (&whole whole info alien)
   (let ((value (gensym))
+        (info-var (gensym))
+        (alloc-tmp (gensym))
         (info (if (and (consp info)
                        (eq (car info) 'quote))
                   (second info)
@@ -473,8 +472,10 @@ allocated using ``malloc'', so it can be passed to foreign functions which use
             (list value)
             `(if (%local-alien-forced-to-memory-p ',info)
                  (%set-local-alien ',info ,alien ,value)
-                 (setf ,alien
-                       (deport ,value ',(local-alien-info-type info))))
+                   (let* ((,info-var ',(local-alien-info-type info))
+                          (,alloc-tmp (deport-alloc ,value ,info-var)))
+                     (maybe-with-pinned-objects (,alloc-tmp) (,(local-alien-info-type info))
+                       (setf ,alien (deport ,alloc-tmp ,info-var)))))
             whole)))
 
 (defun %local-alien-forced-to-memory-p (info)
@@ -534,28 +535,38 @@ allocated using ``malloc'', so it can be passed to foreign functions which use
 
 ;;;; NATURALIZE, DEPORT, EXTRACT-ALIEN-VALUE, DEPOSIT-ALIEN-VALUE
 
+(defun coerce-to-interpreted-function (lambda-form)
+  (let (#!+sb-eval
+        (*evaluator-mode* :interpret))
+    (coerce lambda-form 'function)))
+
 (defun naturalize (alien type)
   (declare (type alien-type type))
-  (funcall (coerce (compute-naturalize-lambda type) 'function)
+  (funcall (coerce-to-interpreted-function (compute-naturalize-lambda type))
            alien type))
 
 (defun deport (value type)
   (declare (type alien-type type))
-  (funcall (coerce (compute-deport-lambda type) 'function)
+  (funcall (coerce-to-interpreted-function (compute-deport-lambda type))
+           value type))
+
+(defun deport-alloc (value type)
+  (declare (type alien-type type))
+  (funcall (coerce-to-interpreted-function (compute-deport-alloc-lambda type))
            value type))
 
 (defun extract-alien-value (sap offset type)
   (declare (type system-area-pointer sap)
            (type unsigned-byte offset)
            (type alien-type type))
-  (funcall (coerce (compute-extract-lambda type) 'function)
+  (funcall (coerce-to-interpreted-function (compute-extract-lambda type))
            sap offset type))
 
 (defun deposit-alien-value (sap offset type value)
   (declare (type system-area-pointer sap)
            (type unsigned-byte offset)
            (type alien-type type))
-  (funcall (coerce (compute-deposit-lambda type) 'function)
+  (funcall (coerce-to-interpreted-function (compute-deposit-lambda type))
            sap offset type value))
 
 ;;;; ALIEN-FUNCALL, DEFINE-ALIEN-ROUTINE
@@ -713,10 +724,6 @@ allocated using ``malloc'', so it can be passed to foreign functions which use
                       (values ,@temps ,@(results))))
                  (values (alien-funcall ,lisp-name ,@(alien-args))
                          ,@(results)))))))))
-
-(defmacro def-alien-routine (&rest rest)
-  (deprecation-warning 'def-alien-routine 'define-alien-routine)
-  `(define-alien-routine ,@rest))
 
 (defun alien-typep (object type)
   #!+sb-doc
@@ -778,6 +785,7 @@ ENTER-ALIEN-CALLBACK pulls the corresponsing trampoline out and calls it.")
                 (vector-push-extend
                  (alien-callback-lisp-trampoline wrapper function)
                  *alien-callback-trampolines*)
+                ;; Assembler-wrapper is static, so sap-taking is safe.
                 (let ((sap (vector-sap assembler-wrapper)))
                   (push (cons sap (make-callback-info :specifier specifier
                                                       :function function