[Sbcl-commits] CVS: sbcl/src/pcl defclass.lisp,1.21,1.22 env.lisp,1.7,1.8 generic-functions.lisp,1.8,1.9 std-class.lisp,1.23,1.24

[Christophe R. <cr...@us...>]

Update of /cvsroot/sbcl/sbcl/src/pcl
In directory usw-pr-cvs1:/tmp/cvs-serv2103/src/pcl

Modified Files:
	defclass.lisp env.lisp generic-functions.lisp std-class.lisp 
Log Message:
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)


Index: defclass.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/pcl/defclass.lisp,v
retrieving revision 1.21
retrieving revision 1.22
diff -u -d -r1.21 -r1.22
--- defclass.lisp	14 Feb 2002 03:38:06 -0000	1.21
+++ defclass.lisp	6 Jun 2002 12:32:13 -0000	1.22
@@ -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

Index: env.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/pcl/env.lisp,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -d -r1.7 -r1.8
--- env.lisp	13 Jan 2002 01:36:20 -0000	1.7
+++ env.lisp	6 Jun 2002 12:32:13 -0000	1.8
@@ -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

Index: generic-functions.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/pcl/generic-functions.lisp,v
retrieving revision 1.8
retrieving revision 1.9
diff -u -d -r1.8 -r1.9
--- generic-functions.lisp	14 Feb 2002 03:38:06 -0000	1.8
+++ generic-functions.lisp	6 Jun 2002 12:32:13 -0000	1.9
@@ -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))
 

Index: std-class.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/pcl/std-class.lisp,v
retrieving revision 1.23
retrieving revision 1.24
diff -u -d -r1.23 -r1.24
--- std-class.lisp	18 May 2002 22:13:07 -0000	1.23
+++ std-class.lisp	6 Jun 2002 12:32:13 -0000	1.24
@@ -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
 ;;;;