Index: /trunk/ccl/level-1/l1-streams.lisp =================================================================== --- /trunk/ccl/level-1/l1-streams.lisp (revision 5318) +++ /trunk/ccl/level-1/l1-streams.lisp (revision 5319) @@ -382,7 +382,11 @@ (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) + (sharing nil) + (reserved0 nil) + (reserved1 nil) (reserved2 nil) - (reserved3 nil) - (reserved4 nil)) + (reserved3 nil)) @@ -477,9 +481,24 @@ (unless (%ioblock-advance ioblock t) (return-from %ioblock-read-u8-byte :eof)) + (setq idx (io-buffer-idx buf))) + (setf (io-buffer-idx buf) (the fixnum (1+ idx))) + (aref (the (simple-array (unsigned-byte 8) (*)) + (io-buffer-buffer buf)) idx))) + +(declaim (inline %ioblock-read-u8-code-unit)) +(defun %ioblock-read-u8-code-unit (ioblock) + (declare (optimize (speed 3) (safety 0))) + (let* ((buf (ioblock-inbuf ioblock)) + (idx (io-buffer-idx buf)) + (limit (io-buffer-count buf))) + (declare (fixnum idx limit)) + (when (= idx limit) + (unless (%ioblock-advance ioblock t) + (return-from %ioblock-read-u8-code-unit :eof)) (setq idx (io-buffer-idx buf) limit (io-buffer-count buf))) (setf (io-buffer-idx buf) (the fixnum (1+ idx))) (aref (the (simple-array (unsigned-byte 8) (*)) - (io-buffer-buffer buf)) idx))) + (io-buffer-buffer buf)) idx))) (declaim (inline %ioblock-read-s8-byte)) @@ -1085,9 +1104,8 @@ (unless (%ioblock-advance ioblock t) (return-from %ioblock-tyi :eof)) - (setq idx (io-buffer-idx buf) - limit (io-buffer-count buf))) + (setq idx 0)) (setf (io-buffer-idx buf) (the fixnum (1+ idx))) (%code-char (aref (the (simple-array (unsigned-byte 8) (*)) - (io-buffer-buffer buf)) idx)))))) + (io-buffer-buffer buf)) idx)))))) (defun %private-ioblock-tyi (ioblock) @@ -1109,5 +1127,5 @@ (prog1 ch (setf (ioblock-untyi-char ioblock) nil)) - (let* ((1st-unit (%ioblock-read-u8-byte ioblock))) + (let* ((1st-unit (%ioblock-read-u8-code-unit ioblock))) (if (eq 1st-unit :eof) 1st-unit @@ -1119,5 +1137,5 @@ (funcall (ioblock-decode-input-function ioblock) 1st-unit - #'%ioblock-read-u8-byte + #'%ioblock-read-u8-code-unit ioblock)))))))) @@ -2060,54 +2078,56 @@ (defun %ioblock-unencoded-read-line (ioblock) - (let* ((string "") - (len 0) - (eof nil) - (inbuf (ioblock-inbuf ioblock)) - (buf (io-buffer-buffer inbuf)) - (newline (char-code #\newline))) - (let* ((ch (ioblock-untyi-char ioblock))) - (when ch - (setf (ioblock-untyi-char ioblock) nil) - (if (eql ch #\newline) - (return-from %ioblock-unencoded-read-line - (values string nil)) - (progn - (setq string (make-string 1) - len 1) - (setf (schar string 0) ch))))) - (loop - (let* ((more 0) - (idx (io-buffer-idx inbuf)) - (count (io-buffer-count inbuf))) - (declare (fixnum idx count more)) - (if (= idx count) - (if eof - (return (values string t)) - (progn - (setq eof t) - (%ioblock-advance ioblock t))) - (progn - (setq eof nil) - (let* ((pos (position newline buf :start idx :end count))) - (when pos - (locally (declare (fixnum pos)) - (setf (io-buffer-idx inbuf) (the fixnum (1+ pos))) - (setq more (- pos idx)) - (unless (zerop more) - (setq string - (%extend-vector - 0 string (the fixnum (+ len more))))) + (let* ((inbuf (ioblock-inbuf ioblock))) + (if (io-buffer-translate inbuf) + (%ioblock-encoded-read-line ioblock) + (let* ((string "") + (len 0) + (eof nil) + (buf (io-buffer-buffer inbuf)) + (newline (char-code #\newline))) + (let* ((ch (ioblock-untyi-char ioblock))) + (when ch + (setf (ioblock-untyi-char ioblock) nil) + (if (eql ch #\newline) + (return-from %ioblock-unencoded-read-line + (values string nil)) + (progn + (setq string (make-string 1) + len 1) + (setf (schar string 0) ch))))) + (loop + (let* ((more 0) + (idx (io-buffer-idx inbuf)) + (count (io-buffer-count inbuf))) + (declare (fixnum idx count more)) + (if (= idx count) + (if eof + (return (values string t)) + (progn + (setq eof t) + (%ioblock-advance ioblock t))) + (progn + (setq eof nil) + (let* ((pos (position newline buf :start idx :end count))) + (when pos + (locally (declare (fixnum pos)) + (setf (io-buffer-idx inbuf) (the fixnum (1+ pos))) + (setq more (- pos idx)) + (unless (zerop more) + (setq string + (%extend-vector + 0 string (the fixnum (+ len more))))) + (%copy-u8-to-string + buf idx string len more) + (return (values string nil)))) + ;; No #\newline in the buffer. Read everything that's + ;; there into the string, and fill the buffer again. + (setf (io-buffer-idx inbuf) count) + (setq more (- count idx) + string (%extend-vector + 0 string (the fixnum (+ len more)))) (%copy-u8-to-string buf idx string len more) - (return (values string nil)))) - ;; No #\newline in the buffer. Read everything that's - ;; there into the string, and fill the buffer again. - (setf (io-buffer-idx inbuf) count) - (setq more (- count idx) - string (%extend-vector - 0 string (the fixnum (+ len more)))) - (%copy-u8-to-string - buf idx string len more) - (incf len more)))))))) + (incf len more)))))))))) ;;; There are lots of ways of doing better here, but in the most general @@ -2125,27 +2145,29 @@ (defun %ioblock-unencoded-character-read-vector (ioblock vector start end) - (do* ((i start) - (in (ioblock-inbuf ioblock)) - (inbuf (io-buffer-buffer in)) - (need (- end start))) - ((= i end) end) - (declare (fixnum i need)) - (let* ((ch (%ioblock-tyi ioblock))) - (if (eq ch :eof) - (return i)) - (setf (schar vector i) ch) - (incf i) - (decf need) - (let* ((idx (io-buffer-idx in)) - (count (io-buffer-count in)) - (avail (- count idx))) - (declare (fixnum idx count avail)) - (unless (zerop avail) - (if (> avail need) - (setq avail need)) - (%copy-u8-to-string inbuf idx vector i avail) - (setf (io-buffer-idx in) (+ idx avail)) - (incf i avail) - (decf need avail)))))) + (let* ((in (ioblock-inbuf ioblock))) + (if (io-buffer-translate in) + (%ioblock-encoded-character-read-vector ioblock vector start end) + (do* ((i start) + (inbuf (io-buffer-buffer in)) + (need (- end start))) + ((= i end) end) + (declare (fixnum i need)) + (let* ((ch (%ioblock-tyi ioblock))) + (if (eq ch :eof) + (return i)) + (setf (schar vector i) ch) + (incf i) + (decf need) + (let* ((idx (io-buffer-idx in)) + (count (io-buffer-count in)) + (avail (- count idx))) + (declare (fixnum idx count avail)) + (unless (zerop avail) + (if (> avail need) + (setq avail need)) + (%copy-u8-to-string inbuf idx vector i avail) + (setf (io-buffer-idx in) (+ idx avail)) + (incf i avail) + (decf need avail)))))))) (defun %ioblock-encoded-character-read-vector (ioblock vector start end) @@ -2296,10 +2318,135 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - -(defun setup-ioblock-input (ioblock character-p element-type sharing encoding) +;;; Character-at-a-time line-termination-translation functions. +;;; It's not always possible to just blast through the buffer, blindly +;;; replacing #xd with #xa (for example), and it's not always desirable +;;; to do that (if we support changing encoding on open streams.) +;;; This is done at a fairly high level; some cases could be done at +;;; a lower level, and some cases are hard even at that lower level. +;;; This approach doesn't slow down the simple case (when no line-termination +;;; translation is used), and hopefully isn't -that- bad. + +(declaim (inline %ioblock-read-char-translating-cr-to-newline)) +(defun %ioblock-read-char-translating-cr-to-newline (ioblock) + (let* ((ch (funcall + (ioblock-read-char-without-translation-while-locked-function + ioblock) + ioblock))) + (if (eql ch #\Return) + #\Newline + ch))) + +(defun %private-ioblock-read-char-translating-cr-to-newline (ioblock) + (check-ioblock-owner ioblock) + (%ioblock-read-char-translating-cr-to-newline ioblock)) + +(defun %locked-ioblock-read-char-translating-cr-to-newline (ioblock) + (with-ioblock-input-lock-grabbed (ioblock) + (%ioblock-read-char-translating-cr-to-newline ioblock))) + +(declaim (inline %ioblock-read-char-translating-crlf-to-newline)) +(defun %ioblock-read-char-translating-crlf-to-newline (ioblock) + (let* ((ch (funcall + (ioblock-read-char-without-translation-while-locked-function + ioblock) + ioblock))) + (if (eql ch #\Return) + (let* ((next (funcall + (ioblock-read-char-without-translation-while-locked-function + ioblock) + ioblock))) + (if (eql next #\Linefeed) + next + (progn + (unless (eq next :eof) + (setf (ioblock-untyi-char ioblock) next)) + ch))) + ch))) + +(defun %private-ioblock-read-char-translating-crlf-to-newline (ioblock) + (check-ioblock-owner ioblock) + (%ioblock-read-char-translating-crlf-to-newline ioblock)) + +(defun %locked-ioblock-read-char-translating-crlf-to-newline (ioblock) + (with-ioblock-input-lock-grabbed (ioblock) + (%ioblock-read-char-translating-crlf-to-newline ioblock))) + +(declaim (inline %ioblock-read-char-translating-line-separator-to-newline)) +(defun %ioblock-read-char-translating-line-separator-to-newline (ioblock) + (let* ((ch (funcall + (ioblock-read-char-without-translation-while-locked-function + ioblock) + ioblock))) + (if (eql ch #\Line_Separator) + #\Newline + ch))) + +(defun %private-ioblock-read-char-translating-line-separator-to-newline (ioblock) + (check-ioblock-owner ioblock) + (%ioblock-read-char-translating-line-separator-to-newline ioblock)) + +(defun %locked-ioblock-read-char-translating-line-separator-to-newline (ioblock) + (with-ioblock-input-lock-grabbed (ioblock) + (%ioblock-read-char-translating-line-separator-to-newline ioblock))) + +(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 + ioblock) + ioblock + (if (eql char #\Newline) #\Return char))) + +(defun %private-ioblock-write-char-translating-newline-to-cr (ioblock char) + (check-ioblock-owner ioblock) + (%ioblock-write-char-translating-newline-to-cr ioblock char)) + +(defun %locked-ioblock-write-char-translating-newline-to-cr (ioblock char) + (with-ioblock-input-lock-grabbed (ioblock) + (%ioblock-write-char-translating-newline-to-cr ioblock char))) + +(declaim (inline %ioblock-write-char-translating-newline-to-crlf)) +(defun %ioblock-write-char-translating-newline-to-crlf (ioblock char) + (when (eql char #\Newline) + (funcall (ioblock-write-char-without-translation-while-locked-function + ioblock) + ioblock + #\Return)) + (funcall (ioblock-write-char-without-translation-while-locked-function + ioblock) + ioblock + char)) + +(defun %private-ioblock-write-char-translating-newline-to-crlf (ioblock char) + (check-ioblock-owner ioblock) + (%ioblock-write-char-translating-newline-to-crlf ioblock char)) + +(defun %locked-ioblock-write-char-translating-newline-to-crlf (ioblock char) + (with-ioblock-input-lock-grabbed (ioblock) + (%ioblock-write-char-translating-newline-to-crlf ioblock char))) + +(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 + ioblock) + ioblock + (if (eql char #\Newline) #\Line_Separator char))) + +(defun %private-ioblock-write-char-translating-newline-to-line-separator (ioblock char) + (check-ioblock-owner ioblock) + (%ioblock-write-char-translating-newline-to-line-separator ioblock char)) + +(defun %locked-ioblock-write-char-translating-newline-to-line-separator (ioblock char) + (with-ioblock-input-lock-grabbed (ioblock) + (%ioblock-write-char-translating-newline-to-line-separator ioblock char))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun setup-ioblock-input (ioblock character-p element-type sharing encoding line-termination) (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) @@ -2346,5 +2493,9 @@ '%ioblock-unencoded-character-read-vector) (setf (ioblock-read-line-function ioblock) - '%ioblock-unencoded-read-line)))) + '%ioblock-unencoded-read-line))) + (case line-termination + ((:cr :crlf) + (let* ((inbuf (ioblock-inbuf ioblock))) + (setf (io-buffer-translate inbuf) line-termination))))) (unless (or (eq element-type 'character) (subtypep element-type 'character)) @@ -2426,8 +2577,10 @@ '%general-ioblock-read-byte)))))) -(defun setup-ioblock-output (ioblock character-p element-type sharing encoding) +(defun setup-ioblock-output (ioblock character-p element-type sharing encoding line-termination) (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)) @@ -2475,5 +2628,9 @@ (:private '%private-ioblock-write-char) (:lock '%locked-ioblock-write-char) - (t '%ioblock-write-char)))))) + (t '%ioblock-write-char))))) + (case line-termination + ((:cr :crlf) + (let* ((outbuf (ioblock-outbuf ioblock))) + (setf (io-buffer-translate outbuf) line-termination))))) (unless (or (eq element-type 'character) (subtypep element-type 'character)) @@ -2578,4 +2735,5 @@ character-p encoding + line-termination &allow-other-keys) (declare (ignorable element-shift)) @@ -2617,5 +2775,5 @@ (when (eq sharing :lock) (setf (ioblock-inbuf-lock ioblock) (make-lock))) - (setup-ioblock-input ioblock character-p element-type sharing encoding) + (setup-ioblock-input ioblock character-p element-type sharing encoding line-termination) (setf (ioblock-element-shift ioblock) (max 0 (ceiling (log (/ in-size-in-octets insize) 2)))) ))) @@ -2645,5 +2803,5 @@ )))) (when (or share-buffers-p outsize) - (setup-ioblock-output ioblock character-p element-type sharing encoding)) + (setup-ioblock-output ioblock character-p element-type sharing encoding line-termination)) (when element-type (setf (ioblock-element-type ioblock) element-type)) @@ -2765,4 +2923,17 @@ +(defparameter *canonical-line-termination-conventions* + '((:unix . nil) + (:macos . :cr) + (:cr . :cr) + (:crlf . :crlf) + (:cp/m . :crlf) + (:msdos . :crlf) + (:windows . :crlf) + (:inferred . nil))) + + + + ;;; Note that we can get "bivalent" streams by specifiying :character-p t ;;; with a reasonable element-type (e.g. (UNSIGNED-BYTE 8)) @@ -2777,5 +2948,9 @@ (subtypep element-type 'character))) (basic nil) - encoding) + encoding + line-termination) + (when line-termination + (setq line-termination + (cdr (assoc line-termination *canonical-line-termination-conventions*)))) (when basic (setq class (map-to-basic-stream-class-name class)) @@ -2800,5 +2975,6 @@ :sharing sharing :character-p character-p - :encoding encoding))) + :encoding encoding + :line-termination line-termination))) ;;; Fundamental streams.