Changeset 5520

Timestamp:

Nov 8, 2006, 4:15:05 AM (18 years ago)

Author:

Gary Byers

Message:

Some bivalent/binary fixes.

TODO: get rid of "bivalent" streams, but allow switching some streams (sockets)
between "character mode" and "binary mode".

File:

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

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

@@ -3585 +3585 @@
   (declare (fixnum count))
   (dotimes (i count)
-    (stream-write-byte stream (pop list))))
+    (let* ((element (pop list)))
+      (if (typep element 'character)
+        (write-char element stream)
+        (write-byte element stream)))))
 
 (defmethod stream-write-list ((stream basic-binary-output-stream)
@@ -3591 +3594 @@
   (declare (fixnum count))
   (dotimes (i count)
-    (write-byte (pop list) stream)))
+    (let* ((element (pop list)))
+      (if (typep element 'character)
+        (write-char element stream)
+        (write-byte element stream)))))
 
 (defmethod stream-read-list ((stream fundamental-binary-input-stream)
@@ -4917 +4923 @@
                      ioblock vector start total))))))
 
+;;; bivalence: we don't actually have a "bivalent stream" class;
+;;; all actual (potentially) bivalent streams (sockets) include binary streams
+;;; before character streams in their CPLs.  That effectively means that
+;;; binary-stream methods for reading and writing sequences have to
+;;; handle character I/O in some cases.  That may slow some things down
+;;; (at least in theory), but the case where the stream's element-type
+;;; matches the sequence's element-type isn't affected.
+(defun %ioblock-binary-stream-write-vector (ioblock vector start end)
+  (declare (fixnum start end))
+  (let* ((out (ioblock-outbuf ioblock))
+         (buf (io-buffer-buffer out))
+         (written 0)
+         (limit (io-buffer-limit out))
+         (total (- end start))
+         (buftype (typecode buf)))
+    (declare (fixnum buftype written total limit))
+    (if (not (= (the fixnum (typecode vector)) buftype))
+      (if (typep vector 'string)
+        (funcall (ioblock-write-simple-string-function ioblock)
+                 ioblock
+                 vector
+                 start
+                 (- end start))
+        (do* ((i start (1+ i))
+              (wbf (ioblock-write-byte-when-locked-function ioblock))
+              (wcf (ioblock-write-char-when-locked-function ioblock)))
+             ((= i end))
+          (let ((byte (uvref vector i)))
+            (if (characterp byte)
+              (funcall wcf ioblock byte)
+              (funcall wbf ioblock byte)))))
+      (do* ((pos start (+ pos written))
+            (left total (- left written)))
+           ((= left 0))
+        (declare (fixnum pos left))
+        (setf (ioblock-dirty ioblock) t)
+        (let* ((index (io-buffer-idx out))
+               (count (io-buffer-count out))
+               (avail (- limit index)))
+          (declare (fixnum index avail count))
+          (cond
+            ((= (setq written avail) 0)
+             (%ioblock-force-output ioblock nil))
+            (t
+             (if (> written left)
+               (setq written left))
+             (%copy-ivector-to-ivector
+              vector
+              (ioblock-elements-to-octets ioblock pos)
+              buf
+              (ioblock-elements-to-octets ioblock index)
+              (ioblock-elements-to-octets ioblock written))
+             (setf (ioblock-dirty ioblock) t)
+             (incf index written)
+             (if (> index count)
+               (setf (io-buffer-count out) index))
+             (setf (io-buffer-idx out) index)
+             (if (= index  limit)
+               (%ioblock-force-output ioblock nil)))))))))
+
 (defmethod stream-write-vector ((stream buffered-binary-output-stream-mixin)
                                 vector start end)
-  (declare (fixnum start end))
   (with-stream-ioblock-output (ioblock stream :speedy t)
-    (let* ((out (ioblock-outbuf ioblock))
-           (buf (io-buffer-buffer out))
-           (written 0)
-           (limit (io-buffer-limit out))
-           (total (- end start))
-           (buftype (typecode buf)))
-      (declare (fixnum buftype written total limit))
-      (if (not (= (the fixnum (typecode vector)) buftype))
-        (do* ((i start (1+ i))
-              (wbf (ioblock-write-byte-function ioblock)))
-             ((= i end))
-          (let ((byte (uvref vector i)))
-            (funcall wbf ioblock byte)))
-        (do* ((pos start (+ pos written))
-              (left total (- left written)))
-             ((= left 0))
-          (declare (fixnum pos left))
-          (setf (ioblock-dirty ioblock) t)
-          (let* ((index (io-buffer-idx out))
-                 (count (io-buffer-count out))
-                 (avail (- limit index)))
-            (declare (fixnum index avail count))
-            (cond
-              ((= (setq written avail) 0)
-               (%ioblock-force-output ioblock nil))
-              (t
-               (if (> written left)
-                 (setq written left))
-               (%copy-ivector-to-ivector
-                vector
-                (ioblock-elements-to-octets ioblock pos)
-                buf
-                (ioblock-elements-to-octets ioblock index)
-                (ioblock-elements-to-octets ioblock written))
-               (setf (ioblock-dirty ioblock) t)
-               (incf index written)
-               (if (> index count)
-                 (setf (io-buffer-count out) index))
-               (setf (io-buffer-idx out) index)
-               (if (= index  limit)
-                 (%ioblock-force-output ioblock nil))))))))))
+    (%ioblock-binary-stream-write-vector ioblock vector start end)))
+
 
 (defmethod stream-write-vector ((stream basic-binary-output-stream)
@@ -4968 +4994 @@
   (let* ((ioblock (basic-stream-ioblock stream)))
     (with-ioblock-output-locked (ioblock)
-      (let* ((out (ioblock-outbuf ioblock))
-             (buf (io-buffer-buffer out))
-             (written 0)
-             (limit (io-buffer-limit out))
-             (total (- end start))
-             (buftype (typecode buf)))
-        (declare (fixnum buftype written total limit))
-        (if (not (= (the fixnum (typecode vector)) buftype))
-          (do* ((i start (1+ i))
-                (wbf (ioblock-write-byte-function ioblock)))
-               ((= i end))
-            (let ((byte (uvref vector i)))
-              (when (characterp byte)
-                (setq byte (char-code byte)))
-              (funcall wbf ioblock byte)))
-          (do* ((pos start (+ pos written))
-                (left total (- left written)))
-               ((= left 0))
-            (declare (fixnum pos left))
-            (setf (ioblock-dirty ioblock) t)
-            (let* ((index (io-buffer-idx out))
-                   (count (io-buffer-count out))
-                   (avail (- limit index)))
-              (declare (fixnum index avail count))
-              (cond
-                ((= (setq written avail) 0)
-                 (%ioblock-force-output ioblock nil))
-                (t
-                 (if (> written left)
-                   (setq written left))
-                 (%copy-ivector-to-ivector
-                  vector
-                  (ioblock-elements-to-octets ioblock pos)
-                  buf
-                  (ioblock-elements-to-octets ioblock index)
-                  (ioblock-elements-to-octets ioblock written))
-                 (setf (ioblock-dirty ioblock) t)
-                 (incf index written)
-                 (if (> index count)
-                   (setf (io-buffer-count out) index))
-                 (setf (io-buffer-idx out) index)
-                 (if (= index  limit)
-                   (%ioblock-force-output ioblock nil)))))))))))
+      (%ioblock-binary-stream-write-vector ioblock vector start end))))