X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ffd-stream.lisp;h=acf84b05985324ed695127a97d6818c1daebff8b;hb=b14a61c6af3e3005c94e633e727177346240066e;hp=5daab69d3e2b5c6354d1a7e51c6fe8106745d594;hpb=75476d1d19ac3d7239c8963a498c447a8368433d;p=sbcl.git diff --git a/src/code/fd-stream.lisp b/src/code/fd-stream.lisp index 5daab69..acf84b0 100644 --- a/src/code/fd-stream.lisp +++ b/src/code/fd-stream.lisp @@ -52,25 +52,16 @@ #!+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) @@ -156,7 +147,9 @@ ;; 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 @@ -169,6 +162,8 @@ (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 (*))) @@ -185,7 +180,8 @@ (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) @@ -262,32 +258,47 @@ (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))) @@ -312,6 +323,7 @@ ;;; 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 @@ -390,14 +402,10 @@ ;;; 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)))))) ;;;; output routines and related noise @@ -420,39 +428,26 @@ :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 @@ -484,7 +479,10 @@ (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 "~@")) @@ -505,11 +503,6 @@ (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. @@ -532,7 +525,7 @@ (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) @@ -559,28 +552,28 @@ `(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) @@ -730,7 +723,7 @@ (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)) @@ -755,28 +748,53 @@ (: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 @@ -784,28 +802,73 @@ 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)) @@ -881,20 +944,7 @@ ;; 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 @@ -904,10 +954,14 @@ (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 @@ -919,8 +973,11 @@ :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 @@ -931,8 +988,8 @@ ;; 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 @@ -968,10 +1025,9 @@ (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) @@ -1027,12 +1083,17 @@ (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)) @@ -1149,14 +1210,14 @@ ;;; 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)) @@ -1272,198 +1333,73 @@ (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)) @@ -1550,6 +1486,8 @@ (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) @@ -1564,9 +1502,12 @@ ((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) @@ -1594,8 +1535,8 @@ (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) @@ -1615,18 +1556,20 @@ (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) @@ -1642,12 +1585,15 @@ (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))) @@ -1661,12 +1607,15 @@ (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) @@ -1712,6 +1661,7 @@ (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 @@ -1723,8 +1673,12 @@ :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)))))) @@ -1743,6 +1697,7 @@ (character-stream-p (subtypep target-type 'character)) (bivalent-stream-p (eq element-type :default)) normalized-external-format + char-size (bin-routine #'ill-bin) (bin-type nil) (bin-size nil) @@ -1786,24 +1741,23 @@ (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 @@ -1812,8 +1766,8 @@ (setf input-size (or cin-size bin-size)) (setf input-type (or cin-type bin-type)) (when normalized-external-format - (setf (fd-stream-external-format fd-stream) - normalized-external-format)) + (setf (fd-stream-external-format fd-stream) normalized-external-format + (fd-stream-char-size fd-stream) char-size)) (when (= (or cin-size 1) (or bin-size 1) 1) (setf (fd-stream-n-bin fd-stream) ;XXX (if (and character-stream-p (not bivalent-stream-p)) @@ -1840,30 +1794,33 @@ (when output-p (when (or (not character-stream-p) bivalent-stream-p) - (multiple-value-setq (bout-routine bout-type bout-size output-bytes - normalized-external-format) - (pick-output-routine (if bivalent-stream-p - '(unsigned-byte 8) - target-type) - (fd-stream-buffering fd-stream) - external-format)) + (setf (values bout-routine bout-type bout-size output-bytes + char-size normalized-external-format) + (let ((buffering (fd-stream-buffering fd-stream))) + (if bivalent-stream-p + (pick-output-routine '(unsigned-byte 8) + (if (eq :line buffering) + :full + buffering) + external-format) + (pick-output-routine target-type buffering external-format)))) (unless bout-routine (error "could not find any output routine for ~S buffered ~S" (fd-stream-buffering fd-stream) target-type))) (when character-stream-p - (multiple-value-setq (cout-routine cout-type cout-size output-bytes - normalized-external-format) - (pick-output-routine target-type - (fd-stream-buffering fd-stream) - external-format)) + (setf (values cout-routine cout-type cout-size output-bytes + char-size normalized-external-format) + (pick-output-routine target-type + (fd-stream-buffering fd-stream) + external-format)) (unless cout-routine (error "could not find any output routine for ~S buffered ~S" (fd-stream-buffering fd-stream) target-type))) (when normalized-external-format - (setf (fd-stream-external-format fd-stream) - normalized-external-format)) + (setf (fd-stream-external-format fd-stream) normalized-external-format + (fd-stream-char-size fd-stream) char-size)) (when character-stream-p (setf (fd-stream-output-bytes fd-stream) output-bytes)) (setf (fd-stream-out fd-stream) cout-routine @@ -1985,8 +1942,7 @@ (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+ @@ -2070,8 +2026,8 @@ (: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 @@ -2087,6 +2043,7 @@ :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)) @@ -2096,7 +2053,21 @@ (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)) @@ -2123,13 +2094,14 @@ (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. @@ -2158,7 +2130,7 @@ (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 @@ -2190,7 +2162,7 @@ (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 @@ -2202,7 +2174,7 @@ ;; 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)))))))) ;;;; creation routines (MAKE-FD-STREAM and OPEN) @@ -2224,6 +2196,9 @@ ;;; FILE is the name of the file (will be returned by PATHNAME). ;;; ;;; NAME is used to identify the stream when printed. +;;; +;;; If SERVE-EVENTS is true, SERVE-EVENT machinery is used to +;;; handle blocking IO on the stream. (defun make-fd-stream (fd &key (input nil input-p) @@ -2231,6 +2206,7 @@ (element-type 'base-char) (buffering :full) (external-format :default) + serve-events timeout file original @@ -2249,6 +2225,12 @@ ((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 @@ -2256,9 +2238,8 @@ :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) @@ -2308,12 +2289,12 @@ (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)) @@ -2335,7 +2316,7 @@ (:io (values t t sb!unix:o_rdwr)) (:probe (values t nil sb!unix:o_rdonly))) (declare (type index mask)) - (let* (;; PATHNAME is the pathname we associate with the stream. + (let* ( ;; PATHNAME is the pathname we associate with the stream. (pathname (merge-pathnames filename)) (physical (physicalize-pathname pathname)) (truename (probe-file physical)) @@ -2344,144 +2325,172 @@ (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))) + (and (eq direction :io) + (not if-does-not-exist-given))) (native-namestring physical :as-file t))))) - ;; Process if-exists argument if we are doing any output. - (cond (output - (unless if-exists-given - (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) + (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 "~@" + 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 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)) - (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 "~@" - pathname)) - (t nil))) - ((and (eql errno sb!unix:eexist) (null if-exists)) - nil) - (t - (vanilla-open-error))))))))) + (vanilla-open-error)))))))))) ;;;; initialization @@ -2517,6 +2526,20 @@ (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 @@ -2524,24 +2547,34 @@ (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*))