X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ffd-stream.lisp;h=79911fc45a2948e5f2c4f7c7d9497e6701219db4;hb=4ec0d70e08ea4b512d45ddbd6c82e8f6a91a914f;hp=655ee641013c41a287a176ba89e87f489142954a;hpb=576e192035c3b6a2101eb423cec2fa286ad5ba81;p=sbcl.git diff --git a/src/code/fd-stream.lisp b/src/code/fd-stream.lisp index 655ee64..79911fc 100644 --- a/src/code/fd-stream.lisp +++ b/src/code/fd-stream.lisp @@ -171,8 +171,9 @@ (listen nil :type (member nil t :eof)) ;; 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)) @@ -462,7 +463,24 @@ (force-end-of-file () :report (lambda (stream) (format stream "~@")) - t))) + (setf (fd-stream-eof-forced-p stream) t)) + (input-replacement (string) + :report (lambda (stream) + (format stream "~@")) + :interactive (lambda () + (format *query-io* "~@") + (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 @@ -470,6 +488,16 @@ (output-nothing () :report (lambda (stream) (format stream "~@")) + (throw 'output-nothing nil)) + (output-replacement (string) + :report (lambda (stream) + (format stream "~@")) + :interactive (lambda () + (format *query-io* "~@") + (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) @@ -477,11 +505,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. @@ -702,7 +725,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)) @@ -727,28 +750,48 @@ (: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 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 @@ -756,12 +799,57 @@ 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))) +(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. @@ -777,7 +865,7 @@ 'character 1 (ef-write-n-bytes-fun entry) - (first (ef-names entry))))))) + (canonize-external-format external-format entry)))))) (dolist (entry *output-routines*) (when (and (subtypep type (first entry)) (eq buffering (second entry)) @@ -979,45 +1067,54 @@ `(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 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 + (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) @@ -1025,11 +1122,8 @@ (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) @@ -1122,7 +1216,7 @@ 'character 1 (ef-read-n-chars-fun entry) - (first (ef-names entry))))))) + (canonize-external-format external-format entry)))))) (dolist (entry *input-routines*) (when (and (subtypep type (first entry)) (or (not (fourth entry)) @@ -1178,22 +1272,7 @@ &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)) @@ -1253,195 +1332,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))) - (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))) - (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)) @@ -1467,36 +1424,33 @@ (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 @@ -1522,12 +1476,18 @@ (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)) @@ -1565,8 +1525,10 @@ (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. @@ -1591,20 +1553,21 @@ ,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))))) + (catch 'eof-input-catcher + (loop + (incf (buffer-head ibuf)) + (input-at-least stream 1) + (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)))))) (defun ,read-c-string-function (sap element-type) (declare (type system-area-pointer sap)) (locally @@ -1686,6 +1649,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 @@ -1697,8 +1661,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)))))) @@ -1895,13 +1863,12 @@ ;; 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)) @@ -1959,17 +1926,8 @@ (do-listen))))))) (do-listen))) (:unread - ;; If the stream is bivalent, the user might follow an - ;; unread-char with a read-byte. In this case, the bookkeeping - ;; is simpler if we adjust the buffer head by the number of code - ;; units in the character. - ;; FIXME: there has to be a proper way to check for bivalence, - ;; right? - (if (fd-stream-bivalent-p fd-stream) - (decf (buffer-head (fd-stream-ibuf fd-stream)) - (fd-stream-character-size fd-stream arg1)) - (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+ @@ -2135,8 +2093,6 @@ (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)))))) @@ -2502,6 +2458,14 @@ (without-package-locks (makunbound '*available-buffers*)))) +(defun stdstream-external-format (outputp) + (declare (ignorable outputp)) + (let* ((keyword #!+win32 (if outputp (sb!win32::console-output-codepage) (sb!win32::console-input-codepage)) + #!-win32 (default-external-format)) + (ef (get-external-format keyword)) + (replacement (ef-default-replacement-character ef))) + `(,keyword :replacement ,replacement))) + ;;; This is called whenever a saved core is restarted. (defun stream-reinit (&optional init-buffers-p) (when init-buffers-p @@ -2511,22 +2475,20 @@ (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))) + :external-format (stdstream-external-format nil))) (setf *stdout* (make-fd-stream 1 :name "standard output" :output t :buffering :line - #!+win32 :external-format #!+win32 (sb!win32::console-output-codepage))) + :external-format (stdstream-external-format t))) (setf *stderr* (make-fd-stream 2 :name "standard error" :output t :buffering :line - #!+win32 :external-format #!+win32 (sb!win32::console-output-codepage))) + :external-format (stdstream-external-format t))) (let* ((ttyname #.(coerce "/dev/tty" 'simple-base-string)) (tty (sb!unix:unix-open ttyname sb!unix:o_rdwr #o666))) (if tty (setf *tty* - (make-fd-stream tty - :name "the terminal" - :input t - :output t - :buffering :line + (make-fd-stream tty :name "the terminal" + :input t :output t :buffering :line + :external-format (stdstream-external-format t) :auto-close t)) (setf *tty* (make-two-way-stream *stdin* *stdout*)))) (princ (get-output-stream-string *error-output*) *stderr*))