X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fdefstruct.lisp;h=984fa3ae808fc6edfc0324b3201ae997d6351fe3;hb=a8161e77843ee18a99ec30dd57f796264dfac05a;hp=2a81fb3d226b36f4f2c165c3e4d7db10e3297457;hpb=78a057624fecd10d0fb2ead4ef02ffc361b1ee22;p=sbcl.git

diff --git a/src/code/defstruct.lisp b/src/code/defstruct.lisp
index 2a81fb3..984fa3a 100644
--- a/src/code/defstruct.lisp
+++ b/src/code/defstruct.lisp
@@ -890,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
@@ -1212,8 +1210,8 @@
 ;;; 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)
-      (sb!kernel:parse-lambda-list (second boa))
+  (multiple-value-bind (req opt restp rest keyp keys allowp auxp aux)
+      (parse-lambda-list (second boa))
     (collect ((arglist)
 	      (vars)
 	      (types))
@@ -1239,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
@@ -1256,21 +1261,27 @@
 	  (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))))
 
 	(when allowp (arglist '&allow-other-keys))
 
-	(when aux
+	(when auxp
 	  (arglist '&aux)
 	  (dolist (arg aux)
 	    (let* ((arg (if (consp arg) arg (list arg)))
@@ -1409,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"))