X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fstream.lisp;h=ac44a9053cd6df6b538f738d83ce6b5294d791d5;hb=24407d11d34abdaaef6d839fd0b2665c73b0e6d5;hp=e93c89cf537afaa44453588f71968e8e7d8b584a;hpb=c713eb2b521b048ff2c927ec52b861787d289f85;p=sbcl.git diff --git a/src/code/stream.lisp b/src/code/stream.lisp index e93c89c..ac44a90 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 @@ -255,6 +251,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 +318,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))) @@ -607,16 +628,12 @@ (bout #'broadcast-bout) (sout #'broadcast-sout) (misc #'broadcast-misc)) - (:constructor #!-high-security-support - make-broadcast-stream - #!+high-security-support - %make-broadcast-stream (&rest - streams)) + (:constructor %make-broadcast-stream + (&rest streams)) (:copier nil)) ;; a list of all the streams we broadcast to (streams () :type list :read-only t)) -#!+high-security-support (defun make-broadcast-stream (&rest streams) (dolist (stream streams) (unless (or (and (synonym-stream-p stream) @@ -736,24 +753,16 @@ (bout #'two-way-bout) (sout #'two-way-sout) (misc #'two-way-misc)) - (:constructor #!-high-security-support - make-two-way-stream - #!+high-security-support - %make-two-way-stream (input-stream output-stream)) + (:constructor %make-two-way-stream (input-stream output-stream)) (:copier nil)) (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 -(setf (fdocumentation 'make-two-way-stream 'function) - "Return a bidirectional stream which gets its input from Input-Stream and - sends its output to Output-Stream.") -#!+high-security-support (defun make-two-way-stream (input-stream output-stream) #!+sb-doc - "Return a bidirectional stream which gets its input from Input-Stream and - sends its output to Output-Stream." + "Return a bidirectional stream which gets its input from INPUT-STREAM and + sends its output to OUTPUT-STREAM." ;; FIXME: This idiom of the-real-stream-of-a-possibly-synonym-stream ;; should be encapsulated in a function, and used here and most of ;; the other places that SYNONYM-STREAM-P appears. @@ -832,10 +841,8 @@ (bin #'concatenated-bin) (n-bin #'concatenated-n-bin) (misc #'concatenated-misc)) - (:constructor - #!-high-security-support make-concatenated-stream - #!+high-security-support %make-concatenated-stream - (&rest streams &aux (current streams))) + (:constructor %make-concatenated-stream + (&rest streams &aux (current streams))) (:copier nil)) ;; The car of this is the substream we are reading from now. current @@ -854,15 +861,9 @@ ":STREAMS ~S" (concatenated-stream-streams x)))) -#!-high-security-support -(setf (fdocumentation 'make-concatenated-stream 'function) - "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 - "Return 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) @@ -945,7 +946,7 @@ (bin #'echo-bin) (misc #'echo-misc) (n-bin #'ill-bin)) - (:constructor make-echo-stream (input-stream output-stream)) + (:constructor %make-echo-stream (input-stream output-stream)) (:copier nil)) unread-stuff) (def!method print-object ((x echo-stream) stream) @@ -955,6 +956,27 @@ (two-way-stream-input-stream x) (two-way-stream-output-stream x)))) +(defun make-echo-stream (input-stream output-stream) + #!+sb-doc + "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." + (unless (or (and (synonym-stream-p output-stream) + (output-stream-p (symbol-value + (synonym-stream-symbol output-stream)))) + (output-stream-p output-stream)) + (error 'type-error + :datum output-stream + :expected-type '(satisfies output-stream-p))) + (unless (or (and (synonym-stream-p input-stream) + (input-stream-p (symbol-value + (synonym-stream-symbol input-stream)))) + (input-stream-p input-stream)) + (error 'type-error + :datum input-stream + :expected-type '(satisfies input-stream-p))) + (funcall #'%make-echo-stream input-stream output-stream)) + (macrolet ((in-fun (name fun out-slot stream-method &rest args) `(defun ,name (stream ,@args) (or (pop (echo-stream-unread-stuff stream)) @@ -989,6 +1011,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) @@ -996,25 +1053,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 -#!+sb-doc -(setf (fdocumentation 'make-echo-stream 'function) - "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") +(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)) @@ -1095,17 +1154,17 @@ (internal-make-string-input-stream (coerce string 'simple-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)) @@ -1189,15 +1248,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)) @@ -1359,7 +1425,7 @@ (defstruct (case-frob-stream (:include ansi-stream - (:misc #'case-frob-misc)) + (misc #'case-frob-misc)) (:constructor %make-case-frob-stream (target out sout)) (:copier nil)) (target (missing-arg) :type stream))