X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fstream.lisp;h=a99b5e3806f6f3855281af3c5940ba55fbeef2f5;hb=988afd9d54ba6c8a915544822658824ab6ae0d6c;hp=5676b14fda6a0d7c5d6b5bc38b975004dcb36459;hpb=ebbaa0e11a4d5c9bf021d28f212cfb6d5cd4aaab;p=sbcl.git diff --git a/src/code/stream.lisp b/src/code/stream.lisp index 5676b14..a99b5e3 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,15 @@ ;;; 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 +75,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)) + ;; CLHS 22.1.4 lets us not worry about synonym streams here. (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) @@ -124,19 +142,25 @@ ;;;; file position and file length ;;; Call the MISC method with the :FILE-POSITION operation. -(defun file-position (stream &optional position) +#!-sb-fluid (declaim (inline ansi-stream-file-position)) +(defun ansi-stream-file-position (stream position) (declare (type stream stream)) - (declare (type (or index (member nil :start :end)) position)) + (declare (type (or index (alien sb!unix:off-t) (member nil :start :end)) + position)) (cond - (position - (setf (ansi-stream-in-index stream) +ansi-stream-in-buffer-length+) - (funcall (ansi-stream-misc stream) stream :file-position position)) - (t - (let ((res (funcall (ansi-stream-misc stream) stream :file-position nil))) - (when res - (- res - (- +ansi-stream-in-buffer-length+ - (ansi-stream-in-index stream)))))))) + (position + (setf (ansi-stream-in-index stream) +ansi-stream-in-buffer-length+) + (funcall (ansi-stream-misc stream) stream :file-position position)) + (t + (let ((res (funcall (ansi-stream-misc stream) stream :file-position nil))) + (when res + (- res + (- +ansi-stream-in-buffer-length+ + (ansi-stream-in-index stream)))))))) + + +(defun file-position (stream &optional position) + (ansi-stream-file-position stream position)) ;;; This is a literal translation of the ANSI glossary entry "stream ;;; associated with a file". @@ -166,24 +190,25 @@ ;; private predicate function..) is ugly and confusing, but ;; I can't see any other way. -- WHN 2001-04-14 :expected-type '(satisfies stream-associated-with-file-p) - :format-string + :format-control "~@" :format-arguments (list stream)))) ;;; 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)) ;;;; input functions -(defun read-line (&optional (stream *standard-input*) (eof-error-p t) eof-value - recursive-p) +#!-sb-fluid (declaim (inline ansi-stream-read-line)) +(defun ansi-stream-read-line (stream eof-error-p eof-value recursive-p) (declare (ignore recursive-p)) - (let ((stream (in-synonym-of stream))) - (if (ansi-stream-p stream) - (prepare-for-fast-read-char stream + (prepare-for-fast-read-char stream (let ((res (make-string 80)) (len 80) (index 0)) @@ -210,160 +235,128 @@ ;; shouldn't do another READ-CHAR. (t (done-with-fast-read-char) - (return (values (shrink-vector res index) t)))))))) + (return (values (shrink-vector res index) t))))))))) + +(defun read-line (&optional (stream *standard-input*) (eof-error-p t) eof-value + recursive-p) + (let ((stream (in-synonym-of stream))) + (if (ansi-stream-p stream) + (ansi-stream-read-line stream eof-error-p eof-value recursive-p) ;; must be Gray streams FUNDAMENTAL-STREAM (multiple-value-bind (string eof) (stream-read-line stream) (if (and eof (zerop (length string))) (values (eof-or-lose stream eof-error-p eof-value) t) (values string eof)))))) -;;; We proclaim them INLINE here, then proclaim them MAYBE-INLINE at EOF, +;;; We proclaim them INLINE here, then proclaim them NOTINLINE later on, ;;; so, except in this file, they are not inline by default, but they can be. #!-sb-fluid (declaim (inline read-char unread-char read-byte listen)) +#!-sb-fluid (declaim (inline ansi-stream-read-char)) +(defun ansi-stream-read-char (stream eof-error-p eof-value recursive-p) + (declare (ignore recursive-p)) + (prepare-for-fast-read-char stream + (prog1 + (fast-read-char eof-error-p eof-value) + (done-with-fast-read-char)))) + (defun read-char (&optional (stream *standard-input*) (eof-error-p t) eof-value recursive-p) - (declare (ignore recursive-p)) (let ((stream (in-synonym-of stream))) (if (ansi-stream-p stream) - (prepare-for-fast-read-char stream - (prog1 - (fast-read-char eof-error-p eof-value) - (done-with-fast-read-char))) + (ansi-stream-read-char stream eof-error-p eof-value recursive-p) ;; must be Gray streams FUNDAMENTAL-STREAM (let ((char (stream-read-char stream))) (if (eq char :eof) (eof-or-lose stream eof-error-p eof-value) char))))) +#!-sb-fluid (declaim (inline ansi-stream-unread-char)) +(defun ansi-stream-unread-char (character stream) + (let ((index (1- (ansi-stream-in-index stream))) + (buffer (ansi-stream-cin-buffer stream))) + (declare (fixnum index)) + (when (minusp index) (error "nothing to unread")) + (cond (buffer + (setf (aref buffer index) character) + (setf (ansi-stream-in-index stream) index)) + (t + (funcall (ansi-stream-misc stream) stream + :unread character))))) + (defun unread-char (character &optional (stream *standard-input*)) (let ((stream (in-synonym-of stream))) (if (ansi-stream-p stream) - (let ((index (1- (ansi-stream-in-index stream))) - (buffer (ansi-stream-in-buffer stream))) - (declare (fixnum index)) - (when (minusp index) (error "nothing to unread")) - (cond (buffer - (setf (aref buffer index) (char-code character)) - (setf (ansi-stream-in-index stream) index)) - (t - (funcall (ansi-stream-misc stream) stream - :unread character)))) + (ansi-stream-unread-char character stream) ;; must be Gray streams FUNDAMENTAL-STREAM (stream-unread-char stream character))) nil) -(defun peek-char (&optional (peek-type nil) - (stream *standard-input*) - (eof-error-p t) - 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 (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")))))) +#!-sb-fluid (declaim (inline ansi-stream-listen)) +(defun ansi-stream-listen (stream) + (or (/= (the fixnum (ansi-stream-in-index stream)) + +ansi-stream-in-buffer-length+) + ;; Test for T explicitly since misc methods return :EOF sometimes. + (eq (funcall (ansi-stream-misc stream) stream :listen) t))) (defun listen (&optional (stream *standard-input*)) (let ((stream (in-synonym-of stream))) (if (ansi-stream-p stream) - (or (/= (the fixnum (ansi-stream-in-index stream)) - +ansi-stream-in-buffer-length+) - ;; Test for T explicitly since misc methods return :EOF sometimes. - (eq (funcall (ansi-stream-misc stream) stream :listen) t)) + (ansi-stream-listen stream) ;; Fall through to Gray streams FUNDAMENTAL-STREAM case. (stream-listen stream)))) +#!-sb-fluid (declaim (inline ansi-stream-read-char-no-hang)) +(defun ansi-stream-read-char-no-hang (stream eof-error-p eof-value recursive-p) + (if (funcall (ansi-stream-misc stream) stream :listen) + ;; On T or :EOF get READ-CHAR to do the work. + (ansi-stream-read-char stream eof-error-p eof-value recursive-p) + nil)) + (defun read-char-no-hang (&optional (stream *standard-input*) (eof-error-p t) eof-value recursive-p) - (declare (ignore recursive-p)) (let ((stream (in-synonym-of stream))) (if (ansi-stream-p stream) - (if (funcall (ansi-stream-misc stream) stream :listen) - ;; On T or :EOF get READ-CHAR to do the work. - (read-char stream eof-error-p eof-value) - nil) + (ansi-stream-read-char-no-hang stream eof-error-p eof-value + recursive-p) ;; must be Gray streams FUNDAMENTAL-STREAM (let ((char (stream-read-char-no-hang stream))) (if (eq char :eof) (eof-or-lose stream eof-error-p eof-value) char))))) +#!-sb-fluid (declaim (inline ansi-stream-clear-input)) +(defun ansi-stream-clear-input (stream) + (setf (ansi-stream-in-index stream) +ansi-stream-in-buffer-length+) + (funcall (ansi-stream-misc stream) stream :clear-input)) + (defun clear-input (&optional (stream *standard-input*)) (let ((stream (in-synonym-of stream))) - (cond ((ansi-stream-p stream) - (setf (ansi-stream-in-index stream) +ansi-stream-in-buffer-length+) - (funcall (ansi-stream-misc stream) stream :clear-input)) - (t - (stream-clear-input stream)))) + (if (ansi-stream-p stream) + (ansi-stream-clear-input stream) + ;; must be Gray streams FUNDAMENTAL-STREAM + (stream-clear-input stream))) nil) -(declaim (maybe-inline read-byte)) +#!-sb-fluid (declaim (inline ansi-stream-read-byte)) +(defun ansi-stream-read-byte (stream eof-error-p eof-value recursive-p) + ;; Why the "recursive-p" parameter? a-s-r-b is funcall'ed from + ;; a-s-read-sequence and needs a lambda list that's congruent with + ;; that of a-s-read-char + (declare (ignore recursive-p)) + (prepare-for-fast-read-byte stream + (prog1 + (fast-read-byte eof-error-p eof-value t) + (done-with-fast-read-byte)))) + (defun read-byte (stream &optional (eof-error-p t) eof-value) (let ((stream (in-synonym-of stream))) (if (ansi-stream-p stream) - (prepare-for-fast-read-byte stream - (prog1 - (fast-read-byte eof-error-p eof-value t) - (done-with-fast-read-byte))) + (ansi-stream-read-byte stream eof-error-p eof-value nil) ;; must be Gray streams FUNDAMENTAL-STREAM (let ((char (stream-read-byte stream))) (if (eq char :eof) @@ -425,7 +418,7 @@ ;;; the IN-BUFFER for text streams. There is definitely an IN-BUFFER, ;;; and hence must be an N-BIN method. (defun fast-read-char-refill (stream eof-error-p eof-value) - (let* ((ibuf (ansi-stream-in-buffer stream)) + (let* ((ibuf (ansi-stream-cin-buffer stream)) (count (funcall (ansi-stream-n-bin stream) stream ibuf @@ -449,7 +442,7 @@ sb!vm:n-word-bits)) (* count sb!vm:n-byte-bits))) (setf (ansi-stream-in-index stream) (1+ start)) - (code-char (aref ibuf start)))))) + (aref ibuf start))))) ;;; This is similar to FAST-READ-CHAR-REFILL, but we don't have to ;;; leave room for unreading. @@ -484,56 +477,70 @@ (with-out-stream stream (ansi-stream-out #\newline) (stream-terpri)) nil) +#!-sb-fluid (declaim (inline ansi-stream-fresh-line)) +(defun ansi-stream-fresh-line (stream) + (when (/= (or (charpos stream) 1) 0) + (funcall (ansi-stream-out stream) stream #\newline) + t)) + (defun fresh-line (&optional (stream *standard-output*)) (let ((stream (out-synonym-of stream))) (if (ansi-stream-p stream) - (when (/= (or (charpos stream) 1) 0) - (funcall (ansi-stream-out stream) stream #\newline) - t) + (ansi-stream-fresh-line stream) ;; must be Gray streams FUNDAMENTAL-STREAM (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) + +#!-sb-fluid (declaim (inline ansi-stream-write-string)) +(defun ansi-stream-write-string (string stream start end) + (declare (type string string)) + (declare (type ansi-stream stream)) + (declare (type index start end)) + (if (array-header-p string) + (with-array-data ((data string) (offset-start start) + (offset-end end)) + (funcall (ansi-stream-sout stream) + stream data offset-start offset-end)) + (funcall (ansi-stream-sout stream) stream string start end)) + string) +(defun %write-string (string stream start end) + (declare (type string string)) + (declare (type stream-designator stream)) + (declare (type index start end)) (let ((stream (out-synonym-of stream))) - (cond ((ansi-stream-p stream) - (if (array-header-p string) - (with-array-data ((data string) (offset-start start) - (offset-end end)) - (funcall (ansi-stream-sout stream) - stream data offset-start offset-end)) - (funcall (ansi-stream-sout stream) stream string start end)) - string) - (t ; must be Gray streams FUNDAMENTAL-STREAM - (stream-write-string stream string start end))))) + (if(ansi-stream-p stream) + (ansi-stream-write-string string stream start end) + ;; must be Gray streams FUNDAMENTAL-STREAM + (stream-write-string stream string start end)))) + +;;; A wrapper function for all those (MACROLET OUT-FUN) definitions, +;;; which cannot deal with keyword arguments. +(declaim (inline write-string-no-key)) +(defun write-string-no-key (string stream start end) + (write-string string stream :start start :end 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) @@ -564,37 +571,43 @@ (stream-write-byte integer)) integer) + +;;; (These were inline throughout this file, but that's not appropriate +;;; globally. And we must not inline them in the rest of this file if +;;; dispatch to gray or simple streams is to work, since both redefine +;;; these functions later.) +(declaim (notinline read-char unread-char read-byte listen)) + ;;; This is called from ANSI-STREAM routines that encapsulate CLOS ;;; streams to handle the misc routines and dispatch to the -;;; appropriate Gray stream functions. +;;; appropriate SIMPLE- or FUNDAMENTAL-STREAM functions. (defun stream-misc-dispatch (stream operation &optional arg1 arg2) - (declare (type fundamental-stream stream) - (ignore arg2)) - (case operation + (declare (type stream stream) (ignore arg2)) + (ecase operation (:listen ;; Return T if input available, :EOF for end-of-file, otherwise NIL. - (let ((char (stream-read-char-no-hang stream))) + (let ((char (read-char-no-hang stream nil :eof))) (when (characterp char) - (stream-unread-char stream char)) + (unread-char char stream)) char)) (:unread - (stream-unread-char stream arg1)) + (unread-char arg1 stream)) (:close (close stream)) (:clear-input - (stream-clear-input stream)) + (clear-input stream)) (:force-output - (stream-force-output stream)) + (force-output stream)) (:finish-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)) + (line-length stream)) (:charpos - (stream-line-column stream)) + (charpos stream)) (:file-length (file-length stream)) (:file-position @@ -615,31 +628,37 @@ (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)))) (apply #'%make-broadcast-stream streams)) -(macrolet ((out-fun (fun method stream-method &rest args) - `(defun ,fun (stream ,@args) +(macrolet ((out-fun (name fun &rest args) + `(defun ,name (stream ,@args) (dolist (stream (broadcast-stream-streams stream)) - (if (ansi-stream-p stream) - (funcall (,method stream) stream ,@args) - (,stream-method stream ,@args)))))) - (out-fun broadcast-out ansi-stream-out stream-write-char char) - (out-fun broadcast-bout ansi-stream-bout stream-write-byte byte) - (out-fun broadcast-sout ansi-stream-sout stream-write-string - string start end)) + (,fun ,(car args) stream ,@(cdr args)))))) + (out-fun broadcast-out write-char char) + (out-fun broadcast-bout write-byte byte) + (out-fun broadcast-sout write-string-no-key string start end)) (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 @@ -648,10 +667,26 @@ (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))))))) + (:file-position + (if arg1 + (let ((res (or (eql arg1 :start) (eql arg1 0)))) + (dolist (stream streams res) + (setq res (file-position stream arg1)))) + (let ((res 0)) + (dolist (stream streams res) + (setq res (file-position stream)))))) + (:close + (set-closed-flame stream)) (t (let ((res nil)) (dolist (stream streams res) @@ -679,18 +714,16 @@ (print-unreadable-object (x stream :type t :identity t) (format stream ":SYMBOL ~S" (synonym-stream-symbol x)))) -;;; The output simple output methods just call the corresponding method -;;; in the synonymed stream. -(macrolet ((out-fun (name slot stream-method &rest args) +;;; The output simple output methods just call the corresponding +;;; function on the synonymed stream. +(macrolet ((out-fun (name fun &rest args) `(defun ,name (stream ,@args) (declare (optimize (safety 1))) (let ((syn (symbol-value (synonym-stream-symbol stream)))) - (if (ansi-stream-p syn) - (funcall (,slot syn) syn ,@args) - (,stream-method syn ,@args)))))) - (out-fun synonym-out ansi-stream-out stream-write-char ch) - (out-fun synonym-bout ansi-stream-bout stream-write-byte n) - (out-fun synonym-sout ansi-stream-sout stream-write-string string start end)) + (,fun ,(car args) syn ,@(cdr args)))))) + (out-fun synonym-out write-char ch) + (out-fun synonym-bout write-byte n) + (out-fun synonym-sout write-string-no-key string start end)) ;;; For the input methods, we just call the corresponding function on the ;;; synonymed stream. These functions deal with getting input out of @@ -745,31 +778,23 @@ ;; 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))) (funcall #'%make-two-way-stream input-stream output-stream)) -(macrolet ((out-fun (name slot stream-method &rest args) +(macrolet ((out-fun (name fun &rest args) `(defun ,name (stream ,@args) (let ((syn (two-way-stream-output-stream stream))) - (if (ansi-stream-p syn) - (funcall (,slot syn) syn ,@args) - (,stream-method syn ,@args)))))) - (out-fun two-way-out ansi-stream-out stream-write-char ch) - (out-fun two-way-bout ansi-stream-bout stream-write-byte n) - (out-fun two-way-sout ansi-stream-sout stream-write-string string start end)) + (,fun ,(car args) syn ,@(cdr args)))))) + (out-fun two-way-out write-char ch) + (out-fun two-way-bout write-byte n) + (out-fun two-way-sout write-string-no-key string start end)) (macrolet ((in-fun (name fun &rest args) `(defun ,name (stream ,@args) @@ -820,20 +845,10 @@ (bin #'concatenated-bin) (n-bin #'concatenated-n-bin) (misc #'concatenated-misc)) - (:constructor %make-concatenated-stream - (&rest streams &aux (current streams))) + (:constructor %make-concatenated-stream (&rest streams)) (:copier nil)) ;; The car of this is the substream we are reading from now. - current - ;; This is a list of all the substreams there ever were. We need to - ;; remember them so that we can close them. - ;; - ;; FIXME: ANSI says this is supposed to be the list of streams that - ;; we still have to read from. So either this needs to become a - ;; private member %STREAM (with CONCATENATED-STREAM-STREAMS a wrapper - ;; around it which discards closed files from the head of the list) - ;; or we need to update it as we run out of files. - (streams nil :type list :read-only t)) + (streams nil :type list)) (def!method print-object ((x concatenated-stream) stream) (print-unreadable-object (x stream :type t :identity t) (format stream @@ -845,10 +860,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)))) @@ -856,66 +868,68 @@ (macrolet ((in-fun (name fun) `(defun ,name (stream eof-error-p eof-value) - (do ((current (concatenated-stream-current stream) - (cdr current))) - ((null current) + (do ((streams (concatenated-stream-streams stream) + (cdr streams))) + ((null streams) (eof-or-lose stream eof-error-p eof-value)) - (let* ((stream (car current)) + (let* ((stream (car streams)) (result (,fun stream nil nil))) (when result (return result))) - (setf (concatenated-stream-current stream) current))))) + (pop (concatenated-stream-streams stream)))))) (in-fun concatenated-in read-char) (in-fun concatenated-bin read-byte)) (defun concatenated-n-bin (stream buffer start numbytes eof-errorp) - (do ((current (concatenated-stream-current stream) (cdr current)) + (do ((streams (concatenated-stream-streams stream) (cdr streams)) (current-start start) (remaining-bytes numbytes)) - ((null current) + ((null streams) (if eof-errorp (error 'end-of-file :stream stream) (- numbytes remaining-bytes))) - (let* ((stream (car current)) + (let* ((stream (car streams)) (bytes-read (read-n-bytes stream buffer current-start remaining-bytes nil))) (incf current-start bytes-read) (decf remaining-bytes bytes-read) (when (zerop remaining-bytes) (return numbytes))) - (setf (concatenated-stream-current stream) (cdr current)))) + (setf (concatenated-stream-streams stream) (cdr streams)))) (defun concatenated-misc (stream operation &optional arg1 arg2) - (let ((left (concatenated-stream-current stream))) - (when left - (let* ((current (car left))) - (case operation - (:listen - (loop - (let ((stuff (if (ansi-stream-p current) - (funcall (ansi-stream-misc current) current - :listen) - (stream-misc-dispatch current :listen)))) - (cond ((eq stuff :eof) - ;; Advance CURRENT, and try again. - (pop (concatenated-stream-current stream)) - (setf current - (car (concatenated-stream-current stream))) - (unless current - ;; No further streams. EOF. - (return :eof))) - (stuff - ;; Stuff's available. - (return t)) - (t - ;; Nothing is available yet. - (return nil)))))) - (:clear-input (clear-input current)) - (:unread (unread-char arg1 current)) - (:close - (set-closed-flame stream)) - (t - (if (ansi-stream-p current) - (funcall (ansi-stream-misc current) current operation arg1 arg2) - (stream-misc-dispatch current operation arg1 arg2)))))))) + (let* ((left (concatenated-stream-streams stream)) + (current (car left))) + (case operation + (:listen + (unless left + (return-from concatenated-misc :eof)) + (loop + (let ((stuff (if (ansi-stream-p current) + (funcall (ansi-stream-misc current) current + :listen) + (stream-misc-dispatch current :listen)))) + (cond ((eq stuff :eof) + ;; Advance STREAMS, and try again. + (pop (concatenated-stream-streams stream)) + (setf current + (car (concatenated-stream-streams stream))) + (unless current + ;; No further streams. EOF. + (return :eof))) + (stuff + ;; Stuff's available. + (return t)) + (t + ;; Nothing is available yet. + (return nil)))))) + (:clear-input (when left (clear-input current))) + (:unread (when left (unread-char arg1 current))) + (:close + (set-closed-flame stream)) + (t + (when left + (if (ansi-stream-p current) + (funcall (ansi-stream-misc current) current operation arg1 arg2) + (stream-misc-dispatch current operation arg1 arg2))))))) ;;;; echo streams @@ -924,7 +938,7 @@ (in #'echo-in) (bin #'echo-bin) (misc #'echo-misc) - (n-bin #'ill-bin)) + (n-bin #'echo-n-bin)) (:constructor %make-echo-stream (input-stream output-stream)) (:copier nil)) unread-stuff) @@ -940,100 +954,108 @@ "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))) (funcall #'%make-echo-stream input-stream output-stream)) -(macrolet ((in-fun (name fun out-slot stream-method &rest args) +(macrolet ((in-fun (name in-fun out-fun &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))) - (if (ansi-stream-p out) - (funcall (,out-slot out) out result) - (,stream-method out result)) - result))))) - (in-fun echo-in read-char ansi-stream-out stream-write-char - eof-error-p eof-value) - (in-fun echo-bin read-byte ansi-stream-bout stream-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)) - (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))))))) - + (result (if eof-error-p + (,in-fun in ,@args) + (,in-fun in nil in)))) + (cond + ((eql result in) eof-value) + (t (,out-fun result out) 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-n-bin (stream buffer start numbytes eof-error-p) + (let ((new-start start) + (read 0)) + (loop + (let ((thing (pop (echo-stream-unread-stuff stream)))) + (cond + (thing + (setf (aref buffer new-start) thing) + (incf new-start) + (incf read) + (when (= read numbytes) + (return-from echo-n-bin numbytes))) + (t (return nil))))) + (let ((bytes-read (read-n-bytes (echo-stream-input-stream stream) buffer + new-start (- numbytes read) nil))) + (cond + ((not eof-error-p) + (write-sequence buffer (echo-stream-output-stream stream) + :start new-start :end (+ new-start bytes-read)) + (+ bytes-read read)) + ((> numbytes (+ read bytes-read)) + (write-sequence buffer (echo-stream-output-stream stream) + :start new-start :end (+ new-start bytes-read)) + (error 'end-of-file :stream stream)) + (t + (write-sequence buffer (echo-stream-output-stream stream) + :start new-start :end (+ new-start bytes-read)) + (aver (= numbytes (+ new-start bytes-read))) + numbytes))))) + +;;;; base STRING-STREAM stuff + +(defstruct (string-stream + (:include ansi-stream) + (:constructor nil) + (:copier nil)) + ;; FIXME: This type declaration is true, and will probably continue + ;; to be true. However, note well the comments in DEFTRANSFORM + ;; REPLACE, implying that performance of REPLACE is somewhat + ;; critical to performance of string streams. If (VECTOR CHARACTER) + ;; ever becomes different from (VECTOR BASE-CHAR), the transform + ;; probably needs to be extended. + (string (missing-arg) :type (vector character))) -;;;; 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)) + (bin #'ill-bin) + (n-bin #'ill-bin) + (misc #'string-in-misc) + (string (missing-arg) :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)) + (current (missing-arg) :type index) + (end (missing-arg) :type index)) (defun string-inch (stream eof-error-p eof-value) + (declare (type string-input-stream stream)) (let ((string (string-input-stream-string stream)) (index (string-input-stream-current stream))) - (declare (simple-string string) (fixnum index)) - (cond ((= index (the index (string-input-stream-end stream))) + (cond ((>= index (the index (string-input-stream-end stream))) (eof-or-lose stream eof-error-p eof-value)) (t (setf (string-input-stream-current stream) (1+ index)) - (aref string index))))) + (char string index))))) (defun string-binch (stream eof-error-p eof-value) + (declare (type string-input-stream stream)) (let ((string (string-input-stream-string stream)) (index (string-input-stream-current stream))) - (declare (simple-string string) - (type index index)) - (cond ((= index (the index (string-input-stream-end stream))) + (cond ((>= index (the index (string-input-stream-end stream))) (eof-or-lose stream eof-error-p eof-value)) (t (setf (string-input-stream-current stream) (1+ index)) - (char-code (aref string index)))))) + (char-code (char string index)))))) (defun string-stream-read-n-bytes (stream buffer start requested eof-error-p) (declare (type string-input-stream stream) @@ -1042,8 +1064,7 @@ (index (string-input-stream-current stream)) (available (- (string-input-stream-end stream) index)) (copy (min available requested))) - (declare (simple-string string) - (type index index available copy)) + (declare (type simple-string string)) (when (plusp copy) (setf (string-input-stream-current stream) (truly-the index (+ index copy))) @@ -1060,76 +1081,101 @@ copy))) (defun string-in-misc (stream operation &optional arg1 arg2) - (declare (ignore arg2)) + (declare (type string-input-stream stream) + (ignore arg2)) (case operation (:file-position (if arg1 - (setf (string-input-stream-current stream) arg1) + (setf (string-input-stream-current stream) + (case arg1 + (:start 0) + (:end (string-input-stream-end stream)) + ;; We allow moving position beyond EOF. Errors happen + ;; on read, not move -- or the user may extend the + ;; input string. + (t arg1))) (string-input-stream-current stream))) - (:file-length (length (string-input-stream-string stream))) + ;; According to ANSI: "Should signal an error of type type-error + ;; if stream is not a stream associated with a file." + ;; This is checked by FILE-LENGTH, so no need to do it here either. + ;; (:file-length (length (string-input-stream-string stream))) (:unread (decf (string-input-stream-current stream))) - (:listen (or (/= (the fixnum (string-input-stream-current stream)) - (the fixnum (string-input-stream-end stream))) + (:close (set-closed-flame stream)) + (:listen (or (/= (the index (string-input-stream-current stream)) + (the index (string-input-stream-end stream))) :eof)) - (:element-type 'base-char))) + (:element-type (array-element-type (string-input-stream-string stream))))) -(defun make-string-input-stream (string &optional - (start 0) (end (length string))) +(defun make-string-input-stream (string &optional (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)) + (let* ((string (coerce string '(simple-array character (*)))) + (end (%check-vector-sequence-bounds string start end))) + (with-array-data ((string string) (start start) (end end)) + (internal-make-string-input-stream + string ;; now simple + 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)) - (:constructor make-string-output-stream ()) + (misc #'string-out-misc) + ;; The string we throw stuff in. + (string (missing-arg) + :type (simple-array character (*)))) + (:constructor make-string-output-stream + (&key (element-type 'character) + &aux (string (make-string 40)))) (: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)) + (index 0 :type fixnum) + ;; Index cache for string-output-stream-last-index + (index-cache 0 :type fixnum) + ;; Requested element type + (element-type 'character)) #!+sb-doc (setf (fdocumentation 'make-string-output-stream 'function) "Return an output stream which will accumulate all output given it for the benefit of the function GET-OUTPUT-STREAM-STRING.") +(defun string-output-stream-last-index (stream) + (max (string-output-stream-index stream) + (string-output-stream-index-cache stream))) + (defun string-ouch (stream character) (let ((current (string-output-stream-index stream)) (workspace (string-output-stream-string stream))) - (declare (simple-string workspace) (fixnum current)) + (declare (type (simple-array character (*)) workspace) + (type fixnum current)) (if (= current (the fixnum (length workspace))) (let ((new-workspace (make-string (* current 2)))) (replace new-workspace workspace) - (setf (aref new-workspace current) character) - (setf (string-output-stream-string stream) new-workspace)) + (setf (aref new-workspace current) character + (string-output-stream-string stream) new-workspace)) (setf (aref workspace current) character)) (setf (string-output-stream-index stream) (1+ current)))) (defun string-sout (stream string start end) - (declare (simple-string string) (fixnum start end)) - (let* ((current (string-output-stream-index stream)) + (declare (type simple-string string) + (type fixnum start end)) + (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)) (workspace (string-output-stream-string stream))) - (declare (simple-string workspace) - (fixnum current length dst-end)) + (declare (type (simple-array character (*)) workspace string) + (type fixnum current length dst-end)) (if (> dst-end (the fixnum (length workspace))) (let ((new-workspace (make-string (+ (* current 2) length)))) (replace new-workspace workspace :end2 current) @@ -1146,28 +1192,59 @@ (declare (ignore arg2)) (case operation (:file-position - (if (null arg1) + (if arg1 + (let ((end (string-output-stream-last-index stream))) + (setf (string-output-stream-index-cache stream) end + (string-output-stream-index stream) + (case arg1 + (:start 0) + (:end end) + (t + ;; We allow moving beyond the end of stream, + ;; implicitly extending the output stream. + (let ((buffer (string-output-stream-string stream))) + (when (> arg1 (length buffer)) + (setf (string-output-stream-string stream) + (make-string + arg1 :element-type (array-element-type buffer)) + (subseq (string-output-stream-string stream) + 0 end) + (subseq buffer 0 end)))) + arg1)))) (string-output-stream-index stream))) + (:close (set-closed-flame stream)) (:charpos (do ((index (1- (the fixnum (string-output-stream-index stream))) (1- index)) (count 0 (1+ count)) (string (string-output-stream-string stream))) ((< index 0) count) - (declare (simple-string string) - (fixnum index count)) + (declare (type (simple-array character (*)) string) + (type fixnum index count)) (if (char= (schar string index) #\newline) (return count)))) - (:element-type 'base-char))) + (:element-type (array-element-type (string-output-stream-string stream))))) ;;; Return a string of all the characters sent to a stream made by ;;; MAKE-STRING-OUTPUT-STREAM since the last call to this function. (defun get-output-stream-string (stream) (declare (type string-output-stream stream)) - (let* ((length (string-output-stream-index stream)) - (result (make-string length))) - (replace result (string-output-stream-string stream)) - (setf (string-output-stream-index stream) 0) + (let* ((length (string-output-stream-last-index stream)) + (element-type (string-output-stream-element-type stream)) + (result + (case element-type + ;; Overwhelmingly common case; can be inlined. + ((character) (make-string length)) + (t (make-string length :element-type element-type))))) + ;; For the benefit of the REPLACE transform, let's do this, so + ;; that the common case isn't ludicrously expensive. + (etypecase result + ((simple-array character (*)) + (replace result (string-output-stream-string stream))) + ((simple-array nil (*)) + (replace result (string-output-stream-string stream)))) + (setf (string-output-stream-index stream) 0 + (string-output-stream-index-cache stream) 0) result)) ;;; Dump the characters buffer up in IN-STREAM to OUT-STREAM as @@ -1176,8 +1253,9 @@ (%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)) + (string-output-stream-last-index in-stream)) + (setf (string-output-stream-index in-stream) 0 + (string-output-stream-index-cache in-stream) 0)) ;;;; fill-pointer streams @@ -1185,15 +1263,22 @@ ;;; the CLM, but they are required for the implementation of ;;; WITH-OUTPUT-TO-STRING. +(deftype string-with-fill-pointer () + '(and (vector character) + (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 (missing-arg) + :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)) @@ -1201,7 +1286,7 @@ (current+1 (1+ current))) (declare (fixnum current)) (with-array-data ((workspace buffer) (start) (end)) - (declare (simple-string workspace)) + (declare (type (simple-array character (*)) workspace)) (let ((offset-current (+ start current))) (declare (fixnum offset-current)) (if (= offset-current end) @@ -1210,8 +1295,8 @@ (declare (simple-string new-workspace)) (%byte-blt workspace start new-workspace 0 current) - (setf workspace new-workspace) - (setf offset-current current) + (setf workspace new-workspace + offset-current current) (set-array-header buffer workspace new-length current+1 0 new-length nil)) (setf (fill-pointer buffer) current+1)) @@ -1220,20 +1305,23 @@ (defun fill-pointer-sout (stream string start end) (declare (simple-string string) (fixnum start end)) - (let* ((buffer (fill-pointer-output-stream-string stream)) + (let* ((string (if (typep string '(simple-array character (*))) + string + (coerce string '(simple-array character (*))))) + (buffer (fill-pointer-output-stream-string stream)) (current (fill-pointer buffer)) (string-len (- end start)) (dst-end (+ string-len current))) (declare (fixnum current dst-end string-len)) (with-array-data ((workspace buffer) (dst-start) (dst-length)) - (declare (simple-string workspace)) + (declare (type (simple-array character (*)) workspace)) (let ((offset-dst-end (+ dst-start dst-end)) (offset-current (+ dst-start current))) (declare (fixnum offset-dst-end offset-current)) (if (> offset-dst-end dst-length) (let* ((new-length (+ (the fixnum (* current 2)) string-len)) (new-workspace (make-string new-length))) - (declare (simple-string new-workspace)) + (declare (type (simple-array character (*)) new-workspace)) (%byte-blt workspace dst-start new-workspace 0 current) (setf workspace new-workspace) @@ -1252,8 +1340,27 @@ dst-end)) (defun fill-pointer-misc (stream operation &optional arg1 arg2) - (declare (ignore arg1 arg2)) + (declare (ignore arg2)) (case operation + (:file-position + (let ((buffer (fill-pointer-output-stream-string stream))) + (if arg1 + (setf (fill-pointer buffer) + (case arg1 + (:start 0) + ;; Fill-pointer is always at fill-pointer we will + ;; make :END move to the end of the actual string. + (:end (array-total-size buffer)) + ;; We allow moving beyond the end of string if the + ;; string is adjustable. + (t (when (>= arg1 (array-total-size buffer)) + (if (adjustable-array-p buffer) + (adjust-array buffer arg1) + (error "Cannot move FILE-POSITION beyond the end ~ + of WITH-OUTPUT-TO-STRING stream ~ + constructed with non-adjustable string."))) + arg1))) + (fill-pointer buffer)))) (:charpos (let* ((buffer (fill-pointer-output-stream-string stream)) (current (fill-pointer buffer))) @@ -1264,7 +1371,8 @@ (if found (- end (the fixnum found)) current))))) - (:element-type 'base-char))) + (:element-type (array-element-type + (fill-pointer-output-stream-string stream))))) ;;;; indenting streams @@ -1291,7 +1399,7 @@ (indentation (indenting-stream-indentation ,stream))) ((>= i indentation)) (%write-string - " " + #.(make-string 60 :initial-element #\Space) ,sub-stream 0 (min 60 (- indentation i))))) @@ -1364,12 +1472,12 @@ #!+sb-doc "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. - :capitalize - convert the first letter of words to upper case and the - rest of the word to lower case. - :capitalize-first - convert the first letter of the first word to upper - case and everything else to lower case." + :UPCASE - convert to upper case. + :DOWNCASE - convert to lower case. + :CAPITALIZE - convert the first letter of words to upper case and the + rest of the word to lower case. + :CAPITALIZE-FIRST - convert the first letter of the first word to upper + case and everything else to lower case." (declare (type stream target) (type (member :upcase :downcase :capitalize :capitalize-first) kind) @@ -1398,7 +1506,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) @@ -1416,7 +1525,7 @@ (defun case-frob-upcase-sout (stream str start end) (declare (type case-frob-stream stream) - (type simple-base-string str) + (type simple-string str) (type index start) (type (or index null) end)) (let* ((target (case-frob-stream-target stream)) @@ -1441,7 +1550,7 @@ (defun case-frob-downcase-sout (stream str start end) (declare (type case-frob-stream stream) - (type simple-base-string str) + (type simple-string str) (type index start) (type (or index null) end)) (let* ((target (case-frob-stream-target stream)) @@ -1474,7 +1583,7 @@ (defun case-frob-capitalize-sout (stream str start end) (declare (type case-frob-stream stream) - (type simple-base-string str) + (type simple-string str) (type index start) (type (or index null) end)) (let* ((target (case-frob-stream-target stream)) @@ -1519,7 +1628,7 @@ (defun case-frob-capitalize-aux-sout (stream str start end) (declare (type case-frob-stream stream) - (type simple-base-string str) + (type simple-string str) (type index start) (type (or index null) end)) (let* ((target (case-frob-stream-target stream)) @@ -1564,7 +1673,7 @@ (defun case-frob-capitalize-first-sout (stream str start end) (declare (type case-frob-stream stream) - (type simple-base-string str) + (type simple-string str) (type index start) (type (or index null) end)) (let* ((target (case-frob-stream-target stream)) @@ -1586,40 +1695,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 @@ -1649,14 +1727,14 @@ (list (let ((read-function (if (subtypep (stream-element-type stream) 'character) - #'read-char - #'read-byte))) + #'ansi-stream-read-char + #'ansi-stream-read-byte))) (do ((rem (nthcdr start seq) (rest rem)) (i start (1+ i))) ((or (endp rem) (>= i end)) i) (declare (type list rem) (type index i)) - (let ((el (funcall read-function stream nil :eof))) + (let ((el (funcall read-function stream nil :eof nil))) (when (eq el :eof) (return i)) (setf (first rem) el))))) @@ -1664,26 +1742,22 @@ (with-array-data ((data seq) (offset-start start) (offset-end end)) (typecase data ((or (simple-array (unsigned-byte 8) (*)) - (simple-array (signed-byte 8) (*)) - simple-string) + (simple-array (signed-byte 8) (*))) (let* ((numbytes (- end start)) - (bytes-read (sb!sys:read-n-bytes stream - data - offset-start - numbytes - nil))) + (bytes-read (read-n-bytes stream data offset-start + numbytes nil))) (if (< bytes-read numbytes) (+ start bytes-read) end))) (t (let ((read-function (if (subtypep (stream-element-type stream) 'character) - #'read-char - #'read-byte))) + #'ansi-stream-read-char + #'ansi-stream-read-byte))) (do ((i offset-start (1+ i))) ((>= i offset-end) end) (declare (type index i)) - (let ((el (funcall read-function stream nil :eof))) + (let ((el (funcall read-function stream nil :eof nil))) (when (eq el :eof) (return (+ start (- i offset-start)))) (setf (aref data i) el))))))))))) @@ -1715,6 +1789,9 @@ (list (let ((write-function (if (subtypep (stream-element-type stream) 'character) + ;; FIXME (rudi 2004-08-09): since we know we're an + ;; ansi stream here, we could replace these + ;; functions with ansi-stream-specific constructs #'write-char #'write-byte))) (do ((rem (nthcdr start seq) (rest rem)) @@ -1728,6 +1805,9 @@ (vector (let ((write-function (if (subtypep (stream-element-type stream) 'character) + ;; FIXME (rudi 2004-08-09): since we know we're an + ;; ansi stream here, we could replace these + ;; functions with ansi-specific constructs #'write-char #'write-byte))) (do ((i start (1+ i))) @@ -1736,7 +1816,3 @@ (funcall write-function (aref seq i) stream))))))) ;;;; etc. - -;;; (These were inline throughout this file, but that's not appropriate -;;; globally.) -(declaim (maybe-inline read-char unread-char read-byte listen))