From: Christophe Rhodes Date: Thu, 6 Jun 2002 12:32:13 +0000 (+0000) Subject: 0.7.4.14: X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=372989d837526e3100b364153d58181a2a563351;p=sbcl.git 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) --- diff --git a/BUGS b/BUGS index a498227..39508d5 100644 --- a/BUGS +++ b/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 - - 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-#: diff --git a/NEWS b/NEWS index 59ebe6b..8678221 100644 --- a/NEWS +++ b/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. diff --git a/src/pcl/defclass.lisp b/src/pcl/defclass.lisp index 99f2f7a..dfba214 100644 --- a/src/pcl/defclass.lisp +++ b/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 diff --git a/src/pcl/env.lisp b/src/pcl/env.lisp index bf41126..8018e81 100644 --- a/src/pcl/env.lisp +++ b/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 diff --git a/src/pcl/generic-functions.lisp b/src/pcl/generic-functions.lisp index 0b45a7a..14916d4 100644 --- a/src/pcl/generic-functions.lisp +++ b/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)) diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp index f5a0172..0d0d1e2 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 ()) @@ -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 ;;;; diff --git a/tests/clos.impure.lisp b/tests/clos.impure.lisp index b1dd8c7..237e5ea 100644 --- a/tests/clos.impure.lisp +++ b/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 diff --git a/version.lisp-expr b/version.lisp-expr index 2ec7d5b..c1a55f2 100644 --- a/version.lisp-expr +++ b/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"