From: <cli...@li...> - 2004-06-21 19:03:03
|
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.523,1.524 clos-class2.lisp,1.37,1.38 ChangeLog,1.3202,1.3203 (Bruno Haible) 2. clisp/src clos-genfun2.lisp,1.9,1.10 clos-methcomb1.lisp,1.4,1.5 clos-methcomb2.lisp,1.11,1.12 ChangeLog,1.3203,1.3204 (Bruno Haible) 3. clisp/doc unix-ent.xml,1.31,1.32 (Sam Steingold) 4. clisp/doc impent.xml,1.136,1.137 (Sam Steingold) 5. clisp/doc impext.xml,1.238,1.239 (Sam Steingold) 6. clisp/doc impbyte.xml,1.52,1.53 (Sam Steingold) 7. clisp/modules/berkeley-db bdb.c,1.10,1.11 (Sam Steingold) --__--__-- Message: 1 From: Bruno Haible <ha...@us...> To: cli...@li... Subject: clisp/src lispbibl.d,1.523,1.524 clos-class2.lisp,1.37,1.38 ChangeLog,1.3202,1.3203 Date: Mon, 21 Jun 2004 10:31:29 +0000 Reply-To: cli...@li... Update of /cvsroot/clisp/clisp/src In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv10784/src Modified Files: lispbibl.d clos-class2.lisp ChangeLog Log Message: Add direct-subclasses slot to every class. Index: clos-class2.lisp =================================================================== RCS file: /cvsroot/clisp/clisp/src/clos-class2.lisp,v retrieving revision 1.37 retrieving revision 1.38 diff -u -d -r1.37 -r1.38 --- clos-class2.lisp 18 Jun 2004 10:55:30 -0000 1.37 +++ clos-class2.lisp 21 Jun 2004 10:31:24 -0000 1.38 @@ -35,6 +35,7 @@ all-superclasses ; hash table of all superclasses (incl. the class itself) precedence-list ; ordered list of all superclasses (with the class itself first), ; or NIL while the class is waiting to be finalized + direct-subclasses-table ; weak-list or weak-hash-table of all direct subclasses direct-slots ; list of all freshly added slots (as direct-slot-definition instances) slots ; list of all slots (as effective-slot-definitions) (slot-location-table empty-ht) ; hash table slotname -> location of the slot @@ -358,7 +359,10 @@ ((atom l)) (let ((c (car l))) (unless (class-p c) - (setf (car l) (or (find-class c nil) c)))))) + (let ((new-c (or (find-class c nil) 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) @@ -496,6 +500,35 @@ 'DEFCLASS name (find-if-not metaclass-test direct-superclasses) metaclass)))) +;;; The direct-subclasses slot can be either +;;; - NIL or a weak-list (for saving memory when there are few subclasses), or +;;; - a weak-hash-table (for speed when there are many subclasses). +#| +;; Adds a class to the list of direct subclasses. +(defun add-direct-subclass (class subclass) ...) +;; Removes a class from the list of direct subclasses. +(defun remove-direct-subclass (class subclass) ...) +;; 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 + add-direct-subclass + remove-direct-subclass + list-direct-subclasses) + +(defun update-subclasses-sets (class old-augmented-direct-superclasses new-augmented-direct-superclasses) + ;; Drop classes that are not yet defined; they have no subclasses list. + (setq old-augmented-direct-superclasses (remove-if #'symbolp old-augmented-direct-superclasses)) + (setq new-augmented-direct-superclasses (remove-if #'symbolp new-augmented-direct-superclasses)) + (unless (equal old-augmented-direct-superclasses new-augmented-direct-superclasses) + (let ((removed-direct-superclasses + (set-difference old-augmented-direct-superclasses new-augmented-direct-superclasses)) + (added-direct-superclasses + (set-difference new-augmented-direct-superclasses old-augmented-direct-superclasses))) + (dolist (super removed-direct-superclasses) + (removed-direct-subclass super class)) + (dolist (super added-direct-superclasses) + (add-direct-subclass super class))))) ;; --------------- Creation of an instance of <standard-class> --------------- @@ -519,18 +552,28 @@ ((direct-slots direct-slots-as-metaobjects) '() direct-slots-as-metaobjects-p) (direct-default-initargs '()) (documentation nil) (fixed-slot-locations nil) - &allow-other-keys) - (unless (slot-boundp class 'current-version) - (setf (class-current-version class) - (make-class-version :newest-class class - :class class - :serial 0)) - (setf (class-direct-accessors class) '()) - (setf (class-instantiated class) nil) - (setf (class-finalized-direct-subclasses-table class) '())) + &allow-other-keys + &aux (old-augmented-direct-superclasses '())) + (if (slot-boundp class 'current-version) + (setq old-augmented-direct-superclasses + (add-default-superclass (class-direct-superclasses class) + <standard-object>)) + (progn + (setf (class-current-version class) + (make-class-version :newest-class class + :class class + :serial 0)) + (setf (class-direct-subclasses-table class) '()) + (setf (class-direct-accessors class) '()) + (setf (class-instantiated class) nil) + (setf (class-finalized-direct-subclasses-table class) '()))) (when *classes-finished* (apply #'%initialize-instance class args)) ; == (call-next-method) (setf (class-direct-superclasses class) (copy-list direct-superclasses)) + (let ((new-augmented-direct-superclasses + (add-default-superclass direct-superclasses <standard-object>))) + (update-subclasses-sets class old-augmented-direct-superclasses + new-augmented-direct-superclasses)) (setf (class-direct-slots class) (if direct-slots-as-metaobjects-p direct-slots-as-metaobjects @@ -569,14 +612,17 @@ (let ((finalizing-now (cons class finalizing-now))) (do ((superclassesr (class-direct-superclasses class) (cdr superclassesr))) ((endp superclassesr)) - (let ((finalized-superclass - (finalize-class (car superclassesr) force-p finalizing-now))) + (let* ((superclass (car superclassesr)) + (finalized-superclass + (finalize-class superclass force-p finalizing-now))) (unless finalized-superclass ;; Finalization of a superclass was impossible. force-p must ;; be nil here, otherwise an error was signaled already. So we ;; have to return nil as well. (return-from finalize-class nil)) - (setf (car superclassesr) finalized-superclass)))) + (setf (car superclassesr) finalized-superclass) + (when (symbolp superclass) ; changed from symbol to class + (add-direct-subclass finalized-superclass class))))) ;; Now compute the class-precedence-list. (finalize-instance-standard-class class) class)))) @@ -1208,11 +1254,13 @@ (defun initialize-instance-built-in-class (class &key direct-superclasses documentation &allow-other-keys) (setf (class-direct-superclasses class) (copy-list direct-superclasses)) + (update-subclasses-sets class '() direct-superclasses) (setf (class-documentation class) documentation) (setf (class-precedence-list class) (std-compute-cpl class direct-superclasses)) (setf (class-all-superclasses class) (std-compute-superclasses (class-precedence-list class))) + (setf (class-direct-subclasses-table class) '()) (setf (class-direct-slots class) '()) (setf (class-slots class) '()) class) @@ -1262,16 +1310,19 @@ (check-metaclass-mix name direct-superclasses #'structure-class-p 'STRUCTURE-CLASS) (setf (class-direct-superclasses class) (copy-list direct-superclasses)) - (setf (class-precedence-list class) - (std-compute-cpl class + (let ((augmented-direct-superclasses (add-default-superclass (add-default-superclass direct-superclasses <structure-object>) <t>))) + (update-subclasses-sets class '() augmented-direct-superclasses) + (setf (class-precedence-list class) + (std-compute-cpl class augmented-direct-superclasses))) (setf (class-all-superclasses class) (std-compute-superclasses (class-precedence-list class))) (setf (class-subclass-of-stablehash-p class) (std-compute-subclass-of-stablehash-p class)) + (setf (class-direct-subclasses-table class) '()) (setf (class-direct-slots class) direct-slots-as-metaobjects) ;; When called via ENSURE-CLASS, we have to do inheritance of slots. (unless names Index: lispbibl.d =================================================================== RCS file: /cvsroot/clisp/clisp/src/lispbibl.d,v retrieving revision 1.523 retrieving revision 1.524 diff -u -d -r1.523 -r1.524 --- lispbibl.d 18 Jun 2004 10:55:29 -0000 1.523 +++ lispbibl.d 21 Jun 2004 10:31:19 -0000 1.524 @@ -5520,6 +5520,7 @@ gcv_object_t direct_superclasses _attribute_aligned_object_; # direct superclasses gcv_object_t all_superclasses _attribute_aligned_object_; # all superclasses, including itself gcv_object_t precedence_list _attribute_aligned_object_; # ordered list of all superclasses + gcv_object_t direct_subclasses _attribute_aligned_object_; # weak-list or weak-hash-table of all direct subclasses gcv_object_t direct_slots _attribute_aligned_object_; gcv_object_t slots _attribute_aligned_object_; gcv_object_t slot_location_table _attribute_aligned_object_; # hashtable slotname -> where the slot is located Index: ChangeLog =================================================================== RCS file: /cvsroot/clisp/clisp/src/ChangeLog,v retrieving revision 1.3202 retrieving revision 1.3203 diff -u -d -r1.3202 -r1.3203 --- ChangeLog 20 Jun 2004 01:55:25 -0000 1.3202 +++ ChangeLog 21 Jun 2004 10:31:24 -0000 1.3203 @@ -1,3 +1,21 @@ +2004-05-16 Bruno Haible <br...@cl...> + + * lispbibl.d (Class): Add direct_subclasses field. + * clos-class2.lisp (class): Add slot direct-subclasses-table. + (ensure-class): Call add-direct-subclass when a member of the + direct-subclasses list changes from symbol to class. + (add-direct-subclass, remove-direct-subclass, list-direct-subclasses): + New functions. + (update-subclasses-sets): New function. + (initialize-instance-standard-class): Initialize + direct-subclasses-table. Call update-subclasses-sets. + (finalize-class): Call add-direct-subclass when a member of the + direct-subclasses list changes from symbol to class. + (initialize-instance-built-in-class): Initialize + direct-subclasses-table. Call update-subclasses-sets. + (initialize-instance-structure-class): Initialize + direct-subclasses-table. Call update-subclasses-sets. + 2004-06-19 Sam Steingold <sd...@gn...> * hashtabl.d (HASH-TABLE-WARN-IF-NEEDS-REHASH-AFTER-GC): new accessor --__--__-- Message: 2 From: Bruno Haible <ha...@us...> To: cli...@li... Subject: clisp/src clos-genfun2.lisp,1.9,1.10 clos-methcomb1.lisp,1.4,1.5 clos-methcomb2.lisp,1.11,1.12 ChangeLog,1.3203,1.3204 Date: Mon, 21 Jun 2004 10:37:52 +0000 Reply-To: cli...@li... Update of /cvsroot/clisp/clisp/src In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv14740/src Modified Files: clos-genfun2.lisp clos-methcomb1.lisp clos-methcomb2.lisp ChangeLog Log Message: Move the method selection code outside of the method-combination expander. Index: clos-genfun2.lisp =================================================================== RCS file: /cvsroot/clisp/clisp/src/clos-genfun2.lisp,v retrieving revision 1.9 retrieving revision 1.10 diff -u -d -r1.9 -r1.10 --- clos-genfun2.lisp 18 Jun 2004 11:04:58 -0000 1.9 +++ clos-genfun2.lisp 21 Jun 2004 10:37:49 -0000 1.10 @@ -574,9 +574,28 @@ ;;; for the same EQL and class restrictions as the given arguments, ;;; therefore compute dispatch is already taken care of. (defun compute-applicable-methods-effective-method (gf &rest args) - (let ((combination (gf-method-combination gf))) - (funcall (method-combination-expander combination) gf combination - (method-combination-options combination) args))) + ;; FIXME: Unify this with compute-applicable-methods. + ;; 1. Select the applicable methods: + (let* ((signature (gf-signature gf)) + (req-num (sig-req-num signature)) + (req-args (subseq args 0 req-num)) + (methods + (remove-if-not #'(lambda (method) + (method-applicable-p method req-args)) + (the list (gf-methods gf))))) + (when (null methods) + (return-from compute-applicable-methods-effective-method + (no-method-caller 'no-applicable-method gf))) + ;; 2. Sort the applicable methods by precedence order: + (setq methods (sort-applicable-methods methods req-args (gf-argorder gf))) + ;; 3. Combine the methods to an effective method: + (let ((*method-combination-arguments* args)) + (compute-effective-method-as-function gf (gf-method-combination gf) methods)))) + +(defun compute-effective-method-as-function (gf combination methods) + ;; Apply method combination: + (funcall (method-combination-expander combination) gf combination methods + (method-combination-options combination))) (defun gf-keyword-arguments (restp signature methods) ;; CLtL2 28.1.6.4., 28.1.6.5., ANSI CL 7.6.4., 7.6.5. Keyword Arguments in Index: clos-methcomb1.lisp =================================================================== RCS file: /cvsroot/clisp/clisp/src/clos-methcomb1.lisp,v retrieving revision 1.4 retrieving revision 1.5 diff -u -d -r1.4 -r1.5 --- clos-methcomb1.lisp 18 Jun 2004 11:01:24 -0000 1.4 +++ clos-methcomb1.lisp 21 Jun 2004 10:37:49 -0000 1.5 @@ -41,7 +41,7 @@ ; that checks the syntax of arguments to the ; method combination (expander nil) ; A function of 4 arguments - ; (function method-combination options arguments) + ; (function method-combination methods options) ; which computes a combined method function. (check-method-qualifiers nil) ; A function of 3 arguments ; (function method-combination method) Index: clos-methcomb2.lisp =================================================================== RCS file: /cvsroot/clisp/clisp/src/clos-methcomb2.lisp,v retrieving revision 1.11 retrieving revision 1.12 diff -u -d -r1.11 -r1.12 --- clos-methcomb2.lisp 18 Jun 2004 11:03:59 -0000 1.11 +++ clos-methcomb2.lisp 21 Jun 2004 10:37:49 -0000 1.12 @@ -263,34 +263,19 @@ (nreverse after-methods) (nreverse around-methods)))) -(defun standard-method-combination-expander (gf combination options args) +(defun standard-method-combination-expander (gf combination methods options) (declare (ignore combination)) (declare (ignore options)) ; already checked in check-options (let* ((signature (gf-signature gf)) (req-num (sig-req-num signature)) (req-vars (gensym-list req-num)) - (req-args (subseq args 0 req-num)) (restp (gf-sig-restp signature)) (rest-var (if restp (gensym))) (apply-fun (if restp 'APPLY 'FUNCALL)) (apply-args `(,@req-vars ,@(if restp `(,rest-var) '()))) - (lambdalist `(,@req-vars ,@(if restp `(&REST ,rest-var) '()))) - (arg-order (gf-argorder gf)) - (methods (gf-methods gf))) - ;; Determine the effective method: - ;; 1. Select the applicable methods: - (setq methods - (remove-if-not #'(lambda (method) - (method-applicable-p method req-args)) - (the list methods))) - (when (null methods) - (return-from standard-method-combination-expander - (no-method-caller 'no-applicable-method gf))) + (lambdalist `(,@req-vars ,@(if restp `(&REST ,rest-var) '())))) (multiple-value-bind (opt-vars key-vars lambdalist-keypart) (gf-keyword-arguments restp signature methods) - ;; 2. Sort the applicable methods by precedence order: - (setq methods (sort-applicable-methods methods req-args arg-order)) - ;; 3. Apply method combination: ;; Split up into individual method types. (multiple-value-bind (primary-methods before-methods after-methods around-methods) @@ -459,15 +444,8 @@ form))))))) (defun short-form-method-combination-expander - (*method-combination-generic-function* *method-combination* - options *method-combination-arguments*) - (let* ((methods - (or (compute-applicable-methods - *method-combination-generic-function* - *method-combination-arguments*) - (no-method-caller 'no-applicable-method - *method-combination-generic-function*))) - (em-form (compute-short-form-effective-method-form + (*method-combination-generic-function* *method-combination* methods options) + (let ((em-form (compute-short-form-effective-method-form *method-combination* options methods))) (typecase em-form (function em-form) @@ -505,16 +483,10 @@ ;;; ---------------------- Long-Form Method Combination ---------------------- (defun long-form-method-combination-expander - (*method-combination-generic-function* *method-combination* - options *method-combination-arguments* long-expander) - (let* ((methods - (or (compute-applicable-methods - *method-combination-generic-function* - *method-combination-arguments*) - (no-method-caller 'no-applicable-method - *method-combination-generic-function*))) - (em-form (apply long-expander *method-combination-generic-function* - methods options))) + (*method-combination-generic-function* *method-combination* methods options + long-expander) + (let ((em-form (apply long-expander *method-combination-generic-function* + methods options))) (typecase em-form (function em-form) (list (compute-effective-method-function @@ -833,7 +805,6 @@ (gf-variable (gensym "GF-")) (combination-variable (gensym "COMBINATION-")) (options-variable (gensym "OPTIONS-")) - (args-variable (gensym "ARGUMENTS-")) (methods-variable (gensym "METHODS-")) (method-variable (gensym "METHOD-"))) (when (and (consp body) (consp (car body)) @@ -901,10 +872,10 @@ (,check-options-lambda))))) :EXPANDER #'(LAMBDA (,gf-variable ,combination-variable - ,options-variable ,args-variable) + ,methods-variable ,options-variable) (LONG-FORM-METHOD-COMBINATION-EXPANDER ,gf-variable ,combination-variable - ,options-variable ,args-variable + ,methods-variable ,options-variable #'(LAMBDA (,gf-variable ,methods-variable ,@lambda-list) (LET (,@(when user-gf-variable `(,user-gf-variable ,gf-variable))) (,partition-lambda ,methods-variable))))) Index: ChangeLog =================================================================== RCS file: /cvsroot/clisp/clisp/src/ChangeLog,v retrieving revision 1.3203 retrieving revision 1.3204 diff -u -d -r1.3203 -r1.3204 --- ChangeLog 21 Jun 2004 10:31:24 -0000 1.3203 +++ ChangeLog 21 Jun 2004 10:37:49 -0000 1.3204 @@ -1,3 +1,14 @@ +2004-06-06 Bruno Haible <br...@cl...> + + * clos-genfun2.lisp (compute-applicable-methods-effective-method): Do + the method selection here. + (compute-effective-method-as-function): New function. + * clos-methcomb2.lisp (standard-method-combination-expander, + short-form-method-combination-expander, + long-form-method-combination-expander): Add methods argument, remove + args argument. Don't do the method selection here. + (define-method-combination): Update. + 2004-05-16 Bruno Haible <br...@cl...> * lispbibl.d (Class): Add direct_subclasses field. --__--__-- Message: 3 From: Sam Steingold <sd...@us...> To: cli...@li... Subject: clisp/doc unix-ent.xml,1.31,1.32 Date: Mon, 21 Jun 2004 14:54:38 +0000 Reply-To: cli...@li... Update of /cvsroot/clisp/clisp/doc In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv28172/doc Modified Files: unix-ent.xml Log Message: (abort, make): added Index: unix-ent.xml =================================================================== RCS file: /cvsroot/clisp/clisp/doc/unix-ent.xml,v retrieving revision 1.31 retrieving revision 1.32 diff -u -d -r1.31 -r1.32 --- unix-ent.xml 5 May 2004 22:57:44 -0000 1.31 +++ unix-ent.xml 21 Jun 2004 14:54:36 -0000 1.32 @@ -18,6 +18,7 @@ <!-- functions (system calls) --> <!ENTITY unix-f "&unix-top;/functions"> +<!ENTITY abort-c "<ulink url='&unix-f;/abort.html'><function>abort</function></ulink>"> <!ENTITY accept "<ulink url='&unix-f;/accept.html'><function>accept</function></ulink>"> <!ENTITY bind "<ulink url='&unix-f;/bind.html'><function>bind</function></ulink>"> <!ENTITY calloc "<ulink url='&unix-f;/calloc.html'><function>calloc</function></ulink>"> @@ -103,6 +104,7 @@ <!ENTITY chmod "<ulink url='&unix-u;/chmod.html'><command>chmod</command></ulink>"> <!ENTITY iconv-u "<ulink url='&unix-u;/iconv.html'><command>iconv</command></ulink>"> <!ENTITY ls "<ulink url='&unix-u;/ls.html'><command>ls</command></ulink>"> +<!ENTITY make "<ulink url='&unix-u;/make.html'><command>make</command></ulink>"> <!ENTITY sh "<ulink url='&unix-u;/sh.html'><command>/bin/sh</command></ulink>"> <!ENTITY uname-u "<ulink url='&unix-u;/uname.html'><command>uname</command></ulink>"> --__--__-- Message: 4 From: Sam Steingold <sd...@us...> To: cli...@li... Subject: clisp/doc impent.xml,1.136,1.137 Date: Mon, 21 Jun 2004 14:55:49 +0000 Reply-To: cli...@li... Update of /cvsroot/clisp/clisp/doc In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv29036/doc Modified Files: impent.xml Log Message: (object): added Index: impent.xml =================================================================== RCS file: /cvsroot/clisp/clisp/doc/impent.xml,v retrieving revision 1.136 retrieving revision 1.137 diff -u -d -r1.136 -r1.137 --- impent.xml 17 Jun 2004 19:43:44 -0000 1.136 +++ impent.xml 21 Jun 2004 14:55:46 -0000 1.137 @@ -449,6 +449,7 @@ <!ENTITY mod-dynload "<link linkend='mod-dynload'><function>SYS::DYNLOAD-MODULES</function></link>"> <!ENTITY modinfo "<link linkend='modinfo'><function>EXT:MODULE-INFO</function></link>"> <!ENTITY module "<link linkend='modules'>module</link>"> +<!ENTITY object-t "<link linkend='typecodes'><type>object</type></link>"> <!ENTITY offset "<link linkend='offset'><function>FFI:OFFSET</function></link>"> <!ENTITY param-mode "<link linkend='param-mode'><replaceable>PARAM-MODE</replaceable></link>"> <!ENTITY parse-c-type "<link linkend='c-type-parse'><function>FFI:PARSE-C-TYPE</function></link>"> --__--__-- Message: 5 From: Sam Steingold <sd...@us...> To: cli...@li... Subject: clisp/doc impext.xml,1.238,1.239 Date: Mon, 21 Jun 2004 14:56:45 +0000 Reply-To: cli...@li... Update of /cvsroot/clisp/clisp/doc In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv29454/doc Modified Files: impext.xml Log Message: use &make; Index: impext.xml =================================================================== RCS file: /cvsroot/clisp/clisp/doc/impext.xml,v retrieving revision 1.238 retrieving revision 1.239 diff -u -d -r1.238 -r1.239 --- impext.xml 17 Jun 2004 19:43:42 -0000 1.238 +++ impext.xml 21 Jun 2004 14:56:42 -0000 1.239 @@ -2069,7 +2069,7 @@ <para>&clisp; comes with some extension macros, mostly defined in the file <filename>macros3.lisp</filename> and loaded from the file - <filename>init.lisp</filename> during <command>make</command>:</para> + <filename>init.lisp</filename> during &make;:</para> <formalpara id="ethe"><title>Macro ðe;</title> <para><literal role="sexp">(ðe; &val-type-r; &form-r;)</literal> @@ -4798,7 +4798,7 @@ &clisp-cmd; is a shell script because a &c-lang; compiler cannot be assumed to be installed on this platform. If you do have a &c-lang; compiler installed, build &clisp; from the source yourself; - <command>make install</command> will install &clisp-cmd; as a real + <command>&make; install</command> will install &clisp-cmd; as a real executable.</simpara></listitem> <listitem><para>On some platforms, the first line which specifies the interpreter is limited in length: --__--__-- Message: 6 From: Sam Steingold <sd...@us...> To: cli...@li... Subject: clisp/doc impbyte.xml,1.52,1.53 Date: Mon, 21 Jun 2004 14:58:47 +0000 Reply-To: cli...@li... Update of /cvsroot/clisp/clisp/doc In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv30773/doc Modified Files: impbyte.xml Log Message: more about debugging gc-safety Index: impbyte.xml =================================================================== RCS file: /cvsroot/clisp/clisp/doc/impbyte.xml,v retrieving revision 1.52 retrieving revision 1.53 diff -u -d -r1.52 -r1.53 --- impbyte.xml 17 Jun 2004 19:43:44 -0000 1.52 +++ impbyte.xml 21 Jun 2004 14:58:45 -0000 1.53 @@ -23,7 +23,7 @@ <listitem><simpara>&clisp; data (the "heap"), i.e. storage which contains Lisp objects and is managed by the garbage collector.</simpara></listitem> <listitem><simpara>&clisp; stack (called &STACK;), contains &clisp; - objects</simpara></listitem> + &object-t;s</simpara></listitem> <listitem><simpara>&c-lang; data (including program text, data, &malloc;ed memory)</simpara></listitem> </itemizedlist> @@ -69,7 +69,7 @@ <section id="typecodes"><title>Object Pointer Representations</title> <para>&clisp; implements two ways of representing object pointers. -(An object pointer, &c-lang; type <type>object</type>, contains a +(An object pointer, &c-lang; type &object-t;, contains a pointer to the memory location of the object, or - for &immediate-o; - all bits of the object itself.) Both of them have some things in common: @@ -314,9 +314,9 @@ But the &gc; looks only on the &STACK; and not in the &c-lang; variables. (Anything else would not be portable.) Therefore at every "unsafe" point, i.e. every call to such a subroutine, -all the &c-lang; variables of type <type>object</type> +all the &c-lang; variables of type &object-t; <emphasis>MUST BE ASSUMED TO BECOME GARBAGE</emphasis>. -(Except for <type>object</type>s that are known to be unmovable, +(Except for &object-t;s that are known to be unmovable, e.g. immediate data or <type>Subr</type>s.) Pointers inside &clisp; data (e.g. to the characters of a &string-t; or to the elements of a &simple-vector-t;) become @@ -328,12 +328,22 @@ <para>Run-time GC-safety checking is available when you build &clisp; with a C++ compiler, e.g.: -<screen> +<screen id="clisp-config-gxx"> bash$ CC=g++ ./configure --with-debug build-g-gxx </screen> -When built like this, &clisp; will abort when you reference GC-unsafe -data after an allocation (which could have triggered a &gc;ion), -and &gdb; will pinpoint the trouble spot.</para> +When built like this, &clisp; will &abort-c; when you reference +GC-unsafe data after an allocation (which could have triggered a +&gc;ion), and &gdb; will pinpoint the trouble spot.</para> + +<para>Specifically, when &clisp; is configured + as <link linkend="clisp-config-gxx">above</link>, there is a +global integer variable <varname>alloccount</varname> and the &object-t; +structure contains an integer <structfield>allocstamp</structfield> +slot. If these two integers are not the same, the &object-t; is invalid. +By playing with &gdb;, you should be able to figure out the precise spot +where an allocation increments <varname>alloccount</varname> +<emphasis>after</emphasis> the object has been retrieved from a +GC-visible location.</para> </section> @@ -361,8 +371,8 @@ <para>&clisp; can be easily extended the same way any other &cl; implementation can: create a lisp file with your variables, functions, - macros, etc.; &load; it into a running &clisp;, and save the - &mem-image;.</para> + macros, etc.; (optionally) compile it with &compile-file;; &load; it + into a running &clisp;, and save the &mem-image;.</para> <para>This method does not work when you need to use some functionality not available in &clisp;, e.g., you want to call a &c-lang; function. @@ -405,14 +415,13 @@ >GC-safety</link>!</para></warning> <para>These instructions are intentionally terse - you are encouraged to - use &module;s and/or &ffi-pac; instead of adding built-ins - directly.</para> -</section> + use &module;s and/or &ffi-pac; instead of adding built-ins directly. +</para></section> <section id="add-var"><title>Adding a built-in variable.</title> -<para>If you must be able to access the variable in the &c-lang; code, - follow these steps: +<para>If you must be able to access the Lisp variable in the &c-lang; + code, follow these steps: <itemizedlist><listitem><simpara>declare the variable name in <filename>#P"constsym.d"</filename> in the appropriate package (probably &custom-pac;, if there is no specific package); @@ -427,10 +436,11 @@ <section id="recompile"><title>Recompilation.</title> -<para><emphasis>Any</emphasis> change that forces <command>make</command> - to remake &lisp-run;, will force recompilation of all &lisp-file; files - and re-dumping of &lispinit;, which may be time-consuming. This is not - always necessary, depending on what kind of change you introduced.</para> +<para><emphasis>Any</emphasis> change that forces &make; to remake + &lisp-run;, will force recompilation of all &lisp-file; files and + re-dumping of &lispinit;, which may be time-consuming. This is not + always necessary, depending on what kind of change you introduced. +</para> <para>On the other hand, if you change any of the following files: <simplelist> --__--__-- Message: 7 From: Sam Steingold <sd...@us...> To: cli...@li... Subject: clisp/modules/berkeley-db bdb.c,1.10,1.11 Date: Mon, 21 Jun 2004 19:01:23 +0000 Reply-To: cli...@li... Update of /cvsroot/clisp/clisp/modules/berkeley-db In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv3934/modules/berkeley-db Modified Files: bdb.c Log Message: (BDB:ENV-GET-OPTIONS): new Lisp DEFUN Index: bdb.c =================================================================== RCS file: /cvsroot/clisp/clisp/modules/berkeley-db/bdb.c,v retrieving revision 1.10 retrieving revision 1.11 diff -u -d -r1.10 -r1.11 --- bdb.c 19 Jun 2004 20:35:22 -0000 1.10 +++ bdb.c 21 Jun 2004 19:01:20 -0000 1.11 @@ -251,13 +251,13 @@ *(nullp(arg) ? flag_off : flag_on) |= values; } -DEFUN(BDB:ENV-SET-OPTIONS, dbe &key :DATA-DIR :TMP-DIR \ - :AUTO-COMMIT :CDB-ALLDB :DIRECT-DB :DIRECT-LOG :NOLOCKING \ - :NOMMAP :NOPANIC :OVERWRITE :PANIC-ENVIRONMENT :REGION-INIT \ - :TXN-NOSYNC :TXN-WRITE-NOSYNC :YIELDCPU \ - :VERB-CHKPOINT :VERB-DEADLOCK :VERB-RECOVERY :VERB-REPLICATION \ - :VERB-WAITSFOR :VERBOSE) -{ /* set many options - but how do we query them?! */ +DEFUN(BDB:ENV-SET-OPTIONS, dbe &key :DATA_DIR :TMP_DIR \ + :AUTO_COMMIT :CDB_ALLDB :DIRECT_DB :DIRECT_LOG :NOLOCKING \ + :NOMMAP :NOPANIC :OVERWRITE :PANIC_ENVIRONMENT :REGION_INIT \ + :TXN_NOSYNC :TXN_WRITE_NOSYNC :YIELDCPU \ + :VERB_CHKPOINT :VERB_DEADLOCK :VERB_RECOVERY :VERB_REPLICATION \ + :VERB_WAITSFOR :VERBOSE) +{ /* set many options */ u_int32_t flags_on = 0, flags_off = 0; DB_ENV *dbe = object_handle(STACK_(21),`BDB::ENV`,false); /* verbose */ @@ -301,6 +301,154 @@ VALUES0; skipSTACK(1); /* skip dbe */ } +/* get the list of verbosity options + can trigger GC */ +static object env_verbose (DB_ENV *dbe) { + int count = 0, onoffp; + SYSCALL(dbe->get_verbose,(dbe,DB_VERB_WAITSFOR,&onoffp)); + if (onoffp) { pushSTACK(`:VERB_WAITSFOR`); count++; } + SYSCALL(dbe->get_verbose,(dbe,DB_VERB_REPLICATION,&onoffp)); + if (onoffp) { pushSTACK(`:VERB_REPLICATION`); count++;} + SYSCALL(dbe->get_verbose,(dbe,DB_VERB_RECOVERY,&onoffp)); + if (onoffp) { pushSTACK(`:VERB_RECOVERY`); count++; } + SYSCALL(dbe->get_verbose,(dbe,DB_VERB_DEADLOCK,&onoffp)); + if (onoffp) { pushSTACK(`:VERB_DEADLOCK`); count++; } + SYSCALL(dbe->get_verbose,(dbe,DB_VERB_CHKPOINT,&onoffp)); + if (onoffp) { pushSTACK(`:VERB_CHKPOINT`); count++; } + return listof(count); +} +/* get the tmp directory + can trigger GC */ +static object env_tmp_dir (DB_ENV *dbe) { + const char *dir; + SYSCALL(dbe->get_tmp_dir,(dbe,&dir)); + return dir ? asciz_to_string(dir,GLO(pathname_encoding)) : NIL; +} +/* get the data directory list + can trigger GC */ +static object env_data_dirs (DB_ENV *dbe) { + const char **dirs; int ii; + SYSCALL(dbe->get_data_dirs,(dbe,&dirs)); + if (dirs) { + for (ii=0; dirs[ii]; ii++) + pushSTACK(asciz_to_string(dirs[ii],GLO(pathname_encoding))); + return listof(ii); + } else return NIL; +} + +DEFUNR(BDB:ENV-GET-OPTIONS, dbe &optional what) { + object what = popSTACK(); + DB_ENV *dbe = object_handle(popSTACK(),`BDB::ENV`,false); + restart_ENV_GET_OPTIONS: + if (missingp(what)) { /* get everything */ + /* verbose */ + value1 = env_verbose(dbe); pushSTACK(value1); /* save */ + { /* flags */ + u_int32_t count = 0, flags; + SYSCALL(dbe->get_flags,(dbe,&flags)); + if (flags & DB_YIELDCPU) { pushSTACK(`:YIELDCPU`); count++; } + if (flags & DB_TXN_WRITE_NOSYNC) {pushSTACK(`:TXN_WRITE_NOSYNC`);count++;} + if (flags & DB_TXN_NOSYNC) { pushSTACK(`:TXN_NOSYNC`); count++; } + if (flags & DB_REGION_INIT) { pushSTACK(`:REGION_INIT`); count++; } + if (flags &DB_PANIC_ENVIRONMENT){pushSTACK(`:PANIC_ENVIRONMENT`);count++;} + if (flags & DB_OVERWRITE) { pushSTACK(`:OVERWRITE`); count++; } + if (flags & DB_NOPANIC) { pushSTACK(`:NOPANIC`); count++; } + if (flags & DB_NOMMAP) { pushSTACK(`:NOMMAP`); count++; } + if (flags & DB_NOLOCKING) { pushSTACK(`:NOLOCKING`); count++; } + if (flags & DB_DIRECT_LOG) { pushSTACK(`:DIRECT_LOG`); count++; } + if (flags & DB_CDB_ALLDB) { pushSTACK(`:CDB_ALLDB`); count++; } + if (flags & DB_AUTO_COMMIT) { pushSTACK(`:AUTO_COMMIT`); count++; } + value1 = listof(count); pushSTACK(value1); /* save */ + pushSTACK(fixnum(flags)); /* raw flags too! */ + } + /* tmp-dir */ + pushSTACK(env_tmp_dir(dbe)); + /* data-dir */ + value1 = env_data_dirs(dbe); pushSTACK(value1); + funcall(L(values),5); + } else if (eq(what,S(Kverbose))) { + VALUES1(env_verbose(dbe)); + } else if (eq(what,`:VERB_WAITSFOR`)) { + int onoffp; + SYSCALL(dbe->get_verbose,(dbe,DB_VERB_WAITSFOR,&onoffp)); + VALUES_IF(onoffp); + } else if (eq(what,`:VERB_REPLICATION`)) { + int onoffp; + SYSCALL(dbe->get_verbose,(dbe,DB_VERB_REPLICATION,&onoffp)); + VALUES_IF(onoffp); + } else if (eq(what,`:VERB_RECOVERY`)) { + int onoffp; + SYSCALL(dbe->get_verbose,(dbe,DB_VERB_RECOVERY,&onoffp)); + VALUES_IF(onoffp); + } else if (eq(what,`:VERB_DEADLOCK`)) { + int onoffp; + SYSCALL(dbe->get_verbose,(dbe,DB_VERB_DEADLOCK,&onoffp)); + VALUES_IF(onoffp); + } else if (eq(what,`:VERB_CHKPOINT`)) { + int onoffp; + SYSCALL(dbe->get_verbose,(dbe,DB_VERB_CHKPOINT,&onoffp)); + VALUES_IF(onoffp); + } else if (eq(what,`:YIELDCPU`)) { + u_int32_t flags; + SYSCALL(dbe->get_flags,(dbe,&flags)); + VALUES_IF(flags & DB_YIELDCPU); + } else if (eq(what,`:TXN_WRITE_NOSYNC`)) { + u_int32_t flags; + SYSCALL(dbe->get_flags,(dbe,&flags)); + VALUES_IF(flags & DB_TXN_WRITE_NOSYNC); + } else if (eq(what,`:TXN_NOSYNC`)) { + u_int32_t flags; + SYSCALL(dbe->get_flags,(dbe,&flags)); + VALUES_IF(flags & DB_TXN_NOSYNC); + } else if (eq(what,`:REGION_INIT`)) { + u_int32_t flags; + SYSCALL(dbe->get_flags,(dbe,&flags)); + VALUES_IF(flags & DB_REGION_INIT); + } else if (eq(what,`:PANIC_ENVIRONMENT`)) { + u_int32_t flags; + SYSCALL(dbe->get_flags,(dbe,&flags)); + VALUES_IF(flags & DB_PANIC_ENVIRONMENT); + } else if (eq(what,`:OVERWRITE`)) { + u_int32_t flags; + SYSCALL(dbe->get_flags,(dbe,&flags)); + VALUES_IF(flags & DB_OVERWRITE); + } else if (eq(what,`:NOPANIC`)) { + u_int32_t flags; + SYSCALL(dbe->get_flags,(dbe,&flags)); + VALUES_IF(flags & DB_NOPANIC); + } else if (eq(what,`:NOMMAP`)) { + u_int32_t flags; + SYSCALL(dbe->get_flags,(dbe,&flags)); + VALUES_IF(flags & DB_NOMMAP); + } else if (eq(what,`:NOLOCKING`)) { + u_int32_t flags; + SYSCALL(dbe->get_flags,(dbe,&flags)); + VALUES_IF(flags & DB_NOLOCKING); + } else if (eq(what,`:DIRECT_LOG`)) { + u_int32_t flags; + SYSCALL(dbe->get_flags,(dbe,&flags)); + VALUES_IF(flags & DB_DIRECT_LOG); + } else if (eq(what,`:CDB_ALLDB`)) { + u_int32_t flags; + SYSCALL(dbe->get_flags,(dbe,&flags)); + VALUES_IF(flags & DB_CDB_ALLDB); + } else if (eq(what,`:AUTO_COMMIT`)) { + u_int32_t flags; + SYSCALL(dbe->get_flags,(dbe,&flags)); + VALUES_IF(flags & DB_AUTO_COMMIT); + } else if (eq(what,`:DATA_DIR`)) { + VALUES1(env_data_dirs(dbe)); + } else if (eq(what,`:TMP_DIR`)) { + VALUES1(env_tmp_dir(dbe)); + } else { + pushSTACK(NIL); /* no PLACE */ + pushSTACK(what); pushSTACK(TheSubr(subr_self)->name); + check_value(error,GETTEXT("~S: invalid argument ~S")); + what = value1; + goto restart_ENV_GET_OPTIONS; + } +} + /* ===== Database Operations ===== */ /* not exported: --__--__-- _______________________________________________ clisp-cvs mailing list cli...@li... https://lists.sourceforge.net/lists/listinfo/clisp-cvs End of clisp-cvs Digest |