From 26f0ae97e957a26acf6f4b55e4eb70f4cae3a36c Mon Sep 17 00:00:00 2001 From: William Harold Newman Date: Mon, 3 Sep 2001 02:26:26 +0000 Subject: [PATCH] 0.pre7.32: merged Alexey Dejneka's WRITE-STRING/WRITE-LINE fix rewrote WRITE-STRING to use a simplified, unconditional version of the old HIGH-SECURITY code WRITE-STRING* is always used with four arguments, so the &OPTIONALness of its arguments is unnecessary generality, so get rid of it. Then, since its calling convention has changed, rename it to %WRITE-STRING. WRITE-LINE can be made a lot simpler by reusing WRITE-STRING, and then WRITE-LINE* isn't needed at all. --- src/code/stream.lisp | 89 +++++++++++++++++++++----------------------------- version.lisp-expr | 2 +- 2 files changed, 39 insertions(+), 52 deletions(-) diff --git a/src/code/stream.lisp b/src/code/stream.lisp index f1a3998..fb1d207 100644 --- a/src/code/stream.lisp +++ b/src/code/stream.lisp @@ -566,33 +566,29 @@ (stream-fresh-line stream)))) (defun write-string (string &optional (stream *standard-output*) - &key (start 0) (end (length (the string string)))) - - ;; FIXME: These SETFs don't look right to me. Looking at the - ;; definition of "bounding indices" in the glossary of the ANSI - ;; spec, and extrapolating from the behavior of other operations - ;; when their operands are the wrong type, it seems that it would be - ;; more correct to essentially - ;; (AVER (<= 0 START END (LENGTH STRING))) - ;; instead of modifying the incorrect values. - #!+high-security - (setf end (min end (length (the vector string)))) - #!+high-security - (setf start (max start 0)) - - ;; FIXME: And I'd just signal a non-continuable error.. - #!+high-security - (when (< end start) - (cerror "Continue with switched start and end ~S <-> ~S" - "Write-string: start (~S) and end (~S) exchanged." - start end string) - (rotatef start end)) + &key (start 0) (end nil)) + (%write-string string stream start (or end (length string))) + string) - (write-string* string stream start end)) +(defun %write-string (string stream start end) + (declare (type string string)) + (declare (type streamlike stream)) + (declare (type index start end)) + + ;; Note that even though you might expect, based on the behavior of + ;; things like AREF, that the correct upper bound here is + ;; (ARRAY-DIMENSION STRING 0), the ANSI glossary definitions for + ;; "bounding index" and "length" indicate that in this case (i.e. + ;; for the ANSI-specified functions WRITE-STRING and WRITE-LINE + ;; which are implemented in terms of this function), (LENGTH STRING) + ;; is the required upper bound. A foolish consistency is the + ;; hobgoblin of lesser languages.. + (unless (<= 0 start end (length string)) + (error "~@" + start + end + string)) -(defun write-string* (string &optional (stream *standard-output*) - (start 0) (end (length (the vector string)))) - (declare (fixnum start end)) (let ((stream (out-synonym-of stream))) (cond ((lisp-stream-p stream) (if (array-header-p string) @@ -606,25 +602,12 @@ (stream-write-string stream string start end))))) (defun write-line (string &optional (stream *standard-output*) - &key (start 0) (end (length string))) - (write-line* string stream start end)) - -(defun write-line* (string &optional (stream *standard-output*) - (start 0) (end (length string))) - (declare (fixnum start end)) - (let ((stream (out-synonym-of stream))) - (cond ((lisp-stream-p stream) - (if (array-header-p string) - (with-array-data ((data string) (offset-start start) - (offset-end end)) - (with-out-stream stream (lisp-stream-sout data offset-start - offset-end))) - (with-out-stream stream (lisp-stream-sout string start end))) - (funcall (lisp-stream-out stream) stream #\newline)) - (t ; must be Gray streams FUNDAMENTAL-STREAM - (stream-write-string stream string start end) - (stream-write-char stream #\Newline))) - string)) + &key (start 0) (end nil)) + (let ((defaulted-stream (out-synonym-of stream)) + (defaulted-end (or end (length string)))) + (%write-string string defaulted-stream start defaulted-end) + (write-char #\newline defaulted-stream)) + string) (defun charpos (&optional (stream *standard-output*)) (with-out-stream stream (lisp-stream-misc :charpos) (stream-line-column))) @@ -1265,8 +1248,10 @@ ;;; Dump the characters buffer up in IN-STREAM to OUT-STREAM as ;;; GET-OUTPUT-STREAM-STRING would return them. (defun dump-output-stream-string (in-stream out-stream) - (write-string* (string-output-stream-string in-stream) out-stream - 0 (string-output-stream-index in-stream)) + (%write-string (string-output-stream-string in-stream) + out-stream + 0 + (string-output-stream-index in-stream)) (setf (string-output-stream-index in-stream) 0)) ;;;; fill-pointer streams @@ -1380,9 +1365,11 @@ `(do ((i 0 (+ i 60)) (indentation (indenting-stream-indentation ,stream))) ((>= i indentation)) - (write-string* + (%write-string " " - ,sub-stream 0 (min 60 (- indentation i))))) + ,sub-stream + 0 + (min 60 (- indentation i))))) ;;; INDENTING-OUT writes a character to an indenting stream. (defun indenting-out (stream char) @@ -1399,11 +1386,11 @@ ((= i end)) (let ((newline (position #\newline string :start i :end end))) (cond (newline - (write-string* string sub-stream i (1+ newline)) + (%write-string string sub-stream i (1+ newline)) (indenting-indent stream sub-stream) (setq i (+ newline 1))) (t - (write-string* string sub-stream i end) + (%write-string string sub-stream i end) (setq i end)))))) ;;; INDENTING-MISC just treats just the :LINE-LENGTH message @@ -1786,7 +1773,7 @@ (type index i)) (funcall write-function (first rem) stream)))) (string - (write-string* seq stream start end)) + (%write-string seq stream start end)) (vector (let ((write-function (if (subtypep (stream-element-type stream) 'character) diff --git a/version.lisp-expr b/version.lisp-expr index 41f0e52..dba0ec6 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -18,4 +18,4 @@ ;;; for internal versions, especially for internal versions off the ;;; main CVS branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.pre7.31" +"0.pre7.32" -- 1.7.10.4