X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fdefstruct.lisp;h=410759cda6a9b331120af9a88a28b5f3e283c940;hb=86210c4e406c1b2ff10cc3bac0e71435867db48b;hp=d3fc91657585d2f14de7f3f23a7d6d3658a4595d;hpb=74a48d09e08aead6f67204878bdf9be4f448e1e8;p=sbcl.git

diff --git a/src/code/defstruct.lisp b/src/code/defstruct.lisp
index d3fc916..410759c 100644
--- a/src/code/defstruct.lisp
+++ b/src/code/defstruct.lisp
@@ -50,21 +50,25 @@
 	     (:conc-name dd-)
 	     (:make-load-form-fun just-dump-it-normally)
 	     #-sb-xc-host (:pure t)
-	     (:constructor make-defstruct-description (name)))
+	     (:constructor make-defstruct-description
+			   (name &aux
+				 (conc-name (symbolicate name "-"))
+				 (copier-name (symbolicate "COPY-" name))
+				 (predicate-name (symbolicate name "-P")))))
   ;; name of the structure
-  (name (missing-arg) :type symbol)
+  (name (missing-arg) :type symbol :read-only t)
   ;; documentation on the structure
   (doc nil :type (or string null))
   ;; prefix for slot names. If NIL, none.
-  (conc-name (symbolicate name "-") :type (or symbol null))
+  (conc-name nil :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-name (symbolicate "COPY-" name) :type (or symbol null))
+  (copier-name nil :type (or symbol null))
   ;; name of type predicate
-  (predicate-name (symbolicate name "-P") :type (or symbol null))
+  (predicate-name nil :type (or symbol null))
   ;; the arguments to the :INCLUDE option, or NIL if no included
   ;; structure
   (include nil :type list)
@@ -274,7 +278,10 @@
 		       fun-name)))
 	      (cond ((not (eql pf 0))
 		     `((def!method print-object ((,x ,name) ,s)
-			 (funcall #',(farg pf) ,x ,s *current-level*))))
+			 (funcall #',(farg pf)
+				  ,x
+				  ,s
+				  *current-level-in-print*))))
 		    ((not (eql po 0))
 		     `((def!method print-object ((,x ,name) ,s)
 			 (funcall #',(farg po) ,x ,s))))
@@ -515,7 +522,7 @@
 	   (when offset (incf (dd-length dd) offset)))))
 
       (when (dd-include dd)
-	(do-dd-inclusion-stuff dd))
+	(frob-dd-inclusion-stuff dd))
 
       dd)))
 
@@ -676,7 +683,7 @@
 
 ;;; Process any included slots pretty much like they were specified.
 ;;; Also inherit various other attributes.
-(defun do-dd-inclusion-stuff (dd)
+(defun frob-dd-inclusion-stuff (dd)
   (destructuring-bind (included-name &rest modified-slots) (dd-include dd)
     (let* ((type (dd-type dd))
 	   (included-structure
@@ -883,9 +890,7 @@
 
   (%compiler-set-up-layout dd inherits)
 
-  (let* ((dd-name (dd-name dd))
-	 (dtype (dd-declarable-type dd))
-	 (class (sb!xc:find-class dd-name)))
+  (let* ((dtype (dd-declarable-type dd)))
 
     (let ((copier-name (dd-copier-name dd)))
       (when copier-name
@@ -1232,9 +1237,16 @@
 	  (dolist (arg opt)
 	    (cond ((consp arg)
 		   (destructuring-bind
-		       (name &optional (def (nth-value 1 (get-slot name))))
+			 ;; FIXME: this shares some logic (though not
+			 ;; code) with the &key case below (and it
+			 ;; looks confusing) -- factor out the logic
+			 ;; if possible. - CSR, 2002-04-19
+			 (name
+			  &optional
+			  (def (nth-value 1 (get-slot name)))
+			  (supplied-test nil supplied-test-p))
 		       arg
-		     (arglist `(,name ,def))
+		     (arglist `(,name ,def ,@(if supplied-test-p `(,supplied-test) nil)))
 		     (vars name)
 		     (types (get-slot name))))
 		  (t
@@ -1249,14 +1261,20 @@
 	  (arglist '&key)
 	  (dolist (key keys)
 	    (if (consp key)
-		(destructuring-bind (wot &optional (def nil def-p)) key
+		(destructuring-bind (wot
+                                     &optional
+                                     (def nil def-p)
+                                     (supplied-test nil supplied-test-p))
+                    key
 		  (let ((name (if (consp wot)
 				  (destructuring-bind (key var) wot
 				    (declare (ignore key))
 				    var)
 				  wot)))
-		    (multiple-value-bind (type slot-def) (get-slot name)
-		      (arglist `(,wot ,(if def-p def slot-def)))
+		    (multiple-value-bind (type slot-def)
+                        (get-slot name)
+		      (arglist `(,wot ,(if def-p def slot-def)
+                                 ,@(if supplied-test-p `(,supplied-test) nil)))
 		      (vars name)
 		      (types type))))
 		(do-default key))))
@@ -1402,7 +1420,6 @@
 	      :metaclass-name metaclass-name
 	      :metaclass-constructor metaclass-constructor
 	      :dd-type dd-type))
-	 (conc-name (concatenate 'string (symbol-name class-name) "-"))
 	 (dd-slots (dd-slots dd))
 	 (dd-length (1+ (length slot-names)))
 	 (object-gensym (gensym "OBJECT"))