1.0.45.15: make waitqueue printing prettier

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

diff --git a/src/code/target-alieneval.lisp b/src/code/target-alieneval.lisp
index 13143b8..2113489 100644 (file)
--- a/src/code/target-alieneval.lisp
+++ b/src/code/target-alieneval.lisp
@@ -145,8 +145,8 @@
                            ,@body))))
                     (:local
                      (/show0 ":LOCAL case")
-                     (let* ((var (gensym))
-                            (initval (if initial-value (gensym)))
+                     (let* ((var (sb!xc:gensym "VAR"))
+                            (initval (if initial-value (sb!xc:gensym "INITVAL")))
                             (info (make-local-alien-info :type alien-type))
                             (inner-body
                              `((note-local-alien-type ',info ,var)
@@ -180,10 +180,10 @@
     `(symbol-macrolet ((&auxiliary-type-definitions&
                         ,(append *new-auxiliary-types*
                                  (auxiliary-type-definitions env))))
-       #+(or x86 x86-64)
+       #!+(or x86 x86-64)
        (let ((sb!vm::*alien-stack* sb!vm::*alien-stack*))
          ,@body)
-       #-(or x86 x86-64)
+       #!-(or x86 x86-64)
        ,@body)))
 \f
 ;;;; runtime C values that don't correspond directly to Lisp types
@@ -608,7 +608,7 @@ allocated using ``malloc'', so it can be passed to foreign functions which use
        (let ((stub (alien-fun-type-stub type)))
          (unless stub
            (setf stub
-                 (let ((fun (gensym))
+                 (let ((fun (sb!xc:gensym "FUN"))
                        (parms (make-gensym-list (length args))))
                    (compile nil
                             `(lambda (,fun ,@parms)
@@ -723,25 +723,11 @@ allocated using ``malloc'', so it can be passed to foreign functions which use
             ((,lisp-name (function ,result-type ,@(arg-types))
                          :extern ,alien-name)
              ,@(alien-vars))
-             #-nil
-             (values (alien-funcall ,lisp-name ,@(alien-args))
-                     ,@(results))
-             #+nil
-             (if (alien-values-type-p result-type)
-                 ;; FIXME: RESULT-TYPE is a type specifier, so it
-                 ;; cannot be of type ALIEN-VALUES-TYPE. Also note,
-                 ;; that if RESULT-TYPE is VOID, then this code
-                 ;; disagrees with the computation of the return type
-                 ;; and with all usages of this macro. -- APD,
-                 ;; 2002-03-02
-                 (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))))
-                 (values (alien-funcall ,lisp-name ,@(alien-args))
-                         ,@(results)))))))))
+             ,@(if (eq 'void result-type)
+                   `((alien-funcall ,lisp-name ,@(alien-args))
+                     (values nil ,@(results)))
+                   `((values (alien-funcall ,lisp-name ,@(alien-args))
+                             ,@(results))))))))))
 \f
 (defun alien-typep (object type)
   #!+sb-doc
@@ -836,22 +822,31 @@ ENTER-ALIEN-CALLBACK pulls the corresponsing trampoline out and calls it.")
                             :local ,(alien-callback-accessor-form
                                      spec 'args-sap offset))
                  do (incf offset (alien-callback-argument-bytes spec env)))
-           ,(flet ((store (spec)
+           ,(flet ((store (spec real-type)
                           (if spec
                               `(setf (deref (sap-alien res-sap (* ,spec)))
-                                     (funcall function ,@arguments))
+                                     ,(if real-type
+                                          `(the ,real-type
+                                             (funcall function ,@arguments))
+                                          `(funcall function ,@arguments)))
                               `(funcall function ,@arguments))))
                   (cond ((alien-void-type-p result-type)
-                         (store nil))
+                         (store nil nil))
                         ((alien-integer-type-p result-type)
+                         ;; Integer types should be padded out to a full
+                         ;; register width, to comply with most ABI calling
+                         ;; conventions, but should be typechecked on the
+                         ;; declared type width, hence the following:
                          (if (alien-integer-type-signed result-type)
                              (store `(signed
-                                      ,(alien-type-word-aligned-bits result-type)))
+                                      ,(alien-type-word-aligned-bits result-type))
+                                    `(signed-byte ,(alien-type-bits result-type)))
                              (store
                               `(unsigned
-                                ,(alien-type-word-aligned-bits result-type)))))
+                                ,(alien-type-word-aligned-bits result-type))
+                              `(unsigned-byte ,(alien-type-bits result-type)))))
                         (t
-                         (store (unparse-alien-type result-type)))))))
+                         (store (unparse-alien-type result-type) nil))))))
        (values))))
 
 (defun invalid-alien-callback (&rest arguments)