;;
;; ...again, once we have smarted locks the spinlock here can become
;; a mutex.
- `(sb!thread::call-with-system-spinlock (lambda () ,@body)
- *available-buffers-spinlock*))
+ `(sb!thread::with-system-spinlock (*available-buffers-spinlock*)
+ ,@body))
(defconstant +bytes-per-buffer+ (* 4 1024)
#!+sb-doc
(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)
+ (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 nil :type (or buffer null))
(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)
(aver (< head tail))
(%queue-and-replace-output-buffer stream))
(t
- ;; Try a non-blocking write, queue whatever is left over.
+ ;; 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)
- (let ((length (- tail head)))
- (multiple-value-bind (count errno)
- (sb!unix:unix-write (fd-stream-fd stream) (buffer-sap obuf)
- head length)
- (cond ((eql count length)
- ;; Complete write -- we can use the same buffer.
- (reset-buffer obuf))
- (count
- ;; Partial write -- update buffer status and queue.
- ;; Do not use INCF! Another thread might have moved
- ;; head...
- (setf (buffer-head obuf) (+ count head))
- (%queue-and-replace-output-buffer stream))
- #!-win32
- ((eql errno sb!unix:ewouldblock)
- ;; Blocking, queue.
- (%queue-and-replace-output-buffer stream))
- (t
- (simple-stream-perror "Couldn't write to ~s"
- stream errno)))))))))))
+ (loop
+ (let ((length (- tail head)))
+ (multiple-value-bind (count errno)
+ (sb!unix:unix-write (fd-stream-fd stream) (buffer-sap obuf)
+ head length)
+ (flet ((queue-or-wait ()
+ (if (fd-stream-serve-events stream)
+ (return (%queue-and-replace-output-buffer stream))
+ (or (wait-until-fd-usable (fd-stream-fd stream) :output
+ (fd-stream-timeout stream)
+ nil)
+ (signal-timeout 'io-timeout
+ :stream stream
+ :direction :output
+ :seconds (fd-stream-timeout stream))))))
+ (cond ((eql count length)
+ ;; Complete write -- we can use the same buffer.
+ (return (reset-buffer obuf)))
+ (count
+ ;; Partial write -- update buffer status and
+ ;; queue or wait. Do not use INCF! Another
+ ;; thread might have moved head...
+ (setf (buffer-head obuf) (+ count head))
+ (queue-or-wait))
+ #!-win32
+ ((eql errno sb!unix:ewouldblock)
+ ;; Blocking, queue or wair.
+ (queue-or-wait))
+ (t
+ (simple-stream-perror "Couldn't write to ~s"
+ stream errno)))))))))))))
;;; Helper for FLUSH-OUTPUT-BUFFER -- returns the new buffer.
(defun %queue-and-replace-output-buffer (stream)
+ (aver (fd-stream-serve-events stream))
(let ((queue (fd-stream-output-queue stream))
(later (list (or (fd-stream-obuf stream) (bug "Missing obuf."))))
(new (get-buffer)))
;;; 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
;;; 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.
-(defun output-raw-bytes (stream thing &optional start end)
+(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))))
-
-(define-compiler-macro output-raw-bytes (stream thing &optional start end)
- (deprecation-warning 'output-raw-bytes)
- (let ((x (gensym "THING")))
- `(let ((,x ,thing))
- (write-or-buffer-output ,stream ,x (or ,start 0) (or ,end (length ,x))))))
\f
;;;; output routines and related noise
(defun stream-decoding-error (stream octets)
(error 'stream-decoding-error
+ :external-format (stream-external-format stream)
:stream stream
;; FIXME: dunno how to get at OCTETS currently, or even if
;; that's the right thing to report.
:octets octets))
(defun stream-encoding-error (stream code)
(error 'stream-encoding-error
+ :external-format (stream-external-format stream)
:stream stream
:code code))
(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
(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))))
(defun external-format-encoding-error (stream code)
(stream-encoding-error-and-handle stream code)
(c-string-encoding-error stream code)))
-(defun external-format-decoding-error (stream octet-count)
- (if (streamp stream)
- (stream-decoding-error stream octet-count)
- (c-string-decoding-error stream octet-count)))
-
(defun synchronize-stream-output (stream)
;; If we're reading and writing on the same file, flush buffered
;; input and rewind file position accordingly.
(position #\newline thing :from-end t
:start start :end end))))
(if (and (typep thing 'base-string)
- (eq (fd-stream-external-format stream) :latin-1))
+ (eq (fd-stream-external-format-keyword stream) :latin-1))
(ecase (fd-stream-buffering stream)
(:full
(buffer-output stream thing start end))
(setf (fd-stream-char-pos stream) (- end last-newline 1))
(incf (fd-stream-char-pos stream) (- end start))))))
-(defvar *external-formats* ()
+(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)
- (dolist (entry *external-formats*)
- (when (member external-format (first entry))
- (return entry))))
-
-(defun get-external-format-function (external-format index)
- (let ((entry (get-external-format external-format)))
- (when entry (nth index entry))))
+ (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)
- (let ((entry (get-external-format external-format)))
- (when 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))
;;; 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
+ #!+win32
;; This answers T at EOF on win32, I think.
(not (sb!win32:fd-listen (fd-stream-fd stream)))
- #-win32
- (sb!unix:with-restarted-syscall (count errno)
- (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 stream) read-fds)
- (sb!unix:unix-fast-select (1+ (fd-stream-fd stream))
- (sb!alien:addr read-fds)
- nil nil 0 0))
- (case count
- ((1) nil)
- ((0) t)
- (otherwise
- (simple-stream-perror "couldn't check whether ~S is readable"
- stream
- errno)))))
+ #!-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)
- (let ((fd (fd-stream-fd stream))
- (errno 0)
- (count 0))
+ (dx-let ((fd (fd-stream-fd stream))
+ (errno 0)
+ (count 0))
(tagbody
- ;; Check for blocking input before touching the stream, as if
- ;; we happen to wait we are liable to be interrupted, and the
- ;; interrupt handler may use the same stream.
- (if (sysread-may-block-p stream)
+ ;; Check for blocking input before touching the stream if we are to
+ ;; serve events: if the FD is blocking, we don't want to hang on the
+ ;; write if we are to serve events or notice timeouts.
+ (if (and (or (fd-stream-serve-events stream)
+ (fd-stream-timeout stream)
+ *deadline*)
+ (sysread-may-block-p stream))
(go :wait-for-input)
(go :main))
;; These (:CLOSED-FLAME and :READ-ERROR) tags are here so what
: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))
- (signal-timeout 'io-timeout :stream stream :direction :read
+ (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.
- (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.
- (let* ((ibuf (or (fd-stream-ibuf stream) (go :closed-flame)))
- (sap (buffer-sap ibuf))
- (length (buffer-length ibuf))
- (head (buffer-head ibuf))
- (tail (buffer-tail ibuf)))
- (declare (index length head tail))
- (unless (zerop head)
- (cond ((eql head tail)
- ;; Buffer is empty, but not at yet reset -- make it so.
- (setf head 0
- tail 0)
- (reset-buffer ibuf))
- (t
- ;; Buffer has things in it, but they are not at the head
- ;; -- move them there.
- (let ((n (- tail head)))
- (system-area-ub8-copy sap head sap 0 n)
- (setf head 0
- (buffer-head ibuf) head
- tail n
- (buffer-tail ibuf) tail)))))
- (setf (fd-stream-listen stream) nil)
- (setf (values count errno)
- (sb!unix:unix-read fd (sap+ sap tail) (- length tail)))
- (cond ((null count)
- #!+win32
- (go :read-error)
- #!-win32
- (if (eql errno sb!unix:ewouldblock)
- (go :wait-for-input)
- (go :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)))))))
+
+ ;; Execute the nlx outside without-interrupts to ensure the
+ ;; resulting thunk is stack-allocatable.
+ ((lambda (return-reason)
+ (ecase return-reason
+ ((nil)) ; fast path normal cases
+ ((:wait-for-input) (go :wait-for-input))
+ ((:closed-flame) (go :closed-flame))
+ ((:read-error) (go :read-error))))
+ (without-interrupts
+ ;; Check the buffer: if it is null, then someone has closed
+ ;; the stream from underneath us. This is not ment to fix
+ ;; multithreaded races, but to deal with interrupt handlers
+ ;; closing the stream.
+ (block nil
+ (prog1 nil
+ (let* ((ibuf (or (fd-stream-ibuf stream) (return :closed-flame)))
+ (sap (buffer-sap ibuf))
+ (length (buffer-length ibuf))
+ (head (buffer-head ibuf))
+ (tail (buffer-tail ibuf)))
+ (declare (index length head tail)
+ (inline sb!unix:unix-read))
+ (unless (zerop head)
+ (cond ((eql head tail)
+ ;; Buffer is empty, but not at yet reset -- make it so.
+ (setf head 0
+ tail 0)
+ (reset-buffer ibuf))
+ (t
+ ;; Buffer has things in it, but they are not at the
+ ;; head -- move them there.
+ (let ((n (- tail head)))
+ (system-area-ub8-copy sap head sap 0 n)
+ (setf head 0
+ (buffer-head ibuf) head
+ tail n
+ (buffer-tail ibuf) tail)))))
+ (setf (fd-stream-listen stream) nil)
+ (setf (values count errno)
+ (sb!unix:unix-read fd (sap+ sap tail) (- length tail)))
+ (cond ((null count)
+ #!+win32
+ (return :read-error)
+ #!-win32
+ (if (eql errno sb!unix:ewouldblock)
+ (return :wait-for-input)
+ (return :read-error)))
+ ((zerop count)
+ (setf (fd-stream-listen stream) :eof)
+ (/show0 "THROWing EOF-INPUT-CATCHER")
+ (throw 'eof-input-catcher nil))
+ (t
+ ;; Success! (Do not use INCF, for sake of other threads.)
+ (setf (buffer-tail ibuf) (+ count tail))))))))))
count))
;;; Make sure there are at least BYTES number of bytes in the input
`(let* ((,stream-var ,stream)
(ibuf (fd-stream-ibuf ,stream-var))
(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 (buffer-sap ibuf)
- (buffer-head ibuf))))
- (declare (ignorable byte))
- (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 (- (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))))))))
+ (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)
(element-var (gensym "ELT")))
`(let* ((,stream-var ,stream)
(ibuf (fd-stream-ibuf ,stream-var)))
- (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))
+ (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)
;;; 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))
&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))
))))
(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)))))
+ (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)
- (dolist (entry *external-formats*)
- (when (member (fd-stream-external-format stream) (first entry))
- (return-from get-fd-stream-character-sizer (ninth entry)))))
+ (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)))
(defun find-external-format (external-format)
(when external-format
- (find external-format *external-formats* :test #'member :key #'car)))
+ (get-external-format external-format)))
(defun variable-width-external-format-p (ef-entry)
- (when (eighth ef-entry) t))
+ (and ef-entry (not (null (ef-resync-fun ef-entry)))))
(defun bytes-for-char-fun (ef-entry)
- (if ef-entry (symbol-function (ninth ef-entry)) (constantly 1)))
-
-;;; 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))
- (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")))
+ (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 ,size-function (byte)
- (declare (ignore byte))
- ,size)
- (defun ,out-function (stream string flush-p start end)
- (let ((start (or start 0))
- (end (or end (length string))))
- (declare (type index start end))
- (synchronize-stream-output stream)
- (unless (<= 0 start end (length string))
- (sequence-bounding-indices-bad-error string start end))
- (do ()
- ((= end start))
- (let ((obuf (fd-stream-obuf stream)))
- (setf (buffer-tail obuf)
- (string-dispatch (simple-base-string
- #!+sb-unicode
- (simple-array character (*))
- string)
- string
- (let ((sap (buffer-sap obuf))
- (len (buffer-length obuf))
- ;; FIXME: rename
- (tail (buffer-tail obuf)))
- (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 tail))
- ;; Exited via CATCH. Skip the current character
- ;; and try the inner loop again.
- (incf start))))))
- (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 (eql byte #\Newline)
- (setf (fd-stream-char-pos stream) 0)
- (incf (fd-stream-char-pos stream)))
- (let* ((obuf (fd-stream-obuf stream))
- (bits (char-code byte))
- (sap (buffer-sap obuf))
- (tail (buffer-tail obuf)))
- ,out-expr))
- (defun ,in-function (stream buffer start requested eof-error-p
- &aux (index start) (end (+ start requested)))
- (declare (type fd-stream stream)
- (type index start requested index end)
- (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* ((ibuf (fd-stream-ibuf stream))
- (head (buffer-head ibuf))
- (tail (buffer-tail ibuf))
- (sap (buffer-sap ibuf)))
- (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 (buffer-head ibuf) 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-input-buffer 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))
- (defun ,read-c-string-function (sap element-type)
- (declare (type system-area-pointer sap)
- (type (member character base-char) element-type))
- (locally
- (declare (optimize (speed 3) (safety 0)))
- (let* ((stream ,name)
- (length
- (loop for head of-type index upfrom 0 by ,size
- for count of-type index upto (1- array-dimension-limit)
- for byte = (sap-ref-8 sap head)
- for char of-type character = ,in-expr
- until (zerop (char-code char))
- finally (return count)))
- ;; Inline the common cases
- (string (make-string length :element-type element-type)))
- (declare (ignorable stream)
- (type index length)
- (type simple-string string))
- (/show0 before-copy-loop)
- (loop for head of-type index upfrom 0 by ,size
- for index of-type index below length
- for byte = (sap-ref-8 sap head)
- for char of-type character = ,in-expr
- do (setf (aref string index) char))
- string))) ;; last loop rewrite to dotimes?
- (defun ,output-c-string-function (string)
- (declare (type simple-string string))
- (locally
- (declare (optimize (speed 3) (safety 0)))
- (let* ((length (length string))
- (,n-buffer (make-array (* (1+ length) ,size)
- :element-type '(unsigned-byte 8)))
- (tail 0)
- (stream ,name))
- (declare (type index length tail))
- (with-pinned-objects (,n-buffer)
- (let ((sap (vector-sap ,n-buffer)))
- (declare (system-area-pointer sap))
- (dotimes (i length)
- (let* ((byte (aref string i))
- (bits (char-code byte)))
- (declare (ignorable byte bits))
- ,out-expr)
- (incf tail ,size))
- (let* ((bits 0)
- (byte (code-char bits)))
- (declare (ignorable bits byte))
- ,out-expr)))
- ,n-buffer)))
- (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))
- nil ; no resync-function
- ,size-function ,read-c-string-function ,output-c-string-function)
- *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)))
(declare (type index start end))
(synchronize-stream-output stream)
(unless (<= 0 start end (length string))
- (sequence-bounding-indices-bad string start end))
+ (sequence-bounding-indices-bad-error string start end))
(do ()
((= end start))
(let ((obuf (fd-stream-obuf stream)))
- (setf (buffer-tail obuf)
- (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)))
- (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 tail))
- ;; Exited via CATCH. Skip the current character
- ;; and try the inner loop again.
- (incf start))))))
+ (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
(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)))
+ (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* ((ibuf (fd-stream-ibuf stream))
((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)))
(declare (ignorable byte))
- (setq size ,in-size-expr)
+ (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)
(if eof-error-p
(error 'end-of-file :stream stream)
(return-from ,in-function total-copied)))
- (setf head (buffer-head ibuf))
- (setf tail (buffer-tail ibuf))))
+ ;; 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)
(declare (ignorable byte))
,in-expr))
(defun ,resync-function (stream)
- (let ((ibuf (fd-stream-ibuf stream)))
- (loop
- (input-at-least stream 2)
- (incf (buffer-head ibuf))
- (unless (block decode-break-reason
- (let* ((sap (buffer-sap ibuf))
- (head (buffer-head ibuf))
- (byte (sap-ref-8 sap head))
- (size ,in-size-expr))
- (declare (ignorable byte))
- (input-at-least stream size)
- (setf head (buffer-head ibuf))
- ,in-expr)
- nil)
- (return)))))
+ (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
(setf decode-break-reason
(block decode-break-reason
(setf byte (sap-ref-8 sap head)
- size ,in-size-expr
+ size ,(if (consp in-size-expr) (cadr in-size-expr) in-size-expr)
char ,in-expr)
(incf head size)
nil))
(setf decode-break-reason
(block decode-break-reason
(setf byte (sap-ref-8 sap head)
- size ,in-size-expr
+ size ,(if (consp in-size-expr) (cadr in-size-expr) in-size-expr)
char ,in-expr)
(incf head size)
nil))
,out-expr)))
,n-buffer)))
- (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
- ,size-function ,read-c-string-function ,output-c-string-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)
- (external-format-encoding-error 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)
- (external-format-encoding-error 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)
- (external-format-encoding-error 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
- (external-format-encoding-error stream byte))
- (if (= (aref latin-9-reverse-1 (logand bits 15)) bits)
- (aref latin-9-reverse-2 (logand bits 15))
- (external-format-encoding-error 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 ((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)
(when output-p
(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.
+;;; 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).
+ ;; --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 unread chatacter, and returns
-;;; the input buffer, and the amount of of flushed input in bytes.
+;;; 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 (if (fd-stream-unread stream)
- 1
- 0)))
- (setf (fd-stream-unread stream) nil)
+ (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))
(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)
- (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 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
(finish-fd-stream-output fd-stream)
- (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))))))))
- (release-fd-stream-resources fd-stream)
- ;; Mark as closed. FIXME: Maybe this should be the first thing done?
- (sb!impl::set-closed-flame 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
(fd-stream-clear-input fd-stream))
(:force-output
(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)
(let ((ibuf (fd-stream-ibuf stream)))
(when ibuf
(decf posn (- (buffer-tail ibuf) (buffer-head ibuf)))))
- (when (fd-stream-unread stream)
- (decf posn))
;; Divide bytes by element size.
(truncate posn (fd-stream-element-size stream))))))
;;; 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
:pathname pathname
:buffering buffering
:dual-channel-p dual-channel-p
- :external-format external-format
+ :bivalent-p (eq element-type :default)
+ :serve-events serve-events
:timeout
(if timeout
(coerce timeout 'single-float)
;; Calculate useful stuff.
(multiple-value-bind (input output mask)
- (case direction
+ (ecase direction
(:input (values t nil sb!unix:o_rdonly))
(:output (values nil t sb!unix:o_wronly))
(:io (values t t sb!unix:o_rdwr))
(:probe (values t nil sb!unix:o_rdonly)))
(declare (type index mask))
- (let* ((pathname (merge-pathnames filename))
- (namestring
- (cond ((unix-namestring pathname input))
- ((and input (eq if-does-not-exist :create))
- (unix-namestring pathname nil))
- ((and (eq direction :io) (not if-does-not-exist-given))
- (unix-namestring pathname nil)))))
+ (let* (;; PATHNAME is the pathname we associate with the stream.
+ (pathname (merge-pathnames filename))
+ (physical (physicalize-pathname pathname))
+ (truename (probe-file physical))
+ ;; NAMESTRING is the native namestring we open the file with.
+ (namestring (cond (truename
+ (native-namestring truename :as-file t))
+ ((or (not input)
+ (and input (eq if-does-not-exist :create))
+ (and (eq direction :io) (not if-does-not-exist-given)))
+ (native-namestring physical :as-file t)))))
;; Process if-exists argument if we are doing any output.
(cond (output
(unless if-exists-given
(when (and output (= (logand orig-mode #o170000)
#o40000))
(error 'simple-file-error
- :pathname namestring
+ :pathname pathname
:format-control
"can't open ~S for output: is a directory"
:format-arguments (list namestring)))
:delete-original delete-original
:pathname pathname
:dual-channel-p nil
+ :serve-events nil
:input-buffer-p t
:auto-close t))
(:probe
(without-package-locks
(makunbound '*available-buffers*))))
+(defun stdstream-external-format (outputp)
+ (declare (ignorable outputp))
+ (let* ((keyword #!+win32 (if outputp (sb!win32::console-output-codepage) (sb!win32::console-input-codepage))
+ #!-win32 (default-external-format))
+ (ef (get-external-format keyword))
+ (replacement (ef-default-replacement-character ef)))
+ `(,keyword :replacement ,replacement)))
+
;;; This is called whenever a saved core is restarted.
(defun stream-reinit (&optional init-buffers-p)
(when init-buffers-p
(with-output-to-string (*error-output*)
(setf *stdin*
(make-fd-stream 0 :name "standard input" :input t :buffering :line
- #!+win32 :external-format #!+win32 (sb!win32::console-input-codepage)))
+ :element-type :default
+ :serve-events t
+ :external-format (stdstream-external-format nil)))
(setf *stdout*
(make-fd-stream 1 :name "standard output" :output t :buffering :line
- #!+win32 :external-format #!+win32 (sb!win32::console-output-codepage)))
+ :element-type :default
+ :external-format (stdstream-external-format t)))
(setf *stderr*
(make-fd-stream 2 :name "standard error" :output t :buffering :line
- #!+win32 :external-format #!+win32 (sb!win32::console-output-codepage)))
+ :element-type :default
+ :external-format (stdstream-external-format t)))
(let* ((ttyname #.(coerce "/dev/tty" 'simple-base-string))
(tty (sb!unix:unix-open ttyname sb!unix:o_rdwr #o666)))
(if tty
(setf *tty*
- (make-fd-stream tty
- :name "the terminal"
- :input t
- :output t
- :buffering :line
+ (make-fd-stream tty :name "the terminal"
+ :input t :output t :buffering :line
+ :external-format (stdstream-external-format t)
+ :serve-events t
:auto-close t))
(setf *tty* (make-two-way-stream *stdin* *stdout*))))
(princ (get-output-stream-string *error-output*) *stderr*))
(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)))))