(element-type 'base-char)
;; the Unix file descriptor
(fd -1 :type fixnum)
+ ;; 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
(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
(instead (make-array 0 :element-type 'character :adjustable t :fill-pointer t) :type (array character (*)))
(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)
+ ;; 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)
(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
(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))
(:constructor %make-external-format)
(:conc-name ef-)
(:predicate external-format-p)
- (:copier nil))
+ (: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)
- (read-n-chars-fun (missing-arg) :type function :read-only t)
- (read-char-fun (missing-arg) :type function :read-only t)
- (write-n-bytes-fun (missing-arg) :type function :read-only t)
- (write-char-none-buffered-fun (missing-arg) :type function :read-only t)
- (write-char-line-buffered-fun (missing-arg) :type function :read-only t)
- (write-char-full-buffered-fun (missing-arg) :type function :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) :read-only t)
- (bytes-for-char-fun (missing-arg) :type function :read-only t)
- (read-c-string-fun (missing-arg) :type function :read-only t)
- (write-c-string-fun (missing-arg) :type function :read-only t)
- ;; We make these symbols 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
- ;; are functions because a developer working with those slots would be
+ (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-sym (missing-arg) :type symbol :read-only t)
- (string-to-octets-sym (missing-arg) :type symbol :read-only t))
+ (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
external-format names to EXTERNAL-FORMAT structures.")
(defun get-external-format (external-format)
- (gethash external-format *external-formats*))
+ (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 ~A" 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 (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)
- (first (ef-names 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))
;; 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)))))
+ (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
(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 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
: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
;; resulting thunk is stack-allocatable.
((lambda (return-reason)
(ecase return-reason
- ((nil)) ; fast path normal cases
+ ((nil)) ; fast path normal cases
((:wait-for-input) (go :wait-for-input))
((:closed-flame) (go :closed-flame))
((:read-error) (go :read-error))))
(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))))
+ (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))
- (setq size ,bytes)
- (input-at-least ,stream-var size)
+ ,@(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))
;;; bytes per element (and for character types string input routine).
(defun pick-input-routine (type &optional external-format)
(when (subtypep type 'character)
- (let ((entry (get-external-format external-format)))
- (when entry
- (return-from pick-input-routine
- (values (ef-read-char-fun entry)
- 'character
- 1
- (ef-read-n-chars-fun entry)
- (first (ef-names 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))
(defun bytes-for-char-fun (ef-entry)
(if ef-entry (ef-bytes-for-char-fun ef-entry) (constantly 1)))
-(defmacro define-external-format (external-format size output-restart
- out-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))
- (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")))
+(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)))
- (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)))
- (,@(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)
- (setf (buffer-tail obuf) tail)
- (incf start)))
- ;; Exited from the loop normally
- (go flush))
- ;; Exited via CATCH. Skip the current character.
- (incf start))))
- flush
- (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))
- (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 index) (vector-pop instead))
- (incf index)
- (when (= index end)
- (return-from ,in-function (- index start))))
- (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)))
- (let ((entry (%make-external-format
- :names ',external-format
- :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 nil
- :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-sym ',octets-to-string-sym
- :string-to-octets-sym ',string-to-octets-sym)))
- (dolist (ef ',external-format)
- (setf (gethash ef *external-formats*) entry))))))
+ (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))
(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)
((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)
(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)))
+ (let ((ibuf (fd-stream-ibuf stream))
+ size)
(catch 'eof-input-catcher
(loop
(incf (buffer-head ibuf))
- (input-at-least stream 1)
+ (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))
- (size ,in-size-expr))
+ (byte (sap-ref-8 sap head)))
(declare (ignorable byte))
- (input-at-least stream size)
+ ,@(when (consp in-size-expr)
+ `((setq size ,(cadr in-size-expr))
+ (input-at-least stream size)))
(setf head (buffer-head ibuf))
,in-expr)
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))
(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))
(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
: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-sym ',octets-to-string-sym
- :string-to-octets-sym ',string-to-octets-sym)))
+ :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
(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
(do-listen)))
(:unread
(decf (buffer-head (fd-stream-ibuf fd-stream))
- (fd-stream-character-size fd-stream arg1))
- (setf (fd-stream-listen fd-stream) t))
+ (fd-stream-character-size fd-stream arg1)))
(:close
;; Drop input buffers
(setf (ansi-stream-in-index fd-stream) +ansi-stream-in-buffer-length+
(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)
;;; 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
((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
:bivalent-p (eq element-type :default)
- :char-size (external-format-char-size external-format)
+ :serve-events serve-events
:timeout
(if timeout
(coerce timeout 'single-float)
: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*))