From: Christophe R. <cr...@us...> - 2002-06-06 12:32:17
|
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 ;;;; |