X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ffd-stream.lisp;h=37a8a442da3ee4f3d3bcd3dd01e95d4fd3c4b69b;hb=8d490a4d6b9d7f156cf503826b3e3195e6f3ad39;hp=a6fdf1abf45c4f0439bc698fe0a98d871a37e7a3;hpb=d1355f6b79af346f05cf21c18637e269e0b499a1;p=sbcl.git diff --git a/src/code/fd-stream.lisp b/src/code/fd-stream.lisp index a6fdf1a..37a8a44 100644 --- a/src/code/fd-stream.lisp +++ b/src/code/fd-stream.lisp @@ -31,16 +31,10 @@ (pop *available-buffers*) (allocate-system-memory bytes-per-buffer))) -;;;; the FILE-STREAM structure +;;;; the FD-STREAM structure -(defstruct (file-stream +(defstruct (fd-stream (:constructor %make-fd-stream) - ;; KLUDGE: in an ideal world, maybe we'd rewrite - ;; everything to use FILE-STREAM rather than simply - ;; providing this hack for compatibility with the old - ;; code. However, CVS doesn't deal terribly well with - ;; file renaming, so for now we use this - ;; backward-compatibility feature. (:conc-name fd-stream-) (:predicate fd-stream-p) (:include ansi-stream @@ -89,7 +83,7 @@ (pathname nil :type (or pathname null)) (external-format :default) (output-bytes #'ill-out :type function)) -(def!method print-object ((fd-stream file-stream) stream) +(def!method print-object ((fd-stream fd-stream) stream) (declare (type stream stream)) (print-unreadable-object (fd-stream stream :type t :identity t) (format stream "for ~S" (fd-stream-name fd-stream)))) @@ -115,6 +109,46 @@ :format-arguments (list note-format (list pathname) (strerror errno)))) +(defun stream-decoding-error (stream octets) + (error 'stream-decoding-error + :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 + :stream stream + :code code)) + +;;; 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 ((sap (fd-stream-ibuf-sap stream)) + (head (fd-stream-ibuf-head stream))) + (loop for i from 0 below octet-count + collect (sap-ref-8 sap (+ head i))))) + (attempt-resync () + :report (lambda (stream) + (format stream + "~@")) + (fd-stream-resync stream) + nil) + (force-end-of-file () + :report (lambda (stream) + (format stream "~@")) + t))) + +(defun stream-encoding-error-and-handle (stream code) + (restart-case + (stream-encoding-error stream code) + (output-nothing () + :report (lambda (stream) + (format stream "~@")) + (throw 'output-nothing nil)))) + ;;; This is called by the server when we can write to the given file ;;; descriptor. Attempt to write the data again. If it worked, remove ;;; the data from the OUTPUT-LATER list. If it didn't work, something @@ -171,7 +205,7 @@ ;;; writes. If so, just queue this one. Otherwise, try to write it. If ;;; this would block, queue it. (defun frob-output (stream base start end reuse-sap) - (declare (type file-stream stream) + (declare (type fd-stream stream) (type (or system-area-pointer (simple-array * (*))) base) (type index start end)) (if (not (null (fd-stream-output-later stream))) ; something buffered. @@ -199,7 +233,7 @@ (frob-output stream (fd-stream-obuf-sap stream) 0 length t) (setf (fd-stream-obuf-tail stream) 0)))) -(defmacro output-wrapper/variable-width ((stream size buffering) +(defmacro output-wrapper/variable-width ((stream size buffering restart) &body body) (let ((stream-var (gensym))) `(let ((,stream-var ,stream) @@ -213,9 +247,13 @@ `(when (> (fd-stream-ibuf-tail ,stream-var) (fd-stream-ibuf-head ,stream-var)) (file-position ,stream-var (file-position ,stream-var)))) - - ,@body - (incf (fd-stream-obuf-tail ,stream-var) size) + ,(if restart + `(catch 'output-nothing + ,@body + (incf (fd-stream-obuf-tail ,stream-var) size)) + `(progn + ,@body + (incf (fd-stream-obuf-tail ,stream-var) size))) ,(ecase (car buffering) (:none `(flush-output-buffer ,stream-var)) @@ -225,7 +263,7 @@ (:full)) (values)))) -(defmacro output-wrapper ((stream size buffering) &body body) +(defmacro output-wrapper ((stream size buffering restart) &body body) (let ((stream-var (gensym))) `(let ((,stream-var ,stream)) ,(unless (eq (car buffering) :none) @@ -237,9 +275,13 @@ `(when (> (fd-stream-ibuf-tail ,stream-var) (fd-stream-ibuf-head ,stream-var)) (file-position ,stream-var (file-position ,stream-var)))) - - ,@body - (incf (fd-stream-obuf-tail ,stream-var) ,size) + ,(if restart + `(catch 'output-nothing + ,@body + (incf (fd-stream-obuf-tail ,stream-var) ,size)) + `(progn + ,@body + (incf (fd-stream-obuf-tail ,stream-var) ,size))) ,(ecase (car buffering) (:none `(flush-output-buffer ,stream-var)) @@ -249,19 +291,18 @@ (:full)) (values)))) -(defmacro def-output-routines/variable-width ((name-fmt size external-format - &rest bufferings) - &body body) +(defmacro def-output-routines/variable-width + ((name-fmt size restart external-format &rest bufferings) + &body body) (declare (optimize (speed 1))) (cons 'progn (mapcar (lambda (buffering) (let ((function - (intern (let ((*print-case* :upcase)) - (format nil name-fmt (car buffering)))))) + (intern (format nil name-fmt (string (car buffering)))))) `(progn (defun ,function (stream byte) - (output-wrapper/variable-width (stream ,size ,buffering) + (output-wrapper/variable-width (stream ,size ,buffering ,restart) ,@body)) (setf *output-routines* (nconc *output-routines* @@ -277,17 +318,17 @@ ;;; Define output routines that output numbers SIZE bytes long for the ;;; given bufferings. Use BODY to do the actual output. -(defmacro def-output-routines ((name-fmt size &rest bufferings) &body body) +(defmacro def-output-routines ((name-fmt size restart &rest bufferings) + &body body) (declare (optimize (speed 1))) (cons 'progn (mapcar (lambda (buffering) (let ((function - (intern (let ((*print-case* :upcase)) - (format nil name-fmt (car buffering)))))) + (intern (format nil name-fmt (string (car buffering)))))) `(progn (defun ,function (stream byte) - (output-wrapper (stream ,size ,buffering) + (output-wrapper (stream ,size ,buffering ,restart) ,@body)) (setf *output-routines* (nconc *output-routines* @@ -301,8 +342,10 @@ (cdr buffering))))))) bufferings))) +;;; FIXME: is this used anywhere any more? (def-output-routines ("OUTPUT-CHAR-~A-BUFFERED" 1 + t (:none character) (:line character) (:full character)) @@ -314,6 +357,7 @@ (def-output-routines ("OUTPUT-UNSIGNED-BYTE-~A-BUFFERED" 1 + nil (:none (unsigned-byte 8)) (:full (unsigned-byte 8))) (setf (sap-ref-8 (fd-stream-obuf-sap stream) (fd-stream-obuf-tail stream)) @@ -321,6 +365,7 @@ (def-output-routines ("OUTPUT-SIGNED-BYTE-~A-BUFFERED" 1 + nil (:none (signed-byte 8)) (:full (signed-byte 8))) (setf (signed-sap-ref-8 (fd-stream-obuf-sap stream) @@ -329,6 +374,7 @@ (def-output-routines ("OUTPUT-UNSIGNED-SHORT-~A-BUFFERED" 2 + nil (:none (unsigned-byte 16)) (:full (unsigned-byte 16))) (setf (sap-ref-16 (fd-stream-obuf-sap stream) (fd-stream-obuf-tail stream)) @@ -336,6 +382,7 @@ (def-output-routines ("OUTPUT-SIGNED-SHORT-~A-BUFFERED" 2 + nil (:none (signed-byte 16)) (:full (signed-byte 16))) (setf (signed-sap-ref-16 (fd-stream-obuf-sap stream) @@ -344,6 +391,7 @@ (def-output-routines ("OUTPUT-UNSIGNED-LONG-~A-BUFFERED" 4 + nil (:none (unsigned-byte 32)) (:full (unsigned-byte 32))) (setf (sap-ref-32 (fd-stream-obuf-sap stream) (fd-stream-obuf-tail stream)) @@ -351,6 +399,7 @@ (def-output-routines ("OUTPUT-SIGNED-LONG-~A-BUFFERED" 4 + nil (:none (signed-byte 32)) (:full (signed-byte 32))) (setf (signed-sap-ref-32 (fd-stream-obuf-sap stream) @@ -383,38 +432,32 @@ ((zerop bytes)) ; easy case ((<= bytes space) (if (system-area-pointer-p thing) - (system-area-copy thing - (* start sb!vm:n-byte-bits) - (fd-stream-obuf-sap fd-stream) - (* tail sb!vm:n-byte-bits) - (* bytes sb!vm:n-byte-bits)) + (system-area-ub8-copy thing start + (fd-stream-obuf-sap fd-stream) + tail + bytes) ;; FIXME: There should be some type checking somewhere to ;; verify that THING here is a vector, not just . - (copy-to-system-area thing - (+ (* start sb!vm:n-byte-bits) - (* sb!vm:vector-data-offset - sb!vm:n-word-bits)) - (fd-stream-obuf-sap fd-stream) - (* tail sb!vm:n-byte-bits) - (* bytes sb!vm:n-byte-bits))) + (copy-ub8-to-system-area thing start + (fd-stream-obuf-sap fd-stream) + tail + bytes)) (setf (fd-stream-obuf-tail fd-stream) newtail)) ((<= bytes len) (flush-output-buffer fd-stream) (if (system-area-pointer-p thing) - (system-area-copy thing - (* start sb!vm:n-byte-bits) - (fd-stream-obuf-sap fd-stream) - 0 - (* bytes sb!vm:n-byte-bits)) + (system-area-ub8-copy thing + start + (fd-stream-obuf-sap fd-stream) + 0 + bytes) ;; FIXME: There should be some type checking somewhere to ;; verify that THING here is a vector, not just . - (copy-to-system-area thing - (+ (* start sb!vm:n-byte-bits) - (* sb!vm:vector-data-offset - sb!vm:n-word-bits)) - (fd-stream-obuf-sap fd-stream) - 0 - (* bytes sb!vm:n-byte-bits))) + (copy-ub8-to-system-area thing + start + (fd-stream-obuf-sap fd-stream) + 0 + bytes)) (setf (fd-stream-obuf-tail fd-stream) bytes)) (t (flush-output-buffer fd-stream) @@ -446,15 +489,15 @@ :end end)))) (if (and (typep thing 'base-string) (eq (fd-stream-external-format stream) :latin-1)) - (ecase (fd-stream-buffering stream) - (:full - (output-raw-bytes stream thing start end)) - (:line - (output-raw-bytes stream thing start end) - (when last-newline - (flush-output-buffer stream))) - (:none - (frob-output stream thing start end nil))) + (ecase (fd-stream-buffering stream) + (:full + (output-raw-bytes stream thing start end)) + (:line + (output-raw-bytes stream thing start end) + (when last-newline + (flush-output-buffer stream))) + (:none + (frob-output stream thing start end nil))) (ecase (fd-stream-buffering stream) (:full (funcall (fd-stream-output-bytes stream) stream thing nil start end)) @@ -516,7 +559,7 @@ (ecase buffering (:none (lambda (stream byte) - (output-wrapper (stream (/ i 8) (:none)) + (output-wrapper (stream (/ i 8) (:none) nil) (loop for j from 0 below (/ i 8) do (setf (sap-ref-8 (fd-stream-obuf-sap stream) @@ -524,7 +567,7 @@ (ldb (byte 8 (- i 8 (* j 8))) byte)))))) (:full (lambda (stream byte) - (output-wrapper (stream (/ i 8) (:full)) + (output-wrapper (stream (/ i 8) (:full) nil) (loop for j from 0 below (/ i 8) do (setf (sap-ref-8 (fd-stream-obuf-sap stream) @@ -539,7 +582,7 @@ (ecase buffering (:none (lambda (stream byte) - (output-wrapper (stream (/ i 8) (:none)) + (output-wrapper (stream (/ i 8) (:none) nil) (loop for j from 0 below (/ i 8) do (setf (sap-ref-8 (fd-stream-obuf-sap stream) @@ -547,7 +590,7 @@ (ldb (byte 8 (- i 8 (* j 8))) byte)))))) (:full (lambda (stream byte) - (output-wrapper (stream (/ i 8) (:full)) + (output-wrapper (stream (/ i 8) (:full) nil) (loop for j from 0 below (/ i 8) do (setf (sap-ref-8 (fd-stream-obuf-sap stream) @@ -563,10 +606,10 @@ ;;; per element. (defvar *input-routines* ()) -;;; Fill the input buffer, and return the first character. Throw to -;;; EOF-INPUT-CATCHER if the eof was reached. Drop into SYSTEM:SERVER -;;; if necessary. -(defun frob-input (stream) +;;; Fill the input buffer, and return the number of bytes read. Throw +;;; to EOF-INPUT-CATCHER if the eof was reached. Drop into +;;; SYSTEM:SERVER if necessary. +(defun refill-buffer/fd (stream) (let ((fd (fd-stream-fd stream)) (ibuf-sap (fd-stream-ibuf-sap stream)) (buflen (fd-stream-ibuf-length stream)) @@ -581,8 +624,8 @@ (setf (fd-stream-ibuf-tail stream) 0)) (t (decf tail head) - (system-area-copy ibuf-sap (* head sb!vm:n-byte-bits) - ibuf-sap 0 (* tail sb!vm:n-byte-bits)) + (system-area-ub8-copy ibuf-sap head + ibuf-sap 0 tail) (setf head 0) (setf (fd-stream-ibuf-head stream) 0) (setf (fd-stream-ibuf-tail stream) tail)))) @@ -623,17 +666,18 @@ (unless (sb!sys:wait-until-fd-usable fd :input (fd-stream-timeout stream)) (error 'io-timeout :stream stream :direction :read)) - (frob-input stream)) + (refill-buffer/fd stream)) (simple-stream-perror "couldn't read from ~S" stream errno))) ((zerop count) (setf (fd-stream-listen stream) :eof) (/show0 "THROWing EOF-INPUT-CATCHER") (throw 'eof-input-catcher nil)) (t - (incf (fd-stream-ibuf-tail stream) count)))))) + (incf (fd-stream-ibuf-tail stream) count) + count))))) ;;; Make sure there are at least BYTES number of bytes in the input -;;; buffer. Keep calling FROB-INPUT until that condition is met. +;;; buffer. Keep calling REFILL-BUFFER/FD until that condition is met. (defmacro input-at-least (stream bytes) (let ((stream-var (gensym)) (bytes-var (gensym))) @@ -644,11 +688,12 @@ (fd-stream-ibuf-head ,stream-var)) ,bytes-var) (return)) - (frob-input ,stream-var))))) + (refill-buffer/fd ,stream-var))))) (defmacro input-wrapper/variable-width ((stream bytes eof-error eof-value) &body read-forms) (let ((stream-var (gensym)) + (retry-var (gensym)) (element-var (gensym))) `(let ((,stream-var ,stream) (size nil)) @@ -657,14 +702,36 @@ (fd-stream-unread ,stream-var) (setf (fd-stream-unread ,stream-var) nil) (setf (fd-stream-listen ,stream-var) nil)) - (let ((,element-var - (catch 'eof-input-catcher - (input-at-least ,stream-var 1) - (let* ((byte (sap-ref-8 (fd-stream-ibuf-sap ,stream-var) - (fd-stream-ibuf-head ,stream-var)))) - (setq size ,bytes) - (input-at-least ,stream-var size) - (locally ,@read-forms))))) + (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 (fd-stream-ibuf-sap + ,stream-var) + (fd-stream-ibuf-head + ,stream-var)))) + (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 (- (fd-stream-ibuf-tail ,stream-var) + (fd-stream-ibuf-head ,stream-var)))) + (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 (fd-stream-ibuf-head ,stream-var) size) ,element-var) @@ -818,10 +885,9 @@ (declare (type index start end)) (let* ((length (- end start)) (string (make-string length))) - (copy-from-system-area sap (* start sb!vm:n-byte-bits) - string (* sb!vm:vector-data-offset - sb!vm:n-word-bits) - (* length sb!vm:n-byte-bits)) + (copy-ub8-from-system-area sap start + string 0 + length) string)) ;;; the N-BIN method for FD-STREAMs @@ -831,7 +897,7 @@ ;;; isn't too problematical. (defun fd-stream-read-n-bytes (stream buffer start requested eof-error-p &aux (total-copied 0)) - (declare (type file-stream stream)) + (declare (type fd-stream stream)) (declare (type index start requested total-copied)) (let ((unread (fd-stream-unread stream))) (when unread @@ -870,7 +936,7 @@ (= total-copied requested) (return total-copied)) (;; If EOF, we're done in another way. - (zerop (refill-fd-stream-buffer stream)) + (null (catch 'eof-input-catcher (refill-buffer/fd stream))) (if eof-error-p (error 'end-of-file :stream stream) (return total-copied))) @@ -878,69 +944,54 @@ ;; through into another pass of the loop. )))) -;;; Try to refill the stream buffer. Return the number of bytes read. -;;; (For EOF, the return value will be zero, otherwise positive.) -(defun refill-fd-stream-buffer (stream) - ;; We don't have any logic to preserve leftover bytes in the buffer, - ;; so we should only be called when the buffer is empty. - ;; FIXME: can have three bytes in buffer because of UTF-8 - (let ((new-head 0) - (sap (fd-stream-ibuf-sap stream))) - (do ((head (fd-stream-ibuf-head stream) (1+ head)) - (tail (fd-stream-ibuf-tail stream))) - ((= head tail)) - (setf (sap-ref-8 sap new-head) (sap-ref-8 sap head)) - (incf new-head)) - (multiple-value-bind (count err) - (sb!unix:unix-read (fd-stream-fd stream) - (sap+ sap new-head) - (- (fd-stream-ibuf-length stream) new-head)) - (declare (type (or index null) count)) - (when (null count) - (simple-stream-perror "couldn't read from ~S" stream err)) - (setf (fd-stream-listen stream) nil - (fd-stream-ibuf-head stream) new-head - (fd-stream-ibuf-tail stream) (+ count new-head)) - count))) - -(defmacro define-external-format (external-format size out-expr in-expr) +(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))))) + +(defmacro define-external-format (external-format size output-restart + out-expr in-expr) (let* ((name (first external-format)) - (out-function (intern (let ((*print-case* :upcase)) - (format nil "OUTPUT-BYTES/~A" name)))) - (format (format nil "OUTPUT-CHAR-~A-~~A-BUFFERED" name)) - (in-function (intern (let ((*print-case* :upcase)) - (format nil "FD-STREAM-READ-N-CHARACTERS/~A" - name)))) - (in-char-function (intern (let ((*print-case* :upcase)) - (format nil "INPUT-CHAR/~A" name))))) + (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))) `(progn - (defun ,out-function (fd-stream string flush-p start end) + (defun ,out-function (stream string flush-p start end) (let ((start (or start 0)) (end (or end (length string)))) (declare (type index start end)) - (when (> (fd-stream-ibuf-tail fd-stream) - (fd-stream-ibuf-head fd-stream)) - (file-position fd-stream (file-position fd-stream))) + (when (> (fd-stream-ibuf-tail stream) + (fd-stream-ibuf-head stream)) + (file-position stream (file-position stream))) (when (< end start) (error ":END before :START!")) (do () ((= end start)) - (setf (fd-stream-obuf-tail fd-stream) - (do* ((len (fd-stream-obuf-length fd-stream)) - (sap (fd-stream-obuf-sap fd-stream)) - (tail (fd-stream-obuf-tail fd-stream))) + (setf (fd-stream-obuf-tail stream) + (do* ((len (fd-stream-obuf-length stream)) + (sap (fd-stream-obuf-sap stream)) + (tail (fd-stream-obuf-tail stream))) ((or (= start end) (< (- len tail) 4)) tail) - (let* ((byte (aref string start)) - (bits (char-code byte))) - ,out-expr - (incf tail ,size) - (incf start)))) + ,(if output-restart + `(catch 'output-nothing + (let* ((byte (aref string start)) + (bits (char-code byte))) + ,out-expr + (incf tail ,size))) + `(let* ((byte (aref string start)) + (bits (char-code byte))) + ,out-expr + (incf tail ,size))) + (incf start))) (when (< start end) - (flush-output-buffer fd-stream))) + (flush-output-buffer stream))) (when flush-p - (flush-output-buffer fd-stream)))) + (flush-output-buffer stream)))) (def-output-routines (,format ,size + ,output-restart (:none character) (:line character) (:full character)) @@ -953,7 +1004,7 @@ ,out-expr)) (defun ,in-function (stream buffer start requested eof-error-p &aux (total-copied 0)) - (declare (type file-stream stream)) + (declare (type fd-stream stream)) (declare (type index start requested total-copied)) (let ((unread (fd-stream-unread stream))) (when unread @@ -982,7 +1033,7 @@ (= total-copied requested) (return total-copied)) ( ;; If EOF, we're done in another way. - (zerop (refill-fd-stream-buffer stream)) + (null (catch 'eof-input-catcher (refill-buffer/fd stream))) (if eof-error-p (error 'end-of-file :stream stream) (return total-copied))) @@ -995,22 +1046,19 @@ (setf *external-formats* (cons '(,external-format ,in-function ,in-char-function ,out-function ,@(mapcar #'(lambda (buffering) - (intern (let ((*print-case* :upcase)) - (format nil format buffering)))) + (intern (format nil format (string buffering)))) '(:none :line :full))) *external-formats*))))) -(defmacro define-external-format/variable-width (external-format out-size-expr - out-expr in-size-expr in-expr) +(defmacro define-external-format/variable-width + (external-format output-restart out-size-expr + out-expr in-size-expr in-expr) (let* ((name (first external-format)) - (out-function (intern (let ((*print-case* :upcase)) - (format nil "OUTPUT-BYTES/~A" name)))) - (format (format nil "OUTPUT-CHAR-~A-~~A-BUFFERED" name)) - (in-function (intern (let ((*print-case* :upcase)) - (format nil "FD-STREAM-READ-N-CHARACTERS/~A" - name)))) - (in-char-function (intern (let ((*print-case* :upcase)) - (format nil "INPUT-CHAR/~A" name))))) + (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)) + (resync-function (symbolicate "RESYNC/" name))) `(progn (defun ,out-function (fd-stream string flush-p start end) (let ((start (or start 0)) @@ -1028,18 +1076,27 @@ (sap (fd-stream-obuf-sap fd-stream)) (tail (fd-stream-obuf-tail fd-stream))) ((or (= start end) (< (- len tail) 4)) tail) - (let* ((byte (aref string start)) - (bits (char-code byte)) - (size ,out-size-expr)) - ,out-expr - (incf tail size) - (incf start)))) + ,(if output-restart + `(catch 'output-nothing + (let* ((byte (aref string start)) + (bits (char-code byte)) + (size ,out-size-expr)) + ,out-expr + (incf tail size) + (incf start))) + `(let* ((byte (aref string start)) + (bits (char-code byte)) + (size ,out-size-expr)) + ,out-expr + (incf tail size))) + (incf start))) (when (< start end) (flush-output-buffer fd-stream))) (when flush-p (flush-output-buffer fd-stream)))) (def-output-routines/variable-width (,format ,out-size-expr + ,output-restart ,external-format (:none character) (:line character) @@ -1053,7 +1110,7 @@ ,out-expr)) (defun ,in-function (stream buffer start requested eof-error-p &aux (total-copied 0)) - (declare (type file-stream stream)) + (declare (type fd-stream stream)) (declare (type index start requested total-copied)) (let ((unread (fd-stream-unread stream))) (when unread @@ -1065,25 +1122,44 @@ (nil) (let* ((head (fd-stream-ibuf-head stream)) (tail (fd-stream-ibuf-tail stream)) - (sap (fd-stream-ibuf-sap stream))) + (sap (fd-stream-ibuf-sap stream)) + (head-start head) + (decode-break-reason nil)) (declare (type index head tail)) ;; Copy data from stream buffer into user's buffer. - (do () + (do ((size nil nil)) ((or (= tail head) (= requested total-copied))) - (let* ((byte (sap-ref-8 sap head)) - (size ,in-size-expr)) - (when (> size (- tail head)) - (return)) - (setf (aref buffer (+ start total-copied)) ,in-expr) - (incf total-copied) - (incf head size))) + (setf decode-break-reason + (block decode-break-reason + (let ((byte (sap-ref-8 sap head))) + (setq size ,in-size-expr) + (when (> size (- tail head)) + (return)) + (setf (aref buffer (+ start total-copied)) ,in-expr) + (incf total-copied) + (incf head size)) + nil)) + (setf (fd-stream-ibuf-head stream) head) + (when (and decode-break-reason + (= head head-start)) + (when (stream-decoding-error-and-handle + stream decode-break-reason) + (if eof-error-p + (error 'end-of-file :stream stream) + (return-from ,in-function total-copied))) + (setf head (fd-stream-ibuf-head stream)) + (setf tail (fd-stream-ibuf-tail stream))) + (when (plusp total-copied) + (return-from ,in-function total-copied))) (setf (fd-stream-ibuf-head stream) 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) (return total-copied)) ( ;; If EOF, we're done in another way. - (zerop (refill-fd-stream-buffer stream)) + (or (eq decode-break-reason 'eof) + (null (catch 'eof-input-catcher + (refill-buffer/fd stream)))) (if eof-error-p (error 'end-of-file :stream stream) (return total-copied))) @@ -1096,23 +1172,104 @@ sap head) (let ((byte (sap-ref-8 sap head))) ,in-expr)) + (defun ,resync-function (stream) + (loop (input-at-least stream 1) + (incf (fd-stream-ibuf-head stream)) + (unless (block decode-break-reason + (let* ((sap (fd-stream-ibuf-sap stream)) + (head (fd-stream-ibuf-head stream)) + (byte (sap-ref-8 sap head)) + (size ,in-size-expr)) + ,in-expr) + nil) + (return)))) (setf *external-formats* (cons '(,external-format ,in-function ,in-char-function ,out-function ,@(mapcar #'(lambda (buffering) - (intern (let ((*print-case* :upcase)) - (format nil format buffering)))) - '(:none :line :full))) + (intern (format nil format (string buffering)))) + '(:none :line :full)) + ,resync-function) *external-formats*))))) -(define-external-format (:latin-1 :latin1 :iso-8859-1 - ;; FIXME: shouldn't ASCII-like things have an - ;; extra typecheck for 7-bitness? - :ascii :us-ascii :ansi_x3.4-1968) - 1 - (setf (sap-ref-8 sap tail) bits) +(define-external-format (:latin-1 :latin1 :iso-8859-1) + 1 t + (if (>= bits 256) + (stream-encoding-error-and-handle stream bits) + (setf (sap-ref-8 sap tail) bits)) (code-char byte)) -(define-external-format/variable-width (:utf-8 :utf8) +(define-external-format (:ascii :us-ascii :ansi_x3.4-1968) + 1 t + (if (>= bits 128) + (stream-encoding-error-and-handle 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) + (stream-encoding-error-and-handle 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) + 1 t + (setf (sap-ref-8 sap tail) + (if (< bits 256) + (if (= bits (char-code (aref latin-9-table bits))) + bits + (stream-encoding-error-and-handle stream byte)) + (if (= (aref latin-9-reverse-1 (logand bits 15)) bits) + (aref latin-9-reverse-2 (logand bits 15)) + (stream-encoding-error-and-handle 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) @@ -1130,19 +1287,32 @@ (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 (dpb byte (byte 5 6) (sap-ref-8 sap (1+ head)))) - (3 (dpb byte (byte 4 12) - (dpb (sap-ref-8 sap (1+ head)) (byte 6 6) - (sap-ref-8 sap (+ 2 head))))) - (4 (dpb byte (byte 3 18) - (dpb (sap-ref-8 sap (1+ head)) (byte 6 12) - (dpb (sap-ref-8 sap (+ 2 head)) (byte 6 6) - (sap-ref-8 sap (+ 3 head))))))))) + (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)))))))) ;;;; utility functions (misc routines, etc) @@ -1178,11 +1348,16 @@ (function c-string int)) sb!unix:codeset) "LATIN-1") - "KEYWORD"))) - (dolist (entry *external-formats* - (setf (fd-stream-external-format fd-stream) :latin-1)) - (when (member (fd-stream-external-format fd-stream) (first entry)) - (return))) + "KEYWORD")) + (dolist (entry *external-formats* + (restart-case + (error "Invalid external-format ~A" + (fd-stream-external-format fd-stream)) + (use-default () + :report "Set external format to LATIN-1" + (setf (fd-stream-external-format fd-stream) :latin-1)))) + (when (member (fd-stream-external-format fd-stream) (first entry)) + (return)))) (when input-p (multiple-value-bind (routine type size read-n-characters @@ -1392,7 +1567,7 @@ 0 0)))) (cond ((eql count 1) - (frob-input fd-stream) + (refill-buffer/fd fd-stream) (setf (fd-stream-ibuf-head fd-stream) 0) (setf (fd-stream-ibuf-tail fd-stream) 0)) (t @@ -1421,7 +1596,7 @@ ;; appropriate value for the EXPECTED-TYPE slot.. (error 'simple-type-error :datum fd-stream - :expected-type 'file-stream + :expected-type 'fd-stream :format-control "~S is not a stream associated with a file." :format-arguments (list fd-stream))) (multiple-value-bind (okay dev ino mode nlink uid gid rdev size @@ -1438,7 +1613,7 @@ (fd-stream-file-position fd-stream arg1)))) (defun fd-stream-file-position (stream &optional newpos) - (declare (type file-stream stream) + (declare (type fd-stream stream) (type (or (alien sb!unix:off-t) (member nil :start :end)) newpos)) (if (null newpos) (sb!sys:without-interrupts @@ -1682,7 +1857,7 @@ (let ((original (case if-exists ((:rename :rename-and-delete) (pick-backup-name namestring)) - ((:append) + ((:append :overwrite) ;; KLUDGE: Provent CLOSE from deleting ;; appending streams when called with :ABORT T namestring))) @@ -1811,7 +1986,8 @@ (make-fd-stream 1 :name "standard output" :output t :buffering :line)) (setf *stderr* (make-fd-stream 2 :name "standard error" :output t :buffering :line)) - (let ((tty (sb!unix:unix-open "/dev/tty" sb!unix:o_rdwr #o666))) + (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 @@ -1835,7 +2011,7 @@ ;;; ;;; FIXME: misleading name, screwy interface (defun file-name (stream &optional new-name) - (when (typep stream 'file-stream) + (when (typep stream 'fd-stream) (cond (new-name (setf (fd-stream-pathname stream) new-name) (setf (fd-stream-file stream) @@ -1852,7 +2028,7 @@ ;;;; COMMON-LISP.) (defun file-string-length (stream object) - (declare (type (or string character) object) (type file-stream stream)) + (declare (type (or string character) object) (type fd-stream stream)) #!+sb-doc "Return the delta in STREAM's FILE-POSITION that would be caused by writing OBJECT to STREAM. Non-trivial only in implementations that support @@ -1863,9 +2039,9 @@ (string (length object)))) (defun stream-external-format (stream) - (declare (type file-stream stream)) + (declare (type fd-stream stream)) #!+sb-doc - "Return the actual external format for file-streams, otherwise :DEFAULT." - (if (typep stream 'file-stream) + "Return the actual external format for fd-streams, otherwise :DEFAULT." + (if (typep stream 'fd-stream) (fd-stream-external-format stream) :default))