X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fctor.lisp;h=3a086896854d562c57d21cb9ca32d23ea52db632;hb=0e35b321b97477bcfedaa1a5aed1fa87d635d262;hp=e783253d6c7fa51bdd354f5eaa3280681c90dfa1;hpb=683e2bd6292cffb08f6033e3197971782f7e39ff;p=sbcl.git

diff --git a/src/pcl/ctor.lisp b/src/pcl/ctor.lisp
index e783253..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))))))))
 
 
 ;;; **************************************************
@@ -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.