Menu
▾
▴
clisp-cvs digest, Vol 1 #800 - 6 msgs
|
From: <cli...@li...> - 2004-11-11 13:11:08
|
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/doc mop-ent.xml,2.7,2.8 mop.xml,2.33,2.34 (Bruno Haible) 2. clisp/tests mop.tst,1.20,1.21 ChangeLog,1.251,1.252 (Bruno Haible) 3. clisp/src init.lisp,1.199,1.200 NEWS,1.204,1.205 clos-class6.lisp,1.26,1.27 clos-genfun2b.lisp,1.4,1.5 clos-package.lisp,1.39,1.40 clos-slotdef1.lisp,1.22,1.23 clos.lisp,1.100,1.101 ChangeLog,1.3809,1.3810 (Bruno Haible) 4. clisp/src lispbibl.d,1.566,1.567 stream.d,1.464,1.465 io.d,1.251,1.252 constobj.d,1.151,1.152 ChangeLog,1.3810,1.3811 (Bruno Haible) 5. clisp/doc impbody.xml,1.301,1.302 (Bruno Haible) 6. clisp/tests mop.tst,1.21,1.22 (Bruno Haible) --__--__-- Message: 1 From: Bruno Haible <ha...@us...> To: cli...@li... Subject: clisp/doc mop-ent.xml,2.7,2.8 mop.xml,2.33,2.34 Date: Thu, 11 Nov 2004 12:33:14 +0000 Reply-To: cli...@li... Update of /cvsroot/clisp/clisp/doc In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv25392/doc Modified Files: mop-ent.xml mop.xml Log Message: New generic function compute-direct-slot-definition-initargs. Index: mop.xml =================================================================== RCS file: /cvsroot/clisp/clisp/doc/mop.xml,v retrieving revision 2.33 retrieving revision 2.34 diff -u -d -r2.33 -r2.34 --- mop.xml 8 Nov 2004 15:16:00 -0000 2.33 +++ mop.xml 11 Nov 2004 12:33:11 -0000 2.34 @@ -1918,6 +1918,49 @@ compatible.</para></formalpara> </section><!-- validate-superclass --> +<section id="compute-dsd-initargs"><title>Generic Function &compute-dsd-initargs;</title> + +<note>&clisp-only;<para> +<variablelist><varlistentry><term>Syntax</term> + <listitem><simpara><code>(&compute-dsd-initargs; + &class-r; &rest-amp; <replaceable>slot-spec</replaceable>) + </code></simpara></listitem></varlistentry> +<varlistentry><term>Arguments</term> + <listitem><variablelist> + <varlistentry><term>&class-r;</term> + <listitem><simpara>a class metaobject.</simpara></listitem></varlistentry> + <varlistentry><term><replaceable>slot-spec</replaceable></term> + <listitem><simpara>a &canonical-slot-spec;.</simpara></listitem></varlistentry> +</variablelist></listitem></varlistentry> +<varlistentry><term>Values</term> + <listitem><simpara>The value returned by this generic function is a + list of initialization arguments for a direct slot definition + metaobject.</simpara></listitem></varlistentry> +<varlistentry><term>Purpose</term> + <listitem><simpara>This generic function determines the initialization + arguments for the direct slot definition for a slot in a class. + It is called during initialization of a class. The resulting + initialization arguments are passed to &dsd-class; and then to + &make-instance;.</simpara> + <simpara>This generic function uses the supplied &canonical-slot-spec;. + The value of &name-k; in the returned initargs is the same as the value + of &name-k; in the supplied <replaceable>slot-spec</replaceable> + argument.</simpara></listitem></varlistentry></variablelist> + +<variablelist><title>Methods</title> +<varlistentry><term><literal role="method">(&compute-dsd-initargs; + (&class-r; &standard-class;) &rest-amp; + <replaceable>slot-spec</replaceable>)</literal></term> + <term><literal role="method">(&compute-dsd-initargs; + (&class-r; &funcallable-standard-class;) &rest-amp; + <replaceable>slot-spec</replaceable>)</literal></term> + <listitem><simpara>This method returns <replaceable>slot-spec</replaceable> + unmodified.</simpara> + <simpara>This method can be overridden.</simpara></listitem> +</varlistentry></variablelist> +</para></note> +</section><!-- compute-dsd-initargs --> + <section id="dsd-class"><title>Generic Function &dsd-class;</title> <variablelist><varlistentry><term>Syntax</term> Index: mop-ent.xml =================================================================== RCS file: /cvsroot/clisp/clisp/doc/mop-ent.xml,v retrieving revision 2.7 retrieving revision 2.8 diff -u -d -r2.7 -r2.8 --- mop-ent.xml 8 Nov 2004 15:16:00 -0000 2.7 +++ mop-ent.xml 11 Nov 2004 12:33:11 -0000 2.8 @@ -20,6 +20,7 @@ <!ENTITY compute-applicable-methods-UC "<link linkend='compute-applicable-methods-UC'><function>CLOS:COMPUTE-APPLICABLE-METHODS-USING-CLASSES</function></link>"> <!ENTITY compute-cpl "<link linkend='compute-cpl'><function>CLOS:COMPUTE-CLASS-PRECEDENCE-LIST</function></link>"> <!ENTITY compute-default-initargs "<link linkend='compute-default-initargs'><function>CLOS:COMPUTE-DEFAULT-INITARGS</function></link>"> +<!ENTITY compute-dsd-initargs "<link linkend='compute-dsd-initargs'><function>CLOS:COMPUTE-DIRECT-SLOT-DEFINITION-INITARGS</function></link>"> <!ENTITY compute-discriminating-function "<link linkend='compute-discriminating-function'><function>CLOS:COMPUTE-DISCRIMINATING-FUNCTION</function></link>"> <!ENTITY compute-effective-method "<link linkend='compute-effective-method'><function>CLOS:COMPUTE-EFFECTIVE-METHOD</function></link>"> <!ENTITY compute-effective-method-as-function "<link linkend='compute-effective-method-as-function'><function>CLOS:COMPUTE-EFFECTIVE-METHOD-AS-FUNCTION</function></link>"> --__--__-- Message: 2 From: Bruno Haible <ha...@us...> To: cli...@li... Subject: clisp/tests mop.tst,1.20,1.21 ChangeLog,1.251,1.252 Date: Thu, 11 Nov 2004 12:33:13 +0000 Reply-To: cli...@li... Update of /cvsroot/clisp/clisp/tests In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv25392/tests Modified Files: mop.tst ChangeLog Log Message: New generic function compute-direct-slot-definition-initargs. Index: mop.tst =================================================================== RCS file: /cvsroot/clisp/clisp/tests/mop.tst,v retrieving revision 1.20 retrieving revision 1.21 diff -u -d -r1.20 -r1.21 --- mop.tst 9 Nov 2004 11:10:16 -0000 1.20 +++ mop.tst 11 Nov 2004 12:33:11 -0000 1.21 @@ -745,6 +745,38 @@ EXTRA +;;; Check the compute-direct-slot-definition-initargs protocol +;;; compute-direct-slot-definition-initargs + +;; Check that it's possible to generate accessors automatically. +(progn + (defclass auto-accessors-2-class (standard-class) + ()) + #-CLISP + (defmethod clos:validate-superclass ((c1 auto-accessors-2-class) (c2 standard-class)) + t) + (defmethod clos::compute-direct-slot-definition-initargs ((class auto-accessors-2-class) &rest slot-spec) + (if (and (null (getf slot-spec ':readers)) (null (getf slot-spec ':writers))) + (let* ((containing-class-name (class-name class)) + (accessor-name + (intern (concatenate 'string + (symbol-name containing-class-name) + "-" + (symbol-name (getf slot-spec ':name))) + (symbol-package containing-class-name)))) + (list* ;; Here are the additional reader/writer lists. + :readers (list accessor-name) + :writers (list (list 'setf accessor-name)) + (call-next-method))) + (call-next-method))) + (defclass testclass15 () + ((x :initarg :x) (y)) + (:metaclass auto-accessors-2-class)) + (let ((inst (make-instance 'testclass15 :x 12))) + (list (testclass15-x inst) (setf (testclass15-y inst) 13)))) +(12 13) + + ;;; Check the compute-discriminating-function protocol ;;; compute-discriminating-function Index: ChangeLog =================================================================== RCS file: /cvsroot/clisp/clisp/tests/ChangeLog,v retrieving revision 1.251 retrieving revision 1.252 diff -u -d -r1.251 -r1.252 --- ChangeLog 10 Nov 2004 11:46:07 -0000 1.251 +++ ChangeLog 11 Nov 2004 12:33:11 -0000 1.252 @@ -1,3 +1,7 @@ +2004-10-27 Bruno Haible <br...@cl...> + + * mop.tst: Add test for compute-direct-slot-definition-initargs. + 2004-10-31 Bruno Haible <br...@cl...> * socket.tst: New file. --__--__-- Message: 3 From: Bruno Haible <ha...@us...> To: cli...@li... Subject: clisp/src init.lisp,1.199,1.200 NEWS,1.204,1.205 clos-class6.lisp,1.26,1.27 clos-genfun2b.lisp,1.4,1.5 clos-package.lisp,1.39,1.40 clos-slotdef1.lisp,1.22,1.23 clos.lisp,1.100,1.101 ChangeLog,1.3809,1.3810 Date: Thu, 11 Nov 2004 12:33:12 +0000 Reply-To: cli...@li... Update of /cvsroot/clisp/clisp/src In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv25392/src Modified Files: init.lisp NEWS clos-class6.lisp clos-genfun2b.lisp clos-package.lisp clos-slotdef1.lisp clos.lisp ChangeLog Log Message: New generic function compute-direct-slot-definition-initargs. Index: clos-slotdef1.lisp =================================================================== RCS file: /cvsroot/clisp/clisp/src/clos-slotdef1.lisp,v retrieving revision 1.22 retrieving revision 1.23 diff -u -d -r1.22 -r1.23 --- clos-slotdef1.lisp 8 Nov 2004 12:17:52 -0000 1.22 +++ clos-slotdef1.lisp 11 Nov 2004 12:33:07 -0000 1.23 @@ -404,6 +404,11 @@ (write (slot-definition-name slotdef) :stream stream))) ;; Preliminary. +(predefun compute-direct-slot-definition-initargs (class &rest slot-spec) + (declare (ignore class)) + slot-spec) + +;; Preliminary. (predefun direct-slot-definition-class (class &rest initargs) (declare (ignore class initargs)) 'standard-direct-slot-definition) @@ -412,45 +417,54 @@ ;; direct-slot-definition instances. (defun convert-direct-slots (class direct-slots) (mapcar #'(lambda (slot-spec) - (let ((slot-definition-class - (apply #'direct-slot-definition-class class slot-spec))) - (cond ((semi-standard-class-p class) - (unless (or ; for bootstrapping - (eq slot-definition-class 'standard-direct-slot-definition) - (and (class-p slot-definition-class) - (subclassp slot-definition-class <standard-direct-slot-definition>))) - (error (TEXT "Wrong ~S result for class ~S: not a subclass of ~S: ~S") - 'direct-slot-definition-class (class-name class) - 'standard-direct-slot-definition slot-definition-class))) - ((structure-class-p class) - (unless (and (class-p slot-definition-class) - (subclassp slot-definition-class <structure-direct-slot-definition>)) - (error (TEXT "Wrong ~S result for class ~S: not a subclass of ~S: ~S") - 'direct-slot-definition-class (class-name class) - 'structure-direct-slot-definition slot-definition-class)))) - (let ((defclass-form (getf slot-spec 'DEFCLASS-FORM))) - (when defclass-form - ;; Provide good error messages. The error message from - ;; MAKE-INSTANCE later is unintelligible. - (let ((valid-keywords - (class-valid-initialization-keywords slot-definition-class))) - (unless (eq valid-keywords 'T) - ;; The valid-keywords contain at least - ;; :NAME :READERS :WRITERS :ALLOCATION :INITARGS - ;; :INITFORM :INITFUNCTION :TYPE :DOCUMENTATION DEFCLASS-FORM. - (do ((specr slot-spec (cddr specr))) - ((endp specr)) - (let ((optionkey (car specr))) - (unless (member optionkey valid-keywords) - (error-of-type 'ext:source-program-error - :form defclass-form - :detail optionkey - (TEXT "~S ~S, slot option for slot ~S: ~S is not a valid slot option") - 'defclass (second defclass-form) (getf slot-spec ':NAME) optionkey)))))))) - (apply (cond ((eq slot-definition-class 'standard-direct-slot-definition) - #'make-instance-<standard-direct-slot-definition>) - (t #'make-instance)) - slot-definition-class slot-spec))) + (let ((slot-initargs + (apply #'compute-direct-slot-definition-initargs class slot-spec))) + (unless (and (listp slot-initargs) (evenp (length slot-initargs))) + (error (TEXT "Wrong ~S result for class ~S: not a plist: ~S") + 'compute-direct-slot-definition-initargs (class-name class) slot-initargs)) + (unless (eq (getf slot-initargs ':NAME) (getf slot-spec ':NAME)) + (error (TEXT "Wrong ~S result for class ~S, slot ~S: value of ~S is wrong: ~S") + 'compute-direct-slot-definition-initargs (class-name class) + (getf slot-spec ':NAME) ':NAME slot-initargs)) + (let ((slot-definition-class + (apply #'direct-slot-definition-class class slot-initargs))) + (cond ((semi-standard-class-p class) + (unless (or ; for bootstrapping + (eq slot-definition-class 'standard-direct-slot-definition) + (and (class-p slot-definition-class) + (subclassp slot-definition-class <standard-direct-slot-definition>))) + (error (TEXT "Wrong ~S result for class ~S: not a subclass of ~S: ~S") + 'direct-slot-definition-class (class-name class) + 'standard-direct-slot-definition slot-definition-class))) + ((structure-class-p class) + (unless (and (class-p slot-definition-class) + (subclassp slot-definition-class <structure-direct-slot-definition>)) + (error (TEXT "Wrong ~S result for class ~S: not a subclass of ~S: ~S") + 'direct-slot-definition-class (class-name class) + 'structure-direct-slot-definition slot-definition-class)))) + (let ((defclass-form (getf slot-spec 'DEFCLASS-FORM))) + (when defclass-form + ;; Provide good error messages. The error message from + ;; MAKE-INSTANCE later is unintelligible. + (let ((valid-keywords + (class-valid-initialization-keywords slot-definition-class))) + (unless (eq valid-keywords 'T) + ;; The valid-keywords contain at least + ;; :NAME :READERS :WRITERS :ALLOCATION :INITARGS + ;; :INITFORM :INITFUNCTION :TYPE :DOCUMENTATION DEFCLASS-FORM. + (do ((specr slot-spec (cddr specr))) + ((endp specr)) + (let ((optionkey (car specr))) + (unless (member optionkey valid-keywords) + (error-of-type 'ext:source-program-error + :form defclass-form + :detail optionkey + (TEXT "~S ~S, slot option for slot ~S: ~S is not a valid slot option") + 'defclass (second defclass-form) (getf slot-spec ':NAME) optionkey)))))))) + (apply (cond ((eq slot-definition-class 'standard-direct-slot-definition) + #'make-instance-<standard-direct-slot-definition>) + (t #'make-instance)) + slot-definition-class slot-initargs)))) direct-slots)) ;; Test two direct slots for equality, except for the inheritable slots, Index: clos-genfun2b.lisp =================================================================== RCS file: /cvsroot/clisp/clisp/src/clos-genfun2b.lisp,v retrieving revision 1.4 retrieving revision 1.5 diff -u -d -r1.4 -r1.5 --- clos-genfun2b.lisp 9 Nov 2004 11:10:12 -0000 1.4 +++ clos-genfun2b.lisp 11 Nov 2004 12:33:07 -0000 1.5 @@ -1166,6 +1166,7 @@ compute-applicable-methods-using-classes compute-class-precedence-list compute-default-initargs + compute-direct-slot-definition-initargs compute-discriminating-function compute-effective-method compute-effective-slot-definition Index: clos-class6.lisp =================================================================== RCS file: /cvsroot/clisp/clisp/src/clos-class6.lisp,v retrieving revision 1.26 retrieving revision 1.27 diff -u -d -r1.26 -r1.27 --- clos-class6.lisp 8 Nov 2004 12:17:52 -0000 1.26 +++ clos-class6.lisp 11 Nov 2004 12:33:07 -0000 1.27 @@ -312,6 +312,15 @@ ;;; =========================================================================== +;;; Class Specification Protocol + +;; Not in MOP. +(defgeneric compute-direct-slot-definition-initargs (class &rest slot-spec) + (:method ((class class) &rest slot-spec) + slot-spec)) + +;;; =========================================================================== + ;;; Class Finalization Protocol ;; MOP p. 76 Index: clos.lisp =================================================================== RCS file: /cvsroot/clisp/clisp/src/clos.lisp,v retrieving revision 1.100 retrieving revision 1.101 diff -u -d -r1.100 -r1.101 --- clos.lisp 8 Nov 2004 12:17:51 -0000 1.100 +++ clos.lisp 11 Nov 2004 12:33:07 -0000 1.101 @@ -300,6 +300,7 @@ ; compute-applicable-methods-using-classes OK OK ; compute-class-precedence-list OK OK ; compute-default-initargs OK OK +; compute-direct-slot-definition-initargs OK OK ; compute-discriminating-function OK OK ; compute-effective-method -- OK ; compute-effective-slot-definition OK OK Index: ChangeLog =================================================================== RCS file: /cvsroot/clisp/clisp/src/ChangeLog,v retrieving revision 1.3809 retrieving revision 1.3810 diff -u -d -r1.3809 -r1.3810 --- ChangeLog 10 Nov 2004 15:36:26 -0000 1.3809 +++ ChangeLog 11 Nov 2004 12:33:07 -0000 1.3810 @@ -1,3 +1,15 @@ +2004-10-27 Bruno Haible <br...@cl...> + + * init.lisp: Export compute-direct-slot-definition-initargs. + * clos-package.lisp: Likewise. + * clos-slotdef1.lisp (compute-direct-slot-definition-initargs): New + preliminary function. + (convert-direct-slots): Use compute-direct-slot-definition-initargs. + * clos-class6.lisp (compute-direct-slot-definition-initargs): New + generic function. + * clos-genfun2b.lisp (*dynamically-modifiable-generic-function-names*): + Add it. + 2004-11-10 Bruno Haible <br...@cl...> * clos-print.lisp (*print-object-method-warning*): Comment out. Index: NEWS =================================================================== RCS file: /cvsroot/clisp/clisp/src/NEWS,v retrieving revision 1.204 retrieving revision 1.205 diff -u -d -r1.204 -r1.205 --- NEWS 10 Nov 2004 13:43:25 -0000 1.204 +++ NEWS 11 Nov 2004 12:33:07 -0000 1.205 @@ -23,6 +23,7 @@ New customizable generic functions For class creation: ENSURE-CLASS-USING-CLASS, VALIDATE-SUPERCLASS, + COMPUTE-DIRECT-SLOT-DEFINITION-INITARGS, COMPUTE-CLASS-PRECEDENCE-LIST, COMPUTE-EFFECTIVE-SLOT-DEFINITION, COMPUTE-EFFECTIVE-SLOT-DEFINITION-INITARGS, COMPUTE-SLOTS, COMPUTE-DEFAULT-INITARGS, READER-METHOD-CLASS, WRITER-METHOD-CLASS. Index: clos-package.lisp =================================================================== RCS file: /cvsroot/clisp/clisp/src/clos-package.lisp,v retrieving revision 1.39 retrieving revision 1.40 diff -u -d -r1.39 -r1.40 --- clos-package.lisp 9 Nov 2004 11:10:12 -0000 1.39 +++ clos-package.lisp 11 Nov 2004 12:33:07 -0000 1.40 @@ -119,7 +119,6 @@ slot-definition-initargs slot-definition-readers slot-definition-writers slot-definition-location - direct-slot-definition-class effective-slot-definition-class ;; MOP for slot access slot-value-using-class slot-boundp-using-class slot-makunbound-using-class @@ -130,9 +129,12 @@ class-direct-subclasses class-direct-slots class-slots class-direct-default-initargs class-default-initargs class-prototype class-finalized-p finalize-inheritance - compute-class-precedence-list compute-slots - compute-effective-slot-definition - compute-effective-slot-definition-initargs compute-default-initargs + compute-direct-slot-definition-initargs direct-slot-definition-class + compute-class-precedence-list + compute-slots compute-effective-slot-definition + compute-effective-slot-definition-initargs + effective-slot-definition-class + compute-default-initargs validate-superclass add-direct-subclass remove-direct-subclass standard-reader-method standard-writer-method reader-method-class writer-method-class Index: init.lisp =================================================================== RCS file: /cvsroot/clisp/clisp/src/init.lisp,v retrieving revision 1.199 retrieving revision 1.200 diff -u -d -r1.199 -r1.200 --- init.lisp 9 Nov 2004 11:10:12 -0000 1.199 +++ init.lisp 11 Nov 2004 12:33:06 -0000 1.200 @@ -462,7 +462,6 @@ slot-definition-initargs slot-definition-readers slot-definition-writers slot-definition-location - direct-slot-definition-class effective-slot-definition-class ;; MOP for slot access slot-value-using-class slot-boundp-using-class slot-makunbound-using-class @@ -473,9 +472,12 @@ class-direct-subclasses class-direct-slots class-slots class-direct-default-initargs class-default-initargs class-prototype class-finalized-p finalize-inheritance - compute-class-precedence-list compute-slots - compute-effective-slot-definition - compute-effective-slot-definition-initargs compute-default-initargs + compute-direct-slot-definition-initargs direct-slot-definition-class + compute-class-precedence-list + compute-slots compute-effective-slot-definition + compute-effective-slot-definition-initargs + effective-slot-definition-class + compute-default-initargs validate-superclass add-direct-subclass remove-direct-subclass standard-reader-method standard-writer-method reader-method-class writer-method-class --__--__-- Message: 4 From: Bruno Haible <ha...@us...> To: cli...@li... Subject: clisp/src lispbibl.d,1.566,1.567 stream.d,1.464,1.465 io.d,1.251,1.252 constobj.d,1.151,1.152 ChangeLog,1.3810,1.3811 Date: Thu, 11 Nov 2004 12:36:37 +0000 Reply-To: cli...@li... Update of /cvsroot/clisp/clisp/src In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv25979/src Modified Files: lispbibl.d stream.d io.d constobj.d ChangeLog Log Message: :BUFFERED :DEFAULT now means T on the input side. Index: lispbibl.d =================================================================== RCS file: /cvsroot/clisp/clisp/src/lispbibl.d,v retrieving revision 1.566 retrieving revision 1.567 diff -u -d -r1.566 -r1.567 --- lispbibl.d 8 Nov 2004 12:11:00 -0000 1.566 +++ lispbibl.d 11 Nov 2004 12:36:28 -0000 1.567 @@ -13866,8 +13866,9 @@ # UP: Tells whether a stream is buffered. # stream_isbuffered(stream) # > stream: a channel or socket stream -# < result: true if stream is buffered, else false -extern bool stream_isbuffered (object stream); +# < result: bit(1) set if input side is buffered, +# bit(0) set if output side is buffered +extern uintB stream_isbuffered (object stream); # is used by IO # UP: Returns the current line number of a stream. Index: constobj.d =================================================================== RCS file: /cvsroot/clisp/clisp/src/constobj.d,v retrieving revision 1.151 retrieving revision 1.152 diff -u -d -r1.151 -r1.152 --- constobj.d 10 Nov 2004 12:47:51 -0000 1.151 +++ constobj.d 11 Nov 2004 12:36:34 -0000 1.152 @@ -586,8 +586,12 @@ LISPOBJ_S(printstring_input,"INPUT ") LISPOBJ_S(printstring_output,"OUTPUT ") LISPOBJ_S(printstring_io,"IO ") - LISPOBJ_S(printstring_buffered,"BUFFERED ") - LISPOBJ_S(printstring_unbuffered,"UNBUFFERED ") + # Buffering mode, addressed by + # (bit(1) if input-buffered) | (bit(0) if output-buffered). + LISPOBJ_S(printstring_buffered_00,"UNBUFFERED ") + LISPOBJ_S(printstring_buffered_01,"OUTPUT-BUFFERED ") + LISPOBJ_S(printstring_buffered_10,"INPUT-BUFFERED ") + LISPOBJ_S(printstring_buffered_11,"BUFFERED ") # name-string for each streamtype, addressed by streamtype: LISPOBJ_S(printstring_strmtype_synonym,"SYNONYM") LISPOBJ_S(printstring_strmtype_broad,"BROADCAST") Index: stream.d =================================================================== RCS file: /cvsroot/clisp/clisp/src/stream.d,v retrieving revision 1.464 retrieving revision 1.465 diff -u -d -r1.464 -r1.465 --- stream.d 10 Nov 2004 11:45:02 -0000 1.464 +++ stream.d 11 Nov 2004 12:36:29 -0000 1.465 @@ -12579,7 +12579,7 @@ # Check and canonicalize the :ELEMENT-TYPE argument: test_eltype_arg(&STACK_2,&eltype); STACK_2 = canon_eltype(&eltype); - if (buffered <= 0) { check_unbuffered_eltype(&eltype); } + if (buffered < 0) { check_unbuffered_eltype(&eltype); } # Check and canonicalize the :EXTERNAL-FORMAT argument: STACK_1 = test_external_format_arg(STACK_1); # Now create the pipe. @@ -12588,7 +12588,7 @@ }); # allocate Stream: var object stream; - if (!eq(STACK_(0+4),T)) { # (buffered <= 0) ? + if (buffered < 0) { stream = make_unbuffered_stream(strmtype_pipe_in,DIRECTION_INPUT, &eltype,false,false); UnbufferedPipeStream_input_init(stream); @@ -12796,7 +12796,7 @@ }); # allocate Stream: var object stream; - if (!eq(STACK_(0+4),T)) { # (buffered <= 0) ? + if (buffered <= 0) { stream = make_unbuffered_stream(strmtype_pipe_out,DIRECTION_OUTPUT, &eltype,false,false); UnbufferedPipeStream_output_init(stream); @@ -12861,11 +12861,11 @@ # Check and canonicalize the :ELEMENT-TYPE argument: test_eltype_arg(&STACK_1,&eltype); STACK_1 = canon_eltype(&eltype); - if (buffered <= 0) { check_unbuffered_eltype(&eltype); } + if (buffered < 0) { check_unbuffered_eltype(&eltype); } # Check and canonicalize the :EXTERNAL-FORMAT argument: STACK_2 = test_external_format_arg(STACK_2); STACK_0 = allocate_handle(ipipe); - if (buffered > 0) { + if (buffered >= 0) { pushSTACK(make_buffered_stream(strmtype_pipe_in,DIRECTION_INPUT, &eltype,false,false)); BufferedPipeStream_init(STACK_0); @@ -13047,7 +13047,7 @@ pushSTACK(STACK_(2+3+1)); # eltype pushSTACK(STACK_(1+2)); var object stream; - if (!eq(STACK_(0+6),T)) { # (buffered <= 0) ? + if (buffered < 0) { stream = make_unbuffered_stream(strmtype_pipe_in,DIRECTION_INPUT, &eltype,false,false); UnbufferedPipeStream_input_init(stream); @@ -13066,7 +13066,7 @@ pushSTACK(STACK_(2+3+1)); # eltype pushSTACK(STACK_(0+2)); var object stream; - if (!eq(STACK_(0+6),T)) { # (buffered <= 0) ? + if (buffered <= 0) { stream = make_unbuffered_stream(strmtype_pipe_out,DIRECTION_OUTPUT, &eltype,false,false); UnbufferedPipeStream_output_init(stream); @@ -13571,7 +13571,7 @@ pushSTACK(allocate_socket(handle)); # allocate stream: var object stream; - if (buffered <= 0) { + if (buffered < 0) { stream = make_unbuffered_stream(strmtype_socket,DIRECTION_IO, eltype,false,false); UnbufferedSocketStream_input_init(stream); @@ -13591,9 +13591,15 @@ pushSTACK(stream); # allocate Output-Stream: pushSTACK(STACK_(2+1)); pushSTACK(STACK_(1+2)); pushSTACK(STACK_(0+3)); - stream = make_buffered_stream(strmtype_socket,DIRECTION_OUTPUT, - eltype,false,false); - BufferedSocketStream_init(stream); + if (buffered <= 0) { + stream = make_unbuffered_stream(strmtype_socket,DIRECTION_OUTPUT, + eltype,false,false); + UnbufferedSocketStream_output_init(stream); + } else { + stream = make_buffered_stream(strmtype_socket,DIRECTION_OUTPUT, + eltype,false,false); + BufferedSocketStream_init(stream); + } ChannelStreamLow_close(stream) = &low_close_socket; TheStream(stream)->strm_socket_port = port; TheStream(stream)->strm_socket_host = STACK_(3+1); @@ -13799,7 +13805,7 @@ test_socket_server(STACK_3,true); # Check and canonicalize the :BUFFERED argument: - buffered = test_buffered_arg(STACK_0); # default is NIL + buffered = test_buffered_arg(STACK_0); # Check and canonicalize the :ELEMENT-TYPE argument: test_eltype_arg(&STACK_2,&eltype); @@ -13858,7 +13864,7 @@ fehler_posfixnum(STACK_4); # Check and canonicalize the :BUFFERED argument: - buffered = test_buffered_arg(STACK_0); # default is NIL + buffered = test_buffered_arg(STACK_0); # Check and canonicalize the :ELEMENT-TYPE argument: test_eltype_arg(&STACK_2,&eltype); @@ -16975,8 +16981,9 @@ # UP: Tells whether a stream is buffered. # stream_isbuffered(stream) # > stream: a channel or socket stream -# < result: true if stream is buffered, else false -global bool stream_isbuffered (object stream) { +# < result: bit(1) set if input side is buffered, +# bit(0) set if output side is buffered +global uintB stream_isbuffered (object stream) { switch (TheStream(stream)->strmtype) { case strmtype_file: #ifdef PIPES @@ -16989,13 +16996,14 @@ #ifdef SOCKET_STREAMS case strmtype_socket: #endif - return ChannelStream_buffered(stream); + return (ChannelStream_buffered(stream) ? bit(1)|bit(0) : 0); #ifdef SOCKET_STREAMS case strmtype_twoway_socket: - return true; + return (ChannelStream_buffered(TheStream(stream)->strm_twoway_socket_input) ? bit(1) : 0) + | (ChannelStream_buffered(TheStream(stream)->strm_twoway_socket_output) ? bit(0) : 0); #endif default: - return false; + return 0; } } Index: io.d =================================================================== RCS file: /cvsroot/clisp/clisp/src/io.d,v retrieving revision 1.251 retrieving revision 1.252 diff -u -d -r1.251 -r1.252 --- io.d 2 Nov 2004 11:30:44 -0000 1.251 +++ io.d 11 Nov 2004 12:36:33 -0000 1.252 @@ -9714,9 +9714,7 @@ case strmtype_twoway_socket: #endif write_sstring_case(stream_, - stream_isbuffered(*obj_) - ? O(printstring_buffered) - : O(printstring_unbuffered)); + (&O(printstring_buffered_00))[stream_isbuffered(*obj_)]); break; default: break; Index: ChangeLog =================================================================== RCS file: /cvsroot/clisp/clisp/src/ChangeLog,v retrieving revision 1.3810 retrieving revision 1.3811 diff -u -d -r1.3810 -r1.3811 --- ChangeLog 11 Nov 2004 12:33:07 -0000 1.3810 +++ ChangeLog 11 Nov 2004 12:36:34 -0000 1.3811 @@ -1,3 +1,20 @@ +2004-11-01 Bruno Haible <br...@cl...> + + Change the meaning of :BUFFERED :DEFAULT to mean T on the input side. + * lispbibl.d (stream_isbuffered): Change return type to uintB. + * stream.d (MAKE-PIPE-INPUT-STREAM): Treat buffered = 0 like + buffered > 0. + (MAKE-PIPE-OUTPUT-STREAM): Nop. + (mkips_from_handles): Treat buffered = 0 like buffered > 0. + (MAKE-PIPE-IO-STREAM): On the input side, treat buffered = 0 like + buffered > 0. + (make_socket_stream): If buffered = 0, combine a buffered input stream + with an unbuffered output stream. + (stream_isbuffered): Change return value to be the combination of + two bits. + * io.d (pr_stream): Print "INPUT-BUFFERED" if the stream combines a + buffered input stream with an unbuffered output stream. + 2004-10-27 Bruno Haible <br...@cl...> * init.lisp: Export compute-direct-slot-definition-initargs. --__--__-- Message: 5 From: Bruno Haible <ha...@us...> To: cli...@li... Subject: clisp/doc impbody.xml,1.301,1.302 Date: Thu, 11 Nov 2004 12:36:30 +0000 Reply-To: cli...@li... Update of /cvsroot/clisp/clisp/doc In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv25979/doc Modified Files: impbody.xml Log Message: :BUFFERED :DEFAULT now means T on the input side. Index: impbody.xml =================================================================== RCS file: /cvsroot/clisp/clisp/doc/impbody.xml,v retrieving revision 1.301 retrieving revision 1.302 diff -u -d -r1.301 -r1.302 --- impbody.xml 10 Nov 2004 13:43:23 -0000 1.301 +++ impbody.xml 11 Nov 2004 12:36:28 -0000 1.302 @@ -3574,7 +3574,8 @@ <itemizedlist> <listitem><simpara>for functions that create &socket-stream;s and <link linkend="pipe">pipes</link>, &default-k; is equivalent to - &nil;; it you are transmitting a lot of data then using buffering + &t; on the input side and to &nil; on the output side; it you are + transmitting a lot of data then using buffering will significantly speed up your i/o;</simpara></listitem> <listitem><simpara>for functions that <link linkend="open">open</link> files, &default-k; means that buffered file streams will be returned --__--__-- Message: 6 From: Bruno Haible <ha...@us...> To: cli...@li... Subject: clisp/tests mop.tst,1.21,1.22 Date: Thu, 11 Nov 2004 12:38:39 +0000 Reply-To: cli...@li... Update of /cvsroot/clisp/clisp/tests In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv26568/tests Modified Files: mop.tst Log Message: A few new disabled tests. Index: mop.tst =================================================================== RCS file: /cvsroot/clisp/clisp/tests/mop.tst,v retrieving revision 1.21 retrieving revision 1.22 diff -u -d -r1.21 -r1.22 --- mop.tst 11 Nov 2004 12:33:11 -0000 1.21 +++ mop.tst 11 Nov 2004 12:38:36 -0000 1.22 @@ -1941,6 +1941,79 @@ (NIL 0.5 T 8.5) +#| ;; Not implemented, because the MOP's description of + ;; compute-discriminating-function doesn't say that we need to invalidate + ;; the effective method cache in this case. + +;; Check that defining a method on compute-applicable-methods[-using-classes] +;; invalidates the cache of all affected generic functions. +(progn + (defclass customized1-generic-function (standard-generic-function) + () + (:metaclass clos:funcallable-standard-class)) + (defgeneric testgf31 (x) + (:generic-function-class customized1-generic-function)) + (defmethod testgf31 ((x integer)) + (cons 'integer (if (next-method-p) (call-next-method)))) + (defmethod testgf31 ((x real)) + (cons 'real (if (next-method-p) (call-next-method)))) + (list + (testgf31 3) + (progn + (defmethod clos:compute-applicable-methods ((gf customized1-generic-function) args) + (let ((all-applicable (call-next-method))) + (if all-applicable (list (first all-applicable)) '()))) + (defmethod clos:compute-applicable-methods-using-classes ((gf customized1-generic-function) classes) + (let ((all-applicable (call-next-method))) + (if all-applicable (list (first all-applicable)) '()))) + (testgf31 3)))) +((INTEGER REAL) (INTEGER)) + +;; Check that defining a method on compute-effective-method +;; invalidates the cache of all affected generic functions. +(progn + (defclass customized2-generic-function (standard-generic-function) + () + (:metaclass clos:funcallable-standard-class)) + (defgeneric testgf32 (x) + (:generic-function-class customized2-generic-function)) + (defmethod testgf32 ((x integer)) + (cons 'integer (if (next-method-p) (call-next-method)))) + (defmethod testgf32 ((x real)) + (cons 'real (if (next-method-p) (call-next-method)))) + (list + (testgf32 3) + (progn + (defmethod clos:compute-effective-method ((gf customized2-generic-function) method-combination methods) + `(REVERSE ,(call-next-method))) + (testgf32 3)))) +((INTEGER REAL) (REAL INTEGER)) + +;; Check that defining a method on compute-discriminating-function +;; invalidates the cache of all affected generic functions. +(progn + (defclass customized3-generic-function (standard-generic-function) + () + (:metaclass clos:funcallable-standard-class)) + (defgeneric testgf33 (x) + (:generic-function-class customized3-generic-function)) + (defmethod testgf33 ((x integer)) + (cons 'integer (if (next-method-p) (call-next-method)))) + (defmethod testgf33 ((x real)) + (cons 'real (if (next-method-p) (call-next-method)))) + (list + (testgf33 3) + (progn + (defmethod clos:compute-discriminating-function ((gf customized3-generic-function)) + (let ((orig-df (call-next-method))) + #'(lambda (&rest arguments) + (reverse (apply orig-df arguments))))) + (testgf33 3)))) +((INTEGER REAL) (REAL INTEGER)) + +|# + + ;;; Application example: Typechecked slots (progn --__--__-- _______________________________________________ clisp-cvs mailing list cli...@li... https://lists.sourceforge.net/lists/listinfo/clisp-cvs End of clisp-cvs Digest |