0.8alpha.0.13:

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

diff --git a/src/code/host-alieneval.lisp b/src/code/host-alieneval.lisp
index 0a263e1..413beba 100644 (file)
--- a/src/code/host-alieneval.lisp
+++ b/src/code/host-alieneval.lisp
@@ -30,7 +30,7 @@
 \f
 ;;;; ALIEN-TYPE-INFO stuff
 
-(eval-when (:compile-toplevel :execute :load-toplevel)
+(eval-when (#-sb-xc :compile-toplevel :execute :load-toplevel)
 
 (defstruct (alien-type-class (:copier nil))
   (name nil :type symbol)
@@ -115,7 +115,9 @@
                               ,@(mapcar (lambda (x)
                                           (if (atom x) x (car x)))
                                         slots)
-                              ,@include-args)))
+                              ,@include-args
+                              ;; KLUDGE
+                              &aux (alignment (or alignment (guess-alignment bits))))))
           ,@slots)))))
 
 (def!macro define-alien-type-method ((class method) lambda-list &rest body)
@@ -145,7 +147,7 @@
 ;;; COMPILER-LET is no longer supported by ANSI or SBCL. Instead, we
 ;;; follow the suggestion in CLTL2 of using SYMBOL-MACROLET to achieve
 ;;; a similar effect.
-(eval-when (:compile-toplevel :load-toplevel :execute)
+(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
   (defun auxiliary-type-definitions (env)
     (multiple-value-bind (result expanded-p)
        (sb!xc:macroexpand '&auxiliary-type-definitions& env)
@@ -243,22 +245,21 @@
 ;;;; alien type defining stuff
 
 (def!macro define-alien-type-translator (name lambda-list &body body)
-  (let ((whole (gensym "WHOLE"))
-       (env (gensym "ENV"))
-       (defun-name (symbolicate "ALIEN-" name "-TYPE-TRANSLATOR")))
-    (multiple-value-bind (body decls docs)
-       (sb!kernel:parse-defmacro lambda-list whole body name
-                                 'define-alien-type-translator
-                                 :environment env)
-      `(eval-when (:compile-toplevel :load-toplevel :execute)
-        (defun ,defun-name (,whole ,env)
-          (declare (ignorable ,env))
-          ,@decls
-          (block ,name
-            ,body))
-        (%define-alien-type-translator ',name #',defun-name ,docs)))))
-
-(eval-when (:compile-toplevel :load-toplevel :execute)
+  (with-unique-names (whole env)
+    (let ((defun-name (symbolicate "ALIEN-" name "-TYPE-TRANSLATOR")))
+      (multiple-value-bind (body decls docs)
+         (sb!kernel:parse-defmacro lambda-list whole body name
+                                   'define-alien-type-translator
+                                   :environment env)
+       `(eval-when (:compile-toplevel :load-toplevel :execute)
+          (defun ,defun-name (,whole ,env)
+            (declare (ignorable ,env))
+            ,@decls
+            (block ,name
+              ,body))
+          (%define-alien-type-translator ',name #',defun-name ,docs))))))
+
+(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
   (defun %define-alien-type-translator (name translator docs)
     (declare (ignore docs))
     (setf (info :alien-type :kind name) :primitive)
@@ -284,7 +285,7 @@
   (deprecation-warning 'def-alien-type 'define-alien-type)
   `(define-alien-type ,@rest))
 
-(eval-when (:compile-toplevel :load-toplevel :execute)
+(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
   (defun %def-auxiliary-alien-types (types)
     (dolist (info types)
       (destructuring-bind (kind name defn) info
@@ -322,10 +323,11 @@
 
 (def!struct (alien-type
             (:make-load-form-fun sb!kernel:just-dump-it-normally)
-            (:constructor make-alien-type (&key class bits alignment)))
+            (:constructor make-alien-type (&key class bits alignment
+                                           &aux (alignment (or alignment (guess-alignment bits))))))
   (class 'root :type symbol)
   (bits nil :type (or null unsigned-byte))
-  (alignment (guess-alignment bits) :type (or null unsigned-byte)))
+  (alignment nil :type (or null unsigned-byte)))
 (def!method print-object ((type alien-type) stream)
   (print-unreadable-object (type stream :type t)
     (prin1 (unparse-alien-type type) stream)))
@@ -596,10 +598,10 @@
 (define-alien-type-class (enum :include (integer (bits 32))
                               :include-args (signed))
   name         ; name of this enum (if any)
-  from         ; alist from keywords to integers.
-  to           ; alist or vector from integers to keywords.
-  kind         ; Kind of from mapping, :vector or :alist.
-  offset)      ; Offset to add to value for :vector from mapping.
+  from         ; alist from keywords to integers
+  to           ; alist or vector from integers to keywords
+  kind         ; kind of from mapping, :VECTOR or :ALIST
+  offset)      ; offset to add to value for :VECTOR from mapping
 
 (define-alien-type-translator enum (&whole
                                 type name
@@ -760,7 +762,7 @@
 
 #!+long-float
 (define-alien-type-class (long-float :include (float (bits #!+x86 96
-                                                           #!+sparc 128))
+                                                          #!+sparc 128))
                                     :include-args (type)))
 
 #!+long-float
@@ -1137,14 +1139,15 @@
 (def!struct (local-alien-info
             (:make-load-form-fun sb!kernel:just-dump-it-normally)
             (:constructor make-local-alien-info
-                          (&key type force-to-memory-p)))
+                          (&key type force-to-memory-p
+                           &aux (force-to-memory-p (or force-to-memory-p
+                                                       (alien-array-type-p type)
+                                                       (alien-record-type-p type))))))
   ;; the type of the local alien
   (type (missing-arg) :type alien-type)
   ;; Must this local alien be forced into memory? Using the ADDR macro
   ;; on a local alien will set this.
-  (force-to-memory-p (or (alien-array-type-p type)
-                        (alien-record-type-p type))
-                    :type (member t nil)))
+  (force-to-memory-p nil :type (member t nil)))
 (def!method print-object ((info local-alien-info) stream)
   (print-unreadable-object (info stream :type t)
     (format stream