X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fhost-alieneval.lisp;h=5e1f3e5c041779335612f09f7229b4095395d8ca;hb=2c6b90e36a7c0377cd79625eb6c94d580f98cb93;hp=adb9eff281c10bd1a4199504de72b2e4d4b681e8;hpb=77360ee4a1f94c41b807be7ad0e8687199fceef1;p=sbcl.git

diff --git a/src/code/host-alieneval.lisp b/src/code/host-alieneval.lisp
index adb9eff..5e1f3e5 100644
--- 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")
 
 ;;;; 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)
@@ -173,14 +167,14 @@
 ;;; we no longer need to make a distinction between this and
 ;;; %PARSE-ALIEN-TYPE.
 (defun parse-alien-type (type env)
-  (declare (type sb!kernel:lexenv 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 sb!kernel:lexenv env))
+  (declare (type (or sb!kernel:lexenv null) env))
   (if (consp type)
       (let ((translator (info :alien-type :translator (car type))))
 	(unless translator
@@ -199,7 +193,7 @@
 	 (error "unknown alien type: ~S" type)))))
 
 (defun auxiliary-alien-type (kind name env)
-  (declare (type sb!kernel:lexenv env))
+  (declare (type (or sb!kernel:lexenv null) env))
   (flet ((aux-defn-matches (x)
 	   (and (eq (first x) kind) (eq (second x) name))))
     (let ((in-auxiliaries
@@ -216,7 +210,7 @@
 	     (info :alien-type :enum name)))))))
 
 (defun (setf auxiliary-alien-type) (new-value kind name env)
-  (declare (type sb!kernel:lexenv env))
+  (declare (type (or sb!kernel:lexenv null) env))
   (flet ((aux-defn-matches (x)
 	   (and (eq (first x) kind) (eq (second x) name))))
     (when (find-if #'aux-defn-matches *new-auxiliary-types*)
@@ -930,7 +924,7 @@
   (parse-alien-record-type :union name fields env))
 
 (defun parse-alien-record-type (kind name fields env)
-  (declare (type sb!kernel:lexenv env))
+  (declare (type (or sb!kernel:lexenv null) env))
   (cond (fields
 	 (let* ((old (and name (auxiliary-alien-type kind name env)))
 		(old-fields (and old (alien-record-type-fields old))))
@@ -1183,3 +1177,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")