X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ffd-stream.lisp;h=54c7c51359b3ca998706f7013d7593d3a6cf95f9;hb=4fa1c71c7dfa5c6d361304321cc67069a6410694;hp=6e2b2b4b7720d119cfd5e19e9cf4256407ecf77d;hpb=c1b609d072224eddf850a0e3f85e578c6919117f;p=sbcl.git diff --git a/src/code/fd-stream.lisp b/src/code/fd-stream.lisp index 6e2b2b4..54c7c51 100644 --- a/src/code/fd-stream.lisp +++ b/src/code/fd-stream.lisp @@ -11,40 +11,127 @@ (in-package "SB!IMPL") -;;;; buffer manipulation routines +;;;; BUFFER +;;;; +;;;; Streams hold BUFFER objects, which contain a SAP, size of the +;;;; memory area the SAP stands for (LENGTH bytes), and HEAD and TAIL +;;;; indexes which delimit the "valid", or "active" area of the +;;;; memory. HEAD is inclusive, TAIL is exclusive. +;;;; +;;;; Buffers get allocated lazily, and are recycled by returning them +;;;; to the *AVAILABLE-BUFFERS* list. Every buffer has it's own +;;;; finalizer, to take care of releasing the SAP memory when a stream +;;;; is not properly closed. +;;;; +;;;; The code aims to provide a limited form of thread and interrupt +;;;; safety: parallel writes and reads may lose output or input, cause +;;;; interleaved IO, etc -- but they should not corrupt memory. The +;;;; key to doing this is to read buffer state once, and update the +;;;; state based on the read state: +;;;; +;;;; (let ((tail (buffer-tail buffer))) +;;;; ... +;;;; (setf (buffer-tail buffer) (+ tail n))) +;;;; +;;;; NOT +;;;; +;;;; (let ((tail (buffer-tail buffer))) +;;;; ... +;;;; (incf (buffer-tail buffer) n)) +;;;; + +(declaim (inline buffer-sap buffer-length buffer-head buffer-tail + (setf buffer-head) (setf buffer-tail))) +(defstruct (buffer (:constructor %make-buffer (sap length))) + (sap (missing-arg) :type system-area-pointer :read-only t) + (length (missing-arg) :type index :read-only t) + (head 0 :type index) + (tail 0 :type index)) -;;; FIXME: Is it really good to maintain this pool separate from the -;;; GC and the C malloc logic? (defvar *available-buffers* () #!+sb-doc - "List of available buffers. Each buffer is an sap pointing to - bytes-per-buffer of memory.") + "List of available buffers.") -#!+sb-thread -(defvar *available-buffers-mutex* (sb!thread:make-mutex - :name "lock for *AVAILABLE-BUFFERS*") +(defvar *available-buffers-spinlock* (sb!thread::make-spinlock + :name "lock for *AVAILABLE-BUFFERS*") #!+sb-doc "Mutex for access to *AVAILABLE-BUFFERS*.") (defmacro with-available-buffers-lock ((&optional) &body body) - ;; WITHOUT-INTERRUPTS because streams are low-level enough to be - ;; async signal safe, and in particular a C-c that brings up the - ;; debugger while holding the mutex would lose badly - `(without-interrupts - (sb!thread:with-mutex (*available-buffers-mutex*) - ,@body))) - -(defconstant bytes-per-buffer (* 4 1024) - #!+sb-doc - "Number of bytes per buffer.") + ;; CALL-WITH-SYSTEM-SPINLOCK because + ;; + ;; 1. streams are low-level enough to be async signal safe, and in + ;; particular a C-c that brings up the debugger while holding the + ;; mutex would lose badly + ;; + ;; 2. this can potentially be a fairly busy (but also probably + ;; uncontended) lock, so we don't want to pay the syscall per + ;; release -- hence a spinlock. + ;; + ;; ...again, once we have smarted locks the spinlock here can become + ;; a mutex. + `(sb!thread::with-system-spinlock (*available-buffers-spinlock*) + ,@body)) -;;; Return the next available buffer, creating one if necessary. -#!-sb-fluid (declaim (inline next-available-buffer)) -(defun next-available-buffer () +(defconstant +bytes-per-buffer+ (* 4 1024) + #!+sb-doc + "Default number of bytes per buffer.") + +(defun alloc-buffer (&optional (size +bytes-per-buffer+)) + ;; Don't want to allocate & unwind before the finalizer is in place. + (without-interrupts + (let* ((sap (allocate-system-memory size)) + (buffer (%make-buffer sap size))) + (when (zerop (sap-int sap)) + (error "Could not allocate ~D bytes for buffer." size)) + (finalize buffer (lambda () + (deallocate-system-memory sap size)) + :dont-save t) + buffer))) + +(defun get-buffer () + ;; Don't go for the lock if there is nothing to be had -- sure, + ;; another thread might just release one before we get it, but that + ;; is not worth the cost of locking. Also release the lock before + ;; allocation, since it's going to take a while. + (if *available-buffers* + (or (with-available-buffers-lock () + (pop *available-buffers*)) + (alloc-buffer)) + (alloc-buffer))) + +(declaim (inline reset-buffer)) +(defun reset-buffer (buffer) + (setf (buffer-head buffer) 0 + (buffer-tail buffer) 0) + buffer) + +(defun release-buffer (buffer) + (reset-buffer buffer) (with-available-buffers-lock () - (if *available-buffers* - (pop *available-buffers*) - (allocate-system-memory bytes-per-buffer)))) + (push buffer *available-buffers*))) + +;;; This is a separate buffer management function, as it wants to be +;;; clever about locking -- grabbing the lock just once. +(defun release-fd-stream-buffers (fd-stream) + (let ((ibuf (fd-stream-ibuf fd-stream)) + (obuf (fd-stream-obuf fd-stream)) + (queue (loop for item in (fd-stream-output-queue fd-stream) + when (buffer-p item) + collect (reset-buffer item)))) + (when ibuf + (push (reset-buffer ibuf) queue)) + (when obuf + (push (reset-buffer obuf) queue)) + ;; ...so, anything found? + (when queue + ;; detach from stream + (setf (fd-stream-ibuf fd-stream) nil + (fd-stream-obuf fd-stream) nil + (fd-stream-output-queue fd-stream) nil) + ;; splice to *available-buffers* + (with-available-buffers-lock () + (setf *available-buffers* (nconc queue *available-buffers*)))))) ;;;; the FD-STREAM structure @@ -77,37 +164,254 @@ ;; sources where input and output aren't related). non-NIL means ;; don't clear input buffer. (dual-channel-p nil) - ;; character position (if known) - (char-pos nil :type (or index null)) + ;; character position if known -- this may run into bignums, but + ;; we probably should flip it into null then for efficiency's sake... + (char-pos nil :type (or unsigned-byte null)) ;; T if input is waiting on FD. :EOF if we hit EOF. (listen nil :type (member nil t :eof)) + ;; T if serve-event is allowed when this stream blocks + (serve-events nil :type boolean) ;; the input buffer - (unread nil) - (ibuf-sap nil :type (or system-area-pointer null)) - (ibuf-length nil :type (or index null)) - (ibuf-head 0 :type index) - (ibuf-tail 0 :type index) + (instead (make-array 0 :element-type 'character :adjustable t :fill-pointer t) :type (array character (*))) + (ibuf nil :type (or buffer null)) + (eof-forced-p nil :type (member t nil)) ;; the output buffer - (obuf-sap nil :type (or system-area-pointer null)) - (obuf-length nil :type (or index null)) - (obuf-tail 0 :type index) + (obuf nil :type (or buffer null)) ;; output flushed, but not written due to non-blocking io? - (output-later nil) + (output-queue nil) (handler nil) - ;; timeout specified for this stream, or NIL if none - (timeout nil :type (or index null)) + ;; timeout specified for this stream as seconds or NIL if none + (timeout nil :type (or single-float null)) ;; pathname of the file this stream is opened to (returned by PATHNAME) (pathname nil :type (or pathname null)) - (external-format :default) - (output-bytes #'ill-out :type function)) + ;; Not :DEFAULT, because we want to match CHAR-SIZE! + (external-format :latin-1) + ;; fixed width, or function to call with a character + (char-size 1 :type (or fixnum function)) + (output-bytes #'ill-out :type function) + ;; a boolean indicating whether the stream is bivalent. For + ;; internal use only. + (bivalent-p nil :type boolean)) (def!method print-object ((fd-stream fd-stream) stream) (declare (type stream stream)) (print-unreadable-object (fd-stream stream :type t :identity t) (format stream "for ~S" (fd-stream-name fd-stream)))) +;;;; CORE OUTPUT FUNCTIONS + +;;; Buffer the section of THING delimited by START and END by copying +;;; to output buffer(s) of stream. +(defun buffer-output (stream thing start end) + (declare (index start end)) + (when (< end start) + (error ":END before :START!")) + (when (> end start) + ;; Copy bytes from THING to buffers. + (flet ((copy-to-buffer (buffer tail count) + (declare (buffer buffer) (index tail count)) + (aver (plusp count)) + (let ((sap (buffer-sap buffer))) + (etypecase thing + (system-area-pointer + (system-area-ub8-copy thing start sap tail count)) + ((simple-unboxed-array (*)) + (copy-ub8-to-system-area thing start sap tail count)))) + ;; Not INCF! If another thread has moved tail from under + ;; us, we don't want to accidentally increment tail + ;; beyond buffer-length. + (setf (buffer-tail buffer) (+ count tail)) + (incf start count))) + (tagbody + ;; First copy is special: the buffer may already contain + ;; something, or be even full. + (let* ((obuf (fd-stream-obuf stream)) + (tail (buffer-tail obuf)) + (space (- (buffer-length obuf) tail))) + (when (plusp space) + (copy-to-buffer obuf tail (min space (- end start))) + (go :more-output-p))) + :flush-and-fill + ;; Later copies should always have an empty buffer, since + ;; they are freshly flushed, but if another thread is + ;; stomping on the same buffer that might not be the case. + (let* ((obuf (flush-output-buffer stream)) + (tail (buffer-tail obuf)) + (space (- (buffer-length obuf) tail))) + (copy-to-buffer obuf tail (min space (- end start)))) + :more-output-p + (when (> end start) + (go :flush-and-fill)))))) + +;;; Flush the current output buffer of the stream, ensuring that the +;;; new buffer is empty. Returns (for convenience) the new output +;;; buffer -- which may or may not be EQ to the old one. If the is no +;;; queued output we try to write the buffer immediately -- otherwise +;;; we queue it for later. +(defun flush-output-buffer (stream) + (let ((obuf (fd-stream-obuf stream))) + (when obuf + (let ((head (buffer-head obuf)) + (tail (buffer-tail obuf))) + (cond ((eql head tail) + ;; Buffer is already empty -- just ensure that is is + ;; set to zero as well. + (reset-buffer obuf)) + ((fd-stream-output-queue stream) + ;; There is already stuff on the queue -- go directly + ;; there. + (aver (< head tail)) + (%queue-and-replace-output-buffer stream)) + (t + ;; Try a non-blocking write, if SERVE-EVENT is allowed, queue + ;; whatever is left over. Otherwise wait until we can write. + (aver (< head tail)) + (synchronize-stream-output stream) + (loop + (let ((length (- tail head))) + (multiple-value-bind (count errno) + (sb!unix:unix-write (fd-stream-fd stream) (buffer-sap obuf) + head length) + (flet ((queue-or-wait () + (if (fd-stream-serve-events stream) + (return (%queue-and-replace-output-buffer stream)) + (or (wait-until-fd-usable (fd-stream-fd stream) :output + (fd-stream-timeout stream) + nil) + (signal-timeout 'io-timeout + :stream stream + :direction :output + :seconds (fd-stream-timeout stream)))))) + (cond ((eql count length) + ;; Complete write -- we can use the same buffer. + (return (reset-buffer obuf))) + (count + ;; Partial write -- update buffer status and + ;; queue or wait. Do not use INCF! Another + ;; thread might have moved head... + (setf (buffer-head obuf) (+ count head)) + (queue-or-wait)) + #!-win32 + ((eql errno sb!unix:ewouldblock) + ;; Blocking, queue or wair. + (queue-or-wait)) + (t + (simple-stream-perror "Couldn't write to ~s" + stream errno))))))))))))) + +;;; Helper for FLUSH-OUTPUT-BUFFER -- returns the new buffer. +(defun %queue-and-replace-output-buffer (stream) + (aver (fd-stream-serve-events stream)) + (let ((queue (fd-stream-output-queue stream)) + (later (list (or (fd-stream-obuf stream) (bug "Missing obuf.")))) + (new (get-buffer))) + ;; Important: before putting the buffer on queue, give the stream + ;; a new one. If we get an interrupt and unwind losing the buffer + ;; is relatively OK, but having the same buffer in two places + ;; would be bad. + (setf (fd-stream-obuf stream) new) + (cond (queue + (nconc queue later)) + (t + (setf (fd-stream-output-queue stream) later))) + (unless (fd-stream-handler stream) + (setf (fd-stream-handler stream) + (add-fd-handler (fd-stream-fd stream) + :output + (lambda (fd) + (declare (ignore fd)) + (write-output-from-queue stream))))) + new)) + +;;; This is called by the FD-HANDLER for the stream when output is +;;; possible. +(defun write-output-from-queue (stream) + (aver (fd-stream-serve-events stream)) + (synchronize-stream-output stream) + (let (not-first-p) + (tagbody + :pop-buffer + (let* ((buffer (pop (fd-stream-output-queue stream))) + (head (buffer-head buffer)) + (length (- (buffer-tail buffer) head))) + (declare (index head length)) + (aver (>= length 0)) + (multiple-value-bind (count errno) + (sb!unix:unix-write (fd-stream-fd stream) (buffer-sap buffer) + head length) + (cond ((eql count length) + ;; Complete write, see if we can do another right + ;; away, or remove the handler if we're done. + (release-buffer buffer) + (cond ((fd-stream-output-queue stream) + (setf not-first-p t) + (go :pop-buffer)) + (t + (let ((handler (fd-stream-handler stream))) + (aver handler) + (setf (fd-stream-handler stream) nil) + (remove-fd-handler handler))))) + (count + ;; Partial write. Update buffer status and requeue. + (aver (< count length)) + ;; Do not use INCF! Another thread might have moved head. + (setf (buffer-head buffer) (+ head count)) + (push buffer (fd-stream-output-queue stream))) + (not-first-p + ;; We tried to do multiple writes, and finally our + ;; luck ran out. Requeue. + (push buffer (fd-stream-output-queue stream))) + (t + ;; Could not write on the first try at all! + #!+win32 + (simple-stream-perror "Couldn't write to ~S." stream errno) + #!-win32 + (if (= errno sb!unix:ewouldblock) + (bug "Unexpected blocking in WRITE-OUTPUT-FROM-QUEUE.") + (simple-stream-perror "Couldn't write to ~S" + stream errno)))))))) + nil) + +;;; Try to write THING directly to STREAM without buffering, if +;;; possible. If direct write doesn't happen, buffer. +(defun write-or-buffer-output (stream thing start end) + (declare (index start end)) + (cond ((fd-stream-output-queue stream) + (buffer-output stream thing start end)) + ((< end start) + (error ":END before :START!")) + ((> end start) + (let ((length (- end start))) + (synchronize-stream-output stream) + (multiple-value-bind (count errno) + (sb!unix:unix-write (fd-stream-fd stream) thing start length) + (cond ((eql count length) + ;; Complete write -- done! + ) + (count + (aver (< count length)) + ;; Partial write -- buffer the rest. + (buffer-output stream thing (+ start count) end)) + (t + ;; Could not write -- buffer or error. + #!+win32 + (simple-stream-perror "couldn't write to ~s" stream errno) + #!-win32 + (if (= errno sb!unix:ewouldblock) + (buffer-output stream thing start end) + (simple-stream-perror "couldn't write to ~s" stream errno))))))))) + +;;; Deprecated -- can go away after 1.1 or so. Deprecated because +;;; this is not something we want to export. Nikodemus thinks the +;;; right thing is to support a low-level non-stream like IO layer, +;;; akin to java.nio. +(declaim (inline output-raw-bytes)) +(define-deprecated-function :late "1.0.8.16" output-raw-bytes write-sequence + (stream thing &optional start end) + (write-or-buffer-output stream thing (or start 0) (or end (length thing)))) + ;;;; output routines and related noise (defvar *output-routines* () @@ -131,35 +435,65 @@ (defun stream-decoding-error (stream octets) (error 'stream-decoding-error + :external-format (stream-external-format stream) :stream stream ;; FIXME: dunno how to get at OCTETS currently, or even if ;; that's the right thing to report. :octets octets)) (defun stream-encoding-error (stream code) (error 'stream-encoding-error + :external-format (stream-external-format stream) :stream stream :code code)) +(defun c-string-encoding-error (external-format code) + (error 'c-string-encoding-error + :external-format external-format + :code code)) + +(defun c-string-decoding-error (external-format octets) + (error 'c-string-decoding-error + :external-format external-format + :octets octets)) + ;;; Returning true goes into end of file handling, false will enter another ;;; round of input buffer filling followed by re-entering character decode. (defun stream-decoding-error-and-handle (stream octet-count) (restart-case (stream-decoding-error stream - (let ((sap (fd-stream-ibuf-sap stream)) - (head (fd-stream-ibuf-head stream))) + (let* ((buffer (fd-stream-ibuf stream)) + (sap (buffer-sap buffer)) + (head (buffer-head buffer))) (loop for i from 0 below octet-count collect (sap-ref-8 sap (+ head i))))) (attempt-resync () :report (lambda (stream) (format stream - "~@")) (fd-stream-resync stream) nil) (force-end-of-file () :report (lambda (stream) (format stream "~@")) - t))) + (setf (fd-stream-eof-forced-p stream) t)) + (input-replacement (string) + :report (lambda (stream) + (format stream "~@")) + :interactive (lambda () + (format *query-io* "~@") + (finish-output *query-io*) + (list (read *query-io*))) + (let ((string (reverse (string string))) + (instead (fd-stream-instead stream))) + (dotimes (i (length string)) + (vector-push-extend (char string i) instead)) + (fd-stream-resync stream) + (when (> (length string) 0) + (setf (fd-stream-listen stream) t))) + nil))) (defun stream-encoding-error-and-handle (stream code) (restart-case @@ -167,149 +501,91 @@ (output-nothing () :report (lambda (stream) (format stream "~@")) + (throw 'output-nothing nil)) + (output-replacement (string) + :report (lambda (stream) + (format stream "~@")) + :interactive (lambda () + (format *query-io* "~@") + (finish-output *query-io*) + (list (read *query-io*))) + (let ((string (string string))) + (fd-sout stream (string string) 0 (length string))) (throw 'output-nothing nil)))) -;;; This is called by the server when we can write to the given file -;;; descriptor. Attempt to write the data again. If it worked, remove -;;; the data from the OUTPUT-LATER list. If it didn't work, something -;;; is wrong. -(defun frob-output-later (stream) - (let* ((stuff (pop (fd-stream-output-later stream))) - (base (car stuff)) - (start (cadr stuff)) - (end (caddr stuff)) - (reuse-sap (cadddr stuff)) - (length (- end start))) - (declare (type index start end length)) - (multiple-value-bind (count errno) - (sb!unix:unix-write (fd-stream-fd stream) - base - start - length) - (cond ((not count) - (if (= errno sb!unix:ewouldblock) - (error "Write would have blocked, but SERVER told us to go.") - (simple-stream-perror "couldn't write to ~S" stream errno))) - ((eql count length) ; Hot damn, it worked. - (when reuse-sap - (with-available-buffers-lock () - (push base *available-buffers*)))) - ((not (null count)) ; sorta worked.. - (push (list base - (the index (+ start count)) - end) - (fd-stream-output-later stream)))))) - (unless (fd-stream-output-later stream) - (sb!sys:remove-fd-handler (fd-stream-handler stream)) - (setf (fd-stream-handler stream) nil))) - -;;; Arange to output the string when we can write on the file descriptor. -(defun output-later (stream base start end reuse-sap) - (cond ((null (fd-stream-output-later stream)) - (setf (fd-stream-output-later stream) - (list (list base start end reuse-sap))) - (setf (fd-stream-handler stream) - (sb!sys:add-fd-handler (fd-stream-fd stream) - :output - (lambda (fd) - (declare (ignore fd)) - (frob-output-later stream))))) - (t - (nconc (fd-stream-output-later stream) - (list (list base start end reuse-sap))))) - (when reuse-sap - (let ((new-buffer (next-available-buffer))) - (setf (fd-stream-obuf-sap stream) new-buffer) - (setf (fd-stream-obuf-length stream) bytes-per-buffer)))) - -;;; Output the given noise. Check to see whether there are any pending -;;; writes. If so, just queue this one. Otherwise, try to write it. If -;;; this would block, queue it. -(defun frob-output (stream base start end reuse-sap) - (declare (type fd-stream stream) - (type (or system-area-pointer (simple-array * (*))) base) - (type index start end)) - (if (not (null (fd-stream-output-later stream))) ; something buffered. - (progn - (output-later stream base start end reuse-sap) - ;; ### check to see whether any of this noise can be output - ) - (let ((length (- end start))) - (multiple-value-bind (count errno) - (sb!unix:unix-write (fd-stream-fd stream) base start length) - (cond ((not count) - (if (= errno sb!unix:ewouldblock) - (output-later stream base start end reuse-sap) - (simple-stream-perror "couldn't write to ~S" - stream - errno))) - ((not (eql count length)) - (output-later stream base (the index (+ start count)) - end reuse-sap))))))) - -;;; Flush any data in the output buffer. -(defun flush-output-buffer (stream) - (let ((length (fd-stream-obuf-tail stream))) - (unless (= length 0) - (frob-output stream (fd-stream-obuf-sap stream) 0 length t) - (setf (fd-stream-obuf-tail stream) 0)))) +(defun external-format-encoding-error (stream code) + (if (streamp stream) + (stream-encoding-error-and-handle stream code) + (c-string-encoding-error stream code))) + +(defun synchronize-stream-output (stream) + ;; If we're reading and writing on the same file, flush buffered + ;; input and rewind file position accordingly. + (unless (fd-stream-dual-channel-p stream) + (let ((adjust (nth-value 1 (flush-input-buffer stream)))) + (unless (eql 0 adjust) + (sb!unix:unix-lseek (fd-stream-fd stream) (- adjust) sb!unix:l_incr))))) + +(defun fd-stream-output-finished-p (stream) + (let ((obuf (fd-stream-obuf stream))) + (or (not obuf) + (and (zerop (buffer-tail obuf)) + (not (fd-stream-output-queue stream)))))) (defmacro output-wrapper/variable-width ((stream size buffering restart) &body body) - (let ((stream-var (gensym))) - `(let ((,stream-var ,stream) - (size ,size)) + (let ((stream-var (gensym "STREAM"))) + `(let* ((,stream-var ,stream) + (obuf (fd-stream-obuf ,stream-var)) + (tail (buffer-tail obuf)) + (size ,size)) ,(unless (eq (car buffering) :none) - `(when (< (fd-stream-obuf-length ,stream-var) - (+ (fd-stream-obuf-tail ,stream-var) - size)) - (flush-output-buffer ,stream-var))) + `(when (<= (buffer-length obuf) (+ tail size)) + (setf obuf (flush-output-buffer ,stream-var) + tail (buffer-tail obuf)))) ,(unless (eq (car buffering) :none) - `(when (and (not (fd-stream-dual-channel-p ,stream-var)) - (> (fd-stream-ibuf-tail ,stream-var) - (fd-stream-ibuf-head ,stream-var))) - (file-position ,stream-var (file-position ,stream-var)))) + ;; FIXME: Why this here? Doesn't seem necessary. + `(synchronize-stream-output ,stream-var)) ,(if restart `(catch 'output-nothing ,@body - (incf (fd-stream-obuf-tail ,stream-var) size)) + (setf (buffer-tail obuf) (+ tail size))) `(progn ,@body - (incf (fd-stream-obuf-tail ,stream-var) size))) + (setf (buffer-tail obuf) (+ tail size)))) ,(ecase (car buffering) (:none `(flush-output-buffer ,stream-var)) (:line - `(when (eq (char-code byte) (char-code #\Newline)) + `(when (eql byte #\Newline) (flush-output-buffer ,stream-var))) (:full)) (values)))) (defmacro output-wrapper ((stream size buffering restart) &body body) - (let ((stream-var (gensym))) - `(let ((,stream-var ,stream)) + (let ((stream-var (gensym "STREAM"))) + `(let* ((,stream-var ,stream) + (obuf (fd-stream-obuf ,stream-var)) + (tail (buffer-tail obuf))) ,(unless (eq (car buffering) :none) - `(when (< (fd-stream-obuf-length ,stream-var) - (+ (fd-stream-obuf-tail ,stream-var) - ,size)) - (flush-output-buffer ,stream-var))) + `(when (<= (buffer-length obuf) (+ tail ,size)) + (setf obuf (flush-output-buffer ,stream-var) + tail (buffer-tail obuf)))) + ;; FIXME: Why this here? Doesn't seem necessary. ,(unless (eq (car buffering) :none) - `(when (and (not (fd-stream-dual-channel-p ,stream-var)) - (> (fd-stream-ibuf-tail ,stream-var) - (fd-stream-ibuf-head ,stream-var))) - (file-position ,stream-var (file-position ,stream-var)))) + `(synchronize-stream-output ,stream-var)) ,(if restart `(catch 'output-nothing ,@body - (incf (fd-stream-obuf-tail ,stream-var) ,size)) + (setf (buffer-tail obuf) (+ tail ,size))) `(progn ,@body - (incf (fd-stream-obuf-tail ,stream-var) ,size))) + (setf (buffer-tail obuf) (+ tail ,size)))) ,(ecase (car buffering) (:none `(flush-output-buffer ,stream-var)) (:line - `(when (eq (char-code byte) (char-code #\Newline)) + `(when (eql byte #\Newline) (flush-output-buffer ,stream-var))) (:full)) (values)))) @@ -325,6 +601,7 @@ (intern (format nil name-fmt (string (car buffering)))))) `(progn (defun ,function (stream byte) + (declare (ignorable byte)) (output-wrapper/variable-width (stream ,size ,buffering ,restart) ,@body)) (setf *output-routines* @@ -372,10 +649,10 @@ (:none character) (:line character) (:full character)) - (if (char= byte #\Newline) + (if (eql byte #\Newline) (setf (fd-stream-char-pos stream) 0) (incf (fd-stream-char-pos stream))) - (setf (sap-ref-8 (fd-stream-obuf-sap stream) (fd-stream-obuf-tail stream)) + (setf (sap-ref-8 (buffer-sap obuf) tail) (char-code byte))) (def-output-routines ("OUTPUT-UNSIGNED-BYTE-~A-BUFFERED" @@ -383,7 +660,7 @@ nil (:none (unsigned-byte 8)) (:full (unsigned-byte 8))) - (setf (sap-ref-8 (fd-stream-obuf-sap stream) (fd-stream-obuf-tail stream)) + (setf (sap-ref-8 (buffer-sap obuf) tail) byte)) (def-output-routines ("OUTPUT-SIGNED-BYTE-~A-BUFFERED" @@ -391,8 +668,7 @@ nil (:none (signed-byte 8)) (:full (signed-byte 8))) - (setf (signed-sap-ref-8 (fd-stream-obuf-sap stream) - (fd-stream-obuf-tail stream)) + (setf (signed-sap-ref-8 (buffer-sap obuf) tail) byte)) (def-output-routines ("OUTPUT-UNSIGNED-SHORT-~A-BUFFERED" @@ -400,7 +676,7 @@ nil (:none (unsigned-byte 16)) (:full (unsigned-byte 16))) - (setf (sap-ref-16 (fd-stream-obuf-sap stream) (fd-stream-obuf-tail stream)) + (setf (sap-ref-16 (buffer-sap obuf) tail) byte)) (def-output-routines ("OUTPUT-SIGNED-SHORT-~A-BUFFERED" @@ -408,8 +684,7 @@ nil (:none (signed-byte 16)) (:full (signed-byte 16))) - (setf (signed-sap-ref-16 (fd-stream-obuf-sap stream) - (fd-stream-obuf-tail stream)) + (setf (signed-sap-ref-16 (buffer-sap obuf) tail) byte)) (def-output-routines ("OUTPUT-UNSIGNED-LONG-~A-BUFFERED" @@ -417,7 +692,7 @@ nil (:none (unsigned-byte 32)) (:full (unsigned-byte 32))) - (setf (sap-ref-32 (fd-stream-obuf-sap stream) (fd-stream-obuf-tail stream)) + (setf (sap-ref-32 (buffer-sap obuf) tail) byte)) (def-output-routines ("OUTPUT-SIGNED-LONG-~A-BUFFERED" @@ -425,155 +700,190 @@ nil (:none (signed-byte 32)) (:full (signed-byte 32))) - (setf (signed-sap-ref-32 (fd-stream-obuf-sap stream) - (fd-stream-obuf-tail stream)) + (setf (signed-sap-ref-32 (buffer-sap obuf) tail) byte)) -;;; Do the actual output. If there is space to buffer the string, -;;; buffer it. If the string would normally fit in the buffer, but -;;; doesn't because of other stuff in the buffer, flush the old noise -;;; out of the buffer and put the string in it. Otherwise we have a -;;; very long string, so just send it directly (after flushing the -;;; buffer, of course). -(defun output-raw-bytes (fd-stream thing &optional start end) - #!+sb-doc - "Output THING to FD-STREAM. THING can be any kind of vector or a SAP. If - THING is a SAP, END must be supplied (as length won't work)." - (let ((start (or start 0)) - (end (or end (length (the (simple-array * (*)) thing))))) - (declare (type index start end)) - (when (and (not (fd-stream-dual-channel-p fd-stream)) - (> (fd-stream-ibuf-tail fd-stream) - (fd-stream-ibuf-head fd-stream))) - (file-position fd-stream (file-position fd-stream))) - (let* ((len (fd-stream-obuf-length fd-stream)) - (tail (fd-stream-obuf-tail fd-stream)) - (space (- len tail)) - (bytes (- end start)) - (newtail (+ tail bytes))) - (cond ((minusp bytes) ; error case - (error ":END before :START!")) - ((zerop bytes)) ; easy case - ((<= bytes space) - (if (system-area-pointer-p thing) - (system-area-ub8-copy thing start - (fd-stream-obuf-sap fd-stream) - tail - bytes) - ;; FIXME: There should be some type checking somewhere to - ;; verify that THING here is a vector, not just . - (copy-ub8-to-system-area thing start - (fd-stream-obuf-sap fd-stream) - tail - bytes)) - (setf (fd-stream-obuf-tail fd-stream) newtail)) - ((<= bytes len) - (flush-output-buffer fd-stream) - (if (system-area-pointer-p thing) - (system-area-ub8-copy thing - start - (fd-stream-obuf-sap fd-stream) - 0 - bytes) - ;; FIXME: There should be some type checking somewhere to - ;; verify that THING here is a vector, not just . - (copy-ub8-to-system-area thing - start - (fd-stream-obuf-sap fd-stream) - 0 - bytes)) - (setf (fd-stream-obuf-tail fd-stream) bytes)) - (t - (flush-output-buffer fd-stream) - (frob-output fd-stream thing start end nil)))))) +#+#.(cl:if (cl:= sb!vm:n-word-bits 64) '(and) '(or)) +(progn + (def-output-routines ("OUTPUT-UNSIGNED-LONG-LONG-~A-BUFFERED" + 8 + nil + (:none (unsigned-byte 64)) + (:full (unsigned-byte 64))) + (setf (sap-ref-64 (buffer-sap obuf) tail) + byte)) + (def-output-routines ("OUTPUT-SIGNED-LONG-LONG-~A-BUFFERED" + 8 + nil + (:none (signed-byte 64)) + (:full (signed-byte 64))) + (setf (signed-sap-ref-64 (buffer-sap obuf) tail) + byte))) ;;; the routine to use to output a string. If the stream is ;;; unbuffered, slam the string down the file descriptor, otherwise ;;; use OUTPUT-RAW-BYTES to buffer the string. Update charpos by ;;; checking to see where the last newline was. -;;; -;;; Note: some bozos (the FASL dumper) call write-string with things -;;; other than strings. Therefore, we must make sure we have a string -;;; before calling POSITION on it. -;;; KLUDGE: It would be better to fix the bozos instead of trying to -;;; cover for them here. -- WHN 20000203 (defun fd-sout (stream thing start end) + (declare (type fd-stream stream) (type string thing)) (let ((start (or start 0)) (end (or end (length (the vector thing))))) (declare (fixnum start end)) - (if (stringp thing) - (let ((last-newline - (flet ((do-it (string) - (and (find #\newline string :start start :end end) - ;; FIXME why do we need both calls? - ;; Is find faster forwards than - ;; position is backwards? - (position #\newline string - :from-end t - :start start - :end end)))) - (declare (inline do-it)) - ;; Specialize the common cases - (etypecase thing - (simple-base-string - (do-it (the simple-base-string thing))) - #!+sb-unicode - ((simple-array character) - (do-it (the (simple-array character) thing))) - (string - (do-it thing)))))) - (if (and (typep thing 'base-string) - (eq (fd-stream-external-format stream) :latin-1)) - (ecase (fd-stream-buffering stream) - (:full - (output-raw-bytes stream thing start end)) - (:line - (output-raw-bytes stream thing start end) - (when last-newline - (flush-output-buffer stream))) - (:none - (frob-output stream thing start end nil))) - (ecase (fd-stream-buffering stream) - (:full (funcall (fd-stream-output-bytes stream) - stream thing nil start end)) - (:line (funcall (fd-stream-output-bytes stream) - stream thing last-newline start end)) - (:none (funcall (fd-stream-output-bytes stream) - stream thing t start end)))) - (if last-newline - (setf (fd-stream-char-pos stream) - (- end last-newline 1)) - (incf (fd-stream-char-pos stream) - (- end start)))) - (ecase (fd-stream-buffering stream) - ((:line :full) - (output-raw-bytes stream thing start end)) - (:none - (frob-output stream thing start end nil)))))) - -(defvar *external-formats* () + (let ((last-newline + (string-dispatch (simple-base-string + #!+sb-unicode + (simple-array character (*)) + string) + thing + (position #\newline thing :from-end t + :start start :end end)))) + (if (and (typep thing 'base-string) + (eq (fd-stream-external-format-keyword stream) :latin-1)) + (ecase (fd-stream-buffering stream) + (:full + (buffer-output stream thing start end)) + (:line + (buffer-output stream thing start end) + (when last-newline + (flush-output-buffer stream))) + (:none + (write-or-buffer-output stream thing start end))) + (ecase (fd-stream-buffering stream) + (:full (funcall (fd-stream-output-bytes stream) + stream thing nil start end)) + (:line (funcall (fd-stream-output-bytes stream) + stream thing last-newline start end)) + (:none (funcall (fd-stream-output-bytes stream) + stream thing t start end)))) + (if last-newline + (setf (fd-stream-char-pos stream) (- end last-newline 1)) + (incf (fd-stream-char-pos stream) (- end start)))))) + +(defstruct (external-format + (:constructor %make-external-format) + (:conc-name ef-) + (:predicate external-format-p) + (:copier %copy-external-format)) + ;; All the names that can refer to this external format. The first + ;; one is the canonical name. + (names (missing-arg) :type list :read-only t) + (default-replacement-character (missing-arg) :type character) + (read-n-chars-fun (missing-arg) :type function) + (read-char-fun (missing-arg) :type function) + (write-n-bytes-fun (missing-arg) :type function) + (write-char-none-buffered-fun (missing-arg) :type function) + (write-char-line-buffered-fun (missing-arg) :type function) + (write-char-full-buffered-fun (missing-arg) :type function) + ;; Can be nil for fixed-width formats. + (resync-fun nil :type (or function null)) + (bytes-for-char-fun (missing-arg) :type function) + (read-c-string-fun (missing-arg) :type function) + (write-c-string-fun (missing-arg) :type function) + ;; We indirect through symbols in these functions so that a + ;; developer working on the octets code can easily redefine things + ;; and use the new function definition without redefining the + ;; external format as well. The slots above don't do any + ;; indirection because a developer working with those slots would be + ;; redefining the external format anyway. + (octets-to-string-fun (missing-arg) :type function) + (string-to-octets-fun (missing-arg) :type function)) + +(defun ef-char-size (ef-entry) + (if (variable-width-external-format-p ef-entry) + (bytes-for-char-fun ef-entry) + (funcall (bytes-for-char-fun ef-entry) #\x))) + +(defun wrap-external-format-functions (external-format fun) + (let ((result (%copy-external-format external-format))) + (macrolet ((frob (accessor) + `(setf (,accessor result) (funcall fun (,accessor result))))) + (frob ef-read-n-chars-fun) + (frob ef-read-char-fun) + (frob ef-write-n-bytes-fun) + (frob ef-write-char-none-buffered-fun) + (frob ef-write-char-line-buffered-fun) + (frob ef-write-char-full-buffered-fun) + (frob ef-resync-fun) + (frob ef-bytes-for-char-fun) + (frob ef-read-c-string-fun) + (frob ef-write-c-string-fun) + (frob ef-octets-to-string-fun) + (frob ef-string-to-octets-fun)) + result)) + +(defvar *external-formats* (make-hash-table) #!+sb-doc - "List of all available external formats. Each element is a list of the - element-type, string input function name, character input function name, - and string output function name.") + "Hashtable of all available external formats. The table maps from + external-format names to EXTERNAL-FORMAT structures.") + +(defun get-external-format (external-format) + (flet ((keyword-external-format (keyword) + (declare (type keyword keyword)) + (gethash keyword *external-formats*)) + (replacement-handlerify (entry replacement) + (when entry + (wrap-external-format-functions + entry + (lambda (fun) + (and fun + (lambda (&rest rest) + (declare (dynamic-extent rest)) + (handler-bind + ((stream-decoding-error + (lambda (c) + (declare (ignore c)) + (invoke-restart 'input-replacement replacement))) + (stream-encoding-error + (lambda (c) + (declare (ignore c)) + (invoke-restart 'output-replacement replacement))) + (octets-encoding-error + (lambda (c) (use-value replacement c))) + (octet-decoding-error + (lambda (c) (use-value replacement c)))) + (apply fun rest))))))))) + (typecase external-format + (keyword (keyword-external-format external-format)) + ((cons keyword) + (let ((entry (keyword-external-format (car external-format))) + (replacement (getf (cdr external-format) :replacement))) + (if replacement + (replacement-handlerify entry replacement) + entry)))))) + +(defun get-external-format-or-lose (external-format) + (or (get-external-format external-format) + (error "Undefined external-format: ~S" external-format))) + +(defun external-format-keyword (external-format) + (typecase external-format + (keyword external-format) + ((cons keyword) (car external-format)))) + +(defun fd-stream-external-format-keyword (stream) + (external-format-keyword (fd-stream-external-format stream))) + +(defun canonize-external-format (external-format entry) + (typecase external-format + (keyword (first (ef-names entry))) + ((cons keyword) (cons (first (ef-names entry)) (rest external-format))))) ;;; Find an output routine to use given the type and buffering. Return ;;; as multiple values the routine, the real type transfered, and the ;;; number of bytes per element. (defun pick-output-routine (type buffering &optional external-format) (when (subtypep type 'character) - (dolist (entry *external-formats*) - (when (member external-format (first entry)) - (return-from pick-output-routine - (values (symbol-function (nth (ecase buffering - (:none 4) - (:line 5) - (:full 6)) - entry)) - 'character - 1 - (symbol-function (fourth entry)) - (first (first entry))))))) + (let ((entry (get-external-format-or-lose external-format))) + (return-from pick-output-routine + (values (ecase buffering + (:none (ef-write-char-none-buffered-fun entry)) + (:line (ef-write-char-line-buffered-fun entry)) + (:full (ef-write-char-full-buffered-fun entry))) + 'character + 1 + (ef-write-n-bytes-fun entry) + (ef-char-size entry) + (canonize-external-format external-format entry))))) (dolist (entry *output-routines*) (when (and (subtypep type (first entry)) (eq buffering (second entry)) @@ -596,17 +906,15 @@ (lambda (stream byte) (output-wrapper (stream (/ i 8) (:none) nil) (loop for j from 0 below (/ i 8) - do (setf (sap-ref-8 - (fd-stream-obuf-sap stream) - (+ j (fd-stream-obuf-tail stream))) + do (setf (sap-ref-8 (buffer-sap obuf) + (+ j tail)) (ldb (byte 8 (- i 8 (* j 8))) byte)))))) (:full (lambda (stream byte) (output-wrapper (stream (/ i 8) (:full) nil) (loop for j from 0 below (/ i 8) - do (setf (sap-ref-8 - (fd-stream-obuf-sap stream) - (+ j (fd-stream-obuf-tail stream))) + do (setf (sap-ref-8 (buffer-sap obuf) + (+ j tail)) (ldb (byte 8 (- i 8 (* j 8))) byte))))))) `(unsigned-byte ,i) (/ i 8)))) @@ -619,17 +927,15 @@ (lambda (stream byte) (output-wrapper (stream (/ i 8) (:none) nil) (loop for j from 0 below (/ i 8) - do (setf (sap-ref-8 - (fd-stream-obuf-sap stream) - (+ j (fd-stream-obuf-tail stream))) + do (setf (sap-ref-8 (buffer-sap obuf) + (+ j tail)) (ldb (byte 8 (- i 8 (* j 8))) byte)))))) (:full (lambda (stream byte) (output-wrapper (stream (/ i 8) (:full) nil) (loop for j from 0 below (/ i 8) - do (setf (sap-ref-8 - (fd-stream-obuf-sap stream) - (+ j (fd-stream-obuf-tail stream))) + do (setf (sap-ref-8 (buffer-sap obuf) + (+ j tail)) (ldb (byte 8 (- i 8 (* j 8))) byte))))))) `(signed-byte ,i) (/ i 8))))) @@ -641,151 +947,203 @@ ;;; per element. (defvar *input-routines* ()) -;;; Fill the input buffer, and return the number of bytes read. Throw -;;; to EOF-INPUT-CATCHER if the eof was reached. Drop into -;;; SYSTEM:SERVER if necessary. -(defun refill-buffer/fd (stream) - (let ((fd (fd-stream-fd stream)) - (ibuf-sap (fd-stream-ibuf-sap stream)) - (buflen (fd-stream-ibuf-length stream)) - (head (fd-stream-ibuf-head stream)) - (tail (fd-stream-ibuf-tail stream))) - (declare (type index head tail)) - (unless (zerop head) - (cond ((eql head tail) - (setf head 0) - (setf tail 0) - (setf (fd-stream-ibuf-head stream) 0) - (setf (fd-stream-ibuf-tail stream) 0)) - (t - (decf tail head) - (system-area-ub8-copy ibuf-sap head - ibuf-sap 0 tail) - (setf head 0) - (setf (fd-stream-ibuf-head stream) 0) - (setf (fd-stream-ibuf-tail stream) tail)))) - (setf (fd-stream-listen stream) nil) - (sb!unix:with-restarted-syscall (count errno) - ;; FIXME: Judging from compiler warnings, this WITH-ALIEN form expands - ;; into something which uses the not-yet-defined type - ;; (SB!ALIEN-INTERNALS:ALIEN (* (SB!ALIEN:STRUCT SB!UNIX:FD-SET))). - ;; This is probably inefficient and unsafe and generally bad, so - ;; try to find some way to make that type known before - ;; this is compiled. - (sb!alien:with-alien ((read-fds (sb!alien:struct sb!unix:fd-set))) - (sb!unix:fd-zero read-fds) - (sb!unix:fd-set fd read-fds) - (sb!unix:unix-fast-select (1+ fd) - (sb!alien:addr read-fds) - nil nil 0 0)) - (case count - (1) - (0 - (unless (sb!sys:wait-until-fd-usable - fd :input (fd-stream-timeout stream)) - (error 'io-timeout :stream stream :direction :read))) - (t - (simple-stream-perror "couldn't check whether ~S is readable" - stream - errno)))) - (multiple-value-bind (count errno) - (sb!unix:unix-read fd - (sb!sys:int-sap (+ (sb!sys:sap-int ibuf-sap) tail)) - (- buflen tail)) - (cond ((null count) - (if (eql errno sb!unix:ewouldblock) - (progn - (unless (sb!sys:wait-until-fd-usable - fd :input (fd-stream-timeout stream)) - (error 'io-timeout :stream stream :direction :read)) - (refill-buffer/fd stream)) - (simple-stream-perror "couldn't read from ~S" stream errno))) - ((zerop count) - (setf (fd-stream-listen stream) :eof) - (/show0 "THROWing EOF-INPUT-CATCHER") - (throw 'eof-input-catcher nil)) - (t - (incf (fd-stream-ibuf-tail stream) count) - count))))) +;;; Return whether a primitive partial read operation on STREAM's FD +;;; would (probably) block. Signal a `simple-stream-error' if the +;;; system call implementing this operation fails. +;;; +;;; It is "may" instead of "would" because "would" is not quite +;;; correct on win32. However, none of the places that use it require +;;; further assurance than "may" versus "will definitely not". +(defun sysread-may-block-p (stream) + #!+win32 + ;; This answers T at EOF on win32, I think. + (not (sb!win32:fd-listen (fd-stream-fd stream))) + #!-win32 + (not (sb!unix:unix-simple-poll (fd-stream-fd stream) :input 0))) + +;;; If the read would block wait (using SERVE-EVENT) till input is available, +;;; then fill the input buffer, and return the number of bytes read. Throws +;;; to EOF-INPUT-CATCHER if the eof was reached. +(defun refill-input-buffer (stream) + (dx-let ((fd (fd-stream-fd stream)) + (errno 0) + (count 0)) + (tagbody + ;; Check for blocking input before touching the stream if we are to + ;; serve events: if the FD is blocking, we don't want to hang on the + ;; write if we are to serve events or notice timeouts. + (if (and (or (fd-stream-serve-events stream) + (fd-stream-timeout stream) + *deadline*) + (sysread-may-block-p stream)) + (go :wait-for-input) + (go :main)) + ;; These (:CLOSED-FLAME and :READ-ERROR) tags are here so what + ;; we can signal errors outside the WITHOUT-INTERRUPTS. + :closed-flame + (closed-flame stream) + :read-error + (simple-stream-perror "couldn't read from ~S" stream errno) + :wait-for-input + ;; This tag is here so we can unwind outside the WITHOUT-INTERRUPTS + ;; to wait for input if read tells us EWOULDBLOCK. + (unless (wait-until-fd-usable fd :input (fd-stream-timeout stream) + (fd-stream-serve-events stream)) + (signal-timeout 'io-timeout + :stream stream + :direction :input + :seconds (fd-stream-timeout stream))) + :main + ;; Since the read should not block, we'll disable the + ;; interrupts here, so that we don't accidentally unwind and + ;; leave the stream in an inconsistent state. + + ;; Execute the nlx outside without-interrupts to ensure the + ;; resulting thunk is stack-allocatable. + ((lambda (return-reason) + (ecase return-reason + ((nil)) ; fast path normal cases + ((:wait-for-input) (go :wait-for-input)) + ((:closed-flame) (go :closed-flame)) + ((:read-error) (go :read-error)))) + (without-interrupts + ;; Check the buffer: if it is null, then someone has closed + ;; the stream from underneath us. This is not ment to fix + ;; multithreaded races, but to deal with interrupt handlers + ;; closing the stream. + (block nil + (prog1 nil + (let* ((ibuf (or (fd-stream-ibuf stream) (return :closed-flame))) + (sap (buffer-sap ibuf)) + (length (buffer-length ibuf)) + (head (buffer-head ibuf)) + (tail (buffer-tail ibuf))) + (declare (index length head tail) + (inline sb!unix:unix-read)) + (unless (zerop head) + (cond ((eql head tail) + ;; Buffer is empty, but not at yet reset -- make it so. + (setf head 0 + tail 0) + (reset-buffer ibuf)) + (t + ;; Buffer has things in it, but they are not at the + ;; head -- move them there. + (let ((n (- tail head))) + (system-area-ub8-copy sap head sap 0 n) + (setf head 0 + (buffer-head ibuf) head + tail n + (buffer-tail ibuf) tail))))) + (setf (fd-stream-listen stream) nil) + (setf (values count errno) + (sb!unix:unix-read fd (sap+ sap tail) (- length tail))) + (cond ((null count) + #!+win32 + (return :read-error) + #!-win32 + (if (eql errno sb!unix:ewouldblock) + (return :wait-for-input) + (return :read-error))) + ((zerop count) + (setf (fd-stream-listen stream) :eof) + (/show0 "THROWing EOF-INPUT-CATCHER") + (throw 'eof-input-catcher nil)) + (t + ;; Success! (Do not use INCF, for sake of other threads.) + (setf (buffer-tail ibuf) (+ count tail)))))))))) + count)) ;;; Make sure there are at least BYTES number of bytes in the input -;;; buffer. Keep calling REFILL-BUFFER/FD until that condition is met. +;;; buffer. Keep calling REFILL-INPUT-BUFFER until that condition is met. (defmacro input-at-least (stream bytes) - (let ((stream-var (gensym)) - (bytes-var (gensym))) - `(let ((,stream-var ,stream) - (,bytes-var ,bytes)) + (let ((stream-var (gensym "STREAM")) + (bytes-var (gensym "BYTES")) + (buffer-var (gensym "IBUF"))) + `(let* ((,stream-var ,stream) + (,bytes-var ,bytes) + (,buffer-var (fd-stream-ibuf ,stream-var))) (loop - (when (>= (- (fd-stream-ibuf-tail ,stream-var) - (fd-stream-ibuf-head ,stream-var)) + (when (>= (- (buffer-tail ,buffer-var) + (buffer-head ,buffer-var)) ,bytes-var) (return)) - (refill-buffer/fd ,stream-var))))) + (refill-input-buffer ,stream-var))))) (defmacro input-wrapper/variable-width ((stream bytes eof-error eof-value) &body read-forms) - (let ((stream-var (gensym)) - (retry-var (gensym)) - (element-var (gensym))) - `(let ((,stream-var ,stream) - (size nil)) - (if (fd-stream-unread ,stream-var) - (prog1 - (fd-stream-unread ,stream-var) - (setf (fd-stream-unread ,stream-var) nil) - (setf (fd-stream-listen ,stream-var) nil)) - (let ((,element-var nil) - (decode-break-reason nil)) - (do ((,retry-var t)) - ((not ,retry-var)) - (unless - (catch 'eof-input-catcher - (setf decode-break-reason - (block decode-break-reason - (input-at-least ,stream-var 1) - (let* ((byte (sap-ref-8 (fd-stream-ibuf-sap - ,stream-var) - (fd-stream-ibuf-head - ,stream-var)))) - (setq size ,bytes) - (input-at-least ,stream-var size) - (setq ,element-var (locally ,@read-forms)) - (setq ,retry-var nil)) - nil)) - (when decode-break-reason - (stream-decoding-error-and-handle stream - decode-break-reason)) - t) - (let ((octet-count (- (fd-stream-ibuf-tail ,stream-var) - (fd-stream-ibuf-head ,stream-var)))) - (when (or (zerop octet-count) - (and (not ,element-var) - (not decode-break-reason) - (stream-decoding-error-and-handle - stream octet-count))) - (setq ,retry-var nil))))) - (cond (,element-var - (incf (fd-stream-ibuf-head ,stream-var) size) - ,element-var) - (t - (eof-or-lose ,stream-var ,eof-error ,eof-value)))))))) + (let ((stream-var (gensym "STREAM")) + (retry-var (gensym "RETRY")) + (element-var (gensym "ELT"))) + `(let* ((,stream-var ,stream) + (ibuf (fd-stream-ibuf ,stream-var)) + (size nil)) + (block use-instead + (when (fd-stream-eof-forced-p ,stream-var) + (setf (fd-stream-eof-forced-p ,stream-var) nil) + (return-from use-instead + (eof-or-lose ,stream-var ,eof-error ,eof-value))) + (let ((,element-var nil) + (decode-break-reason nil)) + (do ((,retry-var t)) + ((not ,retry-var)) + (if (> (length (fd-stream-instead ,stream-var)) 0) + (let* ((instead (fd-stream-instead ,stream-var)) + (result (vector-pop instead)) + (pointer (fill-pointer instead))) + (when (= pointer 0) + (setf (fd-stream-listen ,stream-var) nil)) + (return-from use-instead result)) + (unless + (catch 'eof-input-catcher + (setf decode-break-reason + (block decode-break-reason + (input-at-least ,stream-var ,(if (consp bytes) (car bytes) `(setq size ,bytes))) + (let* ((byte (sap-ref-8 (buffer-sap ibuf) (buffer-head ibuf)))) + (declare (ignorable byte)) + ,@(when (consp bytes) + `((let ((sap (buffer-sap ibuf)) + (head (buffer-head ibuf))) + (declare (ignorable sap head)) + (setq size ,(cadr bytes)) + (input-at-least ,stream-var size)))) + (setq ,element-var (locally ,@read-forms)) + (setq ,retry-var nil)) + nil)) + (when decode-break-reason + (when (stream-decoding-error-and-handle + stream decode-break-reason) + (setq ,retry-var nil) + (throw 'eof-input-catcher nil))) + t) + (let ((octet-count (- (buffer-tail ibuf) + (buffer-head ibuf)))) + (when (or (zerop octet-count) + (and (not ,element-var) + (not decode-break-reason) + (stream-decoding-error-and-handle + stream octet-count))) + (setq ,retry-var nil)))))) + (cond (,element-var + (incf (buffer-head ibuf) size) + ,element-var) + (t + (eof-or-lose ,stream-var ,eof-error ,eof-value)))))))) ;;; a macro to wrap around all input routines to handle EOF-ERROR noise (defmacro input-wrapper ((stream bytes eof-error eof-value) &body read-forms) - (let ((stream-var (gensym)) - (element-var (gensym))) - `(let ((,stream-var ,stream)) - (if (fd-stream-unread ,stream-var) - (prog1 - (fd-stream-unread ,stream-var) - (setf (fd-stream-unread ,stream-var) nil) - (setf (fd-stream-listen ,stream-var) nil)) + (let ((stream-var (gensym "STREAM")) + (element-var (gensym "ELT"))) + `(let* ((,stream-var ,stream) + (ibuf (fd-stream-ibuf ,stream-var))) + (if (> (length (fd-stream-instead ,stream-var)) 0) + (bug "INSTEAD not empty in INPUT-WRAPPER for ~S" ,stream-var) (let ((,element-var (catch 'eof-input-catcher (input-at-least ,stream-var ,bytes) (locally ,@read-forms)))) (cond (,element-var - (incf (fd-stream-ibuf-head ,stream-var) ,bytes) + (incf (buffer-head (fd-stream-ibuf ,stream-var)) ,bytes) ,element-var) (t (eof-or-lose ,stream-var ,eof-error ,eof-value)))))))) @@ -796,8 +1154,8 @@ `(progn (defun ,name (stream eof-error eof-value) (input-wrapper/variable-width (stream ,size eof-error eof-value) - (let ((,sap (fd-stream-ibuf-sap stream)) - (,head (fd-stream-ibuf-head stream))) + (let ((,sap (buffer-sap ibuf)) + (,head (buffer-head ibuf))) ,@body))) (setf *input-routines* (nconc *input-routines* @@ -809,8 +1167,8 @@ `(progn (defun ,name (stream eof-error eof-value) (input-wrapper (stream ,size eof-error eof-value) - (let ((,sap (fd-stream-ibuf-sap stream)) - (,head (fd-stream-ibuf-head stream))) + (let ((,sap (buffer-sap ibuf)) + (,head (buffer-head ibuf))) ,@body))) (setf *input-routines* (nconc *input-routines* @@ -851,21 +1209,28 @@ ((signed-byte 32) 4 sap head) (signed-sap-ref-32 sap head)) - +#+#.(cl:if (cl:= sb!vm:n-word-bits 64) '(and) '(or)) +(progn + (def-input-routine input-unsigned-64bit-byte + ((unsigned-byte 64) 8 sap head) + (sap-ref-64 sap head)) + (def-input-routine input-signed-64bit-byte + ((signed-byte 64) 8 sap head) + (signed-sap-ref-64 sap head))) ;;; Find an input routine to use given the type. Return as multiple ;;; values the routine, the real type transfered, and the number of ;;; bytes per element (and for character types string input routine). (defun pick-input-routine (type &optional external-format) (when (subtypep type 'character) - (dolist (entry *external-formats*) - (when (member external-format (first entry)) - (return-from pick-input-routine - (values (symbol-function (third entry)) - 'character - 1 - (symbol-function (second entry)) - (first (first entry))))))) + (let ((entry (get-external-format-or-lose external-format))) + (return-from pick-input-routine + (values (ef-read-char-fun entry) + 'character + 1 + (ef-read-n-chars-fun entry) + (ef-char-size entry) + (canonize-external-format external-format entry))))) (dolist (entry *input-routines*) (when (and (subtypep type (first entry)) (or (not (fourth entry)) @@ -883,8 +1248,8 @@ (values (lambda (stream eof-error eof-value) (input-wrapper (stream (/ i 8) eof-error eof-value) - (let ((sap (fd-stream-ibuf-sap stream)) - (head (fd-stream-ibuf-head stream))) + (let ((sap (buffer-sap ibuf)) + (head (buffer-head ibuf))) (loop for j from 0 below (/ i 8) with result = 0 do (setf result @@ -899,8 +1264,8 @@ (values (lambda (stream eof-error eof-value) (input-wrapper (stream (/ i 8) eof-error eof-value) - (let ((sap (fd-stream-ibuf-sap stream)) - (head (fd-stream-ibuf-head stream))) + (let ((sap (buffer-sap ibuf)) + (head (buffer-head ibuf))) (loop for j from 0 below (/ i 8) with result = 0 do (setf result @@ -912,16 +1277,6 @@ `(signed-byte ,i) (/ i 8))))) -;;; Return a string constructed from SAP, START, and END. -(defun string-from-sap (sap start end) - (declare (type index start end)) - (let* ((length (- end start)) - (string (make-string length))) - (copy-ub8-from-system-area sap start - string 0 - length) - string)) - ;;; the N-BIN method for FD-STREAMs ;;; ;;; Note that this blocks in UNIX-READ. It is generally used where @@ -931,44 +1286,30 @@ &aux (total-copied 0)) (declare (type fd-stream stream)) (declare (type index start requested total-copied)) - (let ((unread (fd-stream-unread stream))) - (when unread - ;; AVERs designed to fail when we have more complicated - ;; character representations. - (aver (typep unread 'base-char)) - (aver (= (fd-stream-element-size stream) 1)) - ;; KLUDGE: this is a slightly-unrolled-and-inlined version of - ;; %BYTE-BLT - (etypecase buffer - (system-area-pointer - (setf (sap-ref-8 buffer start) (char-code unread))) - ((simple-unboxed-array (*)) - (setf (aref buffer start) unread))) - (setf (fd-stream-unread stream) nil) - (setf (fd-stream-listen stream) nil) - (incf total-copied))) + (aver (= (length (fd-stream-instead stream)) 0)) (do () (nil) (let* ((remaining-request (- requested total-copied)) - (head (fd-stream-ibuf-head stream)) - (tail (fd-stream-ibuf-tail stream)) + (ibuf (fd-stream-ibuf stream)) + (head (buffer-head ibuf)) + (tail (buffer-tail ibuf)) (available (- tail head)) (n-this-copy (min remaining-request available)) (this-start (+ start total-copied)) (this-end (+ this-start n-this-copy)) - (sap (fd-stream-ibuf-sap stream))) + (sap (buffer-sap ibuf))) (declare (type index remaining-request head tail available)) (declare (type index n-this-copy)) ;; Copy data from stream buffer into user's buffer. (%byte-blt sap head buffer this-start this-end) - (incf (fd-stream-ibuf-head stream) n-this-copy) + (incf (buffer-head ibuf) n-this-copy) (incf total-copied n-this-copy) ;; Maybe we need to refill the stream buffer. (cond (;; If there were enough data in the stream buffer, we're done. - (= total-copied requested) + (eql total-copied requested) (return total-copied)) (;; If EOF, we're done in another way. - (null (catch 'eof-input-catcher (refill-buffer/fd stream))) + (null (catch 'eof-input-catcher (refill-input-buffer stream))) (if eof-error-p (error 'end-of-file :stream stream) (return total-copied))) @@ -977,199 +1318,153 @@ )))) (defun fd-stream-resync (stream) - (dolist (entry *external-formats*) - (when (member (fd-stream-external-format stream) (first entry)) - (return-from fd-stream-resync - (funcall (symbol-function (eighth entry)) stream))))) - -;;; FIXME: OAOOM here vrt. *EXTERNAL-FORMAT-FUNCTIONS* in fd-stream.lisp -(defmacro define-external-format (external-format size output-restart - out-expr in-expr) - (let* ((name (first external-format)) - (out-function (symbolicate "OUTPUT-BYTES/" name)) - (format (format nil "OUTPUT-CHAR-~A-~~A-BUFFERED" (string name))) - (in-function (symbolicate "FD-STREAM-READ-N-CHARACTERS/" name)) - (in-char-function (symbolicate "INPUT-CHAR/" name))) + (let ((entry (get-external-format (fd-stream-external-format stream)))) + (when entry + (funcall (ef-resync-fun entry) stream)))) + +(defun get-fd-stream-character-sizer (stream) + (let ((entry (get-external-format (fd-stream-external-format stream)))) + (when entry + (ef-bytes-for-char-fun entry)))) + +(defun fd-stream-character-size (stream char) + (let ((sizer (get-fd-stream-character-sizer stream))) + (when sizer (funcall sizer char)))) + +(defun fd-stream-string-size (stream string) + (let ((sizer (get-fd-stream-character-sizer stream))) + (when sizer + (loop for char across string summing (funcall sizer char))))) + +(defun find-external-format (external-format) + (when external-format + (get-external-format external-format))) + +(defun variable-width-external-format-p (ef-entry) + (and ef-entry (not (null (ef-resync-fun ef-entry))))) + +(defun bytes-for-char-fun (ef-entry) + (if ef-entry (ef-bytes-for-char-fun ef-entry) (constantly 1))) + +(defmacro define-unibyte-mapping-external-format + (canonical-name (&rest other-names) &body exceptions) + (let ((->code-name (symbolicate canonical-name '->code-mapper)) + (code->-name (symbolicate 'code-> canonical-name '-mapper)) + (get-bytes-name (symbolicate 'get- canonical-name '-bytes)) + (string->-name (symbolicate 'string-> canonical-name)) + (define-string*-name (symbolicate 'define- canonical-name '->string*)) + (string*-name (symbolicate canonical-name '->string*)) + (define-string-name (symbolicate 'define- canonical-name '->string)) + (string-name (symbolicate canonical-name '->string)) + (->string-aref-name (symbolicate canonical-name '->string-aref))) `(progn - (defun ,out-function (stream string flush-p start end) - (let ((start (or start 0)) - (end (or end (length string)))) - (declare (type index start end)) - (when (and (not (fd-stream-dual-channel-p stream)) - (> (fd-stream-ibuf-tail stream) - (fd-stream-ibuf-head stream))) - (file-position stream (file-position stream))) - (unless (<= 0 start end (length string)) - (signal-bounding-indices-bad-error string start end)) - (do () - ((= end start)) - (setf (fd-stream-obuf-tail stream) - (flet ((do-it (string) - (let ((len (fd-stream-obuf-length stream)) - (sap (fd-stream-obuf-sap stream)) - (tail (fd-stream-obuf-tail stream))) - (declare (type index tail) - ;; STRING bounds have already been checked. - (optimize (safety 0))) - (loop - (,@(if output-restart - `(catch 'output-nothing) - `(progn)) - (do* () - ((or (= start end) (< (- len tail) 4))) - (let* ((byte (aref string start)) - (bits (char-code byte))) - ,out-expr - (incf tail ,size) - (incf start))) - ;; Exited from the loop normally - (return-from do-it tail)) - ;; Exited via CATCH. Skip the current character - ;; and try the inner loop again. - (incf start))))) - (declare (inline do-it)) - ;; Specialized versions for the common cases of - ;; SIMPLE-BASE-STRING and (SIMPLE-ARRAY CHARACTER) - ;; to avoid doing a generic AREF. - (etypecase string - (simple-base-string - (do-it (the simple-base-string string))) - #!+sb-unicode - ((simple-array character) - ;; For some reason the type information from the - ;; etypecase doesn't propagate through here without - ;; an explicit THE. - (do-it (the (simple-array character) string))) - (string - (do-it string))))) - (when (< start end) - (flush-output-buffer stream))) - (when flush-p - (flush-output-buffer stream)))) - (def-output-routines (,format - ,size - ,output-restart - (:none character) - (:line character) - (:full character)) - (if (char= byte #\Newline) - (setf (fd-stream-char-pos stream) 0) - (incf (fd-stream-char-pos stream))) - (let ((bits (char-code byte)) - (sap (fd-stream-obuf-sap stream)) - (tail (fd-stream-obuf-tail stream))) - ,out-expr)) - (defun ,in-function (stream buffer start requested eof-error-p - &aux (index start) (end (+ start requested))) - (declare (type fd-stream stream)) - (declare (type index start requested index end)) - (declare (type (simple-array character (#.+ansi-stream-in-buffer-length+)) buffer)) - (let ((unread (fd-stream-unread stream))) - (when unread - (setf (aref buffer index) unread) - (setf (fd-stream-unread stream) nil) - (setf (fd-stream-listen stream) nil) - (incf index))) - (do () - (nil) - (let* ((head (fd-stream-ibuf-head stream)) - (tail (fd-stream-ibuf-tail stream)) - (sap (fd-stream-ibuf-sap stream))) - (declare (type index head tail) - (type system-area-pointer sap)) - ;; Copy data from stream buffer into user's buffer. - (dotimes (i (min (truncate (- tail head) ,size) - (- end index))) - (declare (optimize speed)) - (let* ((byte (sap-ref-8 sap head))) - (setf (aref buffer index) ,in-expr) - (incf index) - (incf head ,size))) - (setf (fd-stream-ibuf-head stream) head) - ;; Maybe we need to refill the stream buffer. - (cond ( ;; If there was enough data in the stream buffer, we're done. - (= index end) - (return (- index start))) - ( ;; If EOF, we're done in another way. - (null (catch 'eof-input-catcher (refill-buffer/fd stream))) - (if eof-error-p - (error 'end-of-file :stream stream) - (return (- index start)))) - ;; Otherwise we refilled the stream buffer, so fall - ;; through into another pass of the loop. - )))) - (def-input-routine ,in-char-function (character ,size sap head) - (let ((byte (sap-ref-8 sap head))) - ,in-expr)) - (setf *external-formats* - (cons '(,external-format ,in-function ,in-char-function ,out-function - ,@(mapcar #'(lambda (buffering) - (intern (format nil format (string buffering)))) - '(:none :line :full))) - *external-formats*))))) + (define-unibyte-mapper ,->code-name ,code->-name + ,@exceptions) + (declaim (inline ,get-bytes-name)) + (defun ,get-bytes-name (string pos) + (declare (optimize speed (safety 0)) + (type simple-string string) + (type array-range pos)) + (get-latin-bytes #',code->-name ,canonical-name string pos)) + (defun ,string->-name (string sstart send null-padding) + (declare (optimize speed (safety 0)) + (type simple-string string) + (type array-range sstart send)) + (values (string->latin% string sstart send #',get-bytes-name null-padding))) + (defmacro ,define-string*-name (accessor type) + (declare (ignore type)) + (let ((name (make-od-name ',string*-name accessor))) + `(progn + (defun ,name (string sstart send array astart aend) + (,(make-od-name 'latin->string* accessor) + string sstart send array astart aend #',',->code-name))))) + (instantiate-octets-definition ,define-string*-name) + (defmacro ,define-string-name (accessor type) + (declare (ignore type)) + (let ((name (make-od-name ',string-name accessor))) + `(progn + (defun ,name (array astart aend) + (,(make-od-name 'latin->string accessor) + array astart aend #',',->code-name))))) + (instantiate-octets-definition ,define-string-name) + (define-unibyte-external-format ,canonical-name ,other-names + (let ((octet (,code->-name bits))) + (if octet + (setf (sap-ref-8 sap tail) octet) + (external-format-encoding-error stream bits))) + (let ((code (,->code-name byte))) + (if code + (code-char code) + (return-from decode-break-reason 1))) + ,->string-aref-name + ,string->-name)))) + +(defmacro define-unibyte-external-format + (canonical-name (&rest other-names) + out-form in-form octets-to-string-symbol string-to-octets-symbol) + `(define-external-format/variable-width (,canonical-name ,@other-names) + t #\? 1 + ,out-form + 1 + ,in-form + ,octets-to-string-symbol + ,string-to-octets-symbol)) (defmacro define-external-format/variable-width - (external-format output-restart out-size-expr - out-expr in-size-expr in-expr) + (external-format output-restart replacement-character + out-size-expr out-expr in-size-expr in-expr + octets-to-string-sym string-to-octets-sym) (let* ((name (first external-format)) (out-function (symbolicate "OUTPUT-BYTES/" name)) (format (format nil "OUTPUT-CHAR-~A-~~A-BUFFERED" (string name))) (in-function (symbolicate "FD-STREAM-READ-N-CHARACTERS/" name)) (in-char-function (symbolicate "INPUT-CHAR/" name)) - (resync-function (symbolicate "RESYNC/" name))) + (resync-function (symbolicate "RESYNC/" name)) + (size-function (symbolicate "BYTES-FOR-CHAR/" name)) + (read-c-string-function (symbolicate "READ-FROM-C-STRING/" name)) + (output-c-string-function (symbolicate "OUTPUT-TO-C-STRING/" name)) + (n-buffer (gensym "BUFFER"))) `(progn + (defun ,size-function (byte) + (declare (ignorable byte)) + ,out-size-expr) (defun ,out-function (stream string flush-p start end) (let ((start (or start 0)) (end (or end (length string)))) (declare (type index start end)) - (when (and (not (fd-stream-dual-channel-p stream)) - (> (fd-stream-ibuf-tail stream) - (fd-stream-ibuf-head stream))) - (file-position stream (file-position stream))) + (synchronize-stream-output stream) (unless (<= 0 start end (length string)) - (signal-bounding-indices-bad-error string start end)) + (sequence-bounding-indices-bad-error string start end)) (do () ((= end start)) - (setf (fd-stream-obuf-tail stream) - (flet ((do-it (string) - (let ((len (fd-stream-obuf-length stream)) - (sap (fd-stream-obuf-sap stream)) - (tail (fd-stream-obuf-tail stream))) - (declare (type index tail) - ;; STRING bounds have already been checked. - (optimize (safety 0))) - (loop - (,@(if output-restart - `(catch 'output-nothing) - `(progn)) - (do* () - ((or (= start end) (< (- len tail) 4))) - (let* ((byte (aref string start)) - (bits (char-code byte)) - (size ,out-size-expr)) - ,out-expr - (incf tail size) - (incf start))) - ;; Exited from the loop normally - (return-from do-it tail)) - ;; Exited via CATCH. Skip the current character - ;; and try the inner loop again. - (incf start))))) - (declare (inline do-it)) - ;; Specialized versions for the common cases of - ;; SIMPLE-BASE-STRING and (SIMPLE-ARRAY CHARACTER) - ;; to avoid doing a generic AREF. - (etypecase string - (simple-base-string - (do-it (the simple-base-string string))) - #!+sb-unicode - ((simple-array character) - ;; For some reason the type information from the - ;; etypecase doesn't propagate through here without - ;; an explicit THE. - (do-it (the (simple-array character) string))) - (string - (do-it string))))) + (let ((obuf (fd-stream-obuf stream))) + (string-dispatch (simple-base-string + #!+sb-unicode (simple-array character (*)) + string) + string + (let ((len (buffer-length obuf)) + (sap (buffer-sap obuf)) + ;; FIXME: Rename + (tail (buffer-tail obuf))) + (declare (type index tail) + ;; STRING bounds have already been checked. + (optimize (safety 0))) + (,@(if output-restart + `(catch 'output-nothing) + `(progn)) + (do* () + ((or (= start end) (< (- len tail) 4))) + (let* ((byte (aref string start)) + (bits (char-code byte)) + (size ,out-size-expr)) + ,out-expr + (incf tail size) + (setf (buffer-tail obuf) tail) + (incf start))) + (go flush)) + ;; Exited via CATCH: skip the current character. + (incf start)))) + flush (when (< start end) (flush-output-buffer stream))) (when flush-p @@ -1181,29 +1476,38 @@ (:none character) (:line character) (:full character)) - (if (char= byte #\Newline) + (if (eql byte #\Newline) (setf (fd-stream-char-pos stream) 0) (incf (fd-stream-char-pos stream))) (let ((bits (char-code byte)) - (sap (fd-stream-obuf-sap stream)) - (tail (fd-stream-obuf-tail stream))) + (sap (buffer-sap obuf)) + (tail (buffer-tail obuf))) ,out-expr)) (defun ,in-function (stream buffer start requested eof-error-p &aux (total-copied 0)) - (declare (type fd-stream stream)) - (declare (type index start requested total-copied)) - (declare (type (simple-array character (#.+ansi-stream-in-buffer-length+)) buffer)) - (let ((unread (fd-stream-unread stream))) - (when unread - (setf (aref buffer start) unread) - (setf (fd-stream-unread stream) nil) - (setf (fd-stream-listen stream) nil) - (incf total-copied))) + (declare (type fd-stream stream) + (type index start requested total-copied) + (type + (simple-array character (#.+ansi-stream-in-buffer-length+)) + buffer)) + (when (fd-stream-eof-forced-p stream) + (setf (fd-stream-eof-forced-p stream) nil) + (return-from ,in-function 0)) + (do ((instead (fd-stream-instead stream))) + ((= (fill-pointer instead) 0) + (setf (fd-stream-listen stream) nil)) + (setf (aref buffer (+ start total-copied)) (vector-pop instead)) + (incf total-copied) + (when (= requested total-copied) + (when (= (fill-pointer instead) 0) + (setf (fd-stream-listen stream) nil)) + (return-from ,in-function total-copied))) (do () (nil) - (let* ((head (fd-stream-ibuf-head stream)) - (tail (fd-stream-ibuf-tail stream)) - (sap (fd-stream-ibuf-sap stream)) + (let* ((ibuf (fd-stream-ibuf stream)) + (head (buffer-head ibuf)) + (tail (buffer-tail ibuf)) + (sap (buffer-sap ibuf)) (decode-break-reason nil)) (declare (type index head tail)) ;; Copy data from stream buffer into user's buffer. @@ -1211,15 +1515,19 @@ ((or (= tail head) (= requested total-copied))) (setf decode-break-reason (block decode-break-reason + ,@(when (consp in-size-expr) + `((when (> ,(car in-size-expr) (- tail head)) + (return)))) (let ((byte (sap-ref-8 sap head))) - (setq size ,in-size-expr) + (declare (ignorable byte)) + (setq size ,(if (consp in-size-expr) (cadr in-size-expr) in-size-expr)) (when (> size (- tail head)) (return)) (setf (aref buffer (+ start total-copied)) ,in-expr) (incf total-copied) (incf head size)) nil)) - (setf (fd-stream-ibuf-head stream) head) + (setf (buffer-head ibuf) head) (when decode-break-reason ;; If we've already read some characters on when the invalid ;; code sequence is detected, we return immediately. The @@ -1234,17 +1542,19 @@ (if eof-error-p (error 'end-of-file :stream stream) (return-from ,in-function total-copied))) - (setf head (fd-stream-ibuf-head stream)) - (setf tail (fd-stream-ibuf-tail stream)))) - (setf (fd-stream-ibuf-head stream) head) + ;; we might have been given stuff to use instead, so + ;; we have to return (and trust our caller to know + ;; what to do about TOTAL-COPIED being 0). + (return-from ,in-function total-copied))) + (setf (buffer-head ibuf) head) ;; Maybe we need to refill the stream buffer. - (cond ( ;; If there were enough data in the stream buffer, we're done. - (= total-copied requested) + (cond ( ;; If was data in the stream buffer, we're done. + (plusp total-copied) (return total-copied)) ( ;; If EOF, we're done in another way. (or (eq decode-break-reason 'eof) (null (catch 'eof-input-catcher - (refill-buffer/fd stream)))) + (refill-input-buffer stream)))) (if eof-error-p (error 'end-of-file :stream stream) (return total-copied))) @@ -1256,152 +1566,128 @@ ,in-size-expr sap head) (let ((byte (sap-ref-8 sap head))) + (declare (ignorable byte)) ,in-expr)) (defun ,resync-function (stream) - (loop (input-at-least stream 1) - (incf (fd-stream-ibuf-head stream)) - (unless (block decode-break-reason - (let* ((sap (fd-stream-ibuf-sap stream)) - (head (fd-stream-ibuf-head stream)) - (byte (sap-ref-8 sap head)) - (size ,in-size-expr)) - ,in-expr) - nil) - (return)))) - (setf *external-formats* - (cons '(,external-format ,in-function ,in-char-function ,out-function - ,@(mapcar #'(lambda (buffering) - (intern (format nil format (string buffering)))) - '(:none :line :full)) - ,resync-function) - *external-formats*))))) - -;;; Multiple names for the :ISO{,-}8859-* families are needed because on -;;; FreeBSD (and maybe other BSD systems), nl_langinfo("LATIN-1") will -;;; return "ISO8859-1" instead of "ISO-8859-1". -(define-external-format (:latin-1 :latin1 :iso-8859-1 :iso8859-1) - 1 t - (if (>= bits 256) - (stream-encoding-error-and-handle stream bits) - (setf (sap-ref-8 sap tail) bits)) - (code-char byte)) - -(define-external-format (:ascii :us-ascii :ansi_x3.4-1968 - :iso-646 :iso-646-us :|646|) - 1 t - (if (>= bits 128) - (stream-encoding-error-and-handle stream bits) - (setf (sap-ref-8 sap tail) bits)) - (code-char byte)) - -(let* ((table (let ((s (make-string 256))) - (map-into s #'code-char - '(#x00 #x01 #x02 #x03 #x9c #x09 #x86 #x7f #x97 #x8d #x8e #x0b #x0c #x0d #x0e #x0f - #x10 #x11 #x12 #x13 #x9d #x85 #x08 #x87 #x18 #x19 #x92 #x8f #x1c #x1d #x1e #x1f - #x80 #x81 #x82 #x83 #x84 #x0a #x17 #x1b #x88 #x89 #x8a #x8b #x8c #x05 #x06 #x07 - #x90 #x91 #x16 #x93 #x94 #x95 #x96 #x04 #x98 #x99 #x9a #x9b #x14 #x15 #x9e #x1a - #x20 #xa0 #xe2 #xe4 #xe0 #xe1 #xe3 #xe5 #xe7 #xf1 #xa2 #x2e #x3c #x28 #x2b #x7c - #x26 #xe9 #xea #xeb #xe8 #xed #xee #xef #xec #xdf #x21 #x24 #x2a #x29 #x3b #xac - #x2d #x2f #xc2 #xc4 #xc0 #xc1 #xc3 #xc5 #xc7 #xd1 #xa6 #x2c #x25 #x5f #x3e #x3f - #xf8 #xc9 #xca #xcb #xc8 #xcd #xce #xcf #xcc #x60 #x3a #x23 #x40 #x27 #x3d #x22 - #xd8 #x61 #x62 #x63 #x64 #x65 #x66 #x67 #x68 #x69 #xab #xbb #xf0 #xfd #xfe #xb1 - #xb0 #x6a #x6b #x6c #x6d #x6e #x6f #x70 #x71 #x72 #xaa #xba #xe6 #xb8 #xc6 #xa4 - #xb5 #x7e #x73 #x74 #x75 #x76 #x77 #x78 #x79 #x7a #xa1 #xbf #xd0 #xdd #xde #xae - #x5e #xa3 #xa5 #xb7 #xa9 #xa7 #xb6 #xbc #xbd #xbe #x5b #x5d #xaf #xa8 #xb4 #xd7 - #x7b #x41 #x42 #x43 #x44 #x45 #x46 #x47 #x48 #x49 #xad #xf4 #xf6 #xf2 #xf3 #xf5 - #x7d #x4a #x4b #x4c #x4d #x4e #x4f #x50 #x51 #x52 #xb9 #xfb #xfc #xf9 #xfa #xff - #x5c #xf7 #x53 #x54 #x55 #x56 #x57 #x58 #x59 #x5a #xb2 #xd4 #xd6 #xd2 #xd3 #xd5 - #x30 #x31 #x32 #x33 #x34 #x35 #x36 #x37 #x38 #x39 #xb3 #xdb #xdc #xd9 #xda #x9f)) - s)) - (reverse-table (let ((rt (make-array 256 :element-type '(unsigned-byte 8) :initial-element 0))) - (loop for char across table for i from 0 - do (aver (= 0 (aref rt (char-code char)))) - do (setf (aref rt (char-code char)) i)) - rt))) - (define-external-format (:ebcdic-us :ibm-037 :ibm037) - 1 t - (if (>= bits 256) - (stream-encoding-error-and-handle stream bits) - (setf (sap-ref-8 sap tail) (aref reverse-table bits))) - (aref table byte))) - - -#!+sb-unicode -(let ((latin-9-table (let ((table (make-string 256))) - (do ((i 0 (1+ i))) - ((= i 256)) - (setf (aref table i) (code-char i))) - (setf (aref table #xa4) (code-char #x20ac)) - (setf (aref table #xa6) (code-char #x0160)) - (setf (aref table #xa8) (code-char #x0161)) - (setf (aref table #xb4) (code-char #x017d)) - (setf (aref table #xb8) (code-char #x017e)) - (setf (aref table #xbc) (code-char #x0152)) - (setf (aref table #xbd) (code-char #x0153)) - (setf (aref table #xbe) (code-char #x0178)) - table)) - (latin-9-reverse-1 (make-array 16 - :element-type '(unsigned-byte 21) - :initial-contents '(#x0160 #x0161 #x0152 #x0153 0 0 0 0 #x0178 0 0 0 #x20ac #x017d #x017e 0))) - (latin-9-reverse-2 (make-array 16 - :element-type '(unsigned-byte 8) - :initial-contents '(#xa6 #xa8 #xbc #xbd 0 0 0 0 #xbe 0 0 0 #xa4 #xb4 #xb8 0)))) - (define-external-format (:latin-9 :latin9 :iso-8859-15 :iso8859-15) - 1 t - (setf (sap-ref-8 sap tail) - (if (< bits 256) - (if (= bits (char-code (aref latin-9-table bits))) - bits - (stream-encoding-error-and-handle stream byte)) - (if (= (aref latin-9-reverse-1 (logand bits 15)) bits) - (aref latin-9-reverse-2 (logand bits 15)) - (stream-encoding-error-and-handle stream byte)))) - (aref latin-9-table byte))) - -(define-external-format/variable-width (:utf-8 :utf8) nil - (let ((bits (char-code byte))) - (cond ((< bits #x80) 1) - ((< bits #x800) 2) - ((< bits #x10000) 3) - (t 4))) - (ecase size - (1 (setf (sap-ref-8 sap tail) bits)) - (2 (setf (sap-ref-8 sap tail) (logior #xc0 (ldb (byte 5 6) bits)) - (sap-ref-8 sap (1+ tail)) (logior #x80 (ldb (byte 6 0) bits)))) - (3 (setf (sap-ref-8 sap tail) (logior #xe0 (ldb (byte 4 12) bits)) - (sap-ref-8 sap (1+ tail)) (logior #x80 (ldb (byte 6 6) bits)) - (sap-ref-8 sap (+ 2 tail)) (logior #x80 (ldb (byte 6 0) bits)))) - (4 (setf (sap-ref-8 sap tail) (logior #xf0 (ldb (byte 3 18) bits)) - (sap-ref-8 sap (1+ tail)) (logior #x80 (ldb (byte 6 12) bits)) - (sap-ref-8 sap (+ 2 tail)) (logior #x80 (ldb (byte 6 6) bits)) - (sap-ref-8 sap (+ 3 tail)) (logior #x80 (ldb (byte 6 0) bits))))) - (cond ((< byte #x80) 1) - ((< byte #xc2) (return-from decode-break-reason 1)) - ((< byte #xe0) 2) - ((< byte #xf0) 3) - (t 4)) - (code-char (ecase size - (1 byte) - (2 (let ((byte2 (sap-ref-8 sap (1+ head)))) - (unless (<= #x80 byte2 #xbf) - (return-from decode-break-reason 2)) - (dpb byte (byte 5 6) byte2))) - (3 (let ((byte2 (sap-ref-8 sap (1+ head))) - (byte3 (sap-ref-8 sap (+ 2 head)))) - (unless (and (<= #x80 byte2 #xbf) - (<= #x80 byte3 #xbf)) - (return-from decode-break-reason 3)) - (dpb byte (byte 4 12) (dpb byte2 (byte 6 6) byte3)))) - (4 (let ((byte2 (sap-ref-8 sap (1+ head))) - (byte3 (sap-ref-8 sap (+ 2 head))) - (byte4 (sap-ref-8 sap (+ 3 head)))) - (unless (and (<= #x80 byte2 #xbf) - (<= #x80 byte3 #xbf) - (<= #x80 byte4 #xbf)) - (return-from decode-break-reason 4)) - (dpb byte (byte 3 18) - (dpb byte2 (byte 6 12) - (dpb byte3 (byte 6 6) byte4)))))))) + (let ((ibuf (fd-stream-ibuf stream)) + size) + (catch 'eof-input-catcher + (loop + (incf (buffer-head ibuf)) + (input-at-least stream ,(if (consp in-size-expr) (car in-size-expr) `(setq size ,in-size-expr))) + (unless (block decode-break-reason + (let* ((sap (buffer-sap ibuf)) + (head (buffer-head ibuf)) + (byte (sap-ref-8 sap head))) + (declare (ignorable byte)) + ,@(when (consp in-size-expr) + `((setq size ,(cadr in-size-expr)) + (input-at-least stream size))) + (setf head (buffer-head ibuf)) + ,in-expr) + nil) + (return)))))) + (defun ,read-c-string-function (sap element-type) + (declare (type system-area-pointer sap)) + (locally + (declare (optimize (speed 3) (safety 0))) + (let* ((stream ,name) + (size 0) (head 0) (byte 0) (char nil) + (decode-break-reason nil) + (length (dotimes (count (1- ARRAY-DIMENSION-LIMIT) count) + (setf decode-break-reason + (block decode-break-reason + (setf byte (sap-ref-8 sap head) + size ,(if (consp in-size-expr) (cadr in-size-expr) in-size-expr) + char ,in-expr) + (incf head size) + nil)) + (when decode-break-reason + (c-string-decoding-error ,name decode-break-reason)) + (when (zerop (char-code char)) + (return count)))) + (string (make-string length :element-type element-type))) + (declare (ignorable stream) + (type index head length) ;; size + (type (unsigned-byte 8) byte) + (type (or null character) char) + (type string string)) + (setf head 0) + (dotimes (index length string) + (setf decode-break-reason + (block decode-break-reason + (setf byte (sap-ref-8 sap head) + size ,(if (consp in-size-expr) (cadr in-size-expr) in-size-expr) + char ,in-expr) + (incf head size) + nil)) + (when decode-break-reason + (c-string-decoding-error ,name decode-break-reason)) + (setf (aref string index) char))))) + + (defun ,output-c-string-function (string) + (declare (type simple-string string)) + (locally + (declare (optimize (speed 3) (safety 0))) + (let* ((length (length string)) + (char-length (make-array (1+ length) :element-type 'index)) + (buffer-length + (+ (loop for i of-type index below length + for byte of-type character = (aref string i) + for bits = (char-code byte) + sum (setf (aref char-length i) + (the index ,out-size-expr))) + (let* ((byte (code-char 0)) + (bits (char-code byte))) + (declare (ignorable byte bits)) + (setf (aref char-length length) + (the index ,out-size-expr))))) + (tail 0) + (,n-buffer (make-array buffer-length + :element-type '(unsigned-byte 8))) + stream) + (declare (type index length buffer-length tail) + (type null stream) + (ignorable stream)) + (with-pinned-objects (,n-buffer) + (let ((sap (vector-sap ,n-buffer))) + (declare (system-area-pointer sap)) + (loop for i of-type index below length + for byte of-type character = (aref string i) + for bits = (char-code byte) + for size of-type index = (aref char-length i) + do (prog1 + ,out-expr + (incf tail size))) + (let* ((bits 0) + (byte (code-char bits)) + (size (aref char-length length))) + (declare (ignorable bits byte size)) + ,out-expr))) + ,n-buffer))) + + (let ((entry (%make-external-format + :names ',external-format + :default-replacement-character ,replacement-character + :read-n-chars-fun #',in-function + :read-char-fun #',in-char-function + :write-n-bytes-fun #',out-function + ,@(mapcan #'(lambda (buffering) + (list (intern (format nil "WRITE-CHAR-~A-BUFFERED-FUN" buffering) :keyword) + `#',(intern (format nil format (string buffering))))) + '(:none :line :full)) + :resync-fun #',resync-function + :bytes-for-char-fun #',size-function + :read-c-string-fun #',read-c-string-function + :write-c-string-fun #',output-c-string-function + :octets-to-string-fun (lambda (&rest rest) + (declare (dynamic-extent rest)) + (apply ',octets-to-string-sym rest)) + :string-to-octets-fun (lambda (&rest rest) + (declare (dynamic-extent rest)) + (apply ',string-to-octets-sym rest))))) + (dolist (ef ',external-format) + (setf (gethash ef *external-formats*) entry)))))) ;;;; utility functions (misc routines, etc) @@ -1418,6 +1704,7 @@ (character-stream-p (subtypep target-type 'character)) (bivalent-stream-p (eq element-type :default)) normalized-external-format + char-size (bin-routine #'ill-bin) (bin-type nil) (bin-size nil) @@ -1437,43 +1724,47 @@ (output-size nil) (output-bytes #'ill-bout)) - ;; drop buffers when direction changes - (when (and (fd-stream-obuf-sap fd-stream) (not output-p)) - (with-available-buffers-lock () - (push (fd-stream-obuf-sap fd-stream) *available-buffers*) - (setf (fd-stream-obuf-sap fd-stream) nil))) - (when (and (fd-stream-ibuf-sap fd-stream) (not input-p)) - (with-available-buffers-lock () - (push (fd-stream-ibuf-sap fd-stream) *available-buffers*) - (setf (fd-stream-ibuf-sap fd-stream) nil))) - (when input-p - (setf (fd-stream-ibuf-sap fd-stream) (next-available-buffer)) - (setf (fd-stream-ibuf-length fd-stream) bytes-per-buffer) - (setf (fd-stream-ibuf-tail fd-stream) 0)) + ;; Ensure that we have buffers in the desired direction(s) only, + ;; getting new ones and dropping/resetting old ones as necessary. + (let ((obuf (fd-stream-obuf fd-stream))) + (if output-p + (if obuf + (reset-buffer obuf) + (setf (fd-stream-obuf fd-stream) (get-buffer))) + (when obuf + (setf (fd-stream-obuf fd-stream) nil) + (release-buffer obuf)))) + + (let ((ibuf (fd-stream-ibuf fd-stream))) + (if input-p + (if ibuf + (reset-buffer ibuf) + (setf (fd-stream-ibuf fd-stream) (get-buffer))) + (when ibuf + (setf (fd-stream-ibuf fd-stream) nil) + (release-buffer ibuf)))) + + ;; FIXME: Why only for output? Why unconditionally? (when output-p - (setf (fd-stream-obuf-sap fd-stream) (next-available-buffer)) - (setf (fd-stream-obuf-length fd-stream) bytes-per-buffer) - (setf (fd-stream-obuf-tail fd-stream) 0) (setf (fd-stream-char-pos fd-stream) 0)) - (when (and character-stream-p - (eq external-format :default)) + (when (and character-stream-p (eq external-format :default)) (/show0 "/getting default external format") (setf external-format (default-external-format))) (when input-p (when (or (not character-stream-p) bivalent-stream-p) - (multiple-value-setq (bin-routine bin-type bin-size read-n-characters - normalized-external-format) - (pick-input-routine (if bivalent-stream-p '(unsigned-byte 8) - target-type) - external-format)) + (setf (values bin-routine bin-type bin-size read-n-characters + char-size normalized-external-format) + (pick-input-routine (if bivalent-stream-p '(unsigned-byte 8) + target-type) + external-format)) (unless bin-routine (error "could not find any input routine for ~S" target-type))) (when character-stream-p - (multiple-value-setq (cin-routine cin-type cin-size read-n-characters - normalized-external-format) - (pick-input-routine target-type external-format)) + (setf (values cin-routine cin-type cin-size read-n-characters + char-size normalized-external-format) + (pick-input-routine target-type external-format)) (unless cin-routine (error "could not find any input routine for ~S" target-type))) (setf (fd-stream-in fd-stream) cin-routine @@ -1482,8 +1773,8 @@ (setf input-size (or cin-size bin-size)) (setf input-type (or cin-type bin-type)) (when normalized-external-format - (setf (fd-stream-external-format fd-stream) - normalized-external-format)) + (setf (fd-stream-external-format fd-stream) normalized-external-format + (fd-stream-char-size fd-stream) char-size)) (when (= (or cin-size 1) (or bin-size 1) 1) (setf (fd-stream-n-bin fd-stream) ;XXX (if (and character-stream-p (not bivalent-stream-p)) @@ -1510,30 +1801,33 @@ (when output-p (when (or (not character-stream-p) bivalent-stream-p) - (multiple-value-setq (bout-routine bout-type bout-size output-bytes - normalized-external-format) - (pick-output-routine (if bivalent-stream-p - '(unsigned-byte 8) - target-type) - (fd-stream-buffering fd-stream) - external-format)) + (setf (values bout-routine bout-type bout-size output-bytes + char-size normalized-external-format) + (let ((buffering (fd-stream-buffering fd-stream))) + (if bivalent-stream-p + (pick-output-routine '(unsigned-byte 8) + (if (eq :line buffering) + :full + buffering) + external-format) + (pick-output-routine target-type buffering external-format)))) (unless bout-routine (error "could not find any output routine for ~S buffered ~S" (fd-stream-buffering fd-stream) target-type))) (when character-stream-p - (multiple-value-setq (cout-routine cout-type cout-size output-bytes - normalized-external-format) - (pick-output-routine target-type - (fd-stream-buffering fd-stream) - external-format)) + (setf (values cout-routine cout-type cout-size output-bytes + char-size normalized-external-format) + (pick-output-routine target-type + (fd-stream-buffering fd-stream) + external-format)) (unless cout-routine (error "could not find any output routine for ~S buffered ~S" (fd-stream-buffering fd-stream) target-type))) (when normalized-external-format - (setf (fd-stream-external-format fd-stream) - normalized-external-format)) + (setf (fd-stream-external-format fd-stream) normalized-external-format + (fd-stream-char-size fd-stream) char-size)) (when character-stream-p (setf (fd-stream-output-bytes fd-stream) output-bytes)) (setf (fd-stream-out fd-stream) cout-routine @@ -1567,126 +1861,173 @@ input-type output-type)))))) +;;; Handles the resource-release aspects of stream closing, and marks +;;; it as closed. +(defun release-fd-stream-resources (fd-stream) + (handler-case + (without-interrupts + ;; Drop handlers first. + (when (fd-stream-handler fd-stream) + (remove-fd-handler (fd-stream-handler fd-stream)) + (setf (fd-stream-handler fd-stream) nil)) + ;; Disable interrupts so that a asynch unwind will not leave + ;; us with a dangling finalizer (that would close the same + ;; --possibly reassigned-- FD again), or a stream with a closed + ;; FD that appears open. + (sb!unix:unix-close (fd-stream-fd fd-stream)) + (set-closed-flame fd-stream) + (when (fboundp 'cancel-finalization) + (cancel-finalization fd-stream))) + ;; On error unwind from WITHOUT-INTERRUPTS. + (serious-condition (e) + (error e))) + ;; Release all buffers. If this is undone, or interrupted, + ;; we're still safe: buffers have finalizers of their own. + (release-fd-stream-buffers fd-stream)) + +;;; Flushes the current input buffer and any supplied replacements, +;;; and returns the input buffer, and the amount of of flushed input +;;; in bytes. +(defun flush-input-buffer (stream) + (let ((unread (length (fd-stream-instead stream)))) + (setf (fill-pointer (fd-stream-instead stream)) 0) + (let ((ibuf (fd-stream-ibuf stream))) + (if ibuf + (let ((head (buffer-head ibuf)) + (tail (buffer-tail ibuf))) + (values (reset-buffer ibuf) (- (+ unread tail) head))) + (values nil unread))))) + +(defun fd-stream-clear-input (stream) + (flush-input-buffer stream) + #!+win32 + (progn + (sb!win32:fd-clear-input (fd-stream-fd stream)) + (setf (fd-stream-listen stream) nil)) + #!-win32 + (catch 'eof-input-catcher + (loop until (sysread-may-block-p stream) + do + (refill-input-buffer stream) + (reset-buffer (fd-stream-ibuf stream))) + t)) + ;;; Handle miscellaneous operations on FD-STREAM. (defun fd-stream-misc-routine (fd-stream operation &optional arg1 arg2) (declare (ignore arg2)) (case operation (:listen - (or (not (eql (fd-stream-ibuf-head fd-stream) - (fd-stream-ibuf-tail fd-stream))) - (fd-stream-listen fd-stream) - (setf (fd-stream-listen fd-stream) - (eql (sb!unix:with-restarted-syscall () - (sb!alien:with-alien ((read-fds (sb!alien:struct - sb!unix:fd-set))) - (sb!unix:fd-zero read-fds) - (sb!unix:fd-set (fd-stream-fd fd-stream) read-fds) - (sb!unix:unix-fast-select (1+ (fd-stream-fd fd-stream)) - (sb!alien:addr read-fds) - nil nil 0 0))) - 1)))) + (labels ((do-listen () + (let ((ibuf (fd-stream-ibuf fd-stream))) + (or (not (eql (buffer-head ibuf) (buffer-tail ibuf))) + (fd-stream-listen fd-stream) + #!+win32 + (sb!win32:fd-listen (fd-stream-fd fd-stream)) + #!-win32 + ;; If the read can block, LISTEN will certainly return NIL. + (if (sysread-may-block-p fd-stream) + nil + ;; Otherwise select(2) and CL:LISTEN have slightly + ;; different semantics. The former returns that an FD + ;; is readable when a read operation wouldn't block. + ;; That includes EOF. However, LISTEN must return NIL + ;; at EOF. + (progn (catch 'eof-input-catcher + ;; r-b/f too calls select, but it shouldn't + ;; block as long as read can return once w/o + ;; blocking + (refill-input-buffer fd-stream)) + ;; At this point either IBUF-HEAD != IBUF-TAIL + ;; and FD-STREAM-LISTEN is NIL, in which case + ;; we should return T, or IBUF-HEAD == + ;; IBUF-TAIL and FD-STREAM-LISTEN is :EOF, in + ;; which case we should return :EOF for this + ;; call and all future LISTEN call on this stream. + ;; Call ourselves again to determine which case + ;; applies. + (do-listen))))))) + (do-listen))) (:unread - (setf (fd-stream-unread fd-stream) arg1) - (setf (fd-stream-listen fd-stream) t)) + (decf (buffer-head (fd-stream-ibuf fd-stream)) + (fd-stream-character-size fd-stream arg1))) (:close - (cond (arg1 ; We got us an abort on our hands. - (when (fd-stream-handler fd-stream) - (sb!sys:remove-fd-handler (fd-stream-handler fd-stream)) - (setf (fd-stream-handler fd-stream) nil)) - ;; We can't do anything unless we know what file were - ;; dealing with, and we don't want to do anything - ;; strange unless we were writing to the file. - (when (and (fd-stream-file fd-stream) - (fd-stream-obuf-sap fd-stream)) - (if (fd-stream-original fd-stream) - ;; If the original is EQ to file we are appending - ;; and can just close the file without renaming. - (unless (eq (fd-stream-original fd-stream) - (fd-stream-file fd-stream)) - ;; We have a handle on the original, just revert. + ;; Drop input buffers + (setf (ansi-stream-in-index fd-stream) +ansi-stream-in-buffer-length+ + (ansi-stream-cin-buffer fd-stream) nil + (ansi-stream-in-buffer fd-stream) nil) + (cond (arg1 + ;; We got us an abort on our hands. + (let ((outputp (fd-stream-obuf fd-stream)) + (file (fd-stream-file fd-stream)) + (orig (fd-stream-original fd-stream))) + ;; This takes care of the important stuff -- everything + ;; rest is cleaning up the file-system, which we cannot + ;; do on some platforms as long as the file is open. + (release-fd-stream-resources fd-stream) + ;; We can't do anything unless we know what file were + ;; dealing with, and we don't want to do anything + ;; strange unless we were writing to the file. + (when (and outputp file) + (if orig + ;; If the original is EQ to file we are appending to + ;; and can just close the file without renaming. + (unless (eq orig file) + ;; We have a handle on the original, just revert. + (multiple-value-bind (okay err) + (sb!unix:unix-rename orig file) + ;; FIXME: Why is this a SIMPLE-STREAM-ERROR, and the + ;; others are SIMPLE-FILE-ERRORS? Surely they should + ;; all be the same? + (unless okay + (error 'simple-stream-error + :format-control + "~@" + :format-arguments + (list file orig fd-stream (strerror err)) + :stream fd-stream)))) + ;; We can't restore the original, and aren't + ;; appending, so nuke that puppy. + ;; + ;; FIXME: This is currently the fate of superseded + ;; files, and according to the CLOSE spec this is + ;; wrong. However, there seems to be no clean way to + ;; do that that doesn't involve either copying the + ;; data (bad if the :abort resulted from a full + ;; disk), or renaming the old file temporarily + ;; (probably bad because stream opening becomes more + ;; racy). (multiple-value-bind (okay err) - (sb!unix:unix-rename (fd-stream-original fd-stream) - (fd-stream-file fd-stream)) + (sb!unix:unix-unlink file) (unless okay - (simple-stream-perror - "couldn't restore ~S to its original contents" - fd-stream - err)))) - ;; We can't restore the original, and aren't - ;; appending, so nuke that puppy. - ;; - ;; FIXME: This is currently the fate of superseded - ;; files, and according to the CLOSE spec this is - ;; wrong. However, there seems to be no clean way to - ;; do that that doesn't involve either copying the - ;; data (bad if the :abort resulted from a full - ;; disk), or renaming the old file temporarily - ;; (probably bad because stream opening becomes more - ;; racy). - (multiple-value-bind (okay err) - (sb!unix:unix-unlink (fd-stream-file fd-stream)) - (unless okay - (error 'simple-file-error - :pathname (fd-stream-file fd-stream) - :format-control - "~@" - :format-arguments (list (fd-stream-file fd-stream) - (strerror err)))))))) + (error 'simple-file-error + :pathname file + :format-control + "~@" + :format-arguments + (list file fd-stream (strerror err))))))))) (t - (fd-stream-misc-routine fd-stream :finish-output) - (when (and (fd-stream-original fd-stream) - (fd-stream-delete-original fd-stream)) - (multiple-value-bind (okay err) - (sb!unix:unix-unlink (fd-stream-original fd-stream)) - (unless okay - (error 'simple-file-error - :pathname (fd-stream-original fd-stream) - :format-control - "~@" - :format-arguments - (list (fd-stream-original fd-stream) - fd-stream - (strerror err)))))))) - (when (fboundp 'cancel-finalization) - (cancel-finalization fd-stream)) - (sb!unix:unix-close (fd-stream-fd fd-stream)) - (when (fd-stream-obuf-sap fd-stream) - (with-available-buffers-lock () - (push (fd-stream-obuf-sap fd-stream) *available-buffers*) - (setf (fd-stream-obuf-sap fd-stream) nil))) - (when (fd-stream-ibuf-sap fd-stream) - (with-available-buffers-lock () - (push (fd-stream-ibuf-sap fd-stream) *available-buffers*) - (setf (fd-stream-ibuf-sap fd-stream) nil))) - (sb!impl::set-closed-flame fd-stream)) + (finish-fd-stream-output fd-stream) + (let ((orig (fd-stream-original fd-stream))) + (when (and orig (fd-stream-delete-original fd-stream)) + (multiple-value-bind (okay err) (sb!unix:unix-unlink orig) + (unless okay + (error 'simple-file-error + :pathname orig + :format-control + "~@" + :format-arguments + (list orig fd-stream (strerror err))))))) + ;; In case of no-abort close, don't *really* close the + ;; stream until the last moment -- the cleaning up of the + ;; original can be done first. + (release-fd-stream-resources fd-stream)))) (:clear-input - (setf (fd-stream-unread fd-stream) nil) - (setf (fd-stream-ibuf-head fd-stream) 0) - (setf (fd-stream-ibuf-tail fd-stream) 0) - (catch 'eof-input-catcher - (loop - (let ((count (sb!unix:with-restarted-syscall () - (sb!alien:with-alien ((read-fds (sb!alien:struct - sb!unix:fd-set))) - (sb!unix:fd-zero read-fds) - (sb!unix:fd-set (fd-stream-fd fd-stream) read-fds) - (sb!unix:unix-fast-select (1+ (fd-stream-fd fd-stream)) - (sb!alien:addr read-fds) - nil nil 0 0))))) - (cond ((eql count 1) - (refill-buffer/fd fd-stream) - (setf (fd-stream-ibuf-head fd-stream) 0) - (setf (fd-stream-ibuf-tail fd-stream) 0)) - (t - (return t))))))) + (fd-stream-clear-input fd-stream)) (:force-output (flush-output-buffer fd-stream)) (:finish-output - (flush-output-buffer fd-stream) - (do () - ((null (fd-stream-output-later fd-stream))) - (sb!sys:serve-all-events))) + (finish-fd-stream-output fd-stream)) (:element-type (fd-stream-element-type fd-stream)) (:external-format @@ -1710,7 +2051,7 @@ :format-control "~S is not a stream associated with a file." :format-arguments (list fd-stream))) (multiple-value-bind (okay dev ino mode nlink uid gid rdev size - atime mtime ctime blksize blocks) + atime mtime ctime blksize blocks) (sb!unix:unix-fstat (fd-stream-fd fd-stream)) (declare (ignore ino nlink uid gid rdev atime mtime ctime blksize blocks)) @@ -1719,88 +2060,114 @@ (if (zerop mode) nil (truncate size (fd-stream-element-size fd-stream))))) - ;; FIXME: I doubt this is correct in the presence of Unicode, - ;; since fd-stream FILE-POSITION is measured in bytes. (:file-string-length (etypecase arg1 - (character 1) - (string (length arg1)))) + (character (fd-stream-character-size fd-stream arg1)) + (string (fd-stream-string-size fd-stream arg1)))) (:file-position - (fd-stream-file-position fd-stream arg1)))) - -(defun fd-stream-file-position (stream &optional newpos) - (declare (type fd-stream stream) - (type (or (alien sb!unix:off-t) (member nil :start :end)) newpos)) - (if (null newpos) - (sb!sys:without-interrupts - ;; First, find the position of the UNIX file descriptor in the file. - (multiple-value-bind (posn errno) - (sb!unix:unix-lseek (fd-stream-fd stream) 0 sb!unix:l_incr) - (declare (type (or (alien sb!unix:off-t) null) posn)) - (cond ((integerp posn) - ;; Adjust for buffered output: If there is any output - ;; buffered, the *real* file position will be larger - ;; than reported by lseek() because lseek() obviously - ;; cannot take into account output we have not sent - ;; yet. - (dolist (later (fd-stream-output-later stream)) - (incf posn (- (caddr later) - (cadr later)))) - (incf posn (fd-stream-obuf-tail stream)) - ;; Adjust for unread input: If there is any input - ;; read from UNIX but not supplied to the user of the - ;; stream, the *real* file position will smaller than - ;; reported, because we want to look like the unread - ;; stuff is still available. - (decf posn (- (fd-stream-ibuf-tail stream) - (fd-stream-ibuf-head stream))) - (when (fd-stream-unread stream) - (decf posn)) - ;; Divide bytes by element size. - (truncate posn (fd-stream-element-size stream))) - ((eq errno sb!unix:espipe) - nil) - (t - (sb!sys:with-interrupts - (simple-stream-perror "failure in Unix lseek() on ~S" - stream - errno)))))) - (let ((offset 0) origin) - (declare (type (alien sb!unix:off-t) offset)) - ;; Make sure we don't have any output pending, because if we - ;; move the file pointer before writing this stuff, it will be - ;; written in the wrong location. - (flush-output-buffer stream) - (do () - ((null (fd-stream-output-later stream))) - (sb!sys:serve-all-events)) - ;; Clear out any pending input to force the next read to go to - ;; the disk. - (setf (fd-stream-unread stream) nil) - (setf (fd-stream-ibuf-head stream) 0) - (setf (fd-stream-ibuf-tail stream) 0) - ;; Trash cached value for listen, so that we check next time. - (setf (fd-stream-listen stream) nil) - ;; Now move it. - (cond ((eq newpos :start) - (setf offset 0 origin sb!unix:l_set)) - ((eq newpos :end) - (setf offset 0 origin sb!unix:l_xtnd)) - ((typep newpos '(alien sb!unix:off-t)) - (setf offset (* newpos (fd-stream-element-size stream)) - origin sb!unix:l_set)) - (t - (error "invalid position given to FILE-POSITION: ~S" newpos))) - (multiple-value-bind (posn errno) - (sb!unix:unix-lseek (fd-stream-fd stream) offset origin) - (cond ((typep posn '(alien sb!unix:off-t)) - t) - ((eq errno sb!unix:espipe) - nil) - (t - (simple-stream-perror "error in Unix lseek() on ~S" - stream - errno))))))) + (if arg1 + (fd-stream-set-file-position fd-stream arg1) + (fd-stream-get-file-position fd-stream))))) + +;; FIXME: Think about this. +;; +;; (defun finish-fd-stream-output (fd-stream) +;; (let ((timeout (fd-stream-timeout fd-stream))) +;; (loop while (fd-stream-output-queue fd-stream) +;; ;; FIXME: SIGINT while waiting for a timeout will +;; ;; cause a timeout here. +;; do (when (and (not (serve-event timeout)) timeout) +;; (signal-timeout 'io-timeout +;; :stream fd-stream +;; :direction :write +;; :seconds timeout))))) + +(defun finish-fd-stream-output (stream) + (flush-output-buffer stream) + (do () + ((null (fd-stream-output-queue stream))) + (aver (fd-stream-serve-events stream)) + (serve-all-events))) + +(defun fd-stream-get-file-position (stream) + (declare (fd-stream stream)) + (without-interrupts + (let ((posn (sb!unix:unix-lseek (fd-stream-fd stream) 0 sb!unix:l_incr))) + (declare (type (or (alien sb!unix:off-t) null) posn)) + ;; We used to return NIL for errno==ESPIPE, and signal an error + ;; in other failure cases. However, CLHS says to return NIL if + ;; the position cannot be determined -- so that's what we do. + (when (integerp posn) + ;; Adjust for buffered output: If there is any output + ;; buffered, the *real* file position will be larger + ;; than reported by lseek() because lseek() obviously + ;; cannot take into account output we have not sent + ;; yet. + (dolist (buffer (fd-stream-output-queue stream)) + (incf posn (- (buffer-tail buffer) (buffer-head buffer)))) + (let ((obuf (fd-stream-obuf stream))) + (when obuf + (incf posn (buffer-tail obuf)))) + ;; Adjust for unread input: If there is any input + ;; read from UNIX but not supplied to the user of the + ;; stream, the *real* file position will smaller than + ;; reported, because we want to look like the unread + ;; stuff is still available. + (let ((ibuf (fd-stream-ibuf stream))) + (when ibuf + (decf posn (- (buffer-tail ibuf) (buffer-head ibuf))))) + ;; Divide bytes by element size. + (truncate posn (fd-stream-element-size stream)))))) + +(defun fd-stream-set-file-position (stream position-spec) + (declare (fd-stream stream)) + (check-type position-spec + (or (alien sb!unix:off-t) (member nil :start :end)) + "valid file position designator") + (tagbody + :again + ;; Make sure we don't have any output pending, because if we + ;; move the file pointer before writing this stuff, it will be + ;; written in the wrong location. + (finish-fd-stream-output stream) + ;; Disable interrupts so that interrupt handlers doing output + ;; won't screw us. + (without-interrupts + (unless (fd-stream-output-finished-p stream) + ;; We got interrupted and more output came our way during + ;; the interrupt. Wrapping the FINISH-FD-STREAM-OUTPUT in + ;; WITHOUT-INTERRUPTS gets nasty as it can signal errors, + ;; so we prefer to do things like this... + (go :again)) + ;; Clear out any pending input to force the next read to go to + ;; the disk. + (flush-input-buffer stream) + ;; Trash cached value for listen, so that we check next time. + (setf (fd-stream-listen stream) nil) + ;; Now move it. + (multiple-value-bind (offset origin) + (case position-spec + (:start + (values 0 sb!unix:l_set)) + (:end + (values 0 sb!unix:l_xtnd)) + (t + (values (* position-spec (fd-stream-element-size stream)) + sb!unix:l_set))) + (declare (type (alien sb!unix:off-t) offset)) + (let ((posn (sb!unix:unix-lseek (fd-stream-fd stream) + offset origin))) + ;; CLHS says to return true if the file-position was set + ;; succesfully, and NIL otherwise. We are to signal an error + ;; only if the given position was out of bounds, and that is + ;; dealt with above. In times past we used to return NIL for + ;; errno==ESPIPE, and signal an error in other cases. + ;; + ;; FIXME: We are still liable to signal an error if flushing + ;; output fails. + (return-from fd-stream-set-file-position + (typep posn '(alien sb!unix:off-t)))))))) + ;;;; creation routines (MAKE-FD-STREAM and OPEN) @@ -1821,6 +2188,9 @@ ;;; FILE is the name of the file (will be returned by PATHNAME). ;;; ;;; NAME is used to identify the stream when printed. +;;; +;;; If SERVE-EVENTS is true, SERVE-EVENT machinery is used to +;;; handle blocking IO on the stream. (defun make-fd-stream (fd &key (input nil input-p) @@ -1828,6 +2198,7 @@ (element-type 'base-char) (buffering :full) (external-format :default) + serve-events timeout file original @@ -1839,7 +2210,7 @@ (format nil "file ~A" file) (format nil "descriptor ~W" fd))) auto-close) - (declare (type index fd) (type (or index null) timeout) + (declare (type index fd) (type (or real null) timeout) (type (member :none :line :full) buffering)) (cond ((not (or input-p output-p)) (setf input t)) @@ -1853,8 +2224,12 @@ :pathname pathname :buffering buffering :dual-channel-p dual-channel-p - :external-format external-format - :timeout timeout))) + :bivalent-p (eq element-type :default) + :serve-events serve-events + :timeout + (if timeout + (coerce timeout 'single-float) + nil)))) (set-fd-stream-routines stream element-type external-format input output input-buffer-p) (when (and auto-close (fboundp 'finalize)) @@ -1863,14 +2238,15 @@ (sb!unix:unix-close fd) #!+sb-show (format *terminal-io* "** closed file descriptor ~W **~%" - fd)))) + fd)) + :dont-save t)) stream)) ;;; Pick a name to use for the backup file for the :IF-EXISTS ;;; :RENAME-AND-DELETE and :RENAME options. (defun pick-backup-name (name) - (declare (type simple-base-string name)) - (concatenate 'simple-base-string name ".bak")) + (declare (type simple-string name)) + (concatenate 'simple-string name ".bak")) ;;; Ensure that the given arg is one of the given list of valid ;;; things. Allow the user to fix any problems. @@ -1920,19 +2296,23 @@ ;; Calculate useful stuff. (multiple-value-bind (input output mask) - (case direction + (ecase direction (:input (values t nil sb!unix:o_rdonly)) (:output (values nil t sb!unix:o_wronly)) (:io (values t t sb!unix:o_rdwr)) (:probe (values t nil sb!unix:o_rdonly))) (declare (type index mask)) - (let* ((pathname (merge-pathnames filename)) - (namestring - (cond ((unix-namestring pathname input)) - ((and input (eq if-does-not-exist :create)) - (unix-namestring pathname nil)) - ((and (eq direction :io) (not if-does-not-exist-given)) - (unix-namestring pathname nil))))) + (let* (;; PATHNAME is the pathname we associate with the stream. + (pathname (merge-pathnames filename)) + (physical (physicalize-pathname pathname)) + (truename (probe-file physical)) + ;; NAMESTRING is the native namestring we open the file with. + (namestring (cond (truename + (native-namestring truename :as-file t)) + ((or (not input) + (and input (eq if-does-not-exist :create)) + (and (eq direction :io) (not if-does-not-exist-given))) + (native-namestring physical :as-file t))))) ;; Process if-exists argument if we are doing any output. (cond (output (unless if-exists-given @@ -1997,7 +2377,7 @@ (when (and output (= (logand orig-mode #o170000) #o40000)) (error 'simple-file-error - :pathname namestring + :pathname pathname :format-control "can't open ~S for output: is a directory" :format-arguments (list namestring))) @@ -2048,6 +2428,7 @@ :delete-original delete-original :pathname pathname :dual-channel-p nil + :serve-events nil :input-buffer-p t :auto-close t)) (:probe @@ -2097,25 +2478,49 @@ (setf *trace-output* *standard-output*) (values)) +(defun stream-deinit () + ;; Unbind to make sure we're not accidently dealing with it + ;; before we're ready (or after we think it's been deinitialized). + (with-available-buffers-lock () + (without-package-locks + (makunbound '*available-buffers*)))) + +(defun stdstream-external-format (outputp) + (declare (ignorable outputp)) + (let* ((keyword #!+win32 (if outputp (sb!win32::console-output-codepage) (sb!win32::console-input-codepage)) + #!-win32 (default-external-format)) + (ef (get-external-format keyword)) + (replacement (ef-default-replacement-character ef))) + `(,keyword :replacement ,replacement))) + ;;; This is called whenever a saved core is restarted. -(defun stream-reinit () - (setf *available-buffers* nil) +(defun stream-reinit (&optional init-buffers-p) + (when init-buffers-p + (with-available-buffers-lock () + (aver (not (boundp '*available-buffers*))) + (setf *available-buffers* nil))) (with-output-to-string (*error-output*) (setf *stdin* - (make-fd-stream 0 :name "standard input" :input t :buffering :line)) + (make-fd-stream 0 :name "standard input" :input t :buffering :line + :element-type :default + :serve-events t + :external-format (stdstream-external-format nil))) (setf *stdout* - (make-fd-stream 1 :name "standard output" :output t :buffering :line)) + (make-fd-stream 1 :name "standard output" :output t :buffering :line + :element-type :default + :external-format (stdstream-external-format t))) (setf *stderr* - (make-fd-stream 2 :name "standard error" :output t :buffering :line)) + (make-fd-stream 2 :name "standard error" :output t :buffering :line + :element-type :default + :external-format (stdstream-external-format t))) (let* ((ttyname #.(coerce "/dev/tty" 'simple-base-string)) (tty (sb!unix:unix-open ttyname sb!unix:o_rdwr #o666))) (if tty (setf *tty* - (make-fd-stream tty - :name "the terminal" - :input t - :output t - :buffering :line + (make-fd-stream tty :name "the terminal" + :input t :output t :buffering :line + :external-format (stdstream-external-format t) + :serve-events t :auto-close t)) (setf *tty* (make-two-way-stream *stdin* *stdout*)))) (princ (get-output-stream-string *error-output*) *stderr*)) @@ -2137,7 +2542,8 @@ (cond (new-name (setf (fd-stream-pathname stream) new-name) (setf (fd-stream-file stream) - (unix-namestring new-name nil)) + (native-namestring (physicalize-pathname new-name) + :as-file t)) t) (t (fd-stream-pathname stream)))))