Changeset 5319

Timestamp:

Oct 8, 2006, 7:28:31 PM (18 years ago)

Author:

Gary Byers

Message:

Yet another line-termination translation scheme; hopefully, the last for a
while. (More tedium before it's actually installed.)

File:

• trunk/ccl/level-1/l1-streams.lisp (modified) (17 diffs)

trunk/ccl/level-1/l1-streams.lisp

@@ -382 +382 @@
   (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 +481 @@
       (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 +1104 @@
           (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 +1127 @@
       (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 +1137 @@
               (funcall (ioblock-decode-input-function ioblock)
                        1st-unit
-                       #'%ioblock-read-u8-byte
+                       #'%ioblock-read-u8-code-unit
                        ioblock))))))))
 
@@ -2060 +2078 @@
 
 (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 +2145 @@
          
 (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 +2318 @@
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
-
-
-(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 +2493 @@
               '%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 +2577 @@
                    '%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 +2628 @@
                 (: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 +2735 @@
                             character-p
                             encoding
+                            line-termination
                             &allow-other-keys)
   (declare (ignorable element-shift))
@@ -2617 +2775 @@
           (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 +2803 @@
             ))))
     (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 +2923 @@
 
 
+(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 +2948 @@
                                            (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 +2975 @@
                          :sharing sharing
                          :character-p character-p
-                         :encoding encoding)))
+                         :encoding encoding
+                         :line-termination line-termination)))
   
 ;;;  Fundamental streams.