0.7.4.14:

	Various CLOS fixes...
	... Fix printing of instances of classes with metaclass of
		STRUCTURE-CLASS (thanks to Pierre Mai)
	... ANSIfy CHANGE-CLASS (thanks to Espen Johnsen and Pierre Mai)
	... Allow classes with metaclass of STRUCTURE-CLASS to have slots
		again (this fix comes with a FIXME, as it wasn't a clean fix
		at all)

BUGS

@@ -1258,18 +1258,7 @@ WORKAROUND:
   cmucl-help 2002-05-31)
 
 175:
-  sbcl's CHANGE-CLASS does not accept and use initargs, so that e.g.:
-    (defclass foo () ((a :accessor a :initarg :a)))
-    (defclass bar () ((a :accessor a :initarg :a)
-                      (b :accessor b :initarg :b)))
-    (change-class (make-instance 'foo :a 1) 'bar :b 2)
-  should return an instance of class BAR with its A slot-value being 1
-  and its B slot-value being 2; at present (sbcl-0.7.4.8), it signals
-  an error. There's some code by Espen S. Johnsen at 
-  <http://cvs.sourceforge.net/cgi-bin/viewcvs.cgi/clg/clg/glib/pcl.lisp>
-  to patch around this (and some related things? not sure -- WHN) which 
-  might be usable to fix it in the main SBCL CVS.
-
+  (fixed in sbcl-0.7.4.14)
 
 DEFUNCT CATEGORIES OF BUGS
   IR1-#:

NEWS

@@ -1135,8 +1135,12 @@ changes in sbcl-0.7.5 relative to sbcl-0.7.4:
   * bug 169 fixed: no more bogus warnings about using lexical bindings
     despite the presence of perfectly good SPECIAL declarations. (thanks
     to David Lichteblau)
+  * bug 175 fixed: more-closely-ANSI CHANGE-CLASS function, now
+    accepting initargs. (thanks to Espen Johnsen and Pierre Mai)
   * bug fix: Structure type predicate functions now check their argument
     count as they should.
+  * bug fix: classes with :METACLASS STRUCTURE-CLASS now print
+    correctly. (thanks to Pierre Mai)
   * minor incompatible change: The LOAD function no longer, when given
     a wild pathname to load, loads all files matching that pathname;
     instead, an error of type FILE-ERROR is signalled.

src/pcl/defclass.lisp

@@ -117,17 +117,30 @@
 						       '(:from-defclass-p t))
 						     other-initargs)))))))
             (if defstruct-p
-		(let* ((include (or (and supers
-					 (fix-super (car supers)))
-				    (and (not (eq name 'structure-object))
-					 *the-class-structure-object*)))
-		       (defstruct-form (make-structure-class-defstruct-form
-					name slots include)))
-		  `(progn
-		     (eval-when (:compile-toplevel :load-toplevel :execute)
-		       ,defstruct-form) ; really compile the defstruct-form
-		     (eval-when (:compile-toplevel :load-toplevel :execute)
-		       ,defclass-form)))
+		(progn
+		  ;; FIXME: (YUK!) Why do we do this? Because in order
+		  ;; to make the defstruct form, we need to know what
+		  ;; the accessors for the slots are, so we need
+		  ;; already to have hooked into the CLOS machinery.
+		  ;;
+		  ;; There may be a better way to do this: it would
+		  ;; involve knowing enough about PCL to ask "what
+		  ;; will my slot names and accessors be"; failing
+		  ;; this, we currently just evaluate the whole
+		  ;; kaboodle, and then use CLASS-DIRECT-SLOTS. --
+		  ;; CSR, 2002-06-07
+		  (eval defclass-form)
+		  (let* ((include (or (and supers
+					   (fix-super (car supers)))
+				      (and (not (eq name 'structure-object))
+					   *the-class-structure-object*)))
+			 (defstruct-form (make-structure-class-defstruct-form
+					  name (class-direct-slots (find-class name)) include)))
+		    `(progn
+		      (eval-when (:compile-toplevel :load-toplevel :execute)
+			,defstruct-form) ; really compile the defstruct-form
+		      (eval-when (:compile-toplevel :load-toplevel :execute)
+			,defclass-form))))
 		`(progn
 		   ;; By telling the type system at compile time about
 		   ;; the existence of a class named NAME, we can avoid

src/pcl/env.lisp

@@ -142,8 +142,8 @@
 
 (defmethod make-instance ((class cl:class) &rest stuff)
   (apply #'make-instance (coerce-to-pcl-class class) stuff))
-(defmethod change-class (instance (class cl:class))
-  (apply #'change-class instance (coerce-to-pcl-class class)))
+(defmethod change-class (instance (class cl:class) &rest initargs)
+  (apply #'change-class instance (coerce-to-pcl-class class) initargs))
 
 (macrolet ((frob (&rest names)
 	     `(progn

src/pcl/generic-functions.lisp

@@ -312,8 +312,6 @@
 
 (defgeneric add-method (generic-function method))
 
-(defgeneric change-class (instance new-class-name))
-
 (defgeneric class-slot-value (class slot-name))
 
 (defgeneric compatible-meta-class-change-p (class proto-new-class))
@@ -474,7 +472,9 @@
 
 (defgeneric initialize-instance (gf &key &allow-other-keys))
 
-(defgeneric make-instance (class &rest initargs))
+(defgeneric make-instance (class &rest initargs &key &allow-other-keys))
+
+(defgeneric change-class (instance new-class-name &rest initargs &key &allow-other-keys))
 
 (defgeneric no-applicable-method (generic-function &rest args))
 

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 ())
@@ -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
 ;;;;

tests/clos.impure.lisp

@@ -115,7 +115,7 @@
 (defgeneric born-to-be-redefined (x))
 (assert (eq (born-to-be-redefined 1) 'int))
 
-;;; in the removal of ITERATE from SB-PCL, a bug was introduced
+;;; In the removal of ITERATE from SB-PCL, a bug was introduced
 ;;; preventing forward-references and also change-class (which
 ;;; forward-references used interally) from working properly.  One
 ;;; symptom was reported by Brian Spilsbury (sbcl-devel 2002-04-08),
@@ -139,6 +139,47 @@
     (assert (= (a-slot bar) 1))
     (assert (= (b-slot bar) 2))
     (assert (= (c-slot bar) 3))))
+
+;;; some more change-class testing, now that we have an ANSI-compliant
+;;; version (thanks to Espen Johnsen):
+(defclass from-class ()
+  ((foo :initarg :foo :accessor foo)))
+
+(defclass to-class ()
+  ((foo :initarg :foo :accessor foo)
+   (bar :initarg :bar :accessor bar)))
+
+(let* ((from (make-instance 'from-class :foo 1))
+       (to (change-class from 'to-class :bar 2)))
+  (assert (= (foo to) 1))
+  (assert (= (bar to) 2)))
+
+;;; printing a structure class should not loop indefinitely (or cause
+;;; a stack overflow):
+(defclass test-printing-structure-class ()
+  ((slot :initarg :slot))
+  (:metaclass structure-class))
+
+(print (make-instance 'test-printing-structure-class :slot 2))
+
+;;; structure-classes should behave nicely when subclassed
+(defclass super-structure ()
+  ((a :initarg :a :accessor a-accessor)
+   (b :initform 2 :reader b-reader))
+  (:metaclass structure-class))
+
+(defclass sub-structure (super-structure)
+  ((c :initarg :c :writer c-writer :accessor c-accessor))
+  (:metaclass structure-class))
+
+(let ((foo (make-instance 'sub-structure :a 1 :c 3)))
+  (assert (= (a-accessor foo) 1))
+  (assert (= (b-reader foo) 2))
+  (assert (= (c-accessor foo) 3))
+  (setf (a-accessor foo) 4)
+  (c-writer 5 foo)
+  (assert (= (a-accessor foo) 4))
+  (assert (= (c-accessor foo) 5)))
 
 ;;;; success
 

version.lisp-expr

@@ -18,4 +18,4 @@
 ;;; for internal versions, especially for internal versions off the
 ;;; main CVS branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
 
-"0.7.4.13"
+"0.7.4.14"