Index: /trunk/ccl/level-1/l1-streams.lisp =================================================================== --- /trunk/ccl/level-1/l1-streams.lisp (revision 5328) +++ /trunk/ccl/level-1/l1-streams.lisp (revision 5329) @@ -382,6 +382,6 @@ (peek-char-function 'ioblock-no-char-input) (native-byte-order t) - (read-char-without-translation-while-locked-function 'ioblock-no-char-input) - (write-char-without-translation-while-locked-function 'iblock-no-char-output) + (read-char-without-translation-when-locked-function 'ioblock-no-char-input) + (write-char-without-translation-when-locked-function 'iblock-no-char-output) (sharing nil) (reserved0 nil) @@ -406,6 +406,6 @@ (report-bad-arg (ioblock-stream ioblock) '(and character-stream input-stream))) -(defun ioblock-no-char-output (ioblock &rest other-otters) - (declare (ignore other-otters)) +(defun ioblock-no-char-output (ioblock &rest others) + (declare (ignore others)) (report-bad-arg (ioblock-stream ioblock) '(and character-stream output-stream))) @@ -1833,4 +1833,5 @@ (limit (ioblock-literal-char-code-limit ioblock)) (encode-function (ioblock-encode-output-function ioblock)) + (wcf (ioblock-write-char-when-locked-function ioblock)) (start-char start-char (1+ start-char))) ((= i num-chars) (setf (ioblock-charpos ioblock) col) num-chars) @@ -1839,10 +1840,12 @@ (code (char-code char))) (declare (type (mod #x110000) code)) - (if (eq char #\newline) - (setq col 0) - (incf col)) - (if (< code limit) - (%ioblock-write-u8-element ioblock code) - (funcall encode-function char #'%ioblock-write-u8-element ioblock))))) + (cond ((eq char #\newline) + (setq col 0) + (funcall wcf ioblock char)) + (t + (incf col) + (if (< code limit) + (%ioblock-write-u8-element ioblock code) + (funcall encode-function char #'%ioblock-write-u8-element ioblock))))))) (declaim (inline %ioblock-write-u16-encoded-char)) @@ -1889,4 +1892,5 @@ (limit (ioblock-literal-char-code-limit ioblock)) (encode-function (ioblock-encode-output-function ioblock)) + (wcf (ioblock-write-char-when-locked-function ioblock)) (start-char start-char (1+ start-char))) ((= i num-chars) (setf (ioblock-charpos ioblock) col) num-chars) @@ -1895,10 +1899,12 @@ (code (char-code char))) (declare (type (mod #x110000) code)) - (if (eq char #\newline) - (setq col 0) - (incf col)) - (if (< code limit) - (%ioblock-write-u16-code-unit ioblock code) - (funcall encode-function char #'%ioblock-write-u16-code-unit ioblock))))) + (cond ((eq char #\newline) + (setq col 0) + (funcall wcf ioblock char)) + (t + (incf col) + (if (< code limit) + (%ioblock-write-u16-code-unit ioblock code) + (funcall encode-function char #'%ioblock-write-u16-code-unit ioblock))))))) (declaim (inline %ioblock-write-swapped-u16-encoded-char)) @@ -1935,4 +1941,5 @@ (limit (ioblock-literal-char-code-limit ioblock)) (encode-function (ioblock-encode-output-function ioblock)) + (wcf (ioblock-write-char-when-locked-function ioblock)) (start-char start-char (1+ start-char))) ((= i num-chars) (setf (ioblock-charpos ioblock) col) num-chars) @@ -1941,10 +1948,12 @@ (code (char-code char))) (declare (type (mod #x110000) code)) - (if (eq char #\newline) - (setq col 0) - (incf col)) - (if (< code limit) - (%ioblock-write-swapped-u16-code-unit ioblock code) - (funcall encode-function char #'%ioblock-write-swapped-u16-code-unit ioblock))))) + (cond ((eq char #\newline) + (setq col 0) + (funcall wcf ioblock char)) + (t + (incf col) + (if (< code limit) + (%ioblock-write-swapped-u16-code-unit ioblock code) + (funcall encode-function char #'%ioblock-write-swapped-u16-code-unit ioblock))))))) @@ -2330,5 +2339,5 @@ (defun %ioblock-read-char-translating-cr-to-newline (ioblock) (let* ((ch (funcall - (ioblock-read-char-without-translation-while-locked-function + (ioblock-read-char-without-translation-when-locked-function ioblock) ioblock))) @@ -2348,10 +2357,10 @@ (defun %ioblock-read-char-translating-crlf-to-newline (ioblock) (let* ((ch (funcall - (ioblock-read-char-without-translation-while-locked-function + (ioblock-read-char-without-translation-when-locked-function ioblock) ioblock))) (if (eql ch #\Return) (let* ((next (funcall - (ioblock-read-char-without-translation-while-locked-function + (ioblock-read-char-without-translation-when-locked-function ioblock) ioblock))) @@ -2375,5 +2384,5 @@ (defun %ioblock-read-char-translating-line-separator-to-newline (ioblock) (let* ((ch (funcall - (ioblock-read-char-without-translation-while-locked-function + (ioblock-read-char-without-translation-when-locked-function ioblock) ioblock))) @@ -2392,5 +2401,5 @@ (declaim (inline %ioblock-write-char-translating-newline-to-cr)) (defun %ioblock-write-char-translating-newline-to-cr (ioblock char) - (funcall (ioblock-write-char-without-translation-while-locked-function + (funcall (ioblock-write-char-without-translation-when-locked-function ioblock) ioblock @@ -2408,9 +2417,9 @@ (defun %ioblock-write-char-translating-newline-to-crlf (ioblock char) (when (eql char #\Newline) - (funcall (ioblock-write-char-without-translation-while-locked-function + (funcall (ioblock-write-char-without-translation-when-locked-function ioblock) ioblock #\Return)) - (funcall (ioblock-write-char-without-translation-while-locked-function + (funcall (ioblock-write-char-without-translation-when-locked-function ioblock) ioblock @@ -2427,5 +2436,5 @@ (declaim (inline %ioblock-write-char-translating-newline-to-line-separator)) (defun %ioblock-write-char-translating-newline-to-line-separator (ioblock char) - (funcall (ioblock-write-char-without-translation-while-locked-function + (funcall (ioblock-write-char-without-translation-when-locked-function ioblock) ioblock @@ -2444,9 +2453,8 @@ (defun setup-ioblock-input (ioblock character-p element-type sharing encoding line-termination) + (setf (ioblock-sharing ioblock) sharing) (when character-p (if encoding (let* ((unit-size (character-encoding-code-unit-size encoding))) - (unless (eql unit-size 8) - (setq line-termination nil)) (setf (ioblock-peek-char-function ioblock) '%encoded-ioblock-peek-char) (setf (ioblock-read-line-function ioblock) @@ -2494,8 +2502,36 @@ (setf (ioblock-read-line-function ioblock) '%ioblock-unencoded-read-line))) - (case line-termination - ((:cr :crlf) - (let* ((inbuf (ioblock-inbuf ioblock))) - (setf (io-buffer-translate inbuf) line-termination))))) + (when line-termination + (setf (ioblock-read-char-without-translation-when-locked-function ioblock) + (ioblock-read-char-when-locked-function ioblock)) + (ecase line-termination + (:cr (setf (ioblock-read-char-when-locked-function ioblock) + '%ioblock-read-char-translating-cr-to-newline + (ioblock-read-char-function ioblock) + (case sharing + (:private + '%private-ioblock-read-char-translating-cr-to-newline) + (:lock + '%locked-ioblock-read-char-translating-cr-to-newline) + (t '%ioblock-read-char-translating-cr-to-newline)))) + (:crlf (setf (ioblock-read-char-when-locked-function ioblock) + '%ioblock-read-char-translating-crlf-to-newline + (ioblock-read-char-function ioblock) + (case sharing + (:private + '%private-ioblock-read-char-translating-crlf-to-newline) + (:lock + '%locked-ioblock-read-char-translating-crlf-to-newline) + (t '%ioblock-read-char-translating-crlf-to-newline)))) + (:unicode (setf (ioblock-read-char-when-locked-function ioblock) + '%ioblock-read-char-translating-line-separator-to-newline + (ioblock-read-char-function ioblock) + (case sharing + (:private + '%private-ioblock-read-char-translating-line-separator-to-newline) + (:lock + '%locked-ioblock-read-char-translating-line-separator-to-newline) + (t '%ioblock-read-char-translating-line-separator-to-newline))))))) + (unless (or (eq element-type 'character) (subtypep element-type 'character)) @@ -2578,9 +2614,9 @@ (defun setup-ioblock-output (ioblock character-p element-type sharing encoding line-termination) + (or (ioblock-sharing ioblock) + (setf (ioblock-sharing ioblock) sharing)) (when character-p (if encoding (let* ((unit-size (character-encoding-code-unit-size encoding))) - (unless (eq unit-size 8) - (setq line-termination nil)) (setf (ioblock-encode-output-function ioblock) (character-encoding-stream-encode-function encoding)) @@ -2589,5 +2625,5 @@ (8 (setf (ioblock-write-char-when-locked-function ioblock) - '%ioblock-write-u8-encoded-char) + '%ioblock-write-u8-encoded-char) (case sharing (:private '%private-ioblock-write-u8-encoded-char) @@ -2616,5 +2652,5 @@ (if (character-encoding-native-endianness encoding) '%ioblock-write-u16-encoded-simple-string - '%ioblock-write-swapped-u8-encoded-simple-string)))) + '%ioblock-write-swapped-u16-encoded-simple-string)))) (when (character-encoding-use-byte-order-mark encoding) (setf (ioblock-pending-byte-order-mark ioblock) t))) @@ -2629,8 +2665,35 @@ (:lock '%locked-ioblock-write-char) (t '%ioblock-write-char))))) - (case line-termination - ((:cr :crlf) - (let* ((outbuf (ioblock-outbuf ioblock))) - (setf (io-buffer-translate outbuf) line-termination))))) + (when line-termination + (setf (ioblock-write-char-without-translation-when-locked-function ioblock) + (ioblock-write-char-when-locked-function ioblock)) + (ecase line-termination + (:cr (setf (ioblock-write-char-when-locked-function ioblock) + '%ioblock-write-char-translating-newline-to-cr + (ioblock-read-char-function ioblock) + (case sharing + (:private + '%private-ioblock-write-char-translating-newline-to-cr) + (:lock + '%locked-ioblock-write-char-translating-newline-to-cr) + (t '%ioblock-write-char-translating-newline-to-cr)))) + (:crlf (setf (ioblock-write-char-when-locked-function ioblock) + '%ioblock-write-char-translating-newline-to-crlf + (ioblock-write-char-function ioblock) + (case sharing + (:private + '%private-ioblock-write-char-translating-newline-to-crlf) + (:lock + '%locked-ioblock-write-char-translating-newline-to-crlf) + (t '%ioblock-write-char-translating-newline-to-crlf)))) + (:unicode (setf (ioblock-write-char-when-locked-function ioblock) + '%ioblock-write-char-translating-newline-to-line-separator + (ioblock-write-char-function ioblock) + (case sharing + (:private + '%private-ioblock-write-char-translating-newline-to-line-separator) + (:lock + '%locked-ioblock-write-char-translating-newline-to-line-separator) + (t '%ioblock-write-char-translating-newline-to-line-separator))))))) (unless (or (eq element-type 'character) (subtypep element-type 'character)) @@ -2738,4 +2801,5 @@ &allow-other-keys) (declare (ignorable element-shift)) + (setq line-termination (cdr (assoc line-termination *canonical-line-termination-conventions*))) (when encoding (unless (typep encoding 'character-encoding) @@ -2930,6 +2994,8 @@ (:cp/m . :crlf) (:msdos . :crlf) + (:dos . :crlf) (:windows . :crlf) - (:inferred . nil))) + (:inferred . nil) + (:unicode . :unicode)))