X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fconstruct.lisp;h=501ff2d48eadda634b2f738efa6376d6f36a2efc;hb=683874b497a99cd2c11b6c5d9b47e2785b1ede5f;hp=b7f9ac2a9ba7d936223a98d2b42a4d86bda7d17b;hpb=26b8ddda97fcfa2e2c0eae3bd2fdb19717c5fa40;p=sbcl.git

diff --git a/src/pcl/construct.lisp b/src/pcl/construct.lisp
index b7f9ac2..501ff2d 100644
--- a/src/pcl/construct.lisp
+++ b/src/pcl/construct.lisp
@@ -1,5 +1,10 @@
-;;;; This file defines the defconstructor and other make-instance optimization
-;;;; mechanisms.
+;;;; This file defines MAKE-INSTANCE optimization mechanisms.
+;;;;
+;;;; KLUDGE: I removed the old DEFCONSTRUCTOR, MAKE-CONSTRUCTOR, and
+;;;; LOAD-CONSTRUCTOR families of definitions in sbcl-0.pre7.99, since
+;;;; it was clear from a few minutes with egrep that they were dead
+;;;; code, but I suspect more dead code remains in this file. (Maybe
+;;;; it's all dead?) -- WHN 2001-12-26
 
 ;;;; This software is part of the SBCL system. See the README file for
 ;;;; more information.
@@ -26,147 +31,6 @@
 
 (in-package "SB-PCL")
 
-;;; defconstructor is used to define special purpose functions which just
-;;; call make-instance with a symbol as the first argument. The semantics
-;;; of defconstructor is that it is equivalent to defining a function which
-;;; just calls make-instance. The purpose of defconstructor is to provide
-;;; PCL with a way of noticing these calls to make-instance so that it can
-;;; optimize them. Specific ports of PCL could just have their compiler
-;;; spot these calls to make-instance and then call this code. Having the
-;;; special defconstructor facility is the best we can do portably.
-;;;
-;;; A call to defconstructor like:
-;;;
-;;;  (defconstructor make-foo foo (a b &rest r) a a :mumble b baz r)
-;;;
-;;; Is equivalent to a defun like:
-;;;
-;;;  (defun make-foo (a b &rest r)
-;;;    (make-instance 'foo 'a a ':mumble b 'baz r))
-;;;
-;;; Calls like the following are also legal:
-;;;
-;;;  (defconstructor make-foo foo ())
-;;;  (defconstructor make-bar bar () :x *x* :y *y*)
-;;;  (defconstructor make-baz baz (a b c) a-b (list a b) b-c (list b c))
-;;;
-;;; The general idea of this implementation is that the expansion of the
-;;; defconstructor form includes the creation of closure generators which
-;;; can be called to create constructor code for the class. The ways that
-;;; a constructor can be optimized depends not only on the defconstructor
-;;; form, but also on the state of the class and the generic functions in
-;;; the initialization protocol. Because of this, the determination of the
-;;; form of constructor code to be used is a two part process.
-;;;
-;;; At compile time, make-constructor-code-generators looks at the actual
-;;; defconstructor form and makes a list of appropriate constructor code
-;;; generators. All that is really taken into account here is whether
-;;; any initargs are supplied in the call to make-instance, and whether
-;;; any of those are constant.
-;;;
-;;; At constructor code generation time (see note about lazy evaluation)
-;;; compute-constructor-code calls each of the constructor code generators
-;;; to try to get code for this constructor. Each generator looks at the
-;;; state of the class and initialization protocol generic functions and
-;;; decides whether its type of code is appropriate. This depends on things
-;;; like whether there are any applicable methods on initialize-instance,
-;;; whether class slots are affected by initialization etc.
-;;;
-;;; Constructor objects are funcallable instances, the protocol followed to
-;;; to compute the constructor code for them is quite similar to the protocol
-;;; followed to compute the discriminator code for a generic function. When
-;;; the constructor is first loaded, we install as its code a function which
-;;; will compute the actual constructor code the first time it is called.
-;;;
-;;; If there is an update to the class structure which might invalidate the
-;;; optimized constructor, the special lazy constructor installer is put back
-;;; so that it can compute the appropriate constructor when it is called.
-;;; This is the same kind of lazy evaluation update strategy used elswhere
-;;; in PCL.
-;;;
-;;; To allow for flexibility in the PCL implementation and to allow PCL users
-;;; to specialize this constructor facility for their own metaclasses, there
-;;; is an internal protocol followed by the code which loads and installs
-;;; the constructors. This is documented in the comments in the code.
-;;;
-;;; This code is also designed so that one of its levels, can be used to
-;;; implement optimization of calls to make-instance which can't go through
-;;; the defconstructor facility. This has not been implemented yet, but the
-;;; hooks are there.
-
-(defmacro defconstructor
-	  (name class lambda-list &rest initialization-arguments)
-  (expand-defconstructor class
-			 name
-			 lambda-list
-			 (copy-list initialization-arguments)))
-
-(defun expand-defconstructor (class-name name lambda-list supplied-initargs)
-  (let ((class (find-class class-name nil))
-	(supplied-initarg-names
-	  (gathering1 (collecting)
-	    (iterate ((name (*list-elements supplied-initargs :by #'cddr)))
-	      (gather1 name)))))
-    (when (null class)
-      (error "defconstructor form being compiled (or evaluated) before~@
-	      class ~S is defined."
-	     class-name))
-    `(progn
-       ;; comments from PCL code back when it was portable:
-       ;;   In order to avoid undefined function warnings, we want to
-       ;;   tell the compile time environment that a function with this
-       ;;   name and this argument list has been defined. The portable
-       ;;   way to do this is with defun:
-       ;;   #-cmu (declaim (notinline ,name))
-       ;;   #-cmu
-       ;;   (defun ,name ,lambda-list
-       ;;     (declare (ignore ,@(extract-parameters lambda-list)))
-       ;;     (error "Constructor ~S not loaded." ',name))
-       ;;   But the derived result type for the above is wrong under CMU CL.
-       ;;   So instead:
-       (declaim (ftype ,(ftype-declaration-from-lambda-list lambda-list name)
-		       ,name))
-       (load-constructor
-        ',class-name
-        ',(class-name (class-of class))
-        ',name
-        ',supplied-initarg-names
-        ;; make-constructor-code-generators is called to return a list
-        ;; of constructor code generators. The actual interpretation
-        ;; of this list is left to compute-constructor-code, but the
-        ;; general idea is that it should be an plist where the keys
-        ;; name a kind of constructor code and the values are generator
-        ;; functions which return the actual constructor code. The
-        ;; constructor code is usually a closures over the arguments
-        ;; to the generator.
-        ,(make-constructor-code-generators class
-                                           name
-                                           lambda-list
-                                           supplied-initarg-names
-                                           supplied-initargs)))))
-
-(defun load-constructor (class-name metaclass-name constructor-name
-			 supplied-initarg-names code-generators)
-  (let ((class (find-class class-name nil)))
-    (cond ((null class)
-	   (error "defconstructor form being loaded (or evaluated) before~@
-		   class ~S is defined."
-		  class-name))
-	  ((neq (class-name (class-of class)) metaclass-name)
-	   (error "When defconstructor ~S was compiled, the metaclass of the~@
-		   class ~S was ~S. The metaclass is now ~S.~@
-		   The constructor must be recompiled."
-		  constructor-name
-		  class-name
-		  metaclass-name
-		  (class-name (class-of class))))
-	  (t
-	   (load-constructor-internal class
-				      constructor-name
-				      supplied-initarg-names
-				      code-generators)
-	   constructor-name))))
-
 ;;; The actual constructor objects.
 (defclass constructor (funcallable-standard-object)
      ((class					;The class with which this
@@ -178,8 +42,9 @@
 	:initform nil				;This is the symbol in whose
 	:initarg :name				;function cell the constructor
 	:reader constructor-name)		;usually sits. Of course, this
-						;is optional. defconstructor
-						;makes named constructors, but
+						;is optional. The old
+					        ;DEFCONSTRUCTOR macro made
+						;named constructors, but
 						;it is possible to manipulate
 						;anonymous constructors also.
 
@@ -202,14 +67,6 @@
 	:reader constructor-code-generators))	;could use.
   (:metaclass funcallable-standard-class))
 
-;;; Because the value in the code-type slot should always correspond to the
-;;; funcallable-instance-function of the constructor, this function should
-;;; always be used to set the both at the same time.
-(defun set-constructor-code (constructor code type)
-  (set-funcallable-instance-function constructor code)
-  (set-function-name constructor (constructor-name constructor))
-  (setf (constructor-code-type constructor) type))
-
 (defmethod describe-object ((constructor constructor) stream)
   (format stream
 	  "~S is a constructor for the class ~S.~%~
@@ -217,136 +74,47 @@
 	    Other possible code types are ~S."
 	  constructor (constructor-class constructor)
 	  (constructor-code-type constructor)
-	  (gathering1 (collecting)
+          (let ((collect nil))
 	    (doplist (key val) (constructor-code-generators constructor)
-	      (gather1 key)))))
-
-;;; I am not in a hairy enough mood to make this implementation be metacircular
-;;; enough that it can support a defconstructor for constructor objects.
-(defun make-constructor (class name supplied-initarg-names code-generators)
-  (make-instance 'constructor
-		 :class class
-		 :name name
-		 :supplied-initarg-names supplied-initarg-names
-		 :code-generators code-generators))
-
-; This definition actually appears in std-class.lisp.
-;(defmethod class-constructors ((class std-class))
-;  (with-slots (plist) class (getf plist 'constructors)))
-
-(defmethod add-constructor ((class slot-class)
-			    (constructor constructor))
-  (with-slots (plist) class
-    (pushnew constructor (getf plist 'constructors))))
-
-(defmethod remove-constructor ((class slot-class)
-			       (constructor constructor))
-  (with-slots (plist) class
-    (setf (getf plist 'constructors)
-	  (delete constructor (getf plist 'constructors)))))
-
-(defmethod get-constructor ((class slot-class) name &optional (error-p t))
-  (or (dolist (c (class-constructors class))
-	(when (eq (constructor-name c) name) (return c)))
-      (if error-p
-	  (error "Couldn't find a constructor with name ~S for class ~S."
-		 name class)
-	  ())))
-
-;;; This is called to actually load a defconstructor constructor. It must
-;;; install the lazy installer in the function cell of the constructor name,
-;;; and also add this constructor to the list of constructors the class has.
-(defmethod load-constructor-internal
-	   ((class slot-class) name initargs generators)
-  (let ((constructor (make-constructor class name initargs generators))
-	(old (get-constructor class name nil)))
-    (when old (remove-constructor class old))
-    (install-lazy-constructor-installer constructor)
-    (add-constructor class constructor)
-    (setf (gdefinition name) constructor)))
-
-(defmethod install-lazy-constructor-installer ((constructor constructor))
-  (let ((class (constructor-class constructor)))
-    (set-constructor-code constructor
-			  #'(sb-kernel:instance-lambda (&rest args)
-			      (multiple-value-bind (code type)
-				  (compute-constructor-code class constructor)
-				(set-constructor-code constructor code type)
-				(apply constructor args)))
-			  'lazy)))
-
-;;; The interface to keeping the constructors updated.
-;;;
-;;; add-method and remove-method (for standard-generic-function and -method),
-;;; promise to call maybe-update-constructors on the generic function and
-;;; the method.
-;;;
-;;; The class update code promises to call update-constructors whenever the
-;;; class is changed. That is, whenever the supers, slots or options change.
-;;; If user defined classes of constructor needs to be updated in more than
-;;; these circumstances, they should use the dependent updating mechanism to
-;;; make sure update-constructors is called.
-;;;
-;;; Bootstrapping concerns force the definitions of maybe-update-constructors
-;;; and update-constructors to be in the file std-class. For clarity, they
-;;; also appear below. Be sure to keep the definition here and there in sync.
-;(defvar *initialization-generic-functions*
-;	 (list #'make-instance
-;	       #'default-initargs
-;	       #'allocate-instance
-;	       #'initialize-instance
-;	       #'shared-initialize))
-;
-;(defmethod maybe-update-constructors
-;	   ((generic-function generic-function)
-;	    (method method))
-;  (when (memq generic-function *initialization-generic-functions*)
-;    (labels ((recurse (class)
-;	       (update-constructors class)
-;	       (dolist (subclass (class-direct-subclasses class))
-;		 (recurse subclass))))
-;      (when (classp (car (method-specializers method)))
-;	(recurse (car (method-specializers method)))))))
-;
-;(defmethod update-constructors ((class slot-class))
-;  (dolist (cons (class-constructors class))
-;    (install-lazy-constructor-installer cons)))
-;
-;(defmethod update-constructors ((class class))
-;  ())
+              (push key collect))
+            (nreverse collect))))
 
-;;; Here is the actual smarts for making the code generators and then trying
-;;; each generator to get constructor code. This extensible mechanism allows
-;;; new kinds of constructor code types to be added. A programmer defining a
-;;; specialization of the constructor class can either use this mechanism to
-;;; define new code types, or can override this mechanism by overriding the
-;;; methods on make-constructor-code-generators and compute-constructor-code.
-;;;
-;;; The function defined by define-constructor-code-type will receive the
-;;; class object, and the 4 original arguments to defconstructor. It can
-;;; return a constructor code generator, or return nil if this type of code
-;;; is determined to not be appropriate after looking at the defconstructor
-;;; arguments.
-;;;
-;;; When compute-constructor-code is called, it first performs basic checks
-;;; to make sure that the basic assumptions common to all the code types are
-;;; valid. (For details see method definition). If any of the tests fail,
-;;; the fallback constructor code type is used. If none of the tests fail,
-;;; the constructor code generators are called in order. They receive 5
-;;; arguments:
-;;;
-;;;   CLASS	the class the constructor is making instances of
-;;;   WRAPPER      that class's wrapper
-;;;   DEFAULTS     the result of calling class-default-initargs on class
-;;;   INITIALIZE   the applicable methods on initialize-instance
-;;;   SHARED       the applicable methosd on shared-initialize
-;;;
-;;; The first code generator to return code is used. The code generators are
-;;; called in reverse order of definition, so define-constructor-code-type
-;;; forms which define better code should appear after ones that define less
-;;; good code. The fallback code type appears first. Note that redefining a
-;;; code type does not change its position in the list. To do that,  define
-;;; a new type at the end with the behavior.
+;;;; Here is the actual smarts for making the code generators and then
+;;;; trying each generator to get constructor code. This extensible
+;;;; mechanism allows new kinds of constructor code types to be added.
+;;;; A programmer defining a specialization of the constructor class
+;;;; can use this mechanism to define new code types.
+;;;;
+;;;; original PCL comment from before dead DEFCONSTRUCTOR was deleted:
+;;;;   The function defined by define-constructor-code-type will receive
+;;;;   the class object, and the 4 original arguments to DEFCONSTRUCTOR.
+;;;;   It can return a constructor code generator, or return NIL if this
+;;;;   type of code is determined to not be appropriate after looking at
+;;;;   the DEFCONSTRUCTOR arguments.
+;;;;
+;;;; original PCL comment from before dead COMPUTE-CONSTRUCTOR-CODE
+;;;; was deleted:
+;;;;    When compute-constructor-code is called, it first performs
+;;;;    basic checks to make sure that the basic assumptions common to
+;;;;    all the code types are valid. (For details see method
+;;;;    definition). If any of the tests fail, the fallback
+;;;;    constructor code type is used. If none of the tests fail, the
+;;;;    constructor code generators are called in order. They receive
+;;;;    5 arguments:
+;;;;
+;;;;   CLASS	the class the constructor is making instances of
+;;;;   WRAPPER      that class's wrapper
+;;;;   DEFAULTS     the result of calling class-default-initargs on class
+;;;;   INITIALIZE   the applicable methods on initialize-instance
+;;;;   SHARED       the applicable methosd on shared-initialize
+;;;;
+;;;; The first code generator to return code is used. The code
+;;;; generators are called in reverse order of definition, so
+;;;; DEFINE-CONSTRUCTOR-CODE-TYPE forms which define better code
+;;;; should appear after ones that define less good code. The fallback
+;;;; code type appears first. Note that redefining a code type does
+;;;; not change its position in the list. To do that, define a new
+;;;; type at the end with the behavior.
 
 (defvar *constructor-code-types* ())
 
@@ -366,110 +134,9 @@
 	(setf (cadr old-entry) generator)
 	(push (list type generator) *constructor-code-types*))
     type))
-
-(defmethod make-constructor-code-generators
-	   ((class slot-class)
-	    name lambda-list supplied-initarg-names supplied-initargs)
-  (cons 'list
-	(gathering1 (collecting)
-	  (dolist (entry *constructor-code-types*)
-	    (let ((generator
-		    (funcall (cadr entry) class name lambda-list
-					  supplied-initarg-names
-					  supplied-initargs)))
-	      (when generator
-		(gather1 `',(car entry))
-		(gather1 generator)))))))
-
-(defmethod compute-constructor-code ((class slot-class)
-				     (constructor constructor))
-  (let* ((proto (class-prototype class))
-	 (wrapper (class-wrapper class))
-	 (defaults (class-default-initargs class))
-	 (make
-	   (compute-applicable-methods (gdefinition 'make-instance) (list class)))
-	 (supplied-initarg-names
-	   (constructor-supplied-initarg-names constructor))
-	 (default
-	   (compute-applicable-methods (gdefinition 'default-initargs)
-				       (list class supplied-initarg-names))) ;?
-	 (allocate
-	   (compute-applicable-methods (gdefinition 'allocate-instance)
-				       (list class)))
-	 (initialize
-	   (compute-applicable-methods (gdefinition 'initialize-instance)
-				       (list proto)))
-	 (shared
-	   (compute-applicable-methods (gdefinition 'shared-initialize)
-				       (list proto t)))
-	 (code-generators
-	   (constructor-code-generators constructor)))
-    (flet ((call-code-generator (generator)
-	     (when (null generator)
-	       (unless (setq generator (getf code-generators 'fallback))
-		 (error "No FALLBACK generator?")))
-	     (funcall generator class wrapper defaults initialize shared)))
-      (if (or (cdr make)
-	      (cdr default)
-	      (cdr allocate)
-	      (not (check-initargs-1 class
-				     supplied-initarg-names
-				     (append initialize shared)
-				     nil nil)))
-	  ;; These are basic shared assumptions, if one of the
-	  ;; has been violated, we have to resort to the fallback
-	  ;; case. Any of these assumptions could be moved out
-	  ;; of here and into the individual code types if there
-	  ;; was a need to do so.
-	  (values (call-code-generator nil) 'fallback)
-	  ;; Otherwise try all the generators until one produces
-	  ;; code for us.
-	  (doplist (type generator) code-generators
-	    (let ((code (call-code-generator generator)))
-	      (when code (return (values code type)))))))))
-
-;;; The facilities are useful for debugging, and to measure the performance
-;;; boost from constructors.
-;;;
-;;; FIXME: so they should probably be #+SB-SHOW instead of unconditional
-
-(defun map-constructors (fn)
-  (let ((nclasses 0)
-	(nconstructors 0))
-    (labels ((recurse (class)
-	       (incf nclasses)
-	       (dolist (constructor (class-constructors class))
-		 (incf nconstructors)
-		 (funcall fn constructor))
-	       (dolist (subclass (class-direct-subclasses class))
-		 (recurse subclass))))
-      (recurse (find-class 't))
-      (values nclasses nconstructors))))
-
-(defun reset-constructors ()
-  (multiple-value-bind (nclass ncons)
-      (map-constructors #'install-lazy-constructor-installer )
-    (format t "~&~D classes, ~D constructors." nclass ncons)))
-
-(defun disable-constructors ()
-  (multiple-value-bind (nclass ncons)
-      (map-constructors
-	#'(lambda (c)
-	    (let ((gen (getf (constructor-code-generators c) 'fallback)))
-	      (if (null gen)
-		  (error "No fallback constructor for ~S." c)
-		  (set-constructor-code c
-					(funcall gen
-						 (constructor-class c)
-						 () () () ())
-					'fallback)))))
-    (format t "~&~D classes, ~D constructors." nclass ncons)))
-
-(defun enable-constructors ()
-  (reset-constructors))
 
-;;; helper functions and utilities that are shared by all of the code types
-;;; and by the main compute-constructor-code method as well
+;;;; helper functions and utilities that are shared by all of the code
+;;;; types
 
 (defvar *standard-initialize-instance-method*
 	(get-method #'initialize-instance
@@ -527,7 +194,7 @@
 	       (when (eq flag ':unsupplied) (setq flag ':constants)))
 	      (t
 	       (push (cons name +slot-unbound+) constants)
-	       (setq flag 't)))))
+	       (setq flag t)))))
     (let* ((constants-alist (sort constants #'(lambda (x y)
 						(memq (car y)
 						      (memq (car x) layout)))))
@@ -543,10 +210,9 @@
 (defun compute-initarg-positions (class initarg-names)
   (let* ((layout (wrapper-instance-slots-layout (class-wrapper class)))
 	 (positions
-	   (gathering1 (collecting)
-	     (iterate ((slot-name (list-elements layout))
-		       (position (interval :from 0)))
-	       (gather1 (cons slot-name position)))))
+           (loop for slot-name in layout
+                 for position from 0
+                 collect (cons slot-name position)))
 	 (slot-initargs
 	   (mapcar #'(lambda (slotd)
 		       (list (slot-definition-initargs slotd)
@@ -563,18 +229,20 @@
 		     (not (null slot-initargs))
 		     (memq initarg slot-initargs))
 	    (setf (car slot-entry) initarg)))))
-    (gathering1 (collecting)
+    (let (collect)
       (dolist (initarg initarg-names)
-	(let ((positions (gathering1 (collecting)
+	(let ((positions (let (collect)
 			   (dolist (slot-entry slot-initargs)
 			     (when (eq (car slot-entry) initarg)
-			       (gather1 (cadr slot-entry)))))))
+			       (push (cadr slot-entry) collect)))
+                           (nreverse collect))))
 	  (when positions
-	    (gather1 (cons initarg positions))))))))
+	    (push (cons initarg positions) collect))))
+      (nreverse collect))))
 
-;;; The FALLBACK case allows anything. This always works, and always appears
-;;; as the last of the generators for a constructor. It does a full call to
-;;; make-instance.
+;;; The FALLBACK case allows anything. This always works, and always
+;;; appears as the last of the generators for a constructor. It does a
+;;; full call to make-instance.
 (define-constructor-code-type fallback
 	(class name arglist supplied-initarg-names supplied-initargs)
   (declare (ignore name supplied-initarg-names))
@@ -585,10 +253,11 @@
 	 (sb-kernel:instance-lambda ,arglist
 	   (make-instance
 	     ',(class-name class)
-	     ,@(gathering1 (collecting)
-		 (iterate ((tail (*list-tails supplied-initargs :by #'cddr)))
-		   (gather1 `',(car tail))
-		   (gather1 (cadr tail))))))))))
+	     ,@(let (collect)
+                 (loop for tail on supplied-initargs by #'cddr
+                       do (push `',(car tail) collect)
+                          (push (cadr tail) collect))
+                 (nreverse collect))))))))
 
 ;;; The GENERAL case allows:
 ;;;   constant, unsupplied or non-constant initforms
@@ -639,15 +308,17 @@
                        (dolist (pos (cddr entry))
                          (setf (clos-slots-ref .slots. pos) val))))
 
-		   ,@(gathering1 (collecting)
+		   ,@(let (collect)
                        (doplist (initarg value) supplied-initargs
 			 (unless (constantp value)
-			   (gather1 `(let ((.value. ,value))
-				       (push .value. .initargs.)
-				       (push ',initarg .initargs.)
-				       (dolist (.p. (pop .positions.))
-					 (setf (clos-slots-ref .slots. .p.)
-					       .value.)))))))
+			   (push `(let ((.value. ,value))
+                                   (push .value. .initargs.)
+                                   (push ',initarg .initargs.)
+                                   (dolist (.p. (pop .positions.))
+                                     (setf (clos-slots-ref .slots. .p.)
+                                           .value.)))
+                                 collect)))
+                       (nreverse collect))
 
 		   (dolist (fn .shared-initfns.)
 		     (apply fn .instance. t .initargs.))
@@ -786,14 +457,16 @@
 		       (dolist (pos (cdr entry))
 			 (setf (clos-slots-ref .slots. pos) val))))
 
-		   ,@(gathering1 (collecting)
+		   ,@(let (collect)
 		       (doplist (initarg value) supplied-initargs
 			 (unless (constantp value)
-			   (gather1
+			   (push
 			     `(let ((.value. ,value))
 				(dolist (.p. (pop .positions.))
 				  (setf (clos-slots-ref .slots. .p.)
-					.value.)))))))
+					.value.)))
+                             collect)))
+                       (nreverse collect))
 
 		   .instance.))))))))
 
@@ -909,14 +582,16 @@
 			  (.positions. .supplied-initarg-positions.))
 		     .positions.
 
-		     ,@(gathering1 (collecting)
+		     ,@(let (collect)
 			 (doplist (initarg value) supplied-initargs
 			   (unless (constantp value)
-			     (gather1
+			     (push
 			       `(let ((.value. ,value))
 				  (dolist (.p. (pop .positions.))
 				    (setf (clos-slots-ref .slots. .p.)
-					  .value.)))))))
+					  .value.)))
+                               collect)))
+                         (nreverse collect))
 
 		     .instance.))))))))))