0.9.0.12:

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

diff --git a/src/pcl/ctor.lisp b/src/pcl/ctor.lisp
index e783253..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
 ;;; **************************************************
@@ -462,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))
@@ -598,14 +590,9 @@
                  collect var into vars
                  collect `(,var (funcall ,initfn)) into bindings
                  finally (return (values vars bindings)))
-          ;; FIXME: adjust comment above!
           (values bindings vars (nreverse defaulting-initargs)
                   `(,@(delete nil instance-init-forms)
                     ,@class-init-forms)))))))
-#|       `(let ,bindings
-            (declare (ignorable ,@vars))
-            ,@(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.