X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fdefstruct.lisp;h=8ea7dae05f0229c63e61848adb8b57fa5017f37b;hb=2d0b882f9eabffe5e2d32c0e2e7ab06c96f4fea3;hp=824641493b0b2d2ed9d6392709a6badb2f6e2828;hpb=993d5b779638756473181dda8d928d33038d4cc3;p=sbcl.git

diff --git a/src/code/defstruct.lisp b/src/code/defstruct.lisp
index 8246414..8ea7dae 100644
--- a/src/code/defstruct.lisp
+++ b/src/code/defstruct.lisp
@@ -11,6 +11,8 @@
 ;;;; files for more information.
 
 (in-package "SB!KERNEL")
+
+(/show0 "code/defstruct.lisp 15")
 
 ;;;; getting LAYOUTs
 
@@ -163,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
@@ -208,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.)
@@ -246,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)
@@ -260,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
@@ -269,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.
 
@@ -509,7 +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
-    (assert name) ; A null name doesn't seem to make sense here.
+    (aver name) ; A null name doesn't seem to make sense here.
     (let ((defstruct (make-defstruct-description name)))
       (dolist (option options)
 	(cond ((consp option)
@@ -1262,8 +1267,7 @@
     (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
@@ -1416,3 +1420,5 @@
 		     (rest args)))
 	 (inherits (inherits-for-structure defstruct)))
     (function-%compiler-only-defstruct defstruct inherits)))
+
+(/show0 "code/defstruct.lisp end of file")