#!+sb-doc
"List of available buffers.")
-(defvar *available-buffers-spinlock* (sb!thread::make-spinlock
- :name "lock for *AVAILABLE-BUFFERS*")
+(defvar *available-buffers-lock* (sb!thread:make-mutex
+ :name "lock for *AVAILABLE-BUFFERS*")
#!+sb-doc
"Mutex for access to *AVAILABLE-BUFFERS*.")
(defmacro with-available-buffers-lock ((&optional) &body body)
- ;; CALL-WITH-SYSTEM-SPINLOCK because
- ;;
- ;; 1. streams are low-level enough to be async signal safe, and in
- ;; particular a C-c that brings up the debugger while holding the
- ;; mutex would lose badly
- ;;
- ;; 2. this can potentially be a fairly busy (but also probably
- ;; uncontended) lock, so we don't want to pay the syscall per
- ;; release -- hence a spinlock.
- ;;
- ;; ...again, once we have smarted locks the spinlock here can become
- ;; a mutex.
- `(sb!thread::with-system-spinlock (*available-buffers-spinlock*)
+ ;; CALL-WITH-SYSTEM-MUTEX because streams are low-level enough to be
+ ;; async signal safe, and in particular a C-c that brings up the
+ ;; debugger while holding the mutex would lose badly.
+ `(sb!thread::with-system-mutex (*available-buffers-lock*)
,@body))
(defconstant +bytes-per-buffer+ (* 4 1024)
;; the type of element being transfered
(element-type 'base-char)
;; the Unix file descriptor
- (fd -1 :type fixnum)
+ (fd -1 :type #!-win32 fixnum #!+win32 sb!vm:signed-word)
+ ;; What do we know about the FD?
+ (fd-type :unknown :type keyword)
;; controls when the output buffer is flushed
(buffering :full :type (member :full :line :none))
;; controls whether the input buffer must be cleared before output
(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)
+ ;; 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))
+ (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.
+ (incf head count)
+ (setf (buffer-head obuf) head)
+ (queue-or-wait))
+ #!-win32
+ ((eql errno sb!unix:ewouldblock)
+ ;; Blocking, queue or wair.
+ (queue-or-wait))
+ ;; if interrupted on win32, just try again
+ #!+win32 ((eql errno sb!unix:eintr))
+ (t
+ (simple-stream-perror "Couldn't write to ~s"
+ stream errno)))))))))))))
;;; Helper for FLUSH-OUTPUT-BUFFER -- returns the new buffer.
(defun %queue-and-replace-output-buffer (stream)
+ (aver (fd-stream-serve-events stream))
(let ((queue (fd-stream-output-queue stream))
(later (list (or (fd-stream-obuf stream) (bug "Missing obuf."))))
(new (get-buffer)))
;;; 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
:format-arguments
(list note-format (list pathname) (strerror errno))))
-(defun stream-decoding-error (stream octets)
- (error 'stream-decoding-error
- :external-format (stream-external-format stream)
- :stream stream
- ;; FIXME: dunno how to get at OCTETS currently, or even if
- ;; that's the right thing to report.
- :octets octets))
-(defun stream-encoding-error (stream code)
- (error 'stream-encoding-error
- :external-format (stream-external-format stream)
- :stream stream
- :code code))
-
(defun c-string-encoding-error (external-format code)
(error 'c-string-encoding-error
:external-format external-format
:code code))
-
-(defun c-string-decoding-error (external-format octets)
+(defun c-string-decoding-error (external-format sap offset count)
(error 'c-string-decoding-error
:external-format external-format
- :octets octets))
+ :octets (sap-ref-octets sap offset count)))
;;; Returning true goes into end of file handling, false will enter another
;;; round of input buffer filling followed by re-entering character decode.
(defun stream-decoding-error-and-handle (stream octet-count)
(restart-case
- (stream-decoding-error stream
- (let* ((buffer (fd-stream-ibuf stream))
- (sap (buffer-sap buffer))
- (head (buffer-head buffer)))
- (loop for i from 0 below octet-count
- collect (sap-ref-8 sap (+ head i)))))
+ (error 'stream-decoding-error
+ :external-format (stream-external-format stream)
+ :stream stream
+ :octets (let ((buffer (fd-stream-ibuf stream)))
+ (sap-ref-octets (buffer-sap buffer)
+ (buffer-head buffer)
+ octet-count)))
(attempt-resync ()
:report (lambda (stream)
(format stream
(force-end-of-file ()
:report (lambda (stream)
(format stream "~@<Force an end of file.~@:>"))
- t)))
+ (setf (fd-stream-eof-forced-p stream) t))
+ (input-replacement (string)
+ :report (lambda (stream)
+ (format stream "~@<Use string as replacement input, ~
+ attempt to resync at a character ~
+ boundary and continue.~@:>"))
+ :interactive (lambda ()
+ (format *query-io* "~@<Enter a string: ~@:>")
+ (finish-output *query-io*)
+ (list (read *query-io*)))
+ (let ((string (reverse (string string)))
+ (instead (fd-stream-instead stream)))
+ (dotimes (i (length string))
+ (vector-push-extend (char string i) instead))
+ (fd-stream-resync stream)
+ (when (> (length string) 0)
+ (setf (fd-stream-listen stream) t)))
+ nil)))
(defun stream-encoding-error-and-handle (stream code)
(restart-case
- (stream-encoding-error stream code)
+ (error 'stream-encoding-error
+ :external-format (stream-external-format stream)
+ :stream stream
+ :code code)
(output-nothing ()
:report (lambda (stream)
(format stream "~@<Skip output of this character.~@:>"))
+ (throw 'output-nothing nil))
+ (output-replacement (string)
+ :report (lambda (stream)
+ (format stream "~@<Output replacement string.~@:>"))
+ :interactive (lambda ()
+ (format *query-io* "~@<Enter a string: ~@:>")
+ (finish-output *query-io*)
+ (list (read *query-io*)))
+ (let ((string (string string)))
+ (fd-sout stream (string string) 0 (length string)))
(throw 'output-nothing nil))))
(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.
(tail (buffer-tail obuf))
(size ,size))
,(unless (eq (car buffering) :none)
- `(when (<= (buffer-length obuf) (+ tail size))
+ `(when (< (buffer-length obuf) (+ tail size))
(setf obuf (flush-output-buffer ,stream-var)
tail (buffer-tail obuf))))
,(unless (eq (car buffering) :none)
`(let* ((,stream-var ,stream)
(obuf (fd-stream-obuf ,stream-var))
(tail (buffer-tail obuf)))
- ,(unless (eq (car buffering) :none)
- `(when (<= (buffer-length obuf) (+ tail ,size))
- (setf obuf (flush-output-buffer ,stream-var)
- tail (buffer-tail obuf))))
- ;; FIXME: Why this here? Doesn't seem necessary.
- ,(unless (eq (car buffering) :none)
- `(synchronize-stream-output ,stream-var))
- ,(if restart
- `(catch 'output-nothing
- ,@body
- (setf (buffer-tail obuf) (+ tail ,size)))
- `(progn
- ,@body
- (setf (buffer-tail obuf) (+ tail ,size))))
- ,(ecase (car buffering)
- (:none
- `(flush-output-buffer ,stream-var))
- (:line
- `(when (eql byte #\Newline)
- (flush-output-buffer ,stream-var)))
- (:full))
- (values))))
+ ,(unless (eq (car buffering) :none)
+ `(when (< (buffer-length obuf) (+ tail ,size))
+ (setf obuf (flush-output-buffer ,stream-var)
+ tail (buffer-tail obuf))))
+ ;; FIXME: Why this here? Doesn't seem necessary.
+ ,(unless (eq (car buffering) :none)
+ `(synchronize-stream-output ,stream-var))
+ ,(if restart
+ `(catch 'output-nothing
+ ,@body
+ (setf (buffer-tail obuf) (+ tail ,size)))
+ `(progn
+ ,@body
+ (setf (buffer-tail obuf) (+ tail ,size))))
+ ,(ecase (car buffering)
+ (:none
+ `(flush-output-buffer ,stream-var))
+ (:line
+ `(when (eql byte #\Newline)
+ (flush-output-buffer ,stream-var)))
+ (:full))
+ (values))))
(defmacro def-output-routines/variable-width
((name-fmt size restart external-format &rest bufferings)
(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))
;; 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)
+ #!+win32
+ (go :main)
+
+ ;; Check for blocking input before touching the stream if we are to
+ ;; serve events: if the FD is blocking, we don't want to try an uninterruptible
+ ;; read(). Regular files should never block, so we can elide the check.
+ (if (and (neq :regular (fd-stream-fd-type stream))
+ (sysread-may-block-p stream))
(go :wait-for-input)
(go :main))
;; These (:CLOSED-FLAME and :READ-ERROR) tags are here so what
: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
- ((:wait-for-input) (go :wait-for-input))
+ ((nil)) ; fast path normal cases
+ ((:wait-for-input) (go #!-win32 :wait-for-input #!+win32 :main))
((:closed-flame) (go :closed-flame))
((:read-error) (go :read-error))))
(without-interrupts
(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)
+ (if (eql errno
+ #!+win32 sb!unix:eintr
+ #!-win32 sb!unix:ewouldblock)
(return :wait-for-input)
(return :read-error)))
((zerop count)
`(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))
(when decode-break-reason
- (c-string-decoding-error ,name decode-break-reason))
+ (c-string-decoding-error
+ ,name sap head decode-break-reason))
(when (zerop (char-code char))
(return count))))
(string (make-string length :element-type element-type)))
(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))
(when decode-break-reason
- (c-string-decoding-error ,name decode-break-reason))
+ (c-string-decoding-error
+ ,name sap head decode-break-reason))
(setf (aref string index) char)))))
(defun ,output-c-string-function (string)
,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
;; 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
;; Drop input buffers
(setf (ansi-stream-in-index fd-stream) +ansi-stream-in-buffer-length+
(:external-format
(fd-stream-external-format fd-stream))
(:interactive-p
- (= 1 (the (member 0 1)
- (sb!unix:unix-isatty (fd-stream-fd fd-stream)))))
+ (plusp (the (integer 0)
+ (sb!unix:unix-isatty (fd-stream-fd fd-stream)))))
(:line-length
80)
(:charpos
:expected-type 'fd-stream
:format-control "~S is not a stream associated with a file."
:format-arguments (list fd-stream)))
+ #!-win32
(multiple-value-bind (okay dev ino mode nlink uid gid rdev size
atime mtime ctime blksize blocks)
(sb!unix:unix-fstat (fd-stream-fd fd-stream))
(simple-stream-perror "failed Unix fstat(2) on ~S" fd-stream dev))
(if (zerop mode)
nil
- (truncate size (fd-stream-element-size fd-stream)))))
+ (truncate size (fd-stream-element-size fd-stream))))
+ #!+win32
+ (let* ((handle (fd-stream-fd fd-stream))
+ (element-size (fd-stream-element-size fd-stream)))
+ (multiple-value-bind (got native-size)
+ (sb!win32:get-file-size-ex handle 0)
+ (if (zerop got)
+ ;; Might be a block device, in which case we fall back to
+ ;; a non-atomic workaround:
+ (let* ((here (sb!unix:unix-lseek handle 0 sb!unix:l_incr))
+ (there (sb!unix:unix-lseek handle 0 sb!unix:l_xtnd)))
+ (when (and here there)
+ (sb!unix:unix-lseek handle here sb!unix:l_set)
+ (truncate there element-size)))
+ (truncate native-size element-size)))))
(:file-string-length
(etypecase arg1
(character (fd-stream-character-size fd-stream arg1))
(flush-output-buffer stream)
(do ()
((null (fd-stream-output-queue stream)))
+ (aver (fd-stream-serve-events stream))
(serve-all-events)))
(defun fd-stream-get-file-position (stream)
(declare (fd-stream stream))
(without-interrupts
(let ((posn (sb!unix:unix-lseek (fd-stream-fd stream) 0 sb!unix:l_incr)))
- (declare (type (or (alien sb!unix:off-t) null) posn))
+ (declare (type (or (alien sb!unix:unix-offset) null) posn))
;; We used to return NIL for errno==ESPIPE, and signal an error
;; in other failure cases. However, CLHS says to return NIL if
;; the position cannot be determined -- so that's what we do.
(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))))))
(defun fd-stream-set-file-position (stream position-spec)
(declare (fd-stream stream))
(check-type position-spec
- (or (alien sb!unix:off-t) (member nil :start :end))
+ (or (alien sb!unix:unix-offset) (member nil :start :end))
"valid file position designator")
(tagbody
:again
(t
(values (* position-spec (fd-stream-element-size stream))
sb!unix:l_set)))
- (declare (type (alien sb!unix:off-t) offset))
+ (declare (type (alien sb!unix:unix-offset) offset))
(let ((posn (sb!unix:unix-lseek (fd-stream-fd stream)
offset origin)))
;; CLHS says to return true if the file-position was set
;; FIXME: We are still liable to signal an error if flushing
;; output fails.
(return-from fd-stream-set-file-position
- (typep posn '(alien sb!unix:off-t))))))))
+ (typep posn '(alien sb!unix:unix-offset))))))))
\f
;;;; creation routines (MAKE-FD-STREAM and OPEN)
;;; FILE is the name of the file (will be returned by PATHNAME).
;;;
;;; NAME is used to identify the stream when printed.
+;;;
+;;; If SERVE-EVENTS is true, SERVE-EVENT machinery is used to
+;;; handle blocking IO on the stream.
(defun make-fd-stream (fd
&key
(input nil input-p)
(element-type 'base-char)
(buffering :full)
(external-format :default)
+ serve-events
timeout
file
original
((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
- :char-size (external-format-char-size external-format)
+ :bivalent-p (eq element-type :default)
+ :serve-events serve-events
:timeout
(if timeout
(coerce timeout 'single-float)
(defun open (filename
&key
- (direction :input)
- (element-type 'base-char)
- (if-exists nil if-exists-given)
- (if-does-not-exist nil if-does-not-exist-given)
- (external-format :default)
- &aux ; Squelch assignment warning.
+ (direction :input)
+ (element-type 'base-char)
+ (if-exists nil if-exists-given)
+ (if-does-not-exist nil if-does-not-exist-given)
+ (external-format :default)
+ &aux ; Squelch assignment warning.
(direction direction)
(if-does-not-exist if-does-not-exist)
(if-exists if-exists))
(:io (values t t sb!unix:o_rdwr))
(:probe (values t nil sb!unix:o_rdonly)))
(declare (type index mask))
- (let* ((pathname (merge-pathnames filename))
- (namestring
- (cond ((unix-namestring pathname input))
- ((and input (eq if-does-not-exist :create))
- (unix-namestring pathname nil))
- ((and (eq direction :io) (not if-does-not-exist-given))
- (unix-namestring pathname nil)))))
- ;; Process if-exists argument if we are doing any output.
- (cond (output
- (unless if-exists-given
- (setf if-exists
- (if (eq (pathname-version pathname) :newest)
- :new-version
- :error)))
- (ensure-one-of if-exists
- '(:error :new-version :rename
- :rename-and-delete :overwrite
- :append :supersede nil)
- :if-exists)
- (case if-exists
- ((:new-version :error nil)
- (setf mask (logior mask sb!unix:o_excl)))
- ((:rename :rename-and-delete)
- (setf mask (logior mask sb!unix:o_creat)))
- ((:supersede)
- (setf mask (logior mask sb!unix:o_trunc)))
- (:append
- (setf mask (logior mask sb!unix:o_append)))))
- (t
- (setf if-exists :ignore-this-arg)))
-
- (unless if-does-not-exist-given
- (setf if-does-not-exist
- (cond ((eq direction :input) :error)
- ((and output
- (member if-exists '(:overwrite :append)))
- :error)
- ((eq direction :probe)
+ (let* ( ;; PATHNAME is the pathname we associate with the stream.
+ (pathname (merge-pathnames filename))
+ (physical (physicalize-pathname pathname))
+ (truename (probe-file physical))
+ ;; NAMESTRING is the native namestring we open the file with.
+ (namestring (cond (truename
+ (native-namestring truename :as-file t))
+ ((or (not input)
+ (and input (eq if-does-not-exist :create))
+ (and (eq direction :io)
+ (not if-does-not-exist-given)))
+ (native-namestring physical :as-file t)))))
+ (flet ((open-error (format-control &rest format-arguments)
+ (error 'simple-file-error
+ :pathname pathname
+ :format-control format-control
+ :format-arguments format-arguments)))
+ ;; Process if-exists argument if we are doing any output.
+ (cond (output
+ (unless if-exists-given
+ (setf if-exists
+ (if (eq (pathname-version pathname) :newest)
+ :new-version
+ :error)))
+ (ensure-one-of if-exists
+ '(:error :new-version :rename
+ :rename-and-delete :overwrite
+ :append :supersede nil)
+ :if-exists)
+ (case if-exists
+ ((:new-version :error nil)
+ (setf mask (logior mask sb!unix:o_excl)))
+ ((:rename :rename-and-delete)
+ (setf mask (logior mask sb!unix:o_creat)))
+ ((:supersede)
+ (setf mask (logior mask sb!unix:o_trunc)))
+ (:append
+ (setf mask (logior mask sb!unix:o_append)))))
+ (t
+ (setf if-exists :ignore-this-arg)))
+
+ (unless if-does-not-exist-given
+ (setf if-does-not-exist
+ (cond ((eq direction :input) :error)
+ ((and output
+ (member if-exists '(:overwrite :append)))
+ :error)
+ ((eq direction :probe)
+ nil)
+ (t
+ :create))))
+ (ensure-one-of if-does-not-exist
+ '(:error :create nil)
+ :if-does-not-exist)
+ (cond ((and if-exists-given
+ truename
+ (eq if-exists :new-version))
+ (open-error "OPEN :IF-EXISTS :NEW-VERSION is not supported ~
+ when a new version must be created."))
+ ((eq if-does-not-exist :create)
+ (setf mask (logior mask sb!unix:o_creat)))
+ ((not (member if-exists '(:error nil))))
+ ;; Both if-does-not-exist and if-exists now imply
+ ;; that there will be no opening of files, and either
+ ;; an error would be signalled, or NIL returned
+ ((and (not if-exists) (not if-does-not-exist))
+ (return-from open))
+ ((and if-exists if-does-not-exist)
+ (open-error "OPEN :IF-DOES-NOT-EXIST ~s ~
+ :IF-EXISTS ~s will always signal an error."
+ if-does-not-exist if-exists))
+ (truename
+ (if if-exists
+ (open-error "File exists ~s." pathname)
+ (return-from open)))
+ (if-does-not-exist
+ (open-error "File does not exist ~s." pathname))
+ (t
+ (return-from open)))
+ (let ((original (case if-exists
+ ((:rename :rename-and-delete)
+ (pick-backup-name namestring))
+ ((:append :overwrite)
+ ;; KLUDGE: Prevent CLOSE from deleting
+ ;; appending streams when called with :ABORT T
+ namestring)))
+ (delete-original (eq if-exists :rename-and-delete))
+ (mode #o666))
+ (when (and original (not (eq original namestring)))
+ ;; We are doing a :RENAME or :RENAME-AND-DELETE. Determine
+ ;; whether the file already exists, make sure the original
+ ;; file is not a directory, and keep the mode.
+ (let ((exists
+ (and namestring
+ (multiple-value-bind (okay err/dev inode orig-mode)
+ (sb!unix:unix-stat namestring)
+ (declare (ignore inode)
+ (type (or index null) orig-mode))
+ (cond
+ (okay
+ (when (and output (= (logand orig-mode #o170000)
+ #o40000))
+ (error 'simple-file-error
+ :pathname pathname
+ :format-control
+ "can't open ~S for output: is a directory"
+ :format-arguments (list namestring)))
+ (setf mode (logand orig-mode #o777))
+ t)
+ ((eql err/dev sb!unix:enoent)
+ nil)
+ (t
+ (simple-file-perror "can't find ~S"
+ namestring
+ err/dev)))))))
+ (unless (and exists
+ (rename-the-old-one namestring original))
+ (setf original nil)
+ (setf delete-original nil)
+ ;; In order to use :SUPERSEDE instead, we have to make
+ ;; sure SB!UNIX:O_CREAT corresponds to
+ ;; IF-DOES-NOT-EXIST. SB!UNIX:O_CREAT was set before
+ ;; because of IF-EXISTS being :RENAME.
+ (unless (eq if-does-not-exist :create)
+ (setf mask
+ (logior (logandc2 mask sb!unix:o_creat)
+ sb!unix:o_trunc)))
+ (setf if-exists :supersede))))
+
+ ;; Now we can try the actual Unix open(2).
+ (multiple-value-bind (fd errno)
+ (if namestring
+ (sb!unix:unix-open namestring mask mode)
+ (values nil sb!unix:enoent))
+ (flet ((vanilla-open-error ()
+ (simple-file-perror "error opening ~S" pathname errno)))
+ (cond ((numberp fd)
+ (case direction
+ ((:input :output :io)
+ ;; For O_APPEND opened files, lseek returns 0 until first write.
+ ;; So we jump ahead here.
+ (when (eq if-exists :append)
+ (sb!unix:unix-lseek fd 0 sb!unix:l_xtnd))
+ (make-fd-stream fd
+ :input input
+ :output output
+ :element-type element-type
+ :external-format external-format
+ :file namestring
+ :original original
+ :delete-original delete-original
+ :pathname pathname
+ :dual-channel-p nil
+ :serve-events nil
+ :input-buffer-p t
+ :auto-close t))
+ (:probe
+ (let ((stream
+ (%make-fd-stream :name namestring
+ :fd fd
+ :pathname pathname
+ :element-type element-type)))
+ (close stream)
+ stream))))
+ ((eql errno sb!unix:enoent)
+ (case if-does-not-exist
+ (:error (vanilla-open-error))
+ (:create
+ (open-error "~@<The path ~2I~_~S ~I~_does not exist.~:>"
+ pathname))
+ (t nil)))
+ ((and (eql errno sb!unix:eexist) (null if-exists))
nil)
(t
- :create))))
- (ensure-one-of if-does-not-exist
- '(:error :create nil)
- :if-does-not-exist)
- (if (eq if-does-not-exist :create)
- (setf mask (logior mask sb!unix:o_creat)))
-
- (let ((original (case if-exists
- ((:rename :rename-and-delete)
- (pick-backup-name namestring))
- ((:append :overwrite)
- ;; KLUDGE: Provent CLOSE from deleting
- ;; appending streams when called with :ABORT T
- namestring)))
- (delete-original (eq if-exists :rename-and-delete))
- (mode #o666))
- (when (and original (not (eq original namestring)))
- ;; We are doing a :RENAME or :RENAME-AND-DELETE. Determine
- ;; whether the file already exists, make sure the original
- ;; file is not a directory, and keep the mode.
- (let ((exists
- (and namestring
- (multiple-value-bind (okay err/dev inode orig-mode)
- (sb!unix:unix-stat namestring)
- (declare (ignore inode)
- (type (or index null) orig-mode))
- (cond
- (okay
- (when (and output (= (logand orig-mode #o170000)
- #o40000))
- (error 'simple-file-error
- :pathname namestring
- :format-control
- "can't open ~S for output: is a directory"
- :format-arguments (list namestring)))
- (setf mode (logand orig-mode #o777))
- t)
- ((eql err/dev sb!unix:enoent)
- nil)
- (t
- (simple-file-perror "can't find ~S"
- namestring
- err/dev)))))))
- (unless (and exists
- (rename-the-old-one namestring original))
- (setf original nil)
- (setf delete-original nil)
- ;; In order to use :SUPERSEDE instead, we have to make
- ;; sure SB!UNIX:O_CREAT corresponds to
- ;; IF-DOES-NOT-EXIST. SB!UNIX:O_CREAT was set before
- ;; because of IF-EXISTS being :RENAME.
- (unless (eq if-does-not-exist :create)
- (setf mask
- (logior (logandc2 mask sb!unix:o_creat)
- sb!unix:o_trunc)))
- (setf if-exists :supersede))))
-
- ;; Now we can try the actual Unix open(2).
- (multiple-value-bind (fd errno)
- (if namestring
- (sb!unix:unix-open namestring mask mode)
- (values nil sb!unix:enoent))
- (labels ((open-error (format-control &rest format-arguments)
- (error 'simple-file-error
- :pathname pathname
- :format-control format-control
- :format-arguments format-arguments))
- (vanilla-open-error ()
- (simple-file-perror "error opening ~S" pathname errno)))
- (cond ((numberp fd)
- (case direction
- ((:input :output :io)
- (make-fd-stream fd
- :input input
- :output output
- :element-type element-type
- :external-format external-format
- :file namestring
- :original original
- :delete-original delete-original
- :pathname pathname
- :dual-channel-p nil
- :input-buffer-p t
- :auto-close t))
- (:probe
- (let ((stream
- (%make-fd-stream :name namestring
- :fd fd
- :pathname pathname
- :element-type element-type)))
- (close stream)
- stream))))
- ((eql errno sb!unix:enoent)
- (case if-does-not-exist
- (:error (vanilla-open-error))
- (:create
- (open-error "~@<The path ~2I~_~S ~I~_does not exist.~:>"
- pathname))
- (t nil)))
- ((and (eql errno sb!unix:eexist) (null if-exists))
- nil)
- (t
- (vanilla-open-error)))))))))
+ (vanilla-open-error))))))))))
\f
;;;; initialization
(without-package-locks
(makunbound '*available-buffers*))))
+(defun stdstream-external-format (fd outputp)
+ #!-win32 (declare (ignore fd outputp))
+ (let* ((keyword #!+win32 (if (and (/= fd -1)
+ (logbitp 0 fd)
+ (logbitp 1 fd))
+ :ucs-2
+ (if outputp
+ (sb!win32::console-output-codepage)
+ (sb!win32::console-input-codepage)))
+ #!-win32 (default-external-format))
+ (ef (get-external-format keyword))
+ (replacement (ef-default-replacement-character ef)))
+ `(,keyword :replacement ,replacement)))
+
;;; This is called whenever a saved core is restarted.
(defun stream-reinit (&optional init-buffers-p)
(when init-buffers-p
(aver (not (boundp '*available-buffers*)))
(setf *available-buffers* nil)))
(with-output-to-string (*error-output*)
- (setf *stdin*
- (make-fd-stream 0 :name "standard input" :input t :buffering :line
- #!+win32 :external-format #!+win32 (sb!win32::console-input-codepage)))
- (setf *stdout*
- (make-fd-stream 1 :name "standard output" :output t :buffering :line
- #!+win32 :external-format #!+win32 (sb!win32::console-output-codepage)))
- (setf *stderr*
- (make-fd-stream 2 :name "standard error" :output t :buffering :line
- #!+win32 :external-format #!+win32 (sb!win32::console-output-codepage)))
+ (multiple-value-bind (in out err)
+ #!-win32 (values 0 1 2)
+ #!+win32 (sb!win32::get-std-handles)
+ (flet ((stdio-stream (handle name inputp outputp)
+ (make-fd-stream
+ handle
+ :name name
+ :input inputp
+ :output outputp
+ :buffering :line
+ :element-type :default
+ :serve-events inputp
+ :external-format (stdstream-external-format handle outputp))))
+ (setf *stdin* (stdio-stream in "standard input" t nil))
+ (setf *stdout* (stdio-stream out "standard output" nil t))
+ (setf *stderr* (stdio-stream err "standard error" nil t))))
+ #!+win32
+ (setf *tty* (make-two-way-stream *stdin* *stdout*))
+ #!-win32
(let* ((ttyname #.(coerce "/dev/tty" 'simple-base-string))
(tty (sb!unix:unix-open ttyname sb!unix:o_rdwr #o666)))
(if tty
(setf *tty*
- (make-fd-stream tty
- :name "the terminal"
- :input t
- :output t
- :buffering :line
+ (make-fd-stream tty :name "the terminal"
+ :input t :output t :buffering :line
+ :external-format (stdstream-external-format
+ tty t)
+ :serve-events (or #!-win32 t)
:auto-close t))
(setf *tty* (make-two-way-stream *stdin* *stdout*))))
(princ (get-output-stream-string *error-output*) *stderr*))
(cond (new-name
(setf (fd-stream-pathname stream) new-name)
(setf (fd-stream-file stream)
- (unix-namestring new-name nil))
+ (native-namestring (physicalize-pathname new-name)
+ :as-file t))
t)
(t
(fd-stream-pathname stream)))))
projects / sbcl.git / blobdiff