X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fcode%2Ffd-stream.lisp;h=d2acaeef97e5900ef1f02eae768dac3543189f59;hb=22de9286aa239843ab7bc2cb772009fba6bcd080;hp=534c42c511a292ac2aeb4437f78e74b576ccac78;hpb=ed53de3c94faddfdc7447b3d61fef821c250e8d1;p=sbcl.git diff --git a/src/code/fd-stream.lisp b/src/code/fd-stream.lisp index 534c42c..d2acaee 100644 --- a/src/code/fd-stream.lisp +++ b/src/code/fd-stream.lisp @@ -505,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. @@ -759,6 +754,7 @@ ;; All the names that can refer to this external format. The first ;; one is the canonical name. (names (missing-arg) :type list :read-only t) + (default-replacement-character (missing-arg) :type character) (read-n-chars-fun (missing-arg) :type function) (read-char-fun (missing-arg) :type function) (write-n-bytes-fun (missing-arg) :type function) @@ -1091,12 +1087,15 @@ (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)) @@ -1336,202 +1335,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-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)))))) + (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)) @@ -1618,6 +1488,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) @@ -1632,9 +1504,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) @@ -1683,18 +1558,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) @@ -1710,7 +1587,7 @@ (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)) @@ -1729,7 +1606,7 @@ (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)) @@ -1780,6 +1657,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 @@ -2057,8 +1935,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+ @@ -2589,6 +2466,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 @@ -2598,22 +2483,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*))