(defun stream-element-type (stream)
(ansi-stream-element-type stream))
+(defun stream-external-format (stream)
+ (funcall (ansi-stream-misc stream) stream :external-format))
+
(defun interactive-stream-p (stream)
(declare (type stream stream))
(funcall (ansi-stream-misc stream) stream :interactive-p))
;;;; 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".
;; EXPECTED-TYPE? This SATISFIES type (with a nonstandard
;; private predicate function..) is ugly and confusing, but
;; I can't see any other way. -- WHN 2001-04-14
+ :datum stream
:expected-type '(satisfies stream-associated-with-file-p)
:format-control
"~@<The stream ~2I~_~S ~I~_isn't associated with a file.~:>"
;; cause cross-compiler hangup.
;;
;; (declare (type (or file-stream synonym-stream) stream))
- (stream-must-be-associated-with-file stream)
+ ;;
+ ;; The description for FILE-LENGTH says that an error must be raised
+ ;; for streams not associated with files (which broadcast streams
+ ;; aren't according to the glossary). However, the behaviour of
+ ;; FILE-LENGTH for broadcast streams is explicitly described in the
+ ;; BROADCAST-STREAM entry.
+ (unless (typep stream 'broadcast-stream)
+ (stream-must-be-associated-with-file stream))
(funcall (ansi-stream-misc stream) stream :file-length))
+
+(defun file-string-length (stream object)
+ (funcall (ansi-stream-misc stream) stream :file-string-length object))
\f
;;;; 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))
;; 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+)
+ ;; Handle :EOF return from misc methods specially
+ (let ((result (funcall (ansi-stream-misc stream) stream :listen)))
+ (if (eq result :eof)
+ nil
+ result))))
+
(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)
\f
-(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)
numbytes
eof-error-p))
((<= numbytes num-buffered)
+ #+nil
+ (let ((copy-function (typecase buffer
+ ((simple-array * (*)) #'ub8-bash-copy)
+ (system-area-pointer #'copy-ub8-to-system-area))))
+ (funcall copy-function in-buffer index buffer start numbytes))
(%byte-blt in-buffer index
buffer start (+ start numbytes))
(setf (ansi-stream-in-index stream) (+ index numbytes))
numbytes)
(t
(let ((end (+ start num-buffered)))
- (%byte-blt in-buffer index buffer start end)
+ #+nil
+ (let ((copy-function (typecase buffer
+ ((simple-array * (*)) #'ub8-bash-copy)
+ (system-area-pointer #'copy-ub8-to-system-area))))
+ (funcall copy-function in-buffer index buffer start num-buffered))
+ (%byte-blt in-buffer index buffer start end)
(setf (ansi-stream-in-index stream) +ansi-stream-in-buffer-length+)
(+ (funcall (ansi-stream-n-bin stream)
stream
;;; 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))
- (count (funcall (ansi-stream-n-bin stream)
- stream
- ibuf
- +ansi-stream-in-buffer-extra+
- (- +ansi-stream-in-buffer-length+
- +ansi-stream-in-buffer-extra+)
- nil))
- (start (- +ansi-stream-in-buffer-length+ count)))
+ (let* ((ibuf (ansi-stream-cin-buffer stream))
+ (count (funcall (ansi-stream-n-bin stream)
+ stream
+ ibuf
+ +ansi-stream-in-buffer-extra+
+ (- +ansi-stream-in-buffer-length+
+ +ansi-stream-in-buffer-extra+)
+ nil))
+ (start (- +ansi-stream-in-buffer-length+ count)))
(declare (type index start count))
(cond ((zerop count)
- (setf (ansi-stream-in-index stream) +ansi-stream-in-buffer-length+)
- (funcall (ansi-stream-in stream) stream eof-error-p eof-value))
- (t
- (when (/= start +ansi-stream-in-buffer-extra+)
- (bit-bash-copy ibuf (+ (* +ansi-stream-in-buffer-extra+
- sb!vm:n-byte-bits)
- (* sb!vm:vector-data-offset
- sb!vm:n-word-bits))
- ibuf (+ (the index (* start sb!vm:n-byte-bits))
- (* sb!vm:vector-data-offset
- sb!vm:n-word-bits))
- (* count sb!vm:n-byte-bits)))
- (setf (ansi-stream-in-index stream) (1+ start))
- (code-char (aref ibuf start))))))
+ (setf (ansi-stream-in-index stream)
+ +ansi-stream-in-buffer-length+)
+ (funcall (ansi-stream-in stream) stream eof-error-p eof-value))
+ (t
+ (when (/= start +ansi-stream-in-buffer-extra+)
+ (#.(let* ((n-character-array-bits
+ (sb!vm:saetp-n-bits
+ (find 'character
+ sb!vm:*specialized-array-element-type-properties*
+ :key #'sb!vm:saetp-specifier)))
+ (bash-function (intern (format nil "UB~D-BASH-COPY" n-character-array-bits)
+ (find-package "SB!KERNEL"))))
+ bash-function)
+ ibuf +ansi-stream-in-buffer-extra+
+ ibuf start
+ count))
+ (setf (ansi-stream-in-index stream) (1+ start))
+ (aref ibuf start)))))
;;; This is similar to FAST-READ-CHAR-REFILL, but we don't have to
;;; leave room for unreading.
(funcall (ansi-stream-bin stream) stream eof-error-p eof-value))
(t
(unless (zerop start)
- (bit-bash-copy ibuf (* sb!vm:vector-data-offset sb!vm:n-word-bits)
- ibuf (+ (the index (* start sb!vm:n-byte-bits))
- (* sb!vm:vector-data-offset
- sb!vm:n-word-bits))
- (* count sb!vm:n-byte-bits)))
+ (ub8-bash-copy ibuf 0
+ ibuf start
+ count))
(setf (ansi-stream-in-index stream) (1+ start))
(aref ibuf start)))))
\f
(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))))
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.
;;; 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
(finish-output stream))
(:element-type
(stream-element-type stream))
+ (:stream-external-format
+ (stream-external-format stream))
(:interactive-p
(interactive-stream-p stream))
(:line-length
(charpos stream))
(:file-length
(file-length stream))
+ (:file-string-length
+ (file-string-length stream arg1))
(:file-position
(file-position stream arg1))))
\f
((null streams) res)
(when (null (cdr streams))
(setq res (stream-element-type (car streams)))))))
+ (:external-format
+ (let ((res :default))
+ (dolist (stream streams res)
+ (setq res (stream-external-format stream)))))
+ (:file-length
+ (let ((last (last streams)))
+ (if last
+ (file-length (car last))
+ 0)))
+ (: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))))))
+ (:file-string-length
+ (let ((res 1))
+ (dolist (stream streams res)
+ (setq res (file-string-length stream arg1)))))
(:close
(set-closed-flame stream))
(t
(or (/= (the fixnum (ansi-stream-in-index in))
+ansi-stream-in-buffer-length+)
(funcall (ansi-stream-misc in) in :listen))
- (stream-listen in)))
+ (listen in)))
((:finish-output :force-output :clear-output)
(if out-ansi-stream-p
(funcall (ansi-stream-misc out) out operation arg1 arg2)
(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.
(streams nil :type list))
(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)
(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))
-\f
-;;;; 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)))
+
+(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)))))
\f
;;;; STRING-INPUT-STREAM stuff
(defstruct (string-input-stream
- (:include string-stream
+ (:include ansi-stream
(in #'string-inch)
(bin #'ill-bin)
- (n-bin #'string-stream-read-n-bytes)
- (misc #'string-in-misc)
- (string (missing-arg) :type simple-string))
+ (n-bin #'ill-bin)
+ (misc #'string-in-misc))
(:constructor internal-make-string-input-stream
(string current end))
(:copier nil))
+ (string (missing-arg) :type simple-string)
(current (missing-arg) :type index)
(end (missing-arg) :type index))
(when (plusp copy)
(setf (string-input-stream-current stream)
(truly-the index (+ index copy)))
+ ;; FIXME: why are we VECTOR-SAP'ing things here? what's the point?
+ ;; and are there SB-UNICODE issues here as well? --njf, 2005-03-24
(sb!sys:without-gcing
- (system-area-copy (vector-sap string)
- (* index sb!vm:n-byte-bits)
- (if (typep buffer 'system-area-pointer)
- buffer
- (vector-sap buffer))
- (* start sb!vm:n-byte-bits)
- (* copy sb!vm:n-byte-bits))))
+ (system-area-ub8-copy (vector-sap string)
+ index
+ (if (typep buffer 'system-area-pointer)
+ buffer
+ (vector-sap buffer))
+ start
+ copy)))
(if (and (> requested copy) eof-error-p)
(error 'end-of-file :stream stream)
copy)))
;; 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)))
+ (:close (set-closed-flame stream))
(:listen (or (/= (the index (string-input-stream-current stream))
(the index (string-input-stream-end stream)))
:eof))
;;;; STRING-OUTPUT-STREAM stuff
(defstruct (string-output-stream
- (:include string-stream
+ (:include ansi-stream
(out #'string-ouch)
(sout #'string-sout)
- (misc #'string-out-misc)
- ;; The string we throw stuff in.
- (string (missing-arg)
- :type (simple-array character (*))))
+ (misc #'string-out-misc))
(:constructor make-string-output-stream
(&key (element-type 'character)
&aux (string (make-string 40))))
(:copier nil))
+ ;; The string we throw stuff in.
+ (string (missing-arg) :type (simple-array character (*)))
;; Index of the next location to use.
(index 0 :type fixnum)
;; Index cache for string-output-stream-last-index
(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))
(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
;;; 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)))
(defstruct (fill-pointer-output-stream
- (:include string-stream
+ (:include ansi-stream
(out #'fill-pointer-ouch)
(sout #'fill-pointer-sout)
- (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))
+ (misc #'fill-pointer-misc))
(:constructor make-fill-pointer-output-stream (string))
- (:copier nil)))
+ (:copier nil))
+ ;; a string with a fill pointer where we stuff the stuff we write
+ (string (missing-arg) :type string-with-fill-pointer :read-only t))
(defun fill-pointer-ouch (stream character)
(let* ((buffer (fill-pointer-output-stream-string stream))
(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
(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)
- (declare (ignore arg1 arg2))
+ (declare (ignore arg2))
(case operation
(:file-position
(let ((buffer (fill-pointer-output-stream-string stream)))
(indentation (indenting-stream-indentation ,stream)))
((>= i indentation))
(%write-string
- " "
+ #.(make-string 60 :initial-element #\Space)
,sub-stream
0
(min 60 (- indentation i)))))
#!+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)
(defun case-frob-upcase-out (stream char)
(declare (type case-frob-stream stream)
- (type base-char char))
+ (type character char))
(let ((target (case-frob-stream-target stream))
(char (char-upcase char)))
(if (ansi-stream-p target)
(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))
(defun case-frob-downcase-out (stream char)
(declare (type case-frob-stream stream)
- (type base-char char))
+ (type character char))
(let ((target (case-frob-stream-target stream))
(char (char-downcase char)))
(if (ansi-stream-p target)
(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))
(defun case-frob-capitalize-out (stream char)
(declare (type case-frob-stream stream)
- (type base-char char))
+ (type character char))
(let ((target (case-frob-stream-target stream)))
(cond ((alphanumericp char)
(let ((char (char-upcase char)))
(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))
(defun case-frob-capitalize-aux-out (stream char)
(declare (type case-frob-stream stream)
- (type base-char char))
+ (type character char))
(let ((target (case-frob-stream-target stream)))
(cond ((alphanumericp char)
(let ((char (char-downcase char)))
(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))
(defun case-frob-capitalize-first-out (stream char)
(declare (type case-frob-stream stream)
- (type base-char char))
+ (type character char))
(let ((target (case-frob-stream-target stream)))
(cond ((alphanumericp char)
(let ((char (char-upcase char)))
(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))
(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)))))
(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)))))))))))
(list
(let ((write-function
(if (subtypep (stream-element-type stream) 'character)
- #'write-char
- #'write-byte)))
+ (ansi-stream-out stream)
+ (ansi-stream-bout stream))))
(do ((rem (nthcdr start seq) (rest rem))
(i start (1+ i)))
- ((or (endp rem) (>= i end)) seq)
+ ((or (endp rem) (>= i end)))
(declare (type list rem)
(type index i))
- (funcall write-function (first rem) stream))))
+ (funcall write-function stream (first rem)))))
(string
(%write-string seq stream start end))
(vector
- (let ((write-function
- (if (subtypep (stream-element-type stream) 'character)
- #'write-char
- #'write-byte)))
- (do ((i start (1+ i)))
- ((>= i end) seq)
- (declare (type index i))
- (funcall write-function (aref seq i) stream)))))))
+ (with-array-data ((data seq) (offset-start start) (offset-end end))
+ (labels
+ ((output-seq-in-loop ()
+ (let ((write-function
+ (if (subtypep (stream-element-type stream) 'character)
+ (ansi-stream-out stream)
+ (ansi-stream-bout stream))))
+ (do ((i offset-start (1+ i)))
+ ((>= i offset-end))
+ (declare (type index i))
+ (funcall write-function stream (aref data i))))))
+ (typecase data
+ ((or (simple-array (unsigned-byte 8) (*))
+ (simple-array (signed-byte 8) (*)))
+ (if (fd-stream-p stream)
+ (output-raw-bytes stream data offset-start offset-end)
+ (output-seq-in-loop)))
+ (t
+ (output-seq-in-loop))))))))
+ seq)
\f
;;;; etc.
projects / sbcl.git / blobdiff