0.pre7.49:

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

diff --git a/src/code/host-alieneval.lisp b/src/code/host-alieneval.lisp
index 2c7bb5c..f2ac852 100644 (file)
--- a/src/code/host-alieneval.lisp
+++ b/src/code/host-alieneval.lisp
@@ -11,6 +11,8 @@
 ;;;; files for more information.
 
 (in-package "SB!ALIEN")
+
+(/show0 "host-alieneval.lisp 15")
 \f
 ;;;; utility functions
 
@@ -30,7 +32,7 @@
 
 (eval-when (:compile-toplevel :execute :load-toplevel)
 
-(defstruct alien-type-class
+(defstruct (alien-type-class (:copier nil))
   (name nil :type symbol)
   (include nil :type (or null alien-type-class))
   (unparse nil :type (or null function))
@@ -84,8 +86,7 @@
 ;;; We define a keyword "BOA" constructor so that we can reference the
 ;;; slot names in init forms.
 (def!macro def-alien-type-class ((name &key include include-args) &rest slots)
-  (let ((defstruct-name
-        (intern (concatenate 'string "ALIEN-" (symbol-name name) "-TYPE"))))
+  (let ((defstruct-name (symbolicate "ALIEN-" name "-TYPE")))
     (multiple-value-bind (include include-defstruct overrides)
        (etypecase include
          (null
@@ -93,14 +94,12 @@
          (symbol
           (values
            include
-           (intern (concatenate 'string
-                                "ALIEN-" (symbol-name include) "-TYPE"))
+           (symbolicate "ALIEN-" include "-TYPE")
            nil))
          (list
           (values
            (car include)
-           (intern (concatenate 'string
-                                "ALIEN-" (symbol-name (car include)) "-TYPE"))
+           (symbolicate "ALIEN-" (car include) "-TYPE")
            (cdr include))))
       `(progn
         (eval-when (:compile-toplevel :load-toplevel :execute)
@@ -110,21 +109,16 @@
                                  (:class ',name)
                                  ,@overrides)
                        (:constructor
-                        ,(intern (concatenate 'string "MAKE-"
-                                              (string defstruct-name)))
+                        ,(symbolicate "MAKE-" defstruct-name)
                         (&key class bits alignment
-                              ,@(mapcar #'(lambda (x)
-                                            (if (atom x) x (car x)))
+                              ,@(mapcar (lambda (x)
+                                          (if (atom x) x (car x)))
                                         slots)
                               ,@include-args)))
           ,@slots)))))
 
 (def!macro def-alien-type-method ((class method) lambda-list &rest body)
-  (let ((defun-name (intern (concatenate 'string
-                                        (symbol-name class)
-                                        "-"
-                                        (symbol-name method)
-                                        "-METHOD"))))
+  (let ((defun-name (symbolicate class "-" method "-METHOD")))
     `(progn
        (defun ,defun-name ,lambda-list
         ,@body)
@@ -169,24 +163,16 @@
       ,(let ((*new-auxiliary-types* nil))
         ,@body)))
 
-;;; FIXME: Now that *NEW-AUXILIARY-TYPES* is born initialized to NIL,
-;;; we no longer need to make a distinction between this and
-;;; %PARSE-ALIEN-TYPE.
+;;; Parse TYPE as an alien type specifier and return the resultant
+;;; ALIEN-TYPE structure.
 (defun parse-alien-type (type env)
   (declare (type (or sb!kernel:lexenv null) env))
-  #!+sb-doc
-  "Parse the list structure TYPE as an alien type specifier and return
-   the resultant ALIEN-TYPE structure."
-  (%parse-alien-type type env))
-
-(defun %parse-alien-type (type env)
-  (declare (type (or sb!kernel:lexenv null) env))
   (if (consp type)
       (let ((translator (info :alien-type :translator (car type))))
        (unless translator
          (error "unknown alien type: ~S" type))
        (funcall translator type env))
-      (case (info :alien-type :kind type)
+      (ecase (info :alien-type :kind type)
        (:primitive
         (let ((translator (info :alien-type :translator type)))
           (unless translator
@@ -860,6 +846,7 @@
   (dimensions (required-argument) :type list))
 
 (def-alien-type-translator array (ele-type &rest dims &environment env)
+
   (when dims
     (unless (typep (first dims) '(or index null))
       (error "The first dimension is not a non-negative fixnum or NIL: ~S"
@@ -869,15 +856,15 @@
       (when loser
        (error "A dimension is not a non-negative fixnum: ~S" loser))))
        
-  (let ((type (parse-alien-type ele-type env)))
+  (let ((parsed-ele-type (parse-alien-type ele-type env)))
     (make-alien-array-type
-     :element-type type
+     :element-type parsed-ele-type
      :dimensions dims
-     :alignment (alien-type-alignment type)
-     :bits (if (and (alien-type-bits type)
+     :alignment (alien-type-alignment parsed-ele-type)
+     :bits (if (and (alien-type-bits parsed-ele-type)
                    (every #'integerp dims))
-              (* (align-offset (alien-type-bits type)
-                               (alien-type-alignment type))
+              (* (align-offset (alien-type-bits parsed-ele-type)
+                               (alien-type-alignment parsed-ele-type))
                  (reduce #'* dims))))))
 
 (def-alien-type-method (array :unparse) (type)
@@ -1154,7 +1141,7 @@
 \f
 ;;;; the ADDR macro
 
-(sb!kernel:defmacro-mundanely addr (expr &environment env)
+(defmacro-mundanely addr (expr &environment env)
   #!+sb-doc
   "Return an Alien pointer to the data addressed by Expr, which must be a call
    to SLOT or DEREF, or a reference to an Alien variable."
@@ -1183,3 +1170,5 @@
             (when (eq kind :alien)
               `(%heap-alien-addr ',(info :variable :alien-info form))))))
        (error "~S is not a valid L-value." form))))
+
+(/show0 "host-alieneval.lisp end of file")