X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fstream.lisp;h=3e2c5ca1d953190a2b775e311b0589e82458f209;hb=05525d3a5906d7a89fcb689c26177732493c40ce;hp=5676b14fda6a0d7c5d6b5bc38b975004dcb36459;hpb=ebbaa0e11a4d5c9bf021d28f212cfb6d5cd4aaab;p=sbcl.git diff --git a/src/code/stream.lisp b/src/code/stream.lisp index 5676b14..3e2c5ca 100644 --- a/src/code/stream.lisp +++ b/src/code/stream.lisp @@ -11,10 +11,6 @@ (in-package "SB!IMPL") -(deftype string-stream () - '(or string-input-stream string-output-stream - fill-pointer-output-stream)) - ;;;; standard streams ;;; The initialization of these streams is performed by @@ -63,16 +59,16 @@ ;;; stream manipulation functions -(defun input-stream-p (stream) - (declare (type stream stream)) +(declaim (inline ansi-stream-input-stream-p)) +(defun ansi-stream-input-stream-p (stream) + (declare (type ansi-stream stream)) #!+high-security (when (synonym-stream-p stream) (setf stream (symbol-value (synonym-stream-symbol stream)))) - (and (ansi-stream-p stream) - (not (eq (ansi-stream-in stream) #'closed-flame)) + (and (not (eq (ansi-stream-in stream) #'closed-flame)) ;;; KLUDGE: It's probably not good to have EQ tests on function ;;; values like this. What if someone's redefined the function? ;;; Is there a better way? (Perhaps just VALID-FOR-INPUT and @@ -80,37 +76,60 @@ (or (not (eq (ansi-stream-in stream) #'ill-in)) (not (eq (ansi-stream-bin stream) #'ill-bin))))) -(defun output-stream-p (stream) +(defun input-stream-p (stream) (declare (type stream stream)) + (and (ansi-stream-p stream) + (ansi-stream-input-stream-p stream))) + +(declaim (inline ansi-stream-output-stream-p)) +(defun ansi-stream-output-stream-p (stream) + (declare (type ansi-stream stream)) #!+high-security (when (synonym-stream-p stream) (setf stream (symbol-value (synonym-stream-symbol stream)))) - (and (ansi-stream-p stream) - (not (eq (ansi-stream-in stream) #'closed-flame)) + (and (not (eq (ansi-stream-in stream) #'closed-flame)) (or (not (eq (ansi-stream-out stream) #'ill-out)) (not (eq (ansi-stream-bout stream) #'ill-bout))))) -(defun open-stream-p (stream) +(defun output-stream-p (stream) (declare (type stream stream)) + + (and (ansi-stream-p stream) + (ansi-stream-output-stream-p stream))) + +(declaim (inline ansi-stream-open-stream-p)) +(defun ansi-stream-open-stream-p (stream) + (declare (type ansi-stream stream)) (not (eq (ansi-stream-in stream) #'closed-flame))) -(defun stream-element-type (stream) - (declare (type stream stream)) +(defun open-stream-p (stream) + (ansi-stream-open-stream-p stream)) + +(declaim (inline ansi-stream-element-type)) +(defun ansi-stream-element-type (stream) + (declare (type ansi-stream stream)) (funcall (ansi-stream-misc stream) stream :element-type)) +(defun stream-element-type (stream) + (ansi-stream-element-type stream)) + (defun interactive-stream-p (stream) (declare (type stream stream)) (funcall (ansi-stream-misc stream) stream :interactive-p)) -(defun close (stream &key abort) - (declare (type stream stream)) +(declaim (inline ansi-stream-close)) +(defun ansi-stream-close (stream abort) + (declare (type ansi-stream stream)) (when (open-stream-p stream) (funcall (ansi-stream-misc stream) stream :close abort)) t) +(defun close (stream &key abort) + (ansi-stream-close stream abort)) + (defun set-closed-flame (stream) (setf (ansi-stream-in stream) #'closed-flame) (setf (ansi-stream-bin stream) #'closed-flame) @@ -172,7 +191,10 @@ ;;; like FILE-POSITION, only using :FILE-LENGTH (defun file-length (stream) - (declare (type (or file-stream synonym-stream) stream)) + ;; FIXME: The following declaration uses yet undefined types, which + ;; cause cross-compiler hangup. + ;; + ;; (declare (type (or file-stream synonym-stream) stream)) (stream-must-be-associated-with-file stream) (funcall (ansi-stream-misc stream) stream :file-length)) @@ -255,6 +277,55 @@ (stream-unread-char stream character))) nil) + +;;; In the interest of ``once and only once'' this macro contains the +;;; framework necessary to implement a peek-char function, which has +;;; two special-cases (one for gray streams and one for echo streams) +;;; in addition to the normal case. +;;; +;;; All arguments are forms which will be used for a specific purpose +;;; PEEK-TYPE - the current peek-type as defined by ANSI CL +;;; EOF-VALUE - the eof-value argument to peek-char +;;; CHAR-VAR - the variable which will be used to store the current character +;;; READ-FORM - the form which will be used to read a character +;;; UNREAD-FORM - ditto for unread-char +;;; SKIPPED-CHAR-FORM - the form to execute when skipping a character +;;; EOF-DETECTED-FORM - the form to execute when EOF has been detected +;;; (this will default to CHAR-VAR) +(defmacro generalized-peeking-mechanism (peek-type eof-value char-var read-form unread-form &optional (skipped-char-form nil) (eof-detected-form nil)) + `(let ((,char-var ,read-form)) + (cond ((eql ,char-var ,eof-value) + ,(if eof-detected-form + eof-detected-form + char-var)) + ((characterp ,peek-type) + (do ((,char-var ,char-var ,read-form)) + ((or (eql ,char-var ,eof-value) + (char= ,char-var ,peek-type)) + (cond ((eql ,char-var ,eof-value) + ,(if eof-detected-form + eof-detected-form + char-var)) + (t ,unread-form + ,char-var))) + ,skipped-char-form)) + ((eql ,peek-type t) + (do ((,char-var ,char-var ,read-form)) + ((or (eql ,char-var ,eof-value) + (not (whitespace-char-p ,char-var))) + (cond ((eql ,char-var ,eof-value) + ,(if eof-detected-form + eof-detected-form + char-var)) + (t ,unread-form + ,char-var))) + ,skipped-char-form)) + ((null ,peek-type) + ,unread-form + ,char-var) + (t + (bug "Impossible case reached in PEEK-CHAR"))))) + (defun peek-char (&optional (peek-type nil) (stream *standard-input*) (eof-error-p t) @@ -273,52 +344,28 @@ :format-control "~@" :format-arguments (list peek-type '(or character boolean)))) (let ((stream (in-synonym-of stream))) - (if (ansi-stream-p stream) - (let ((char (read-char stream eof-error-p eof-value))) - (cond ((eq char eof-value) char) - ((characterp peek-type) - (do ((char char (read-char stream eof-error-p eof-value))) - ((or (eq char eof-value) (char= char peek-type)) - (unless (eq char eof-value) - (unread-char char stream)) - char))) - ((eq peek-type t) - (do ((char char (read-char stream eof-error-p eof-value))) - ((or (eq char eof-value) (not (whitespace-char-p char))) - (unless (eq char eof-value) - (unread-char char stream)) - char))) - ((null peek-type) - (unread-char char stream) - char) - (t - (bug "impossible case")))) - ;; by elimination, must be Gray streams FUNDAMENTAL-STREAM - (cond ((characterp peek-type) - (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)) - (t - (stream-unread-char stream char) - char))))) - ((eq peek-type t) - (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))))) - ((null peek-type) - (let ((char (stream-peek-char stream))) - (if (eq char :eof) - (eof-or-lose stream eof-error-p eof-value) - char))) - (t - (bug "impossible case")))))) + (cond ((typep stream 'echo-stream) + (echo-misc stream + :peek-char + peek-type + (list eof-error-p eof-value))) + ((ansi-stream-p stream) + (generalized-peeking-mechanism + peek-type eof-value char + (read-char stream eof-error-p eof-value) + (unread-char char stream))) + (t + ;; by elimination, must be Gray streams FUNDAMENTAL-STREAM + (generalized-peeking-mechanism + peek-type :eof char + (if (null peek-type) + (stream-peek-char stream) + (stream-read-char stream)) + (if (null peek-type) + () + (stream-unread-char stream char)) + () + (eof-or-lose stream eof-error-p eof-value)))))) (defun listen (&optional (stream *standard-input*)) (let ((stream (in-synonym-of stream))) @@ -494,29 +541,23 @@ (stream-fresh-line stream)))) (defun write-string (string &optional (stream *standard-output*) - &key (start 0) (end nil)) - (%write-string string stream start (or end (length string))) - string) - -(defun %write-string (string stream start end) + &key (start 0) 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)) + ;; for the ANSI-specified functions WRITE-STRING [and WRITE-LINE]), + ;; (LENGTH STRING) is the required upper bound. A foolish + ;; consistency is the hobgoblin of lesser languages.. + (%write-string string stream start (%check-vector-sequence-bounds + string start end)) + string) +(defun %write-string (string stream start end) + (declare (type string string)) + (declare (type streamlike stream)) + (declare (type index start end)) (let ((stream (out-synonym-of stream))) (cond ((ansi-stream-p stream) (if (array-header-p string) @@ -530,10 +571,13 @@ (stream-write-string stream string start end))))) (defun write-line (string &optional (stream *standard-output*) - &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) + &key (start 0) end) + (declare (type string string)) + ;; FIXME: Why is there this difference between the treatments of the + ;; STREAM argument in WRITE-STRING and WRITE-LINE? + (let ((defaulted-stream (out-synonym-of stream))) + (%write-string string defaulted-stream start (%check-vector-sequence-bounds + string start end)) (write-char #\newline defaulted-stream)) string) @@ -863,7 +907,7 @@ (let* ((stream (car current)) (result (,fun stream nil nil))) (when result (return result))) - (setf (concatenated-stream-current stream) current))))) + (pop (concatenated-stream-current stream)))))) (in-fun concatenated-in read-char) (in-fun concatenated-bin read-byte)) @@ -990,6 +1034,41 @@ in-type `(and ,in-type ,out-type)))) (:close (set-closed-flame stream)) + (:peek-char + ;; For the special case of peeking into an echo-stream + ;; arg1 is PEEK-TYPE, arg2 is (EOF-ERROR-P EOF-VALUE) + ;; returns peeked-char, eof-value, or errors end-of-file + ;; + ;; Note: This code could be moved into PEEK-CHAR if desired. + ;; I am unsure whether this belongs with echo-streams because it is + ;; echo-stream specific, or PEEK-CHAR because it is peeking code. + ;; -- mrd 2002-11-18 + ;; + ;; UNREAD-CHAR-P indicates whether the current character was one + ;; that was previously unread. In that case, we need to ensure that + ;; the semantics for UNREAD-CHAR are held; the character should + ;; not be echoed again. + (let ((unread-char-p nil)) + (flet ((outfn (c) + (unless unread-char-p + (if (ansi-stream-p out) + (funcall (ansi-stream-out out) out c) + ;; gray-stream + (stream-write-char out c)))) + (infn () + ;; Obtain input from unread buffer or input stream, + ;; and set the flag appropriately. + (cond ((not (null (echo-stream-unread-stuff stream))) + (setf unread-char-p t) + (pop (echo-stream-unread-stuff stream))) + (t + (setf unread-char-p nil) + (read-char in (first arg2) (second arg2)))))) + (generalized-peeking-mechanism + arg1 (second arg2) char + (infn) + (unread-char char in) + (outfn char))))) (t (or (if (ansi-stream-p in) (funcall (ansi-stream-misc in) in operation arg1 arg2) @@ -997,20 +1076,27 @@ (if (ansi-stream-p out) (funcall (ansi-stream-misc out) out operation arg1 arg2) (stream-misc-dispatch out operation arg1 arg2))))))) + +;;;; base STRING-STREAM stuff +(defstruct (string-stream + (:include ansi-stream) + (:constructor nil) + (:copier nil)) + (string nil :type string)) -;;;; string input streams +;;;; STRING-INPUT-STREAM stuff (defstruct (string-input-stream - (:include ansi-stream + (:include string-stream (in #'string-inch) (bin #'string-binch) (n-bin #'string-stream-read-n-bytes) - (misc #'string-in-misc)) + (misc #'string-in-misc) + (string nil :type simple-string)) (:constructor internal-make-string-input-stream (string current end)) (:copier nil)) - (string nil :type simple-string) (current nil :type index) (end nil :type index)) @@ -1074,34 +1160,30 @@ (:element-type 'base-char))) (defun make-string-input-stream (string &optional - (start 0) (end (length string))) + (start 0) end) #!+sb-doc "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)) - - #!+high-security - (when (> end (length string)) - (cerror "Continue with end changed from ~S to ~S" - "Write-string: end (~S) is larger then the length of the string (~S)" - end (1- (length string)))) - - (internal-make-string-input-stream (coerce string 'simple-string) - start end)) + + (internal-make-string-input-stream + (coerce string 'simple-string) + start + (%check-vector-sequence-bounds string start end))) -;;;; string output streams +;;;; STRING-OUTPUT-STREAM stuff (defstruct (string-output-stream - (:include ansi-stream + (:include string-stream (out #'string-ouch) (sout #'string-sout) - (misc #'string-out-misc)) + (misc #'string-out-misc) + ;; The string we throw stuff in. + (string (make-string 40) :type simple-string)) (:constructor make-string-output-stream ()) (:copier nil)) - ;; The string we throw stuff in. - (string (make-string 40) :type simple-string) ;; Index of the next location to use. (index 0 :type fixnum)) @@ -1185,15 +1267,22 @@ ;;; the CLM, but they are required for the implementation of ;;; WITH-OUTPUT-TO-STRING. +(deftype string-with-fill-pointer () + '(and string + (satisfies array-has-fill-pointer-p))) + (defstruct (fill-pointer-output-stream - (:include ansi-stream + (:include string-stream (out #'fill-pointer-ouch) (sout #'fill-pointer-sout) - (misc #'fill-pointer-misc)) + (misc #'fill-pointer-misc) + ;; a string with a fill pointer where we stuff + ;; the stuff we write + (string (error "missing argument") + :type string-with-fill-pointer + :read-only t)) (:constructor make-fill-pointer-output-stream (string)) - (:copier nil)) - ;; the string we throw stuff in - string) + (:copier nil))) (defun fill-pointer-ouch (stream character) (let* ((buffer (fill-pointer-output-stream-string stream)) @@ -1586,40 +1675,9 @@ (funcall (ansi-stream-sout target) target str 0 len) (stream-write-string target str 0 len)))) -;;;; stream commands - -(defstruct (stream-command (:constructor make-stream-command - (name &optional args)) - (:copier nil)) - (name nil :type symbol) - (args nil :type list)) -(def!method print-object ((obj stream-command) str) - (print-unreadable-object (obj str :type t :identity t) - (prin1 (stream-command-name obj) str))) - -;;; Take a stream and wait for text or a command to appear on it. If -;;; text appears before a command, return NIL, otherwise return a -;;; command. -;;; -;;; We can't simply call the stream's misc method because NIL is an -;;; ambiguous return value: does it mean text arrived, or does it mean -;;; the stream's misc method had no :GET-COMMAND implementation? We -;;; can't return NIL until there is text input. We don't need to loop -;;; because any stream implementing :GET-COMMAND would wait until it -;;; had some input. If the LISTEN fails, then we have some stream we -;;; must wait on. -(defun get-stream-command (stream) - (let ((cmdp (funcall (ansi-stream-misc stream) stream :get-command))) - (cond (cmdp) - ((listen stream) - nil) - (t - ;; This waits for input and returns NIL when it arrives. - (unread-char (read-char stream) stream))))) - ;;;; READ-SEQUENCE -(defun read-sequence (seq stream &key (start 0) (end nil)) +(defun read-sequence (seq stream &key (start 0) end) #!+sb-doc "Destructively modify SEQ by reading elements from STREAM. That part of SEQ bounded by START and END is destructively modified by