X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fstream.lisp;h=77c29bcd95b0ece7f57df85db18526980d5a0dce;hb=a0d9e7847b870acfbea98b01469654d01a8cf920;hp=edfc4ed112ffceb8e074175efdfaba6b674c781f;hpb=6a8fb906ba96395f2a60f821b2ec7649a2a3ae46;p=sbcl.git diff --git a/src/code/stream.lisp b/src/code/stream.lisp index edfc4ed..77c29bc 100644 --- a/src/code/stream.lisp +++ b/src/code/stream.lisp @@ -145,7 +145,7 @@ ;;; Call the MISC method with the :FILE-POSITION operation. (defun file-position (stream &optional 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+) @@ -559,6 +559,12 @@ (t ; 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) (declare (type string string)) @@ -597,37 +603,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 (maybe-inline 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 @@ -657,16 +669,13 @@ :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))) @@ -712,18 +721,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 @@ -794,15 +801,13 @@ :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) @@ -989,20 +994,16 @@ :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 in ,@args))) + (,out-fun result out) 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)) + (in-fun echo-in read-char write-char eof-error-p eof-value) + (in-fun echo-bin read-byte write-byte eof-error-p eof-value)) (defun echo-misc (stream operation &optional arg1 arg2) (let* ((in (two-way-stream-input-stream stream)) @@ -1085,38 +1086,35 @@ (defstruct (string-input-stream (:include string-stream (in #'string-inch) - (bin #'string-binch) + (bin #'ill-bin) (n-bin #'string-stream-read-n-bytes) (misc #'string-in-misc) - (string (missing-arg) - :type (simple-array character (*)))) + (string (missing-arg) :type simple-string)) (:constructor internal-make-string-input-stream (string current end)) (:copier nil)) - (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 (type (simple-array character (*)) string) - (type 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 (type (simple-array character (*)) 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) @@ -1125,8 +1123,7 @@ (index (string-input-stream-current stream)) (available (- (string-input-stream-end stream) index)) (copy (min available requested))) - (declare (type (simple-array character (*)) 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))) @@ -1143,32 +1140,43 @@ 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))) + (: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) +(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)) - - (internal-make-string-input-stream - (coerce string 'simple-string) - start - (%check-vector-sequence-bounds string start end))) + (let ((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-STREAM stuff @@ -1178,18 +1186,28 @@ (sout #'string-sout) (misc #'string-out-misc) ;; The string we throw stuff in. - (string (make-string 40) + (string (missing-arg) :type (simple-array character (*)))) - (:constructor make-string-output-stream ()) + (:constructor make-string-output-stream + (&key (element-type 'character) + &aux (string (make-string 40)))) (:copier nil)) ;; 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))) @@ -1198,8 +1216,8 @@ (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)))) @@ -1231,7 +1249,25 @@ (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))) (:charpos (do ((index (1- (the fixnum (string-output-stream-index stream))) @@ -1243,16 +1279,28 @@ (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 @@ -1261,8 +1309,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 @@ -1281,7 +1330,7 @@ (misc #'fill-pointer-misc) ;; a string with a fill pointer where we stuff ;; the stuff we write - (string (error "missing argument") + (string (missing-arg) :type string-with-fill-pointer :read-only t)) (:constructor make-fill-pointer-output-stream (string)) @@ -1302,8 +1351,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)) @@ -1349,6 +1398,25 @@ (defun fill-pointer-misc (stream operation &optional arg1 arg2) (declare (ignore arg1 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))) @@ -1359,7 +1427,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 @@ -1800,7 +1869,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))