-;;; Basic functionality for ansi-streams. These are separate
-;;; functions because they are called in places where we already know
-;;; we operate on an ansi-stream (as opposed to a simple- or
-;;; gray-stream, or the symbols t or nil), so we can evade typecase
-;;; and (in|out)-synonym-of calls.
-
-(declaim (inline %ansi-stream-read-byte %ansi-stream-read-char
- %ansi-stream-unread-char %ansi-stream-read-line
- %ansi-stream-read-sequence))
-
-(defun %ansi-stream-read-byte (stream eof-error-p eof-value blocking)
- (declare (ignore blocking))
- #+nil
- (sb-kernel:ansi-stream-read-byte stream eof-error-p eof-value)
- (sb-int:prepare-for-fast-read-byte stream
- (prog1
- (sb-int:fast-read-byte eof-error-p eof-value t)
- (sb-int:done-with-fast-read-byte))))
-
-(defun %ansi-stream-read-char (stream eof-error-p eof-value blocking)
- (declare (ignore blocking))
- #+nil
- (sb-kernel:ansi-stream-read-char stream eof-error-p eof-value)
- (sb-int:prepare-for-fast-read-char stream
- (prog1
- (sb-int:fast-read-char eof-error-p eof-value)
- (sb-int:done-with-fast-read-char))))
-
-(defun %ansi-stream-unread-char (character stream)
- (let ((index (1- (sb-kernel:ansi-stream-in-index stream)))
- (buffer (sb-kernel: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 (sb-kernel:ansi-stream-in-index stream) index))
- (t
- (funcall (sb-kernel:ansi-stream-misc stream) stream
- :unread character)))))
-
-(defun %ansi-stream-read-line (stream eof-error-p eof-value)
- (sb-int:prepare-for-fast-read-char stream
- (let ((res (make-string 80))
- (len 80)
- (index 0))
- (loop
- (let ((ch (sb-int:fast-read-char nil nil)))
- (cond (ch
- (when (char= ch #\newline)
- (sb-int:done-with-fast-read-char)
- (return (values (sb-kernel:shrink-vector res index) nil)))
- (when (= index len)
- (setq len (* len 2))
- (let ((new (make-string len)))
- (replace new res)
- (setq res new)))
- (setf (schar res index) ch)
- (incf index))
- ((zerop index)
- (sb-int:done-with-fast-read-char)
- (return (values (sb-impl::eof-or-lose stream eof-error-p
- eof-value)
- t)))
- ;; Since FAST-READ-CHAR already hit the eof char, we
- ;; shouldn't do another READ-CHAR.
- (t
- (sb-int:done-with-fast-read-char)
- (return (values (sb-kernel:shrink-vector res index) t)))))))))
-
-(defun %ansi-stream-read-sequence (seq stream start %end)
- (declare (type sequence seq)
- (type sb-kernel:ansi-stream stream)
- (type sb-int:index start)
- (type sb-kernel:sequence-end %end)
- (values sb-int:index))
- (let ((end (or %end (length seq))))
- (declare (type sb-int:index end))
- (etypecase seq
- (list
- (let ((read-function
- (if (subtypep (stream-element-type stream) 'character)
- #'%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 sb-int:index i))
- (let ((el (funcall read-function stream nil :eof nil)))
- (when (eq el :eof)
- (return i))
- (setf (first rem) el)))))
- (vector
- (sb-kernel: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)
- (let* ((numbytes (- end start))
- (bytes-read (sb-sys: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)
- #'%ansi-stream-read-char
- #'%ansi-stream-read-byte)))
- (do ((i offset-start (1+ i)))
- ((>= i offset-end) end)
- (declare (type sb-int:index i))
- (let ((el (funcall read-function stream nil :eof nil)))
- (when (eq el :eof)
- (return (+ start (- i offset-start))))
- (setf (aref data i) el)))))))))))
-
-
-(defun %ansi-stream-write-string (string stream start end)
- (declare (type string string)
- (type sb-kernel:ansi-stream stream)
- (type sb-int: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 "~@<bad bounding indices START=~W END=~W for ~2I~_~S~:>"
- start
- end
- string))
-
- (if (sb-kernel:array-header-p string)
- (sb-kernel:with-array-data ((data string) (offset-start start)
- (offset-end end))
- (funcall (sb-kernel:ansi-stream-sout stream)
- stream data offset-start offset-end))
- (funcall (sb-kernel:ansi-stream-sout stream) stream string start end))
- string)
-
-(defun %ansi-stream-write-sequence (seq stream start %end)
- (declare (type sequence seq)
- (type sb-kernel:ansi-stream stream)
- (type sb-int:index start)
- (type sb-kernel:sequence-end %end)
- (values sequence))
- (let ((end (or %end (length seq))))
- (declare (type sb-int:index end))
- (etypecase seq
- (list
- (let ((write-function
- (if (subtypep (stream-element-type stream) 'character)
- ;; TODO: Replace these with ansi-stream specific
- ;; functions too.
- #'write-char
- #'write-byte)))
- (do ((rem (nthcdr start seq) (rest rem))
- (i start (1+ i)))
- ((or (endp rem) (>= i end)) seq)
- (declare (type list rem)
- (type sb-int:index i))
- (funcall write-function (first rem) stream))))
- (string
- (%ansi-stream-write-string seq stream start end))
- (vector
- (let ((write-function
- (if (subtypep (stream-element-type stream) 'character)
- ;; TODO: Replace these with ansi-stream specific
- ;; functions too.
- #'write-char
- #'write-byte)))
- (do ((i start (1+ i)))
- ((>= i end) seq)
- (declare (type sb-int:index i))
- (funcall write-function (aref seq i) stream)))))))
-