Index: /branches/working-0711/ccl/level-1/l1-streams.lisp
===================================================================
--- /branches/working-0711/ccl/level-1/l1-streams.lisp	(revision 13509)
+++ /branches/working-0711/ccl/level-1/l1-streams.lisp	(revision 13510)
@@ -1415,8 +1415,6 @@
     (error "Can't write vector to stream ~s" (ioblock-stream ioblock)))
   (let* ((written 0)
-	 (out (ioblock-outbuf ioblock))
-	 (bufsize (io-buffer-size out))
-	 (buffer (io-buffer-buffer out)))
-    (declare (fixnum written bufsize))
+	 (out (ioblock-outbuf ioblock)))
+    (declare (fixnum written))
     (do* ((pos start-octet (+ pos written))
 	  (left num-octets (- left written)))
@@ -1426,6 +1424,8 @@
       (let* ((index (io-buffer-idx out))
 	     (count (io-buffer-count out))
-	     (avail (- bufsize index)))
-	(declare (fixnum index avail count))
+	     (bufsize (io-buffer-size out))
+             (avail (- bufsize index))
+             (buffer (io-buffer-buffer out)))
+	(declare (fixnum index avail count bufsize))
 	(cond
 	  ((= (setq written avail) 0)
@@ -1448,9 +1448,6 @@
   (let* ((written 0)
 	 (col (ioblock-charpos ioblock))
-	 (out (ioblock-outbuf ioblock))
-	 (bufsize (io-buffer-size out))
-	 (buffer (io-buffer-buffer out)))
-    (declare (fixnum written bufsize col)
-	     (type (simple-array (unsigned-byte 8) (*)) buffer)
+	 (out (ioblock-outbuf ioblock)))
+    (declare (fixnum written col)
 	     (optimize (speed 3) (safety 0)))
     (do* ((pos start-char (+ pos written))
@@ -1461,6 +1458,9 @@
       (let* ((index (io-buffer-idx out))
 	     (count (io-buffer-count out))
+             (bufsize (io-buffer-size out))
+             (buffer (io-buffer-buffer out))
 	     (avail (- bufsize index)))
-	(declare (fixnum index avail count))
+	(declare (fixnum index bufsize avail count)
+                 (type (simple-array (unsigned-byte 8) (*)) buffer))
 	(cond
 	  ((= (setq written avail) 0)
@@ -1509,7 +1509,8 @@
 		 ioblock))))
 
-(declaim (inline %ioblock-write-element))
-
-(defun %ioblock-write-element (ioblock element)
+
+
+(declaim (inline %ioblock-write-u8-element))
+(defun %ioblock-write-u8-element (ioblock element)
   (declare (optimize (speed 3) (safety 0)))
   (let* ((buf (ioblock-outbuf ioblock))
@@ -1520,6 +1521,6 @@
     (when (= idx limit)
       (%ioblock-force-output ioblock nil)
-      (setq idx 0 count 0))
-    (setf (aref (io-buffer-buffer buf) idx) element)
+      (setq idx (io-buffer-idx buf) count (io-buffer-count buf)))
+    (setf (aref (the (simple-array (unsigned-byte 8) (*)) (io-buffer-buffer buf)) idx) element)
     (incf idx)
     (setf (io-buffer-idx buf) idx)
@@ -1529,6 +1530,6 @@
     element))
 
-(declaim (inline %ioblock-write-u8-element))
-(defun %ioblock-write-u8-element (ioblock element)
+(declaim (inline %ioblock-write-s8-element))
+(defun %ioblock-write-s8-element (ioblock element)
   (declare (optimize (speed 3) (safety 0)))
   (let* ((buf (ioblock-outbuf ioblock))
@@ -1539,6 +1540,6 @@
     (when (= idx limit)
       (%ioblock-force-output ioblock nil)
-      (setq idx 0 count 0))
-    (setf (aref (the (simple-array (unsigned-byte 8) (*)) (io-buffer-buffer buf)) idx) element)
+      (setq idx (io-buffer-idx buf) count (io-buffer-count buf)))
+    (setf (aref (the (simple-array (signed-byte 8) (*)) (io-buffer-buffer buf)) idx) element)
     (incf idx)
     (setf (io-buffer-idx buf) idx)
@@ -1548,6 +1549,6 @@
     element))
 
-(declaim (inline %ioblock-write-s8-element))
-(defun %ioblock-write-s8-element (ioblock element)
+(declaim (inline %ioblock-write-u16-element))
+(defun %ioblock-write-u16-element (ioblock element)
   (declare (optimize (speed 3) (safety 0)))
   (let* ((buf (ioblock-outbuf ioblock))
@@ -1558,24 +1559,5 @@
     (when (= idx limit)
       (%ioblock-force-output ioblock nil)
-      (setq idx 0 count 0))
-    (setf (aref (the (simple-array (signed-byte 8) (*)) (io-buffer-buffer buf)) idx) element)
-    (incf idx)
-    (setf (io-buffer-idx buf) idx)
-    (when (> idx count)
-      (setf (io-buffer-count buf) idx))
-    (setf (ioblock-dirty ioblock) t)
-    element))
-
-(declaim (inline %ioblock-write-u16-element))
-(defun %ioblock-write-u16-element (ioblock element)
-  (declare (optimize (speed 3) (safety 0)))
-  (let* ((buf (ioblock-outbuf ioblock))
-         (idx (io-buffer-idx buf))
-	 (count (io-buffer-count buf))
-         (limit (io-buffer-limit buf)))
-    (declare (fixnum idx limit count))
-    (when (= idx limit)
-      (%ioblock-force-output ioblock nil)
-      (setq idx 0 count 0))
+      (setq idx (io-buffer-idx buf) count (io-buffer-count buf)))
     (setf (aref (the (simple-array (unsigned-byte 16) (*)) (io-buffer-buffer buf)) idx) element)
     (incf idx)
@@ -1605,5 +1587,5 @@
     (when (= idx limit)
       (%ioblock-force-output ioblock nil)
-      (setq idx 0 count 0))
+      (setq idx (io-buffer-idx buf) count (io-buffer-count buf)))
     (setf (aref vector idx) b0)
     (incf idx)
@@ -1612,5 +1594,5 @@
         (setf (io-buffer-count buf) idx))
       (%ioblock-force-output ioblock nil)
-      (setq idx 0 count 0))
+      (setq idx (io-buffer-idx buf) count (io-buffer-count buf)))
     (setf (aref vector idx) b1)
     (incf idx)
@@ -1639,5 +1621,8 @@
     (when (= idx limit)
       (%ioblock-force-output ioblock nil)
-      (setq idx 0 count 0))
+      (setq idx (io-buffer-idx buf)
+            count (io-buffer-count buf)
+            vector (io-buffer-buffer buf)
+            limit (io-buffer-limit buf)))
     (setf (aref vector idx) b1)
     (incf idx)
@@ -1646,5 +1631,8 @@
         (setf (io-buffer-count buf) idx))
       (%ioblock-force-output ioblock nil)
-      (setq idx 0 count 0))
+      (setq idx (io-buffer-idx buf)
+            count (io-buffer-count buf)
+            vector (io-buffer-buffer buf)
+            limit (io-buffer-limit buf)))
     (setf (aref vector idx) b0)
     (incf idx)
@@ -1677,5 +1665,8 @@
     (when (= idx limit)
       (%ioblock-force-output ioblock nil)
-      (setq idx 0 count 0))
+      (setq idx (io-buffer-idx buf)
+            count (io-buffer-count buf)
+            vector (io-buffer-buffer buf)
+            limit (io-buffer-limit buf)))
     (setf (aref vector idx) b0)
     (incf idx)
@@ -1684,5 +1675,8 @@
         (setf (io-buffer-count buf) idx))
       (%ioblock-force-output ioblock nil)
-      (setq idx 0 count 0))
+      (setq idx (io-buffer-idx buf)
+            count (io-buffer-count buf)
+            vector (io-buffer-buffer buf)
+            limit (io-buffer-limit buf)))
     (setf (aref vector idx) b1)
     (incf idx)
@@ -1691,5 +1685,8 @@
         (setf (io-buffer-count buf) idx))
       (%ioblock-force-output ioblock nil)
-      (setq idx 0 count 0))
+      (setq idx (io-buffer-idx buf)
+            count (io-buffer-count buf)
+            vector (io-buffer-buffer buf)
+            limit (io-buffer-limit buf)))
     (setf (aref vector idx) b2)
     (incf idx)
@@ -1698,5 +1695,8 @@
         (setf (io-buffer-count buf) idx))
       (%ioblock-force-output ioblock nil)
-      (setq idx 0 count 0))
+      (setq idx (io-buffer-idx buf)
+            count (io-buffer-count buf)
+            vector (io-buffer-buffer buf)
+            limit (io-buffer-limit buf)))
     (setf (aref vector idx) b3)
     (incf idx)
@@ -1729,5 +1729,8 @@
     (when (= idx limit)
       (%ioblock-force-output ioblock nil)
-      (setq idx 0 count 0))
+      (setq idx (io-buffer-idx buf)
+            count (io-buffer-count buf)
+            vector (io-buffer-buffer buf)
+            limit (io-buffer-limit buf)))
     (setf (aref vector idx) b0)
     (incf idx)
@@ -1736,5 +1739,5 @@
         (setf (io-buffer-count buf) idx))
       (%ioblock-force-output ioblock nil)
-      (setq idx 0 count 0))
+      (setq idx (io-buffer-idx buf) count (io-buffer-count buf)))
     (setf (aref vector idx) b1)
     (incf idx)
@@ -1743,5 +1746,8 @@
         (setf (io-buffer-count buf) idx))
       (%ioblock-force-output ioblock nil)
-      (setq idx 0 count 0))
+      (setq idx (io-buffer-idx buf)
+            count (io-buffer-count buf)
+            vector (io-buffer-buffer buf)
+            limit (io-buffer-limit buf)))
     (setf (aref vector idx) b2)
     (incf idx)
@@ -1750,5 +1756,8 @@
         (setf (io-buffer-count buf) idx))
       (%ioblock-force-output ioblock nil)
-      (setq idx 0 count 0))
+      (setq idx (io-buffer-idx buf)
+            count (io-buffer-count buf)
+            vector (io-buffer-buffer buf)
+            limit (io-buffer-limit buf)))
     (setf (aref vector idx) b3)
     (incf idx)
@@ -1769,5 +1778,6 @@
     (when (= idx limit)
       (%ioblock-force-output ioblock nil)
-      (setq idx 0 count 0))
+      (setq idx (io-buffer-idx buf)
+            count (io-buffer-count buf)))
     (setf (aref (the (simple-array (signed-byte 16) (*)) (io-buffer-buffer buf)) idx) element)
     (incf idx)
@@ -1788,5 +1798,6 @@
     (when (= idx limit)
       (%ioblock-force-output ioblock nil)
-      (setq idx 0 count 0))
+      (setq idx (io-buffer-idx buf)
+            count (io-buffer-count buf)))
     (setf (aref (the (simple-array (unsigned-byte 32) (*)) (io-buffer-buffer buf)) idx) element)
     (incf idx)
@@ -1807,5 +1818,6 @@
     (when (= idx limit)
       (%ioblock-force-output ioblock nil)
-      (setq idx 0 count 0))
+      (setq idx (io-buffer-idx buf)
+            count (io-buffer-count buf)))
     (setf (aref (the (simple-array (unsigned-byte 32) (*)) (io-buffer-buffer buf)) idx)
           (%swap-u32 element))
@@ -1827,5 +1839,5 @@
     (when (= idx limit)
       (%ioblock-force-output ioblock nil)
-      (setq idx 0 count 0))
+      (setq idx (io-buffer-idx buf) count (io-buffer-count buf)))
     (setf (aref (the (simple-array (signed-byte 32) (*)) (io-buffer-buffer buf)) idx) element)
     (incf idx)
@@ -1848,5 +1860,5 @@
     (when (= idx limit)
       (%ioblock-force-output ioblock nil)
-      (setq idx 0 count 0))
+      (setq idx (io-buffer-idx buf) count (io-buffer-count buf)))
     (setf (aref (the (simple-array (unsigned-byte 64) (*)) (io-buffer-buffer buf)) idx) element)
     (incf idx)
@@ -1867,5 +1879,5 @@
     (when (= idx limit)
       (%ioblock-force-output ioblock nil)
-      (setq idx 0 count 0))
+      (setq idx (io-buffer-idx buf) count (io-buffer-count buf)))
     (setf (aref (the (simple-array (signed-byte 64) (*)) (io-buffer-buffer buf)) idx) element)
     (incf idx)
@@ -3128,7 +3140,9 @@
             (setf (ioblock-inbuf-lock ioblock) (make-lock)))
           (setf (ioblock-line-termination ioblock) line-termination)
-          (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))))
           )))
+    (when (ioblock-inbuf ioblock)
+      (setup-ioblock-input ioblock character-p element-type sharing encoding line-termination))      
     (if share-buffers-p
       (if insize
@@ -3155,5 +3169,5 @@
             (setf (ioblock-element-shift ioblock) (max 0 (ceiling (log (/ out-size-in-octets outsize) 2))))
             ))))
-    (when (or share-buffers-p outsize)
+    (when (ioblock-outbuf ioblock)
       (setup-ioblock-output ioblock character-p element-type sharing encoding line-termination))
     (when element-type
@@ -6084,3 +6098,432 @@
   '%ioblock-untyi)
 
+
+
+
+
+(defparameter *vector-output-stream-default-initial-allocation* 64 "Default size of the vector created by (MAKE-VECTOR-OUTPUT-STREAM), in octets.")
+
+;;; Bivalent vector streams.
+(make-built-in-class 'vector-stream 'basic-binary-stream 'basic-character-stream)
+
+(defmethod print-object ((s vector-stream) out)
+  (print-unreadable-object (s out :type t :identity t)
+    (unless (open-stream-p s)  (format out " ~s" :closed))))
+
+
+(defstruct (vector-stream-ioblock (:include ioblock))
+  (displacement 0)                      ;displaced-index-offset
+  )
+
+(defstruct (vector-output-stream-ioblock (:include vector-stream-ioblock))
+  (line-length 80)                      ;for pretty-printer 
+  displaced                             ;original vector if fill-pointer case
+ )
+
+(defstatic *vector-output-stream-class* (make-built-in-class 'vector-output-stream 'vector-stream 'basic-binary-output-stream 'basic-character-output-stream))
+(defstatic *vector-output-stream-class-wrapper* (%class-own-wrapper *vector-output-stream-class*))
+(defstatic *vector-input-stream-class* (make-built-in-class 'vector-input-stream 'vector-stream 'basic-binary-input-stream 'basic-character-input-stream))
+(defstatic *vector-input-stream-class-wrapper* (%class-own-wrapper *vector-input-stream-class*))
+
+(defmethod initialize-basic-stream :after ((s vector-stream) &key ioblock &allow-other-keys)
+  (setf (basic-stream.state s) ioblock))
+
+(defmethod stream-force-output ((s vector-output-stream)))
+
+(defmethod stream-finish-output ((s vector-output-stream)))
+
+
+
+(defun %extend-vector-output-stream (s ioblock count finish-p)
+  (declare (ignore s count finish-p))
+  (check-ioblock-owner ioblock)
+  (let* ((displaced (vector-output-stream-ioblock-displaced ioblock))
+         (outbuf (ioblock-outbuf ioblock)))
+    (cond (displaced
+           (let* ((flags (%svref displaced target::arrayH.flags-cell)))
+             (declare (fixnum flags))
+             (unless (logbitp $arh_adjp_bit flags)
+               (%err-disp $XMALADJUST displaced))
+             (let* ((len (%svref displaced target::vectorH.physsize-cell))
+                    (newlen (max (the fixnum (+ len len)) (+ len *vector-output-stream-default-initial-allocation*)))
+                    (new (%alloc-misc newlen target::subtag-u8-vector)))
+               (declare (fixnum len newlen)
+                        ((simple-array (unsigned-byte 8) (*)) new))
+               (multiple-value-bind (data offset)
+                   (%array-header-data-and-offset displaced)
+                 (declare ((simple-array (unsigned-byte 8) (*)) data)
+                          (fixnum offset))
+                 (%copy-ivector-to-ivector new 0 data offset len)
+                 (setf (vector-output-stream-ioblock-displacement ioblock) 0)
+                 (unless (= 0 offset)
+                   (setf (io-buffer-idx outbuf) len
+                         (io-buffer-count outbuf) len))
+                 (setf (io-buffer-limit outbuf) newlen
+                       (io-buffer-size outbuf) newlen
+                       (io-buffer-buffer outbuf) new)
+                 ;; Adjust the displaced vector.
+                 (setf (%svref displaced target::vectorH.data-vector-cell) new
+                       (%svref displaced target::vectorH.displacement-cell) 0
+                       (%svref displaced target::vectorH.physsize-cell) newlen
+                       (%svref displaced target::vectorH.flags-cell) (bitclr $arh_exp_disp_bit flags)
+                       (%svref displaced target::vectorH.logsize-cell) len)))))
+          (t
+           ;; Simpler. Honest.
+           (let* ((old (io-buffer-buffer outbuf))
+                  (len (length old))
+                  (newlen (max (the fixnum (+ len len)) 16))
+                  (new (%alloc-misc newlen target::subtag-u8-vector)))
+             (declare (fixnum len newlen)
+                      ((simple-array (unsigned-byte 8) (*)) old new))
+             (%copy-ivector-to-ivector new 0 old 0 len)
+             (setf (io-buffer-buffer outbuf) new
+                   (io-buffer-size outbuf) newlen
+                   (io-buffer-limit outbuf) newlen))))))
+
+(defun %vector-output-stream-close (s ioblock)
+  (declare (ignore s))
+  ;; If there's a displaced vector, fix its fill pointer.
+  (let* ((displaced (vector-output-stream-ioblock-displaced ioblock)))
+    (when displaced
+      (setf (%svref displaced target::vectorH.logsize-cell)
+            (the fixnum (- (the fixnum (io-buffer-count (ioblock-outbuf ioblock)))
+                           (the fixnum (vector-output-stream-ioblock-displacement ioblock))))))))
+
+(defmethod stream-line-length ((s vector-output-stream))
+  (let* ((ioblock (basic-stream-ioblock s)))
+    (string-output-stream-ioblock-line-length ioblock)))
+
+(defmethod (setf stream-line-length) (newlen (s vector-output-stream))
+  (let* ((ioblock (basic-stream-ioblock s)))
+    (setf (vector-output-stream-ioblock-line-length ioblock) newlen)))
+
+(defun get-output-stream-vector (s)
+  (unless (and (typep s 'basic-stream)
+               (eq *vector-output-stream-class-wrapper*
+                   (basic-stream.wrapper s)))
+    (report-bad-arg s 'vector-output-stream))
+  (let* ((ioblock (basic-stream-ioblock s))
+         (outbuf (progn
+                   (check-ioblock-owner ioblock)
+                   (ioblock-outbuf ioblock)))
+         (v (io-buffer-buffer outbuf))
+         (offset (vector-output-stream-ioblock-displacement ioblock))
+         (len (the fixnum (- (the fixnum (io-buffer-count outbuf)) offset)))
+         (new (%alloc-misc len target::subtag-u8-vector)))
+    (declare (fixnum offset len))
+    (%copy-ivector-to-ivector v offset new 0 len)
+    (setf (io-buffer-idx outbuf) offset
+          (io-buffer-count outbuf) offset)
+    new))
+
+
+(defun unsigned-integer-to-binary (value len s)
+  (declare (fixnum len))
+  (unless (and (typep s 'basic-stream)
+               (eq *vector-output-stream-class-wrapper*
+                   (basic-stream.wrapper s)))
+    (report-bad-arg s 'vector-input-stream))
+  (let* ((ioblock (basic-stream-ioblock s))
+         (outbuf (progn
+                   (check-ioblock-owner ioblock)
+                   (ioblock-outbuf ioblock)))
+         (idx (io-buffer-idx outbuf))
+         (limit (io-buffer-limit outbuf))
+         (buffer (io-buffer-buffer outbuf)))
+    (declare (fixnum idx limit)
+             ((simple-array (unsigned-byte 8) (*)) buffer)
+             (optimize (speed 3) (safety 0)))
+    (etypecase value
+      (fixnum
+       (if (< (the fixnum value) 0)
+         (report-bad-arg value 'unsigned-byte))
+       (do* ((shift (ash (the fixnum (1- len)) 3) (- shift 8)))
+            ((< shift 0) (progn
+                           (setf (io-buffer-idx outbuf) idx)
+                           (if (> idx (the fixnum (io-buffer-count outbuf)))
+                             (setf (io-buffer-count outbuf) idx))
+                           value))
+         (declare (fixnum shift))
+         (when (= idx limit)
+           (%ioblock-force-output ioblock nil)
+           (setq limit (io-buffer-limit outbuf)
+                 buffer (io-buffer-buffer outbuf)))
+         (setf (aref buffer idx) (logand #xff (the fixnum (%iasr shift value))))
+         (incf idx)))
+      (bignum
+       (locally
+           (declare ((simple-array (unsigned-byte 8) (*)) value))
+         (let* ((nbytes (ash (uvsize value) 2))
+                (sign-byte (if (logbitp 7 (the (unsigned-byte 8) (aref value (the fixnum (- nbytes #+big-endian-target 4 #+little-endian-target 1))))) #xff #x00)))
+           (declare (fixnum nbytes)
+                    ((unsigned-byte 8) sign-byte))
+           (unless (zerop sign-byte)
+             (report-bad-arg value 'unsigned-byte))
+           (do* ((n (1- len) (1- n)))
+                ((< n 0) (progn
+                           (setf (io-buffer-idx outbuf) idx)
+                           (if (> idx (the fixnum (io-buffer-count outbuf)))
+                             (setf (io-buffer-count outbuf) idx))
+                           value))
+             (declare (fixnum n))
+             (when (= idx limit)
+               (%ioblock-force-output ioblock nil)
+               (setq limit (io-buffer-limit outbuf)
+                     buffer (io-buffer-buffer outbuf)))
+             (setf (aref buffer idx)
+                   (if (>= n nbytes)
+                     0
+                     (aref value #+little-endian-target n #+big-endian-target (the fixnum (logxor n 3)))))
+             (incf idx))))))))
+
+(defun signed-integer-to-binary (value len s)
+  (declare (fixnum len))
+  (unless (and (typep s 'basic-stream)
+               (eq *vector-output-stream-class-wrapper*
+                   (basic-stream.wrapper s)))
+    (report-bad-arg s 'vector-input-stream))
+  (let* ((ioblock (basic-stream-ioblock s))
+         (outbuf (progn
+                   (check-ioblock-owner ioblock)
+                   (ioblock-outbuf ioblock)))
+         (idx (io-buffer-idx outbuf))
+         (limit (io-buffer-limit outbuf))
+         (buffer (io-buffer-buffer outbuf)))
+    (declare (fixnum idx limit)
+             ((simple-array (unsigned-byte 8) (*)) buffer)
+             (optimize (speed 3) (safety 0)))
+    (do* ((newidx (+ idx len)))
+         ((< newidx limit))
+      (declare (fixnum newidx))
+      (%ioblock-force-output ioblock nil)
+      (setq limit (io-buffer-limit outbuf)
+            buffer (io-buffer-buffer outbuf)))
+    (etypecase value
+      (fixnum
+       (do* ((shift (ash (the fixnum (1- len)) 3) (- shift 8)))
+            ((< shift 0) (progn
+                           (setf (io-buffer-idx outbuf) idx)
+                           (if (> idx (the fixnum (io-buffer-count outbuf)))
+                             (setf (io-buffer-count outbuf) idx))
+                           value))
+         (declare (fixnum shift))
+         (setf (aref buffer idx) (logand #xff (the fixnum (%iasr shift value))))
+         (incf idx)))
+      (bignum
+       (locally
+           (declare ((simple-array (unsigned-byte 8) (*)) value))
+         (let* ((nbytes (ash (uvsize value) 2))
+                (sign-byte (if (logbitp 7 (the (unsigned-byte 8) (aref value (the fixnum (- nbytes #+big-endian-target 4 #+little-endian-target 1))))) #xff #x00)))
+           (declare (fixnum nbytes)
+                    ((unsigned-byte 8) sign-byte))
+           (do* ((n (1- len) (1- n)))
+                ((< n 0) (progn
+                           (setf (io-buffer-idx outbuf) idx)
+                           (if (> idx (the fixnum (io-buffer-count outbuf)))
+                             (setf (io-buffer-count outbuf) idx))
+                           value))
+             (declare (fixnum n))
+             (setf (aref buffer idx)
+                   (if (>= n nbytes)
+                     sign-byte
+                     (aref value #+little-endian-target n #+big-endian-target (the fixnum (logxor n 3)))))
+             (incf idx))))))))
+      
+             
+               
+
+         
+
+(defun %make-vector-output-stream (vector external-format)
+  (let* ((data nil)
+         (len nil)
+         (offset 0)
+         (start 0)
+         (displaced nil)
+         (external-format (normalize-external-format t external-format))
+         (encoding (external-format-character-encoding external-format))
+         (line-termination (external-format-line-termination external-format)))
+    (cond ((typep vector '(simple-array (unsigned-byte 8) (*)))
+           (setq data vector len (length vector)))
+          (t
+           (multiple-value-setq (data offset) (array-data-and-offset vector))
+           (unless (eql (typecode data) target::subtag-u8-vector)
+             (report-bad-arg vector '(vector (unsigned-byte 8))))
+           (unless (array-has-fill-pointer-p vector)
+             (error "~S must be a vector with a fill pointer." vector))
+           (setq start (+ (fill-pointer vector) offset)
+                 len (+ (array-total-size vector) offset)
+                 displaced vector)))
+    (make-ioblock-stream *vector-output-stream-class*
+                         :ioblock (make-vector-output-stream-ioblock
+                                   :outbuf (make-io-buffer :buffer data
+                                                           :idx start
+                                                           :count start
+                                                           :limit len
+                                                           :size len)
+                                   :displaced displaced
+                                   :displacement offset)
+                         :encoding encoding
+                         :character-p t
+                         :element-type '(unsigned-byte 8)
+                         :line-termination line-termination
+                         :force-output-function '%extend-vector-output-stream
+                         :close-function '%vector-output-stream-close)))
+
+    
+(defun make-vector-output-stream (&key (external-format :default))
+  (%make-vector-output-stream (make-array *vector-output-stream-default-initial-allocation* :element-type '(unsigned-byte 8))  external-format))
+
+(defmethod stream-position ((s vector-output-stream) &optional newpos)
+  (let* ((ioblock (basic-stream-ioblock s))
+         (outbuf (ioblock-outbuf ioblock))
+         (origin (vector-stream-ioblock-displacement ioblock)))
+    (declare (fixnum origin))
+    (if newpos
+      (if (and (typep newpos 'fixnum)
+               (> (the fixnum newpos) -1)
+               (< (the fixnum newpos) (the fixnum (+ origin (the fixnum (io-buffer-limit outbuf))))))
+        (let* ((scaled-new (+ origin (the fixnum newpos))))
+          (declare (fixnum scaled-new))
+          (setf (io-buffer-idx outbuf) scaled-new)
+          (if (> (the fixnum (io-buffer-count outbuf)) scaled-new)
+            (setf (io-buffer-count outbuf) scaled-new))
+          (let* ((displaced (vector-output-stream-ioblock-displaced ioblock)))
+            (when displaced
+              (setf (fill-pointer displaced) newpos)))
+          newpos)
+        (report-bad-arg newpos `(integer 0 `(,(- (the fixnum (io-buffer-limit outbuf)) origin)))))
+      (the fixnum (- (the fixnum (io-buffer-idx outbuf)) origin)))))
+
+(defun vector-input-stream-index (s)
+  (unless (and (typep s 'basic-stream)
+               (eq *vector-input-stream-class-wrapper*
+                   (basic-stream.wrapper s)))
+    (report-bad-arg s 'vector-input-stream))
+  (let* ((ioblock (basic-stream-ioblock s)))
+    (check-ioblock-owner ioblock)
+    (the fixnum (- (the fixnum (io-buffer-idx (ioblock-inbuf ioblock)))
+                   (the fixnum (vector-stream-ioblock-displacement ioblock))))))
+            
+
+(defun %vector-input-stream-untyi (ioblock char)
+  (check-ioblock-owner ioblock)
+  (let* ((inbuf (ioblock-inbuf ioblock))
+         (idx (io-buffer-idx inbuf))
+         (encoding (ioblock-encoding ioblock))
+         (noctets (if encoding
+                    (funcall (character-encoding-character-size-in-octets-function encoding) char)
+                    1))
+         (newidx (- idx noctets)))
+    (declare (fixnum idx noctets newidx))
+    (if (>= newidx (the fixnum (vector-stream-ioblock-displacement ioblock)))
+      (setf (io-buffer-idx inbuf) newidx)
+      (error "Invalid attempt to unread ~s on ~s." char (ioblock-stream ioblock)))))
+
+  
+
+(defmethod select-stream-untyi-function ((s vector-input-stream) (direction t))
+  '%vector-input-stream-untyi)
+
+
+
+
+(defun %make-vector-input-stream (vector start end external-format)
+  (setq end (check-sequence-bounds vector start end))
+  (let* ((data nil)
+         (offset 0)
+         (external-format (normalize-external-format t external-format))
+         (encoding (external-format-character-encoding external-format))
+         (line-termination (external-format-line-termination external-format)))
+
+      (cond ((typep vector '(simple-array (unsigned-byte 8) (*)))
+             (setq data vector                   offset start))
+            (t (multiple-value-setq (data offset) (array-data-and-offset vector))
+               (unless (typep data '(simple-array (unsigned-byte 8) (*)))
+                 (report-bad-arg vector '(vector (unsigned-byte 8))))
+               (incf start offset)
+               (incf end offset)))
+      (make-ioblock-stream *vector-input-stream-class*
+                           :ioblock (make-vector-stream-ioblock
+                                     :inbuf (make-io-buffer
+                                             :buffer data
+                                             :idx start
+                                             :count end
+                                             :limit end
+                                             :size end)
+                                     :displacement start)
+                           :direction :input
+                           :character-p t
+                           :element-type '(unsigned-byte 8)
+                           :encoding encoding
+                           :line-termination line-termination
+                           :listen-function 'false
+                           :eofp-function 'true
+                           :advance-function 'false
+                           :close-function 'false)))
+      
+(defun make-vector-input-stream (vector &key (start 0) end external-format)
+  (%make-vector-input-stream vector start end external-format))
+
+
+
+
+(defun pui-stream (s count)
+  (declare (fixnum count))
+  (unless (and (typep s 'basic-stream)
+               (eq *vector-input-stream-class-wrapper*
+                   (basic-stream.wrapper s)))
+    (report-bad-arg s 'vector-input-stream))
+  (let* ((ioblock (basic-stream-ioblock s))
+         (inbuf (progn
+                  (check-ioblock-owner ioblock)
+                  (ioblock-inbuf ioblock)))
+         (idx (io-buffer-idx inbuf))
+         (end (+ idx count))
+         (limit (io-buffer-limit inbuf))
+         (vector (io-buffer-buffer inbuf)))
+    (declare (fixnum idx limit end)
+             ((simple-array (unsigned-byte 8) (*)) vector))
+    (if (< limit end)
+      (error "Integer decoding error"))
+    (let* ((result (%parse-unsigned-integer vector idx end)))
+      (setf (io-buffer-idx inbuf) end)
+      result)))
+
+(defun psi-stream (s count)
+  (declare (fixnum count))
+  (unless (and (typep s 'basic-stream)
+               (eq *vector-input-stream-class-wrapper*
+                   (basic-stream.wrapper s)))
+    (report-bad-arg s 'vector-input-stream))
+  (let* ((ioblock (basic-stream-ioblock s))
+         (inbuf (progn
+                  (check-ioblock-owner ioblock)
+                  (ioblock-inbuf ioblock)))
+         (idx (io-buffer-idx inbuf))
+         (end (+ idx count))
+         (limit (io-buffer-limit inbuf))
+         (vector (io-buffer-buffer inbuf)))
+    (declare (fixnum idx limit end))
+    (if (< limit end)
+      (error "Integer decoding error"))
+    (let* ((result (%parse-signed-integer vector idx end)))
+      (setf (io-buffer-idx inbuf) end)
+      result)))
+
+(defmethod stream-position ((s vector-input-stream) &optional newpos)
+  (let* ((ioblock (basic-stream-ioblock s))
+         (inbuf (ioblock-inbuf ioblock))
+         (origin (vector-stream-ioblock-displacement ioblock)))
+    (declare (fixnum origin))
+    (if newpos
+      (if (and (typep newpos 'fixnum)
+               (> (the fixnum newpos) -1)
+               (< (the fixnum newpos) (the fixnum (+ origin (the fixnum (io-buffer-limit inbuf))))))
+        (progn
+          (setf (io-buffer-idx inbuf) (the fixnum (+ origin (the fixnum newpos))))
+          newpos)
+        (report-bad-arg newpos `(integer 0 `(,(- (the fixnum (io-buffer-limit inbuf)) origin)))))
+      (the fixnum (- (the fixnum (io-buffer-idx inbuf)) origin)))))
+
 ; end of L1-streams.lisp
Index: /branches/working-0711/ccl/lib/ccl-export-syms.lisp
===================================================================
--- /branches/working-0711/ccl/lib/ccl-export-syms.lisp	(revision 13509)
+++ /branches/working-0711/ccl/lib/ccl-export-syms.lisp	(revision 13510)
@@ -709,5 +709,18 @@
      heap-utilization
      collect-heap-utilization
-
+     parse-unsigned-integer
+     parse-signed-integer
+     pui-stream
+     psi-stream
+     with-output-to-vector
+     with-input-from-vector
+     make-vector-output-stream
+     make-vector-input-stream
+     unsigned-integer-to-binary
+     signed-integer-to-binary
+     vector-input-stream
+     vector-output-stream
+     get-output-stream-vector  
+     *vector-output-stream-default-initial-allocation*   
      external-process-creation-failure
 
Index: /branches/working-0711/ccl/lib/macros.lisp
===================================================================
--- /branches/working-0711/ccl/lib/macros.lisp	(revision 13509)
+++ /branches/working-0711/ccl/lib/macros.lisp	(revision 13510)
@@ -1469,4 +1469,14 @@
         (close ,var)))))
 
+(defmacro with-input-from-vector ((var vector &key index (start 0) end external-format) &body forms &environment env)
+  (multiple-value-bind (forms decls) (parse-body forms env nil)
+    `(let ((,var (%make-vector-input-stream ,vector ,start ,end ,external-format)))
+      ,@decls
+      (unwind-protect
+           (multiple-value-prog1
+               (progn ,@forms)
+             ,@(if index `((setf ,index (vector-input-stream-index ,var)))))
+        (close ,var)))))
+
 (defmacro with-output-to-string ((var &optional string &key (element-type 'base-char element-type-p))
                                  &body body 
@@ -1476,21 +1486,35 @@
 executed as an implicit progn with VAR bound to an output string stream.
 All output to that string stream is saved in a string."
-  (let ((string-var (gensym "string")))
+  (let* ((string-p (not (null string))))
     (multiple-value-bind (forms decls) (parse-body body env nil)
-      `(let* ((,string-var ,string)
-              (,var (if ,string-var
-                      ,@(if element-type-p
-                            `((progn
-                                ,element-type
-                                (%make-string-output-stream ,string-var)))
-                            `((%make-string-output-stream ,string-var)))
-                      ,@(if element-type-p
-                            `((make-string-output-stream :element-type ,element-type))
-                            `((make-string-output-stream))))))
+      `(let* ((,var ,@(if string-p
+                          `(,@(if element-type-p
+                                   `((progn
+                                       ,element-type
+                                       (%make-string-output-stream ,string)))
+                                   `((%make-string-output-stream ,string))))
+                          `(,@(if element-type-p
+                                   `((make-string-output-stream :element-type ,element-type))
+                                   `((make-string-output-stream)))))))
+        ,@decls
+        (unwind-protect
+             (progn
+               ,@forms
+               ,@(if string-p () `((get-output-stream-string ,var))))
+          (close ,var))))))
+
+(defmacro with-output-to-vector ((var &optional vector &key external-format)
+                                 &body body 
+                                 &environment env)
+  (let* ((vector-p (not (null vector))))
+    (multiple-value-bind (forms decls) (parse-body body env nil)
+      `(let* ((,var ,@(if vector-p
+                          `((%make-vector-output-stream ,vector ,external-format))
+                          `((make-vector-output-stream :external-format ,external-format)))))
          ,@decls
          (unwind-protect
               (progn
                 ,@forms
-                ,@(if string () `((get-output-stream-string ,var))))
+                ,@(if vector-p () `((get-output-stream-vector ,var))))
            (close ,var))))))
 
Index: /branches/working-0711/ccl/lib/misc.lisp
===================================================================
--- /branches/working-0711/ccl/lib/misc.lisp	(revision 13509)
+++ /branches/working-0711/ccl/lib/misc.lisp	(revision 13510)
@@ -1281,2 +1281,129 @@
 			(return-from unwatch (%unwatch thing new)))))
                 area-watched)))
+
+(defun %parse-unsigned-integer (vector start end)
+  (declare ((simple-array (unsigned-byte 8) (*)) vector)
+           (fixnum start end)
+           (optimize (speed 3) (safety 0)))
+  (let* ((count (- end start))
+         (msb 0))
+    (declare (fixnum count) ((unsigned-byte 8) msb))
+    (or
+     (do* ((i start (1+ i)))
+          ((>= i end) 0)
+       (declare (fixnum i))
+       (let* ((b (aref vector i)))
+         (declare ((unsigned-byte 8) b))
+         (cond ((zerop b) (incf start) (decf count))
+               (t (setq msb b) (return)))))
+     (cond
+       ((or (< count #+64-bit-target 8 #+32-bit-target 4)
+            (and (= count #+64-bit-target 8 #+32-bit-target 4)
+                 (< msb #+64-bit-target 16 #+32-bit-target 32)))
+        ;; Result will be a fixnum.
+        (do* ((result 0)
+              (shift 0 (+ shift 8))
+              (i (1- end) (1- i)))
+             ((< i start) result)
+          (declare (fixnum result shift i))
+          (setq result (logior result (the fixnum (%ilsl shift (aref vector i)))))))
+       (t
+        ;; Result will be a bignum.  If COUNT is a multiple of 4
+        ;; and the most significant bit is set, need to add an
+        ;; extra word of zero-extension.
+        (let* ((result (allocate-typed-vector :bignum
+                                              (if (and (logbitp 7 msb)
+                                                       (zerop (the fixnum (logand count 3))))
+                                                (the fixnum (1+ (the fixnum (ash count -2))))
+                                                (the fixnum (ash (the fixnum (+ count 3)) -2))))))
+          (declare ((simple-array (unsigned-byte 8) (*)) result)) ; lie
+          (dotimes (i count result)
+            (decf end)
+            (setf (aref result
+                        #+little-endian-target i
+                        #+big-endian-target (the fixnum (logxor i 3)))
+                  (aref vector end)))))))))
+
+  
+;;; Octets between START and END encode an unsigned integer in big-endian
+;;; byte order.
+(defun parse-unsigned-integer (vector &optional (start 0) end)
+  (setq end (check-sequence-bounds vector start end))
+  (locally (declare (fixnum start end))
+      (unless (typep vector '(simple-array (unsigned-byte 8) (*)))
+        (multiple-value-bind (data offset) (array-data-and-offset vector)
+          (declare (fixnum offset))
+          (unless (typep data '(simple-array (unsigned-byte 8) (*)))
+            (report-bad-arg vector '(vector (unsigned-byte 8))))
+          (incf start offset)
+          (incf end offset)
+          (setq vector data)))
+      (%parse-unsigned-integer vector start end)))
+
+(defun %parse-signed-integer (vector start end)
+  (declare ((simple-array (unsigned-byte 8) (*)) vector)
+           (fixnum start end)
+           (optimize (speed 3) (safety 0)))
+  (let* ((count (- end start)))
+    (declare (fixnum count))
+    (if (zerop count)
+      0
+      (let* ((sign-byte (aref vector start)))
+        (declare (fixnum sign-byte))
+        (if (< sign-byte 128)
+          (%parse-unsigned-integer vector start end)
+          (progn
+            (decf sign-byte 256)
+            (or
+             (do* ()
+                  ((= count 1) sign-byte)
+               (unless (= sign-byte -1)
+                 (return))
+               (let* ((next (1+ start))
+                      (nextb (aref vector next)))
+                 (declare (fixnum next nextb))
+                 (if (not (logbitp 7 nextb))
+                   (return))
+                 (setq sign-byte (- nextb 256)
+                       start next
+                       count (1- count))))
+             (cond ((or (< count #+64-bit-target 8 #+32-bit-target 4)
+                        (and (= count #+64-bit-target 8 #+32-bit-target 4)
+                             (>= sign-byte
+                                 #+64-bit-target -16
+                                 #+32-bit-target -32)))
+                    ;; Result will be a fixnum
+                    (do* ((result 0)
+                          (shift 0 (+ shift 8))
+                          (i (1- end) (1- i)))
+                         ((= i start) (logior result (the fixnum (%ilsl shift sign-byte))))
+                      (declare (fixnum result shift i))
+                      (setq result (logior result (the fixnum (%ilsl shift (aref vector i)))))))
+                   (t
+                    (let* ((result (allocate-typed-vector :bignum (the fixnum (ash (the fixnum (+ count 3)) -2)))))
+          (declare ((simple-array (unsigned-byte 8) (*)) result)) ; lie
+          (dotimes (i count (do* ((i count (1+ i)))
+                                 ((= 0 (the fixnum (logand i 3)))
+                                  result)
+                              (declare (fixnum i))
+                              (setf (aref result
+                                          #+little-endian-target i
+                                          #+big-endian-target (the fixnum (logxor i 3))) #xff)))
+            (decf end)
+            (setf (aref result
+                        #+little-endian-target i
+                        #+big-endian-target (the fixnum (logxor i 3)))
+                  (aref vector end)))))))))))))
+
+(defun parse-signed-integer (vector &optional (start 0) end)
+  (setq end (check-sequence-bounds vector start end))
+  (locally (declare (fixnum start end))
+    (unless (typep vector '(simple-array (unsigned-byte 8) (*)))
+      (multiple-value-bind (data offset) (array-data-and-offset vector)
+        (declare (fixnum offset))
+        (unless (typep data '(simple-array (unsigned-byte 8) (*)))
+          (report-bad-arg vector '(vector (unsigned-byte 8))))
+        (incf start offset)
+        (incf end offset)
+        (setq vector data)))
+    (%parse-signed-integer vector start end)))