(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
;; 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
(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
(setf workspace new-workspace
offset-current current)
(set-array-header buffer workspace new-length
- current+1 0 new-length nil))
+ current+1 0 new-length nil nil))
(setf (fill-pointer buffer) current+1))
(setf (char workspace offset-current) character))))
current+1))
offset-current current
offset-dst-end dst-end)
(set-array-header buffer workspace new-length
- dst-end 0 new-length nil))
+ dst-end 0 new-length nil nil))
(setf (fill-pointer buffer) dst-end))
(replace workspace string
:start1 offset-current :start2 start :end2 end)))
projects / sbcl.git / blobdiff