Menu
▾
▴
clisp-cvs digest, Vol 1 #699 - 5 msgs
|
From: <cli...@li...> - 2004-09-14 19:50:07
|
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 lispbibl.d,1.549,1.550 record.d,1.97,1.98 clos-class1.lisp,1.11,1.12 clos-class3.lisp,1.37,1.38 clos-class5.lisp,1.35,1.36 clos-class6.lisp,1.20,1.21 clos-print.lisp,1.9,1.10 ChangeLog,1.3541,1.3542 (Bruno Haible) 2. clisp/src ChangeLog,1.3542,1.3543 (Sam Steingold) 3. clisp/src ChangeLog,1.3543,1.3544 condition.lisp,1.46,1.47 (Bruno Haible) 4. clisp/src compiler.lisp,1.216,1.217 ChangeLog,1.3544,1.3545 (Bruno Haible) 5. clisp/src spvw_sigsegv.d,1.17,1.18 pathname.d,1.329,1.330 lispbibl.d,1.550,1.551 ChangeLog,1.3545,1.3546 (Sam Steingold) --__--__-- Message: 1 From: Bruno Haible <ha...@us...> To: cli...@li... Subject: clisp/src lispbibl.d,1.549,1.550 record.d,1.97,1.98 clos-class1.lisp,1.11,1.12 clos-class3.lisp,1.37,1.38 clos-class5.lisp,1.35,1.36 clos-class6.lisp,1.20,1.21 clos-print.lisp,1.9,1.10 ChangeLog,1.3541,1.3542 Date: Tue, 14 Sep 2004 11:35:12 +0000 Reply-To: cli...@li... Update of /cvsroot/clisp/clisp/src In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv3050/src Modified Files: lispbibl.d record.d clos-class1.lisp clos-class3.lisp clos-class5.lisp clos-class6.lisp clos-print.lisp ChangeLog Log Message: Make it possible to call class-precedence-list during compute-slots and compute-default-initargs. Initialization of classes proceeds in 6 steps. Index: clos-class5.lisp =================================================================== RCS file: /cvsroot/clisp/clisp/src/clos-class5.lisp,v retrieving revision 1.35 retrieving revision 1.36 diff -u -d -r1.35 -r1.36 --- clos-class5.lisp 19 Aug 2004 22:22:31 -0000 1.35 +++ clos-class5.lisp 14 Sep 2004 11:35:08 -0000 1.36 @@ -515,7 +515,7 @@ #|| (defgeneric allocate-instance (class) (:method ((class semi-standard-class)) - (unless (%class-precedence-list class) (finalize-class class t)) + (unless (= (class-initialized class) 6) (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) @@ -531,7 +531,7 @@ ;; (class-current-version class) is an atom, (class-names class) a cons. (if (atom (class-current-version class)) (progn - (unless (%class-precedence-list class) (finalize-class class t)) + (unless (= (class-initialized class) 6) (finalize-class class t)) ;; Dispatch among <standard-class> and <funcallable-standard-class>. (if (not (class-funcallablep class)) (allocate-std-instance class (class-instance-size class)) Index: clos-class6.lisp =================================================================== RCS file: /cvsroot/clisp/clisp/src/clos-class6.lisp,v retrieving revision 1.20 retrieving revision 1.21 diff -u -d -r1.20 -r1.21 --- clos-class6.lisp 10 Sep 2004 11:10:35 -0000 1.20 +++ clos-class6.lisp 14 Sep 2004 11:35:08 -0000 1.21 @@ -33,14 +33,14 @@ ;;; Optimized class-xxx accessors. ;;; These are possible thanks to the :fixed-slot-locations class option. -(defun check-class-initialized (class) - (unless (class-initialized class) +(defun check-class-initialized (class level) + (unless (>= (class-initialized class) level) (error (TEXT "The class ~S has not yet been initialized.") class))) -(defun check-class-finalized (class) - (check-class-initialized class) - (when (null (%class-precedence-list class)) +(defun check-class-finalized (class level) + (check-class-initialized class 2) + (unless (>= (class-initialized class) level) (error (TEXT "The class ~S has not yet been finalized.") class))) @@ -54,7 +54,7 @@ ;; MOP p. 76 (defgeneric class-name (class) (:method ((class class)) - (check-class-initialized class) + (check-class-initialized class 1) (class-classname class))) ;; MOP p. 92 (defgeneric (setf class-name) (new-value class) @@ -74,7 +74,7 @@ ;; MOP p. 76 (defgeneric class-direct-superclasses (class) (:method ((class class)) - (check-class-initialized class) + (check-class-initialized class 2) (sys::%record-ref class *<class>-direct-superclasses-location*))) ;; Not in MOP. (defun (setf class-direct-superclasses) (new-value class) @@ -89,18 +89,15 @@ (accessor-typecheck class 'class '(setf class-all-superclasses)) (setf (sys::%record-ref class *<class>-all-superclasses-location*) new-value)) -;; Not in MOP. -(defun %class-precedence-list (class) - (accessor-typecheck class 'class '%class-precedence-list) - (sys::%record-ref class *<class>-precedence-list-location*)) -(defun (setf class-precedence-list) (new-value class) - (accessor-typecheck class 'class '(setf class-precedence-list)) - (setf (sys::%record-ref class *<class>-precedence-list-location*) new-value)) ;; MOP p. 76 (defgeneric class-precedence-list (class) (:method ((class class)) - (check-class-finalized class) + (check-class-finalized class 3) (sys::%record-ref class *<class>-precedence-list-location*))) +;; Not in MOP. +(defun (setf class-precedence-list) (new-value class) + (accessor-typecheck class 'class '(setf class-precedence-list)) + (setf (sys::%record-ref class *<class>-precedence-list-location*) new-value)) ;; Not in MOP. (defun class-direct-subclasses-table (class) @@ -112,13 +109,13 @@ ;; MOP p. 76 (defgeneric class-direct-subclasses (class) (:method ((class class)) - (check-class-initialized class) + (check-class-initialized class 2) (list-direct-subclasses class))) ;; MOP p. 75 (defgeneric class-direct-slots (class) (:method ((class class)) - (check-class-initialized class) + (check-class-initialized class 2) (sys::%record-ref class *<class>-direct-slots-location*))) ;; Not in MOP. (defun (setf class-direct-slots) (new-value class) @@ -128,7 +125,7 @@ ;; MOP p. 77 (defgeneric class-slots (class) (:method ((class class)) - (check-class-finalized class) + (check-class-finalized class 5) (sys::%record-ref class *<class>-slots-location*))) ;; Not in MOP. (defun (setf class-slots) (new-value class) @@ -146,7 +143,7 @@ ;; MOP p. 75 (defgeneric class-direct-default-initargs (class) (:method ((class class)) - (check-class-initialized class) + (check-class-initialized class 2) (sys::%record-ref class *<class>-direct-default-initargs-location*))) ;; Not in MOP. (defun (setf class-direct-default-initargs) (new-value class) @@ -156,7 +153,7 @@ ;; MOP p. 75 (defgeneric class-default-initargs (class) (:method ((class class)) - (check-class-finalized class) + (check-class-finalized class 6) (sys::%record-ref class *<class>-default-initargs-location*))) ;; Not in MOP. (defun (setf class-default-initargs) (new-value class) @@ -278,7 +275,7 @@ ;; MOP p. 77 (defgeneric class-prototype (class) (:method ((class semi-standard-class)) - (check-class-finalized class) + (check-class-finalized class 6) (or (sys::%record-ref class *<semi-standard-class>-prototype-location*) (setf (sys::%record-ref class *<semi-standard-class>-prototype-location*) (let ((old-instantiated (class-instantiated class))) @@ -302,8 +299,7 @@ ;; MOP p. 76 (defgeneric class-finalized-p (class) (:method ((class class)) - (and (class-initialized class) - (not (null (%class-precedence-list class))))) + (= (class-initialized class) 6)) ;; CLISP extension: Convenience method on symbols. (:method ((name symbol)) (class-finalized-p (find-class name)))) Index: clos-print.lisp =================================================================== RCS file: /cvsroot/clisp/clisp/src/clos-print.lisp,v retrieving revision 1.9 retrieving revision 1.10 diff -u -d -r1.9 -r1.10 --- clos-print.lisp 4 Sep 2004 14:13:05 -0000 1.9 +++ clos-print.lisp 14 Sep 2004 11:35:08 -0000 1.10 @@ -28,7 +28,7 @@ (class-version-p (class-current-version object)) (slot-boundp object '$precedence-list)) (progn - (unless (%class-precedence-list object) ; not yet finalized? + (when (< (class-initialized object) 3) ; not yet finalized? (write-string " " stream) (write :incomplete :stream stream)) ;; FIXME: Overhaul this questionable and confusing feature. Index: ChangeLog =================================================================== RCS file: /cvsroot/clisp/clisp/src/ChangeLog,v retrieving revision 1.3541 retrieving revision 1.3542 diff -u -d -r1.3541 -r1.3542 --- ChangeLog 13 Sep 2004 17:03:33 -0000 1.3541 +++ ChangeLog 14 Sep 2004 11:35:08 -0000 1.3542 @@ -1,3 +1,46 @@ +2004-08-01 Bruno Haible <br...@cl...> + + Make it possible to call class-precedence-list during compute-slots + and compute-default-initargs. + * record.d (do_allocate_instance, update_instance, + CLOS::%MAKE-INSTANCE): Test for finalized class by using the + 'initialized' field, not the 'precedence_list' field. + * clos-class1.lisp (class): Change type of initialized slot to integer. + (%class-precedence-list): Remove function. + (shared-initialize-<class>): Set the initialized flag to 0 or 2, + instead of nil and t. + * clos-class3.lisp (subclassp): Test for finalized class by using the + 'initialized' slot, not the 'precedence-list' slot. + (reinitialize-instance-<class>): Likewise. + (std-compute-subclass-of-stablehash-p, compute-slots-<class>-primary, + compute-slots-<slotted-class>-around, compute-default-initargs-<class>): + Use class-precedence-list instead of %class-precedence-list. + (shared-initialize-<built-in-class>, + shared-initialize-<structure-class>): Likewise. Set the initialized + flag to 6. + (shared-initialize-<semi-standard-class>): Set initialized flag to 2. + (finalize-class): Test for finalized class by using the 'initialized' + slot, not the 'precedence-list' slot. + (finalize-instance-semi-standard-class): Use class-precedence-list + instead of %class-precedence-list. Set the initialized flag to 6. + (make-instances-obsolete-<semi-standard-class>, + make-instances-obsolete-<semi-standard-class>-nonrecursive): + Test for finalized class by using the 'initialized' slot, not the + 'precedence-list' slot. + (update-subclasses-for-redefined-class): Set initialized flag to 2. + (update-subclasses-for-redefined-class-nonrecursive): Likewise. Test + for finalized class by using the 'initialized' slot, not the + 'precedence-list' slot. + * clos-class6.lisp (check-class-initialized): Add a level argument. + (check-class-finalized): Add a level argument. Test for finalized class + by using the 'initialized' slot, not the 'precedence-list' slot. + (%class-precedence-list): Remove function. + (class-precedence-list, class-slots, class-default-initargs, + class-prototype): Update. + (class-finalized-p@class): Test for finalized class by using the + 'initialized' slot, not the 'precedence-list' slot. + * clos-print.lisp (print-object@class): Likewise. + 2004-09-13 Sam Steingold <sd...@gn...> comply with <http://www.lisp.org/HyperSpec/Body/fun_compile-file.html>: Index: lispbibl.d =================================================================== RCS file: /cvsroot/clisp/clisp/src/lispbibl.d,v retrieving revision 1.549 retrieving revision 1.550 diff -u -d -r1.549 -r1.550 --- lispbibl.d 10 Sep 2004 11:10:35 -0000 1.549 +++ lispbibl.d 14 Sep 2004 11:35:06 -0000 1.550 @@ -5587,7 +5587,7 @@ gcv_object_t default_initargs _attribute_aligned_object_; gcv_object_t documentation _attribute_aligned_object_; # string or NIL gcv_object_t listeners _attribute_aligned_object_; # list of objects to be notified upon a change - gcv_object_t initialized _attribute_aligned_object_; # set to true when the class is initialized + gcv_object_t initialized _attribute_aligned_object_; # describes which parts of the class are initialized # from here on only for metaclass â <standard-class> or metaclass â <funcallable-standard-class> or metaclass â <structure-class> gcv_object_t subclass_of_stablehash_p _attribute_aligned_object_; /* true if <standard-stablehash> or <structure-stablehash> is among the superclasses */ gcv_object_t generic_accessors _attribute_aligned_object_; Index: clos-class3.lisp =================================================================== RCS file: /cvsroot/clisp/clisp/src/clos-class3.lisp,v retrieving revision 1.37 retrieving revision 1.38 diff -u -d -r1.37 -r1.38 --- clos-class3.lisp 13 Sep 2004 13:28:35 -0000 1.37 +++ clos-class3.lisp 14 Sep 2004 11:35:08 -0000 1.38 @@ -14,7 +14,7 @@ ;; 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)) + (unless (>= (class-initialized class1) 4) (finalize-class class1 t)) (values (gethash class2 (class-all-superclasses class1)))) ; T or (default) NIL @@ -495,7 +495,7 @@ (fixed-slot-locations nil fixed-slot-locations-p) &allow-other-keys &aux (metaclass (class-of class))) - (if (and (%class-precedence-list class) ; already finalized? + (if (and (>= (class-initialized class) 4) ; already finalized? (subclassp class <metaobject>)) ;; Things would go awry when we try to redefine <class> and similar. (warn (TEXT "Redefining metaobject class ~S has no effect.") @@ -506,7 +506,7 @@ ;; the direct-superclasses argument, so that we can compare the two ;; lists using EQUAL. (when (and (subclassp metaclass <standard-class>) - (null (%class-precedence-list class))) + (< (class-initialized class) 3)) (do ((l (class-direct-superclasses class) (cdr l))) ((atom l)) (let ((c (car l))) @@ -535,7 +535,7 @@ (and fixed-slot-locations-p (not (eq fixed-slot-locations (class-fixed-slot-locations class))))) ;; Instances have to be updated: - (let* ((was-finalized (%class-precedence-list class)) + (let* ((was-finalized (>= (class-initialized class) 6)) (must-be-finalized (and was-finalized (some #'class-instantiated (list-all-finalized-subclasses class)))) @@ -920,7 +920,7 @@ ;; Determine whether a class inherits from <standard-stablehash> or ;; <structure-stablehash>. (defun std-compute-subclass-of-stablehash-p (class) - (dolist (superclass (%class-precedence-list class) nil) + (dolist (superclass (class-precedence-list class) nil) (let ((superclassname (class-classname superclass))) (when (or (eq superclassname 'standard-stablehash) (eq superclassname 'structure-stablehash)) @@ -1005,7 +1005,7 @@ ;; Gather all slot-specifiers, ordered by precedence: (let ((all-slots (mapcan #'(lambda (c) (nreverse (copy-list (class-direct-slots c)))) - (%class-precedence-list class)))) + (class-precedence-list class)))) ;; Partition by slot-names: (setq all-slots (let ((ht (make-hash-table :key-type 'symbol :value-type 't @@ -1043,7 +1043,7 @@ ;; Side effects done by this function: The slot-definition-location of the ;; slots is determined. (defun compute-slots-<slotted-class>-around (class next-method) - (let ((cpl (%class-precedence-list class)) + (let ((cpl (class-precedence-list class)) (slots (funcall next-method class))) ; Some checks, to guarantee that user-defined primary methods on ; compute-slots don't break our CLOS. @@ -1071,7 +1071,7 @@ (remove-if-not #'(lambda (c) (and (semi-standard-class-p c) (class-fixed-slot-locations c))) - (cdr (%class-precedence-list class))))) + (cdr (class-precedence-list class))))) (when superclasses-with-fixed-slot-locations (dolist (slot slots) (let ((name (slot-definition-name slot)) @@ -1254,7 +1254,7 @@ (defun compute-default-initargs-<class> (class) (remove-duplicates - (mapcap #'class-direct-default-initargs (%class-precedence-list class)) + (mapcap #'class-direct-default-initargs (class-precedence-list class)) :key #'car :from-end t)) @@ -1429,11 +1429,17 @@ (when (or (eq situation 't) direct-superclasses-p) (setf (class-precedence-list class) (checked-compute-class-precedence-list class)) + (when (eq situation 't) + (setf (class-initialized class) 3)) (setf (class-all-superclasses class) - (std-compute-superclasses (%class-precedence-list class)))) + (std-compute-superclasses (class-precedence-list class))) + (when (eq situation 't) + (setf (class-initialized class) 4))) (when (eq situation 't) (setf (class-slots class) '()) - (setf (class-default-initargs class) '())) + (setf (class-initialized class) 5) + (setf (class-default-initargs class) '()) + (setf (class-initialized class) 6)) ; Done. class) @@ -1495,8 +1501,12 @@ (when (or (eq situation 't) direct-superclasses-p) (setf (class-precedence-list class) (checked-compute-class-precedence-list class)) + (when (eq situation 't) + (setf (class-initialized class) 3)) (setf (class-all-superclasses class) - (std-compute-superclasses (%class-precedence-list class)))) + (std-compute-superclasses (class-precedence-list class))) + (when (eq situation 't) + (setf (class-initialized class) 4))) (when (or (eq situation 't) direct-superclasses-p direct-slots-as-lists-p direct-slots-as-metaobjects-p) (unless names @@ -1505,6 +1515,8 @@ (setq slots (class-slots (first direct-superclasses))) (setq size (class-instance-size (first direct-superclasses))))) (setf (class-slots class) slots) + (when (eq situation 't) + (setf (class-initialized class) 5)) (setf (class-slot-location-table class) (compute-slot-location-table class)) (setf (class-instance-size class) size) (unless names @@ -1528,6 +1540,8 @@ (when (or (eq situation 't) direct-superclasses-p direct-default-initargs-p) (setf (class-default-initargs class) (checked-compute-default-initargs class))) + (when (eq situation 't) + (setf (class-initialized class) 6)) ; Initialize the remaining <slotted-class> slots: (when (or (eq situation 't) direct-superclasses-p) (setf (class-subclass-of-stablehash-p class) @@ -1603,6 +1617,7 @@ (setf (class-instantiated class) nil) (setf (class-finalized-direct-subclasses-table class) '()))) ; Initialize the remaining <class> slots: + (setf (class-initialized class) 2) ; mark as not yet finalized (setf (class-precedence-list class) nil) ; mark as not yet finalized (setf (class-all-superclasses class) nil) ; mark as not yet finalized ; Initialize the remaining <slotted-class> slots: @@ -1629,7 +1644,7 @@ ; 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? + (if (>= (class-initialized class) 6) ; already finalized? class (progn ;; Here we get only for instances of STANDARD-CLASS, since instances @@ -1671,8 +1686,12 @@ #'semi-standard-class-p 'SEMI-STANDARD-CLASS)) (setf (class-precedence-list class) (checked-compute-class-precedence-list class)) + (when (< (class-initialized class) 3) + (setf (class-initialized class) 3)) (setf (class-all-superclasses class) - (std-compute-superclasses (%class-precedence-list class))) + (std-compute-superclasses (class-precedence-list class))) + (when (< (class-initialized class) 4) + (setf (class-initialized class) 4)) (dolist (super direct-superclasses) (when (semi-standard-class-p super) (add-finalized-direct-subclass super class))) @@ -1686,6 +1705,8 @@ 3 ; see comments in clos-genfun1.lisp 1)) ; slot 0 is the class_version pointer (setf (class-slots class) (checked-compute-slots class)) + (when (< (class-initialized class) 5) + (setf (class-initialized class) 5)) (setf (class-instance-size class) (compute-instance-size class)) (setf (class-slot-location-table class) (compute-slot-location-table class)) (let ((shared-size (compute-shared-size class))) @@ -1696,6 +1717,8 @@ (setf (class-default-initargs class) (checked-compute-default-initargs class)) (setf (class-valid-initargs class) (remove-duplicates (mapcap #'slot-definition-initargs (class-slots class)))) + (when (< (class-initialized class) 6) + (setf (class-initialized class) 6)) (system::note-new-standard-class)) ;; ------------- Redefining an instance of <semi-standard-class> ------------- @@ -1705,14 +1728,14 @@ (make-instances-obsolete-<semi-standard-class> class)) (defun make-instances-obsolete-<semi-standard-class> (class) - (when (%class-precedence-list class) ; nothing to do if not yet finalized + (when (>= (class-initialized class) 6) ; nothing to do if not yet finalized ;; Recurse to the subclasses. (Even if there are no direct instances of ;; this class: the subclasses may have instances.) (mapc #'make-instances-obsolete-<semi-standard-class>-nonrecursive (list-all-finalized-subclasses class)))) (defun make-instances-obsolete-<semi-standard-class>-nonrecursive (class) - (if (and (%class-precedence-list class) ; already finalized? + (if (and (>= (class-initialized class) 4) ; already finalized? (subclassp class <metaobject>)) ; Don't obsolete metaobject instances. (let ((name (class-name class)) @@ -1752,6 +1775,7 @@ (when was-finalized ; nothing to do if not finalized before the redefinition ;; Handle the class itself specially, because its superclasses list now is ;; not the same as before. + (setf (class-initialized class) 2) ; mark as not yet finalized (setf (class-precedence-list class) nil) ; mark as not yet finalized (setf (class-all-superclasses class) nil) ; mark as not yet finalized (if must-be-finalized @@ -1779,7 +1803,8 @@ (rest (list-all-finalized-subclasses class))))) (defun update-subclasses-for-redefined-class-nonrecursive (class) - (when (%class-precedence-list class) ; nothing to do if not yet finalized + (when (>= (class-initialized class) 6) ; nothing to do if not yet finalized + (setf (class-initialized class) 2) ; mark as not yet finalized (setf (class-precedence-list class) nil) ; mark as not yet finalized (setf (class-all-superclasses class) nil) ; mark as not yet finalized (if (class-instantiated class) Index: clos-class1.lisp =================================================================== RCS file: /cvsroot/clisp/clisp/src/clos-class1.lisp,v retrieving revision 1.11 retrieving revision 1.12 diff -u -d -r1.11 -r1.12 --- clos-class1.lisp 10 Sep 2004 11:10:34 -0000 1.11 +++ clos-class1.lisp 14 Sep 2004 11:35:08 -0000 1.12 @@ -87,9 +87,15 @@ ($listeners ; list of objects to be notified upon a change :type list :initform nil) - ($initialized ; set to true when the class is initialized - :type boolean - :initform nil)) + ($initialized ; describes which parts of the class are initialized + :type (integer 0 6) ; 0 = nothing + ; 1 = name + ; 2 = likewise, plus direct-... info + ; 3 = likewise, plus class-precedence-list + ; 4 = likewise, plus class-all-superclasses + ; 5 = likewise, plus class-slots + ; 6 = likewise, plus slot-location-table, default-initargs + :initform 0)) (:fixed-slot-locations))) ;; Fixed slot locations. @@ -120,8 +126,6 @@ (sys::%record-ref object *<class>-all-superclasses-location*)) (defun (setf class-all-superclasses) (new-value object) (setf (sys::%record-ref object *<class>-all-superclasses-location*) new-value)) -(defun %class-precedence-list (object) - (sys::%record-ref object *<class>-precedence-list-location*)) (defun class-precedence-list (object) (sys::%record-ref object *<class>-precedence-list-location*)) (defun (setf class-precedence-list) (new-value object) @@ -200,10 +204,13 @@ (setf (class-direct-subclasses-table class) nil) (setf (class-slot-location-table class) empty-ht) (setf (class-listeners class) nil) - (setf (class-initialized class) nil))) + (setf (class-initialized class) 0))) (if (or (eq situation 't) name-p) - ; No need to check the name: any name is valid. - (setf (class-classname class) name) + (progn + ; No need to check the name: any name is valid. + (setf (class-classname class) name) + (when (eq situation 't) + (setf (class-initialized class) 1))) ; Get the name, for error message purposes. (setq name (class-classname class))) (when (or (eq situation 't) direct-superclasses-p) @@ -272,8 +279,9 @@ ; slots ; slot-location-table ; default-initargs - ; Now allow the user to call the class-xxx accessor functions. - (setf (class-initialized class) t) + ; Now allow the user to call some class-xxx accessor functions. + (when (eq situation 't) + (setf (class-initialized class) 2)) class) ;;; =========================================================================== Index: record.d =================================================================== RCS file: /cvsroot/clisp/clisp/src/record.d,v retrieving revision 1.97 retrieving revision 1.98 diff -u -d -r1.97 -r1.98 --- record.d 23 Aug 2004 10:44:49 -0000 1.97 +++ record.d 14 Sep 2004 11:35:08 -0000 1.98 @@ -900,14 +900,14 @@ is (class-names class) a cons? */ if (matomp(TheClass(clas)->current_version)) { /* <semi-standard-class>. */ - if (nullp(TheClass(clas)->precedence_list)) { + if (!eq(TheClass(clas)->initialized,fixnum(6))) { /* Call (CLOS:FINALIZE-INHERITANCE class). */ pushSTACK(clas); /* save clas */ pushSTACK(clas); funcall(S(finalize_inheritance),1); clas = popSTACK(); /* restore clas */ /* The class must be finalized now, otherwise FINALIZE-INHERITANCE has not done its job. */ - ASSERT(!nullp(TheClass(clas)->precedence_list)); + ASSERT(eq(TheClass(clas)->initialized,fixnum(6))); } /* Make a distinction between <standard-class> and <funcallable-standard-class>. */ @@ -1143,7 +1143,7 @@ # TheInstance(obj)->inst_class_version is filled. { var object newclass = TheClassVersion(TheClassVersion(cv)->cv_next)->cv_class; - if (nullp(TheClass(newclass)->precedence_list)) + if (!eq(TheClass(newclass)->initialized,fixnum(6))) NOTREACHED; } # Compute the information needed for the update, if not already done. @@ -1637,13 +1637,13 @@ /* stack layout: class, argcount Initarg/Value-pairs. */ { /* add default-initargs: */ var object clas = Before(rest_args_pointer); - if (nullp(TheClass(clas)->precedence_list)) { + if (!eq(TheClass(clas)->initialized,fixnum(6))) { /* Call (CLOS:FINALIZE-INHERITANCE class). */ pushSTACK(clas); funcall(S(finalize_inheritance),1); clas = Before(rest_args_pointer); /* The class must be finalized now, otherwise FINALIZE-INHERITANCE has not done its job. */ - ASSERT(!nullp(TheClass(clas)->precedence_list)); + ASSERT(eq(TheClass(clas)->initialized,fixnum(6))); } var object l = TheClass(clas)->default_initargs; while (consp(l)) { --__--__-- Message: 2 From: Sam Steingold <sd...@us...> To: cli...@li... Subject: clisp/src ChangeLog,1.3542,1.3543 Date: Tue, 14 Sep 2004 15:40:06 +0000 Reply-To: cli...@li... Update of /cvsroot/clisp/clisp/src In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv16822/src Modified Files: ChangeLog Log Message: formatting Index: ChangeLog =================================================================== RCS file: /cvsroot/clisp/clisp/src/ChangeLog,v retrieving revision 1.3542 retrieving revision 1.3543 diff -u -d -r1.3542 -r1.3543 --- ChangeLog 14 Sep 2004 11:35:08 -0000 1.3542 +++ ChangeLog 14 Sep 2004 15:40:01 -0000 1.3543 @@ -2,8 +2,8 @@ Make it possible to call class-precedence-list during compute-slots and compute-default-initargs. - * record.d (do_allocate_instance, update_instance, - CLOS::%MAKE-INSTANCE): Test for finalized class by using the + * record.d (do_allocate_instance, update_instance) + (CLOS::%MAKE-INSTANCE): Test for finalized class by using the 'initialized' field, not the 'precedence_list' field. * clos-class1.lisp (class): Change type of initialized slot to integer. (%class-precedence-list): Remove function. @@ -12,19 +12,20 @@ * clos-class3.lisp (subclassp): Test for finalized class by using the 'initialized' slot, not the 'precedence-list' slot. (reinitialize-instance-<class>): Likewise. - (std-compute-subclass-of-stablehash-p, compute-slots-<class>-primary, - compute-slots-<slotted-class>-around, compute-default-initargs-<class>): + (std-compute-subclass-of-stablehash-p, compute-slots-<class>-primary) + (compute-slots-<slotted-class>-around) + (compute-default-initargs-<class>): Use class-precedence-list instead of %class-precedence-list. - (shared-initialize-<built-in-class>, - shared-initialize-<structure-class>): Likewise. Set the initialized - flag to 6. + (shared-initialize-<built-in-class>) + (shared-initialize-<structure-class>): Likewise. Set the + initialized flag to 6. (shared-initialize-<semi-standard-class>): Set initialized flag to 2. (finalize-class): Test for finalized class by using the 'initialized' slot, not the 'precedence-list' slot. (finalize-instance-semi-standard-class): Use class-precedence-list instead of %class-precedence-list. Set the initialized flag to 6. - (make-instances-obsolete-<semi-standard-class>, - make-instances-obsolete-<semi-standard-class>-nonrecursive): + (make-instances-obsolete-<semi-standard-class>) + (make-instances-obsolete-<semi-standard-class>-nonrecursive): Test for finalized class by using the 'initialized' slot, not the 'precedence-list' slot. (update-subclasses-for-redefined-class): Set initialized flag to 2. @@ -35,8 +36,8 @@ (check-class-finalized): Add a level argument. Test for finalized class by using the 'initialized' slot, not the 'precedence-list' slot. (%class-precedence-list): Remove function. - (class-precedence-list, class-slots, class-default-initargs, - class-prototype): Update. + (class-precedence-list, class-slots, class-default-initargs) + (class-prototype): Update. (class-finalized-p@class): Test for finalized class by using the 'initialized' slot, not the 'precedence-list' slot. * clos-print.lisp (print-object@class): Likewise. --__--__-- Message: 3 From: Bruno Haible <ha...@us...> To: cli...@li... Subject: clisp/src ChangeLog,1.3543,1.3544 condition.lisp,1.46,1.47 Date: Tue, 14 Sep 2004 16:32:38 +0000 Reply-To: cli...@li... Update of /cvsroot/clisp/clisp/src In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv27095 Modified Files: ChangeLog condition.lisp Log Message: Let print-condition call print-object, not the other way around. Index: condition.lisp =================================================================== RCS file: /cvsroot/clisp/clisp/src/condition.lisp,v retrieving revision 1.46 retrieving revision 1.47 diff -u -d -r1.46 -r1.47 --- condition.lisp 22 Aug 2004 10:48:25 -0000 1.46 +++ condition.lisp 14 Sep 2004 16:32:21 -0000 1.47 @@ -64,18 +64,20 @@ (t ENGLISH)) (deflocalized print-condition-format ENGLISH (formatter "Condition of type ~S.")) -(clos:defgeneric print-condition (condition stream) - (:method ((condition condition) stream) - (format stream (localized 'print-condition-format) (type-of condition)))) (clos:defmethod clos:print-object ((object condition) stream) (if (or *print-escape* *print-readably*) (clos:call-next-method) - (print-condition object stream))) - -;; Avoid warnings caused by DEFCONDITION adding methods to PRINT-CONDITION. -(ext:without-package-lock ("CLOS") - (pushnew 'print-condition - clos::*dynamically-modifiable-generic-function-names*)) + (progn + (format stream (localized 'print-condition-format) (type-of condition)) + object))) +; Entry-points used by other parts of CLISP. +(defun print-condition (condition stream) + (let ((*print-escape* nil) + (*print-readably* nil)) + (print-object condition stream))) +(defun pretty-print-condition (condition stream &key (indent 6)) + (with-fill-stream (out stream :indent indent) + (print-condition condition out))) ;;; 29.4.5. Defining Conditions ;;; <http://www.lisp.org/HyperSpec/Body/sec_9-1-2.html> @@ -129,10 +131,14 @@ `(PROGN ,defclass-form ,@(when report-function - `((CLOS:DEFMETHOD PRINT-CONDITION ((CONDITION ,name) STREAM) - ,(if (stringp (first report-function)) - `(WRITE-STRING ,(first report-function) STREAM) - `(FUNCALL (FUNCTION ,@report-function) CONDITION STREAM))))) + `((CLOS:DEFMETHOD PRINT-OBJECT ((CONDITION ,name) STREAM) + (IF (OR *PRINT-ESCAPE* *PRINT-READABLY*) + (CLOS:CALL-NEXT-METHOD) + (PROGN + ,(if (stringp (first report-function)) + `(WRITE-STRING ,(first report-function) STREAM) + `(FUNCALL (FUNCTION ,@report-function) CONDITION STREAM)) + CONDITION))))) ',name)))) ;;; 29.4.6. Creating Conditions @@ -397,16 +403,15 @@ (simple-condition-format-arguments condition)))))) |# ) -;; We don't use the :report option here. Instead we define a print-condition +;; We don't use the :report option here. Instead we define a print-object ;; method which will be executed regardless of the condition type's CPL. -(clos:defmethod print-condition :around ((condition simple-condition) stream) - (let ((fstring (simple-condition-format-control condition))) - (if fstring - (apply #'format stream fstring (simple-condition-format-arguments condition)) - (clos:call-next-method)))) -(defun pretty-print-condition (condition stream &key (indent 6)) - (with-fill-stream (out stream :indent indent) - (print-condition condition out))) +(clos:defmethod print-object :around ((condition simple-condition) stream) + (if (or *print-escape* *print-readably*) + (clos:call-next-method) + (let ((fstring (simple-condition-format-control condition))) + (if fstring + (apply #'format stream fstring (simple-condition-format-arguments condition)) + (clos:call-next-method))))) ;; conditions usually created by ERROR or CERROR (define-condition simple-error (simple-condition error) ()) Index: ChangeLog =================================================================== RCS file: /cvsroot/clisp/clisp/src/ChangeLog,v retrieving revision 1.3543 retrieving revision 1.3544 diff -u -d -r1.3543 -r1.3544 --- ChangeLog 14 Sep 2004 15:40:01 -0000 1.3543 +++ ChangeLog 14 Sep 2004 16:32:17 -0000 1.3544 @@ -1,3 +1,14 @@ +2004-09-14 Bruno Haible <br...@cl...> + + * condition.lisp (print-condition): Change from generic function to + plain function. Call print-object. + (print-object@condition): Don't call print-condition. Instead inline + its earlier definition. + (define-condition): Change the macroexpansion to define a method on + print-object, not on print-condition. + (print-condition@simple-condition): Remove. + (print-object@simple-condition): New method. + 2004-08-01 Bruno Haible <br...@cl...> Make it possible to call class-precedence-list during compute-slots --__--__-- Message: 4 From: Bruno Haible <ha...@us...> To: cli...@li... Subject: clisp/src compiler.lisp,1.216,1.217 ChangeLog,1.3544,1.3545 Date: Tue, 14 Sep 2004 17:14:17 +0000 Reply-To: cli...@li... Update of /cvsroot/clisp/clisp/src In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv3366 Modified Files: compiler.lisp ChangeLog Log Message: Fix reporting of *unknown-functions*. Index: compiler.lisp =================================================================== RCS file: /cvsroot/clisp/clisp/src/compiler.lisp,v retrieving revision 1.216 retrieving revision 1.217 diff -u -d -r1.216 -r1.217 --- compiler.lisp 13 Sep 2004 17:03:31 -0000 1.216 +++ compiler.lisp 14 Sep 2004 17:14:12 -0000 1.217 @@ -10659,8 +10659,8 @@ (when *unknown-functions* (c-comment (concatenate 'string "~%" (TEXT "The following functions were used but not defined:~%~{~<~%~:; ~S~>~^~}")) - (delete-duplicates - (mapcar #'car (nreverse *unknown-functions*))))) + (delete-duplicates (mapcar #'car (nreverse *unknown-functions*)) + :test #'equal))) (let ((unknown-vars (set-difference *unknown-free-vars* *known-special-vars*)) (too-late-vars (intersection *unknown-free-vars* Index: ChangeLog =================================================================== RCS file: /cvsroot/clisp/clisp/src/ChangeLog,v retrieving revision 1.3544 retrieving revision 1.3545 diff -u -d -r1.3544 -r1.3545 --- ChangeLog 14 Sep 2004 16:32:17 -0000 1.3544 +++ ChangeLog 14 Sep 2004 17:14:13 -0000 1.3545 @@ -1,5 +1,10 @@ 2004-09-14 Bruno Haible <br...@cl...> + * compiler.lisp (c-report-problems): When reporting unknown functions, + compare function names with EQUAL, not EQL. + +2004-09-14 Bruno Haible <br...@cl...> + * condition.lisp (print-condition): Change from generic function to plain function. Call print-object. (print-object@condition): Don't call print-condition. Instead inline --__--__-- Message: 5 From: Sam Steingold <sd...@us...> To: cli...@li... Subject: clisp/src spvw_sigsegv.d,1.17,1.18 pathname.d,1.329,1.330 lispbibl.d,1.550,1.551 ChangeLog,1.3545,1.3546 Date: Tue, 14 Sep 2004 19:48:25 +0000 Reply-To: cli...@li... Update of /cvsroot/clisp/clisp/src In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv3943/src Modified Files: spvw_sigsegv.d pathname.d lispbibl.d ChangeLog Log Message: support libsigsegv-2.1 on cygwin, which includes <windows.h> from <sigsegv.h> Index: pathname.d =================================================================== RCS file: /cvsroot/clisp/clisp/src/pathname.d,v retrieving revision 1.329 retrieving revision 1.330 diff -u -d -r1.329 -r1.330 --- pathname.d 6 Sep 2004 10:48:11 -0000 1.329 +++ pathname.d 14 Sep 2004 19:48:19 -0000 1.330 @@ -8320,11 +8320,16 @@ } } -#ifdef UNIX -#define NORMAL_PRIORITY_CLASS 0 -#define HIGH_PRIORITY_CLASS -10 -#define IDLE_PRIORITY_CLASS 10 -#define CloseHandle(h) (close(h)==0) +/* on cygwin, <sigsegv.h> includes <windows.h> therefore *_PRIORITY_CLASS + macros are already defined */ +#if !defined(NORMAL_PRIORITY_CLASS) + #define NORMAL_PRIORITY_CLASS 0 + #define HIGH_PRIORITY_CLASS -10 + #define IDLE_PRIORITY_CLASS 10 + #define MY_LOCAL_PRIORITY_CLASSES +#endif +#if defined(UNIX) + #define CloseHandle(h) (close(h)==0) #endif /* paranoidal close */ #define ParaClose(h) if (!CloseHandle(h)) { end_system_call(); OS_error(); } @@ -8566,11 +8571,14 @@ skipSTACK(10); } -#ifdef UNIX -#undef NORMAL_PRIORITY_CLASS -#undef HIGH_PRIORITY_CLASS -#undef IDLE_PRIORITY_CLASS -#undef CloseHandle +#if defined(MY_LOCAL_PRIORITY_CLASSES) + #undef MY_LOCAL_PRIORITY_CLASSES + #undef NORMAL_PRIORITY_CLASS + #undef HIGH_PRIORITY_CLASS + #undef IDLE_PRIORITY_CLASS +#endif +#if defined(UNIX) + #undef CloseHandle #endif #undef ParaClose Index: spvw_sigsegv.d =================================================================== RCS file: /cvsroot/clisp/clisp/src/spvw_sigsegv.d,v retrieving revision 1.17 retrieving revision 1.18 diff -u -d -r1.17 -r1.18 --- spvw_sigsegv.d 6 Sep 2004 10:50:45 -0000 1.17 +++ spvw_sigsegv.d 14 Sep 2004 19:48:18 -0000 1.18 @@ -67,6 +67,9 @@ if (saved_STACK != NULL) { setSTACK(STACK = saved_STACK); } else { # This depends on STACK_register. + #ifdef UNIX_CYGWIN32 + if (scp) { setSTACK(STACK = (gcv_object_t*)(scp->Ebx)); } + #endif #ifdef UNIX_LINUX # stackoverflow_context_t is actually `struct sigcontext *'. # What about MC680X0 and SPARC ?? Index: lispbibl.d =================================================================== RCS file: /cvsroot/clisp/clisp/src/lispbibl.d,v retrieving revision 1.550 retrieving revision 1.551 diff -u -d -r1.550 -r1.551 --- lispbibl.d 14 Sep 2004 11:35:06 -0000 1.550 +++ lispbibl.d 14 Sep 2004 19:48:21 -0000 1.551 @@ -991,14 +991,6 @@ #define switchu switch #endif -# Ignoring of a value (instead of assigning it to a variable) -# unused ... -#ifdef GNU # to prevent a gcc-warning "statement with no effect" - #define unused (void) -#else - #define unused -#endif - # Ignore C++ keyword. #define export export_sym @@ -1727,8 +1719,22 @@ #endif # UNIX || WIN32 #if (defined(UNIX) || defined(WIN32_NATIVE)) && !defined(NO_SIGSEGV) - # Support for fault handling. + /* Support for fault handling. */ #include <sigsegv.h> + #if defined(UNIX_CYGWIN32) + /* <sigsegv.h> includes <windows.h> */ + #undef WIN32 + #undef INVALID_HANDLE_VALUE + #endif +#endif + +/* Ignoring of a value (instead of assigning it to a variable) + unused ... + <sigsegv.h> includes <windows.h> which uses unused! */ +#ifdef GNU /* to prevent a gcc-warning "statement with no effect" */ + #define unused (void) +#else + #define unused #endif # Consensys and Solaris: "#define DS 3", "#define SP ESP", "#define EAX 11". Index: ChangeLog =================================================================== RCS file: /cvsroot/clisp/clisp/src/ChangeLog,v retrieving revision 1.3545 retrieving revision 1.3546 diff -u -d -r1.3545 -r1.3546 --- ChangeLog 14 Sep 2004 17:14:13 -0000 1.3545 +++ ChangeLog 14 Sep 2004 19:48:22 -0000 1.3546 @@ -1,3 +1,13 @@ +2004-09-14 Sam Steingold <sd...@gn...> + + support libsigsegv-2.1 on cygwin, + which includes <windows.h> from <sigsegv.h> + * lispbibl.d [UNIX_CYGWIN32]: undefine WIN32 and + INVALID_HANDLE_VALUE after including <sigsegv.h> + define unused after including <sigsegv.h> because it is used by woe32 + * pathname.d [UNIX_CYGWIN32]: do not redefine *_PRIORITY_CLASS + * spvw_sigsegv.d (stackoverflow_handler) [UNIX_CYGWIN32]: use Ebx + 2004-09-14 Bruno Haible <br...@cl...> * compiler.lisp (c-report-problems): When reporting unknown functions, --__--__-- _______________________________________________ clisp-cvs mailing list cli...@li... https://lists.sourceforge.net/lists/listinfo/clisp-cvs End of clisp-cvs Digest |
