(setf (ansi-stream-sout stream) #'closed-flame)
(setf (ansi-stream-misc stream) #'closed-flame))
\f
-;;;; file position and file length
+;;;; for file position and file length
(defun external-format-char-size (external-format)
- (let ((ef-entry (find-external-format external-format)))
- (if (variable-width-external-format-p ef-entry)
- (bytes-for-char-fun ef-entry)
- (funcall (bytes-for-char-fun ef-entry) #\x))))
+ (ef-char-size (get-external-format external-format)))
;;; Call the MISC method with the :FILE-POSITION operation.
#!-sb-fluid (declaim (inline ansi-stream-file-position))
(declare (type stream stream))
(declare (type (or index (alien sb!unix:off-t) (member nil :start :end))
position))
- ;; FIXME: It woud be good to comment on the stuff that is done here...
+ ;; FIXME: It would be good to comment on the stuff that is done here...
;; FIXME: This doesn't look interrupt safe.
(cond
(position
;; 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))))
+ (with-fast-read-byte (t stream eof-error-p eof-value)
+ (fast-read-byte)))
(defun read-byte (stream &optional (eof-error-p t) eof-value)
(if (ansi-stream-p stream)
;; An empty count does not necessarily mean that we reached
;; the EOF, it's also possible that it's e.g. due to a
;; invalid octet sequence in a multibyte stream. To handle
- ;; the resyncing case correctly we need to call the
- ;; single-character reading function and check whether an
- ;; EOF was really reached. If not, we can just fill the
- ;; buffer by one character, and hope that the next refill
- ;; will not need to resync.
- (let* ((value (funcall (ansi-stream-in stream) stream nil :eof))
- (index (1- +ansi-stream-in-buffer-length+)))
- (case value
- ((:eof)
- ;; Mark buffer as empty.
+ ;; the resyncing case correctly we need to call the reading
+ ;; function and check whether an EOF was really reached. If
+ ;; not, we can just fill the buffer by one character, and
+ ;; hope that the next refill will not need to resync.
+ ;;
+ ;; KLUDGE: we can't use FD-STREAM functions (which are the
+ ;; only ones which will give us decoding errors) here,
+ ;; because this code is generic. We can't call the N-BIN
+ ;; function, because near the end of a real file that can
+ ;; legitimately bounce us to the IN function. So we have
+ ;; to call ANSI-STREAM-IN.
+ (let* ((index (1- +ansi-stream-in-buffer-length+))
+ (value (funcall (ansi-stream-in stream) stream nil :eof)))
+ (cond
+ ((eql value :eof)
+ ;; definitely EOF now
(setf (ansi-stream-in-index stream)
+ansi-stream-in-buffer-length+)
- ;; EOF. Redo the read, this time with the real eof parameters.
- (values t (funcall (ansi-stream-in stream)
- stream eof-error-p eof-value)))
- (otherwise
+ (values t (eof-or-lose stream eof-error-p eof-value)))
+ ;; we resynced or were given something instead
+ (t
(setf (aref ibuf index) value)
(values nil (setf (ansi-stream-in-index stream) index))))))
(t
;; must be Gray streams FUNDAMENTAL-STREAM
(stream-fresh-line stream))))
-(defun write-string (string &optional (stream *standard-output*)
- &key (start 0) end)
- (declare (type string string))
- ;; 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]),
- ;; (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))
(with-array-data ((data string) (offset-start start)
(offset-end end)
:check-fill-pointer t)
(funcall (ansi-stream-sout stream)
- stream data offset-start offset-end))
- string)
+ stream data offset-start offset-end)))
(defun %write-string (string stream start end)
+ (let ((stream (out-synonym-of stream)))
+ (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)))
+ string)
+
+(defun write-string (string &optional (stream *standard-output*)
+ &key (start 0) end)
(declare (type string string))
(declare (type stream-designator stream))
- (declare (type index start end))
- (let ((stream (out-synonym-of stream)))
- (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))))
+ (%write-string string stream start end))
;;; A wrapper function for all those (MACROLET OUT-FUN) definitions,
-;;; which cannot deal with keyword arguments.
+;;; which cannot deal with keyword arguments. %WRITE-STRING cannot
+;;; replace this, as this needs to deal with simple-strings as well.
(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)
+ &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))
+ (declare (type stream-designator stream))
+ (let ((stream (out-synonym-of stream)))
+ (cond ((ansi-stream-p stream)
+ (ansi-stream-write-string string stream start end)
+ (funcall (ansi-stream-out stream) stream #\newline))
+ (t
+ (stream-write-string stream string start end)
+ (stream-write-char stream #\newline))))
string)
(defun charpos (&optional (stream *standard-output*))
(defun clear-output (&optional (stream *standard-output*))
(with-out-stream stream (ansi-stream-misc :clear-output)
- (stream-force-output))
+ (stream-clear-output))
nil)
(defun write-byte (integer stream)
(macrolet ((in-fun (name fun &rest args)
`(defun ,name (stream ,@args)
- (force-output (two-way-stream-output-stream stream))
(,fun (two-way-stream-input-stream stream) ,@args))))
(in-fun two-way-in read-char eof-error-p eof-value)
(in-fun two-way-bin read-byte eof-error-p eof-value)
(n-bin #'echo-n-bin))
(:constructor %make-echo-stream (input-stream output-stream))
(:copier nil))
- unread-stuff)
+ (unread-stuff nil :type boolean))
(def!method print-object ((x echo-stream) stream)
(print-unreadable-object (x stream :type t :identity t)
(format stream
(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 (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)))))))
+ (let* ((unread-stuff-p (echo-stream-unread-stuff stream))
+ (in (echo-stream-input-stream stream))
+ (out (echo-stream-output-stream stream))
+ (result (if eof-error-p
+ (,in-fun in ,@args)
+ (,in-fun in nil in))))
+ (setf (echo-stream-unread-stuff stream) nil)
+ (cond
+ ((eql result in) eof-value)
+ ;; If unread-stuff was true, the character read
+ ;; from the input stream was previously echoed.
+ (t (unless unread-stuff-p (,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)))))
+ (let ((bytes-read 0))
+ ;; Note: before ca 1.0.27.18, the logic for handling unread
+ ;; characters never could have worked, so probably nobody has ever
+ ;; tried doing bivalent block I/O through an echo stream; this may
+ ;; not work either.
+ (when (echo-stream-unread-stuff stream)
+ (let* ((char (read-char stream))
+ (octets (string-to-octets
+ (string char)
+ :external-format
+ (stream-external-format
+ (echo-stream-input-stream stream))))
+ (octet-count (length octets))
+ (blt-count (min octet-count numbytes)))
+ (replace buffer octets :start1 start :end1 (+ start blt-count))
+ (incf start blt-count)
+ (decf numbytes blt-count)))
+ (incf bytes-read (read-n-bytes (echo-stream-input-stream stream) buffer
+ start numbytes nil))
+ (cond
+ ((not eof-error-p)
+ (write-sequence buffer (echo-stream-output-stream stream)
+ :start start :end (+ start bytes-read))
+ bytes-read)
+ ((> numbytes bytes-read)
+ (write-sequence buffer (echo-stream-output-stream stream)
+ :start start :end (+ start bytes-read))
+ (error 'end-of-file :stream stream))
+ (t
+ (write-sequence buffer (echo-stream-output-stream stream)
+ :start start :end (+ start bytes-read))
+ (aver (= numbytes (+ start bytes-read)))
+ numbytes))))
\f
;;;; STRING-INPUT-STREAM stuff
;; end of the stream.
(index-cache 0 :type index)
;; Requested element type
- (element-type 'character))
+ (element-type 'character :type type-specifier))
#!+sb-doc
(setf (fdocumentation 'make-string-output-stream 'function)
(defun string-out-misc (stream operation &optional arg1 arg2)
(declare (ignore arg2))
+ (declare (optimize speed))
(case operation
(:charpos
;; Keeping this first is a silly micro-optimization: FRESH-LINE
(buffer (string-output-stream-buffer stream))
(prev (string-output-stream-prev stream))
(base 0))
+ (declare (type (or null (simple-array character (*))) buffer))
:next
- (let ((pos (position #\newline buffer :from-end t :end pointer)))
+ (let ((pos (when buffer
+ (position #\newline buffer :from-end t :end pointer))))
(when (or pos (not buffer))
;; If newline is at index I, and pointer at index I+N, charpos
;; is N-1. If there is no newline, and pointer is at index N,
;;; 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.
+;;; FIXME: need to support (VECTOR NIL), ideally without destroying all hope
+;;; of efficiency.
+(declaim (inline vector-with-fill-pointer))
+(defun vector-with-fill-pointer-p (x)
+ (and (vectorp x)
+ (array-has-fill-pointer-p x)))
+
(deftype string-with-fill-pointer ()
- '(and (vector character)
- (satisfies array-has-fill-pointer-p)))
+ `(and (or (vector character) (vector base-char))
+ (satisfies vector-with-fill-pointer-p)))
(defstruct (fill-pointer-output-stream
(:include ansi-stream
(current+1 (1+ current)))
(declare (fixnum current))
(with-array-data ((workspace buffer) (start) (end))
- (declare (type (simple-array character (*)) workspace))
- (let ((offset-current (+ start current)))
- (declare (fixnum offset-current))
- (if (= offset-current end)
- (let* ((new-length (1+ (* current 2)))
- (new-workspace (make-string new-length)))
- (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
- current+1 0 new-length nil))
- (setf (fill-pointer buffer) current+1))
- (setf (schar workspace offset-current) character)))
+ (string-dispatch
+ ((simple-array character (*))
+ (simple-array base-char (*)))
+ workspace
+ (let ((offset-current (+ start current)))
+ (declare (fixnum offset-current))
+ (if (= offset-current end)
+ (let* ((new-length (1+ (* current 2)))
+ (new-workspace
+ (ecase (array-element-type workspace)
+ (character (make-string new-length
+ :element-type 'character))
+ (base-char (make-string new-length
+ :element-type 'base-char)))))
+ (replace new-workspace workspace :start2 start :end2 offset-current)
+ (setf workspace new-workspace
+ offset-current current)
+ (set-array-header buffer workspace new-length
+ current+1 0 new-length nil nil))
+ (setf (fill-pointer buffer) current+1))
+ (setf (char workspace offset-current) character))))
current+1))
(defun fill-pointer-sout (stream string start end)
- (declare (simple-string string) (fixnum start end))
- (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 (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 (type (simple-array character (*)) new-workspace))
- (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))
- (replace workspace string
- :start1 offset-current :start2 start :end2 end)))
- dst-end))
+ (declare (fixnum start end))
+ (string-dispatch
+ ((simple-array character (*))
+ (simple-array base-char (*)))
+ string
+ (let* ((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))
+ (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
+ (ecase (array-element-type workspace)
+ (character (make-string new-length
+ :element-type 'character))
+ (base-char (make-string new-length
+ :element-type 'base-char)))))
+ (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 nil))
+ (setf (fill-pointer buffer) 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 arg2))
(if found
(- end (the fixnum found))
current)))))
- (:element-type (array-element-type
- (fill-pointer-output-stream-string stream)))))
-\f
-;;;; indenting streams
-
-(defstruct (indenting-stream (:include ansi-stream
- (out #'indenting-out)
- (sout #'indenting-sout)
- (misc #'indenting-misc))
- (:constructor make-indenting-stream (stream))
- (:copier nil))
- ;; the stream we're based on
- stream
- ;; how much we indent on each line
- (indentation 0))
-
-#!+sb-doc
-(setf (fdocumentation 'make-indenting-stream 'function)
- "Return an output stream which indents its output by some amount.")
-
-;;; INDENTING-INDENT writes the correct number of spaces needed to indent
-;;; output on the given STREAM based on the specified SUB-STREAM.
-(defmacro indenting-indent (stream sub-stream)
- ;; KLUDGE: bare magic number 60
- `(do ((i 0 (+ i 60))
- (indentation (indenting-stream-indentation ,stream)))
- ((>= i indentation))
- (%write-string
- #.(make-string 60 :initial-element #\Space)
- ,sub-stream
- 0
- (min 60 (- indentation i)))))
-
-;;; INDENTING-OUT writes a character to an indenting stream.
-(defun indenting-out (stream char)
- (let ((sub-stream (indenting-stream-stream stream)))
- (write-char char sub-stream)
- (if (char= char #\newline)
- (indenting-indent stream sub-stream))))
-
-;;; INDENTING-SOUT writes a string to an indenting stream.
-(defun indenting-sout (stream string start end)
- (declare (simple-string string) (fixnum start end))
- (do ((i start)
- (sub-stream (indenting-stream-stream stream)))
- ((= i end))
- (let ((newline (position #\newline string :start i :end end)))
- (cond (newline
- (%write-string string sub-stream i (1+ newline))
- (indenting-indent stream sub-stream)
- (setq i (+ newline 1)))
- (t
- (%write-string string sub-stream i end)
- (setq i end))))))
-
-;;; INDENTING-MISC just treats just the :LINE-LENGTH message
-;;; differently. INDENTING-CHARPOS says the charpos is the charpos of
-;;; the base stream minus the stream's indentation.
-(defun indenting-misc (stream operation &optional arg1 arg2)
- (let ((sub-stream (indenting-stream-stream stream)))
- (if (ansi-stream-p sub-stream)
- (let ((method (ansi-stream-misc sub-stream)))
- (case operation
- (:line-length
- (let ((line-length (funcall method sub-stream operation)))
- (if line-length
- (- line-length (indenting-stream-indentation stream)))))
- (:charpos
- (let ((charpos (funcall method sub-stream operation)))
- (if charpos
- (- charpos (indenting-stream-indentation stream)))))
- (t
- (funcall method sub-stream operation arg1 arg2))))
- ;; must be Gray streams FUNDAMENTAL-STREAM
- (case operation
- (:line-length
- (let ((line-length (stream-line-length sub-stream)))
- (if line-length
- (- line-length (indenting-stream-indentation stream)))))
- (:charpos
- (let ((charpos (stream-line-column sub-stream)))
- (if charpos
- (- charpos (indenting-stream-indentation stream)))))
- (t
- (stream-misc-dispatch sub-stream operation arg1 arg2))))))
-
-(declaim (maybe-inline read-char unread-char read-byte listen))
+ (:element-type
+ (array-element-type
+ (fill-pointer-output-stream-string stream)))))
\f
;;;; case frobbing streams, used by FORMAT ~(...~)
(refill-buffer))
(done-with-fast-read-char)
(return-from ansi-stream-read-string-from-frc-buffer
- read)))))
+ (+ start read))))))
(declare (inline refill-buffer))
(when (and (= %frc-index% +ansi-stream-in-buffer-length+)
(refill-buffer))
;; EOF had been reached before we read anything
;; at all. Return the EOF value or signal the error.
(done-with-fast-read-char)
- (return-from ansi-stream-read-string-from-frc-buffer 0))
+ (return-from ansi-stream-read-string-from-frc-buffer start))
(loop (add-chunk))))))
\f
projects / sbcl.git / blobdiff