(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-lock* (sb!thread:make-mutex
+ :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
+ ;; CALL-WITH-SYSTEM-MUTEX 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)))
+ ;; debugger while holding the mutex would lose badly.
+ `(sb!thread::with-system-mutex (*available-buffers-lock*)
+ ,@body))
-(defconstant bytes-per-buffer (* 4 1024)
+(defconstant +bytes-per-buffer+ (* 4 1024)
#!+sb-doc
- "Number of bytes per buffer.")
-
-;;; Return the next available buffer, creating one if necessary.
-#!-sb-fluid (declaim (inline next-available-buffer))
-(defun next-available-buffer ()
+ "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*))))))
\f
;;;; the FD-STREAM structure
;; the type of element being transfered
(element-type 'base-char)
;; the Unix file descriptor
- (fd -1 :type fixnum)
+ (fd -1 :type #!-win32 fixnum #!+win32 sb!vm:signed-word)
+ ;; What do we know about the FD?
+ (fd-type :unknown :type keyword)
;; controls when the output buffer is flushed
(buffering :full :type (member :full :line :none))
;; controls whether the input buffer must be cleared before output
;; 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))))
\f
+;;;; 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.
+ (incf head count)
+ (setf (buffer-head obuf) head)
+ (queue-or-wait))
+ #!-win32
+ ((eql errno sb!unix:ewouldblock)
+ ;; Blocking, queue or wair.
+ (queue-or-wait))
+ ;; if interrupted on win32, just try again
+ #!+win32 ((eql errno sb!unix:eintr))
+ (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))))
+\f
;;;; output routines and related noise
(defvar *output-routines* ()
:format-arguments
(list note-format (list pathname) (strerror errno))))
-(defun stream-decoding-error (stream octets)
- (error 'stream-decoding-error
- :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
- :stream stream
+(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 sap offset count)
+ (error 'c-string-decoding-error
+ :external-format external-format
+ :octets (sap-ref-octets sap offset count)))
;;; 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)))
- (loop for i from 0 below octet-count
- collect (sap-ref-8 sap (+ head i)))))
+ (error 'stream-decoding-error
+ :external-format (stream-external-format stream)
+ :stream stream
+ :octets (let ((buffer (fd-stream-ibuf stream)))
+ (sap-ref-octets (buffer-sap buffer)
+ (buffer-head buffer)
+ octet-count)))
(attempt-resync ()
:report (lambda (stream)
(format stream
- "~@<Attempt to resync the stream at a character ~
+ "~@<Attempt to resync the stream at a ~
character boundary and continue.~@:>"))
(fd-stream-resync stream)
nil)
(force-end-of-file ()
:report (lambda (stream)
(format stream "~@<Force an end of file.~@:>"))
- t)))
+ (setf (fd-stream-eof-forced-p stream) t))
+ (input-replacement (string)
+ :report (lambda (stream)
+ (format stream "~@<Use string as replacement input, ~
+ attempt to resync at a character ~
+ boundary and continue.~@:>"))
+ :interactive (lambda ()
+ (format *query-io* "~@<Enter a string: ~@:>")
+ (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
- (stream-encoding-error stream code)
+ (error 'stream-encoding-error
+ :external-format (stream-external-format stream)
+ :stream stream
+ :code code)
(output-nothing ()
:report (lambda (stream)
(format stream "~@<Skip output of this character.~@:>"))
+ (throw 'output-nothing nil))
+ (output-replacement (string)
+ :report (lambda (stream)
+ (format stream "~@<Output replacement string.~@:>"))
+ :interactive (lambda ()
+ (format *query-io* "~@<Enter a string: ~@:>")
+ (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))
- ,(unless (eq (car buffering) :none)
- `(when (< (fd-stream-obuf-length ,stream-var)
- (+ (fd-stream-obuf-tail ,stream-var)
- ,size))
- (flush-output-buffer ,stream-var)))
- ,(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))))
- ,(if restart
- `(catch 'output-nothing
- ,@body
- (incf (fd-stream-obuf-tail ,stream-var) ,size))
- `(progn
- ,@body
- (incf (fd-stream-obuf-tail ,stream-var) ,size)))
- ,(ecase (car buffering)
- (:none
- `(flush-output-buffer ,stream-var))
- (:line
- `(when (eq (char-code byte) (char-code #\Newline))
- (flush-output-buffer ,stream-var)))
- (:full))
- (values))))
+ (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 (< (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)
+ `(synchronize-stream-output ,stream-var))
+ ,(if restart
+ `(catch 'output-nothing
+ ,@body
+ (setf (buffer-tail obuf) (+ tail ,size)))
+ `(progn
+ ,@body
+ (setf (buffer-tail obuf) (+ tail ,size))))
+ ,(ecase (car buffering)
+ (:none
+ `(flush-output-buffer ,stream-var))
+ (:line
+ `(when (eql byte #\Newline)
+ (flush-output-buffer ,stream-var)))
+ (:full))
+ (values))))
(defmacro def-output-routines/variable-width
((name-fmt size restart external-format &rest bufferings)
(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*
(: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"
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"
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"
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"
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"
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"
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 <not a SAP>.
- (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 <not a SAP>.
- (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))
(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))))
(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)))))
;;; 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
+ #!+win32
+ (go :main)
+
+ ;; Check for blocking input before touching the stream if we are to
+ ;; serve events: if the FD is blocking, we don't want to try an uninterruptible
+ ;; read(). Regular files should never block, so we can elide the check.
+ (if (and (neq :regular (fd-stream-fd-type stream))
+ (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 #!-win32 :wait-for-input #!+win32 :main))
+ ((: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)
+ (if (eql errno
+ #!+win32 sb!unix:eintr
+ #!-win32 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))))))))
`(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*
`(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*
((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))
(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
(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
`(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
&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)))
))))
(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
(: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.
((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
(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)))
,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 sap head 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 sap head 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))))))
\f
;;;; utility functions (misc routines, etc)
(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)
(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
(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))
(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
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
+ "~@<Couldn't restore ~S to its original contents ~
+ from ~S while closing ~S: ~2I~_~A~:>"
+ :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
- "~@<couldn't remove ~S: ~2I~_~A~:>"
- :format-arguments (list (fd-stream-file fd-stream)
- (strerror err))))))))
+ (error 'simple-file-error
+ :pathname file
+ :format-control
+ "~@<Couldn't remove ~S while closing ~S: ~2I~_~A~:>"
+ :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
- "~@<couldn't delete ~S during close of ~S: ~
- ~2I~_~A~:>"
- :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
+ "~@<couldn't delete ~S while closing ~S: ~2I~_~A~:>"
+ :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
(fd-stream-external-format fd-stream))
(:interactive-p
- (= 1 (the (member 0 1)
- (sb!unix:unix-isatty (fd-stream-fd fd-stream)))))
+ (plusp (the (integer 0)
+ (sb!unix:unix-isatty (fd-stream-fd fd-stream)))))
(:line-length
80)
(:charpos
:expected-type 'fd-stream
:format-control "~S is not a stream associated with a file."
:format-arguments (list fd-stream)))
+ #!-win32
(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))
(simple-stream-perror "failed Unix fstat(2) on ~S" fd-stream dev))
(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.
+ (truncate size (fd-stream-element-size fd-stream))))
+ #!+win32
+ (let* ((handle (fd-stream-fd fd-stream))
+ (element-size (fd-stream-element-size fd-stream)))
+ (multiple-value-bind (got native-size)
+ (sb!win32:get-file-size-ex handle 0)
+ (if (zerop got)
+ ;; Might be a block device, in which case we fall back to
+ ;; a non-atomic workaround:
+ (let* ((here (sb!unix:unix-lseek handle 0 sb!unix:l_incr))
+ (there (sb!unix:unix-lseek handle 0 sb!unix:l_xtnd)))
+ (when (and here there)
+ (sb!unix:unix-lseek handle here sb!unix:l_set)
+ (truncate there element-size)))
+ (truncate native-size element-size)))))
(: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:unix-offset) 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:unix-offset) (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:unix-offset) 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:unix-offset))))))))
+
\f
;;;; creation routines (MAKE-FD-STREAM and OPEN)
;;; 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)
(element-type 'base-char)
(buffering :full)
(external-format :default)
+ serve-events
timeout
file
original
(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))
((not (or input output))
(error "File descriptor must be opened either for input or output.")))
(let ((stream (%make-fd-stream :fd fd
+ :fd-type (progn
+ #!-win32 (sb!unix:fd-type fd)
+ ;; KLUDGE.
+ #!+win32 (if serve-events
+ :unknown
+ :regular))
:name name
:file file
:original original
: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))
(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.
(defun open (filename
&key
- (direction :input)
- (element-type 'base-char)
- (if-exists nil if-exists-given)
- (if-does-not-exist nil if-does-not-exist-given)
- (external-format :default)
- &aux ; Squelch assignment warning.
+ (direction :input)
+ (element-type 'base-char)
+ (if-exists nil if-exists-given)
+ (if-does-not-exist nil if-does-not-exist-given)
+ (external-format :default)
+ &aux ; Squelch assignment warning.
(direction direction)
(if-does-not-exist if-does-not-exist)
(if-exists if-exists))
;; 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)))))
- ;; Process if-exists argument if we are doing any output.
- (cond (output
- (unless if-exists-given
- (setf if-exists
- (if (eq (pathname-version pathname) :newest)
- :new-version
- :error)))
- (ensure-one-of if-exists
- '(:error :new-version :rename
- :rename-and-delete :overwrite
- :append :supersede nil)
- :if-exists)
- (case if-exists
- ((:new-version :error nil)
- (setf mask (logior mask sb!unix:o_excl)))
- ((:rename :rename-and-delete)
- (setf mask (logior mask sb!unix:o_creat)))
- ((:supersede)
- (setf mask (logior mask sb!unix:o_trunc)))
- (:append
- (setf mask (logior mask sb!unix:o_append)))))
- (t
- (setf if-exists :ignore-this-arg)))
-
- (unless if-does-not-exist-given
- (setf if-does-not-exist
- (cond ((eq direction :input) :error)
- ((and output
- (member if-exists '(:overwrite :append)))
- :error)
- ((eq direction :probe)
+ (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)))))
+ (flet ((open-error (format-control &rest format-arguments)
+ (error 'simple-file-error
+ :pathname pathname
+ :format-control format-control
+ :format-arguments format-arguments)))
+ ;; Process if-exists argument if we are doing any output.
+ (cond (output
+ (unless if-exists-given
+ (setf if-exists
+ (if (eq (pathname-version pathname) :newest)
+ :new-version
+ :error)))
+ (ensure-one-of if-exists
+ '(:error :new-version :rename
+ :rename-and-delete :overwrite
+ :append :supersede nil)
+ :if-exists)
+ (case if-exists
+ ((:new-version :error nil)
+ (setf mask (logior mask sb!unix:o_excl)))
+ ((:rename :rename-and-delete)
+ (setf mask (logior mask sb!unix:o_creat)))
+ ((:supersede)
+ (setf mask (logior mask sb!unix:o_trunc)))
+ (:append
+ (setf mask (logior mask sb!unix:o_append)))))
+ (t
+ (setf if-exists :ignore-this-arg)))
+
+ (unless if-does-not-exist-given
+ (setf if-does-not-exist
+ (cond ((eq direction :input) :error)
+ ((and output
+ (member if-exists '(:overwrite :append)))
+ :error)
+ ((eq direction :probe)
+ nil)
+ (t
+ :create))))
+ (ensure-one-of if-does-not-exist
+ '(:error :create nil)
+ :if-does-not-exist)
+ (cond ((and if-exists-given
+ truename
+ (eq if-exists :new-version))
+ (open-error "OPEN :IF-EXISTS :NEW-VERSION is not supported ~
+ when a new version must be created."))
+ ((eq if-does-not-exist :create)
+ (setf mask (logior mask sb!unix:o_creat)))
+ ((not (member if-exists '(:error nil))))
+ ;; Both if-does-not-exist and if-exists now imply
+ ;; that there will be no opening of files, and either
+ ;; an error would be signalled, or NIL returned
+ ((and (not if-exists) (not if-does-not-exist))
+ (return-from open))
+ ((and if-exists if-does-not-exist)
+ (open-error "OPEN :IF-DOES-NOT-EXIST ~s ~
+ :IF-EXISTS ~s will always signal an error."
+ if-does-not-exist if-exists))
+ (truename
+ (if if-exists
+ (open-error "File exists ~s." pathname)
+ (return-from open)))
+ (if-does-not-exist
+ (open-error "File does not exist ~s." pathname))
+ (t
+ (return-from open)))
+ (let ((original (case if-exists
+ ((:rename :rename-and-delete)
+ (pick-backup-name namestring))
+ ((:append :overwrite)
+ ;; KLUDGE: Prevent CLOSE from deleting
+ ;; appending streams when called with :ABORT T
+ namestring)))
+ (delete-original (eq if-exists :rename-and-delete))
+ (mode #o666))
+ (when (and original (not (eq original namestring)))
+ ;; We are doing a :RENAME or :RENAME-AND-DELETE. Determine
+ ;; whether the file already exists, make sure the original
+ ;; file is not a directory, and keep the mode.
+ (let ((exists
+ (and namestring
+ (multiple-value-bind (okay err/dev inode orig-mode)
+ (sb!unix:unix-stat namestring)
+ (declare (ignore inode)
+ (type (or index null) orig-mode))
+ (cond
+ (okay
+ (when (and output (= (logand orig-mode #o170000)
+ #o40000))
+ (error 'simple-file-error
+ :pathname pathname
+ :format-control
+ "can't open ~S for output: is a directory"
+ :format-arguments (list namestring)))
+ (setf mode (logand orig-mode #o777))
+ t)
+ ((eql err/dev sb!unix:enoent)
+ nil)
+ (t
+ (simple-file-perror "can't find ~S"
+ namestring
+ err/dev)))))))
+ (unless (and exists
+ (rename-the-old-one namestring original))
+ (setf original nil)
+ (setf delete-original nil)
+ ;; In order to use :SUPERSEDE instead, we have to make
+ ;; sure SB!UNIX:O_CREAT corresponds to
+ ;; IF-DOES-NOT-EXIST. SB!UNIX:O_CREAT was set before
+ ;; because of IF-EXISTS being :RENAME.
+ (unless (eq if-does-not-exist :create)
+ (setf mask
+ (logior (logandc2 mask sb!unix:o_creat)
+ sb!unix:o_trunc)))
+ (setf if-exists :supersede))))
+
+ ;; Now we can try the actual Unix open(2).
+ (multiple-value-bind (fd errno)
+ (if namestring
+ (sb!unix:unix-open namestring mask mode)
+ (values nil sb!unix:enoent))
+ (flet ((vanilla-open-error ()
+ (simple-file-perror "error opening ~S" pathname errno)))
+ (cond ((numberp fd)
+ (case direction
+ ((:input :output :io)
+ ;; For O_APPEND opened files, lseek returns 0 until first write.
+ ;; So we jump ahead here.
+ (when (eq if-exists :append)
+ (sb!unix:unix-lseek fd 0 sb!unix:l_xtnd))
+ (make-fd-stream fd
+ :input input
+ :output output
+ :element-type element-type
+ :external-format external-format
+ :file namestring
+ :original original
+ :delete-original delete-original
+ :pathname pathname
+ :dual-channel-p nil
+ :serve-events nil
+ :input-buffer-p t
+ :auto-close t))
+ (:probe
+ (let ((stream
+ (%make-fd-stream :name namestring
+ :fd fd
+ :pathname pathname
+ :element-type element-type)))
+ (close stream)
+ stream))))
+ ((eql errno sb!unix:enoent)
+ (case if-does-not-exist
+ (:error (vanilla-open-error))
+ (:create
+ (open-error "~@<The path ~2I~_~S ~I~_does not exist.~:>"
+ pathname))
+ (t nil)))
+ ((and (eql errno sb!unix:eexist) (null if-exists))
nil)
(t
- :create))))
- (ensure-one-of if-does-not-exist
- '(:error :create nil)
- :if-does-not-exist)
- (if (eq if-does-not-exist :create)
- (setf mask (logior mask sb!unix:o_creat)))
-
- (let ((original (case if-exists
- ((:rename :rename-and-delete)
- (pick-backup-name namestring))
- ((:append :overwrite)
- ;; KLUDGE: Provent CLOSE from deleting
- ;; appending streams when called with :ABORT T
- namestring)))
- (delete-original (eq if-exists :rename-and-delete))
- (mode #o666))
- (when (and original (not (eq original namestring)))
- ;; We are doing a :RENAME or :RENAME-AND-DELETE. Determine
- ;; whether the file already exists, make sure the original
- ;; file is not a directory, and keep the mode.
- (let ((exists
- (and namestring
- (multiple-value-bind (okay err/dev inode orig-mode)
- (sb!unix:unix-stat namestring)
- (declare (ignore inode)
- (type (or index null) orig-mode))
- (cond
- (okay
- (when (and output (= (logand orig-mode #o170000)
- #o40000))
- (error 'simple-file-error
- :pathname namestring
- :format-control
- "can't open ~S for output: is a directory"
- :format-arguments (list namestring)))
- (setf mode (logand orig-mode #o777))
- t)
- ((eql err/dev sb!unix:enoent)
- nil)
- (t
- (simple-file-perror "can't find ~S"
- namestring
- err/dev)))))))
- (unless (and exists
- (rename-the-old-one namestring original))
- (setf original nil)
- (setf delete-original nil)
- ;; In order to use :SUPERSEDE instead, we have to make
- ;; sure SB!UNIX:O_CREAT corresponds to
- ;; IF-DOES-NOT-EXIST. SB!UNIX:O_CREAT was set before
- ;; because of IF-EXISTS being :RENAME.
- (unless (eq if-does-not-exist :create)
- (setf mask
- (logior (logandc2 mask sb!unix:o_creat)
- sb!unix:o_trunc)))
- (setf if-exists :supersede))))
-
- ;; Now we can try the actual Unix open(2).
- (multiple-value-bind (fd errno)
- (if namestring
- (sb!unix:unix-open namestring mask mode)
- (values nil sb!unix:enoent))
- (labels ((open-error (format-control &rest format-arguments)
- (error 'simple-file-error
- :pathname pathname
- :format-control format-control
- :format-arguments format-arguments))
- (vanilla-open-error ()
- (simple-file-perror "error opening ~S" pathname errno)))
- (cond ((numberp fd)
- (case direction
- ((:input :output :io)
- (make-fd-stream fd
- :input input
- :output output
- :element-type element-type
- :external-format external-format
- :file namestring
- :original original
- :delete-original delete-original
- :pathname pathname
- :dual-channel-p nil
- :input-buffer-p t
- :auto-close t))
- (:probe
- (let ((stream
- (%make-fd-stream :name namestring
- :fd fd
- :pathname pathname
- :element-type element-type)))
- (close stream)
- stream))))
- ((eql errno sb!unix:enoent)
- (case if-does-not-exist
- (:error (vanilla-open-error))
- (:create
- (open-error "~@<The path ~2I~_~S ~I~_does not exist.~:>"
- pathname))
- (t nil)))
- ((and (eql errno sb!unix:eexist) (null if-exists))
- nil)
- (t
- (vanilla-open-error)))))))))
+ (vanilla-open-error))))))))))
\f
;;;; initialization
(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 (fd outputp)
+ #!-win32 (declare (ignore fd outputp))
+ (let* ((keyword #!+win32 (if (and (/= fd -1)
+ (logbitp 0 fd)
+ (logbitp 1 fd))
+ :ucs-2
+ (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))
- (setf *stdout*
- (make-fd-stream 1 :name "standard output" :output t :buffering :line))
- (setf *stderr*
- (make-fd-stream 2 :name "standard error" :output t :buffering :line))
+ (multiple-value-bind (in out err)
+ #!-win32 (values 0 1 2)
+ #!+win32 (sb!win32::get-std-handles)
+ (flet ((stdio-stream (handle name inputp outputp)
+ (make-fd-stream
+ handle
+ :name name
+ :input inputp
+ :output outputp
+ :buffering :line
+ :element-type :default
+ :serve-events inputp
+ :external-format (stdstream-external-format handle outputp))))
+ (setf *stdin* (stdio-stream in "standard input" t nil))
+ (setf *stdout* (stdio-stream out "standard output" nil t))
+ (setf *stderr* (stdio-stream err "standard error" nil t))))
+ #!+win32
+ (setf *tty* (make-two-way-stream *stdin* *stdout*))
+ #!-win32
(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
+ tty t)
+ :serve-events (or #!-win32 t)
:auto-close t))
(setf *tty* (make-two-way-stream *stdin* *stdout*))))
(princ (get-output-stream-string *error-output*) *stderr*))
(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)))))
projects / sbcl.git / blobdiff