Menu
▾
▴
clisp-cvs digest, Vol 1 #433 - 4 msgs
|
From: <cli...@li...> - 2004-04-04 15:43:01
|
Send clisp-cvs mailing list submissions to cli...@li... To subscribe or unsubscribe via the World Wide Web, visit https://lists.sourceforge.net/lists/listinfo/clisp-cvs or, via email, send a message with subject or body 'help' to cli...@li... You can reach the person managing the list at cli...@li... When replying, please edit your Subject line so it is more specific than "Re: Contents of clisp-cvs digest..." CLISP CVS commits for today Today's Topics: 1. clisp/tests clos.tst,1.36,1.37 ChangeLog,1.125,1.126 (Bruno Haible) 2. clisp/src clos-class5.lisp,1.2,1.3 clos-class2.lisp,1.2,1.3 clos-slots2.lisp,1.1,1.2 documentation.lisp,1.2,1.3 ChangeLog,1.2817,1.2818 (Bruno Haible) 3. clisp/tests clos.tst,1.37,1.38 ChangeLog,1.126,1.127 (Bruno Haible) 4. clisp/src clos-class2.lisp,1.3,1.4 clos-class5.lisp,1.3,1.4 constsym.d,1.227,1.228 record.d,1.72,1.73 ChangeLog,1.2818,1.2819 (Bruno Haible) --__--__-- Message: 1 From: Bruno Haible <ha...@us...> To: cli...@li... Subject: clisp/tests clos.tst,1.36,1.37 ChangeLog,1.125,1.126 Date: Sun, 04 Apr 2004 15:24:18 +0000 Reply-To: cli...@li... Update of /cvsroot/clisp/clisp/tests In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv18814/tests Modified Files: clos.tst ChangeLog Log Message: Various fixes. Index: clos.tst =================================================================== RCS file: /cvsroot/clisp/clisp/tests/clos.tst,v retrieving revision 1.36 retrieving revision 1.37 diff -u -d -r1.36 -r1.37 --- clos.tst 21 Mar 2004 16:26:54 -0000 1.36 +++ clos.tst 4 Apr 2004 15:24:15 -0000 1.37 @@ -630,6 +630,26 @@ (< nslots-before (sys::%record-length i)))) T +;; Redefining a finalized class must not change its identity. +(let (c1 c2) + (defclass foo60-b () ()) + (defclass foo60-a (foo60-b) ()) + (make-instance 'foo60-b) + (setq c1 (find-class 'foo60-a)) + (defclass foo60-a () ()) + (setq c2 (find-class 'foo60-a)) + (eq c1 c2)) +T + +;; Redefining a non-finalized class must not change its identity. +(let (c1 c2) + (defclass foo61-a (foo61-b) ()) + (setq c1 (find-class 'foo61-a)) + (defclass foo61-a () ()) + (setq c2 (find-class 'foo61-a)) + (eq c1 c2)) +T + ;; update-instance-for-redefined-class ;; <http://www.lisp.org/HyperSpec/Body/stagenfun_upd_efined-class.html> (progn Index: ChangeLog =================================================================== RCS file: /cvsroot/clisp/clisp/tests/ChangeLog,v retrieving revision 1.125 retrieving revision 1.126 diff -u -d -r1.125 -r1.126 --- ChangeLog 1 Apr 2004 11:40:07 -0000 1.125 +++ ChangeLog 4 Apr 2004 15:24:16 -0000 1.126 @@ -1,3 +1,7 @@ +2004-03-21 Bruno Haible <br...@cl...> + + * clos.tst: Verify that redefining a class doesn't change its identity. + 2004-04-01 Bruno Haible <br...@cl...> * iofkts.tst (*print-readably*): Fix symbol printing test again. --__--__-- Message: 2 From: Bruno Haible <ha...@us...> To: cli...@li... Subject: clisp/src clos-class5.lisp,1.2,1.3 clos-class2.lisp,1.2,1.3 clos-slots2.lisp,1.1,1.2 documentation.lisp,1.2,1.3 ChangeLog,1.2817,1.2818 Date: Sun, 04 Apr 2004 15:24:17 +0000 Reply-To: cli...@li... Update of /cvsroot/clisp/clisp/src In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv18814/src Modified Files: clos-class5.lisp clos-class2.lisp clos-slots2.lisp documentation.lisp ChangeLog Log Message: Various fixes. Index: clos-class2.lisp =================================================================== RCS file: /cvsroot/clisp/clisp/src/clos-class2.lisp,v retrieving revision 1.2 retrieving revision 1.3 diff -u -d -r1.2 -r1.3 --- clos-class2.lisp 4 Apr 2004 15:19:17 -0000 1.2 +++ clos-class2.lisp 4 Apr 2004 15:24:15 -0000 1.3 @@ -77,18 +77,18 @@ (TEXT "~S: class name ~S should be a symbol") 'defclass name)) (let* ((superclass-forms - (progn - (unless (listp superclass-specs) - (error-of-type 'sys::source-program-error - (TEXT "~S ~S: expecting list of superclasses instead of ~S") - 'defclass name superclass-specs)) - (mapcar (lambda (superclass) - (unless (symbolp superclass) - (error-of-type 'sys::source-program-error - (TEXT "~S ~S: superclass name ~S should be a symbol") - 'defclass name superclass)) - `(or (FIND-CLASS ',superclass nil) ',superclass)) - superclass-specs))) + (progn + (unless (listp superclass-specs) + (error-of-type 'sys::source-program-error + (TEXT "~S ~S: expecting list of superclasses instead of ~S") + 'defclass name superclass-specs)) + (mapcar (lambda (superclass) + (unless (symbolp superclass) + (error-of-type 'sys::source-program-error + (TEXT "~S ~S: superclass name ~S should be a symbol") + 'defclass name superclass)) + `',superclass) + superclass-specs))) (accessor-def-forms '()) (slot-forms (let ((slot-names '())) @@ -317,54 +317,65 @@ (make-standard-slot-definition name allocation initargs location initer)) #|| -;; defstruct.lisp essentially contains the following. -;; In record.d and here we exploit that the first four attributes match! + ;; defstruct.lisp essentially contains the following. + ;; In record.d and here we exploit that the first four attributes match! (defstruct (structure-slot-definition (:include slot-definition) (:conc-name "DS-SLOT-") (:type vector) (:predicate nil) (:constructor make-ds-slot (name offset location initer default type readonly))) - ;;(name nil :type symbol) ; ds-slot-name = slotdef-name !! - ;;(initargs '() :type list) ; ds-slot-initargs = slotdef-initargs !! - ;;(offset nil :type (or null integer)) ; ds-slot-offset = slotdef-location !! - ;;(initer nil :type (or null cons)) ; ds-slot-initer = slotdef-initer !! - (default nil) ; ds-slot-default - (type nil) ; ds-slot-type - (readonly nil)) ; ds-slot-readonly + ;(name nil :type symbol) ; ds-slot-name = slotdef-name !! + ;(initargs '() :type list) ; ds-slot-initargs = slotdef-initargs !! + ;(offset nil :type (or null integer)) ; ds-slot-offset = slotdef-location !! + ;(initer nil :type (or null cons)) ; ds-slot-initer = slotdef-initer !! + (default nil) ; ds-slot-default + (type nil) ; ds-slot-type + (readonly nil)) ; ds-slot-readonly ||# -;; compute the difference between the set of slot of two classes +;; Compute the difference between the set of slots of two classes. (defun slot-difference (new-class old-class) (mapcar #'slotdef-name (set-difference (class-slots new-class) (class-slots old-class) :test #'eq :key #'slotdef-name))) -;; try to finalize the class, return the finalized class object on success -;; or nil when the class could not yet be finalized; -;; when force-p is non-nil, signal an error when finalization is impossible -(defvar *finalizing-now* nil) ; the stack of classes being finalized now -(defun class-finalize (class &optional force-p) +;; Try to finalize a given class, given as a class name or class object. +;; Return the finalized class object on success, or nil when the class could +;; not yet be finalized. +;; When force-p is non-nil, signal an error when finalization is impossible. +;; As a side effect of finalization, symbols in (class-direct-superclasses) are +;; replaced with class objects, and the (class-precedence-list class) is +;; computed. +(defun class-finalize (class + &optional force-p + ; The stack of classes being finalized now: + (finalizing-now nil)) (when (or (class-p class) (setq class (find-class class force-p))) - (if (class-precedence-list class) + (if (class-precedence-list class) ; already finalized? class - (do ((*finalizing-now* - (if (memq class *finalizing-now*) - (error-of-type 'sys::source-program-error - (TEXT "~S: class definition circularity: ~S depends on itself") - 'defclass class) - (cons class *finalizing-now*))) - (cds (class-direct-superclasses class) (cdr cds)) - (ready t)) - ((or (not ready) (endp cds)) - ;; If FORCE-P was non-NIL, then READY is T, otherwise - ;; an error has been signaled already. - (when ready - ;; Instances of BUILT-IN-CLASS and STRUCTURE-CLASS are already - ;; finalized when they are constructed. - (finalize-instance-standard-class class))) - (let ((fin (class-finalize (car cds) force-p))) - (if fin (setf (car cds) fin) (setq ready nil))))))) + (progn + ;; Here we get only for instances of STANDARD-CLASS, since instances + ;; of BUILT-IN-CLASS and STRUCTURE-CLASS are already finalized when + ;; they are constructed. + (when (memq class finalizing-now) + (error-of-type 'sys::source-program-error + (TEXT "~S: class definition circularity: ~S depends on itself") + 'defclass class)) + (let ((finalizing-now (cons class finalizing-now))) + (do ((superclassesr (class-direct-superclasses class) (cdr superclassesr))) + ((endp superclassesr)) + (let ((finalized-superclass + (class-finalize (car superclassesr) force-p finalizing-now))) + (unless finalized-superclass + ;; Finalization of a superclass was impossible. force-p must + ;; be nil here, otherwise an error was signaled already. So we + ;; have to return nil as well. + (return-from class-finalize nil)) + (setf (car superclassesr) finalized-superclass)))) + ;; Now compute the class-precedence-list. + (finalize-instance-standard-class class) + class)))) (defun ensure-class (name &rest all-keys &key (metaclass <standard-class>) @@ -387,58 +398,76 @@ ;; DEFSTRUCT -> (DEFCLASS ... (:METACLASS STRUCTURE-CLASS)) ;; ==> no warning, just discard the old definition, like with DEFSTRUCT (setq class nil)) - (if (and class (class-precedence-list class)) - ;; trivial changes (that can occur when doubly loading the same code) - ;; do not require updating the instances: - ;; changed slot-options :initform, :documentation, - ;; changed class-options :default-initargs, :documentation. - (if (and (equal direct-superclasses (class-direct-superclasses class)) - (equal-slots direct-slots (class-direct-slots class)) - (equal-default-initargs direct-default-initargs - (class-direct-default-initargs class))) - (progn - ;; store new slot-inits: - (do ((l-old (class-direct-slots class) (cdr l-old)) - (l-new direct-slots (cdr l-new))) - ((null l-new)) - (let ((old (getf (car l-old) ':initer)) - (new (getf (car l-new) ':initer))) - (when old - ;; move slot-initer new destructively into the slot-initer old: + ;; See which direct superclasses are already defined. + (setq direct-superclasses + (mapcar #'(lambda (c) + (if (class-p c) c (or (find-class c nil) c))) + direct-superclasses)) + (if class + (progn + ;; Normalize the (class-direct-superclasses class) in the same way as + ;; the direct-superclasses argument, so that we can compare the two + ;; lists using EQUAL. + (do ((l (class-direct-superclasses class) (cdr l))) + ((atom l)) + (let ((c (car l))) + (unless (class-p c) + (setf (car l) (or (find-class c nil) c))))) + ;; Trivial changes (that can occur when loading the same code twice) + ;; do not require updating the instances: + ;; changed slot-options :initform, :documentation, + ;; changed class-options :default-initargs, :documentation. + (if (and (equal direct-superclasses (class-direct-superclasses class)) + (equal-slots direct-slots (class-direct-slots class)) + (equal-default-initargs direct-default-initargs + (class-direct-default-initargs class))) + (progn + ;; Store new slot-inits: + (do ((l-old (class-direct-slots class) (cdr l-old)) + (l-new direct-slots (cdr l-new))) + ((null l-new)) + (let ((old (getf (car l-old) ':initer)) + (new (getf (car l-new) ':initer))) + (when old + ;; Move slot-initer new destructively into the slot-initer old: + (setf (car old) (car new)) + (setf (cdr old) (cdr new))))) + ;; Store new default-initargs: + (do ((l-old (class-direct-default-initargs class) (cddr l-old)) + (l-new direct-default-initargs (cddr l-new))) + ((null l-new)) + (let ((old (second l-old)) + (new (second l-new))) + ;; Move initer new destructively into the initer old: (setf (car old) (car new)) - (setf (cdr old) (cdr new))))) - ;; store new default-initargs: - (do ((l-old (class-direct-default-initargs class) (cddr l-old)) - (l-new direct-default-initargs (cddr l-new))) - ((null l-new)) - (let ((old (second l-old)) - (new (second l-new))) - ;; move initer new destructively into the initer old: - (setf (car old) (car new)) - (setf (cdr old) (cdr new)))) - ;; NB: These modifications are automatically inherited by the - ;; subclasses of class! - ;; modified class as value: - class) - ;; instances have to be updated - (let ((copy (copy-standard-class class))) - (setf (class-previous-definition class) copy) - (incf (class-id class)) - (apply (cond ((eq metaclass <standard-class>) - #'initialize-instance-standard-class) - ((eq metaclass <built-in-class>) - #'initialize-instance-built-in-class) - ((eq metaclass <structure-class>) - #'initialize-instance-structure-class) - (t #'initialize-instance)) - class :name name all-keys) - ;; precompute added/discarded slot lists for all previous definitions - (do ((oc copy (class-previous-definition oc))) - ((null oc)) - (setf (class-proto oc) - (cons (slot-difference class oc) - (slot-difference oc class)))) - (make-instances-obsolete class))) + (setf (cdr old) (cdr new)))) + ;; NB: These modifications are automatically inherited by the + ;; subclasses of class! + ) + ;; Instances have to be updated: + (let ((copy (copy-standard-class class))) + (setf (class-previous-definition class) copy) + (incf (class-id class)) + (apply (cond ((eq metaclass <standard-class>) + #'initialize-instance-standard-class) + ((eq metaclass <built-in-class>) + #'initialize-instance-built-in-class) + ((eq metaclass <structure-class>) + #'initialize-instance-structure-class) + (t #'initialize-instance)) + class + :name name + :direct-superclasses direct-superclasses + all-keys) + ;; Precompute added/discarded slot lists for all previous definitions: + (do ((oc copy (class-previous-definition oc))) + ((null oc)) + (setf (class-proto oc) + (cons (slot-difference class oc) + (slot-difference oc class)))) + (make-instances-obsolete class))) + ;; Modified class as value: + class) (setf (find-class name) (apply (cond ((eq metaclass <standard-class>) #'make-instance-standard-class) @@ -449,6 +478,7 @@ (t #'make-instance)) metaclass :name name + :direct-superclasses direct-superclasses all-keys))))) (defun equal-slots (slots1 slots2) (or (and (null slots1) (null slots2)) @@ -551,11 +581,10 @@ :from-end t)) (setf (class-valid-initargs class) (remove-duplicates (mapcap #'slotdef-initargs (class-slots class)))) - (system::note-new-standard-class) - class) + (system::note-new-standard-class)) ) ; let -;;; 28.1.5. Determining the Class Precedence List +;;; CLtL2 28.1.5., ANSI CL 4.3.5. Determining the Class Precedence List ;; The set of all classes forms a directed graph: Class C is located ;; below the direct superclasses of C. This graph is acyclic, because Index: clos-class5.lisp =================================================================== RCS file: /cvsroot/clisp/clisp/src/clos-class5.lisp,v retrieving revision 1.2 retrieving revision 1.3 diff -u -d -r1.2 -r1.3 --- clos-class5.lisp 4 Apr 2004 15:19:17 -0000 1.2 +++ clos-class5.lisp 4 Apr 2004 15:24:15 -0000 1.3 @@ -538,12 +538,15 @@ (defgeneric make-instances-obsolete (class) (:method ((class standard-class)) - (let ((name (class-name class))) - (warn (TEXT "~S: Class ~S (or one of its ancestors) is being redefined, instances are obsolete") - 'defclass name) + (when (class-precedence-list class) ; nothing to do if not yet finalized + (let ((name (class-name class))) + (warn (TEXT "~S: Class ~S (or one of its ancestors) is being redefined, instances are obsolete") + 'defclass name)) (mapc #'make-instances-obsolete (class-direct-subclasses class))) class) - (:method ((class symbol)) (make-instances-obsolete (find-class class)))) + (:method ((class symbol)) + (make-instances-obsolete (find-class class)) + class)) (defgeneric update-instance-for-redefined-class (instance added-slots discarded-slots property-list &rest initargs Index: documentation.lisp =================================================================== RCS file: /cvsroot/clisp/clisp/src/documentation.lisp,v retrieving revision 1.2 retrieving revision 1.3 diff -u -d -r1.2 -r1.3 --- documentation.lisp 4 Apr 2004 15:19:17 -0000 1.2 +++ documentation.lisp 4 Apr 2004 15:24:15 -0000 1.3 @@ -35,6 +35,9 @@ (:method ((x method-combination) (doc-type (eql 'method-combination))) (declare (ignore doc-type)) (method-combination-documentation x)) + (:method ((x symbol) (doc-type (eql 'method-combination))) + (declare (ignore doc-type)) + (method-combination-documentation (find-method-combination x))) (:method ((x standard-method) (doc-type (eql 't))) (declare (ignore doc-type)) (getf (gethash x sys::*documentation*) 'standard-method)) @@ -98,10 +101,14 @@ (:method (new-value (x method-combination) (doc-type (eql 't))) (declare (ignore doc-type)) (setf (method-combination-documentation x) new-value)) - (:method (new-value (x method-combination) - (doc-type (eql 'method-combination))) + (:method + (new-value (x method-combination) (doc-type (eql 'method-combination))) (declare (ignore doc-type)) (setf (method-combination-documentation x) new-value)) + (:method (new-value (x symbol) (doc-type (eql 'method-combination))) + (declare (ignore doc-type)) + (setf (method-combination-documentation (find-method-combination x)) + new-value)) (:method (new-value (x standard-method) (doc-type (eql 't))) (declare (ignore doc-type)) (sys::%set-documentation x 'standard-method new-value)) Index: clos-slots2.lisp =================================================================== RCS file: /cvsroot/clisp/clisp/src/clos-slots2.lisp,v retrieving revision 1.1 retrieving revision 1.2 diff -u -d -r1.1 -r1.2 --- clos-slots2.lisp 2 Apr 2004 10:10:51 -0000 1.1 +++ clos-slots2.lisp 4 Apr 2004 15:24:15 -0000 1.2 @@ -18,7 +18,7 @@ (:method ((class t) instance slot-name) (declare (ignore class)) (multiple-value-bind (new-value store-p) - (sys::check-value `(slot-value ,instance ,slot-name) + (sys::check-value `(slot-value ,instance ',slot-name) (make-condition 'unbound-slot :name slot-name :instance instance)) (when store-p Index: ChangeLog =================================================================== RCS file: /cvsroot/clisp/clisp/src/ChangeLog,v retrieving revision 1.2817 retrieving revision 1.2818 diff -u -d -r1.2817 -r1.2818 --- ChangeLog 4 Apr 2004 15:15:59 -0000 1.2817 +++ ChangeLog 4 Apr 2004 15:24:15 -0000 1.2818 @@ -1,5 +1,25 @@ 2004-03-21 Bruno Haible <br...@cl...> + * clos-slots2.lisp (slot-unbound): Quote the slot-name in the place. + + * clos-class2.lisp (DEFCLASS): Don't emit code to FIND-CLASS the + direct superclasses. + (ensure-class): Call FIND-CLASS on the direct superclasses here. + Call FIND-CLASS also on the old direct superclasses. Don't create a + new class object if the class exists but has not yet been finalized. + + * clos-class2.lisp (*finalizing-now*): Remove variable. + (class-finalize): Pass the finalizing-now stack as optional argument. + + * clos-class5.lisp (make-instances-obsolete): Don't do anything if the + class is not yet finalized. Return the argument unmodified, even if + it's a symbol. + + * documentation.lisp (documentation, setf documentation): Add a method + for (SYMBOL (EQL METHOD-COMBINATION)). + +2004-03-21 Bruno Haible <br...@cl...> + Remove redundant information from the DEFSTRUCT-DESCRIPTION. * defstruct.lisp (make-ds-slot): Remove 8th argument. (ds-slot-var): Remove function. --__--__-- Message: 3 From: Bruno Haible <ha...@us...> To: cli...@li... Subject: clisp/tests clos.tst,1.37,1.38 ChangeLog,1.126,1.127 Date: Sun, 04 Apr 2004 15:29:32 +0000 Reply-To: cli...@li... Update of /cvsroot/clisp/clisp/tests In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv19615/tests Modified Files: clos.tst ChangeLog Log Message: Fixes relating to class finalization. Index: clos.tst =================================================================== RCS file: /cvsroot/clisp/clisp/tests/clos.tst,v retrieving revision 1.37 retrieving revision 1.38 diff -u -d -r1.37 -r1.38 --- clos.tst 4 Apr 2004 15:24:15 -0000 1.37 +++ clos.tst 4 Apr 2004 15:29:29 -0000 1.38 @@ -650,6 +650,27 @@ (eq c1 c2)) T +;; SUBTYPEP must work on finalized classes. +(progn + (defclass foo62-b (foo62-a) ()) + (defclass foo62-c (foo62-b) ()) + (defclass foo62-a () ()) + (make-instance 'foo62-c) + (list (subtypep 'foo62-b 'foo62-b) + (subtypep 'foo62-c 'foo62-b) + (subtypep 'foo62-b 'foo62-c))) +(T T NIL) + +;; SUBTYPEP must work on non-finalized classes. +(progn + (defclass foo63-b (foo63-a) ()) + (defclass foo63-c (foo63-b) ()) + (defclass foo63-a () ()) + (list (subtypep 'foo63-b 'foo63-b) + (subtypep 'foo63-c 'foo63-b) + (subtypep 'foo63-b 'foo63-c))) +(T T NIL) + ;; update-instance-for-redefined-class ;; <http://www.lisp.org/HyperSpec/Body/stagenfun_upd_efined-class.html> (progn Index: ChangeLog =================================================================== RCS file: /cvsroot/clisp/clisp/tests/ChangeLog,v retrieving revision 1.126 retrieving revision 1.127 diff -u -d -r1.126 -r1.127 --- ChangeLog 4 Apr 2004 15:24:16 -0000 1.126 +++ ChangeLog 4 Apr 2004 15:29:30 -0000 1.127 @@ -1,5 +1,9 @@ 2004-03-21 Bruno Haible <br...@cl...> + * clos.tst: Verify that SUBTYPEP works on not-yet-finalized classes. + +2004-03-21 Bruno Haible <br...@cl...> + * clos.tst: Verify that redefining a class doesn't change its identity. 2004-04-01 Bruno Haible <br...@cl...> --__--__-- Message: 4 From: Bruno Haible <ha...@us...> To: cli...@li... Subject: clisp/src clos-class2.lisp,1.3,1.4 clos-class5.lisp,1.3,1.4 constsym.d,1.227,1.228 record.d,1.72,1.73 ChangeLog,1.2818,1.2819 Date: Sun, 04 Apr 2004 15:29:32 +0000 Reply-To: cli...@li... Update of /cvsroot/clisp/clisp/src In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv19615/src Modified Files: clos-class2.lisp clos-class5.lisp constsym.d record.d ChangeLog Log Message: Fixes relating to class finalization. Index: clos-class2.lisp =================================================================== RCS file: /cvsroot/clisp/clisp/src/clos-class2.lisp,v retrieving revision 1.3 retrieving revision 1.4 diff -u -d -r1.3 -r1.4 --- clos-class2.lisp 4 Apr 2004 15:24:15 -0000 1.3 +++ clos-class2.lisp 4 Apr 2004 15:29:29 -0000 1.4 @@ -52,6 +52,12 @@ proto) ; class prototype - an instance ; or (added . discarded) slots for old definitions +;; CLtL2 28.1.4., ANSI CL 4.3.7. Integrating Types and Classes +(defun subclassp (class1 class2) + (unless (class-precedence-list class1) (finalize-class class1 t)) + (values + (gethash class2 (class-all-superclasses class1)))) ; T or (default) NIL + ;; Access to slots of instances of the class <class> is done by means of the ;; defstruct-defined accessors, hence there are no bootstrapping-problems here. @@ -340,43 +346,6 @@ (class-slots old-class) :test #'eq :key #'slotdef-name))) -;; Try to finalize a given class, given as a class name or class object. -;; Return the finalized class object on success, or nil when the class could -;; not yet be finalized. -;; When force-p is non-nil, signal an error when finalization is impossible. -;; As a side effect of finalization, symbols in (class-direct-superclasses) are -;; replaced with class objects, and the (class-precedence-list class) is -;; computed. -(defun class-finalize (class - &optional force-p - ; The stack of classes being finalized now: - (finalizing-now nil)) - (when (or (class-p class) (setq class (find-class class force-p))) - (if (class-precedence-list class) ; already finalized? - class - (progn - ;; Here we get only for instances of STANDARD-CLASS, since instances - ;; of BUILT-IN-CLASS and STRUCTURE-CLASS are already finalized when - ;; they are constructed. - (when (memq class finalizing-now) - (error-of-type 'sys::source-program-error - (TEXT "~S: class definition circularity: ~S depends on itself") - 'defclass class)) - (let ((finalizing-now (cons class finalizing-now))) - (do ((superclassesr (class-direct-superclasses class) (cdr superclassesr))) - ((endp superclassesr)) - (let ((finalized-superclass - (class-finalize (car superclassesr) force-p finalizing-now))) - (unless finalized-superclass - ;; Finalization of a superclass was impossible. force-p must - ;; be nil here, otherwise an error was signaled already. So we - ;; have to return nil as well. - (return-from class-finalize nil)) - (setf (car superclassesr) finalized-superclass)))) - ;; Now compute the class-precedence-list. - (finalize-instance-standard-class class) - class)))) - (defun ensure-class (name &rest all-keys &key (metaclass <standard-class>) (direct-superclasses '()) @@ -386,11 +355,12 @@ &allow-other-keys) ;; Store new documentation: (when documentation (sys::%set-documentation name 'TYPE documentation)) - (let ((class (find-class name nil))) + (let ((a-standard-class-p (subclassp metaclass <standard-class>)) + (class (find-class name nil))) (when (and class (not (eq (class-name class) name))) ;; Ignore the old class if the given name is not its "proper name". (setq class nil)) - (when (and class (not (and (eq metaclass <standard-class>) + (when (and class (not (and a-standard-class-p (eq metaclass (class-of class))))) (unless (eq metaclass (class-of class)) ; mixing DEFSTRUCT & DEFCLASS (warn (TEXT "Cannot redefine ~S with a different metaclass ~S") @@ -401,18 +371,21 @@ ;; See which direct superclasses are already defined. (setq direct-superclasses (mapcar #'(lambda (c) - (if (class-p c) c (or (find-class c nil) c))) + (if (class-p c) + c + (or (find-class c (not a-standard-class-p)) c))) direct-superclasses)) (if class (progn ;; Normalize the (class-direct-superclasses class) in the same way as ;; the direct-superclasses argument, so that we can compare the two ;; lists using EQUAL. - (do ((l (class-direct-superclasses class) (cdr l))) - ((atom l)) - (let ((c (car l))) - (unless (class-p c) - (setf (car l) (or (find-class c nil) c))))) + (when (and a-standard-class-p (null (class-precedence-list class))) + (do ((l (class-direct-superclasses class) (cdr l))) + ((atom l)) + (let ((c (car l))) + (unless (class-p c) + (setf (car l) (or (find-class c nil) c)))))) ;; Trivial changes (that can occur when loading the same code twice) ;; do not require updating the instances: ;; changed slot-options :initform, :documentation, @@ -521,8 +494,6 @@ ;; --------------- Creation of an instance of <standard-class> --------------- -(let (unbound) (declare (compile)) ; unbound = #<unbound> -(defun def-unbound (x) (declare (compile)) (setq unbound x)) (defun make-instance-standard-class (metaclass &rest args &key name (direct-superclasses '()) (direct-slots '()) @@ -531,6 +502,7 @@ (declare (ignore direct-superclasses direct-slots direct-default-initargs)) (let ((class (make-standard-class :classname name :metaclass metaclass))) (apply #'initialize-instance-standard-class class args))) + (defun initialize-instance-standard-class (class &key (direct-superclasses '()) (direct-slots '()) (direct-default-initargs '()) &allow-other-keys) @@ -538,8 +510,48 @@ (setf (class-direct-slots class) direct-slots) (setf (class-direct-default-initargs class) direct-default-initargs) (setf (class-precedence-list class) nil) ; mark as not yet finalized - (class-finalize class nil) ; try to finalize it + (finalize-class class nil) ; try to finalize it class) + +;; Try to finalize a given class, given as a class name or class object. +;; Return the finalized class object on success, or nil when the class could +;; not yet be finalized. +;; When force-p is non-nil, signal an error when finalization is impossible. +;; As a side effect of finalization, symbols in (class-direct-superclasses) are +;; replaced with class objects, and the (class-precedence-list class) is +;; computed. +(defun finalize-class (class + &optional force-p + ; The stack of classes being finalized now: + (finalizing-now nil)) + (when (or (class-p class) (setq class (find-class class force-p))) + (if (class-precedence-list class) ; already finalized? + class + (progn + ;; Here we get only for instances of STANDARD-CLASS, since instances + ;; of BUILT-IN-CLASS and STRUCTURE-CLASS are already finalized when + ;; they are constructed. + (when (memq class finalizing-now) + (error-of-type 'sys::source-program-error + (TEXT "~S: class definition circularity: ~S depends on itself") + 'defclass class)) + (let ((finalizing-now (cons class finalizing-now))) + (do ((superclassesr (class-direct-superclasses class) (cdr superclassesr))) + ((endp superclassesr)) + (let ((finalized-superclass + (finalize-class (car superclassesr) force-p finalizing-now))) + (unless finalized-superclass + ;; Finalization of a superclass was impossible. force-p must + ;; be nil here, otherwise an error was signaled already. So we + ;; have to return nil as well. + (return-from finalize-class nil)) + (setf (car superclassesr) finalized-superclass)))) + ;; Now compute the class-precedence-list. + (finalize-instance-standard-class class) + class)))) + +(let (unbound) (declare (compile)) ; unbound = #<unbound> +(defun def-unbound (x) (declare (compile)) (setq unbound x)) (defun finalize-instance-standard-class (class &aux (direct-superclasses (class-direct-superclasses class)) (name (class-name class))) @@ -1029,11 +1041,6 @@ (sys::%record-ref (allocate-std-instance <standard-object> 3) 2))) -;; CLtL2 28.1.4., ANSI CL 4.3.7. Integrating Types and Classes -(defun subclassp (class1 class2) - (values - (gethash class2 (class-all-superclasses class1)))) ; T or (default) NIL - ;;; install built-in-classes ;; table 28-1, CLtL2 p. 783 (macrolet ((def (&rest classes &aux (new (car (last classes)))) Index: clos-class5.lisp =================================================================== RCS file: /cvsroot/clisp/clisp/src/clos-class5.lisp,v retrieving revision 1.3 retrieving revision 1.4 diff -u -d -r1.3 -r1.4 --- clos-class5.lisp 4 Apr 2004 15:24:15 -0000 1.3 +++ clos-class5.lisp 4 Apr 2004 15:29:29 -0000 1.4 @@ -358,7 +358,7 @@ #|| (defgeneric allocate-instance (class) (:method ((class standard-class)) - (unless (class-precedence-list class) (class-finalize class t)) + (unless (class-precedence-list class) (finalize-class class t)) (allocate-std-instance class (class-instance-size class))) (:method ((class structure-class)) (sys::%make-structure (class-names class) (class-instance-size class) @@ -370,7 +370,7 @@ ;; Quick and dirty dispatch among <standard-class> and <structure-class>. ;; (class-shared-slots class) is a simple-vector, (class-names class) a cons. (if (atom (class-shared-slots class)) - (progn (unless (class-precedence-list class) (class-finalize class t)) + (progn (unless (class-precedence-list class) (finalize-class class t)) (allocate-std-instance class (class-instance-size class))) (sys::%make-structure (class-names class) (class-instance-size class) :initial-element unbound))) @@ -571,7 +571,7 @@ (:method ((name symbol)) (class-finalized-p (find-class name)))) (defgeneric finalize-inheritance (class) - (:method ((class standard-class)) (class-finalize class t)) + (:method ((class standard-class)) (finalize-class class t)) (:method ((name symbol)) (finalize-inheritance (find-class name)))) ;;; Utility functions Index: constsym.d =================================================================== RCS file: /cvsroot/clisp/clisp/src/constsym.d,v retrieving revision 1.227 retrieving revision 1.228 diff -u -d -r1.227 -r1.228 --- constsym.d 24 Mar 2004 20:38:46 -0000 1.227 +++ constsym.d 4 Apr 2004 15:29:29 -0000 1.228 @@ -751,7 +751,6 @@ LISPSYM(structure_object_p,"STRUCTURE-OBJECT-P",clos) LISPSYM(std_instance_p,"STD-INSTANCE-P",clos) LISPSYM(allocate_std_instance,"ALLOCATE-STD-INSTANCE",clos) -LISPSYM(class_finalize,"CLASS-FINALIZE",clos) LISPSYM(pallocate_instance,"%ALLOCATE-INSTANCE",clos) LISPSYM(slot_value,"SLOT-VALUE",clos) LISPSYM(set_slot_value,"SET-SLOT-VALUE",clos) @@ -1271,6 +1270,7 @@ LISPSYM(initial_initialize_instance,"INITIAL-INITIALIZE-INSTANCE",clos) /* function for RECORD */ LISPSYM(initial_make_instance,"INITIAL-MAKE-INSTANCE",clos) /* function for RECORD */ LISPSYM(allocate_instance,"ALLOCATE-INSTANCE",clos) /* function for RECORD */ +LISPSYM(finalize_class,"FINALIZE-CLASS",clos) /* function for RECORD */ LISPSYM(simple_vector,"SIMPLE-VECTOR",lisp) /* type in SEQUENCE, PREDTYPE */ LISPSYM(simple_string,"SIMPLE-STRING",lisp) /* type in SEQUENCE, PREDTYPE */ LISPSYM(base_string,"BASE-STRING",lisp) /* type in SEQUENCE, PREDTYPE */ Index: record.d =================================================================== RCS file: /cvsroot/clisp/clisp/src/record.d,v retrieving revision 1.72 retrieving revision 1.73 diff -u -d -r1.72 -r1.73 --- record.d 1 Apr 2004 10:12:06 -0000 1.72 +++ record.d 4 Apr 2004 15:29:29 -0000 1.73 @@ -827,7 +827,7 @@ pushSTACK(clas); /* save for ALLOCATE-STD-INSTANCE */ if (nullp(TheClass(clas)->precedence_list)) { /* finalize */ pushSTACK(clas); pushSTACK(T); - funcall(S(class_finalize),2); + funcall(S(finalize_class),2); } /* (CLOS::ALLOCATE-STD-INSTANCE class (class-instance-size class)) */ pushSTACK(TheClass(clas)->instance_size); @@ -1401,7 +1401,7 @@ var object clas = Before(rest_args_pointer); if (nullp(TheClass(clas)->precedence_list)) { /* finalize */ pushSTACK(clas); pushSTACK(T); - funcall(S(class_finalize),2); + funcall(S(finalize_class),2); clas = Before(rest_args_pointer); } var object l = TheClass(clas)->default_initargs; Index: ChangeLog =================================================================== RCS file: /cvsroot/clisp/clisp/src/ChangeLog,v retrieving revision 1.2818 retrieving revision 1.2819 diff -u -d -r1.2818 -r1.2819 --- ChangeLog 4 Apr 2004 15:24:15 -0000 1.2818 +++ ChangeLog 4 Apr 2004 15:29:29 -0000 1.2819 @@ -1,5 +1,19 @@ 2004-03-21 Bruno Haible <br...@cl...> + * clos-class2.lisp (finalize-class): Renamed from class-finalize. + (initialize-instance-standard-class): Update. + * clos-class5.lisp (finalize-inheritance): Update. + * record.d (do_allocate_instance, CLOS::%MAKE-INSTANCE): Update. + + * clos-class2.lisp (ensure-class): Treat metaclasses that are + subclasses of <standard-class> like <standard-class> itself. For + other metaclasses, invoke FIND-CLASS with force-p = t. + + * clos-class2.lisp (subclassp): Finalize the class before accessing + its superclasses table. + +2004-03-21 Bruno Haible <br...@cl...> + * clos-slots2.lisp (slot-unbound): Quote the slot-name in the place. * clos-class2.lisp (DEFCLASS): Don't emit code to FIND-CLASS the --__--__-- _______________________________________________ clisp-cvs mailing list cli...@li... https://lists.sourceforge.net/lists/listinfo/clisp-cvs End of clisp-cvs Digest |