;;; **********************************************************************
;;; This code was written by Paul Foley and has been placed in the public
;;; domain.
-;;;
+;;;
;;; Sbcl port by Rudi Schlatte.
(defun %check (stream kind)
(declare (type simple-stream stream)
- (optimize (speed 3) (space 1) (debug 0) (safety 0)))
+ (optimize (speed 3) (space 1) (debug 0) (safety 0)))
(with-stream-class (simple-stream stream)
(cond ((not (any-stream-instance-flags stream :simple))
- (%uninitialized stream))
- ((and (eq kind :open)
- (not (any-stream-instance-flags stream :input :output)))
- (sb-kernel:closed-flame stream))
- ((and (or (eq kind :input) (eq kind :io))
- (not (any-stream-instance-flags stream :input)))
- (sb-kernel:ill-in stream))
- ((and (or (eq kind :output) (eq kind :io))
- (not (any-stream-instance-flags stream :output)))
- (sb-kernel:ill-out stream)))))
+ (%uninitialized stream))
+ ((and (eq kind :open)
+ (not (any-stream-instance-flags stream :input :output)))
+ (sb-kernel:closed-flame stream))
+ ((and (or (eq kind :input) (eq kind :io))
+ (not (any-stream-instance-flags stream :input)))
+ (sb-kernel:ill-in stream))
+ ((and (or (eq kind :output) (eq kind :io))
+ (not (any-stream-instance-flags stream :output)))
+ (sb-kernel:ill-out stream)))))
(defmethod input-stream-p ((stream simple-stream))
(any-stream-instance-flags stream :input))
(defun %file-position (stream position)
(declare (type simple-stream stream)
- (type (or (integer 0 *) (member nil :start :end)) position))
+ (type (or (integer 0 *) (member nil :start :end)) position))
(with-stream-class (simple-stream stream)
(%check stream :open)
(if position
- ;; Adjust current position
- (let ((position (case position (:start 0) (:end -1)
- (otherwise position))))
- (etypecase stream
- (single-channel-simple-stream
+ ;; Adjust current position
+ (let ((position (case position (:start 0) (:end -1)
+ (otherwise position))))
+ (etypecase stream
+ (single-channel-simple-stream
(when (sc-dirty-p stream)
(flush-buffer stream t)))
- (dual-channel-simple-stream
+ (dual-channel-simple-stream
(with-stream-class (dual-channel-simple-stream stream)
- (when (> (sm outpos stream) 0)
+ (when (> (sm outpos stream) 0)
(device-write stream :flush 0 nil t))))
- (string-simple-stream
+ (string-simple-stream
nil))
- (setf (sm last-char-read-size stream) 0)
- (setf (sm buffpos stream) 0 ; set pointer to 0 to force a read
- (sm buffer-ptr stream) 0)
- (setf (sm charpos stream) nil)
- (remove-stream-instance-flags stream :eof)
- (setf (device-file-position stream) position))
- ;; Just report current position
- (let ((posn (device-file-position stream)))
- (when posn
- (when (sm handler stream)
- (dolist (queued (sm pending stream))
- (incf posn (- (the sb-int:index (third queued))
- (the sb-int:index (second queued))))))
- (etypecase stream
- (single-channel-simple-stream
+ (setf (sm last-char-read-size stream) 0)
+ (setf (sm buffpos stream) 0 ; set pointer to 0 to force a read
+ (sm buffer-ptr stream) 0)
+ (setf (sm charpos stream) nil)
+ (remove-stream-instance-flags stream :eof)
+ (setf (device-file-position stream) position))
+ ;; Just report current position
+ (let ((posn (device-file-position stream)))
+ (when posn
+ (when (sm handler stream)
+ (dolist (queued (sm pending stream))
+ (incf posn (- (the sb-int:index (third queued))
+ (the sb-int:index (second queued))))))
+ (etypecase stream
+ (single-channel-simple-stream
(case (sm mode stream)
- ((0 3) ; read, read-modify
+ ((0 3) ; read, read-modify
;; Note that posn can increase here if we wrote
;; past the end of previously-read data
(decf posn (- (sm buffer-ptr stream) (sm buffpos stream))))
- (1 ; write
+ (1 ; write
(incf posn (sm buffpos stream)))))
- (dual-channel-simple-stream
+ (dual-channel-simple-stream
(with-stream-class (dual-channel-simple-stream stream)
- (incf posn (sm outpos stream))
+ (incf posn (sm outpos stream))
(when (>= (sm buffer-ptr stream) 0)
(decf posn (- (sm buffer-ptr stream) (sm buffpos stream))))))
- (string-simple-stream
+ (string-simple-stream
nil)))
- posn))))
+ posn))))
(defun %file-length (stream)
(declare (type simple-stream stream))
(%check stream nil)
(if (typep stream 'file-simple-stream)
(with-stream-class (file-simple-stream stream)
- (setf (sm pathname stream) new-name)
- (setf (sm filename stream) (sb-int:unix-namestring new-name nil))
- t)
+ (setf (sm pathname stream) new-name)
+ (setf (sm filename stream) (%file-namestring new-name))
+ t)
nil))
;; FIXME: need to account for compositions on the stream...
(let ((count 0))
(flet ((fn (octet)
- (declare (ignore octet))
- (incf count)))
- (etypecase object
- (character
- (let ((x nil))
- (char-to-octets (sm external-format stream) object x #'fn)))
- (string
- (let ((x nil)
- (ef (sm external-format stream)))
- (dotimes (i (length object))
- (declare (type sb-int:index i))
- (char-to-octets ef (char object i) x #'fn))))))
+ (declare (ignore octet))
+ (incf count)))
+ (etypecase object
+ (character
+ (let ((x nil))
+ (char-to-octets (sm external-format stream) object x #'fn)))
+ (string
+ (let ((x nil)
+ (ef (sm external-format stream)))
+ (dotimes (i (length object))
+ (declare (type sb-int:index i))
+ (char-to-octets ef (char object i) x #'fn))))))
count)))
(defun %read-line (stream eof-error-p eof-value recursive-p)
(declare (optimize (speed 3) (space 1) (safety 0) (debug 0))
- (type simple-stream stream)
- (ignore recursive-p))
+ (type simple-stream stream)
+ (ignore recursive-p))
(with-stream-class (simple-stream stream)
(%check stream :input)
(when (any-stream-instance-flags stream :eof)
(return-from %read-line
- (sb-impl::eof-or-lose stream eof-error-p eof-value)))
+ (sb-impl::eof-or-lose stream eof-error-p eof-value)))
;; for interactive streams, finish output first to force prompt
(when (and (any-stream-instance-flags stream :output)
- (any-stream-instance-flags stream :interactive))
+ (any-stream-instance-flags stream :interactive))
(%finish-output stream))
(let* ((encap (sm melded-stream stream)) ; encapsulating stream
- (cbuf (make-string 80)) ; current buffer
- (bufs (list cbuf)) ; list of buffers
- (tail bufs) ; last cons of bufs list
- (index 0) ; current index in current buffer
- (total 0)) ; total characters
+ (cbuf (make-string 80)) ; current buffer
+ (bufs (list cbuf)) ; list of buffers
+ (tail bufs) ; last cons of bufs list
+ (index 0) ; current index in current buffer
+ (total 0)) ; total characters
(declare (type simple-stream encap)
- (type simple-base-string cbuf)
- (type cons bufs tail)
- (type sb-int:index index total))
+ (type simple-string cbuf)
+ (type cons bufs tail)
+ (type sb-int:index index total))
(loop
- (multiple-value-bind (chars done)
- (funcall-stm-handler j-read-chars encap cbuf
- #\Newline index (length cbuf) t)
- (declare (type sb-int:index chars))
- (incf index chars)
- (incf total chars)
- (when (and (eq done :eof) (zerop total))
- (if eof-error-p
- (error 'end-of-file :stream stream)
- (return (values eof-value t))))
- (when done
- ;; If there's only one buffer in use, return it directly
- (when (null (cdr bufs))
- (return (values (sb-kernel:shrink-vector cbuf total)
- (eq done :eof))))
- ;; If total fits in final buffer, use it
- (when (<= total (length cbuf))
- (replace cbuf cbuf :start1 (- total index) :end2 index)
- (let ((idx 0))
- (declare (type sb-int:index idx))
- (do ((list bufs (cdr list)))
- ((eq list tail))
- (let ((buf (car list)))
- (declare (type simple-base-string buf))
- (replace cbuf buf :start1 idx)
- (incf idx (length buf)))))
- (return (values (sb-kernel:shrink-vector cbuf total)
- (eq done :eof))))
- ;; Allocate new string of appropriate length
- (let ((string (make-string total))
- (index 0))
- (declare (type sb-int:index index))
- (dolist (buf bufs)
- (declare (type simple-base-string buf))
- (replace string buf :start1 index)
- (incf index (length buf)))
- (return (values string (eq done :eof)))))
- (when (>= index (length cbuf))
- (setf cbuf (make-string (the sb-int:index (* 2 index))))
- (setf index 0)
- (setf (cdr tail) (cons cbuf nil))
- (setf tail (cdr tail))))))))
+ (multiple-value-bind (chars done)
+ (funcall-stm-handler j-read-chars encap cbuf
+ #\Newline index (length cbuf) t)
+ (declare (type sb-int:index chars))
+ (incf index chars)
+ (incf total chars)
+ (when (and (eq done :eof) (zerop total))
+ (if eof-error-p
+ (error 'end-of-file :stream stream)
+ (return (values eof-value t))))
+ (when done
+ ;; If there's only one buffer in use, return it directly
+ (when (null (cdr bufs))
+ (return (values (sb-kernel:shrink-vector cbuf total)
+ (eq done :eof))))
+ ;; If total fits in final buffer, use it
+ (when (<= total (length cbuf))
+ (replace cbuf cbuf :start1 (- total index) :end2 index)
+ (let ((idx 0))
+ (declare (type sb-int:index idx))
+ (do ((list bufs (cdr list)))
+ ((eq list tail))
+ (let ((buf (car list)))
+ (declare (type simple-string buf))
+ (replace cbuf buf :start1 idx)
+ (incf idx (length buf)))))
+ (return (values (sb-kernel:shrink-vector cbuf total)
+ (eq done :eof))))
+ ;; Allocate new string of appropriate length
+ (let ((string (make-string total))
+ (index 0))
+ (declare (type sb-int:index index))
+ (dolist (buf bufs)
+ (declare (type simple-string buf))
+ (replace string buf :start1 index)
+ (incf index (length buf)))
+ (return (values string (eq done :eof)))))
+ (when (>= index (length cbuf))
+ (setf cbuf (make-string (the sb-int:index (* 2 index))))
+ (setf index 0)
+ (setf (cdr tail) (cons cbuf nil))
+ (setf tail (cdr tail))))))))
(defun %read-char (stream eof-error-p eof-value recursive-p blocking-p)
(declare (type simple-stream stream)
- (ignore recursive-p))
+ (ignore recursive-p))
(with-stream-class (simple-stream stream)
(%check stream :input)
(when (any-stream-instance-flags stream :eof)
(return-from %read-char
- (sb-impl::eof-or-lose stream eof-error-p eof-value)))
+ (sb-impl::eof-or-lose stream eof-error-p eof-value)))
;; for interactive streams, finish output first to force prompt
(when (and (any-stream-instance-flags stream :output)
- (any-stream-instance-flags stream :interactive))
+ (any-stream-instance-flags stream :interactive))
(%finish-output stream))
(funcall-stm-handler j-read-char (sm melded-stream stream)
- eof-error-p eof-value blocking-p)))
+ eof-error-p eof-value blocking-p)))
(defun %unread-char (stream character)
(with-stream-class (simple-stream stream)
(%check stream :input)
(if (zerop (sm last-char-read-size stream))
- (error "Nothing to unread.")
- (progn
- (funcall-stm-handler j-unread-char (sm melded-stream stream) nil)
- (remove-stream-instance-flags stream :eof)
- (setf (sm last-char-read-size stream) 0)))))
+ (error "Nothing to unread.")
+ (progn
+ (funcall-stm-handler j-unread-char (sm melded-stream stream) nil)
+ (remove-stream-instance-flags stream :eof)
+ (setf (sm last-char-read-size stream) 0)))))
(defun %peek-char (stream peek-type eof-error-p eof-value recursive-p)
(declare (type simple-stream stream)
- (ignore recursive-p))
+ (ignore recursive-p))
(with-stream-class (simple-stream stream)
(%check stream :input)
(when (any-stream-instance-flags stream :eof)
(return-from %peek-char
- (sb-impl::eof-or-lose stream eof-error-p eof-value)))
+ (sb-impl::eof-or-lose stream eof-error-p eof-value)))
(let* ((encap (sm melded-stream stream))
- (char (funcall-stm-handler j-read-char encap
- eof-error-p stream t)))
+ (char (funcall-stm-handler j-read-char encap
+ eof-error-p stream t)))
(cond ((eq char stream) eof-value)
- ((characterp peek-type)
- (do ((char char (funcall-stm-handler j-read-char encap
- eof-error-p
- stream t)))
- ((or (eq char stream) (char= char peek-type))
- (unless (eq char stream)
- (funcall-stm-handler j-unread-char encap t))
- (if (eq char stream) eof-value char))))
- ((eq peek-type t)
- (do ((char char (funcall-stm-handler j-read-char encap
- eof-error-p
- stream t)))
- ((or (eq char stream)
- (not (sb-impl::whitespacep char)))
- (unless (eq char stream)
- (funcall-stm-handler j-unread-char encap t))
- (if (eq char stream) eof-value char))))
- (t
- (funcall-stm-handler j-unread-char encap t)
- char)))))
+ ((characterp peek-type)
+ (do ((char char (funcall-stm-handler j-read-char encap
+ eof-error-p
+ stream t)))
+ ((or (eq char stream) (char= char peek-type))
+ (unless (eq char stream)
+ (funcall-stm-handler j-unread-char encap t))
+ (if (eq char stream) eof-value char))))
+ ((eq peek-type t)
+ (do ((char char (funcall-stm-handler j-read-char encap
+ eof-error-p
+ stream t)))
+ ((or (eq char stream)
+ (not (sb-impl::whitespace[2]p char)))
+ (unless (eq char stream)
+ (funcall-stm-handler j-unread-char encap t))
+ (if (eq char stream) eof-value char))))
+ (t
+ (funcall-stm-handler j-unread-char encap t)
+ char)))))
(defun %listen (stream width)
(declare (type simple-stream stream))
(when (any-stream-instance-flags stream :eof)
(return-from %listen nil))
(if (not (or (eql width 1) (null width)))
- (funcall-stm-handler j-listen (sm melded-stream stream))
- (or (< (sm buffpos stream) (sm buffer-ptr stream))
- (when (or (not (any-stream-instance-flags stream :dual :string))
- (>= (sm mode stream) 0)) ;; device-connected @@ single-channel
- (let ((lcrs (sm last-char-read-size stream)))
- (unwind-protect
- (progn
- (setf (sm last-char-read-size stream) (1+ lcrs))
- (plusp (refill-buffer stream nil)))
- (setf (sm last-char-read-size stream) lcrs))))))))
+ (funcall-stm-handler j-listen (sm melded-stream stream))
+ (or (< (sm buffpos stream) (sm buffer-ptr stream))
+ ;; Attempt buffer refill
+ (when (and (not (any-stream-instance-flags stream :dual :string))
+ (>= (sm mode stream) 0))
+ ;; single-channel stream dirty -> write data before reading
+ (flush-buffer stream nil))
+ (>= (refill-buffer stream nil) width)))))
(defun %clear-input (stream buffer-only)
(declare (type simple-stream stream))
(with-stream-class (simple-stream stream)
(%check stream :input)
(setf (sm buffpos stream) 0
- (sm buffer-ptr stream) 0
- (sm last-char-read-size stream) 0
- #|(sm unread-past-soft-eof stream) nil|#)
+ (sm buffer-ptr stream) 0
+ (sm last-char-read-size stream) 0
+ #|(sm unread-past-soft-eof stream) nil|#)
#| (setf (sm reread-count stream) 0) on dual-channel streams? |#
)
(device-clear-input stream buffer-only))
(with-stream-class (simple-stream stream)
(%check stream :input)
(if (any-stream-instance-flags stream :eof)
- (sb-impl::eof-or-lose stream eof-error-p eof-value)
- (etypecase stream
- (single-channel-simple-stream
+ (sb-impl::eof-or-lose stream eof-error-p eof-value)
+ (etypecase stream
+ (single-channel-simple-stream
(read-byte-internal stream eof-error-p eof-value t))
(dual-channel-simple-stream
(read-byte-internal stream eof-error-p eof-value t))
- (string-simple-stream
+ (string-simple-stream
(with-stream-class (string-simple-stream stream)
- (let ((encap (sm input-handle stream)))
+ (let ((encap (sm input-handle stream)))
(unless encap
(error 'simple-type-error
:datum stream
(with-stream-class (simple-stream stream)
(%check stream :output)
(funcall-stm-handler-2 j-write-chars string (sm melded-stream stream)
- start end)))
+ start end)))
(defun %line-length (stream)
(%check stream :output)
(when (sm handler stream)
(do ()
- ((null (sm pending stream)))
- (sb-sys:serve-all-events)))
+ ((null (sm pending stream)))
+ (sb-sys:serve-all-events)))
(etypecase stream
(single-channel-simple-stream
;(when (and (> (sm mode stream) 0) (> (sm buffer-ptr stream) 0))
(dual-channel-simple-stream
(with-stream-class (dual-channel-simple-stream stream)
(device-write stream :flush 0 nil t)
- (setf (sm outpos stream) 0)))
+ (setf (sm outpos stream) 0)))
(string-simple-stream
(device-write stream :flush 0 nil t))))
nil)
(dual-channel-simple-stream
(with-stream-class (dual-channel-simple-stream stream)
(device-write stream :flush 0 nil nil)
- (setf (sm outpos stream) 0)))
+ (setf (sm outpos stream) 0)))
(string-simple-stream
(device-write stream :flush 0 nil nil))))
nil)
(when (sm handler stream)
(sb-sys:remove-fd-handler (sm handler stream))
(setf (sm handler stream) nil
- (sm pending stream) nil))
+ (sm pending stream) nil))
(etypecase stream
(single-channel-simple-stream
(with-stream-class (single-channel-simple-stream stream)
- (case (sm mode stream)
+ (case (sm mode stream)
(1 (setf (sm buffpos stream) 0))
(3 (setf (sm mode stream) 0)))))
(dual-channel-simple-stream
(etypecase stream
(single-channel-simple-stream
(with-stream-class (single-channel-simple-stream stream)
- (let ((ptr (sm buffpos stream)))
- (when (>= ptr (sm buf-len stream))
- (setf ptr (flush-buffer stream t)))
- (setf (sm buffpos stream) (1+ ptr))
+ (let ((ptr (sm buffpos stream)))
+ (when (>= ptr (sm buf-len stream))
+ (setf ptr (flush-buffer stream t)))
+ (setf (sm buffpos stream) (1+ ptr))
(setf (sm charpos stream) nil)
- (setf (bref (sm buffer stream) ptr) integer)
+ (setf (bref (sm buffer stream) ptr) integer)
(sc-set-dirty stream))))
(dual-channel-simple-stream
(with-stream-class (dual-channel-simple-stream stream)
- (let ((ptr (sm outpos stream)))
+ (let ((ptr (sm outpos stream)))
(when (>= ptr (sm max-out-pos stream))
(setf ptr (flush-out-buffer stream t)))
(setf (sm outpos stream) (1+ ptr))
(setf (bref (sm out-buffer stream) ptr) integer))))
(string-simple-stream
(with-stream-class (string-simple-stream stream)
- (let ((encap (sm output-handle stream)))
+ (let ((encap (sm output-handle stream)))
(unless encap
(error 'simple-type-error
:datum stream
(defun %read-sequence (stream seq start end partial-fill)
(declare (type simple-stream stream)
- (type sequence seq)
- (type sb-int:index start end)
- (type boolean partial-fill))
+ (type sequence seq)
+ (type sb-int:index start end)
+ (type boolean partial-fill))
(with-stream-class (simple-stream stream)
(%check stream :input)
(when (any-stream-instance-flags stream :eof)
(etypecase seq
(string
(funcall-stm-handler j-read-chars (sm melded-stream stream) seq nil
- start end
- (if partial-fill :bnb t)))
+ start end
+ (if partial-fill :bnb t)))
((or (simple-array (unsigned-byte 8) (*))
- (simple-array (signed-byte 8) (*)))
+ (simple-array (signed-byte 8) (*)))
(when (any-stream-instance-flags stream :string)
- (error "Can't read into byte sequence from a string stream."))
+ (error "Can't read into byte sequence from a string stream."))
;; "read-vector" equivalent, but blocking if partial-fill is NIL
;; FIXME: this could be implemented faster via buffer-copy
(loop with encap = (sm melded-stream stream)
(defun %write-sequence (stream seq start end)
(declare (type simple-stream stream)
- (type sequence seq)
- (type sb-int:index start end))
+ (type sequence seq)
+ (type sb-int:index start end))
(with-stream-class (simple-stream stream)
(%check stream :output)
(etypecase seq
(string
(funcall-stm-handler-2 j-write-chars seq (sm melded-stream stream)
- start end))
+ start end))
((or (simple-array (unsigned-byte 8) (*))
- (simple-array (signed-byte 8) (*)))
+ (simple-array (signed-byte 8) (*)))
;; "write-vector" equivalent
(setf (sm charpos stream) nil)
(etypecase stream
(defun read-vector (vector stream &key (start 0) end (endian-swap :byte-8))
(declare (type (sb-kernel:simple-unboxed-array (*)) vector)
- (type stream stream))
+ (type stream stream))
;; START and END are octet offsets, not vector indices! [Except for strings]
;; Return value is index of next octet to be read into (i.e., start+count)
(etypecase stream
(index (or start 0) (1+ index))
(end (or end (* (length vector) (vector-elt-width vector))))
(endian-swap (endian-swap-value vector endian-swap))
- (byte (read-byte-internal encap nil nil t)
- (read-byte-internal encap nil nil nil)))
- ((or (null byte) (>= index end)) index)
- (setf (bref vector (logxor index endian-swap)) byte))))))
+ (flag t nil))
+ ((>= index end) index)
+ (let ((byte (read-byte-internal encap nil nil flag)))
+ (unless byte
+ (return index))
+ (setf (bref vector (logxor index endian-swap)) byte)))))))
((or ansi-stream fundamental-stream)
(unless (typep vector '(or string
- (simple-array (signed-byte 8) (*))
- (simple-array (unsigned-byte 8) (*))))
+ (simple-array (signed-byte 8) (*))
+ (simple-array (unsigned-byte 8) (*))))
(error "Wrong vector type for read-vector on stream not of type simple-stream."))
(read-sequence vector stream :start (or start 0) :end end))))
-;;; 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)))))))
-
;;;
;;; USER-LEVEL FUNCTIONS
:output-handle - a stream or Unix file descriptor to write to"
(declare (ignore element-type external-format input-handle output-handle
if-exists if-does-not-exist))
- (let ((class (or class 'sb-sys::file-stream))
- (options (copy-list options))
+ (let ((class (or class 'sb-sys:fd-stream))
+ (options (copy-list options))
(filespec (merge-pathnames filename)))
- (cond ((eq class 'sb-sys::file-stream)
- (remf options :class)
+ (cond ((eq class 'sb-sys:fd-stream)
+ (remf options :class)
(remf options :mapped)
(remf options :input-handle)
(remf options :output-handle)
(apply #'open-fd-stream filespec options))
- ((subtypep class 'simple-stream)
- (when element-type-given
+ ((subtypep class 'simple-stream)
+ (when element-type-given
(cerror "Do it anyway."
"Can't create simple-streams with an element-type."))
(when (and (eq class 'file-simple-stream) mapped)
(when (eq direction :probe)
(setq class 'probe-simple-stream)))
(apply #'make-instance class :filename filespec options))
- ((subtypep class 'sb-gray:fundamental-stream)
- (remf options :class)
+ ((subtypep class 'sb-gray:fundamental-stream)
+ (remf options :class)
(remf options :mapped)
(remf options :input-handle)
(remf options :output-handle)
- (make-instance class :lisp-stream
- (apply #'open-fd-stream filespec options))))))
+ (make-instance class :lisp-stream
+ (apply #'open-fd-stream filespec options)))
+ (t (error "Don't know how to handle the stream class ~A"
+ (etypecase class
+ (symbol (find-class class t))
+ (class class)))))))
(declaim (inline read-byte read-char read-char-no-hang unread-char))
(simple-stream
(%read-byte stream eof-error-p eof-value))
(ansi-stream
- (%ansi-stream-read-byte stream eof-error-p eof-value t))
+ (sb-impl::ansi-stream-read-byte stream eof-error-p eof-value nil))
(fundamental-stream
(let ((char (sb-gray:stream-read-byte stream)))
- (if (eq char :eof)
- (sb-impl::eof-or-lose stream eof-error-p eof-value)
- char))))))
+ (if (eq char :eof)
+ (sb-impl::eof-or-lose stream eof-error-p eof-value)
+ char))))))
(defun read-char (&optional (stream *standard-input*) (eof-error-p t)
- eof-value recursive-p)
+ eof-value recursive-p)
"Inputs a character from Stream and returns it."
(let ((stream (sb-impl::in-synonym-of stream)))
(etypecase stream
(simple-stream
(%read-char stream eof-error-p eof-value recursive-p t))
(ansi-stream
- (%ansi-stream-read-char stream eof-error-p eof-value t))
+ (sb-impl::ansi-stream-read-char stream eof-error-p eof-value
+ recursive-p))
(fundamental-stream
(let ((char (sb-gray:stream-read-char stream)))
- (if (eq char :eof)
- (sb-impl::eof-or-lose stream eof-error-p eof-value)
- char))))))
+ (if (eq char :eof)
+ (sb-impl::eof-or-lose stream eof-error-p eof-value)
+ char))))))
(defun read-char-no-hang (&optional (stream *standard-input*) (eof-error-p t)
- eof-value recursive-p)
+ eof-value recursive-p)
"Returns the next character from the Stream if one is availible, or nil."
- (declare (ignore recursive-p))
(let ((stream (sb-impl::in-synonym-of stream)))
(etypecase stream
(simple-stream
(%check stream :input)
(with-stream-class (simple-stream)
- (funcall-stm-handler j-read-char stream eof-error-p eof-value nil)))
+ (funcall-stm-handler j-read-char stream eof-error-p eof-value nil)))
(ansi-stream
- (if (funcall (sb-kernel:ansi-stream-misc stream) stream :listen)
- (%ansi-stream-read-char stream eof-error-p eof-value t)
- nil))
+ (sb-impl::ansi-stream-read-char-no-hang stream eof-error-p eof-value
+ recursive-p))
(fundamental-stream
(let ((char (sb-gray:stream-read-char-no-hang stream)))
- (if (eq char :eof)
- (sb-impl::eof-or-lose stream eof-error-p eof-value)
- char))))))
+ (if (eq char :eof)
+ (sb-impl::eof-or-lose stream eof-error-p eof-value)
+ char))))))
(defun unread-char (character &optional (stream *standard-input*))
"Puts the Character back on the front of the input Stream."
(simple-stream
(%unread-char stream character))
(ansi-stream
- (%ansi-stream-unread-char character stream))
+ (sb-impl::ansi-stream-unread-char character stream))
(fundamental-stream
(sb-gray:stream-unread-char stream character))))
nil)
(declaim (notinline read-byte read-char read-char-no-hang unread-char))
(defun peek-char (&optional (peek-type nil) (stream *standard-input*)
- (eof-error-p t) eof-value recursive-p)
+ (eof-error-p t) eof-value recursive-p)
"Peeks at the next character in the input Stream. See manual for details."
(let ((stream (sb-impl::in-synonym-of stream)))
(etypecase stream
;; FIXME: Broken on ECHO-STREAM (cf internal implementation?) --
;; CSR, 2004-01-19
(ansi-stream
- (let ((char (%ansi-stream-read-char stream eof-error-p eof-value t)))
- (cond ((eq char eof-value) char)
- ((characterp peek-type)
- (do ((char char (%ansi-stream-read-char stream eof-error-p
- eof-value t)))
- ((or (eq char eof-value) (char= char peek-type))
- (unless (eq char eof-value)
- (%ansi-stream-unread-char char stream))
- char)))
- ((eq peek-type t)
- (do ((char char (%ansi-stream-read-char stream eof-error-p
- eof-value t)))
- ((or (eq char eof-value)
- (not (sb-impl::whitespacep char)))
- (unless (eq char eof-value)
- (%ansi-stream-unread-char char stream))
- char)))
- (t
- (%ansi-stream-unread-char char stream)
- char))))
+ (sb-impl::ansi-stream-peek-char peek-type stream eof-error-p eof-value
+ recursive-p))
(fundamental-stream
(cond ((characterp peek-type)
- (do ((char (sb-gray:stream-read-char stream)
- (sb-gray:stream-read-char stream)))
- ((or (eq char :eof) (char= char peek-type))
- (cond ((eq char :eof)
- (sb-impl::eof-or-lose stream eof-error-p eof-value))
- (t
- (sb-gray:stream-unread-char stream char)
- char)))))
- ((eq peek-type t)
- (do ((char (sb-gray:stream-read-char stream)
- (sb-gray:stream-read-char stream)))
- ((or (eq char :eof) (not (sb-impl::whitespacep char)))
- (cond ((eq char :eof)
- (sb-impl::eof-or-lose stream eof-error-p eof-value))
- (t
- (sb-gray:stream-unread-char stream char)
- char)))))
- (t
- (let ((char (sb-gray:stream-peek-char stream)))
- (if (eq char :eof)
- (sb-impl::eof-or-lose stream eof-error-p eof-value)
- char))))))))
+ (do ((char (sb-gray:stream-read-char stream)
+ (sb-gray:stream-read-char stream)))
+ ((or (eq char :eof) (char= char peek-type))
+ (cond ((eq char :eof)
+ (sb-impl::eof-or-lose stream eof-error-p eof-value))
+ (t
+ (sb-gray:stream-unread-char stream char)
+ char)))))
+ ((eq peek-type t)
+ (do ((char (sb-gray:stream-read-char stream)
+ (sb-gray:stream-read-char stream)))
+ ((or (eq char :eof) (not (sb-impl::whitespace[2]p char)))
+ (cond ((eq char :eof)
+ (sb-impl::eof-or-lose stream eof-error-p eof-value))
+ (t
+ (sb-gray:stream-unread-char stream char)
+ char)))))
+ (t
+ (let ((char (sb-gray:stream-peek-char stream)))
+ (if (eq char :eof)
+ (sb-impl::eof-or-lose stream eof-error-p eof-value)
+ char))))))))
(defun listen (&optional (stream *standard-input*) (width 1))
- "Returns T if Width octets are available on the given Stream. If Width
- is given as 'character, check for a character."
+ "Returns T if WIDTH octets are available on STREAM. If WIDTH is
+given as 'CHARACTER, check for a character. Note: the WIDTH argument
+is supported only on simple-streams."
;; WIDTH is number of octets which must be available; any value
;; other than 1 is treated as 'character.
(let ((stream (sb-impl::in-synonym-of stream)))
(simple-stream
(%listen stream width))
(ansi-stream
- (or (/= (the fixnum (sb-kernel:ansi-stream-in-index stream))
- sb-impl::+ansi-stream-in-buffer-length+)
- ;; Test for T explicitly since misc methods return :EOF sometimes.
- (eq (funcall (sb-kernel:ansi-stream-misc stream) stream :listen)
- t)))
+ (sb-impl::ansi-stream-listen stream))
(fundamental-stream
(sb-gray:stream-listen stream)))))
(defun read-line (&optional (stream *standard-input*) (eof-error-p t)
- eof-value recursive-p)
+ eof-value recursive-p)
"Returns a line of text read from the Stream as a string, discarding the
newline character."
(let ((stream (sb-impl::in-synonym-of stream)))
(simple-stream
(%read-line stream eof-error-p eof-value recursive-p))
(ansi-stream
- (%ansi-stream-read-line stream eof-error-p eof-value))
+ (sb-impl::ansi-stream-read-line stream eof-error-p eof-value
+ recursive-p))
(fundamental-stream
(multiple-value-bind (string eof) (sb-gray:stream-read-line stream)
- (if (and eof (zerop (length string)))
- (values (sb-impl::eof-or-lose stream eof-error-p eof-value) t)
- (values string eof)))))))
+ (if (and eof (zerop (length string)))
+ (values (sb-impl::eof-or-lose stream eof-error-p eof-value) t)
+ (values string eof)))))))
(defun read-sequence (seq stream &key (start 0) (end nil) partial-fill)
"Destructively modify SEQ by reading elements from STREAM.
then the extra elements near the end of sequence are not updated, and
the index of the next element is returned."
(let ((stream (sb-impl::in-synonym-of stream))
- (end (or end (length seq))))
+ (end (or end (length seq))))
(etypecase stream
(simple-stream
(with-stream-class (simple-stream stream)
- (%read-sequence stream seq start end partial-fill)))
+ (%read-sequence stream seq start end partial-fill)))
(ansi-stream
- (%ansi-stream-read-sequence seq stream start end))
+ (sb-impl::ansi-stream-read-sequence seq stream start end))
(fundamental-stream
(sb-gray:stream-read-sequence stream seq start end)))))
(simple-stream
(%clear-input stream buffer-only))
(ansi-stream
- (setf (sb-kernel:ansi-stream-in-index stream)
- sb-impl::+ansi-stream-in-buffer-length+)
- (funcall (sb-kernel:ansi-stream-misc stream) stream :clear-input))
+ (sb-impl::ansi-stream-clear-input stream))
(fundamental-stream
(sb-gray:stream-clear-input stream))))
nil)
character)
(defun write-string (string &optional (stream *standard-output*)
- &key (start 0) (end nil))
+ &key (start 0) (end nil))
"Outputs the String to the given Stream."
(let ((stream (sb-impl::out-synonym-of stream))
- (end (or end (length string))))
+ (end (sb-impl::%check-vector-sequence-bounds string start end)))
(etypecase stream
(simple-stream
(%write-string stream string start end)
string)
(ansi-stream
- (%ansi-stream-write-string string stream start end))
+ (sb-impl::ansi-stream-write-string string stream start end))
(fundamental-stream
(sb-gray:stream-write-string stream string start 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 ((stream (sb-impl::out-synonym-of stream))
- (end (or end (length string))))
+ (end (sb-impl::%check-vector-sequence-bounds string start end)))
(etypecase stream
(simple-stream
(%check stream :output)
(with-stream-class (simple-stream stream)
- (funcall-stm-handler-2 j-write-chars string stream start end)
- (funcall-stm-handler-2 j-write-char #\Newline stream)))
+ (funcall-stm-handler-2 j-write-chars string stream start end)
+ (funcall-stm-handler-2 j-write-char #\Newline stream)))
(ansi-stream
- (%ansi-stream-write-string string stream start end)
+ (sb-impl::ansi-stream-write-string string stream start end)
(funcall (sb-kernel:ansi-stream-out stream) stream #\Newline))
(fundamental-stream
(sb-gray:stream-write-string stream string start end)
(defun write-sequence (seq stream &key (start 0) (end nil))
"Write the elements of SEQ bounded by START and END to STREAM."
(let ((stream (sb-impl::out-synonym-of stream))
- (end (or end (length seq))))
+ (end (or end (length seq))))
(etypecase stream
(simple-stream
(%write-sequence stream seq start end))
(ansi-stream
- (%ansi-stream-write-sequence seq stream start end))
+ (sb-impl::ansi-stream-write-sequence seq stream start end))
(fundamental-stream
(sb-gray:stream-write-sequence stream seq start end)))))
(simple-stream
(%check stream :output)
(with-stream-class (simple-stream stream)
- (funcall-stm-handler-2 j-write-char #\Newline stream)))
+ (funcall-stm-handler-2 j-write-char #\Newline stream)))
(ansi-stream
(funcall (sb-kernel:ansi-stream-out stream) stream #\Newline))
(fundamental-stream
(simple-stream
(%fresh-line stream))
(ansi-stream
- (when (/= (or (sb-kernel:charpos stream) 1) 0)
- (funcall (sb-kernel:ansi-stream-out stream) stream #\Newline)
- t))
+ (sb-impl::ansi-stream-fresh-line stream))
(fundamental-stream
(sb-gray:stream-fresh-line stream)))))
File-Stream is open to. If the second argument is supplied, then
this becomes the new file position. The second argument may also
be :start or :end for the start and end of the file, respectively."
- (declare (type (or (integer 0 *) (member nil :start :end)) position))
+ (declare (type (or sb-int:index (member nil :start :end)) position))
(etypecase stream
(simple-stream
(%file-position stream position))
(ansi-stream
- (cond
- (position
- (setf (sb-kernel:ansi-stream-in-index stream)
- sb-impl::+ansi-stream-in-buffer-length+)
- (funcall (sb-kernel:ansi-stream-misc stream)
- stream :file-position position))
- (t
- (let ((res (funcall (sb-kernel:ansi-stream-misc stream)
- stream :file-position nil)))
- (when res
- (- res
- (- sb-impl::+ansi-stream-in-buffer-length+
- (sb-kernel:ansi-stream-in-index stream))))))))))
+ (sb-impl::ansi-stream-file-position stream position))))
(defun file-length (stream)
"This function returns the length of the file that File-Stream is open to."
(simple-stream
(%file-length stream))
(ansi-stream
- (progn (sb-impl::stream-must-be-associated-with-file stream)
- (funcall (sb-kernel:ansi-stream-misc stream) stream :file-length)))))
+ (sb-impl::stream-must-be-associated-with-file stream)
+ (funcall (sb-kernel:ansi-stream-misc stream) stream :file-length))))
(defun charpos (&optional (stream *standard-output*))
"Returns the number of characters on the current line of output of the given
(simple-stream
(%check stream :input)
(with-stream-class (simple-stream stream)
- (or (< (sm buffpos stream) (sm buffer-ptr stream))
- (wait-for-input-available (sm input-handle stream) timeout))))
+ (or (< (sm buffpos stream) (sm buffer-ptr stream))
+ (wait-for-input-available (sm input-handle stream) timeout))))
(two-way-stream
(wait-for-input-available (two-way-stream-input-stream stream) timeout))
(synonym-stream
(wait-for-input-available (symbol-value (synonym-stream-symbol stream))
- timeout))
- (sb-sys::file-stream
+ timeout))
+ (sb-sys:fd-stream
(or (< (sb-impl::fd-stream-in-index stream)
- (length (sb-impl::fd-stream-in-buffer stream)))
- (wait-for-input-available (sb-sys:fd-stream-fd stream) timeout))))))
+ (length (sb-impl::fd-stream-in-buffer stream)))
+ (wait-for-input-available (sb-sys:fd-stream-fd stream) timeout))))))
;; Make PATHNAME and NAMESTRING work
(defun sb-int:file-name (stream &optional new-name)
(with-stream-class (file-simple-stream stream)
(cond (new-name
(%file-rename stream new-name))
- (t
- (%file-name stream)))))
- (sb-sys::file-stream
+ (t
+ (%file-name stream)))))
+ (sb-sys:fd-stream
(cond (new-name
- (setf (sb-impl::fd-stream-pathname stream) new-name)
- (setf (sb-impl::fd-stream-file stream)
- (sb-int:unix-namestring new-name nil))
- t)
- (t
- (sb-impl::fd-stream-pathname stream))))))
+ (setf (sb-impl::fd-stream-pathname stream) new-name)
+ (setf (sb-impl::fd-stream-file stream)
+ (%file-namestring new-name))
+ t)
+ (t
+ (sb-impl::fd-stream-pathname stream))))))
projects / sbcl.git / blobdiff