Changeset 5245

Timestamp:

Sep 23, 2006, 4:28:38 AM (18 years ago)

Author:

Gary Byers

Message:

Lots-o-changes.

File:

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

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

@@ -368 +368 @@
   (write-char-function 'ioblock-no-char-output)
   (encoding nil)
-  (alternate-line-termination nil)
+  (line-termination nil)
   (literal-char-code-limit 256)
   (encode-output-function nil)
@@ -379 +379 @@
   (read-byte-when-locked-function 'ioblock-no-binary-input)
   (write-byte-when-locked-function 'ioblock-no-binary-output)
+  (peek-char-function 'ioblock-no-char-input)
+  (input-filter #'false)
+  (output-filter #'false)
   (reserved1 nil)
   (reserved2 nil)
-  (reserved2 nil)
-  (reserved3 nil))
+  (reserved3 nil)
+  (reserved4 nil))
 
 
@@ -396 +399 @@
   (report-bad-arg (ioblock-stream ioblock) '(and binary-stream output-stream)))
 
-(defun ioblock-no-charr-input (ioblock &rest others)
+(defun ioblock-no-char-input (ioblock &rest others)
   (declare (ignore others))
   (report-bad-arg (ioblock-stream ioblock) '(and character-stream input-stream)))
@@ -816 +819 @@
   (%ioblock-read-u8-encoded-char ioblock))
 
-(defun %private-ioblock-read-u8-encoded-char (ioblock)
+(defun %locked-ioblock-read-u8-encoded-char (ioblock)
   (declare (optimize (speed 3) (safety 0)))
   (with-ioblock-input-locked (ioblock)
@@ -853 +856 @@
 
 (declaim (inline %ioblock-tyi-no-hang))
-
 (defun %ioblock-tyi-no-hang (ioblock)
   (declare (optimize (speed 3) (safety 0)))
@@ -865 +867 @@
       (when (= idx limit)
         (unless (%ioblock-advance ioblock nil)
-          (return-from %ioblock-tyi-no-hang (if (ioblock-eof ioblock) :eof)))
-        (setq idx (io-buffer-idx buf)
-              limit (io-buffer-count buf)))
-      (setf (io-buffer-idx buf) (the fixnum (1+ idx)))
-      (%code-char (aref (the (simple-array (unsigned-byte 8) (*)) (io-buffer-buffer buf)) idx)))))
-
-
+          (return-from %ioblock-tyi-no-hang (if (ioblock-eof ioblock) :eof))))
+      (funcall (ioblock-read-char-when-locked-function ioblock) ioblock))))
+
+;;; :iso-8859-1 only.
 (defun %ioblock-peek-char (ioblock)
   (or (ioblock-untyi-char ioblock)
@@ -885 +884 @@
         (%code-char (aref (the (simple-array (unsigned-byte 8) (*)) (io-buffer-buffer buf)) idx)))))
 
+(defun %encoded-ioblock-peek-char (ioblock)
+  (or (ioblock-untyi-char ioblock)
+      (let* ((ch (funcall (ioblock-read-char-when-locked-function ioblock))))
+        (unless (eq ch :eof)
+          (setf (ioblock-untyi-char ioblock) ch))
+        ch)))
+
+
+
+
 (defun %ioblock-clear-input (ioblock)    
     (let* ((buf (ioblock-inbuf ioblock)))
@@ -906 +915 @@
 (defun ioblock-outpos (ioblock)
   (io-buffer-count (ioblock-outbuf ioblock)))
+
+
+
+(defun u8-translate-cr-to-lf (vector n)
+  (declare (type (simple-array (unsigned-byte 8) (*)) vector)
+           (type index n)
+           (optimize (speed 3) (safety 0)))
+  (dotimes (i n t)
+    (if (= (the (unsigned-byte 8) (aref vector i)) (char-code #\Return))
+      (setf (aref vector i) (char-code #\Linefeed)))))
+
+(defun u8-translate-lf-to-cr (vector n)
+  (declare (type (simple-array (unsigned-byte 8) (*)) vector)
+           (type index n)
+           (optimize (speed 3) (safety 0)))
+  (dotimes (i n t)
+    (if (= (the (unsigned-byte 8) (aref vector i)) (char-code #\Linefeed))
+      (setf (aref vector i) (char-code #\Return)))))
+
+
+(defun u16-translate-cr-to-lf (vector n)
+  (declare (type (simple-array (unsigned-byte 16) (*)) vector)
+           (type index n)
+           (optimize (speed 3) (safety 0)))
+  (dotimes (i n t)
+    (if (= (the (unsigned-byte 16) (aref vector i)) (char-code #\Return))
+      (setf (aref vector i) (char-code #\Linefeed)))))
+
+(defun u16-translate-lf-to-cr (vector n)
+  (declare (type (simple-array (unsigned-byte 16) (*)) vector)
+           (type index n)
+           (optimize (speed 3) (safety 0)))
+  (dotimes (i n t)
+    (if (= (the (unsigned-byte 16) (aref vector i)) (char-code #\Linefeed))
+      (setf (aref vector i) (char-code #\Return)))))
+
+(defun u32-translate-cr-to-lf (vector n)
+  (declare (type (simple-array (unsigned-byte 32) (*)) vector)
+           (type index n)
+           (optimize (speed 3) (safety 0)))
+  (dotimes (i n t)
+    (if (= (the (unsigned-byte 32) (aref vector i)) (char-code #\Return))
+      (setf (aref vector i) (char-code #\Linefeed)))))
+
+(defun u32-translate-lf-to-cr (vector n)
+  (declare (type (simple-array (unsigned-byte 32) (*)) vector)
+           (type index n)
+           (optimize (speed 3) (safety 0)))
+  (dotimes (i n t)
+    (if (= (the (unsigned-byte 32) (aref vector i)) (char-code #\Linefeed))
+      (setf (aref vector i) (char-code #\Return)))))
+
+
+(defun swapped-u16-translate-cr-to-lf (vector n)
+  (declare (type (simple-array (unsigned-byte 16) (*)) vector)
+           (type index n)
+           (optimize (speed 3) (safety 0)))
+  (dotimes (i n t)
+    (if (= (the (unsigned-byte 16) (aref vector i)) #xd00)
+      (setf (aref vector i) #xa00))))
+
+(defun swapped-u16-translate-lf-to-cr (vector n)
+  (declare (type (simple-array (unsigned-byte 16) (*)) vector)
+           (type index n)
+           (optimize (speed 3) (safety 0)))
+  (dotimes (i n t)
+    (if (= (the (unsigned-byte 16) (aref vector i)) #xa00)
+      (setf (aref vector i) #xd00))))
+
+(defun swapped-u32-translate-cr-to-lf (vector n)
+  (declare (type (simple-array (unsigned-byte 32) (*)) vector)
+           (type index n)
+           (optimize (speed 3) (safety 0)))
+  (dotimes (i n t)
+    (if (= (the (unsigned-byte 32) (aref vector i)) #xd000000)
+      (setf (aref vector i) #xa000000))))
+
+(defun swapped-32-translate-lf-to-cr (vector n)
+  (declare (type (simple-array (unsigned-byte 32) (*)) vector)
+           (type index n)
+           (optimize (speed 3) (safety 0)))
+  (dotimes (i n t)
+    (if (= (the (unsigned-byte 32) (aref vector i)) #xa000000)
+      (setf (aref vector i) #xd0000000))))
 
 (declaim (inline %ioblock-force-output))
@@ -1554 +1647 @@
                buf idx string len more)
               (incf len more))))))))
+
+;;; There are lots of ways of doing better here, but in the most general
+;;; case we can't tell (a) what a newline looks like in the buffer or (b)
+;;; whether there's a 1:1 mapping between code units and characters.
+(defun %ioblock-encoded-read-line (ioblock)
+  (let* ((str (make-array 20 :element-type 'base-char
+                          :adjustable t :fill-pointer 0))
+         (rcf (ioblock-read-char-when-locked-function ioblock))
+         (eof nil))
+    (do* ((ch (funcall rcf ioblock) (funcall rcf ioblock)))
+         ((or (eq ch #\newline) (setq eof (eq ch :eof)))
+          (values (ensure-simple-string str) eof))
+      (vector-push-extend ch str))))
          
 (defun %ioblock-unencoded-character-read-vector (ioblock vector start end)
@@ -1579 +1685 @@
           (incf i avail)
           (decf need avail))))))
+
+(defun %ioblock-encoded-character-read-vector (ioblock vector start end)
+  (declare (fixnum start end))
+  (do* ((i start (1+ i))
+        (rcf (ioblock-read-char-when-locked-function ioblock)))
+       ((= i end) end)
+    (declare (fixnum i need))
+    (let* ((ch (funcall rcf ioblock)))
+      (if (eq ch :eof)
+        (return i))
+      (setf (schar vector i) ch))))
+
 
 (defun %ioblock-binary-read-vector (ioblock vector start end)
@@ -1721 +1839 @@
     (if encoding
       (let* ((unit-size (character-encoding-code-unit-size encoding)))
+        (setf (ioblock-peek-char-function ioblock) '%encoded-ioblock-peek-char)
+        (setf (ioblock-read-line-function ioblock)
+              '%ioblock-encoded-read-line)
+        (setf (ioblock-character-read-vector-function ioblock)
+              '%ioblock-encoded-character-read-vector)        
         (setf (ioblock-decode-input-function ioblock)
               (character-encoding-stream-decode-function encoding))
@@ -1733 +1856 @@
                    (t '%ioblock-read-u8-encoded-char))))))
       (progn
+        (setf (ioblock-peek-char-function ioblock) '%ioblock-peek-char)
         (setf (ioblock-read-char-function ioblock)
               (case sharing
@@ -1836 +1960 @@
                  (case sharing
                    (:private '%private-ioblock-write-u8-encoded-char)
-                   (:lock '%locked-ioblock-write-u8-encoded-charchar)
+                   (:lock '%locked-ioblock-write-u8-encoded-char)
                    (t '%ioblock-write-u8-encoded-char)))))
         (setf (ioblock-write-simple-string-function ioblock)
@@ -1957 +2081 @@
                             character-p
                             encoding
+                            line-termination
                             &allow-other-keys)
   (declare (ignorable element-shift))
@@ -1978 +2103 @@
       (setf (ioblock-owner ioblock) *current-process*))
     (setf (ioblock-encoding ioblock) encoding)
+    (setf (ioblock-line-termination ioblock) line-termination)
     (setf (ioblock-literal-char-code-limit ioblock)
           (if encoding
@@ -2089 +2215 @@
                                            (subtypep element-type 'character)))
                           (basic nil)
-                          encoding)
+                          encoding
+                          line-termination)
   (when basic
     (setq class (map-to-basic-stream-class-name class))
@@ -2115 +2242 @@
                          :sharing sharing
                          :character-p character-p
-                         :encoding encoding)))
+                         :encoding encoding
+                         :line-termination line-termination)))
   
 ;;;  Fundamental streams.
@@ -2248 +2376 @@
   (generic-stream-write-string stream string start end))
 
-(defmethod stream-write-list ((stream fundamental-character-output-stream)
-                              list count)
-  (declare (fixnum count))
-  (dotimes (i count)
-    (stream-write-char stream (pop list))))
-
-(defmethod stream-read-list ((stream fundamental-character-input-stream)
-                             list count)
-  (generic-character-read-list stream list count))
-
-(defmethod stream-write-list ((stream fundamental-binary-output-stream)
-                              list count)
-  (declare (fixnum count))
-  (dotimes (i count)
-    (stream-write-byte stream (pop list))))
-
-(defmethod stream-read-list ((stream fundamental-binary-input-stream)
-                             list count)
-  (declare (fixnum count))
-  (do* ((tail list (cdr tail))
-        (i 0 (1+ i)))
-       ((= i count) count)
-    (declare (fixnum i))
-    (let* ((b (stream-read-byte stream)))
-      (if (eq b :eof)
-        (return i)
-        (rplaca tail b)))))
 
 ;;; The read-/write-vector methods could be specialized for stream classes
@@ -2423 +2524 @@
   (declare (dynamic-extent args))
   (apply #'make-ioblock :stream stream args))
+
+
+(defmethod stream-write-list ((stream fundamental-character-output-stream)
+                              list count)
+  (declare (fixnum count))
+  (dotimes (i count)
+    (stream-write-char stream (pop list))))
+
+(defmethod stream-write-list ((stream basic-character-output-stream)
+                              list count)
+  (declare (fixnum count))
+  (dotimes (i count)
+    (stream-write-char stream (pop list))))
+
+(defmethod stream-read-list ((stream fundamental-character-input-stream)
+                             list count)
+  (generic-character-read-list stream list count))
+
+(defmethod stream-read-list ((stream basic-character-input-stream)
+                             list count)
+  (generic-character-read-list stream list count))
+
+(defmethod stream-write-list ((stream fundamental-binary-output-stream)
+                              list count)
+  (declare (fixnum count))
+  (dotimes (i count)
+    (stream-write-byte stream (pop list))))
+
+(defmethod stream-write-list ((stream basic-binary-output-stream)
+                              list count)
+  (declare (fixnum count))
+  (dotimes (i count)
+    (write-byte (pop list) stream)))
+
+(defmethod stream-read-list ((stream fundamental-binary-input-stream)
+                             list count)
+  (declare (fixnum count))
+  (do* ((tail list (cdr tail))
+        (i 0 (1+ i)))
+       ((= i count) count)
+    (declare (fixnum i))
+    (let* ((b (stream-read-byte stream)))
+      (if (eq b :eof)
+        (return i)
+        (rplaca tail b)))))
+
+(defmethod stream-read-list ((stream basic-binary-input-stream)
+                             list count)
+  (declare (fixnum count))
+  (do* ((tail list (cdr tail))
+        (i 0 (1+ i)))
+       ((= i count) count)
+    (declare (fixnum i))
+    (let* ((b (read-byte stream)))
+      (if (eq b :eof)
+        (return i)
+        (rplaca tail b)))))
 
 (defmethod stream-read-vector ((stream basic-character-input-stream)
@@ -3459 +3617 @@
     (%ioblock-binary-in-ivect ioblock iv start nb)))
 
+
 (defmethod stream-write-vector ((stream buffered-character-output-stream-mixin)
                                 vector start end)
@@ -3467 +3626 @@
       (let* ((total (- end start)))
         (declare (fixnum total))
-        (%ioblock-out-ivect ioblock vector start total)
-        (let* ((last-newline (position #\newline vector
-                                       :start start
-                                       :end end
-                                       :from-end t)))
-          (if last-newline
-            (setf (ioblock-charpos ioblock)
-                  (- end last-newline 1))
-            (incf (ioblock-charpos ioblock) total)))))))
+        (funcall (ioblock-write-simple-string-function ioblock)
+                 ioblock vector start total)))))
+
+(defmethod stream-write-vector ((stream basic-character-output-stream)
+                                vector start end)
+  (declare (fixnum start end))
+  (if (not (typep vector 'simple-base-string))
+    (call-next-method)
+    (let* ((ioblock (basic-stream-ioblock stream))
+           (total (- end start)))
+      (declare (fixnum total))
+      (with-ioblock-output-locked (ioblock)
+                (funcall (ioblock-write-simple-string-function ioblock)
+                 ioblock vector start total)))))
 
 (defmethod stream-write-vector ((stream buffered-binary-output-stream-mixin)
@@ -4139 +4303 @@
     (stream-line-column stream)))        
 
-
+