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)
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-#:
* 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.
'(: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
(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
(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))
(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))
(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 ())
plist)
nwrapper)))
\f
-(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))
;; 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))
\f
;;;; The metaclass BUILT-IN-CLASS
;;;;
(defgeneric born-to-be-redefined (x))
(assert (eq (born-to-be-redefined 1) 'int))
\f
-;;; 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),
(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)))
+\f
+;;; 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)))
\f
;;;; success
;;; 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"
projects / sbcl.git / commitdiff