X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fstream.lisp;h=b33dfb9b90a4796c5365012fe3c21b913f31f4d4;hb=cb296ae5a022a5b0f1fd573584301b0d2a9493f9;hp=2c008bab043612e50b9bde7f19ddbf4586d97d26;hpb=15e14ef1ccd3ab6f4711632435a40493dc4cdd9d;p=sbcl.git diff --git a/src/code/stream.lisp b/src/code/stream.lisp index 2c008ba..b33dfb9 100644 --- a/src/code/stream.lisp +++ b/src/code/stream.lisp @@ -142,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 (alien sb!unix:off-t) (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". @@ -199,12 +205,10 @@ ;;;; 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)) @@ -231,95 +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) +#!-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) @@ -381,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 @@ -405,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. @@ -440,12 +477,16 @@ (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)))) @@ -463,21 +504,28 @@ 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. @@ -528,7 +576,7 @@ ;;; 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 (maybe-inline read-char unread-char read-byte listen)) +(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 @@ -629,6 +677,14 @@ ((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 @@ -882,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) @@ -921,6 +977,36 @@ (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 @@ -942,7 +1028,7 @@ (:include string-stream (in #'string-inch) (bin #'ill-bin) - (n-bin #'string-stream-read-n-bytes) + (n-bin #'ill-bin) (misc #'string-in-misc) (string (missing-arg) :type simple-string)) (:constructor internal-make-string-input-stream @@ -1147,14 +1233,19 @@ (element-type (string-output-stream-element-type stream)) (result (case element-type - ;; Overwhelmingly common case; can be inlined. + ;; overwhelmingly common case: can be inlined ((character) (make-string length)) + ;; slightly less common cases: inline it anyway + ((base-char standard-char) + (make-string length :element-type 'base-char)) (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-base-string + (replace result (string-output-stream-string stream))) ((simple-array nil (*)) (replace result (string-output-stream-string stream)))) (setf (string-output-stream-index stream) 0 @@ -1177,6 +1268,8 @@ ;;; the CLM, but they are required for the implementation of ;;; WITH-OUTPUT-TO-STRING. +;;; FIXME: need to support (VECTOR BASE-CHAR) and (VECTOR NIL), +;;; ideally without destroying all hope of efficiency. (deftype string-with-fill-pointer () '(and (vector character) (satisfies array-has-fill-pointer-p))) @@ -1206,9 +1299,9 @@ (if (= offset-current end) (let* ((new-length (1+ (* current 2))) (new-workspace (make-string new-length))) - (declare (simple-string new-workspace)) - (%byte-blt workspace start - new-workspace 0 current) + (declare (type (simple-array character (*)) new-workspace)) + (replace new-workspace workspace + :start2 start :end2 offset-current) (setf workspace new-workspace offset-current current) (set-array-header buffer workspace new-length @@ -1236,21 +1329,16 @@ (let* ((new-length (+ (the fixnum (* current 2)) string-len)) (new-workspace (make-string new-length))) (declare (type (simple-array character (*)) new-workspace)) - (%byte-blt workspace dst-start - new-workspace 0 current) - (setf workspace new-workspace) - (setf offset-current current) - (setf offset-dst-end dst-end) - (set-array-header buffer - workspace - new-length - dst-end - 0 - new-length - nil)) + (replace new-workspace workspace + :start2 dst-start :end2 offset-current) + (setf workspace new-workspace + offset-current current + offset-dst-end dst-end) + (set-array-header buffer workspace new-length + dst-end 0 new-length nil)) (setf (fill-pointer buffer) dst-end)) - (%byte-blt string start - workspace offset-current offset-dst-end))) + (replace workspace string + :start1 offset-current :start2 start :end2 end))) dst-end)) (defun fill-pointer-misc (stream operation &optional arg1 arg2) @@ -1313,7 +1401,7 @@ (indentation (indenting-stream-indentation ,stream))) ((>= i indentation)) (%write-string - " " + #.(make-string 60 :initial-element #\Space) ,sub-stream 0 (min 60 (- indentation i))))) @@ -1386,12 +1474,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) @@ -1439,7 +1527,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)) @@ -1464,7 +1552,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)) @@ -1497,7 +1585,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)) @@ -1542,7 +1630,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)) @@ -1587,7 +1675,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)) @@ -1641,14 +1729,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))))) @@ -1656,26 +1744,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))))))))))) @@ -1707,6 +1791,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)) @@ -1720,6 +1807,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)))