X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fstd-class.lisp;h=3a7da7bc392983b83669af81ccb9cb5460b36932;hb=422b88abf96f4842a3d0999cd3b80d96f5a153d6;hp=f5a0172a1edadbf92bd42d3788938ccb852ab764;hpb=50462f68bf70faf0bd96de7517643afb740543e6;p=sbcl.git

diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp
index f5a0172..3a7da7b 100644
--- a/src/pcl/std-class.lisp
+++ b/src/pcl/std-class.lisp
@@ -481,11 +481,10 @@
 
 (defun make-structure-class-defstruct-form (name direct-slots include)
   (let* ((conc-name (intern (format nil "~S structure class " name)))
-         (constructor (intern (format nil "~A constructor" conc-name)))
+         (constructor (intern (format nil "~Aconstructor" conc-name)))
          (defstruct `(defstruct (,name
                                  ,@(when include
                                          `((:include ,(class-name include))))
-                                 (:print-function print-std-instance)
                                  (:predicate nil)
                                  (:conc-name ,conc-name)
                                  (:constructor ,constructor ())
@@ -971,9 +970,9 @@
   (let ((method (get-method generic-function () (list class) nil)))
     (when method (remove-method generic-function method))))
 
-;;; make-reader-method-function and make-write-method function are NOT part of
-;;; the standard protocol. They are however useful, PCL makes uses makes use
-;;; of them internally and documents them for PCL users.
+;;; MAKE-READER-METHOD-FUNCTION and MAKE-WRITE-METHOD function are NOT
+;;; part of the standard protocol. They are however useful, PCL makes
+;;; use of them internally and documents them for PCL users.
 ;;;
 ;;; *** This needs work to make type testing by the writer functions which
 ;;; *** do type testing faster. The idea would be to have one constructor
@@ -981,7 +980,7 @@
 ;;;
 ;;; *** There is a subtle bug here which is going to have to be fixed.
 ;;; *** Namely, the simplistic use of the template has to be fixed. We
-;;; *** have to give the optimize-slot-value method the user might have
+;;; *** have to give the OPTIMIZE-SLOT-VALUE method the user might have
 ;;; *** defined for this metaclass a chance to run.
 
 (defmethod make-reader-method-function ((class slot-class) slot-name)
@@ -1151,7 +1150,7 @@
 					     plist)
 	nwrapper)))
 
-(defun change-class-internal (instance new-class)
+(defun change-class-internal (instance new-class initargs)
   (let* ((old-class (class-of instance))
 	 (copy (allocate-instance new-class))
 	 (new-wrapper (get-wrapper copy))
@@ -1184,31 +1183,37 @@
     ;; old instance point to the new storage.
     (swap-wrappers-and-slots instance copy)
 
-    (update-instance-for-different-class copy instance)
+    (apply #'update-instance-for-different-class copy instance initargs)
     instance))
 
 (defmethod change-class ((instance standard-object)
-			 (new-class standard-class))
-  (change-class-internal instance new-class))
+			 (new-class standard-class)
+			 &rest initargs)
+  (change-class-internal instance new-class initargs))
 
 (defmethod change-class ((instance funcallable-standard-object)
-			 (new-class funcallable-standard-class))
-  (change-class-internal instance new-class))
+			 (new-class funcallable-standard-class)
+			 &rest initargs)
+  (change-class-internal instance new-class initargs))
 
 (defmethod change-class ((instance standard-object)
-			 (new-class funcallable-standard-class))
+			 (new-class funcallable-standard-class)
+			 &rest initargs)
+  (declare (ignore initargs))
   (error "You can't change the class of ~S to ~S~@
 	  because it isn't already an instance with metaclass ~S."
 	 instance new-class 'standard-class))
 
 (defmethod change-class ((instance funcallable-standard-object)
-			 (new-class standard-class))
+			 (new-class standard-class)
+			 &rest initargs)
+  (declare (ignore initargs))
   (error "You can't change the class of ~S to ~S~@
 	  because it isn't already an instance with metaclass ~S."
 	 instance new-class 'funcallable-standard-class))
 
-(defmethod change-class ((instance t) (new-class-name symbol))
-  (change-class instance (find-class new-class-name)))
+(defmethod change-class ((instance t) (new-class-name symbol) &rest initargs)
+  (apply #'change-class instance (find-class new-class-name) initargs))
 
 ;;;; The metaclass BUILT-IN-CLASS
 ;;;;