diff --git a/code/stream.lisp b/code/stream.lisp index 80d8ac6f1432a33afc026d4b19a62388cd7aa525..5d263ab30ffac3835992705417fc38c3943bde4b 100644 --- a/code/stream.lisp +++ b/code/stream.lisp @@ -5,12 +5,13 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/stream.lisp,v 1.32 1998/05/05 00:14:37 dtc Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/stream.lisp,v 1.33 1998/05/15 01:03:18 dtc Exp $") ;;; ;;; ********************************************************************** ;;; ;;; Stream functions for Spice Lisp. ;;; Written by Skef Wholey and Rob MacLachlan. +;;; Gray streams support by Douglas Crosher, 1998. ;;; ;;; This file contains the OS-independent stream functions. ;;; @@ -255,40 +256,39 @@ newline character." (declare (ignore recursive-p)) (let ((stream (in-synonym-of stream))) - (etypecase stream - (lisp-stream - (prepare-for-fast-read-char stream - (let ((res (make-string 80)) - (len 80) - (index 0)) - (loop - (let ((ch (fast-read-char nil nil))) - (cond (ch - (when (char= ch #\newline) - (done-with-fast-read-char) - (return (values (shrink-vector res index) nil))) - (when (= index len) - (setq len (* len 2)) - (let ((new (make-string len))) - (replace new res) - (setq res new))) - (setf (schar res index) ch) - (incf index)) - ((zerop index) - (done-with-fast-read-char) - (return (values (eof-or-lose stream eof-errorp eof-value) - t))) - ;; since fast-read-char hit already the eof char, we - ;; shouldn't do another read-char - (t - (done-with-fast-read-char) - (return (values (shrink-vector res index) t))))))))) - (fundamental-stream - (multiple-value-bind (string eof) - (stream-read-line stream) - (if (and eof (zerop (length string))) - (values (eof-or-lose stream eof-errorp eof-value) t) - (values string eof))))))) + (if (lisp-stream-p stream) + (prepare-for-fast-read-char stream + (let ((res (make-string 80)) + (len 80) + (index 0)) + (loop + (let ((ch (fast-read-char nil nil))) + (cond (ch + (when (char= ch #\newline) + (done-with-fast-read-char) + (return (values (shrink-vector res index) nil))) + (when (= index len) + (setq len (* len 2)) + (let ((new (make-string len))) + (replace new res) + (setq res new))) + (setf (schar res index) ch) + (incf index)) + ((zerop index) + (done-with-fast-read-char) + (return (values (eof-or-lose stream eof-errorp eof-value) + t))) + ;; since fast-read-char hit already the eof char, we + ;; shouldn't do another read-char + (t + (done-with-fast-read-char) + (return (values (shrink-vector res index) t)))))))) + ;; Fundamental-stream. + (multiple-value-bind (string eof) + (stream-read-line stream) + (if (and eof (zerop (length string))) + (values (eof-or-lose stream eof-errorp eof-value) t) + (values string eof)))))) ;;; We proclaim them inline here, then proclaim them notinline at EOF, ;;; so, except in this file, they are not inline by default, but they can be. @@ -299,35 +299,33 @@ "Inputs a character from Stream and returns it." (declare (ignore recursive-p)) (let ((stream (in-synonym-of stream))) - (etypecase stream - (lisp-stream - (prepare-for-fast-read-char stream - (prog1 - (fast-read-char eof-errorp eof-value) - (done-with-fast-read-char)))) - (fundamental-stream - (let ((char (stream-read-char stream))) - (if (eq char :eof) - (eof-or-lose stream eof-errorp eof-value) - char)))))) + (if (lisp-stream-p stream) + (prepare-for-fast-read-char stream + (prog1 + (fast-read-char eof-errorp eof-value) + (done-with-fast-read-char))) + ;; Fundamental-stream. + (let ((char (stream-read-char stream))) + (if (eq char :eof) + (eof-or-lose stream eof-errorp eof-value) + char))))) (defun unread-char (character &optional (stream *standard-input*)) "Puts the Character back on the front of the input Stream." (let ((stream (in-synonym-of stream))) - (etypecase stream - (lisp-stream - (let ((index (1- (lisp-stream-in-index stream))) - (buffer (lisp-stream-in-buffer stream))) - (declare (fixnum index)) - (when (minusp index) (error "Nothing to unread.")) - (cond (buffer - (setf (aref buffer index) (char-code character)) - (setf (lisp-stream-in-index stream) index)) - (t - (funcall (lisp-stream-misc stream) stream - :unread character))))) - (fundamental-stream - (stream-unread-char stream character)))) + (if (lisp-stream-p stream) + (let ((index (1- (lisp-stream-in-index stream))) + (buffer (lisp-stream-in-buffer stream))) + (declare (fixnum index)) + (when (minusp index) (error "Nothing to unread.")) + (cond (buffer + (setf (aref buffer index) (char-code character)) + (setf (lisp-stream-in-index stream) index)) + (t + (funcall (lisp-stream-misc stream) stream + :unread character)))) + ;; Fundamental-stream + (stream-unread-char stream character))) nil) (defun peek-char (&optional (peek-type nil) (stream *standard-input*) @@ -335,102 +333,97 @@ "Peeks at the next character in the input Stream. See manual for details." (declare (ignore recursive-p)) (let ((stream (in-synonym-of stream))) - (etypecase stream - (lisp-stream - (let ((char (read-char stream eof-errorp eof-value))) - (cond ((eq char eof-value) char) - ((characterp peek-type) - (do ((char char (read-char stream eof-errorp 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-errorp eof-value))) - ((or (eq char eof-value) (not (whitespace-char-p char))) - (unless (eq char eof-value) - (unread-char char stream)) - char))) - (t - (unread-char char stream) - char)))) - (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-errorp 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-errorp eof-value)) - (t - (stream-unread-char stream char) - char))))) - (t - (let ((char (stream-peek-char stream))) - (if (eq char :eof) - (eof-or-lose stream eof-errorp eof-value) - char)))))))) + (if (lisp-stream-p stream) + (let ((char (read-char stream eof-errorp eof-value))) + (cond ((eq char eof-value) char) + ((characterp peek-type) + (do ((char char (read-char stream eof-errorp 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-errorp eof-value))) + ((or (eq char eof-value) (not (whitespace-char-p char))) + (unless (eq char eof-value) + (unread-char char stream)) + char))) + (t + (unread-char char stream) + char))) + ;; 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-errorp 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-errorp eof-value)) + (t + (stream-unread-char stream char) + char))))) + (t + (let ((char (stream-peek-char stream))) + (if (eq char :eof) + (eof-or-lose stream eof-errorp eof-value) + char))))))) (defun listen (&optional (stream *standard-input*)) "Returns T if a character is availible on the given Stream." (let ((stream (in-synonym-of stream))) - (etypecase stream - (lisp-stream - (or (/= (the fixnum (lisp-stream-in-index stream)) in-buffer-length) - ;; Test for t explicitly since misc methods return :eof sometimes. - (eq (funcall (lisp-stream-misc stream) stream :listen) t))) - (fundamental-stream - (stream-listen stream))))) + (if (lisp-stream-p stream) + (or (/= (the fixnum (lisp-stream-in-index stream)) in-buffer-length) + ;; Test for t explicitly since misc methods return :eof sometimes. + (eq (funcall (lisp-stream-misc stream) stream :listen) t)) + ;; Fundamental-stream. + (stream-listen stream)))) (defun read-char-no-hang (&optional (stream *standard-input*) (eof-errorp t) eof-value recursive-p) "Returns the next character from the Stream if one is availible, or nil." (declare (ignore recursive-p)) (let ((stream (in-synonym-of stream))) - (etypecase stream - (lisp-stream - (if (funcall (lisp-stream-misc stream) stream :listen) - ;; On t or :eof get READ-CHAR to do the work. - (read-char stream eof-errorp eof-value) - nil)) - (fundamental-stream - (let ((char (stream-read-char-no-hang stream))) - (if (eq char :eof) - (eof-or-lose stream eof-errorp eof-value) - char)))))) + (if (lisp-stream-p stream) + (if (funcall (lisp-stream-misc stream) stream :listen) + ;; On t or :eof get READ-CHAR to do the work. + (read-char stream eof-errorp eof-value) + nil) + ;; Fundamental-stream. + (let ((char (stream-read-char-no-hang stream))) + (if (eq char :eof) + (eof-or-lose stream eof-errorp eof-value) + char))))) (defun clear-input (&optional (stream *standard-input*)) "Clears any buffered input associated with the Stream." (let ((stream (in-synonym-of stream))) - (etypecase stream - (lisp-stream - (setf (lisp-stream-in-index stream) in-buffer-length) - (funcall (lisp-stream-misc stream) stream :clear-input)) - (fundamental-stream - (stream-clear-input stream)))) + (cond ((lisp-stream-p stream) + (setf (lisp-stream-in-index stream) in-buffer-length) + (funcall (lisp-stream-misc stream) stream :clear-input)) + (t + (stream-clear-input stream)))) nil) (defun read-byte (stream &optional (eof-errorp t) eof-value) "Returns the next byte of the Stream." (let ((stream (in-synonym-of stream))) - (etypecase stream - (lisp-stream - (prepare-for-fast-read-byte stream - (prog1 - (fast-read-byte eof-errorp eof-value t) - (done-with-fast-read-byte)))) - (fundamental-stream - (let ((char (stream-read-byte stream))) - (if (eq char :eof) - (eof-or-lose stream eof-errorp eof-value) - char)))))) + (if (lisp-stream-p stream) + (prepare-for-fast-read-byte stream + (prog1 + (fast-read-byte eof-errorp eof-value t) + (done-with-fast-read-byte))) + ;; Fundamental-stream. + (let ((char (stream-read-byte stream))) + (if (eq char :eof) + (eof-or-lose stream eof-errorp eof-value) + char))))) (defun read-n-bytes (stream buffer start numbytes &optional (eof-errorp t)) "Reads Numbytes bytes into the Buffer starting at Start, returning the number @@ -541,13 +534,12 @@ "Outputs a new line to the Stream if it is not positioned at the begining of a line. Returns T if it output a new line, nil otherwise." (let ((stream (out-synonym-of stream))) - (etypecase stream - (lisp-stream - (when (/= (or (charpos stream) 1) 0) - (funcall (lisp-stream-out stream) stream #\newline) - t)) - (fundamental-stream - (stream-fresh-line stream))))) + (if (lisp-stream-p stream) + (when (/= (or (charpos stream) 1) 0) + (funcall (lisp-stream-out stream) stream #\newline) + t) + ;; Fundamental-stream. + (stream-fresh-line stream)))) (defun write-string (string &optional (stream *standard-output*) &key (start 0) (end (length (the vector string)))) @@ -558,17 +550,16 @@ (start 0) (end (length (the vector string)))) (declare (fixnum start end)) (let ((stream (out-synonym-of stream))) - (etypecase stream - (lisp-stream - (if (array-header-p string) - (with-array-data ((data string) (offset-start start) - (offset-end end)) - (funcall (lisp-stream-sout stream) - stream data offset-start offset-end)) - (funcall (lisp-stream-sout stream) stream string start end)) - string) - (fundamental-stream - (stream-write-string stream string start end))))) + (cond ((lisp-stream-p stream) + (if (array-header-p string) + (with-array-data ((data string) (offset-start start) + (offset-end end)) + (funcall (lisp-stream-sout stream) + stream data offset-start offset-end)) + (funcall (lisp-stream-sout stream) stream string start end)) + string) + (t ; Fundamental-stream. + (stream-write-string stream string start end))))) (defun write-line (string &optional (stream *standard-output*) &key (start 0) (end (length string))) @@ -579,18 +570,17 @@ (start 0) (end (length string))) (declare (fixnum start end)) (let ((stream (out-synonym-of stream))) - (etypecase stream - (lisp-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)) - (fundamental-stream - (stream-write-string stream string start end) - (stream-write-char stream #\Newline))) + (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 ; Fundamental-stream. + (stream-write-string stream string start end) + (stream-write-char stream #\Newline))) string)) (defun charpos (&optional (stream *standard-output*)) @@ -628,6 +618,47 @@ (with-out-stream stream (lisp-stream-bout integer) (stream-write-byte)) integer) + +;;; Stream-misc-dispatch +;;; +;;; Called from lisp-steam routines that encapsulate CLOS streams to +;;; handle the misc routines and dispatch to the appropriate Gray +;;; stream functions. +;;; +(defun stream-misc-dispatch (stream operation &optional arg1 arg2) + (declare (type fundamental-stream stream) + (ignore arg2)) + (case operation + (:listen + ;; Return true is input available, :eof for eof-of-file, otherwise Nil. + (let ((char (stream-read-char-no-hang stream))) + (when (characterp char) + (stream-unread-char stream char)) + char)) + (:unread + (stream-unread-char stream arg1)) + (:close + (close stream)) + (:clear-input + (stream-clear-input stream)) + (:force-output + (stream-force-output stream)) + (:finish-output + (stream-finish-output stream)) + (:element-type + (stream-element-type stream)) + (:interactive-p + (interactive-stream-p stream)) + (:line-length + (stream-line-length stream)) + (:charpos + (stream-line-column stream)) + (:file-length + (file-length stream)) + (:file-position + (file-position stream arg1)))) + + ;;;; Broadcast streams: (defstruct (broadcast-stream (:include lisp-stream @@ -647,37 +678,43 @@ (declare (ignore s d)) (write-string "#<Broadcast Stream>" stream)) -(macrolet ((out-fun (fun method &rest args) +(macrolet ((out-fun (fun method stream-method &rest args) `(defun ,fun (stream ,@args) (dolist (stream (broadcast-stream-streams stream)) - (funcall (,method stream) stream ,@args))))) - (out-fun broadcast-out lisp-stream-out char) - (out-fun broadcast-bout lisp-stream-bout byte) - (out-fun broadcast-sout lisp-stream-sout string start end)) + (if (lisp-stream-p stream) + (funcall (,method stream) stream ,@args) + (,stream-method stream ,@args)))))) + (out-fun broadcast-out lisp-stream-out stream-write-char char) + (out-fun broadcast-bout lisp-stream-bout stream-write-byte byte) + (out-fun broadcast-sout lisp-stream-sout stream-write-string + string start end)) (defun broadcast-misc (stream operation &optional arg1 arg2) (let ((streams (broadcast-stream-streams stream))) (case operation (:charpos (dolist (stream streams) - (let ((charpos (funcall (lisp-stream-misc stream) stream :charpos))) + (let ((charpos (charpos stream))) (if charpos (return charpos))))) (:line-length (let ((min nil)) (dolist (stream streams min) - (let ((res (funcall (lisp-stream-misc stream) stream :line-length))) + (let ((res (line-length stream))) (when res (setq min (if min (min res min) res))))))) (:element-type (let (res) (dolist (stream streams (if (> (length res) 1) `(and ,@res) res)) - (pushnew (funcall (lisp-stream-misc stream) stream :element-type) res - :test #'equal)))) + (pushnew (stream-element-type stream) res :test #'equal)))) (:close) (t (let ((res nil)) (dolist (stream streams res) - (setq res (funcall (lisp-stream-misc stream) stream operation - arg1 arg2)))))))) + (setq res + (if (lisp-stream-p stream) + (funcall (lisp-stream-misc stream) stream operation + arg1 arg2) + (stream-misc-dispatch stream operation arg1 arg2))))))))) + ;;;; Synonym Streams: @@ -705,14 +742,16 @@ ;;; The output simple output methods just call the corresponding method ;;; in the synonymed stream. ;;; -(macrolet ((out-fun (name slot &rest args) +(macrolet ((out-fun (name slot stream-method &rest args) `(defun ,name (stream ,@args) (declare (optimize (safety 1))) (let ((syn (symbol-value (synonym-stream-symbol stream)))) - (funcall (,slot syn) syn ,@args))))) - (out-fun synonym-out lisp-stream-out ch) - (out-fun synonym-bout lisp-stream-bout n) - (out-fun synonym-sout lisp-stream-sout string start end)) + (if (lisp-stream-p syn) + (funcall (,slot syn) syn ,@args) + (,stream-method syn ,@args)))))) + (out-fun synonym-out lisp-stream-out stream-write-char ch) + (out-fun synonym-bout lisp-stream-bout stream-write-byte n) + (out-fun synonym-sout lisp-stream-sout stream-write-string string start end)) ;;; Bind synonym stream to this so that SPIO can turn on the right frob in @@ -743,11 +782,14 @@ (declare (optimize (safety 1))) (let ((syn (symbol-value (synonym-stream-symbol stream))) (*previous-stream* stream)) - (case operation - (:listen (or (/= (the fixnum (lisp-stream-in-index syn)) in-buffer-length) - (funcall (lisp-stream-misc syn) syn :listen))) - (t - (funcall (lisp-stream-misc syn) syn operation arg1 arg2))))) + (if (lisp-stream-p syn) + (case operation + (:listen (or (/= (the fixnum (lisp-stream-in-index syn)) + in-buffer-length) + (funcall (lisp-stream-misc syn) syn :listen))) + (t + (funcall (lisp-stream-misc syn) syn operation arg1 arg2))) + (stream-misc-dispatch syn operation arg1 arg2)))) ;;;; Two-Way streams: @@ -777,13 +819,15 @@ "Returns a bidirectional stream which gets its input from Input-Stream and sends its output to Output-Stream.") -(macrolet ((out-fun (name slot &rest args) +(macrolet ((out-fun (name slot stream-method &rest args) `(defun ,name (stream ,@args) (let ((syn (two-way-stream-output-stream stream))) - (funcall (,slot syn) syn ,@args))))) - (out-fun two-way-out lisp-stream-out ch) - (out-fun two-way-bout lisp-stream-bout n) - (out-fun two-way-sout lisp-stream-sout string start end)) + (if (lisp-stream-p syn) + (funcall (,slot syn) syn ,@args) + (,stream-method syn ,@args)))))) + (out-fun two-way-out lisp-stream-out stream-write-char ch) + (out-fun two-way-bout lisp-stream-bout stream-write-byte n) + (out-fun two-way-sout lisp-stream-sout stream-write-string string start end)) (macrolet ((in-fun (name fun &rest args) `(defun ,name (stream ,@args) @@ -795,26 +839,38 @@ (defun two-way-misc (stream operation &optional arg1 arg2) (let* ((in (two-way-stream-input-stream stream)) - (in-method (lisp-stream-misc in)) (out (two-way-stream-output-stream stream)) - (out-method (lisp-stream-misc out))) + (in-lisp-stream-p (lisp-stream-p in)) + (out-lisp-stream-p (lisp-stream-p out))) (case operation - (:listen (or (/= (the fixnum (lisp-stream-in-index in)) in-buffer-length) - (funcall in-method in :listen))) + (:listen + (if in-lisp-stream-p + (or (/= (the fixnum (lisp-stream-in-index in)) in-buffer-length) + (funcall (lisp-stream-misc in) in :listen)) + (stream-listen in))) ((:finish-output :force-output :clear-output) - (funcall out-method out operation arg1 arg2)) + (if out-lisp-stream-p + (funcall (lisp-stream-misc out) out operation arg1 arg2) + (stream-misc-dispatch out operation arg1 arg2))) ((:clear-input :unread) - (funcall in-method in operation arg1 arg2)) + (if in-lisp-stream-p + (funcall (lisp-stream-misc in) in operation arg1 arg2) + (stream-misc-dispatch in operation arg1 arg2))) (:element-type - (let ((in-type (funcall in-method in :element-type)) - (out-type (funcall out-method out :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 + (:close (set-closed-flame stream)) (t - (or (funcall in-method in operation arg1 arg2) - (funcall out-method out operation arg1 arg2)))))) + (or (if in-lisp-stream-p + (funcall (lisp-stream-misc in) in operation arg1 arg2) + (stream-misc-dispatch in operation arg1 arg2)) + (if out-lisp-stream-p + (funcall (lisp-stream-misc out) out operation arg1 arg2) + (stream-misc-dispatch out operation arg1 arg2))))))) + ;;;; Concatenated Streams: @@ -856,12 +912,14 @@ (defun concatenated-misc (stream operation &optional arg1 arg2) (let ((left (concatenated-stream-current stream))) (when left - (let* ((current (car left)) - (misc (lisp-stream-misc current))) + (let* ((current (car left))) (case operation (:listen (loop - (let ((stuff (funcall misc current :listen))) + (let ((stuff (if (lisp-stream-p current) + (funcall (lisp-stream-misc current) current + :listen) + (stream-misc-dispatch current :listen)))) (cond ((eq stuff :eof) ;; Advance current, and try again. (pop (concatenated-stream-current stream)) @@ -869,8 +927,7 @@ (car (concatenated-stream-current stream))) (unless current ;; No further streams. EOF. - (return :eof)) - (setf misc (lisp-stream-misc current))) + (return :eof))) (stuff ;; Stuff's available. (return t)) @@ -880,7 +937,10 @@ (:close (set-closed-flame stream)) (t - (funcall misc current operation arg1 arg2))))))) + (if (lisp-stream-p current) + (funcall (lisp-stream-misc current) current operation arg1 arg2) + (stream-misc-dispatch current operation arg1 arg2)))))))) + ;;;; Echo Streams: @@ -895,37 +955,46 @@ unread-stuff) -(macrolet ((in-fun (name fun out-slot &rest args) +(macrolet ((in-fun (name fun out-slot stream-method &rest args) `(defun ,name (stream ,@args) (or (pop (echo-stream-unread-stuff stream)) (let* ((in (echo-stream-input-stream stream)) (out (echo-stream-output-stream stream)) (result (,fun in ,@args))) - (funcall (,out-slot out) out result) + (if (lisp-stream-p out) + (funcall (,out-slot out) out result) + (,stream-method out result)) result))))) - (in-fun echo-in read-char lisp-stream-out eof-errorp eof-value) - (in-fun echo-bin read-byte lisp-stream-bout eof-errorp eof-value)) + (in-fun echo-in read-char lisp-stream-out stream-write-char + eof-errorp eof-value) + (in-fun echo-bin read-byte lisp-stream-bout stream-write-byte + eof-errorp eof-value)) (defun echo-misc (stream operation &optional arg1 arg2) (let* ((in (two-way-stream-input-stream stream)) - (in-method (lisp-stream-misc in)) - (out (two-way-stream-output-stream stream)) - (out-method (lisp-stream-misc out))) + (out (two-way-stream-output-stream stream))) (case operation - (:listen (or (not (null (echo-stream-unread-stuff stream))) - (/= (the fixnum (lisp-stream-in-index in)) in-buffer-length) - (funcall in-method in :listen))) + (:listen + (or (not (null (echo-stream-unread-stuff stream))) + (if (lisp-stream-p in) + (or (/= (the fixnum (lisp-stream-in-index in)) in-buffer-length) + (funcall (lisp-stream-misc in) in :listen)) + (stream-misc-dispatch in :listen)))) (:unread (push arg1 (echo-stream-unread-stuff stream))) (:element-type - (let ((in-type (funcall in-method in :element-type)) - (out-type (funcall out-method out :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)) (t - (or (funcall in-method in operation arg1 arg2) - (funcall out-method out operation arg1 arg2)))))) + (or (if (lisp-stream-p in) + (funcall (lisp-stream-misc in) in operation arg1 arg2) + (stream-misc-dispatch in operation arg1 arg2)) + (if (lisp-stream-p out) + (funcall (lisp-stream-misc out) out operation arg1 arg2) + (stream-misc-dispatch out operation arg1 arg2))))))) (defun %print-echo-stream (s stream d) (declare (ignore d)) @@ -1262,34 +1331,31 @@ (defun indenting-misc (stream operation &optional arg1 arg2) (let ((sub-stream (indenting-stream-stream stream))) - (etypecase sub-stream - (lisp-stream - (let ((method (lisp-stream-misc sub-stream))) - (case operation - (:line-length - (let ((line-length (funcall method sub-stream operation))) - (if line-length - (- line-length (indenting-stream-indentation stream))))) - (:charpos - (let ((charpos (funcall method sub-stream operation))) - (if charpos - (- charpos (indenting-stream-indentation stream))))) - (t - (funcall method sub-stream operation arg1 arg2))))) - (fundamental-stream - (case operation - (:line-length - (let ((line-length (stream-line-length sub-stream))) - (if line-length - (- line-length (indenting-stream-indentation stream))))) - (:charpos - (let ((charpos (stream-line-column sub-stream))) - (if charpos - (- charpos (indenting-stream-indentation stream))))) - (t - ;; XX TODO - (format t "* Warning: ignoring ~s ~s ~s on ~s~%" - operation arg1 arg2 sub-stream))))))) + (if (lisp-stream-p sub-stream) + (let ((method (lisp-stream-misc sub-stream))) + (case operation + (:line-length + (let ((line-length (funcall method sub-stream operation))) + (if line-length + (- line-length (indenting-stream-indentation stream))))) + (:charpos + (let ((charpos (funcall method sub-stream operation))) + (if charpos + (- charpos (indenting-stream-indentation stream))))) + (t + (funcall method sub-stream operation arg1 arg2)))) + ;; Fundamental-stream. + (case operation + (:line-length + (let ((line-length (stream-line-length sub-stream))) + (if line-length + (- line-length (indenting-stream-indentation stream))))) + (:charpos + (let ((charpos (stream-line-column sub-stream))) + (if charpos + (- charpos (indenting-stream-indentation stream))))) + (t + (stream-misc-dispatch sub-stream operation arg1 arg2)))))) (proclaim '(maybe-inline read-char unread-char read-byte listen)) @@ -1345,14 +1411,18 @@ (:close) (t (let ((target (case-frob-stream-target stream))) - (funcall (lisp-stream-misc target) target op arg1 arg2))))) - + (if (lisp-stream-p target) + (funcall (lisp-stream-misc target) target op arg1 arg2) + (stream-misc-dispatch target op arg1 arg2)))))) (defun case-frob-upcase-out (stream char) (declare (type case-frob-stream stream) (type base-char char)) - (let ((target (case-frob-stream-target stream))) - (funcall (lisp-stream-out target) target (char-upcase char)))) + (let ((target (case-frob-stream-target stream)) + (char (char-upcase char))) + (if (lisp-stream-p target) + (funcall (lisp-stream-out target) target char) + (stream-write-char target char)))) (defun case-frob-upcase-sout (stream str start end) (declare (type case-frob-stream stream) @@ -1361,19 +1431,23 @@ (type (or index null) end)) (let* ((target (case-frob-stream-target stream)) (len (length str)) - (end (or end len))) - (funcall (lisp-stream-sout target) target - (if (and (zerop start) (= len end)) - (string-upcase str) - (nstring-upcase (subseq str start end))) - 0 - (- end start)))) + (end (or end len)) + (string (if (and (zerop start) (= len end)) + (string-upcase str) + (nstring-upcase (subseq str start end)))) + (string-len (- end start))) + (if (lisp-stream-p target) + (funcall (lisp-stream-sout target) target string 0 string-len) + (stream-write-string target string 0 string-len)))) (defun case-frob-downcase-out (stream char) (declare (type case-frob-stream stream) (type base-char char)) - (let ((target (case-frob-stream-target stream))) - (funcall (lisp-stream-out target) target (char-downcase char)))) + (let ((target (case-frob-stream-target stream)) + (char (char-downcase char))) + (if (lisp-stream-p target) + (funcall (lisp-stream-out target) target char) + (stream-write-char target char)))) (defun case-frob-downcase-sout (stream str start end) (declare (type case-frob-stream stream) @@ -1382,26 +1456,31 @@ (type (or index null) end)) (let* ((target (case-frob-stream-target stream)) (len (length str)) - (end (or end len))) - (funcall (lisp-stream-sout target) target - (if (and (zerop start) (= len end)) - (string-downcase str) - (nstring-downcase (subseq str start end))) - 0 - (- end start)))) + (end (or end len)) + (string (if (and (zerop start) (= len end)) + (string-downcase str) + (nstring-downcase (subseq str start end)))) + (string-len (- end start))) + (if (lisp-stream-p target) + (funcall (lisp-stream-sout target) target string 0 string-len) + (stream-write-string target string 0 string-len)))) (defun case-frob-capitalize-out (stream char) (declare (type case-frob-stream stream) (type base-char char)) (let ((target (case-frob-stream-target stream))) (cond ((alphanumericp char) - (funcall (lisp-stream-out target) target (char-upcase char)) - (setf (case-frob-stream-out stream) - #'case-frob-capitalize-aux-out) + (let ((char (char-upcase char))) + (if (lisp-stream-p target) + (funcall (lisp-stream-out target) target char) + (stream-write-char target char))) + (setf (case-frob-stream-out stream) #'case-frob-capitalize-aux-out) (setf (case-frob-stream-sout stream) #'case-frob-capitalize-aux-sout)) (t - (funcall (lisp-stream-out target) target char))))) + (if (lisp-stream-p target) + (funcall (lisp-stream-out target) target char) + (stream-write-char target char)))))) (defun case-frob-capitalize-sout (stream str start end) (declare (type case-frob-stream stream) @@ -1426,16 +1505,23 @@ #'case-frob-capitalize-aux-out) (setf (case-frob-stream-sout stream) #'case-frob-capitalize-aux-sout)) - (funcall (lisp-stream-sout target) target str 0 len))) + (if (lisp-stream-p target) + (funcall (lisp-stream-sout target) target str 0 len) + (stream-write-string target str 0 len)))) (defun case-frob-capitalize-aux-out (stream char) (declare (type case-frob-stream stream) (type base-char char)) (let ((target (case-frob-stream-target stream))) (cond ((alphanumericp char) - (funcall (lisp-stream-out target) target (char-downcase char))) + (let ((char (char-downcase char))) + (if (lisp-stream-p target) + (funcall (lisp-stream-out target) target char) + (stream-write-char target char)))) (t - (funcall (lisp-stream-out target) target char) + (if (lisp-stream-p target) + (funcall (lisp-stream-out target) target char) + (stream-write-char target char)) (setf (case-frob-stream-out stream) #'case-frob-capitalize-out) (setf (case-frob-stream-sout stream) @@ -1464,20 +1550,27 @@ #'case-frob-capitalize-out) (setf (case-frob-stream-sout stream) #'case-frob-capitalize-sout)) - (funcall (lisp-stream-sout target) target str 0 len))) + (if (lisp-stream-p target) + (funcall (lisp-stream-sout target) target str 0 len) + (stream-write-string target str 0 len)))) (defun case-frob-capitalize-first-out (stream char) (declare (type case-frob-stream stream) (type base-char char)) (let ((target (case-frob-stream-target stream))) (cond ((alphanumericp char) - (funcall (lisp-stream-out target) target (char-upcase char)) + (let ((char (char-upcase char))) + (if (lisp-stream-p target) + (funcall (lisp-stream-out target) target char) + (stream-write-char target char))) (setf (case-frob-stream-out stream) #'case-frob-downcase-out) (setf (case-frob-stream-sout stream) #'case-frob-downcase-sout)) (t - (funcall (lisp-stream-out target) target char))))) + (if (lisp-stream-p target) + (funcall (lisp-stream-out target) target char) + (stream-write-char target char)))))) (defun case-frob-capitalize-first-sout (stream str start end) (declare (type case-frob-stream stream) @@ -1499,7 +1592,9 @@ (setf (case-frob-stream-sout stream) #'case-frob-downcase-sout) (return)))) - (funcall (lisp-stream-sout target) target str 0 len))) + (if (lisp-stream-p target) + (funcall (lisp-stream-sout target) target str 0 len) + (stream-write-string target str 0 len)))) ;;;; Public interface from "EXTENSIONS" package.