From: <cli...@li...> - 2004-11-24 12:10:21
|
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/src/po Makefile.devel,1.34,1.35 (Bruno Haible) 2. clisp/src clos-class1.lisp,1.26,1.27 clos-class2.lisp,1.48,1.49 clos-class3.lisp,1.73,1.74 clos-class6.lisp,1.30,1.31 clos-print.lisp,1.17,1.18 clos-custom.lisp,1.1,1.2 ChangeLog,1.3842,1.3843 (Bruno Haible) 3. clisp/tests clos.tst,1.80,1.81 mop.tst,1.31,1.32 ChangeLog,1.268,1.269 (Bruno Haible) 4. clisp/src clos-custom.lisp,NONE,1.1 (Bruno Haible) 5. clisp/doc mop.xml,2.45,2.46 (Bruno Haible) --__--__-- Message: 1 From: Bruno Haible <ha...@us...> To: cli...@li... Subject: clisp/src/po Makefile.devel,1.34,1.35 Date: Wed, 24 Nov 2004 11:41:11 +0000 Reply-To: cli...@li... Update of /cvsroot/clisp/clisp/src/po In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv16835/src/po Modified Files: Makefile.devel Log Message: Repair part of the forward-referenced-class misdesign: <forward-referenced-class> should not inherit from <class>. Index: Makefile.devel =================================================================== RCS file: /cvsroot/clisp/clisp/src/po/Makefile.devel,v retrieving revision 1.34 retrieving revision 1.35 diff -u -d -r1.34 -r1.35 --- Makefile.devel 22 Oct 2004 10:55:03 -0000 1.34 +++ Makefile.devel 24 Nov 2004 11:41:09 -0000 1.35 @@ -59,7 +59,7 @@ clos-method1 clos-method2 clos-method3 clos-method4 \ clos-methcomb1 clos-methcomb2 clos-methcomb3 clos-methcomb4 \ clos-genfun1 clos-genfun2a clos-genfun2b clos-genfun3 clos-genfun4 clos-genfun5 \ - clos-dependent clos-print documentation \ + clos-dependent clos-print clos-custom documentation \ fill-out disassem condition loadform gstream xcharin keyboard \ screen beossock runprog query reploop dribble complete \ describe room edit macros3 clhs inspect gray \ --__--__-- Message: 2 From: Bruno Haible <ha...@us...> To: cli...@li... Subject: clisp/src clos-class1.lisp,1.26,1.27 clos-class2.lisp,1.48,1.49 clos-class3.lisp,1.73,1.74 clos-class6.lisp,1.30,1.31 clos-print.lisp,1.17,1.18 clos-custom.lisp,1.1,1.2 ChangeLog,1.3842,1.3843 Date: Wed, 24 Nov 2004 11:46:38 +0000 Reply-To: cli...@li... Update of /cvsroot/clisp/clisp/src In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv17912/src Modified Files: clos-class1.lisp clos-class2.lisp clos-class3.lisp clos-class6.lisp clos-print.lisp clos-custom.lisp ChangeLog Log Message: Repair the rest of the forward-referenced-class misdesign: <forward-referenced-class> should not inherit from <specializer>. Index: clos-class2.lisp =================================================================== RCS file: /cvsroot/clisp/clisp/src/clos-class2.lisp,v retrieving revision 1.48 retrieving revision 1.49 diff -u -d -r1.48 -r1.49 --- clos-class2.lisp 24 Nov 2004 11:41:11 -0000 1.48 +++ clos-class2.lisp 24 Nov 2004 11:46:36 -0000 1.49 @@ -12,12 +12,14 @@ ;; Metaclasses: (defvar <potential-class>) ; <standard-class> -(defvar <forward-referenced-class>) ; <standard-class> (defvar <defined-class>) ; <standard-class> (defvar <standard-class>) ; <standard-class> (defvar <funcallable-standard-class>) ; <standard-class> (defvar <structure-class>) ; <standard-class> (defvar <built-in-class>) ; <standard-class> +;; Not really metaclasses: +(defvar <forward-reference-to-class>) ; <standard-class> +(defvar <misdesigned-forward-referenced-class>) ; <standard-class> ;; Classes: (defvar <standard-object>) ; <standard-class> (defvar <funcallable-standard-object>) ; <funcallable-standard-class> @@ -110,7 +112,7 @@ ;; says that "the class object itself is not affected". (sys::check-redefinition symbol '(setf find-class) (and (defined-class-p h) "class")) - (when (and h (typep-class h <forward-referenced-class>) new-value) + (when (and h (forward-reference-to-class-p h) new-value) ;; Move the list of subclasses from the old class object to the new one. (dolist (subclass (class-direct-subclasses h)) (add-direct-subclass new-value subclass)))) Index: clos-class6.lisp =================================================================== RCS file: /cvsroot/clisp/clisp/src/clos-class6.lisp,v retrieving revision 1.30 retrieving revision 1.31 diff -u -d -r1.30 -r1.31 --- clos-class6.lisp 24 Nov 2004 11:41:12 -0000 1.30 +++ clos-class6.lisp 24 Nov 2004 11:46:36 -0000 1.31 @@ -56,8 +56,8 @@ (:method ((class defined-class)) (check-class-initialized class 1) (class-classname class)) - (:method ((class forward-referenced-class)) - (class-classname class))) + (:method ((class forward-reference-to-class)) + (slot-value class '$classname))) ; No extended method check because this GF is specified in ANSI CL. ;(initialize-extended-method-check #'class-name) ;; MOP p. 92 @@ -78,17 +78,21 @@ ;; Not in MOP. (defun class-direct-subclasses-table (class) - (accessor-typecheck class 'potential-class 'class-direct-subclasses-table) - (sys::%record-ref class *<potential-class>-direct-subclasses-location*)) + (accessor-typecheck class 'super-class 'class-direct-subclasses-table) + (if (potential-class-p class) + (sys::%record-ref class *<potential-class>-direct-subclasses-location*) + (slot-value class '$direct-subclasses))) (defun (setf class-direct-subclasses-table) (new-value class) - (accessor-typecheck class 'potential-class '(setf class-direct-subclasses-table)) - (setf (sys::%record-ref class *<potential-class>-direct-subclasses-location*) new-value)) + (accessor-typecheck class 'super-class '(setf class-direct-subclasses-table)) + (if (potential-class-p class) + (setf (sys::%record-ref class *<potential-class>-direct-subclasses-location*) new-value) + (setf (slot-value class '$direct-subclasses) new-value))) ;; MOP p. 76 (defgeneric class-direct-subclasses (class) (:method ((class defined-class)) (check-class-initialized class 2) (list-direct-subclasses class)) - (:method ((class forward-referenced-class)) + (:method ((class forward-reference-to-class)) (list-direct-subclasses class))) ;; MOP p. 76 @@ -96,10 +100,10 @@ (:method ((class defined-class)) (check-class-initialized class 2) (sys::%record-ref class *<defined-class>-direct-superclasses-location*)) - (:method ((class forward-referenced-class)) + (:method ((class forward-reference-to-class)) ;; Broken MOP. Any use of this method is a bug. (warn (TEXT "~S being called on ~S, but class ~S is not yet defined.") - 'class-direct-superclasses class (class-classname class)) + 'class-direct-superclasses class (class-name class)) '())) (initialize-extended-method-check #'class-direct-superclasses) ;; Not in MOP. @@ -131,10 +135,10 @@ (:method ((class defined-class)) (check-class-initialized class 2) (sys::%record-ref class *<defined-class>-direct-slots-location*)) - (:method ((class forward-referenced-class)) + (:method ((class forward-reference-to-class)) ;; Broken MOP. Any use of this method is a bug. (warn (TEXT "~S being called on ~S, but class ~S is not yet defined.") - 'class-direct-slots class (class-classname class)) + 'class-direct-slots class (class-name class)) '())) (initialize-extended-method-check #'class-direct-slots) ;; Not in MOP. @@ -166,10 +170,10 @@ (:method ((class defined-class)) (check-class-initialized class 2) (sys::%record-ref class *<defined-class>-direct-default-initargs-location*)) - (:method ((class forward-referenced-class)) + (:method ((class forward-reference-to-class)) ;; Broken MOP. Any use of this method is a bug. (warn (TEXT "~S being called on ~S, but class ~S is not yet defined.") - 'class-direct-default-initargs class (class-classname class)) + 'class-direct-default-initargs class (class-name class)) '())) (initialize-extended-method-check #'class-direct-default-initargs) ;; Not in MOP. @@ -354,7 +358,7 @@ (defgeneric class-finalized-p (class) (:method ((class defined-class)) (= (class-initialized class) 6)) - (:method ((class forward-referenced-class)) + (:method ((class forward-reference-to-class)) nil) ;; CLISP extension: Convenience method on symbols. (:method ((name symbol)) @@ -446,12 +450,12 @@ ;; MOP p. 32 (defgeneric add-direct-subclass (class subclass) - (:method ((class potential-class) (subclass potential-class)) + (:method ((class super-class) (subclass potential-class)) (add-direct-subclass-internal class subclass))) ;; MOP p. 90 (defgeneric remove-direct-subclass (class subclass) - (:method ((class potential-class) (subclass potential-class)) + (:method ((class super-class) (subclass potential-class)) (remove-direct-subclass-internal class subclass))) ;;; =========================================================================== Index: clos-custom.lisp =================================================================== RCS file: /cvsroot/clisp/clisp/src/clos-custom.lisp,v retrieving revision 1.1 retrieving revision 1.2 diff -u -d -r1.1 -r1.2 --- clos-custom.lisp 24 Nov 2004 11:39:54 -0000 1.1 +++ clos-custom.lisp 24 Nov 2004 11:46:36 -0000 1.2 @@ -25,26 +25,43 @@ (when val (setq val 't)) (if val (unless (eq (find-class 'class) <potential-class>) - (set-<class>-<potential-class>)) + (set-<class>-<potential-class>) + (set-<forward-referenced-class>-<misdesigned-forward-referenced-class>)) (unless (eq (find-class 'class) <defined-class>) - (set-<class>-<defined-class>))) + (set-<class>-<defined-class>) + (set-<forward-referenced-class>-<forward-reference-to-class>))) (setq *<forward-referenced-class>-under-<class>* val) val) (defun set-<class>-<potential-class> () - (setf (class-classname <defined-class>) 'defined-class) - (setf (class-classname <potential-class>) 'class) - (setf (find-class 'class) <potential-class>) - (setf (get 'class 'sys::type-symbol) (get 'potential-class 'sys::type-symbol))) + (ext:without-package-lock ("CLOS") + (setf (class-classname <defined-class>) 'defined-class) + (setf (class-classname <potential-class>) 'class) + (setf (find-class 'class) <potential-class>) + (setf (get 'class 'sys::type-symbol) (get 'potential-class 'sys::type-symbol)))) (defun set-<class>-<defined-class> () - (setf (class-classname <potential-class>) 'potential-class) - (setf (class-classname <defined-class>) 'class) - (setf (find-class 'class) <defined-class>) - (setf (get 'class 'sys::type-symbol) (get 'defined-class 'sys::type-symbol))) + (ext:without-package-lock ("CLOS") + (setf (class-classname <potential-class>) 'potential-class) + (setf (class-classname <defined-class>) 'class) + (setf (find-class 'class) <defined-class>) + (setf (get 'class 'sys::type-symbol) (get 'defined-class 'sys::type-symbol)))) + +(defun set-<forward-referenced-class>-<misdesigned-forward-referenced-class> () + (ext:without-package-lock ("CLOS") + (setf (class-classname <forward-reference-to-class>) 'forward-reference-to-class) + (setf (class-classname <misdesigned-forward-referenced-class>) 'forward-referenced-class) + (setf (find-class 'forward-referenced-class) <misdesigned-forward-referenced-class>))) + +(defun set-<forward-referenced-class>-<forward-reference-to-class> () + (ext:without-package-lock ("CLOS") + (setf (class-classname <misdesigned-forward-referenced-class>) 'misdesigned-forward-referenced-class) + (setf (class-classname <forward-reference-to-class>) 'forward-referenced-class) + (setf (find-class 'forward-referenced-class) <forward-reference-to-class>))) ; Initial setting: (set-<class>-<defined-class>) +(set-<forward-referenced-class>-<forward-reference-to-class>) ;; ============================================================================ Index: clos-print.lisp =================================================================== RCS file: /cvsroot/clisp/clisp/src/clos-print.lisp,v retrieving revision 1.17 retrieving revision 1.18 diff -u -d -r1.17 -r1.18 --- clos-print.lisp 24 Nov 2004 11:41:12 -0000 1.17 +++ clos-print.lisp 24 Nov 2004 11:46:36 -0000 1.18 @@ -21,6 +21,9 @@ (:method ((object potential-class) stream) (print-object-<potential-class> object stream) object) + (:method ((object forward-reference-to-class) stream) + (print-object-<forward-reference-to-class> object stream) + object) (:method ((object slot-definition) stream) (print-object-<slot-definition> object stream) object) Index: ChangeLog =================================================================== RCS file: /cvsroot/clisp/clisp/src/ChangeLog,v retrieving revision 1.3842 retrieving revision 1.3843 diff -u -d -r1.3842 -r1.3843 --- ChangeLog 24 Nov 2004 11:41:13 -0000 1.3842 +++ ChangeLog 24 Nov 2004 11:46:36 -0000 1.3843 @@ -1,3 +1,64 @@ +2004-11-19 Bruno Haible <br...@cl...> + + Repair the rest of the forward-referenced-class misdesign. + * clos-class1.lisp (super-class): New class. + (*<super-class>-defclass*): New variable. + (potential-class): Inherit all slots from super-class. + (class-direct-subclasses-table): Make it work also for objects + that are not of type <potential-class>. + (forward-referenced-class): Remove class. + (*<forward-referenced-class>-defclass*): Remove variable. + (forward-reference-to-class): New class. + (*<forward-reference-to-class>-defclass*): New variable. + (misdesigned-forward-referenced-class): New class. + (*<misdesigned-forward-referenced-class>-defclass*): New variable. + (shared-initialize-<defined-class>): Test for defined-class or + forward-reference-to-class, instead of for potential-class. + (forward-reference-to-class-p): New function. + (print-object-<forward-reference-to-class>): New function. + * clos-class2.lisp (<forward-referenced-class>): Remove variable. + (<forward-reference-to-class>, <misdesigned-forward-referenced-class>): + New variables. + ((setf find-class)): Use forward-reference-to-class-p instead of typep. + * clos-class3.lisp (ensure-class-using-class-<t>): Test for + defined-class or forward-reference-to-class, instead of for + potential-class. + (reinitialize-instance-<defined-class>): Likewise. + (finalize-class): Likewise. + Define <super-class>. + Define <forward-reference-to-class>, + <misdesigned-forward-referenced-class> instead of + <forward-referenced-class>. + * clos-class6.lisp (class-name@forward-reference-to-class): Renamed + from class-name@forward-referenced-class. Don't use class-classname. + (class-direct-subclasses-table): Make it work also for objects that are + not of type <potential-class>. + (class-direct-subclasses@forward-reference-to-class): Renamed from + class-direct-subclasses@forward-referenced-class. + (class-direct-superclasses@forward-reference-to-class): Renamed from + class-direct-superclasses@forward-referenced-class. Don't use + class-classname. + (class-direct-slots@forward-reference-to-class): Renamed from + class-direct-slots@forward-referenced-class. Don't use class-classname. + (class-direct-default-initargs@forward-reference-to-class): Renamed + from class-direct-default-initargs@forward-referenced-class. Don't use + class-classname. + (class-finalized-p@forward-reference-to-class): Renamed from + class-finalized-p@forward-referenced-class. + (add-direct-subclass@super-class@potential-class): Renamed from + add-direct-subclass@potential-class@potential-class. + (remove-direct-subclass@super-class@potential-class): Renamed from + remove-direct-subclass@potential-class@potential-class. + * clos-print.lisp (print-object@forward-reference-to-class): New + method. + * clos-custom.lisp ((setf <forward-referenced-class>-under-<class>)): + Call also set-<forward-referenced-class>-... + (set-<class>-<potential-class>, set-<class>-<defined-class>): Disable + package lock. + (set-<forward-referenced-class>-<misdesigned-forward-referenced-class>, + set-<forward-referenced-class>-<forward-reference-to-class>): New + functions. + 2004-11-18 Bruno Haible <br...@cl...> Repair part of the forward-referenced-class misdesign. Index: clos-class3.lisp =================================================================== RCS file: /cvsroot/clisp/clisp/src/clos-class3.lisp,v retrieving revision 1.73 retrieving revision 1.74 diff -u -d -r1.73 -r1.74 --- clos-class3.lisp 24 Nov 2004 11:41:11 -0000 1.73 +++ clos-class3.lisp 24 Nov 2004 11:46:36 -0000 1.74 @@ -451,7 +451,11 @@ (unless (proper-list-p direct-superclasses) (error (TEXT "~S for class ~S: The ~S argument should be a proper list, not ~S") 'ensure-class-using-class name ':direct-superclasses direct-superclasses)) - (unless (every #'(lambda (x) (or (potential-class-p x) (symbolp x))) direct-superclasses) + (unless (every #'(lambda (x) + (or (defined-class-p x) + (forward-reference-to-class-p x) + (symbolp x))) + direct-superclasses) (error (TEXT "~S for class ~S: The direct-superclasses list should consist of classes and symbols, not ~S") 'ensure-class-using-class name direct-superclasses)) ;; Ignore the old class if the given name is not its "proper name". @@ -493,7 +497,7 @@ (mapcar #'(lambda (c) (if (defined-class-p c) c - (let ((cn (if (potential-class-p c) (class-name c) c))) + (let ((cn (if (forward-reference-to-class-p c) (class-name c) c))) (assert (symbolp cn)) (if a-semi-standard-class-p ;; Need a class. Allocate a forward-referenced-class @@ -600,7 +604,7 @@ (let ((c (car l))) (unless (defined-class-p c) (let ((new-c - (let ((cn (if (potential-class-p c) (class-name c) c))) + (let ((cn (if (forward-reference-to-class-p c) (class-name c) c))) (assert (symbolp cn)) ;; Need a class. Allocate a forward-referenced-class ;; if none is yet allocated. @@ -613,7 +617,7 @@ ; changed from forward-referenced-class to defined-class (check-allowed-superclass class new-c)) (setf (car l) new-c) - (when (potential-class-p c) + (when (or (defined-class-p c) (forward-reference-to-class-p c)) (remove-direct-subclass c class)) (add-direct-subclass new-c class)))))))) (when direct-slots-p @@ -820,7 +824,7 @@ ;; Returns the currently existing direct subclasses, as a freshly consed list. (defun list-direct-subclasses (class) ...) |# -(def-weak-set-accessors class-direct-subclasses-table class +(def-weak-set-accessors class-direct-subclasses-table defined-class add-direct-subclass-internal remove-direct-subclass-internal list-direct-subclasses) @@ -1882,7 +1886,7 @@ (finalizing-now nil)) (when (or (defined-class-p class) (setq class - (find-class (if (potential-class-p class) (class-name class) class) + (find-class (if (forward-reference-to-class-p class) (class-name class) class) force-p))) (if (>= (class-initialized class) 6) ; already finalized? class @@ -2403,7 +2407,9 @@ (macrolet ((form () *<specializer>-defclass*)) (form)) - ;; 6. Define the class <potential-class>. + ;; 6. Define the classes <super-class>, <potential-class>. + (macrolet ((form () *<super-class>-defclass*)) + (form)) (setq <potential-class> (macrolet ((form () *<potential-class>-defclass*)) (form))) @@ -2504,9 +2510,13 @@ (replace-class-version (find-class 'eql-specializer) *<eql-specializer>-class-version*) - ;; Define the class <forward-referenced-class>. - (setq <forward-referenced-class> - (macrolet ((form () *<forward-referenced-class>-defclass*)) + ;; Define the classes <forward-reference-to-class>, + ;; <misdesigned-forward-referenced-class>. + (setq <forward-reference-to-class> + (macrolet ((form () *<forward-reference-to-class>-defclass*)) + (form))) + (setq <misdesigned-forward-referenced-class> + (macrolet ((form () *<misdesigned-forward-referenced-class>-defclass*)) (form))) );progn Index: clos-class1.lisp =================================================================== RCS file: /cvsroot/clisp/clisp/src/clos-class1.lisp,v retrieving revision 1.26 retrieving revision 1.27 diff -u -d -r1.26 -r1.27 --- clos-class1.lisp 24 Nov 2004 11:41:11 -0000 1.26 +++ clos-class1.lisp 24 Nov 2004 11:46:36 -0000 1.27 @@ -40,11 +40,11 @@ ;;; =========================================================================== -;;; The abstract class <potential-class> allows defined classes and +;;; The abstract class <super-class> allows defined classes and ;;; forward-references to classes to be treated in a homogenous way. -(defvar *<potential-class>-defclass* - '(defclass potential-class (specializer) +(defvar *<super-class>-defclass* + '(defclass super-class (standard-stablehash metaobject) (($classname ; (class-name class) = (class-classname class), ; a symbol :type symbol @@ -53,6 +53,16 @@ ; weak-hash-table or NIL :type (or hash-table weak-list null) :initform nil)) + (:fixed-slot-locations nil))) + +;;; =========================================================================== + +;;; The abstract class <potential-class> is the abstract base class of all +;;; classes. + +(defvar *<potential-class>-defclass* + '(defclass potential-class (specializer super-class) + () (:fixed-slot-locations t))) ;; Fixed slot locations. @@ -65,9 +75,13 @@ (predefun (setf class-classname) (new-value object) (setf (sys::%record-ref object *<potential-class>-classname-location*) new-value)) (predefun class-direct-subclasses-table (object) - (sys::%record-ref object *<potential-class>-direct-subclasses-location*)) + (if (potential-class-p object) + (sys::%record-ref object *<potential-class>-direct-subclasses-location*) + (slot-value object '$direct-subclasses))) (predefun (setf class-direct-subclasses-table) (new-value object) - (setf (sys::%record-ref object *<potential-class>-direct-subclasses-location*) new-value)) + (if (potential-class-p object) + (setf (sys::%record-ref object *<potential-class>-direct-subclasses-location*) new-value) + (setf (slot-value object '$direct-subclasses) new-value))) ;; Initialization of a <potential-class> instance. (defun shared-initialize-<potential-class> (class situation &rest args @@ -120,16 +134,25 @@ ;;; ;;; A better design would be to define an abstract class <superclass> and ;;; let <forward-referenced-class> inherit from it: -;;; (defclass superclass () ...) -;;; (defclass class (superclass specializer) ...) -;;; (defclass forward-referenced-class (superclass) ...) +;;; (defclass super-class () ...) +;;; (defclass class (super-class specializer) ...) +;;; (defclass forward-referenced-class (super-class) ...) ;;; and (class-direct-superclasses class) would simply be a list of -;;; <superclass> instances. +;;; <super-class> instances. -(defvar *<forward-referenced-class>-defclass* - '(defclass forward-referenced-class (potential-class) +;; The proper <forward-referenced-class> inherits from <super-class> but +;; not from <specializer>. +(defvar *<forward-reference-to-class>-defclass* + '(defclass forward-reference-to-class (super-class) () - (:fixed-slot-locations t))) + (:fixed-slot-locations nil))) + +;; The crappy <forward-referenced-class> from the MOP is subclass of +;; <potential-class> and thus also of <specializer>. +(defvar *<misdesigned-forward-referenced-class>-defclass* + '(defclass misdesigned-forward-referenced-class (forward-reference-to-class potential-class) + () + (:fixed-slot-locations nil))) ;;; =========================================================================== @@ -293,7 +316,10 @@ (error (TEXT "(~S ~S) for class ~S: The ~S argument should be a proper list, not ~S") (if (eq situation 't) 'initialize-instance 'shared-initialize) 'class name ':direct-superclasses direct-superclasses)) - (unless (every #'potential-class-p direct-superclasses) + (unless (every #'(lambda (x) + (or (defined-class-p x) + (forward-reference-to-class-p x))) + direct-superclasses) (error (TEXT "(~S ~S) for class ~S: The direct-superclasses list should consist of classes, not ~S") (if (eq situation 't) 'initialize-instance 'shared-initialize) 'class name direct-superclasses)) @@ -632,6 +658,11 @@ (sys::def-atomic-type structure-class structure-class-p) (sys::def-atomic-type standard-class standard-class-p) +(defun forward-reference-to-class-p (object) + (and (std-instance-p object) + (gethash <forward-reference-to-class> + (class-all-superclasses (class-of object))))) + ;;; =========================================================================== ;;; Copying. @@ -667,6 +698,10 @@ (write-string " " stream) (write :uninitialized :stream stream))))))) +(defun print-object-<forward-reference-to-class> (object stream) + (print-unreadable-object (object stream :type t) + (write (slot-value object '$classname) :stream stream))) + ;; Preliminary. ;; Now we can at least print classes. (predefun print-object (object stream) --__--__-- Message: 3 From: Bruno Haible <ha...@us...> To: cli...@li... Subject: clisp/tests clos.tst,1.80,1.81 mop.tst,1.31,1.32 ChangeLog,1.268,1.269 Date: Wed, 24 Nov 2004 11:47:02 +0000 Reply-To: cli...@li... Update of /cvsroot/clisp/clisp/tests In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv18087/tests Modified Files: clos.tst mop.tst ChangeLog Log Message: Test the forward-referenced-class behaviour with both settings of *forward-referenced-class-misdesign*. Index: mop.tst =================================================================== RCS file: /cvsroot/clisp/clisp/tests/mop.tst,v retrieving revision 1.31 retrieving revision 1.32 diff -u -d -r1.31 -r1.32 --- mop.tst 23 Nov 2004 11:35:00 -0000 1.31 +++ mop.tst 24 Nov 2004 11:47:00 -0000 1.32 @@ -286,8 +286,9 @@ ;; Check that undefined classes are treated as undefined, even though they ;; are represented by a FORWARD-REFERENCED-CLASS. (progn - (defclass foo132 (forwardclass02) ()) - (defparameter *forwardclass* (first (clos:class-direct-superclasses (find-class 'foo132)))) + #+CLISP (setq custom:*forward-referenced-class-misdesign* t) + (defclass foo133 (forwardclass03) ()) + (defparameter *forwardclass* (first (clos:class-direct-superclasses (find-class 'foo133)))) t) T (typep 1 *forwardclass*) @@ -306,14 +307,14 @@ NIL ; should also be ERROR (write-to-string *forwardclass* :readably t) ERROR -(setf (find-class 'foo132a) *forwardclass*) +(setf (find-class 'foo133a) *forwardclass*) ERROR (class-name *forwardclass*) -FORWARDCLASS02 -(setf (class-name *forwardclass*) 'forwardclass03) +FORWARDCLASS03 +(setf (class-name *forwardclass*) 'forwardclass03changed) ERROR (class-name *forwardclass*) -FORWARDCLASS02 +FORWARDCLASS03 (clos:class-direct-superclasses *forwardclass*) NIL (clos:class-direct-slots *forwardclass*) @@ -334,19 +335,103 @@ ERROR (clos:class-finalized-p *forwardclass*) NIL -(eval `(defmethod foo132a ((x ,*forwardclass*)))) +(eval `(defmethod foo133a ((x ,*forwardclass*)))) ERROR (progn - (defgeneric foo132b (x) + (defgeneric foo133b (x) (:method ((x integer)) x)) - (clos:add-method #'foo132b + (clos:add-method #'foo133b (make-instance 'standard-method :qualifiers '() :lambda-list '(x) :specializers (list *forwardclass*) :function #'(lambda (args next-methods) (first args)))) - #-CLISP (foo132b 7)) + #-CLISP (foo133b 7)) ERROR +(typep *forwardclass* 'class) +T ; misdesign! +(typep *forwardclass* 'clos:specializer) +T ; misdesign! +(subtypep 'clos:forward-referenced-class 'class) +T ; misdesign! +(subtypep 'clos:forward-referenced-class 'clos:specializer) +T ; misdesign! +;; Same thing with opposite setting of *forward-referenced-class-misdesign*. +(progn + #+CLISP (setq custom:*forward-referenced-class-misdesign* nil) + (defclass foo134 (forwardclass04) ()) + (defparameter *forwardclass* (first (clos:class-direct-superclasses (find-class 'foo134)))) + t) +T +(typep 1 *forwardclass*) +ERROR +(locally (declare (compile)) (typep 1 *forwardclass*)) +ERROR +(type-expand *forwardclass*) +ERROR +(subtypep *forwardclass* 't) +ERROR +(subtypep 'nil *forwardclass*) +ERROR +(sys::subtype-integer *forwardclass*) +ERROR +(sys::subtype-sequence *forwardclass*) +NIL ; should also be ERROR +(write-to-string *forwardclass* :readably t) +ERROR +(setf (find-class 'foo134a) *forwardclass*) +ERROR +(class-name *forwardclass*) +FORWARDCLASS04 +(setf (class-name *forwardclass*) 'forwardclass04changed) +ERROR +(class-name *forwardclass*) +FORWARDCLASS04 +(clos:class-direct-superclasses *forwardclass*) +NIL +(clos:class-direct-slots *forwardclass*) +NIL +(clos:class-direct-default-initargs *forwardclass*) +NIL +(clos:class-precedence-list *forwardclass*) +ERROR +(clos:class-slots *forwardclass*) +ERROR +(clos:class-default-initargs *forwardclass*) +ERROR +(clos:class-finalized-p *forwardclass*) +NIL +(clos:class-prototype *forwardclass*) +ERROR +(clos:finalize-inheritance *forwardclass*) +ERROR +(clos:class-finalized-p *forwardclass*) +NIL +(eval `(defmethod foo134a ((x ,*forwardclass*)))) +ERROR +(progn + (defgeneric foo134b (x) + (:method ((x integer)) x)) + (clos:add-method #'foo134b + (make-instance 'standard-method + :qualifiers '() + :lambda-list '(x) + :specializers (list *forwardclass*) + :function #'(lambda (args next-methods) (first args)))) + #-CLISP (foo134b 7)) +ERROR +(typep *forwardclass* 'class) +#+CLISP NIL +#-CLISP T ; misdesign! +(typep *forwardclass* 'clos:specializer) +#+CLISP NIL +#-CLISP T ; misdesign! +(subtypep 'clos:forward-referenced-class 'class) +#+CLISP NIL +#-CLISP T ; misdesign! +(subtypep 'clos:forward-referenced-class 'clos:specializer) +#+CLISP NIL +#-CLISP T ; misdesign! ;; Check that defclass supports user-defined options. Index: clos.tst =================================================================== RCS file: /cvsroot/clisp/clisp/tests/clos.tst,v retrieving revision 1.80 retrieving revision 1.81 diff -u -d -r1.80 -r1.81 --- clos.tst 23 Nov 2004 11:35:00 -0000 1.80 +++ clos.tst 24 Nov 2004 11:47:00 -0000 1.81 @@ -4050,6 +4050,7 @@ ;; Check that undefined classes are treated as undefined, even though they ;; are represented by a FORWARD-REFERENCED-CLASS. (progn + #+CLISP (setq custom:*forward-referenced-class-misdesign* t) (defclass foo131 (forwardclass01) ()) t) T @@ -4075,3 +4076,31 @@ ERROR (defmethod foo131b ((x forwardclass01))) ERROR +;; Same thing with opposite setting of *forward-referenced-class-misdesign*. +(progn + #+CLISP (setq custom:*forward-referenced-class-misdesign* nil) + (defclass foo132 (forwardclass02) ()) + t) +T +(find-class 'forwardclass02) +ERROR +(find-class 'forwardclass02 nil) +NIL +(typep 1 'forwardclass02) +ERROR +(locally (declare (compile)) (typep 1 'forwardclass02)) +ERROR +(type-expand 'forwardclass02) +ERROR +(subtypep 'forwardclass02 't) +ERROR +(subtypep 'nil 'forwardclass02) +ERROR +(sys::subtype-integer 'forwardclass02) +NIL ; should also be ERROR +(sys::subtype-sequence 'forwardclass02) +NIL ; should also be ERROR +(defstruct (foo132a (:include forwardclass02))) +ERROR +(defmethod foo132b ((x forwardclass02))) +ERROR Index: ChangeLog =================================================================== RCS file: /cvsroot/clisp/clisp/tests/ChangeLog,v retrieving revision 1.268 retrieving revision 1.269 diff -u -d -r1.268 -r1.269 --- ChangeLog 23 Nov 2004 18:28:11 -0000 1.268 +++ ChangeLog 24 Nov 2004 11:47:00 -0000 1.269 @@ -1,3 +1,9 @@ +2004-11-19 Bruno Haible <br...@cl...> + + * clos.tst: Test the forward-referenced-class behaviour with both + settings of *forward-referenced-class-misdesign*. + * mop.tst: Likewise. + 2004-11-23 Sam Steingold <sd...@gn...> * macro8.tst: test COMPILE+LOAD-TIME-VALUE inside COMPILE-FILE --__--__-- Message: 4 From: Bruno Haible <ha...@us...> To: cli...@li... Subject: clisp/src clos-custom.lisp,NONE,1.1 Date: Wed, 24 Nov 2004 11:39:57 +0000 Reply-To: cli...@li... Update of /cvsroot/clisp/clisp/src In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv16728/src Added Files: clos-custom.lisp Log Message: User customizations of the CLOS + MOP implementation. --- NEW FILE: clos-custom.lisp --- ;;;; Common Lisp Object System for CLISP: Customizable variables ;;;; Bruno Haible 2004 (in-package "EXT") (progn (export #1='(custom::*strict-mop* custom::*forward-referenced-class-misdesign*) "CUSTOM") (export #1# "EXT")) (in-package "CLOS") ;; ============================================================================ (define-symbol-macro custom:*forward-referenced-class-misdesign* (<forward-referenced-class>-under-<class>)) (defvar *<forward-referenced-class>-under-<class>* nil) (defun <forward-referenced-class>-under-<class> () *<forward-referenced-class>-under-<class>*) (defun (setf <forward-referenced-class>-under-<class>) (val) (when val (setq val 't)) (if val (unless (eq (find-class 'class) <potential-class>) (set-<class>-<potential-class>)) (unless (eq (find-class 'class) <defined-class>) (set-<class>-<defined-class>))) (setq *<forward-referenced-class>-under-<class>* val) val) (defun set-<class>-<potential-class> () (setf (class-classname <defined-class>) 'defined-class) (setf (class-classname <potential-class>) 'class) (setf (find-class 'class) <potential-class>) (setf (get 'class 'sys::type-symbol) (get 'potential-class 'sys::type-symbol))) (defun set-<class>-<defined-class> () (setf (class-classname <potential-class>) 'potential-class) (setf (class-classname <defined-class>) 'class) (setf (find-class 'class) <defined-class>) (setf (get 'class 'sys::type-symbol) (get 'defined-class 'sys::type-symbol))) ; Initial setting: (set-<class>-<defined-class>) ;; ============================================================================ (define-symbol-macro custom:*strict-mop* (strict-mop)) (defvar *strict-mop* nil) (defun strict-mop () *strict-mop*) (defun (setf strict-mop) (val) (when val (setq val 't)) (setf custom:*forward-referenced-class-misdesign* val) (setq *strict-mop* val) val) --__--__-- Message: 5 From: Bruno Haible <ha...@us...> To: cli...@li... Subject: clisp/doc mop.xml,2.45,2.46 Date: Wed, 24 Nov 2004 11:55:41 +0000 Reply-To: cli...@li... Update of /cvsroot/clisp/clisp/doc In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv19614/doc Modified Files: mop.xml Log Message: Update regarding forward-referenced-class. More details about make-method-lambda's misconception. Index: mop.xml =================================================================== RCS file: /cvsroot/clisp/clisp/doc/mop.xml,v retrieving revision 2.45 retrieving revision 2.46 diff -u -d -r2.45 -r2.46 --- mop.xml 22 Nov 2004 15:42:44 -0000 2.45 +++ mop.xml 24 Nov 2004 11:55:28 -0000 2.46 @@ -461,25 +461,36 @@ stand-in until the class is actually defined.</para> <note>&clisp-only;<formalpara id="no-forward-referenced-class"> - <title>The class &forward-referenced-class; is not implemented.</title> + <title>Implementation of class &forward-referenced-class;</title> + <para>The class &forward-referenced-class; is implemented in a way that fixes several + flaws in the &amop; specification.</para> + <para>It is not a subclass of &class; and &specializer-t;, just a subclass + of &metaobject-t;, because forward references to classes are not classes and + cannot be used as specializers of methods. An &amop; compatibility mode is + provided, however, if you set the variable + <literal>CUSTOM:*FORWARD-REFERENCED-CLASS-MISDESIGN*</literal> + to &t;. In this mode, &forward-referenced-class; is formally a subclass of + &class; and &specializer-t;, but the behaviour of &forward-referenced-class; + instances is the same.</para> + <para>The &amop; says that the first argument of + &ensure-class-UC; can be a &forward-referenced-class;. But from + the description of &ensure-class;, it is clear that it can only be + a class returned by &find-class;, and &ansi-cl; &find-class; + cannot return a &forward-referenced-class;.</para> + <para>The &amop; says that &ensure-class-UC; creates a + &forward-referenced-class; for not-yet-defined class symbols among + the direct-superclasses list. But this leads to many + &forward-referenced-class; with the same name (since they cannot + be stored and retrieved through &find-class;), and since + &change-class; preserves the &eq;-ness, after the class is + defined, we have many class objects with the same name.</para> <para>In the direct-superclasses list of non-finalized classes, - symbols are used instead of &forward-referenced-class; instances. - This choice has been made because the concept of - &forward-referenced-class; contradicts the &find-class; - specification:<orderedlist> - <listitem><simpara>The &amop; says that the first argument of - &ensure-class-UC; can be a &forward-referenced-class;. But from - the description of &ensure-class;, it is clear that it can only be - a class returned by &find-class;, and &ansi-cl; &find-class; - cannot return a &forward-referenced-class;.</simpara></listitem> - <listitem><simpara>The &amop; says that &ensure-class-UC; creates a - &forward-referenced-class; for not-yet-defined class symbols among - the direct-superclasses list. But this leads to many - &forward-referenced-class; with the same name (since they cannot - be stored and retrieved through &find-class;), and since - &change-class; preserves the &eq;-ness, after the class is - defined, we have many class objects with the same name. -</simpara></listitem></orderedlist></para></formalpara></note> + &forward-referenced-class; instances can occur, denoting classes that + have not yet been defined. When or after such a class gets defined, + the &forward-referenced-class; instance is replaced with the real + class. &clisp; uses simple object replacement, not &change-class;, in + this process.</para> +</formalpara></note> <para>The class &standard-object-t; is the <emphasis>default direct superclass</emphasis> of the class &standard-class;. When an instance @@ -1019,9 +1030,9 @@ </para> <note>&clisp-only;<simpara>For a class that has not yet been finalized, - the returned list may contain symbols as placeholder for classes that - were not yet defined when finalization of the class was last attempted. - <xref linkend="no-forward-referenced-class"/>.</simpara></note> + the returned list may contain &forward-referenced-class; instances as + placeholder for classes that were not yet defined when finalization of + the class was last attempted.</simpara></note> </section> <section id="class-direct-slots"> @@ -1671,9 +1682,11 @@ The &proper-name-glo; of the newly created forward referenced class metaobject is set to the element.</simpara> <note>&clisp-only; - <simpara><xref linkend="no-forward-referenced-class"/>. - In the &direct-superclasses-k; argument, symbols are used - to represent classes that have not yet been defined.</simpara> + <simpara>A new &forward-referenced-class; instance is only created + when one for the given class name does not yet exist; otherwise the + existing one is reused. + See <xref linkend="no-forward-referenced-class"/>. + </simpara> </note></listitem></itemizedlist></para></listitem> <listitem><simpara>All other keyword arguments are included directly in the initialization arguments.</simpara></listitem> @@ -1691,6 +1704,7 @@ a documented violation of the general constraint that &change-class; may not be used with class metaobjects.)</simpara> <note>&clisp-only;<simpara> + The &class-r; argument cannot be a forward referenced class. See <xref linkend="no-forward-referenced-class"/>.</simpara></note> <simpara>If the class of the &class-r; argument is not the same as the class specified by the &metaclass-k; argument, an &err-sig;.</simpara> @@ -1713,7 +1727,7 @@ function in the case where the &class-r; argument is a forward referenced class.</simpara> <note>&clisp-only;<simpara>This method does not exist. - <xref linkend="no-forward-referenced-class"/>. Use the method + See <xref linkend="no-forward-referenced-class"/>. Use the method specialized on &null-t; instead.</simpara></note> </listitem></varlistentry> <varlistentry><term><literal role="method">(&ensure-class-UC; @@ -3635,14 +3649,38 @@ </informalexample> <note>&clisp-only;<formalpara id="no-make-method-lambda"> - <title>The generic function &make-method-lambda; is not implemented</title> - <para>Its specification is misdesigned: it mixes &compile-time; and - &exec-time; behaviour.</para></formalpara> + <title>The generic function &make-method-lambda; is not implemented.</title> + <para>Its specification is misdesigned: it mixes compile-time and run-time + behaviour. The essential problem is: where could the generic-function + argument come from? + <itemizedlist> + <listitem><simpara>If a &defmethod; form occurs in a source file, is + &make-method-lambda; then called at compile time or at load time? + If it was called at compile time, there's no possible value for the + first argument, since the class of the generic function to which the + method will belong is not known until load time. If it was called + at load time, it would mean that the method's source code could only + be compiled at load time, not earlier - which defeats the purpose of + &compile-file;</simpara></listitem> + <listitem><simpara>When a method is removed from a generic function + using &remove-method; and then added through &add-method; to a different + generic function, possibly belonging to a different generic function + class, would &make-method-lambda; then be called again or not? If no, + then &make-method-lambda;'s first argument is useless. If yes, then the + source code of every method would have to be present at runtime, and its + lexical environment as well. + </simpara></listitem> + </itemizedlist> + </para> + </formalpara> <formalpara id="method-functions-args"> - <title>Method function arguments.</title> - <para>&call-method; and method functions always expect exactly two - arguments: the list of arguments passed to the generic function, and - the list of next methods.</para></formalpara></note> + <title>Method function arguments</title> + <para>&call-method; always expect exactly two arguments: the method and a + list of next methods.</para> + <para>Method functions always expect exactly two arguments: the list of + arguments passed to the generic function, and the list of next + methods.</para> + </formalpara></note> </section><!-- make-method-lambda --> <section id="compute-discriminating-function"> @@ -3713,8 +3751,12 @@ <note>&clisp-only;<simpara>Overriding methods can make use of the function &compute-effective-method-as-function;. It is more convenient to call &compute-effective-method-as-function; than &compute-effective-method; - because the definition of the local macros &call-method; and &make-method; - is implementation dependent.</simpara></note> + because the in the latter case one needs a lot of <quote>glue code</quote> + for implementing the local macros &call-method; and &make-method;, and + this glue code is implementation dependent because it needs 1. to retrieve + the declarations list stored in the method-combination object and 2. to + handle implementation dependent options that are returned as second value + from &compute-effective-method;.</simpara></note> </section><!-- compute-discriminating-function --> <!-- end generic-function advanced customization --> @@ -5453,8 +5495,6 @@ &clisp; implementation thereof.</para> <itemizedlist id="mop-not-in-clisp"><title>Not implemented in &clisp;</title> -<listitem><para>The class &forward-referenced-class; is not implemented. - See <xref linkend="mop-mo-cl-inheritance"/>.</para></listitem> <listitem><para>The generic function &make-method-lambda; is not implemented. See <xref linkend="mop-gf-invocation"/>.</para></listitem> <listitem><para>Custom methods on &finalize-inheritance; sometimes have @@ -5469,9 +5509,8 @@ See <xref linkend="mop-cl-defclass"/>.</para></listitem> <listitem><para>The &defgeneric; macro passes default values to &ensure-gf;. See <xref linkend="mop-gf-init-defgeneric"/>.</para></listitem> -<listitem><para>The direct-superclasses list of non-finalized classes - contains symbols instead of &forward-referenced-class; instances. - See <xref linkend="mop-mo-cl-inheritance"/>.</para></listitem> +<listitem><para>The class &forward-referenced-class; is implemented differently. + See <xref linkend="no-forward-referenced-class"/>.</para></listitem> <listitem><para>The function &gf-argument-precedence-order; &sig-err; if the generic function has no &lalist;.</para></listitem> </itemizedlist> --__--__-- _______________________________________________ clisp-cvs mailing list cli...@li... https://lists.sourceforge.net/lists/listinfo/clisp-cvs End of clisp-cvs Digest |