X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fctor.lisp;h=3a086896854d562c57d21cb9ca32d23ea52db632;hb=69ef68ba7393e3492c1b4a756d1140f71c2922bc;hp=9e09462eeaceeec10346fc6a144a2a83993974e2;hpb=7c5138fcbdb302abc563a2060493f2f0304ae902;p=sbcl.git

diff --git a/src/pcl/ctor.lisp b/src/pcl/ctor.lisp
index 9e09462..3a08689 100644
--- a/src/pcl/ctor.lisp
+++ b/src/pcl/ctor.lisp
@@ -134,17 +134,8 @@
     (setf (%funcallable-instance-info ctor 1)
 	  (ctor-function-name ctor))))
 
-;;; Keep this a separate function for testing.
 (defun make-ctor-function-name (class-name initargs)
-  (let ((*package* *pcl-package*)
-	(*print-case* :upcase)
-	(*print-pretty* nil)
-	(*print-gensym* t))
-    (format-symbol *pcl-package* "CTOR ~S::~S ~S ~S"
-		   (package-name (symbol-package class-name))
-		   (symbol-name class-name)
-		   (plist-keys initargs)
-		   (plist-values initargs :test #'constantp))))
+  (list* 'ctor class-name initargs))
 
 ;;; Keep this a separate function for testing.
 (defun ensure-ctor (function-name class-name initargs)
@@ -156,7 +147,7 @@
   (without-package-locks ; for (setf symbol-function)
    (let ((ctor (%make-ctor function-name class-name nil initargs)))
      (push ctor *all-ctors*)
-     (setf (symbol-function function-name) ctor)
+     (setf (fdefinition function-name) ctor)
      (install-initial-constructor ctor :force-p t)
      ctor)))
 
@@ -233,7 +224,7 @@
 				    t)
 			  (function (&rest t) t))
 		      ,function-name))
-	      (,function-name ,@value-forms))))))))
+	      (funcall (function ,function-name) ,@value-forms))))))))
 
 
 ;;; **************************************************
@@ -421,25 +412,28 @@
 	(standard-sort-methods si-methods)
       (declare (ignore si-primary))
       (aver (and (null ii-around) (null si-around)))
-      (let ((initargs (ctor-initargs ctor))
-	    (slot-inits (slot-init-forms ctor (or ii-before si-before))))
+      (let ((initargs (ctor-initargs ctor)))
+        (multiple-value-bind (bindings vars defaulting-initargs body)
+	    (slot-init-forms ctor (or ii-before si-before))
 	(values
-	 `(let (,@(when (or ii-before ii-after)
-	           `((.ii-args.
-		      (list .instance. ,@(quote-plist-keys initargs)))))
-	        ,@(when (or si-before si-after)
-		   `((.si-args.
-		      (list .instance. t ,@(quote-plist-keys initargs))))))
+         `(let ,bindings
+           (declare (ignorable ,@vars))
+           (let (,@(when (or ii-before ii-after)
+                     `((.ii-args.
+                        (list .instance. ,@(quote-plist-keys initargs) ,@defaulting-initargs))))
+                 ,@(when (or si-before si-after)
+		     `((.si-args.
+                        (list .instance. t ,@(quote-plist-keys initargs) ,@defaulting-initargs)))))
 	    ,@(loop for method in ii-before
 		    collect `(invoke-method ,method .ii-args.))
 	    ,@(loop for method in si-before
 		    collect `(invoke-method ,method .si-args.))
-	    ,slot-inits
+	    ,@body
 	    ,@(loop for method in si-after
 		    collect `(invoke-method ,method .si-args.))
 	    ,@(loop for method in ii-after
-		    collect `(invoke-method ,method .ii-args.)))
-	 (or ii-before si-before))))))
+		    collect `(invoke-method ,method .ii-args.))))
+	 (or ii-before si-before)))))))
 
 ;;; Return four values from APPLICABLE-METHODS: around methods, before
 ;;; methods, the applicable primary method, and applicable after
@@ -459,13 +453,14 @@
 	finally
 	  (return (values around before (first primary) (reverse after)))))
 
-;;; Return a form initializing instance and class slots of an object
-;;; costructed by CTOR.  The variable .SLOTS. is assumed to bound to
-;;; the instance's slot vector.  BEFORE-METHOD-P T means
-;;; before-methods will be called, which means that 1) other code will
-;;; initialize instance slots to +SLOT-UNBOUND+ before the
-;;; before-methods are run, and that we have to check if these
-;;; before-methods have set slots.
+;;; Return as multiple values bindings for default initialization
+;;; arguments, variable names, defaulting initargs and a body for
+;;; initializing instance and class slots of an object costructed by
+;;; CTOR.  The variable .SLOTS. is assumed to bound to the instance's
+;;; slot vector.  BEFORE-METHOD-P T means before-methods will be
+;;; called, which means that 1) other code will initialize instance
+;;; slots to +SLOT-UNBOUND+ before the before-methods are run, and
+;;; that we have to check if these before-methods have set slots.
 (defun slot-init-forms (ctor before-method-p)
   (let* ((class (ctor-class ctor))
 	 (initargs (ctor-initargs ctor))
@@ -475,6 +470,7 @@
 		      :initial-element nil))
 	 (class-inits ())
 	 (default-inits ())
+         (defaulting-initargs ())
 	 (default-initargs (class-default-initargs class))
 	 (initarg-locations
 	  (compute-initarg-locations
@@ -524,6 +520,13 @@
 	    unless (member key initkeys :test #'eq) do
 	    (let* ((type (if (constantp initform) 'constant 'var))
 		   (init (if (eq type 'var) initfn initform)))
+              (ecase type
+                (constant
+                 (push key defaulting-initargs)
+                 (push initform defaulting-initargs))
+                (var
+                 (push key defaulting-initargs)
+                 (push (default-init-var-name i) defaulting-initargs)))
 	      (when (eq type 'var)
 		(let ((init-var (default-init-var-name i)))
 		  (setq init init-var)
@@ -587,10 +590,9 @@
 		  collect var into vars
 		  collect `(,var (funcall ,initfn)) into bindings
 		  finally (return (values vars bindings)))
-	  `(let ,bindings
-	     (declare (ignorable ,@vars))
-	     ,@(delete nil instance-init-forms)
-	     ,@class-init-forms))))))
+          (values bindings vars (nreverse defaulting-initargs)
+                  `(,@(delete nil instance-init-forms)
+                    ,@class-init-forms)))))))
 
 ;;; Return an alist of lists (KEY LOCATION ...) telling, for each
 ;;; key in INITKEYS, which locations the initarg initializes.