Menu
▾
▴
clisp-cvs digest, Vol 1 #614 - 9 msgs
|
From: <cli...@li...> - 2004-07-21 19:14:09
|
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 clos-class3.lisp,1.19,1.20 clos-class4.lisp,1.8,1.9 ChangeLog,1.3311,1.3312 (Bruno Haible) 2. clisp/src clos-class3.lisp,1.20,1.21 clos-class6.lisp,1.13,1.14 ChangeLog,1.3312,1.3313 (Bruno Haible) 3. clisp/src NEWS,1.159,1.160 (Bruno Haible) 4. clisp/src clos-class5.lisp,1.27,1.28 (Bruno Haible) 5. clisp/src TODO,1.13,1.14 (Bruno Haible) 6. clisp/modules/oracle oracle.lisp,1.16,1.17 oracle.xml,1.9,1.10 (John Hinsdale) 7. clisp/src ChangeLog,1.3313,1.3314 (John Hinsdale) 8. clisp/doc mop.xml,1.7,1.8 (Sam Steingold) 9. clisp/modules/berkeley-db berkeley-db.xml,1.23,1.24 (Sam Steingold) --__--__-- Message: 1 From: Bruno Haible <ha...@us...> To: cli...@li... Subject: clisp/src clos-class3.lisp,1.19,1.20 clos-class4.lisp,1.8,1.9 ChangeLog,1.3311,1.3312 Date: Wed, 21 Jul 2004 10:52:43 +0000 Reply-To: cli...@li... Update of /cvsroot/clisp/clisp/src In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv30678/src Modified Files: clos-class3.lisp clos-class4.lisp ChangeLog Log Message: Let class redefinition go through REINITIALIZE-INSTANCE. Index: clos-class3.lisp =================================================================== RCS file: /cvsroot/clisp/clisp/src/clos-class3.lisp,v retrieving revision 1.19 retrieving revision 1.20 diff -u -d -r1.19 -r1.20 --- clos-class3.lisp 20 Jul 2004 11:28:25 -0000 1.19 +++ clos-class3.lisp 21 Jul 2004 10:52:40 -0000 1.20 @@ -292,6 +292,8 @@ (documentation nil) (fixed-slot-locations nil) &allow-other-keys) + (declare (ignore direct-slots direct-default-initargs documentation + fixed-slot-locations)) ;; Argument checks. (unless (symbolp name) (error (TEXT "~S: class name ~S should be a symbol") @@ -356,115 +358,11 @@ direct-superclasses)) (if class ;; Modify the class and return the modified class. - (progn - (if (and (%class-precedence-list class) ; 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.") - 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. - (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) - (let ((new-c (or (find-class c nil) c))) - (unless (symbolp new-c) - (check-allowed-superclass class new-c)) - (setf (car l) new-c) - (when (class-p new-c) ; changed from symbol to class - (add-direct-subclass new-c class))))))) - ;; Convert the direct-slots to <direct-slot-definition> instances. - (setq direct-slots (convert-direct-slots class direct-slots)) - ;; 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 (or direct-superclasses (default-direct-superclasses class)) - (class-direct-superclasses class)) - (equal-direct-slots direct-slots (class-direct-slots class)) - (equal-default-initargs direct-default-initargs - (class-direct-default-initargs class)) - (eq fixed-slot-locations (class-fixed-slot-locations 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 (car l-old)) - (new (car l-new))) - (setf (slot-definition-initform old) (slot-definition-initform new)) - (setf (slot-definition-initfunction old) (slot-definition-initfunction new)) - (setf (slot-definition-documentation old) (slot-definition-documentation new)))) - ;; Store new default-initargs: - (do ((l-old (class-direct-default-initargs class) (cdr l-old)) - (l-new direct-default-initargs (cdr l-new))) - ((null l-new)) - (let ((old (cdar l-old)) - (new (cdar l-new))) - ;; Move initform and initfunction from new destructively into - ;; the old one: - (setf (car old) (car new)) - (setf (cadr old) (cadr new)))) - ;; Store new documentation: - (setf (class-documentation class) documentation) - ;; NB: These modifications are automatically inherited by the - ;; subclasses of class! Due to <inheritable-slot-definition-initer> - ;; and <inheritable-slot-definition-doc>. - ) - ;; Instances have to be updated: - (let* ((was-finalized (%class-precedence-list class)) - (must-be-finalized - (and was-finalized - (some #'class-instantiated (list-all-finalized-subclasses class)))) - (old-direct-superclasses (class-direct-superclasses class)) - (old-direct-accessors (class-direct-accessors class)) - old-class) - ;; ANSI CL 4.3.6. Remove accessor methods created by old DEFCLASS. - (remove-accessor-methods old-direct-accessors) - (setf (class-direct-accessors class) '()) - ;; Clear the cached prototype. - (setf (class-prototype class) nil) - ;; Declare all instances as obsolete, and backup the class object. - (let ((old-version (class-current-version class)) - (*make-instances-obsolete-caller* 'defclass)) - (make-instances-obsolete class) - (setq old-class (cv-class old-version))) - (locally (declare (compile)) - (sys::%handler-bind - ;; If an error occurs during the class redefinition, switch back - ;; to the old definition, so that existing instances can continue - ;; to be used. - ((ERROR #'(lambda (condition) - (declare (ignore condition)) - ;; Restore the class using the backup copy. - (let ((new-version (class-current-version class))) - (dotimes (i (sys::%record-length class)) - (setf (sys::%record-ref class i) (sys::%record-ref old-class i))) - (setf (class-current-version class) new-version)) - ;; Restore the accessor methods. - (add-accessor-methods old-direct-accessors) - (setf (class-direct-accessors class) old-direct-accessors)))) - (apply (cond ((eq metaclass <standard-class>) - #'shared-initialize-<standard-class>) - ((eq metaclass <built-in-class>) - #'shared-initialize-<built-in-class>) - ((eq metaclass <structure-class>) - #'shared-initialize-<structure-class>) - (t #'shared-initialize)) - class - nil - :name name - :direct-superclasses direct-superclasses - 'direct-slots direct-slots - all-keys) - ;; FIXME: Need to handle changes of shared slots here? - (update-subclasses-for-redefined-class class - was-finalized must-be-finalized old-direct-superclasses))))))) - (install-class-direct-accessors class)) + (apply #'reinitialize-instance ; => #'reinitialize-instance-<class> + class + :name name + :direct-superclasses direct-superclasses + all-keys) (setf (find-class name) (setq class (apply (cond ((eq metaclass <standard-class>) @@ -479,16 +377,6 @@ :direct-superclasses direct-superclasses all-keys)))) class)) -(defun equal-direct-slots (slots1 slots2) - (or (and (null slots1) (null slots2)) - (and (consp slots1) (consp slots2) - (equal-direct-slot (first slots1) (first slots2)) - (equal-direct-slots (rest slots1) (rest slots2))))) -(defun equal-default-initargs (initargs1 initargs2) - (or (and (null initargs1) (null initargs2)) - (and (consp initargs1) (consp initargs2) - (eq (car (first initargs1)) (car (first initargs2))) - (equal-default-initargs (cdr initargs1) (cdr initargs2))))) ;; Preliminary. (defun ensure-class-using-class (class name &rest args @@ -534,6 +422,141 @@ (declare (ignore class direct-slot initargs)) <standard-writer-method>) +;; ---------------------------- Class redefinition ---------------------------- + +(defun reinitialize-instance-<class> (class &rest all-keys + &key (direct-superclasses '() direct-superclasses-p) + (direct-slots '() direct-slots-p) + (direct-default-initargs '() direct-default-initargs-p) + (documentation nil documentation-p) + (fixed-slot-locations nil fixed-slot-locations-p) + &allow-other-keys + &aux (metaclass (class-of class))) + (if (and (%class-precedence-list class) ; 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.") + class) + (progn + (when direct-superclasses-p + ;; 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. + (when (and (subclassp metaclass <standard-class>) + (null (%class-precedence-list class))) + (do ((l (class-direct-superclasses class) (cdr l))) + ((atom l)) + (let ((c (car l))) + (unless (class-p c) + (let ((new-c (or (find-class c nil) c))) + (unless (symbolp new-c) + (check-allowed-superclass class new-c)) + (setf (car l) new-c) + (when (class-p new-c) ; changed from symbol to class + (add-direct-subclass new-c class)))))))) + (when direct-slots-p + ;; Convert the direct-slots to <direct-slot-definition> instances. + (setq direct-slots (convert-direct-slots class direct-slots))) + ;; 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 (or (and direct-superclasses-p + (not (equal (or direct-superclasses (default-direct-superclasses class)) + (class-direct-superclasses class)))) + (and direct-slots-p + (not (equal-direct-slots direct-slots (class-direct-slots class)))) + (and direct-default-initargs-p + (not (equal-default-initargs direct-default-initargs + (class-direct-default-initargs class)))) + (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)) + (must-be-finalized + (and was-finalized + (some #'class-instantiated (list-all-finalized-subclasses class)))) + (old-direct-superclasses (class-direct-superclasses class)) + (old-direct-accessors (class-direct-accessors class)) + old-class) + ;; ANSI CL 4.3.6. Remove accessor methods created by old DEFCLASS. + (remove-accessor-methods old-direct-accessors) + (setf (class-direct-accessors class) '()) + ;; Clear the cached prototype. + (setf (class-prototype class) nil) + ;; Declare all instances as obsolete, and backup the class object. + (let ((old-version (class-current-version class)) + (*make-instances-obsolete-caller* 'defclass)) + (make-instances-obsolete class) + (setq old-class (cv-class old-version))) + (locally (declare (compile)) + (sys::%handler-bind + ;; If an error occurs during the class redefinition, switch back + ;; to the old definition, so that existing instances can continue + ;; to be used. + ((ERROR #'(lambda (condition) + (declare (ignore condition)) + ;; Restore the class using the backup copy. + (let ((new-version (class-current-version class))) + (dotimes (i (sys::%record-length class)) + (setf (sys::%record-ref class i) (sys::%record-ref old-class i))) + (setf (class-current-version class) new-version)) + ;; Restore the accessor methods. + (add-accessor-methods old-direct-accessors) + (setf (class-direct-accessors class) old-direct-accessors)))) + (apply #'shared-initialize ; => #'shared-initialize-<built-in-class> + ; #'shared-initialize-<standard-class> + ; #'shared-initialize-<structure-class> + class + nil + `(,@(if direct-slots-p (list 'direct-slots direct-slots) '()) + ,@all-keys)) + (update-subclasses-for-redefined-class class + was-finalized must-be-finalized old-direct-superclasses)))) + ;; Instances don't need to be updated: + (progn + (when direct-slots-p + ;; 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 (car l-old)) + (new (car l-new))) + (setf (slot-definition-initform old) (slot-definition-initform new)) + (setf (slot-definition-initfunction old) (slot-definition-initfunction new)) + (setf (slot-definition-documentation old) (slot-definition-documentation new))))) + (when direct-default-initargs-p + ;; Store new default-initargs: + (do ((l-old (class-direct-default-initargs class) (cdr l-old)) + (l-new direct-default-initargs (cdr l-new))) + ((null l-new)) + (let ((old (cdar l-old)) + (new (cdar l-new))) + ;; Move initform and initfunction from new destructively into + ;; the old one: + (setf (car old) (car new)) + (setf (cadr old) (cadr new))))) + (when documentation-p + ;; Store new documentation: + (setf (class-documentation class) documentation)) + ;; NB: These modifications are automatically inherited by the + ;; subclasses of class! Due to <inheritable-slot-definition-initer> + ;; and <inheritable-slot-definition-doc>. + ) ) ) ) + (install-class-direct-accessors class) + class) + +(defun equal-direct-slots (slots1 slots2) + (or (and (null slots1) (null slots2)) + (and (consp slots1) (consp slots2) + (equal-direct-slot (first slots1) (first slots2)) + (equal-direct-slots (rest slots1) (rest slots2))))) +(defun equal-default-initargs (initargs1 initargs2) + (or (and (null initargs1) (null initargs2)) + (and (consp initargs1) (consp initargs2) + (eq (car (first initargs1)) (car (first initargs2))) + (equal-default-initargs (cdr initargs1) (cdr initargs2))))) + ;; ----------------------- General routines for <class> ----------------------- ;; Preliminary. Index: clos-class4.lisp =================================================================== RCS file: /cvsroot/clisp/clisp/src/clos-class4.lisp,v retrieving revision 1.8 retrieving revision 1.9 diff -u -d -r1.8 -r1.9 --- clos-class4.lisp 20 Jul 2004 11:26:55 -0000 1.8 +++ clos-class4.lisp 21 Jul 2004 10:52:40 -0000 1.9 @@ -17,6 +17,10 @@ direct-default-initargs documentation)) (apply #'shared-initialize-<class> class situation args)) +(defmethod reinitialize-instance ((class class) &rest args + &key &allow-other-keys) + (apply #'reinitialize-instance-<class> class args)) + ;;; =========================================================================== (defmethod shared-initialize ((class built-in-class) situation &rest args Index: ChangeLog =================================================================== RCS file: /cvsroot/clisp/clisp/src/ChangeLog,v retrieving revision 1.3311 retrieving revision 1.3312 diff -u -d -r1.3311 -r1.3312 --- ChangeLog 20 Jul 2004 16:17:45 -0000 1.3311 +++ ChangeLog 21 Jul 2004 10:52:40 -0000 1.3312 @@ -1,3 +1,12 @@ +2004-05-31 Bruno Haible <br...@cl...> + + Let class redefinition go through REINITIALIZE-INSTANCE. + * clos-class3.lisp (ensure-class-using-class-<t>): Call + reinitialize-instance. + (reinitialize-instance-<class>): New function, extracted from + ensure-class-using-class-<t>. + * clos-class4.lisp (reinitialize-instance@class): New method. + 2004-07-20 Sam Steingold <sd...@gn...> * modules/rawsock/rawsock.c (configdev): fixed STACK references --__--__-- Message: 2 From: Bruno Haible <ha...@us...> To: cli...@li... Subject: clisp/src clos-class3.lisp,1.20,1.21 clos-class6.lisp,1.13,1.14 ChangeLog,1.3312,1.3313 Date: Wed, 21 Jul 2004 10:53:30 +0000 Reply-To: cli...@li... Update of /cvsroot/clisp/clisp/src In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv30766/src Modified Files: clos-class3.lisp clos-class6.lisp ChangeLog Log Message: Implement (SETF CLASS-NAME). Index: clos-class3.lisp =================================================================== RCS file: /cvsroot/clisp/clisp/src/clos-class3.lisp,v retrieving revision 1.20 retrieving revision 1.21 diff -u -d -r1.20 -r1.21 --- clos-class3.lisp 21 Jul 2004 10:52:40 -0000 1.20 +++ clos-class3.lisp 21 Jul 2004 10:53:27 -0000 1.21 @@ -360,7 +360,6 @@ ;; Modify the class and return the modified class. (apply #'reinitialize-instance ; => #'reinitialize-instance-<class> class - :name name :direct-superclasses direct-superclasses all-keys) (setf (find-class name) @@ -425,7 +424,8 @@ ;; ---------------------------- Class redefinition ---------------------------- (defun reinitialize-instance-<class> (class &rest all-keys - &key (direct-superclasses '() direct-superclasses-p) + &key (name nil name-p) + (direct-superclasses '() direct-superclasses-p) (direct-slots '() direct-slots-p) (direct-default-initargs '() direct-default-initargs-p) (documentation nil documentation-p) @@ -460,7 +460,7 @@ ;; 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. + ;; changed class-options :name, :default-initargs, :documentation. (if (or (and direct-superclasses-p (not (equal (or direct-superclasses (default-direct-superclasses class)) (class-direct-superclasses class)))) @@ -512,9 +512,13 @@ `(,@(if direct-slots-p (list 'direct-slots direct-slots) '()) ,@all-keys)) (update-subclasses-for-redefined-class class - was-finalized must-be-finalized old-direct-superclasses)))) + was-finalized must-be-finalized old-direct-superclasses))) + (install-class-direct-accessors class)) ;; Instances don't need to be updated: (progn + (when name-p + ;; Store new name: + (setf (class-classname class) name)) (when direct-slots-p ;; Store new slot-inits: (do ((l-old (class-direct-slots class) (cdr l-old)) @@ -542,8 +546,8 @@ ;; NB: These modifications are automatically inherited by the ;; subclasses of class! Due to <inheritable-slot-definition-initer> ;; and <inheritable-slot-definition-doc>. + ;; No need to call (install-class-direct-accessors class) here. ) ) ) ) - (install-class-direct-accessors class) class) (defun equal-direct-slots (slots1 slots2) Index: clos-class6.lisp =================================================================== RCS file: /cvsroot/clisp/clisp/src/clos-class6.lisp,v retrieving revision 1.13 retrieving revision 1.14 diff -u -d -r1.13 -r1.14 --- clos-class6.lisp 20 Jul 2004 11:28:25 -0000 1.13 +++ clos-class6.lisp 21 Jul 2004 10:53:27 -0000 1.14 @@ -66,8 +66,8 @@ (error-of-type 'error (TEXT "~S: The name of the built-in class ~S cannot be modified") '(setf class-name) class)) - ; TODO: Call (reinitialize-instance class :name new-value) instead. - (setf (class-classname class) new-value))) + (reinitialize-instance class :name new-value) + new-value)) ;; MOP p. 76 (fmakunbound 'class-direct-superclasses) Index: ChangeLog =================================================================== RCS file: /cvsroot/clisp/clisp/src/ChangeLog,v retrieving revision 1.3312 retrieving revision 1.3313 diff -u -d -r1.3312 -r1.3313 --- ChangeLog 21 Jul 2004 10:52:40 -0000 1.3312 +++ ChangeLog 21 Jul 2004 10:53:27 -0000 1.3313 @@ -1,5 +1,14 @@ 2004-05-31 Bruno Haible <br...@cl...> + Implement (SETF CLASS-NAME) as the MOP says. + * clos-class3.lisp (ensure-class-using-class-<t>): Don't pass :name + initializer to reinitialize-instance. + (reinitialize-instance-<class>): Accept :name argument. Don't call + install-class-direct-accessors when not needed. + * clos-class6.lisp ((setf class-name)): Call reinitialize-instance. + +2004-05-31 Bruno Haible <br...@cl...> + Let class redefinition go through REINITIALIZE-INSTANCE. * clos-class3.lisp (ensure-class-using-class-<t>): Call reinitialize-instance. --__--__-- Message: 3 From: Bruno Haible <ha...@us...> To: cli...@li... Subject: clisp/src NEWS,1.159,1.160 Date: Wed, 21 Jul 2004 10:55:04 +0000 Reply-To: cli...@li... Update of /cvsroot/clisp/clisp/src In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv30933/src Modified Files: NEWS Log Message: MOP for classes is now supported. Index: NEWS =================================================================== RCS file: /cvsroot/clisp/clisp/src/NEWS,v retrieving revision 1.159 retrieving revision 1.160 diff -u -d -r1.159 -r1.160 --- NEWS 25 Jun 2004 10:46:14 -0000 1.159 +++ NEWS 21 Jul 2004 10:55:02 -0000 1.160 @@ -11,6 +11,22 @@ -------------------- * Parts of the CLOS MetaObject Protocol are supported: + + Classes: + New classes + STANDARD-READER-METHOD, STANDARD-WRITER-METHOD. + New functions + ENSURE-CLASS. + New generic functions + CLASS-DIRECT-SUPERCLASSES, CLASS-PRECEDENCE-LIST, CLASS-DIRECT-SLOTS, + CLASS-SLOTS, CLASS-DIRECT-DEFAULT-INITARGS, CLASS-DEFAULT-INITARGS. + New customizable generic functions + For class creation: + ENSURE-CLASS-USING-CLASS, VALIDATE-SUPERCLASS, + COMPUTE-CLASS-PRECEDENCE-LIST, COMPUTE-EFFECTIVE-SLOT-DEFINITION, + COMPUTE-SLOTS, COMPUTE-DEFAULT-INITARGS, READER-METHOD-CLASS, + WRITER-METHOD-CLASS. + For notification about subclasses: + CLASS-DIRECT-SUBCLASSES, ADD-DIRECT-SUBCLASS, REMOVE-DIRECT-SUBCLASS. + Method-Combinations: New generic function FIND-METHOD-COMBINATION. --__--__-- Message: 4 From: Bruno Haible <ha...@us...> To: cli...@li... Subject: clisp/src clos-class5.lisp,1.27,1.28 Date: Wed, 21 Jul 2004 10:55:29 +0000 Reply-To: cli...@li... Update of /cvsroot/clisp/clisp/src In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv31028/src Modified Files: clos-class5.lisp Log Message: Nop. Index: clos-class5.lisp =================================================================== RCS file: /cvsroot/clisp/clisp/src/clos-class5.lisp,v retrieving revision 1.27 retrieving revision 1.28 diff -u -d -r1.27 -r1.28 --- clos-class5.lisp 17 Jul 2004 16:00:04 -0000 1.27 +++ clos-class5.lisp 21 Jul 2004 10:55:27 -0000 1.28 @@ -495,8 +495,7 @@ (apply si-ef instance 'T initargs))))) ;; User-defined methods on allocate-instance are now supported. -(defgeneric allocate-instance - (instance &rest initargs &key &allow-other-keys)) +(defgeneric allocate-instance (instance &rest initargs &key &allow-other-keys)) (setq |#'allocate-instance| #'allocate-instance) #|| (defgeneric allocate-instance (class) --__--__-- Message: 5 From: Bruno Haible <ha...@us...> To: cli...@li... Subject: clisp/src TODO,1.13,1.14 Date: Wed, 21 Jul 2004 11:02:29 +0000 Reply-To: cli...@li... Update of /cvsroot/clisp/clisp/src In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv32023 Modified Files: TODO Log Message: Work items not to forget. Index: TODO =================================================================== RCS file: /cvsroot/clisp/clisp/src/TODO,v retrieving revision 1.13 retrieving revision 1.14 diff -u -d -r1.13 -r1.14 --- TODO 16 Jan 2004 11:16:22 -0000 1.13 +++ TODO 21 Jul 2004 11:02:26 -0000 1.14 @@ -1,5 +1,22 @@ This file contains suggestions for further work. +MUST-FIX BEFORE NEXT RELEASE +============================ + +Finish MOP. (Bruno) + +Defstruct accessors are defined twice, which leads to warnings. (Bruno) + +Contagion warnings emitted by many floating-point operations. (Bruno) + +Reordered MOP documentation. (Sam) + +fill-stream cannot print structured multiline objects reasonably: it +flattens all whitespace. (Sam) + +Many pretty-printer test failures. (Sam) + + URGENT PROBLEMS =============== --__--__-- Message: 6 From: John Hinsdale <hi...@us...> To: cli...@li... Subject: clisp/modules/oracle oracle.lisp,1.16,1.17 oracle.xml,1.9,1.10 Date: Wed, 21 Jul 2004 13:50:07 +0000 Reply-To: cli...@li... Update of /cvsroot/clisp/clisp/modules/oracle In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv26707 Modified Files: oracle.lisp oracle.xml Log Message: Identify FLOAT type properly; clean up multiple SETFs Index: oracle.lisp =================================================================== RCS file: /cvsroot/clisp/clisp/modules/oracle/oracle.lisp,v retrieving revision 1.16 retrieving revision 1.17 diff -u -d -r1.16 -r1.17 --- oracle.lisp 27 Jan 2004 15:30:41 -0000 1.16 +++ oracle.lisp 21 Jul 2004 13:50:05 -0000 1.17 @@ -159,8 +159,8 @@ (when (not (lisp-truth (oracle_success conn-handle))) (oracle_disconnect conn-handle) ; Don't check for error here (remhash hkey *oracle-connection-cache*) - (setf conn nil) - (setf *oracle-connection* nil)))) + (setf conn nil + *oracle-connection* nil)))) (when (null conn) ; Connect to database @@ -171,9 +171,9 @@ ; Failed all attempts; give up (db-error (oracle_last_error handle))) ; OK: cache the connection - (setf conn (make-db :connection handle :hkey hkey)) - (setf (gethash hkey *oracle-connection-cache*) conn) - (setf result nil))) + (setf conn (make-db :connection handle :hkey hkey) + (gethash hkey *oracle-connection-cache*) conn + result nil))) ; Set current connection (setf *oracle-connection* conn) result)) @@ -241,9 +241,9 @@ sql (hash-to-sqlparam-array params) (c-truth (not is-select))) - (setf (db-fetch-called *oracle-connection*) nil) - (setf (db-pending-row *oracle-connection*) nil) - (setf (db-colinfo *oracle-connection*) nil) + (setf (db-fetch-called *oracle-connection*) nil + (db-pending-row *oracle-connection*) nil + (db-colinfo *oracle-connection*) nil) (check-success) ; Get the row count for the result @@ -357,8 +357,8 @@ (cond ; Use pending look-ahead row and reset, else do a "real" fetch ((db-pending-row *oracle-connection*) - (setf result (row-to-result (db-pending-row *oracle-connection*) result-type)) - (setf (db-pending-row *oracle-connection*) nil)) + (setf result (row-to-result (db-pending-row *oracle-connection*) result-type) + (db-pending-row *oracle-connection*) nil)) ; Check if already at EOF from previous fetches ((and (db-fetch-called *oracle-connection*) @@ -474,6 +474,13 @@ ; Convert C truth to Lisp for export (map-into result #'(lambda (col) + ; Oracle identifies FLOAT using special value -127 for scale, + ; (which is irrelevant for floats). In this case, map to "FLOAT" + ; for type name and NIL for scale. Precision will be given in bits + ; as ANSI specifies + (when (and (equal (sqlcol-type col) "NUMBER") (= (sqlcol-scale col) -127)) + (setf (sqlcol-scale col) nil + (sqlcol-type col) "FLOAT")) (setf (sqlcol-null_ok col) (lisp-truth (sqlcol-null_ok col))) col) result) Index: oracle.xml =================================================================== RCS file: /cvsroot/clisp/clisp/modules/oracle/oracle.xml,v retrieving revision 1.9 retrieving revision 1.10 diff -u -d -r1.9 -r1.10 --- oracle.xml 29 Jun 2004 13:41:19 -0000 1.9 +++ oracle.xml 21 Jul 2004 13:50:05 -0000 1.10 @@ -328,11 +328,11 @@ <listitem><simpara>&oracle-link; data length (useful mostly for character types)</simpara></listitem></varlistentry> <varlistentry><term>SCALE</term> - <listitem><simpara>For numeric types, number of digits to right of - decimal</simpara></listitem></varlistentry> + <listitem><simpara>For numeric (NUMBER) types, number of digits to right of + decimal; NIL for FLOAT</simpara></listitem></varlistentry> <varlistentry><term>PRECISION</term> <listitem><simpara>For numeric types, total number of significant - digits</simpara></listitem></varlistentry> + digits (decimal digits for NUMBER, bits for FLOAT)</simpara></listitem></varlistentry> <varlistentry><term>NULL_OK</term> <listitem><simpara>&t; if &c-NULL;s allowed, &nil; if &c-NULL;s are not allowed.</simpara></listitem></varlistentry> --__--__-- Message: 7 From: John Hinsdale <hi...@us...> To: cli...@li... Subject: clisp/src ChangeLog,1.3313,1.3314 Date: Wed, 21 Jul 2004 13:51:44 +0000 Reply-To: cli...@li... Update of /cvsroot/clisp/clisp/src In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv26880 Modified Files: ChangeLog Log Message: Minor oracle fix Index: ChangeLog =================================================================== RCS file: /cvsroot/clisp/clisp/src/ChangeLog,v retrieving revision 1.3313 retrieving revision 1.3314 diff -u -d -r1.3313 -r1.3314 --- ChangeLog 21 Jul 2004 10:53:27 -0000 1.3313 +++ ChangeLog 21 Jul 2004 13:51:41 -0000 1.3314 @@ -1,3 +1,7 @@ +2004-07-21 John Hinsdale <hi...@al...> + + * modules/oracle/oracle.lisp: Handle FLOAT type properly + 2004-05-31 Bruno Haible <br...@cl...> Implement (SETF CLASS-NAME) as the MOP says. --__--__-- Message: 8 From: Sam Steingold <sd...@us...> To: cli...@li... Subject: clisp/doc mop.xml,1.7,1.8 Date: Wed, 21 Jul 2004 14:58:35 +0000 Reply-To: cli...@li... Update of /cvsroot/clisp/clisp/doc In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv5841/doc Modified Files: mop.xml Log Message: typo Index: mop.xml =================================================================== RCS file: /cvsroot/clisp/clisp/doc/mop.xml,v retrieving revision 1.7 retrieving revision 1.8 diff -u -d -r1.7 -r1.8 --- mop.xml 16 Jul 2004 20:17:25 -0000 1.7 +++ mop.xml 21 Jul 2004 14:58:32 -0000 1.8 @@ -1750,7 +1750,7 @@ <title>Generic Function &compute-applicable-methods-mop;</title> <variablelist><varlistentry><term>Syntax</term> - <listitem><simpara><literal role="sexp">&compute-applicable-methods-mop; + <listitem><simpara><literal role="sexp">(&compute-applicable-methods-mop; &gf-r; &args-r;)</literal></simpara></listitem></varlistentry> <varlistentry><term>Arguments</term> <listitem><variablelist> --__--__-- Message: 9 From: Sam Steingold <sd...@us...> To: cli...@li... Subject: clisp/modules/berkeley-db berkeley-db.xml,1.23,1.24 Date: Wed, 21 Jul 2004 19:11:52 +0000 Reply-To: cli...@li... Update of /cvsroot/clisp/clisp/modules/berkeley-db In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv3712/modules/berkeley-db Modified Files: berkeley-db.xml Log Message: typo Index: berkeley-db.xml =================================================================== RCS file: /cvsroot/clisp/clisp/modules/berkeley-db/berkeley-db.xml,v retrieving revision 1.23 retrieving revision 1.24 diff -u -d -r1.23 -r1.24 --- berkeley-db.xml 20 Jul 2004 14:12:13 -0000 1.23 +++ berkeley-db.xml 21 Jul 2004 19:11:50 -0000 1.24 @@ -64,7 +64,7 @@ <member>&DBE_set_timeout;</member> <member>&DBE_set_encrypt;</member> <member>&DBE_set_errfile;</member> - </simplelist>.</para></listitem></varlistentry> + </simplelist></para></listitem></varlistentry> <varlistentry><term><literal role="sexp">(BDB:ENV-GET-OPTIONS dbe &optional-amp; what)</literal></term> <listitem><para>Retrieve some environment options. @@ -174,7 +174,7 @@ <simplelist columns="2"><member><constant>:DB_CONSUME</constant></member> <member><constant>:DB_CONSUME_WAIT</constant></member> <member><constant>:DB_GET_BOTH</constant></member> - <member><constant>:DB_SET_RECNO</constant></member></simplelist>. + <member><constant>:DB_SET_RECNO</constant></member></simplelist> </para></listitem></varlistentry> <varlistentry><term><literal role="sexp">(BDB:DB-PUT db key val &key-amp; AUTO_COMMIT ACTION TRANSACTION)</literal></term> @@ -182,7 +182,7 @@ <constant>:ACTION</constant> should be one of <simplelist columns="3"><member><constant>:DB_APPEND</constant></member> <member><constant>:DB_NODUPDATA</constant></member> - <member><constant>:DB_NOOVERWRITE</constant></member></simplelist>. + <member><constant>:DB_NOOVERWRITE</constant></member></simplelist> </para></listitem></varlistentry> <varlistentry><term><literal role="sexp">(BDB:DB-STAT db &key-amp; FAST_STAT)</literal></term> @@ -197,7 +197,7 @@ <member><constant>:HASH</constant></member> <member><constant>:QUEUE</constant></member> <member><constant>:RECNO</constant></member> - <member><constant>:UNKNOWN</constant> (default)</member></simplelist>. + <member><constant>:UNKNOWN</constant> (default)</member></simplelist> </para></listitem></varlistentry> <varlistentry><term><literal role="sexp">(BDB:DB-SYNC db)</literal></term> <listitem><simpara>Flush a database to stable storage (&DB_sync;). @@ -275,7 +275,7 @@ <member>&DB_set_re_pad;</member> <member>&DB_set_re_source;</member> <member>&DB_set_flags;</member> - </simplelist>.</para></listitem></varlistentry> + </simplelist></para></listitem></varlistentry> <varlistentry><term><literal role="sexp">(BDB:DB-GET-OPTIONS db &optional-amp; what)</literal></term> <listitem><para>Retrieve some database options. @@ -342,7 +342,7 @@ for <constant>:RECNO</constant> databases (&DB_get_re_source;). </simpara></listitem></varlistentry> <varlistentry><term><constant>:LORDER</constant></term> - <listitem><simpara>database byte orderb (&DB_get_lorder;). + <listitem><simpara>database byte order (&DB_get_lorder;). </simpara></listitem></varlistentry> </variablelist></para> <warning><para>Once you call a method for one type of access method, @@ -427,7 +427,7 @@ <listitem><para>Retrieve by cursor (&DBC_get;). If &error-k; is &nil; and the record is not found, no &err-sig;, <constant>:NOTFOUND</constant> or <constant>:KEYEMPTY</constant> - is returned instead. + is returned instead, as appropriate. <replaceable>action</replaceable> should be one of <simplelist columns="4"><member><constant>:DB_CURRENT</constant></member> <member><constant>:DB_FIRST</constant></member> @@ -443,7 +443,7 @@ <member><constant>:DB_PREV_NODUP</constant></member> <member><constant>:DB_SET</constant></member> <member><constant>:DB_SET_RANGE</constant></member> - <member><constant>:DB_SET_RECNO</constant></member></simplelist>. + <member><constant>:DB_SET_RECNO</constant></member></simplelist> </para></listitem></varlistentry> <varlistentry><term><literal role="sexp">(BDB:CURSOR-PUT cursor key data flag)</literal></term> --__--__-- _______________________________________________ clisp-cvs mailing list cli...@li... https://lists.sourceforge.net/lists/listinfo/clisp-cvs End of clisp-cvs Digest |