X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fstream.lisp;h=3652f875e190c3156b94e1d10d4e50c0a67513b8;hb=4eb1a6d3ad2b7dcc19ac0ec979a1eb1eb049659a;hp=f1a3998c01aed3c1a9e10a8158ecd0afe4203f2c;hpb=bee53328c93be3433477821131ab805557476c8b;p=sbcl.git diff --git a/src/code/stream.lisp b/src/code/stream.lisp index f1a3998..3652f87 100644 --- a/src/code/stream.lisp +++ b/src/code/stream.lisp @@ -19,13 +19,13 @@ ;;; The initialization of these streams is performed by ;;; STREAM-COLD-INIT-OR-RESET. -(defvar *terminal-io* () #!+sb-doc "Terminal I/O stream.") -(defvar *standard-input* () #!+sb-doc "Default input stream.") -(defvar *standard-output* () #!+sb-doc "Default output stream.") -(defvar *error-output* () #!+sb-doc "Error output stream.") -(defvar *query-io* () #!+sb-doc "Query I/O stream.") -(defvar *trace-output* () #!+sb-doc "Trace output stream.") -(defvar *debug-io* () #!+sb-doc "Interactive debugging stream.") +(defvar *terminal-io* () #!+sb-doc "terminal I/O stream") +(defvar *standard-input* () #!+sb-doc "default input stream") +(defvar *standard-output* () #!+sb-doc "default output stream") +(defvar *error-output* () #!+sb-doc "error output stream") +(defvar *query-io* () #!+sb-doc "query I/O stream") +(defvar *trace-output* () #!+sb-doc "trace output stream") +(defvar *debug-io* () #!+sb-doc "interactive debugging stream") (defun ill-in (stream &rest ignore) (declare (ignore ignore)) @@ -179,10 +179,6 @@ (declare (type stream stream)) (funcall (lisp-stream-misc stream) stream :interactive-p)) -(defun open-stream-p (stream) - (declare (type stream stream)) - (not (eq (lisp-stream-in stream) #'closed-flame))) - (defun close (stream &key abort) (declare (type stream stream)) (when (open-stream-p stream) @@ -513,13 +509,13 @@ (funcall (lisp-stream-in stream) stream eof-error-p eof-value)) (t (when (/= start +in-buffer-extra+) - (bit-bash-copy ibuf (+ (* +in-buffer-extra+ sb!vm:byte-bits) + (bit-bash-copy ibuf (+ (* +in-buffer-extra+ sb!vm:n-byte-bits) (* sb!vm:vector-data-offset - sb!vm:word-bits)) - ibuf (+ (the index (* start sb!vm:byte-bits)) + sb!vm:n-word-bits)) + ibuf (+ (the index (* start sb!vm:n-byte-bits)) (* sb!vm:vector-data-offset - sb!vm:word-bits)) - (* count sb!vm:byte-bits))) + sb!vm:n-word-bits)) + (* count sb!vm:n-byte-bits))) (setf (lisp-stream-in-index stream) (1+ start)) (code-char (aref ibuf start)))))) @@ -537,11 +533,11 @@ (funcall (lisp-stream-bin stream) stream eof-error-p eof-value)) (t (unless (zerop start) - (bit-bash-copy ibuf (* sb!vm:vector-data-offset sb!vm:word-bits) - ibuf (+ (the index (* start sb!vm:byte-bits)) + (bit-bash-copy ibuf (* sb!vm:vector-data-offset sb!vm:n-word-bits) + ibuf (+ (the index (* start sb!vm:n-byte-bits)) (* sb!vm:vector-data-offset - sb!vm:word-bits)) - (* count sb!vm:byte-bits))) + sb!vm:n-word-bits)) + (* count sb!vm:n-byte-bits))) (setf (lisp-stream-in-index stream) (1+ start)) (aref ibuf start))))) @@ -566,33 +562,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 +598,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))) @@ -830,8 +809,8 @@ #!+high-security-support %make-two-way-stream (input-stream output-stream)) (:copier nil)) - (input-stream (required-argument) :type stream :read-only t) - (output-stream (required-argument) :type stream :read-only t)) + (input-stream (missing-arg) :type stream :read-only t) + (output-stream (missing-arg) :type stream :read-only t)) (defprinter (two-way-stream) input-stream output-stream) #!-high-security-support @@ -944,13 +923,13 @@ #!-high-security-support (setf (fdocumentation 'make-concatenated-stream 'function) - "Returns a stream which takes its input from each of the Streams in turn, + "Return a stream which takes its input from each of the Streams in turn, going on to the next at EOF.") #!+high-security-support (defun make-concatenated-stream (&rest streams) #!+sb-doc - "Returns a stream which takes its input from each of the Streams in turn, + "Return a stream which takes its input from each of the Streams in turn, going on to the next at EOF." (dolist (stream streams) (unless (or (and (synonym-stream-p stream) @@ -1087,8 +1066,8 @@ #!+sb-doc (setf (fdocumentation 'make-echo-stream 'function) - "Returns a bidirectional stream which gets its input from Input-Stream and - sends its output to Output-Stream. In addition, all input is echoed to + "Return a bidirectional stream which gets its input from INPUT-STREAM and + sends its output to OUTPUT-STREAM. In addition, all input is echoed to the output stream") ;;;; string input streams @@ -1141,12 +1120,12 @@ (truly-the index (+ index copy))) (sb!sys:without-gcing (system-area-copy (vector-sap string) - (* index sb!vm:byte-bits) + (* index sb!vm:n-byte-bits) (if (typep buffer 'system-area-pointer) buffer (vector-sap buffer)) - (* start sb!vm:byte-bits) - (* copy sb!vm:byte-bits)))) + (* start sb!vm:n-byte-bits) + (* copy sb!vm:n-byte-bits)))) (if (and (> requested copy) eof-error-p) (error 'end-of-file :stream stream) copy))) @@ -1168,8 +1147,8 @@ (defun make-string-input-stream (string &optional (start 0) (end (length string))) #!+sb-doc - "Returns an input stream which will supply the characters of String between - Start and End in order." + "Return an input stream which will supply the characters of STRING between + START and END in order." (declare (type string string) (type index start) (type (or index null) end)) @@ -1199,8 +1178,8 @@ #!+sb-doc (setf (fdocumentation 'make-string-output-stream 'function) - "Returns an Output stream which will accumulate all output given it for - the benefit of the function Get-Output-Stream-String.") + "Return an output stream which will accumulate all output given it for + the benefit of the function GET-OUTPUT-STREAM-STRING.") (defun string-ouch (stream character) (let ((current (string-output-stream-index stream)) @@ -1265,8 +1244,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 @@ -1371,7 +1352,7 @@ #!+sb-doc (setf (fdocumentation 'make-indenting-stream 'function) - "Returns an output stream which indents its output by some amount.") + "Return an output stream which indents its output by some amount.") ;;; INDENTING-INDENT writes the correct number of spaces needed to indent ;;; output on the given STREAM based on the specified SUB-STREAM. @@ -1380,9 +1361,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 +1382,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 @@ -1446,11 +1429,11 @@ (:misc #'case-frob-misc)) (:constructor %make-case-frob-stream (target out sout)) (:copier nil)) - (target (required-argument) :type stream)) + (target (missing-arg) :type stream)) (defun make-case-frob-stream (target kind) #!+sb-doc - "Returns a stream that sends all output to the stream TARGET, but modifies + "Return a stream that sends all output to the stream TARGET, but modifies the case of letters, depending on KIND, which should be one of: :upcase - convert to upper case. :downcase - convert to lower case. @@ -1786,7 +1769,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)