X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ffd-stream.lisp;h=9bfe050ceb8af2cdf01a64e92893bf1d5c5b70af;hb=d1e7b48b17180a417c41ed55eb382ebf6d4e7a2a;hp=9503594d9d47dc499df3ddbf82412fc8554749c2;hpb=766970bdf375cc3fd28c6abc049f48a7dd9e0564;p=sbcl.git diff --git a/src/code/fd-stream.lisp b/src/code/fd-stream.lisp index 9503594..9bfe050 100644 --- a/src/code/fd-stream.lisp +++ b/src/code/fd-stream.lisp @@ -140,6 +140,16 @@ :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) + (error 'c-string-decoding-error + :external-format external-format + :octets octets)) + ;;; 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) @@ -169,6 +179,16 @@ (format stream "~@")) (throw 'output-nothing nil)))) +(defun external-format-encoding-error (stream code) + (if (streamp stream) + (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))) + ;;; 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 @@ -325,6 +345,7 @@ (intern (format nil name-fmt (string (car buffering)))))) `(progn (defun ,function (stream byte) + (declare (ignorable byte)) (output-wrapper/variable-width (stream ,size ,buffering ,restart) ,@body)) (setf *output-routines* @@ -551,13 +572,22 @@ element-type, string input function name, character input function name, and string output function name.") +(defun get-external-format (external-format) + (dolist (entry *external-formats*) + (when (member external-format (first entry)) + (return entry)))) + +(defun get-external-format-function (external-format index) + (let ((entry (get-external-format external-format))) + (when entry (nth index entry)))) + ;;; 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) - (dolist (entry *external-formats*) - (when (member external-format (first entry)) + (let ((entry (get-external-format external-format))) + (when entry (return-from pick-output-routine (values (symbol-function (nth (ecase buffering (:none 4) @@ -752,6 +782,7 @@ ,stream-var) (fd-stream-ibuf-head ,stream-var)))) + (declare (ignorable byte)) (setq size ,bytes) (input-at-least ,stream-var size) (setq ,element-var (locally ,@read-forms)) @@ -1001,6 +1032,16 @@ (when sizer (loop for char across string summing (funcall sizer char))))) +(defun find-external-format (external-format) + (when external-format + (find external-format *external-formats* :test #'member :key #'car))) + +(defun variable-width-external-format-p (ef-entry) + (when (eighth ef-entry) t)) + +(defun bytes-for-char-fun (ef-entry) + (if ef-entry (symbol-function (ninth ef-entry)) (constantly 1))) + ;;; FIXME: OAOOM here vrt. *EXTERNAL-FORMAT-FUNCTIONS* in fd-stream.lisp (defmacro define-external-format (external-format size output-restart out-expr in-expr) @@ -1009,7 +1050,9 @@ (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))) + (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))) `(progn (defun ,size-function (byte) (declare (ignore byte)) @@ -1113,13 +1156,58 @@ (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))) + (string (make-string length :element-type element-type))) + (declare (ignorable stream) + (type index length) + (type 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)) + (buffer (make-array (* (1+ length) ,size) :element-type '(unsigned-byte 8))) + (sap (sb!sys:vector-sap buffer)) + (tail 0) + (stream ,name)) + (declare (type index length tail) + (type 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) + buffer))) (setf *external-formats* (cons '(,external-format ,in-function ,in-char-function ,out-function ,@(mapcar #'(lambda (buffering) (intern (format nil format (string buffering)))) '(:none :line :full)) nil ; no resync-function - ,size-function) + ,size-function ,read-c-string-function ,output-c-string-function) *external-formats*))))) (defmacro define-external-format/variable-width @@ -1131,9 +1219,12 @@ (in-function (symbolicate "FD-STREAM-READ-N-CHARACTERS/" name)) (in-char-function (symbolicate "INPUT-CHAR/" name)) (resync-function (symbolicate "RESYNC/" name)) - (size-function (symbolicate "BYTES-FOR-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))) `(progn (defun ,size-function (byte) + (declare (ignorable byte)) ,out-size-expr) (defun ,out-function (stream string flush-p start end) (let ((start (or start 0)) @@ -1218,6 +1309,7 @@ (setf decode-break-reason (block decode-break-reason (let ((byte (sap-ref-8 sap head))) + (declare (ignorable byte)) (setq size ,in-size-expr) (when (> size (- tail head)) (return)) @@ -1262,6 +1354,7 @@ ,in-size-expr sap head) (let ((byte (sap-ref-8 sap head))) + (declare (ignorable byte)) ,in-expr)) (defun ,resync-function (stream) (loop (input-at-least stream 2) @@ -1271,19 +1364,97 @@ (head (fd-stream-ibuf-head stream)) (byte (sap-ref-8 sap head)) (size ,in-size-expr)) + (declare (ignorable byte)) (input-at-least stream size) (let ((sap (fd-stream-ibuf-sap stream)) (head (fd-stream-ibuf-head stream))) ,in-expr)) nil) (return)))) + (defun ,read-c-string-function (sap element-type) + (declare (type system-area-pointer sap)) + (locally + (declare (optimize (speed 3) (safety 0))) + (let* ((stream ,name) + (size 0) (head 0) (byte 0) (char nil) + (decode-break-reason nil) + (length (dotimes (count (1- ARRAY-DIMENSION-LIMIT) count) + (setf decode-break-reason + (block decode-break-reason + (setf byte (sap-ref-8 sap head) + size ,in-size-expr + char ,in-expr) + (incf head size) + nil)) + (when decode-break-reason + (c-string-decoding-error ,name decode-break-reason)) + (when (zerop (char-code char)) + (return count)))) + (string (make-string length :element-type element-type))) + (declare (ignorable stream) + (type index head length) ;; size + (type (unsigned-byte 8) byte) + (type (or null character) char) + (type string string)) + (setf head 0) + (dotimes (index length string) + (setf decode-break-reason + (block decode-break-reason + (setf byte (sap-ref-8 sap head) + size ,in-size-expr + char ,in-expr) + (incf head size) + nil)) + (when decode-break-reason + (c-string-decoding-error ,name decode-break-reason)) + (setf (aref string index) char))))) + + (defun ,output-c-string-function (string) + (declare (type simple-string string)) + (locally + (declare (optimize (speed 3) (safety 0))) + (let* ((length (length string)) + (char-length (make-array (1+ length) :element-type 'index)) + (buffer-length + (+ (loop for i of-type index below length + for byte of-type character = (aref string i) + for bits = (char-code byte) + sum (setf (aref char-length i) + (the index ,out-size-expr))) + (let* ((byte (code-char 0)) + (bits (char-code byte))) + (declare (ignorable byte bits)) + (setf (aref char-length length) + (the index ,out-size-expr))))) + (tail 0) + (buffer (make-array buffer-length :element-type '(unsigned-byte 8))) + (sap (sb!sys:vector-sap buffer)) + stream) + (declare (type index length buffer-length tail) + (type system-area-pointer sap) + (type null stream) + (ignorable stream)) + (loop for i of-type index below length + for byte of-type character = (aref string i) + for bits = (char-code byte) + for size of-type index = (aref char-length i) + do (prog1 + ,out-expr + (incf tail size))) + (let* ((bits 0) + (byte (code-char bits)) + (size (aref char-length length))) + (declare (ignorable bits byte size)) + ,out-expr) + buffer))) + (setf *external-formats* (cons '(,external-format ,in-function ,in-char-function ,out-function ,@(mapcar #'(lambda (buffering) (intern (format nil format (string buffering)))) '(:none :line :full)) ,resync-function - ,size-function) + ,size-function ,read-c-string-function ,output-c-string-function) *external-formats*))))) ;;; Multiple names for the :ISO{,-}8859-* families are needed because on @@ -1292,7 +1463,7 @@ (define-external-format (:latin-1 :latin1 :iso-8859-1 :iso8859-1) 1 t (if (>= bits 256) - (stream-encoding-error-and-handle stream bits) + (external-format-encoding-error stream bits) (setf (sap-ref-8 sap tail) bits)) (code-char byte)) @@ -1300,7 +1471,7 @@ :iso-646 :iso-646-us :|646|) 1 t (if (>= bits 128) - (stream-encoding-error-and-handle stream bits) + (external-format-encoding-error stream bits) (setf (sap-ref-8 sap tail) bits)) (code-char byte)) @@ -1331,7 +1502,7 @@ (define-external-format (:ebcdic-us :ibm-037 :ibm037) 1 t (if (>= bits 256) - (stream-encoding-error-and-handle stream bits) + (external-format-encoding-error stream bits) (setf (sap-ref-8 sap tail) (aref reverse-table bits))) (aref table byte))) @@ -1362,10 +1533,10 @@ (if (< bits 256) (if (= bits (char-code (aref latin-9-table bits))) bits - (stream-encoding-error-and-handle stream byte)) + (external-format-encoding-error 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)))) + (external-format-encoding-error stream byte)))) (aref latin-9-table byte))) (define-external-format/variable-width (:utf-8 :utf8) nil @@ -1582,33 +1753,36 @@ (declare (ignore arg2)) (case operation (:listen - (or (not (eql (fd-stream-ibuf-head fd-stream) - (fd-stream-ibuf-tail fd-stream))) - (fd-stream-listen fd-stream) - #!+win32 - (setf (fd-stream-listen fd-stream) - (sb!win32:fd-listen (fd-stream-fd fd-stream))) - #!-win32 - (setf (fd-stream-listen fd-stream) - (if (sysread-may-block-p fd-stream) - nil - ;; select(2) and CL:LISTEN have slightly different - ;; semantics. The former returns that an FD is - ;; readable when a read operation wouldn't block. - ;; That includes EOF. However, LISTEN must return - ;; NIL at EOF. - (progn (catch 'eof-input-catcher - ;; r-b/f too calls select, but it shouldn't - ;; block as long as read can return once w/o - ;; blocking - (refill-buffer/fd fd-stream)) - ;; If REFILL-BUFFER/FD set the FD-STREAM-LISTEN - ;; slot to a non-nil value (i.e. :EOF), keep - ;; that value. - (or (fd-stream-listen fd-stream) - ;; Otherwise we have data -> set the slot - ;; to T. - t)))))) + (labels ((do-listen () + (or (not (eql (fd-stream-ibuf-head fd-stream) + (fd-stream-ibuf-tail fd-stream))) + (fd-stream-listen fd-stream) + #!+win32 + (sb!win32:fd-listen (fd-stream-fd fd-stream)) + #!-win32 + ;; If the read can block, LISTEN will certainly return NIL. + (if (sysread-may-block-p fd-stream) + nil + ;; Otherwise select(2) and CL:LISTEN have slightly + ;; different semantics. The former returns that an FD + ;; is readable when a read operation wouldn't block. + ;; That includes EOF. However, LISTEN must return NIL + ;; at EOF. + (progn (catch 'eof-input-catcher + ;; r-b/f too calls select, but it shouldn't + ;; block as long as read can return once w/o + ;; blocking + (refill-buffer/fd fd-stream)) + ;; At this point either IBUF-HEAD != IBUF-TAIL + ;; and FD-STREAM-LISTEN is NIL, in which case + ;; we should return T, or IBUF-HEAD == + ;; IBUF-TAIL and FD-STREAM-LISTEN is :EOF, in + ;; which case we should return :EOF for this + ;; call and all future LISTEN call on this stream. + ;; Call ourselves again to determine which case + ;; applies. + (do-listen)))))) + (do-listen))) (:unread (setf (fd-stream-unread fd-stream) arg1) (setf (fd-stream-listen fd-stream) t)) @@ -1887,8 +2061,8 @@ ;;; Pick a name to use for the backup file for the :IF-EXISTS ;;; :RENAME-AND-DELETE and :RENAME options. (defun pick-backup-name (name) - (declare (type simple-base-string name)) - (concatenate 'simple-base-string name ".bak")) + (declare (type simple-string name)) + (concatenate 'simple-string name ".bak")) ;;; Ensure that the given arg is one of the given list of valid ;;; things. Allow the user to fix any problems.