0.8.21.50:

[sbcl.git] / src / pcl / ctor.lisp

diff --git a/src/pcl/ctor.lisp b/src/pcl/ctor.lisp
index 9e09462..3a08689 100644 (file)
--- 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))))))))
 
 \f
 ;;; **************************************************
@@ -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.