X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fdefstruct.lisp;h=7b16ef27a73cf4a53a6df3327d81e4a5ea95666f;hb=bee53328c93be3433477821131ab805557476c8b;hp=ca7e4672c78c98a8b717a7ff01561625d4715b45;hpb=8fc5fda05f92d69c95b47e4ad7561d91dab18c3e;p=sbcl.git

diff --git a/src/code/defstruct.lisp b/src/code/defstruct.lisp
index ca7e467..7b16ef2 100644
--- a/src/code/defstruct.lisp
+++ b/src/code/defstruct.lisp
@@ -12,8 +12,7 @@
 
 (in-package "SB!KERNEL")
 
-(file-comment
-  "$Header$")
+(/show0 "code/defstruct.lisp 15")
 
 ;;;; getting LAYOUTs
 
@@ -55,15 +54,15 @@
   ;; documentation on the structure
   (doc nil :type (or string null))
   ;; prefix for slot names. If NIL, none.
-  (conc-name (concat-pnames name '-) :type (or symbol null))
+  (conc-name (symbolicate name "-") :type (or symbol null))
   ;; the name of the primary standard keyword constructor, or NIL if none
   (default-constructor nil :type (or symbol null))
   ;; all the explicit :CONSTRUCTOR specs, with name defaulted
   (constructors () :type list)
   ;; name of copying function
-  (copier (concat-pnames 'copy- name) :type (or symbol null))
+  (copier (symbolicate "COPY-" name) :type (or symbol null))
   ;; name of type predicate
-  (predicate (concat-pnames name '-p) :type (or symbol null))
+  (predicate (symbolicate name "-P") :type (or symbol null))
   ;; the arguments to the :INCLUDE option, or NIL if no included
   ;; structure
   (include nil :type list)
@@ -86,7 +85,7 @@
   ;; classes, CLASS-STRUCTURE-P = NIL)
   ;;
   ;; vector element type
-  (element-type 't)
+  (element-type t)
   ;; T if :NAMED was explicitly specified, NIL otherwise
   (named nil :type boolean)
   ;; any INITIAL-OFFSET option on this direct type
@@ -153,7 +152,7 @@
   (intern (string (dsd-%name dsd))
 	  (if (dsd-accessor dsd)
 	      (symbol-package (dsd-accessor dsd))
-	      *package*)))
+	      (sane-package))))
 
 ;;;; typed (non-class) structures
 
@@ -166,8 +165,8 @@
 ;;;; the legendary DEFSTRUCT macro itself (both CL:DEFSTRUCT and its
 ;;;; close personal friend SB!XC:DEFSTRUCT)
 
-;;; Return a list of forms to install print and make-load-form funs, mentioning
-;;; them in the expansion so that they can be compiled.
+;;; Return a list of forms to install PRINT and MAKE-LOAD-FORM funs,
+;;; mentioning them in the expansion so that they can be compiled.
 (defun class-method-definitions (defstruct)
   (let ((name (dd-name defstruct)))
     `((locally
@@ -200,7 +199,7 @@
 			 (funcall #',(farg po) ,x ,s))))
 		    (t nil))))
 	,@(let ((pure (dd-pure defstruct)))
-	    (cond ((eq pure 't)
+	    (cond ((eq pure t)
 		   `((setf (layout-pure (class-layout
 					 (sb!xc:find-class ',name)))
 			   t)))
@@ -211,9 +210,7 @@
 	,@(let ((def-con (dd-default-constructor defstruct)))
 	    (when (and def-con (not (dd-alternate-metaclass defstruct)))
 	      `((setf (structure-class-constructor (sb!xc:find-class ',name))
-		      #',def-con))))
-	;; FIXME: MAKE-LOAD-FORM is supposed to be handled here, too.
-	))))
+		      #',def-con))))))))
 ;;; FIXME: I really would like to make structure accessors less special,
 ;;; just ordinary inline functions. (Or perhaps inline functions with special
 ;;; compact implementations of their expansions, to avoid bloating the system.)
@@ -249,11 +246,13 @@
        (if (class-structure-p dd)
 	   (let ((inherits (inherits-for-structure dd)))
 	     `(progn
+		(/noshow0 "doing CLASS-STRUCTURE-P case for DEFSTRUCT " ,name)
 		(eval-when (:compile-toplevel :load-toplevel :execute)
 		  (%compiler-only-defstruct ',dd ',inherits))
 		(%defstruct ',dd ',inherits)
 		,@(when (eq (dd-type dd) 'structure)
 		    `((%compiler-defstruct ',dd)))
+		(/noshow0 "starting not-for-the-xc-host section in DEFSTRUCT")
 		,@(unless expanding-into-code-for-xc-host-p
 		    (append (raw-accessor-definitions dd)
 			    (predicate-definitions dd)
@@ -263,8 +262,10 @@
 					;(copier-definition dd)
 			    (constructor-definitions dd)
 			    (class-method-definitions dd)))
+		(/noshow0 "done with DEFSTRUCT " ,name)
 		',name))
 	   `(progn
+	      (/show0 "doing NOT CLASS-STRUCTURE-P case for DEFSTRUCT " ,name)
 	      (eval-when (:compile-toplevel :load-toplevel :execute)
 		(setf (info :typed-structure :info ',name) ',dd))
 	      ,@(unless expanding-into-code-for-xc-host-p
@@ -272,13 +273,14 @@
 			  (typed-predicate-definitions dd)
 			  (typed-copier-definitions dd)
 			  (constructor-definitions dd)))
+	      (/noshow0 "done with DEFSTRUCT " ,name)
 	      ',name)))))
 
 (sb!xc:defmacro defstruct (name-and-options &rest slot-descriptions)
   #!+sb-doc
   "DEFSTRUCT {Name | (Name Option*)} {Slot | (Slot [Default] {Key Value}*)}
-   Define the structure type Name. Instances are created by MAKE-<name>, which
-   takes keyword arguments allowing initial slot values to the specified.
+   Define the structure type Name. Instances are created by MAKE-<name>, 
+   which takes &KEY arguments allowing initial slot values to the specified.
    A SETF'able function <name>-<slot> is defined for each slot to read and
    write slot values. <name>-p is a type predicate.
 
@@ -459,16 +461,16 @@
 		   conc-name
 		   (make-symbol (string conc-name))))))
       (:constructor
-       (destructuring-bind (&optional (cname (concat-pnames 'make- name))
+       (destructuring-bind (&optional (cname (symbolicate "MAKE-" name))
 				      &rest stuff)
 	   args
 	 (push (cons cname stuff) (dd-constructors defstruct))))
       (:copier
-       (destructuring-bind (&optional (copier (concat-pnames 'copy- name)))
+       (destructuring-bind (&optional (copier (symbolicate "COPY-" name)))
 	   args
 	 (setf (dd-copier defstruct) copier)))
       (:predicate
-       (destructuring-bind (&optional (pred (concat-pnames name '-p))) args
+       (destructuring-bind (&optional (pred (symbolicate name "-P"))) args
 	 (setf (dd-predicate defstruct) pred)))
       (:include
        (when (dd-include defstruct)
@@ -489,7 +491,7 @@
 	 (cond ((eq type 'funcallable-structure)
 		(setf (dd-type defstruct) type))
 	       ((member type '(list vector))
-		(setf (dd-element-type defstruct) 't)
+		(setf (dd-element-type defstruct) t)
 		(setf (dd-type defstruct) type))
 	       ((and (consp type) (eq (first type) 'vector))
 		(destructuring-bind (vector vtype) type
@@ -512,6 +514,7 @@
 (eval-when (:compile-toplevel :load-toplevel :execute)
 (defun parse-name-and-options (name-and-options)
   (destructuring-bind (name &rest options) name-and-options
+    (aver name) ; A null name doesn't seem to make sense here.
     (let ((defstruct (make-defstruct-description name)))
       (dolist (option options)
 	(cond ((consp option)
@@ -593,14 +596,15 @@
 	spec))
 
     (when (find name (dd-slots defstruct) :test #'string= :key #'dsd-%name)
-      (error 'program-error
+      (error 'simple-program-error
 	     :format-control "duplicate slot name ~S"
 	     :format-arguments (list name)))
     (setf (dsd-%name islot) (string name))
     (setf (dd-slots defstruct) (nconc (dd-slots defstruct) (list islot)))
 
-    (let* ((accname (concat-pnames (dd-conc-name defstruct) name))
+    (let* ((accname (symbolicate (or (dd-conc-name defstruct) "") name))
 	   (existing (info :function :accessor-for accname)))
+      (declare (notinline find)) ; to avoid bug 117 bogowarnings
       (if (and (structure-class-p existing)
 	       (not (eq (sb!xc:class-name existing) (dd-name defstruct)))
 	       (string= (dsd-%name (find accname
@@ -616,7 +620,7 @@
       (setf (dsd-default islot) default))
     (when type-p
       (setf (dsd-type islot)
-	    (if (eq (dsd-type islot) 't)
+	    (if (eq (dsd-type islot) t)
 		type
 		`(and ,(dsd-type islot) ,type))))
     (when ro-p
@@ -1163,7 +1167,7 @@
        (t
 	(dsd-index slot)))
      (cond
-      ((eq rtype 't) object)
+      ((eq rtype t) object)
       (data)
       (t
        `(truly-the (simple-array (unsigned-byte 32) (*))
@@ -1231,10 +1235,10 @@
 	       (%delayed-get-compiler-layout ,(dd-name defstruct)))
 	 ,@(when n-raw-data
 	     `((setf (%instance-ref ,temp ,raw-index) ,n-raw-data)))
-	 ,@(mapcar #'(lambda (dsd value)
-		       (multiple-value-bind (accessor index data)
-			   (slot-accessor-form defstruct dsd temp n-raw-data)
-			 `(setf (,accessor ,data ,index) ,value)))
+	 ,@(mapcar (lambda (dsd value)
+		     (multiple-value-bind (accessor index data)
+			 (slot-accessor-form defstruct dsd temp n-raw-data)
+		       `(setf (,accessor ,data ,index) ,value)))
 		   (dd-slots defstruct)
 		   values)
 	 ,temp))))
@@ -1264,15 +1268,14 @@
     (dolist (slot (dd-slots defstruct))
       (let ((dum (gensym))
 	    (name (dsd-name slot)))
-	(arglist `((,(intern (string name) "KEYWORD") ,dum)
-		   ,(dsd-default slot)))
+	(arglist `((,(keywordicate name) ,dum) ,(dsd-default slot)))
 	(types (dsd-type slot))
 	(vals dum)))
     (funcall creator
 	     defstruct (dd-default-constructor defstruct)
 	     (arglist) (vals) (types) (vals))))
 
-;;; Given a structure and a BOA constructor spec, call Creator with
+;;; Given a structure and a BOA constructor spec, call CREATOR with
 ;;; the appropriate args to make a constructor.
 (defun create-boa-constructor (defstruct boa creator)
   (multiple-value-bind (req opt restp rest keyp keys allowp aux)
@@ -1373,7 +1376,7 @@
       (return-from constructor-definitions ()))
 
     (unless (or defaults boas)
-      (push (concat-pnames 'make- (dd-name defstruct)) defaults))
+      (push (symbolicate "MAKE-" (dd-name defstruct)) defaults))
 
     (collect ((res))
       (when defaults
@@ -1418,3 +1421,5 @@
 		     (rest args)))
 	 (inherits (inherits-for-structure defstruct)))
     (function-%compiler-only-defstruct defstruct inherits)))
+
+(/show0 "code/defstruct.lisp end of file")