X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fstream.lisp;h=3652f875e190c3156b94e1d10d4e50c0a67513b8;hb=4eb1a6d3ad2b7dcc19ac0ec979a1eb1eb049659a;hp=696e65ee47fe572787e656654de20e648f9e068f;hpb=6fa0ad323b5031017e62ee5d7e016eae2cf79efd;p=sbcl.git diff --git a/src/code/stream.lisp b/src/code/stream.lisp index 696e65e..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) @@ -320,7 +316,7 @@ (let ((index (1- (lisp-stream-in-index stream))) (buffer (lisp-stream-in-buffer stream))) (declare (fixnum index)) - (when (minusp index) (error "Nothing to unread.")) + (when (minusp index) (error "nothing to unread")) (cond (buffer (setf (aref buffer index) (char-code character)) (setf (lisp-stream-in-index stream) index)) @@ -334,8 +330,20 @@ (defun peek-char (&optional (peek-type nil) (stream *standard-input*) (eof-error-p t) - eof-value recursive-p) + eof-value + recursive-p) (declare (ignore recursive-p)) + ;; FIXME: The type of PEEK-TYPE is also declared in a DEFKNOWN, but + ;; the compiler doesn't seem to be smart enough to go from there to + ;; imposing a type check. Figure out why (because PEEK-TYPE is an + ;; &OPTIONAL argument?) and fix it, and then this explicit type + ;; check can go away. + (unless (typep peek-type '(or character boolean)) + (error 'simple-type-error + :datum peek-type + :expected-type '(or character boolean) + :format-control "~@" + :format-arguments (list peek-type '(or character boolean)))) (let ((stream (in-synonym-of stream))) (if (lisp-stream-p stream) (let ((char (read-char stream eof-error-p eof-value))) @@ -352,12 +360,15 @@ (unless (eq char eof-value) (unread-char char stream)) char))) - (t + ((null peek-type) (unread-char char stream) - char))) - ;; must be Gray streams FUNDAMENTAL-STREAM + char) + (t + (error "internal error: impossible case")))) + ;; by elimination, must be Gray streams FUNDAMENTAL-STREAM (cond ((characterp peek-type) - (do ((char (stream-read-char stream) (stream-read-char stream))) + (do ((char (stream-read-char stream) + (stream-read-char stream))) ((or (eq char :eof) (char= char peek-type)) (cond ((eq char :eof) (eof-or-lose stream eof-error-p eof-value)) @@ -365,18 +376,21 @@ (stream-unread-char stream char) char))))) ((eq peek-type t) - (do ((char (stream-read-char stream) (stream-read-char stream))) + (do ((char (stream-read-char stream) + (stream-read-char stream))) ((or (eq char :eof) (not (whitespace-char-p char))) (cond ((eq char :eof) (eof-or-lose stream eof-error-p eof-value)) (t (stream-unread-char stream char) char))))) - (t + ((null peek-type) (let ((char (stream-peek-char stream))) (if (eq char :eof) (eof-or-lose stream eof-error-p eof-value) - char))))))) + char))) + (t + (error "internal error: impossible case")))))) (defun listen (&optional (stream *standard-input*)) (let ((stream (in-synonym-of stream))) @@ -455,17 +469,13 @@ numbytes eof-error-p)) ((<= numbytes num-buffered) - (%primitive sb!c:byte-blt - in-buffer - index - buffer - start - (+ start numbytes)) + (%byte-blt in-buffer index + buffer start (+ start numbytes)) (setf (lisp-stream-in-index stream) (+ index numbytes)) numbytes) (t (let ((end (+ start num-buffered))) - (%primitive sb!c:byte-blt in-buffer index buffer start end) + (%byte-blt in-buffer index buffer start end) (setf (lisp-stream-in-index stream) +in-buffer-length+) (+ (funcall (lisp-stream-n-bin stream) stream @@ -499,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)))))) @@ -523,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))))) @@ -552,33 +562,29 @@ (stream-fresh-line stream)))) (defun write-string (string &optional (stream *standard-output*) - &key (start 0) (end (length (the vector 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) @@ -592,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))) @@ -816,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 @@ -930,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) @@ -1073,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 @@ -1127,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))) @@ -1154,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)) @@ -1185,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)) @@ -1251,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 @@ -1281,15 +1276,11 @@ (let ((offset-current (+ start current))) (declare (fixnum offset-current)) (if (= offset-current end) - (let* ((new-length (* current 2)) + (let* ((new-length (1+ (* current 2))) (new-workspace (make-string new-length))) (declare (simple-string new-workspace)) - (%primitive sb!c:byte-blt - workspace - start - new-workspace - 0 - current) + (%byte-blt workspace start + new-workspace 0 current) (setf workspace new-workspace) (setf offset-current current) (set-array-header buffer workspace new-length @@ -1314,12 +1305,8 @@ (let* ((new-length (+ (the fixnum (* current 2)) string-len)) (new-workspace (make-string new-length))) (declare (simple-string new-workspace)) - (%primitive sb!c:byte-blt - workspace - dst-start - new-workspace - 0 - current) + (%byte-blt workspace dst-start + new-workspace 0 current) (setf workspace new-workspace) (setf offset-current current) (setf offset-dst-end dst-end) @@ -1331,12 +1318,8 @@ new-length nil)) (setf (fill-pointer buffer) dst-end)) - (%primitive sb!c:byte-blt - string - start - workspace - offset-current - offset-dst-end))) + (%byte-blt string start + workspace offset-current offset-dst-end))) dst-end)) (defun fill-pointer-misc (stream operation &optional arg1 arg2) @@ -1369,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. @@ -1378,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) @@ -1397,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 @@ -1444,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. @@ -1784,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)