X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fstream.lisp;h=f436ab05d9787796cc625bb20afce2e2eee43ff5;hb=a22dd643fb599880f4c0856e1a85bffe4358aea8;hp=e5296c8868fa0dc2503c7f8d1580a491b9e59840;hpb=0bc2d6ca22c988d65e37108afbb433e29689a528;p=sbcl.git diff --git a/src/code/stream.lisp b/src/code/stream.lisp index e5296c8..f436ab0 100644 --- a/src/code/stream.lisp +++ b/src/code/stream.lisp @@ -63,7 +63,6 @@ (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)))) @@ -85,7 +84,6 @@ (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)))) @@ -103,6 +101,7 @@ (declaim (inline ansi-stream-open-stream-p)) (defun ansi-stream-open-stream-p (stream) (declare (type ansi-stream stream)) + ;; CLHS 22.1.4 lets us not worry about synonym streams here. (not (eq (ansi-stream-in stream) #'closed-flame))) (defun open-stream-p (stream) @@ -277,85 +276,6 @@ (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) - eof-value - recursive-p) - (declare (ignore recursive-p)) - (let ((stream (in-synonym-of stream))) - (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))) (if (ansi-stream-p stream) @@ -660,10 +580,7 @@ (defun make-broadcast-stream (&rest streams) (dolist (stream streams) - (unless (or (and (synonym-stream-p stream) - (output-stream-p (symbol-value - (synonym-stream-symbol stream)))) - (output-stream-p stream)) + (unless (output-stream-p stream) (error 'type-error :datum stream :expected-type '(satisfies output-stream-p)))) @@ -680,8 +597,20 @@ (defun broadcast-misc (stream operation &optional arg1 arg2) (let ((streams (broadcast-stream-streams stream))) (case operation + ;; FIXME: This may not be the best place to note this, but I + ;; think the :CHARPOS protocol needs revision. Firstly, I think + ;; this is the last place where a NULL return value was possible + ;; (before adjusting it to be 0), so a bunch of conditionals IF + ;; CHARPOS can be removed; secondly, it is my belief that + ;; FD-STREAMS, when running FILE-POSITION, do not update the + ;; CHARPOS, and consequently there will be much wrongness. + ;; + ;; FIXME: see also TWO-WAY-STREAM treatment of :CHARPOS -- why + ;; is it testing the :charpos of an input stream? + ;; + ;; -- CSR, 2004-02-04 (:charpos - (dolist (stream streams) + (dolist (stream streams 0) (let ((charpos (charpos stream))) (if charpos (return charpos))))) (:line-length @@ -690,10 +619,18 @@ (let ((res (line-length stream))) (when res (setq min (if min (min res min) res))))))) (:element-type + #+nil ; old, arguably more logical, version (let (res) - (dolist (stream streams (if (> (length res) 1) `(and ,@res) res)) - (pushnew (stream-element-type stream) res :test #'equal)))) - (:close) + (dolist (stream streams (if (> (length res) 1) `(and ,@res) t)) + (pushnew (stream-element-type stream) res :test #'equal))) + ;; ANSI-specified version (under System Class BROADCAST-STREAM) + (let ((res t)) + (do ((streams streams (cdr streams))) + ((null streams) res) + (when (null (cdr streams)) + (setq res (stream-element-type (car streams))))))) + (:close + (set-closed-flame stream)) (t (let ((res nil)) (dolist (stream streams res) @@ -785,17 +722,11 @@ ;; 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. - (unless (or (and (synonym-stream-p output-stream) - (output-stream-p (symbol-value - (synonym-stream-symbol output-stream)))) - (output-stream-p output-stream)) + (unless (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)) + (unless (input-stream-p input-stream) (error 'type-error :datum input-stream :expected-type '(satisfies input-stream-p))) @@ -883,10 +814,7 @@ "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) - (input-stream-p (symbol-value - (synonym-stream-symbol stream)))) - (input-stream-p stream)) + (unless (input-stream-p stream) (error 'type-error :datum stream :expected-type '(satisfies input-stream-p)))) @@ -978,17 +906,11 @@ "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)) + (unless (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)) + (unless (input-stream-p input-stream) (error 'type-error :datum input-stream :expected-type '(satisfies input-stream-p))) @@ -1004,68 +926,6 @@ result))))) (in-fun echo-in read-char write-char eof-error-p eof-value) (in-fun echo-bin read-byte write-byte eof-error-p eof-value)) - -(defun echo-misc (stream operation &optional arg1 arg2) - (let* ((in (two-way-stream-input-stream stream)) - (out (two-way-stream-output-stream stream))) - (case operation - (:listen - (or (not (null (echo-stream-unread-stuff stream))) - (if (ansi-stream-p in) - (or (/= (the fixnum (ansi-stream-in-index in)) - +ansi-stream-in-buffer-length+) - (funcall (ansi-stream-misc in) in :listen)) - (stream-misc-dispatch in :listen)))) - (:unread (push arg1 (echo-stream-unread-stuff stream))) - (:element-type - (let ((in-type (stream-element-type in)) - (out-type (stream-element-type out))) - (if (equal in-type out-type) - 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) - (stream-misc-dispatch in operation arg1 arg2)) - (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 @@ -1224,7 +1084,9 @@ (defun string-sout (stream string start end) (declare (type simple-string string) (type fixnum start end)) - (let* ((string (coerce string '(simple-array character (*)))) + (let* ((string (if (typep string '(simple-array character (*))) + string + (coerce string '(simple-array character (*))))) (current (string-output-stream-index stream)) (length (- end start)) (dst-end (+ length current)) @@ -1560,7 +1422,8 @@ (defun case-frob-misc (stream op &optional arg1 arg2) (declare (type case-frob-stream stream)) (case op - (:close) + (:close + (set-closed-flame stream)) (t (let ((target (case-frob-stream-target stream))) (if (ansi-stream-p target)