clisp-cvs digest, Vol 1 #886 - 7 msgs

[<cli...@li...>]

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/tests format.tst,1.14,1.15 ChangeLog,1.295,1.296 (Bruno Haible)
   2. clisp/src format.lisp,1.40,1.41 ChangeLog,1.4020,1.4021 (Bruno Haible)
   3. clisp/doc impbody.xml,1.338,1.339 (Bruno Haible)
   4. clisp/src CodingStyle,1.14,1.15 (Bruno Haible)
   5. clisp/doc Newline-Convention.txt,NONE,1.1 (Bruno Haible)
   6. clisp/src NEWS,1.221,1.222 (Bruno Haible)
   7. clisp/src condition.lisp,1.60,1.61 ChangeLog,1.4021,1.4022 (Bruno Haible)

--__--__--

Message: 1
From: Bruno Haible <ha...@us...>
To: cli...@li...
Subject: clisp/tests format.tst,1.14,1.15 ChangeLog,1.295,1.296
Date: Wed, 05 Jan 2005 11:49:41 +0000
Reply-To: cli...@li...

Update of /cvsroot/clisp/clisp/tests
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv24924/tests

Modified Files:
	format.tst ChangeLog 
Log Message:
New format directive "~.", equivalent to ELASTIC-NEWLINE.


Index: format.tst
===================================================================
RCS file: /cvsroot/clisp/clisp/tests/format.tst,v
retrieving revision 1.14
retrieving revision 1.15
diff -u -d -r1.14 -r1.15
--- format.tst	30 Aug 2004 13:49:45 -0000	1.14
+++ format.tst	5 Jan 2005 11:49:39 -0000	1.15
@@ -1037,6 +1037,157 @@
            (funcall (formatter "~10I") s)))
 T
 
+;; Test elastic-newline as a FORMAT directive.
+
+(format nil "~&abc~.")
+"abc
+"
+
+(with-output-to-string (s) (funcall (formatter "~&abc~.") s))
+"abc
+"
+
+(format nil "~&abc~.~%")
+"abc
+"
+
+(format nil "~&abc~3.")
+"abc
+
+
+"
+
+(format nil "~&abc~0.")
+"abc"
+
+;; Test elastic-newline on string-output-stream.
+
+(with-output-to-string (stream)
+  (format stream "~&abc~."))
+"abc
+"
+
+(with-output-to-string (stream)
+  (format stream "~&abc~.")
+  (format stream "def"))
+"abc
+def"
+
+(with-output-to-string (stream)
+  (format stream "~&abc~.")
+  (format stream "~%def"))
+"abc
+def"
+
+(with-output-to-string (stream)
+  (format stream "~&abc~.")
+  (format stream "~&def"))
+"abc
+def"
+
+(with-output-to-string (stream)
+  (format stream "~&abc~.~.")
+  (format stream "~&~&def"))
+"abc
+def"
+
+(with-output-to-string (stream)
+  (format stream "~&abc~%~.")
+  (format stream "~&def"))
+"abc
+
+def"
+
+(with-output-to-string (stream)
+  (format stream "~&abc~.")
+  (format stream "~&~%def"))
+"abc
+
+def"
+
+(with-output-to-string (stream)
+  (format stream "~&abc~%~.")
+  (format stream "~&~%def"))
+"abc
+
+
+def"
+
+;; Test elastic-newline also on Gray streams.
+(progn
+  (defclass gray-string-output-stream (fundamental-character-output-stream)
+    ((accumulator :type string)))
+  (defmethod initialize-instance :after ((s gray-string-output-stream) &rest args)
+    (setf (slot-value s 'accumulator)
+          (make-array 0 :element-type 'character :adjustable t :fill-pointer 0)))
+  (defmethod stream-write-char ((s gray-string-output-stream) ch)
+    (vector-push-extend ch (slot-value s 'accumulator)))
+  (defmethod stream-line-column ((s gray-string-output-stream))
+    (let* ((a (slot-value s 'accumulator))
+           (j (length a))
+           (i (1+ (or (position #\Newline a :from-end t) -1))))
+      (string-width a :start i :end j)))
+  (list
+    (let ((stream (make-instance 'gray-string-output-stream)))
+      (format stream "~&abc~.")
+      (close stream)
+      (coerce (slot-value stream 'accumulator) 'simple-string))
+    (let ((stream (make-instance 'gray-string-output-stream)))
+      (format stream "~&abc~.")
+      (format stream "def")
+      (close stream)
+      (coerce (slot-value stream 'accumulator) 'simple-string))
+    (let ((stream (make-instance 'gray-string-output-stream)))
+      (format stream "~&abc~.")
+      (format stream "~%def")
+      (close stream)
+      (coerce (slot-value stream 'accumulator) 'simple-string))
+    (let ((stream (make-instance 'gray-string-output-stream)))
+      (format stream "~&abc~.")
+      (format stream "~&def")
+      (close stream)
+      (coerce (slot-value stream 'accumulator) 'simple-string))
+    (let ((stream (make-instance 'gray-string-output-stream)))
+      (format stream "~&abc~.~.")
+      (format stream "~&~&def")
+      (close stream)
+      (coerce (slot-value stream 'accumulator) 'simple-string))
+    (let ((stream (make-instance 'gray-string-output-stream)))
+      (format stream "~&abc~%~.")
+      (format stream "~&def")
+      (close stream)
+      (coerce (slot-value stream 'accumulator) 'simple-string))
+    (let ((stream (make-instance 'gray-string-output-stream)))
+      (format stream "~&abc~.")
+      (format stream "~&~%def")
+      (close stream)
+      (coerce (slot-value stream 'accumulator) 'simple-string))
+    (let ((stream (make-instance 'gray-string-output-stream)))
+      (format stream "~&abc~%~.")
+      (format stream "~&~%def")
+      (close stream)
+      (coerce (slot-value stream 'accumulator) 'simple-string))))
+("abc
+"
+"abc
+def"
+"abc
+def"
+"abc
+def"
+"abc
+def"
+"abc
+
+def"
+"abc
+
+def"
+"abc
+
+
+def")
+
 ;; local variables:
 ;; eval: (make-local-variable 'write-file-functions)
 ;; eval: (remove-hook 'write-file-functions 'delete-trailing-whitespace t)

Index: ChangeLog
===================================================================
RCS file: /cvsroot/clisp/clisp/tests/ChangeLog,v
retrieving revision 1.295
retrieving revision 1.296
diff -u -d -r1.295 -r1.296
--- ChangeLog	4 Jan 2005 17:44:49 -0000	1.295
+++ ChangeLog	5 Jan 2005 11:49:39 -0000	1.296
@@ -1,3 +1,7 @@
+2004-12-24  Bruno Haible  <br...@cl...>
+
+	* format.tst: Add some tests for elastic-newline.
+
 2005-01-04  Sam Steingold  <sd...@gn...>
 
 	* type.tst: check that there are no unnecessary warnings on



--__--__--

Message: 2
From: Bruno Haible <ha...@us...>
To: cli...@li...
Subject: clisp/src format.lisp,1.40,1.41 ChangeLog,1.4020,1.4021
Date: Wed, 05 Jan 2005 11:49:41 +0000
Reply-To: cli...@li...

Update of /cvsroot/clisp/clisp/src
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv24924/src

Modified Files:
	format.lisp ChangeLog 
Log Message:
New format directive "~.", equivalent to ELASTIC-NEWLINE.


Index: format.lisp
===================================================================
RCS file: /cvsroot/clisp/clisp/src/format.lisp,v
retrieving revision 1.40
retrieving revision 1.41
diff -u -d -r1.40 -r1.41
--- format.lisp	21 Dec 2004 13:02:55 -0000	1.40
+++ format.lisp	5 Jan 2005 11:49:36 -0000	1.41
@@ -206,7 +206,8 @@
                            (#\{ . FORMAT-ITERATION)       (#\} . FORMAT-ITERATION-END)
                            (#\< . FORMAT-JUSTIFICATION)   (#\> . FORMAT-JUSTIFICATION-END)
                            (#\^ . FORMAT-UP-AND-OUT)      (#\; . FORMAT-SEPARATOR)
-                           (#\! . FORMAT-CALL))))))
+                           (#\! . FORMAT-CALL)
+                           (#\. . FORMAT-ELASTIC-NEWLINE))))))
             (if directive-name
               (setf (csd-data newcsd) directive-name)
               (format-error 'error control-string index
@@ -1350,6 +1351,15 @@
     (fresh-line stream)
     (dotimes (i (1- count)) (terpri stream))))
 
+;; ~.
+(defun format-elastic-newline (stream colon-modifier atsign-modifier
+                               &optional (count 1))
+  (declare (ignore colon-modifier atsign-modifier))
+  (if (null count) (setq count 1))
+  (when (plusp count)
+    (dotimes (i (1- count)) (terpri stream))
+    (ext:elastic-newline stream)))
+
 ;; ~|, CLTL p.397, CLtL2 p. 596, ABI
 (defun format-page (stream colon-modifier atsign-modifier &optional (count 1))
   (declare (ignore colon-modifier atsign-modifier))
@@ -2516,6 +2526,11 @@
                                    ,inner-form)
                                 inner-form)
                               forms)))
+                     (FORMAT-ELASTIC-NEWLINE        ; #\.
+                      (simple-arglist 1)
+                      (if (member (first arglist) '(nil 1))
+                        (push `(EXT:ELASTIC-NEWLINE STREAM) forms)
+                        (trivial-call)))
                      (t ;; Huh? Someone implemented a new format directive,
                         ;; but forgot it here! Bail out.
                       (throw 'formatter-hairy nil)))))))))

Index: ChangeLog
===================================================================
RCS file: /cvsroot/clisp/clisp/src/ChangeLog,v
retrieving revision 1.4020
retrieving revision 1.4021
diff -u -d -r1.4020 -r1.4021
--- ChangeLog	5 Jan 2005 00:15:18 -0000	1.4020
+++ ChangeLog	5 Jan 2005 11:49:36 -0000	1.4021
@@ -1,3 +1,10 @@
+2004-12-24  Bruno Haible  <br...@cl...>
+
+	New format directive "~.".
+	* format.lisp (format-parse-cs): Add support for ~..
+	(format-elastic-newline): New function.
+	(formatter-main-1): Add support for ~..
+
 2005-01-04  Sam Steingold  <sd...@gn...>
 
 	* foreign1.lisp: import SYS:SYMBOL-KEYWORD



--__--__--

Message: 3
From: Bruno Haible <ha...@us...>
To: cli...@li...
Subject: clisp/doc impbody.xml,1.338,1.339
Date: Wed, 05 Jan 2005 11:49:38 +0000
Reply-To: cli...@li...

Update of /cvsroot/clisp/clisp/doc
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv24924/doc

Modified Files:
	impbody.xml 
Log Message:
New format directive "~.", equivalent to ELASTIC-NEWLINE.


Index: impbody.xml
===================================================================
RCS file: /cvsroot/clisp/clisp/doc/impbody.xml,v
retrieving revision 1.338
retrieving revision 1.339
diff -u -d -r1.338 -r1.339
--- impbody.xml	4 Jan 2005 15:44:22 -0000	1.338
+++ impbody.xml	5 Jan 2005 11:49:25 -0000	1.339
@@ -3773,6 +3773,9 @@
  on the stream is &fresh-line;, &finish-output;, &force-output; or
  &close;.</para>
 
+<para>The functionality of &elastic-newline; is also available through
+ &format;, see <xref linkend="format-dot"/>.</para>
+
 <para>A technique for avoiding unnecessary blank lines in output is to
  begin each chunk of output with a call to &fresh-line; and to terminate it
  with a call to &elastic-newline;.</para>
@@ -4036,13 +4039,8 @@
 
 </section>
 
-<section id="print-dict"><title>The Printer Dictionary
-   <ulink url="&clhs;/Body/sec_the_printer_dictionary.html">[CLHS-22.4]</ulink></title>
-
-<formalpara><title>Functions &write; &amp; &write-to-string;</title>
-<para>The functions &write; and &write-to-string; have an additional
- keyword argument <constant>:closure</constant> which is used to bind
- &pr-closure;.</para></formalpara>
+<section id="print-formatted"><title>Formatted Output</title>
+   <ulink url="&clhs;/Body/sec_22-3.html">[CLHS-22.3]</ulink></title>
 
 <section id="format"><title>Function &format;</title>
 
@@ -4059,6 +4057,16 @@
   <replaceable>atsign-modifier-p</replaceable>
   <replaceable>args</replaceable>)</code>.</para>
 
+<para>The additional &format; instruction
+ <firstterm>~.<indexterm id="format-dot" significance="preferred">
+   <primary>&format;</primary>
+   <secondary id="format-dot-i">~.</secondary></indexterm></firstterm>
+ is a kind of opposite to <code>~&amp;</code>: It outputs a conditional
+ newline, by calling the function &elastic-newline;.
+ <code>~<replaceable>n</replaceable>.</code> outputs
+ <replaceable>n-1</replaceable> newlines followed by an &elastic-newline;.
+ <code>~0.</code> does nothing.</para>
+
 <para>&format; &format-r; and &format; &format-rs; can output only
  integers in the range <varname>|n| &lt;
  <replaceable>10<superscript>66</superscript></replaceable></varname>.
@@ -4079,6 +4087,16 @@
 
 </section>
 
+</section>
+
+<section id="print-dict"><title>The Printer Dictionary
+   <ulink url="&clhs;/Body/sec_the_printer_dictionary.html">[CLHS-22.4]</ulink></title>
+
+<formalpara><title>Functions &write; &amp; &write-to-string;</title>
+<para>The functions &write; and &write-to-string; have an additional
+ keyword argument <constant>:closure</constant> which is used to bind
+ &pr-closure;.</para></formalpara>
+
 <!-- //Commented out from the source code.
 <section id="print-object"><title>Generic Function &print-object;</title>
 <para>The function &print-object; verifies the &ansi-cl; requirement that its



--__--__--

Message: 4
From: Bruno Haible <ha...@us...>
To: cli...@li...
Subject: clisp/src CodingStyle,1.14,1.15
Date: Wed, 05 Jan 2005 11:51:39 +0000
Reply-To: cli...@li...

Update of /cvsroot/clisp/clisp/src
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv25305/src

Modified Files:
	CodingStyle 
Log Message:
Newline convention: before or after each line? Neither!
Half newline before, half newline after each line!


Index: CodingStyle
===================================================================
RCS file: /cvsroot/clisp/clisp/src/CodingStyle,v
retrieving revision 1.14
retrieving revision 1.15
diff -u -d -r1.14 -r1.15
--- CodingStyle	15 Nov 2004 11:14:01 -0000	1.14
+++ CodingStyle	5 Jan 2005 11:51:37 -0000	1.15
@@ -226,6 +226,12 @@
 "; ABI" in the *.lisp source code or "/* ABI */" in constsym.d, to make the
 developers aware.
 
+                             Newline Output
+                             --------------
+
+All output by the system must start with a fresh-line and must be terminated
+with an elastic newline. See doc/Newline-Convention.txt for the rationale.
+
                             Change Management
                             -----------------
 



--__--__--

Message: 5
From: Bruno Haible <ha...@us...>
To: cli...@li...
Subject: clisp/doc Newline-Convention.txt,NONE,1.1
Date: Wed, 05 Jan 2005 11:51:39 +0000
Reply-To: cli...@li...

Update of /cvsroot/clisp/clisp/doc
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv25305/doc

Added Files:
	Newline-Convention.txt 
Log Message:
Newline convention: before or after each line? Neither!
Half newline before, half newline after each line!


--- NEW FILE: Newline-Convention.txt ---
                       Choosing a Good Newline Convention
                       ==================================

Question: Should programs output a newline before or after each line of output?

The answer is complicated. There is an antagonism between the "old Lisp way"
of outputting a newline before the line's contents (exemplified by the
functions PRINT and PPRINT) and the "Unix way" of outputting a newline after
the line's contents. Which one is "right"?

A newline convention is, by definition, a consistent way to use the TERPRI
and FRESH-LINE functions or - in FORMAT notation - ~% and ~& directives in
such a way that the resulting output is properly subdivided into lines.

Three newline conventions are conceivable:

  A) Print a newline before the line, and nothing after it.
     As a format string: "~%First line.~%Second line."

  B) Print a newline if needed before the line, and a newline always after it.
     As a format string: "~&First line.~%Second line.~%"

  C) Print nothing before the line, and a newline always after it.
     As a format string: "First line.~%Second line.~%"

The most important criterion is interoperability. Two newline conventions
are interoperable if, when parts of a program use one of the convention
and other parts of the program use the other conventions, lines are still
properly separated. It is easily seen that A and B are interoperable, B and
C are interoperable as well, but A and C are not interoperable: When an
output with convention A is followed by output in convention C, two lines
are appended without a line separator. This should not happen.

Therefore, in what follows, we consider five kinds of programs:

  A) using convention A exclusively,
  AB) using conventions A and B in a mixed way,
  B) using convention B exclusively,
  BC) using conventions B and C in a mixed way,
  C) using convention C exclusively,

Which of these five kinds of programs operates satisfactorily?
Let's consider different criteria:

  1. Do extra blank lines occur during normal operation?
  2. What happens if FRESH-LINE prints a newline when it's not needed, i.e.
     when it cannot tell for sure whether the current column is 0?
     (This situation happens, for example, when logging to a file: After the
     user has entered a line interactively, the column on screen is 0, but
     since the input has not been echoed in the log file, the column in the
     log file is usually not 0, and FRESH-LINE _must_ output a newline. Then
     a blank line is visible on the screen.)
  3. What happens if FRESH-LINE omits a newline when it would be needed?
     (This is more rare, but can happen, for example, when standard output
     and standard error are different streams but are joined outside the
     Lisp implementation, at the OS level. Such as in "lisp | cat".)
  4. Is it possible to reliably output a blank line before or after a
     paragraph of text? I.e. what happens with
     A1) "~%~%First line.~%Second line."
     A2) "~%First line.~%Second line.~%"
     B1) "~&~%First line.~%Second line.~%"
     B2) "~&First line.~%Second line.~%~%"
     C1) "~%First line.~%Second line.~%"
     C2) "First line.~%Second line.~%~%"
  5. Is is possible to optimize away blank lines? I.e. is it possible to avoid
     a blank line even though another piece of code uses one of A1 ... C2,
     without risking that adjacent lines be unseparated?

Here is the analysis:

  1. A)  No extra blank lines.
     AB) An extra blank line each time one switches from convention B to A.
     B)  No extra blank lines.
     BC) No extra blank lines.
     C)  No extra blank lines.

  2. A)  No extra blank lines.
     AB) Blank lines can occur, when convention B is used.
     B)  Blank lines can occur.
     BC) Blank lines can occur, when convention B is used.
     C)  No extra blank lines.

  3. A)  No problem.
     AB) Lines can be unseparated when one switches from convention A to B.
     B)  No problem.
     BC) No problem.
     C)  No problem.

  4. A)  No problem.
     AB) The blank line is omitted when using A2 before switching to B.
     B)  No problem.
     BC) No problem.
     C)  No problem.

  5. A)  Yes, using "~&First line.~%Second line." eats a previous blank line.
     AB) Not really: Using "~&First line.~%Second line." may eat a previous
         blank line or a following blank line, but you cannot know in advance
         which one.
     B)  Yes, using "~&First line.~%Second line." eats a following blank line.
     BC) Impossible.
     C)  Impossible.
     To optimize blank lines in case C would require the opposite of
     FRESH-LINE, namely a conditional newline that is annullated if the
     _next_ output on the stream will be a newline. (ELASTIC-NEWLINE,
     see below.)

Conclusion:

Each approach has its benefits and drawbacks.

When used globally (i.e. no interoperability requirements), A, B, C can be
compared as follows:
  - A and C are equally perfect if eating blank lines is not a requirement.
  - If eating blank lines is desirable, A is perfect.
  - B is not so good, because it is suboptimal in case 2.

For CLISP built-ins, however, the interoperability requirement with both A
and C is a major requirement. Therefore we have to choose B, and accept the
drawbacks:
  1. AB) An extra blank line each time one switches from convention B to A.
  2. B) When logging to a file, blank lines can occur.
  3. AB) When joining two output streams into one, lines can be unseparated.
  4. AB) Blank lines after a paragraph can be eaten by CLISP.
  5. AB) Optimizing blank lines is not really possible.
And to minimize the drawbacks, we recommend to user programs to use approach
B or C, but not A.

Another drawback of B is, however, that in interactive sessions the cursor
is nearly always positioned at the beginning of a line, pointing the user's
focus to the wrong point and taking away a screen line.

To solve this, we introduce the concept of ELASTIC-NEWLINE. This is the
converse of FRESH-LINE: It waits for the next character and outputs a newline
when the next character is not a newline; then the next character is processed
normally. As a FORMAT directive, we write it "~." (the only FORMAT directives
left are "~.", "~=", "~\""). ELASTIC-NEWLINE followed by FRESH-LINE leads to
exactly one newline always.

It leads to a slightly different newline convention:

  B') Print a newline if needed before the line, and a newline if needed after
      it.
      As a format string: "~&First line.~%Second line.~."

The five programs being considered are now:

  A) using convention A exclusively,
  AB') using conventions A and B' in a mixed way,
  B') using convention B' exclusively,
  B'C) using conventions B' and C in a mixed way,
  C) using convention C exclusively,

Here is the corresponding analysis:

  1. A)   No extra blank lines.
     AB') No extra blank lines.
     B')  No extra blank lines.
     B'C) No extra blank lines.
     C)   No extra blank lines.

  2. A)   No extra blank lines.
     AB') Blank lines can occur, when convention B' is used.
     B')  Blank lines can occur.
     B'C) Blank lines can occur, when convention B' is used.
     C)   No extra blank lines.

  3. A)   No problem.
     AB') Lines can be unseparated when one switches from convention A to B'.
     B')  No problem.
     B'C) No problem.
     C)   No problem.

  4. A)   No problem.
     AB') The blank line is omitted when using A2 before switching to B'
          or when using B'2 before switching to A.
     B')  No problem.
     B'C) No problem.
     C)   No problem.

  5. A)   Yes, using "~&First line.~%Second line." eats a previous blank line.
     AB') Not really: Using "~&First line.~%Second line." may eat a previous
          blank line or a following blank line, but you cannot know in advance
          which one.
     B')  Yes, using "~&First line.~%Second line." eats a following blank line.
     B'C) Impossible.
     C)   Yes, using "First line.~%Second line.~." eats a following blank line.

Now criterium 1 is satisfied perfectly. We therefore choose B', not B, for
use inside CLISP, and programs can use either A or C without problems during
normal operation.



--__--__--

Message: 6
From: Bruno Haible <ha...@us...>
To: cli...@li...
Subject: clisp/src NEWS,1.221,1.222
Date: Wed, 05 Jan 2005 12:01:55 +0000
Reply-To: cli...@li...

Update of /cvsroot/clisp/clisp/src
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv27162/src

Modified Files:
	NEWS 
Log Message:
Mention ELASTIC-NEWLINE.


Index: NEWS
===================================================================
RCS file: /cvsroot/clisp/clisp/src/NEWS,v
retrieving revision 1.221
retrieving revision 1.222
diff -u -d -r1.221 -r1.222
--- NEWS	4 Jan 2005 15:07:50 -0000	1.221
+++ NEWS	5 Jan 2005 12:01:53 -0000	1.222
@@ -213,6 +213,12 @@
 * New function ABSOLUTE-PATHNAME.
   See <http://clisp.cons.org/impnotes.html#absolute-pathname> for details.
 
+* New function ELASTIC-NEWLINE and new FORMAT directive "~.".
+  See <http://clisp.cons.org/impnotes.html#elastic-newline>
+  and <http://clisp.cons.org/impnotes.html#format-dot> for details.
+  Through this function, CLISP no longer produces spurious blank lines when
+  a program uses the convention of printing a #\Newline before each line.
+
 * TRACE has a new option :MAX-DEPTH, that is useful to avoid infinite
   recursions in the tracer.
   See <http://clisp.cons.org/impnotes.html#trace> for details.
@@ -247,6 +253,9 @@
   initialization and finalization.
   See <http://clisp.cons.org/impnotes.html#c-lines> for details.
 
+* Buffered streams now are suitable for interactive streams. It is no longer
+  necessary to use :BUFFERED NIL to avoid blocking in various situations.
+
 * Function READ-BYTE-SEQUENCE takes a new keyword argument :INTERACTIVE.
   See <http://clisp.cons.org/impnotes.html#rd-by-seq> for details.
 



--__--__--

Message: 7
From: Bruno Haible <ha...@us...>
To: cli...@li...
Subject: clisp/src condition.lisp,1.60,1.61 ChangeLog,1.4021,1.4022
Date: Wed, 05 Jan 2005 12:11:50 +0000
Reply-To: cli...@li...

Update of /cvsroot/clisp/clisp/src
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv29094/src

Modified Files:
	condition.lisp ChangeLog 
Log Message:
Reduce code size of some macro expansions.


Index: condition.lisp
===================================================================
RCS file: /cvsroot/clisp/clisp/src/condition.lisp,v
retrieving revision 1.60
retrieving revision 1.61
diff -u -d -r1.60 -r1.61
--- condition.lisp	4 Jan 2005 15:56:26 -0000	1.60
+++ condition.lisp	5 Jan 2005 12:11:46 -0000	1.61
@@ -1136,26 +1136,29 @@
 (defmacro check-type (place typespec &optional (string nil))
   (let ((tag1 (gensym))
         (tag2 (gensym))
-        (var (gensym))
-        (reporter `(lambda (stream)
-                     (format stream (report-one-new-value-string) ',place))))
+        (var (gensym)))
     `(TAGBODY
        ,tag1
        (LET ((,var ,place))
          (WHEN (TYPEP ,var ',typespec) (GO ,tag2))
-         (RESTART-CASE
-           (ERROR-OF-TYPE 'TYPE-ERROR
-             :DATUM ,var :EXPECTED-TYPE ',typespec
-             (TYPE-ERROR-STRING)
-             (CHECK-TYPE-ERROR-STRING ',place ,string ',typespec)
-             ,var)
-           ;; only one restart, will "continue" invoke it? - no!
-           (STORE-VALUE
-             :REPORT ,reporter
-             :INTERACTIVE (LAMBDA () (PROMPT-FOR-NEW-VALUE ',place))
-             (NEW-VALUE) (SETF ,place NEW-VALUE))))
+         (CHECK-TYPE-FAILED ',place ,var #'(LAMBDA (NEW-VALUE) (SETF ,place NEW-VALUE))
+                            ,string ',typespec))
        (GO ,tag1)
        ,tag2)))
+(defun check-type-failed (place place-oldvalue place-setter string typespec) ; ABI
+  (restart-case
+    (error-of-type 'type-error
+      :datum place-oldvalue :expected-type typespec
+      (type-error-string)
+      (check-type-error-string place string typespec)
+      place-oldvalue)
+    ;; Only one restart. Call it STORE-VALUE, not CONTINUE, so that it's not
+    ;; chosen by "continue".
+    (STORE-VALUE
+      :report (lambda (stream)
+                (format stream (report-one-new-value-string) place))
+      :interactive (lambda () (prompt-for-new-value place))
+      (new-value) (funcall place-setter new-value))))
 
 ;; this is the same as `default-restart-interactive' but it must
 ;; be kept a separate object for the benefit of `appease-cerrors'
@@ -1165,50 +1168,66 @@
 (defmacro assert (test-form &optional (place-list nil) (datum nil) &rest args)
   (let ((tag1 (gensym))
         (tag2 (gensym)))
-    `(flet ((assert-restart-prompt ()
-              (nconc
-               ,@(mapcar #'(lambda (place)
-                             `(PROMPT-FOR-NEW-VALUE ',place))
-                         place-list))))
-       ,(when place-list
-          `(setf (closure-name #'assert-restart-prompt)
-                 'assert-restart-prompt))
-       (TAGBODY
-         ,tag1
-         (WHEN ,test-form (GO ,tag2))
-         (RESTART-CASE
-             ;; no need for explicit association, see APPLICABLE-RESTART-P
-             (ERROR ; of-type ??
-              ,@(if datum
-                  `(,datum ,@args) ; use coerce-to-condition??
-                  `("~A" (ASSERT-ERROR-STRING ',test-form))))
-           ;; only one restart: CONTINUE
-           (CONTINUE
-             :REPORT (LAMBDA (STREAM)
-                       (APPLY #'FORMAT STREAM
-                               (,(case (length place-list)
-                                   (0 'REPORT-NO-NEW-VALUE-STRING)
-                                   (1 'REPORT-ONE-NEW-VALUE-STRING)
-                                   (t 'REPORT-NEW-VALUES-STRING)))
-                               ',place-list))
-             :INTERACTIVE ,(if place-list
-                             'assert-restart-prompt
-                             'assert-restart-no-prompts)
-             ,@(do ((pl place-list (cdr pl))
-                    (all-setter-vars '())
-                    (all-setter-forms '()))
-                   ((endp pl)
-                    (cons (nreverse all-setter-vars)
-                          (nreverse all-setter-forms)))
-                 (multiple-value-bind (temps subforms stores setterform getterform)
-                     (get-setf-expansion (car pl))
-                   (declare (ignore getterform))
-                   (setq all-setter-vars
-                         (revappend stores all-setter-vars))
-                   (push (wrap-let* (mapcar #'list temps subforms) setterform)
-                         all-setter-forms)))))
-         (GO ,tag1)
-         ,tag2))))
+    `(TAGBODY
+       ,tag1
+       (WHEN ,test-form (GO ,tag2))
+       (,@(if place-list
+            (let ((all-setter-vars '())
+                  (all-setter-forms '()))
+              (do ((pl place-list (cdr pl)))
+                  ((endp pl))
+                (multiple-value-bind (temps subforms stores setterform getterform)
+                    (get-setf-expansion (car pl) env)
+                  (declare (ignore getterform))
+                  (push (length stores) all-numvalues)
+                  (setq all-setter-vars
+                        (revappend stores all-setter-vars))
+                  (push (wrap-let* (mapcar #'list temps subforms) setterform)
+                        all-setter-forms)))
+              (setq all-setter-vars (nreverse all-setter-vars))
+              (setq all-setter-forms (nreverse all-setter-forms))
+              `(ASSERT-FAILED ',place-list
+                              #'(LAMBDA ,all-setter-vars ,@all-setter-forms)))
+            `(SIMPLE-ASSERT-FAILED))
+        ,@(if datum
+            `(NIL ,datum ,@args) ; use coerce-to-condition??
+            `((ASSERT-ERROR-STRING ',test-form))))
+       (GO ,tag1)
+       ,tag2)))
+(defun assert-failed (place-list places-setter error-string &rest condition-datum+args) ; ABI
+  (flet ((assert-restart-prompt ()
+           (mapcan #'(lambda (place)
+                       (prompt-for-new-value place))
+                   place-list)))
+    (setf (closure-name #'assert-restart-prompt) 'assert-restart-prompt)
+    (restart-case
+      ;; No need for explicit association, see APPLICABLE-RESTART-P.
+      (if error-string
+        (error ; of-type ??
+          "~A" error-string)
+        (apply #'error condition-datum+args)) ; use coerce-to-condition??
+      ;; Only one restart: CONTINUE.
+      (CONTINUE
+        :REPORT (lambda (stream)
+                  (apply #'format stream
+                         (if (= (length place-list) 1)
+                           (report-one-new-value-string)
+                           (report-new-values-string))
+                         place-list))
+        :INTERACTIVE assert-restart-prompt
+        (&rest new-values) (apply places-setter new-values)))))
+(defun simple-assert-failed (error-string &rest condition-datum+args) ; ABI
+  (restart-case
+    ;; No need for explicit association, see APPLICABLE-RESTART-P.
+    (if error-string
+      (error ; of-type ??
+        "~A" error-string)
+      (apply #'error condition-datum+args)) ; use coerce-to-condition??
+    ;; Only one restart: CONTINUE.
+    (CONTINUE
+      :REPORT (lambda (stream) (format stream (report-no-new-value-string)))
+      :INTERACTIVE assert-restart-no-prompts
+      ())))
 
 (defun correctable-error (options condition)
   (let ((restarts
@@ -1343,16 +1362,10 @@
                   ;; if a clause contains an OTHERWISE or T key,
                   ;; it is treated as a normal key, as per CLHS.
                   (OTHERWISE
-                   (ERROR-OF-TYPE 'TYPE-ERROR
-                     :DATUM ,var :EXPECTED-TYPE ',expected-type
-                     (TYPE-ERROR-STRING)
-                     ,errorstring ,var))))))
+                    (ETYPECASE-FAILED ,var ,errorstring ',expected-type))))))
          (retry-loop (casename place clauselist errorstring expected-type)
            (let ((g (gensym))
-                 (h (gensym))
-                 (reporter `(lambda (stream)
-                              (format stream (report-one-new-value-string)
-                                      ',place))))
+                 (h (gensym)))
              `(BLOCK ,g
                 (TAGBODY
                   ,h
@@ -1361,31 +1374,21 @@
                       ;; if a clause contains an OTHERWISE or T key,
                       ;; it is treated as a normal key, as per CLHS.
                       (OTHERWISE
-                       (RESTART-CASE
-                          (PROGN ; no need for explicit association, see applicable-restart-p
-                            (ERROR-OF-TYPE 'TYPE-ERROR
-                              :DATUM ,place :EXPECTED-TYPE ',expected-type
-                              (TYPE-ERROR-STRING)
-                              ,errorstring
-                              ,place))
-                          ;; only one restart, will "continue" invoke it? - NO
-                          (STORE-VALUE
-                            :REPORT ,reporter
-                            :INTERACTIVE (LAMBDA () (PROMPT-FOR-NEW-VALUE ',place))
-                            (NEW-VALUE) (SETF ,place NEW-VALUE)))
+                        (CTYPECASE-FAILED ',place ,place #'(LAMBDA (NEW-VALUE) (SETF ,place NEW-VALUE))
+                                          ,errorstring ',expected-type)
                         (GO ,h)))))))))
     (defmacro etypecase (keyform &rest keyclauselist)
       (if (assoc t keyclauselist)
-          `(typecase ,keyform ,@keyclauselist)
-          (simply-error 'TYPECASE keyform keyclauselist
-                        (typecase-errorstring keyform keyclauselist)
-                        (typecase-expected-type keyclauselist))))
+        `(TYPECASE ,keyform ,@keyclauselist)
+        (simply-error 'TYPECASE keyform keyclauselist
+                      (typecase-errorstring keyform keyclauselist)
+                      (typecase-expected-type keyclauselist))))
     (defmacro ctypecase (keyplace &rest keyclauselist)
       (if (assoc t keyclauselist)
-          `(typecase ,keyplace ,@keyclauselist)
-          (retry-loop 'TYPECASE keyplace keyclauselist
-                      (typecase-errorstring keyplace keyclauselist)
-                      (typecase-expected-type keyclauselist))))
+        `(TYPECASE ,keyplace ,@keyclauselist)
+        (retry-loop 'TYPECASE keyplace keyclauselist
+                    (typecase-errorstring keyplace keyclauselist)
+                    (typecase-expected-type keyclauselist))))
     (defmacro ecase (keyform &rest keyclauselist)
       (simply-error 'CASE keyform keyclauselist
                     (case-errorstring keyform keyclauselist)
@@ -1395,6 +1398,26 @@
                   (case-errorstring keyform keyclauselist)
                   (case-expected-type keyclauselist)))
 ) )
+(defun etypecase-failed (value errorstring expected-type) ; ABI
+  (error-of-type 'type-error
+    :datum value :expected-type expected-type
+    (type-error-string)
+    errorstring value))
+(defun ctypecase-failed (place place-oldvalue place-setter errorstring expected-type) ; ABI
+  (restart-case
+    (progn ; no need for explicit association, see applicable-restart-p
+      (error-of-type 'type-error
+        :datum place-oldvalue :expected-type expected-type
+        (type-error-string)
+        errorstring
+        place-oldvalue))
+    ;; Only one restart. Call it STORE-VALUE, not CONTINUE, so that it's not
+    ;; chosen by "continue".
+    (STORE-VALUE
+      :report (lambda (stream)
+                (format stream (report-one-new-value-string) place))
+      :interactive (lambda () (prompt-for-new-value place))
+      (new-value) (funcall place-setter new-value))))
 
 ;;; 29.4.11. Debugging Utilities
 

Index: ChangeLog
===================================================================
RCS file: /cvsroot/clisp/clisp/src/ChangeLog,v
retrieving revision 1.4021
retrieving revision 1.4022
diff -u -d -r1.4021 -r1.4022
--- ChangeLog	5 Jan 2005 11:49:36 -0000	1.4021
+++ ChangeLog	5 Jan 2005 12:11:46 -0000	1.4022
@@ -1,3 +1,14 @@
+2005-01-01  Bruno Haible  <br...@cl...>
+
+	Reduce code size of some macro expansions.
+	* condition.lisp (check-type-failed): New function.
+	(check-type): Use it in the macroexpansion.
+	(assert-failed, simple-assert-failed): New functions, extracted from
+	assert.
+	(assert): Use them in the macroexpansion.
+	(etypecase-failed, ctypecase-failed): New functions.
+	(etypecase, ctypecase, ecase, ccase): Use them in the macroexpansion.
+
 2004-12-24  Bruno Haible  <br...@cl...>
 
 	New format directive "~.".




--__--__--

_______________________________________________
clisp-cvs mailing list
cli...@li...
https://lists.sourceforge.net/lists/listinfo/clisp-cvs


End of clisp-cvs Digest