Changeset 13454


Ignore:
Timestamp:
Feb 22, 2010, 6:12:06 AM (15 years ago)
Author:
Gary Byers
Message:

New vector streams; similar to STRING streams but use vectors of
(UNSIGNED-BYTE 8), allow binary as well as character I/O.

The following symbols are newly exported from the CCL package:

VECTOR-INPUT-STREAM, VECTOR-OUTPUT-STREAM: class/type names.

MAKE-VECTOR-OUTPUT-STREAM &key external-format

Returns a VECTOR-OUTPUT-STREAM. Character output on that
stream is encoded according to the specified external format
(which is handled as it is by other CCL stream classes.)

GET-OUTPUT-STREAM-VECTOR s

S should be a VECTOR-OUTPUT-STREAM. Returns a (SIMPLE-ARRAY
(UNSIGNED-BYTE) (*)) of all bytes written to S since it was
created or since the last call GET-OUTPUT-STREAM-VECTOR on S.

WITH-OUTPUT-TO-VECTOR var &optional vector &key external-format &body body

Like WITH-OUTPUT-TO-STRING (too much like it, in fact.)
Executes BODY with VAR bound to a VECTOR-OUTPUT-STREAM. If VECTOR is
non-null, it should be a (VECTOR (UNSIGNED-BYTE 8)) with a fill-pointer;
the value(s) returned by BODY are returned and the vector's contents
and fill-pointer are updated at the end of the WITH-OUTPUT-TO-VECTOR form.
If VECTOR is NIL, returns the result of (GET-OUTPUT-STREAM-VECTOR var) after
executing BODY.

WITH-INPUT-FROM-VECTOR var vector &key (start 0) end external-format &body body

Like WITH-INPUT-FROM-STRING. VECTOR should be a (VECTOR (UNSIGNED-BYTE 8)).
Executes BODY with VAR bound to a VECTOR-INPUT-STREAM constructed from
VECTOR (bounded by START and END.)

UNSIGNED-INTEGER-TO-BINARY value s
SIGNED-INTEGER-TO-BINARY value s

Encodes the integer VALUE on the VECTOR-OUTPUT-STREAM S. These functions
can be used interchangably; negative integers are encoded in SLEB128 and
non-negative integers in ULEB128.

PARSE-UNSIGNED-INTEGER vector &optional (start 0) end

Decodes a ULEB128-encoded integer from the bounded range of VECTOR,
which must be of type (VECTOR (UNSIGNED-BYTE 8)). Returns two
values: that integer and the the index of the first octet in VECTOR
that follows the encoded integer. (The second value will be > start
and <= end)

PARSE-SIGNED-INTEGER vector &optional (start 0) end

As PARSE-UNSIGNED-INTEGER, but assumes SLEB128 encoding and may return
a negative first value.

PUI-STREAM s

Decodes a ULEB128-encoded integer from the VECTOR-INPUT-STREAM S and
returns that value.

PSI-STREAM s

Decodes an SLEB128-encoded integer from the VECTOR-INPUT-STREAM S and
returns that value.

Other (hopefully transparent) changes to stream buffering code, slight
change to WITH-OUTPUT-TO-STRING.

Location:
trunk/source
Files:
4 edited

Legend:

Unmodified
Added
Removed

  • trunk/source/level-1/l1-streams.lisp

    r13384 r13454  
    14151415    (error "Can't write vector to stream ~s" (ioblock-stream ioblock)))
    14161416  (let* ((written 0)
    1417          (out (ioblock-outbuf ioblock))
    1418          (bufsize (io-buffer-size out))
    1419          (buffer (io-buffer-buffer out)))
    1420     (declare (fixnum written bufsize))
     1417         (out (ioblock-outbuf ioblock)))
     1418    (declare (fixnum written))
    14211419    (do* ((pos start-octet (+ pos written))
    14221420          (left num-octets (- left written)))
    … …  
    14261424      (let* ((index (io-buffer-idx out))
    14271425             (count (io-buffer-count out))
    1428              (avail (- bufsize index)))
    1429         (declare (fixnum index avail count))
     1426             (bufsize (io-buffer-size out))
     1427             (avail (- bufsize index))
     1428             (buffer (io-buffer-buffer out)))
     1429        (declare (fixnum index avail count bufsize))
    14301430        (cond
    14311431          ((= (setq written avail) 0)
    … …  
    14481448  (let* ((written 0)
    14491449         (col (ioblock-charpos ioblock))
    1450          (out (ioblock-outbuf ioblock))
    1451          (bufsize (io-buffer-size out))
    1452          (buffer (io-buffer-buffer out)))
    1453     (declare (fixnum written bufsize col)
    1454              (type (simple-array (unsigned-byte 8) (*)) buffer)
     1450         (out (ioblock-outbuf ioblock)))
     1451    (declare (fixnum written col)
    14551452             (optimize (speed 3) (safety 0)))
    14561453    (do* ((pos start-char (+ pos written))
    … …  
    14611458      (let* ((index (io-buffer-idx out))
    14621459             (count (io-buffer-count out))
     1460             (bufsize (io-buffer-size out))
     1461             (buffer (io-buffer-buffer out))
    14631462             (avail (- bufsize index)))
    1464         (declare (fixnum index avail count))
     1463        (declare (fixnum index bufsize avail count)
     1464                 (type (simple-array (unsigned-byte 8) (*)) buffer))
    14651465        (cond
    14661466          ((= (setq written avail) 0)
    … …  
    15091509                 ioblock))))
    15101510
    1511 (declaim (inline %ioblock-write-element))
    1512 
    1513 (defun %ioblock-write-element (ioblock element)
     1511
     1512
     1513(declaim (inline %ioblock-write-u8-element))
     1514(defun %ioblock-write-u8-element (ioblock element)
    15141515  (declare (optimize (speed 3) (safety 0)))
    15151516  (let* ((buf (ioblock-outbuf ioblock))
    … …  
    15201521    (when (= idx limit)
    15211522      (%ioblock-force-output ioblock nil)
    1522       (setq idx 0 count 0))
    1523     (setf (aref (io-buffer-buffer buf) idx) element)
     1523      (setq idx (io-buffer-idx buf) count (io-buffer-count buf)))
     1524    (setf (aref (the (simple-array (unsigned-byte 8) (*)) (io-buffer-buffer buf)) idx) element)
    15241525    (incf idx)
    15251526    (setf (io-buffer-idx buf) idx)
    … …  
    15291530    element))
    15301531
    1531 (declaim (inline %ioblock-write-u8-element))
    1532 (defun %ioblock-write-u8-element (ioblock element)
     1532(declaim (inline %ioblock-write-s8-element))
     1533(defun %ioblock-write-s8-element (ioblock element)
    15331534  (declare (optimize (speed 3) (safety 0)))
    15341535  (let* ((buf (ioblock-outbuf ioblock))
    … …  
    15391540    (when (= idx limit)
    15401541      (%ioblock-force-output ioblock nil)
    1541       (setq idx 0 count 0))
    1542     (setf (aref (the (simple-array (unsigned-byte 8) (*)) (io-buffer-buffer buf)) idx) element)
     1542      (setq idx (io-buffer-idx buf) count (io-buffer-count buf)))
     1543    (setf (aref (the (simple-array (signed-byte 8) (*)) (io-buffer-buffer buf)) idx) element)
    15431544    (incf idx)
    15441545    (setf (io-buffer-idx buf) idx)
    … …  
    15481549    element))
    15491550
    1550 (declaim (inline %ioblock-write-s8-element))
    1551 (defun %ioblock-write-s8-element (ioblock element)
     1551(declaim (inline %ioblock-write-u16-element))
     1552(defun %ioblock-write-u16-element (ioblock element)
    15521553  (declare (optimize (speed 3) (safety 0)))
    15531554  (let* ((buf (ioblock-outbuf ioblock))
    … …  
    15581559    (when (= idx limit)
    15591560      (%ioblock-force-output ioblock nil)
    1560       (setq idx 0 count 0))
    1561     (setf (aref (the (simple-array (signed-byte 8) (*)) (io-buffer-buffer buf)) idx) element)
    1562     (incf idx)
    1563     (setf (io-buffer-idx buf) idx)
    1564     (when (> idx count)
    1565       (setf (io-buffer-count buf) idx))
    1566     (setf (ioblock-dirty ioblock) t)
    1567     element))
    1568 
    1569 (declaim (inline %ioblock-write-u16-element))
    1570 (defun %ioblock-write-u16-element (ioblock element)
    1571   (declare (optimize (speed 3) (safety 0)))
    1572   (let* ((buf (ioblock-outbuf ioblock))
    1573          (idx (io-buffer-idx buf))
    1574          (count (io-buffer-count buf))
    1575          (limit (io-buffer-limit buf)))
    1576     (declare (fixnum idx limit count))
    1577     (when (= idx limit)
    1578       (%ioblock-force-output ioblock nil)
    1579       (setq idx 0 count 0))
     1561      (setq idx (io-buffer-idx buf) count (io-buffer-count buf)))
    15801562    (setf (aref (the (simple-array (unsigned-byte 16) (*)) (io-buffer-buffer buf)) idx) element)
    15811563    (incf idx)
    … …  
    16051587    (when (= idx limit)
    16061588      (%ioblock-force-output ioblock nil)
    1607       (setq idx 0 count 0))
     1589      (setq idx (io-buffer-idx buf) count (io-buffer-count buf)))
    16081590    (setf (aref vector idx) b0)
    16091591    (incf idx)
    … …  
    16121594        (setf (io-buffer-count buf) idx))
    16131595      (%ioblock-force-output ioblock nil)
    1614       (setq idx 0 count 0))
     1596      (setq idx (io-buffer-idx buf) count (io-buffer-count buf)))
    16151597    (setf (aref vector idx) b1)
    16161598    (incf idx)
    … …  
    16391621    (when (= idx limit)
    16401622      (%ioblock-force-output ioblock nil)
    1641       (setq idx 0 count 0))
     1623      (setq idx (io-buffer-idx buf)
     1624            count (io-buffer-count buf)
     1625            vector (io-buffer-buffer buf)
     1626            limit (io-buffer-limit buf)))
    16421627    (setf (aref vector idx) b1)
    16431628    (incf idx)
    … …  
    16461631        (setf (io-buffer-count buf) idx))
    16471632      (%ioblock-force-output ioblock nil)
    1648       (setq idx 0 count 0))
     1633      (setq idx (io-buffer-idx buf)
     1634            count (io-buffer-count buf)
     1635            vector (io-buffer-buffer buf)
     1636            limit (io-buffer-limit buf)))
    16491637    (setf (aref vector idx) b0)
    16501638    (incf idx)
    … …  
    16771665    (when (= idx limit)
    16781666      (%ioblock-force-output ioblock nil)
    1679       (setq idx 0 count 0))
     1667      (setq idx (io-buffer-idx buf)
     1668            count (io-buffer-count buf)
     1669            vector (io-buffer-buffer buf)
     1670            limit (io-buffer-limit buf)))
    16801671    (setf (aref vector idx) b0)
    16811672    (incf idx)
    … …  
    16841675        (setf (io-buffer-count buf) idx))
    16851676      (%ioblock-force-output ioblock nil)
    1686       (setq idx 0 count 0))
     1677      (setq idx (io-buffer-idx buf)
     1678            count (io-buffer-count buf)
     1679            vector (io-buffer-buffer buf)
     1680            limit (io-buffer-limit buf)))
    16871681    (setf (aref vector idx) b1)
    16881682    (incf idx)
    … …  
    16911685        (setf (io-buffer-count buf) idx))
    16921686      (%ioblock-force-output ioblock nil)
    1693       (setq idx 0 count 0))
     1687      (setq idx (io-buffer-idx buf)
     1688            count (io-buffer-count buf)
     1689            vector (io-buffer-buffer buf)
     1690            limit (io-buffer-limit buf)))
    16941691    (setf (aref vector idx) b2)
    16951692    (incf idx)
    … …  
    16981695        (setf (io-buffer-count buf) idx))
    16991696      (%ioblock-force-output ioblock nil)
    1700       (setq idx 0 count 0))
     1697      (setq idx (io-buffer-idx buf)
     1698            count (io-buffer-count buf)
     1699            vector (io-buffer-buffer buf)
     1700            limit (io-buffer-limit buf)))
    17011701    (setf (aref vector idx) b3)
    17021702    (incf idx)
    … …  
    17291729    (when (= idx limit)
    17301730      (%ioblock-force-output ioblock nil)
    1731       (setq idx 0 count 0))
     1731      (setq idx (io-buffer-idx buf)
     1732            count (io-buffer-count buf)
     1733            vector (io-buffer-buffer buf)
     1734            limit (io-buffer-limit buf)))
    17321735    (setf (aref vector idx) b0)
    17331736    (incf idx)
    … …  
    17361739        (setf (io-buffer-count buf) idx))
    17371740      (%ioblock-force-output ioblock nil)
    1738       (setq idx 0 count 0))
     1741      (setq idx (io-buffer-idx buf) count (io-buffer-count buf)))
    17391742    (setf (aref vector idx) b1)
    17401743    (incf idx)
    … …  
    17431746        (setf (io-buffer-count buf) idx))
    17441747      (%ioblock-force-output ioblock nil)
    1745       (setq idx 0 count 0))
     1748      (setq idx (io-buffer-idx buf)
     1749            count (io-buffer-count buf)
     1750            vector (io-buffer-buffer buf)
     1751            limit (io-buffer-limit buf)))
    17461752    (setf (aref vector idx) b2)
    17471753    (incf idx)
    … …  
    17501756        (setf (io-buffer-count buf) idx))
    17511757      (%ioblock-force-output ioblock nil)
    1752       (setq idx 0 count 0))
     1758      (setq idx (io-buffer-idx buf)
     1759            count (io-buffer-count buf)
     1760            vector (io-buffer-buffer buf)
     1761            limit (io-buffer-limit buf)))
    17531762    (setf (aref vector idx) b3)
    17541763    (incf idx)
    … …  
    17691778    (when (= idx limit)
    17701779      (%ioblock-force-output ioblock nil)
    1771       (setq idx 0 count 0))
     1780      (setq idx (io-buffer-idx buf)
     1781            count (io-buffer-count buf)))
    17721782    (setf (aref (the (simple-array (signed-byte 16) (*)) (io-buffer-buffer buf)) idx) element)
    17731783    (incf idx)
    … …  
    17881798    (when (= idx limit)
    17891799      (%ioblock-force-output ioblock nil)
    1790       (setq idx 0 count 0))
     1800      (setq idx (io-buffer-idx buf)
     1801            count (io-buffer-count buf)))
    17911802    (setf (aref (the (simple-array (unsigned-byte 32) (*)) (io-buffer-buffer buf)) idx) element)
    17921803    (incf idx)
    … …  
    18071818    (when (= idx limit)
    18081819      (%ioblock-force-output ioblock nil)
    1809       (setq idx 0 count 0))
     1820      (setq idx (io-buffer-idx buf)
     1821            count (io-buffer-count buf)))
    18101822    (setf (aref (the (simple-array (unsigned-byte 32) (*)) (io-buffer-buffer buf)) idx)
    18111823          (%swap-u32 element))
    … …  
    18271839    (when (= idx limit)
    18281840      (%ioblock-force-output ioblock nil)
    1829       (setq idx 0 count 0))
     1841      (setq idx (io-buffer-idx buf) count (io-buffer-count buf)))
    18301842    (setf (aref (the (simple-array (signed-byte 32) (*)) (io-buffer-buffer buf)) idx) element)
    18311843    (incf idx)
    … …  
    18481860    (when (= idx limit)
    18491861      (%ioblock-force-output ioblock nil)
    1850       (setq idx 0 count 0))
     1862      (setq idx (io-buffer-idx buf) count (io-buffer-count buf)))
    18511863    (setf (aref (the (simple-array (unsigned-byte 64) (*)) (io-buffer-buffer buf)) idx) element)
    18521864    (incf idx)
    … …  
    18671879    (when (= idx limit)
    18681880      (%ioblock-force-output ioblock nil)
    1869       (setq idx 0 count 0))
     1881      (setq idx (io-buffer-idx buf) count (io-buffer-count buf)))
    18701882    (setf (aref (the (simple-array (signed-byte 64) (*)) (io-buffer-buffer buf)) idx) element)
    18711883    (incf idx)
    … …  
    31283140            (setf (ioblock-inbuf-lock ioblock) (make-lock)))
    31293141          (setf (ioblock-line-termination ioblock) line-termination)
    3130           (setup-ioblock-input ioblock character-p element-type sharing encoding line-termination)
     3142
    31313143          (setf (ioblock-element-shift ioblock) (max 0 (ceiling (log  (/ in-size-in-octets insize) 2))))
    31323144          )))
     3145    (when (ioblock-inbuf ioblock)
     3146      (setup-ioblock-input ioblock character-p element-type sharing encoding line-termination))     
    31333147    (if share-buffers-p
    31343148      (if insize
    … …  
    31553169            (setf (ioblock-element-shift ioblock) (max 0 (ceiling (log (/ out-size-in-octets outsize) 2))))
    31563170            ))))
    3157     (when (or share-buffers-p outsize)
     3171    (when (ioblock-outbuf ioblock)
    31583172      (setup-ioblock-output ioblock character-p element-type sharing encoding line-termination))
    31593173    (when element-type
    … …  
    60846098  '%ioblock-untyi)
    60856099
     6100
     6101
     6102
     6103;;; Bivalent vector streams.
     6104(make-built-in-class 'vector-stream 'basic-binary-stream 'basic-character-stream)
     6105
     6106(defmethod print-object ((s vector-stream) out)
     6107  (print-unreadable-object (s out :type t :identity t)
     6108    (unless (open-stream-p s)  (format out " ~s" :closed))))
     6109
     6110
     6111(defstruct (vector-stream-ioblock (:include ioblock))
     6112  (displacement 0)                      ;displaced-index-offset
     6113  )
     6114
     6115(defstruct (vector-output-stream-ioblock (:include vector-stream-ioblock))
     6116  (line-length 80)                      ;for pretty-printer
     6117  displaced                             ;original vector if fill-pointer case
     6118 )
     6119
     6120(defstatic *vector-output-stream-class* (make-built-in-class 'vector-output-stream 'vector-stream 'basic-binary-output-stream 'basic-character-output-stream))
     6121(defstatic *vector-output-stream-class-wrapper* (%class-own-wrapper *vector-output-stream-class*))
     6122(defstatic *vector-input-stream-class* (make-built-in-class 'vector-input-stream 'vector-stream 'basic-binary-input-stream 'basic-character-input-stream))
     6123(defstatic *vector-input-stream-class-wrapper* (%class-own-wrapper *vector-input-stream-class*))
     6124
     6125(defmethod initialize-basic-stream :after ((s vector-stream) &key ioblock &allow-other-keys)
     6126  (setf (basic-stream.state s) ioblock))
     6127
     6128(defmethod stream-force-output ((s vector-output-stream)))
     6129
     6130(defmethod stream-finish-output ((s vector-output-stream)))
     6131
     6132
     6133
     6134(defun %extend-vector-output-stream (s ioblock count finish-p)
     6135  (declare (ignore s count finish-p))
     6136  (check-ioblock-owner ioblock)
     6137  (let* ((displaced (vector-output-stream-ioblock-displaced ioblock))
     6138         (outbuf (ioblock-outbuf ioblock)))
     6139    (cond (displaced
     6140           (let* ((flags (%svref displaced target::arrayH.flags-cell)))
     6141             (declare (fixnum flags))
     6142             (unless (logbitp $arh_adjp_bit flags)
     6143               (%err-disp $XMALADJUST displaced))
     6144             (let* ((len (%svref displaced target::vectorH.physsize-cell))
     6145                    (newlen (max (the fixnum (+ len len)) 16))
     6146                    (new (%alloc-misc newlen target::subtag-u8-vector)))
     6147               (declare (fixnum len newlen)
     6148                        ((simple-array (unsigned-byte 8) (*)) new))
     6149               (multiple-value-bind (data offset)
     6150                   (%array-header-data-and-offset displaced)
     6151                 (declare ((simple-array (unsigned-byte 8) (*)) data)
     6152                          (fixnum offset))
     6153                 (%copy-ivector-to-ivector new 0 data offset len)
     6154                 (setf (vector-output-stream-ioblock-displacement ioblock) 0)
     6155                 (unless (= 0 offset)
     6156                   (setf (io-buffer-idx outbuf) len
     6157                         (io-buffer-count outbuf) len))
     6158                 (setf (io-buffer-limit outbuf) newlen
     6159                       (io-buffer-size outbuf) newlen
     6160                       (io-buffer-buffer outbuf) new)
     6161                 ;; Adjust the displaced vector.
     6162                 (setf (%svref displaced target::vectorH.data-vector-cell) new
     6163                       (%svref displaced target::vectorH.displacement-cell) 0
     6164                       (%svref displaced target::vectorH.physsize-cell) newlen
     6165                       (%svref displaced target::vectorH.flags-cell) (bitclr $arh_exp_disp_bit flags)
     6166                       (%svref displaced target::vectorH.logsize-cell) len)))))
     6167          (t
     6168           ;; Simpler. Honest.
     6169           (let* ((old (io-buffer-buffer outbuf))
     6170                  (len (length old))
     6171                  (newlen (max (the fixnum (+ len len)) 16))
     6172                  (new (%alloc-misc newlen target::subtag-u8-vector)))
     6173             (declare (fixnum len newlen)
     6174                      ((simple-array (unsigned-byte 8) (*)) old new))
     6175             (%copy-ivector-to-ivector new 0 old 0 len)
     6176             (setf (io-buffer-buffer outbuf) new
     6177                   (io-buffer-size outbuf) newlen
     6178                   (io-buffer-limit outbuf) newlen))))))
     6179
     6180(defun %vector-output-stream-close (s ioblock)
     6181  (declare (ignore s))
     6182  ;; If there's a displaced vector, fix its fill pointer.
     6183  (let* ((displaced (vector-output-stream-ioblock-displaced ioblock)))
     6184    (when displaced
     6185      (setf (%svref displaced target::vectorH.logsize-cell)
     6186            (the fixnum (- (the fixnum (io-buffer-count (ioblock-outbuf ioblock)))
     6187                           (the fixnum (vector-output-stream-ioblock-displacement ioblock))))))))
     6188
     6189(defmethod stream-line-length ((s vector-output-stream))
     6190  (let* ((ioblock (basic-stream-ioblock s)))
     6191    (string-output-stream-ioblock-line-length ioblock)))
     6192
     6193(defmethod (setf stream-line-length) (newlen (s vector-output-stream))
     6194  (let* ((ioblock (basic-stream-ioblock s)))
     6195    (setf (vector-output-stream-ioblock-line-length ioblock) newlen)))
     6196
     6197(defun get-output-stream-vector (s)
     6198  (unless (and (typep s 'basic-stream)
     6199               (eq *vector-output-stream-class-wrapper*
     6200                   (basic-stream.wrapper s)))
     6201    (report-bad-arg s 'vector-output-stream))
     6202  (let* ((ioblock (basic-stream-ioblock s))
     6203         (outbuf (progn
     6204                   (check-ioblock-owner ioblock)
     6205                   (ioblock-outbuf ioblock)))
     6206         (v (io-buffer-buffer outbuf))
     6207         (offset (vector-output-stream-ioblock-displacement ioblock))
     6208         (len (the fixnum (- (the fixnum (io-buffer-count outbuf)) offset)))
     6209         (new (%alloc-misc len target::subtag-u8-vector)))
     6210    (declare (fixnum offset len))
     6211    (%copy-ivector-to-ivector v offset new 0 len)
     6212    (setf (io-buffer-idx outbuf) offset
     6213          (io-buffer-count outbuf) offset)
     6214    new))
     6215
     6216(defun unsigned-integer-to-binary (value s)
     6217  (if (< value 0)
     6218    (signed-integer-to-binary value s)
     6219    (progn
     6220      (unless (and (typep s 'basic-stream)
     6221                   (eq *vector-output-stream-class-wrapper*
     6222                       (basic-stream.wrapper s)))
     6223        (report-bad-arg s 'vector-input-stream))
     6224      (let* ((ioblock (basic-stream-ioblock s))
     6225             (outbuf (progn
     6226                       (check-ioblock-owner ioblock)
     6227                       (ioblock-outbuf ioblock)))
     6228             (idx (io-buffer-idx outbuf))
     6229             (limit (io-buffer-limit outbuf))
     6230             (buffer (io-buffer-buffer outbuf)))
     6231        (declare (fixnum idx limit)
     6232                 ((simple-array (unsigned-byte 8) (*)) buffer))
     6233        (loop
     6234          (let* ((b (logand value #x7f)))
     6235            (declare ((unsigned-byte 7) b))
     6236            (setq value (ash value -7))
     6237            (when (= idx limit)
     6238              (%ioblock-force-output ioblock nil)
     6239              (setq limit (io-buffer-limit outbuf)
     6240                    buffer (io-buffer-buffer outbuf)))
     6241            (if (eql 0 value)
     6242              (progn
     6243                (setf (aref buffer idx) b)
     6244                (incf idx)
     6245                (setf (io-buffer-idx outbuf) idx
     6246                      (io-buffer-count outbuf) idx)
     6247                (return))
     6248              (progn
     6249                (setf (aref buffer idx) (logior b #x80))
     6250                (incf idx)))))))))
     6251
     6252(defun signed-integer-to-binary (value s)
     6253  (if (< value 0)
     6254    (signed-integer-to-binary value s)
     6255    (progn
     6256      (unless (and (typep s 'basic-stream)
     6257                   (eq *vector-output-stream-class-wrapper*
     6258                       (basic-stream.wrapper s)))
     6259        (report-bad-arg s 'vector-input-stream))
     6260      (let* ((ioblock (basic-stream-ioblock s))
     6261             (outbuf (progn
     6262                       (check-ioblock-owner ioblock)
     6263                       (ioblock-outbuf ioblock)))
     6264             (idx (io-buffer-idx outbuf))
     6265             (limit (io-buffer-limit outbuf))
     6266             (buffer (io-buffer-buffer outbuf)))
     6267        (declare (fixnum idx limit)
     6268                 ((simple-array (unsigned-byte 8) (*)) buffer))
     6269        (loop
     6270          (let* ((b (logand value #x7f)))
     6271            (declare ((unsigned-byte 7) b))
     6272            (setq value (ash value -7))
     6273            (when (= idx limit)
     6274              (%ioblock-force-output ioblock nil)
     6275              (setq limit (io-buffer-limit outbuf)
     6276                    buffer (io-buffer-buffer outbuf)))
     6277            (if (eql -1 value)
     6278              (progn
     6279                (setf (aref buffer idx) b)
     6280                (incf idx)
     6281                (setf (io-buffer-idx outbuf) idx
     6282                      (io-buffer-count outbuf) idx)
     6283                (return))
     6284              (progn
     6285                (setf (aref buffer idx) (logior b #x80))
     6286                (incf idx)))))))))
     6287             
     6288               
     6289
     6290         
     6291
     6292(defun %make-vector-output-stream (vector external-format)
     6293  (let* ((data nil)
     6294         (len nil)
     6295         (offset 0)
     6296         (start 0)
     6297         (displaced nil)
     6298         (external-format (normalize-external-format t external-format))
     6299         (encoding (external-format-character-encoding external-format))
     6300         (line-termination (external-format-line-termination external-format)))
     6301    (cond ((typep vector '(simple-array (unsigned-byte 8) (*)))
     6302           (setq data vector len (length vector)))
     6303          (t
     6304           (multiple-value-setq (data offset) (array-data-and-offset vector))
     6305           (unless (eql (typecode data) target::subtag-u8-vector)
     6306             (report-bad-arg vector '(vector (unsigned-byte 8))))
     6307           (unless (array-has-fill-pointer-p vector)
     6308             (error "~S must be a vector with a fill pointer." vector))
     6309           (setq start (+ (fill-pointer vector) offset)
     6310                 len (+ (array-total-size vector) offset)
     6311                 displaced vector)))
     6312    (make-ioblock-stream *vector-output-stream-class*
     6313                         :ioblock (make-vector-output-stream-ioblock
     6314                                   :outbuf (make-io-buffer :buffer data
     6315                                                           :idx start
     6316                                                           :count start
     6317                                                           :limit len
     6318                                                           :size len)
     6319                                   :displaced displaced
     6320                                   :displacement offset)
     6321                         :encoding encoding
     6322                         :character-p t
     6323                         :element-type '(unsigned-byte 8)
     6324                         :line-termination line-termination
     6325                         :force-output-function '%extend-vector-output-stream
     6326                         :close-function '%vector-output-stream-close)))
     6327
     6328   
     6329(defun make-vector-output-stream (&key (external-format :default))
     6330  (%make-vector-output-stream (make-array 64 :element-type '(unsigned-byte 8))  external-format))
     6331
     6332(defun vector-input-stream-index (s)
     6333  (unless (and (typep s 'basic-stream)
     6334               (eq *vector-input-stream-class-wrapper*
     6335                   (basic-stream.wrapper s)))
     6336    (report-bad-arg s 'vector-input-stream))
     6337  (let* ((ioblock (basic-stream-ioblock s)))
     6338    (check-ioblock-owner ioblock)
     6339    (the fixnum (- (the fixnum (io-buffer-idx (ioblock-inbuf ioblock)))
     6340                   (the fixnum (vector-stream-ioblock-displacement ioblock))))))
     6341           
     6342
     6343(defun %vector-input-stream-untyi (ioblock char)
     6344  (check-ioblock-owner ioblock)
     6345  (let* ((inbuf (ioblock-inbuf ioblock))
     6346         (idx (io-buffer-idx inbuf))
     6347         (encoding (ioblock-encoding ioblock))
     6348         (noctets (if encoding
     6349                    (funcall (character-encoding-character-size-in-octets-function encoding) char)
     6350                    1))
     6351         (newidx (- idx noctets)))
     6352    (declare (fixnum idx noctets newidx))
     6353    (if (>= newidx (the fixnum (vector-stream-ioblock-displacement ioblock)))
     6354      (setf (io-buffer-idx inbuf) newidx)
     6355      (error "Invalid attempt to unread ~s on ~s." char (ioblock-stream ioblock)))))
     6356
     6357 
     6358
     6359(defmethod select-stream-untyi-function ((s vector-input-stream) (direction t))
     6360  '%vector-input-stream-untyi)
     6361
     6362
     6363
     6364
     6365(defun %make-vector-input-stream (vector start end external-format)
     6366  (setq end (check-sequence-bounds vector start end))
     6367  (let* ((data nil)
     6368         (offset 0)
     6369         (external-format (normalize-external-format t external-format))
     6370         (encoding (external-format-character-encoding external-format))
     6371         (line-termination (external-format-line-termination external-format)))
     6372
     6373      (cond ((typep vector '(simple-array (unsigned-byte 8) (*)))
     6374             (setq data vector                   offset start))
     6375            (t (multiple-value-setq (data offset) (array-data-and-offset vector))
     6376               (unless (typep data '(simple-array (unsigned-byte 8) (*)))
     6377                 (report-bad-arg vector '(vector (unsigned-byte 8))))
     6378               (incf start offset)
     6379               (incf end offset)))
     6380      (make-ioblock-stream *vector-input-stream-class*
     6381                           :ioblock (make-vector-stream-ioblock
     6382                                     :inbuf (make-io-buffer
     6383                                             :buffer data
     6384                                             :idx start
     6385                                             :count end
     6386                                             :limit end
     6387                                             :size end)
     6388                                     :displacement start)
     6389                           :direction :input
     6390                           :character-p t
     6391                           :element-type '(unsigned-byte 8)
     6392                           :encoding encoding
     6393                           :line-termination line-termination
     6394                           :listen-function 'false
     6395                           :eofp-function 'true
     6396                           :advance-function 'false
     6397                           :close-function 'false)))
     6398     
     6399(defun make-vector-input-stream (vector &key (start 0) end external-format)
     6400  (%make-vector-input-stream vector start end external-format))
     6401
     6402
     6403
     6404
     6405(defun pui-stream (s)
     6406  (unless (and (typep s 'basic-stream)
     6407               (eq *vector-input-stream-class-wrapper*
     6408                   (basic-stream.wrapper s)))
     6409    (report-bad-arg s 'vector-input-stream))
     6410  (let* ((ioblock (basic-stream-ioblock s))
     6411         (inbuf (progn
     6412                  (check-ioblock-owner ioblock)
     6413                  (ioblock-inbuf ioblock)))
     6414         (idx (io-buffer-idx inbuf))
     6415         (limit (io-buffer-limit inbuf))
     6416         (vector (io-buffer-buffer inbuf)))
     6417    (declare (fixnum idx limit)
     6418             ((simple-array (unsigned-byte 8) (*)) vector))
     6419    (let* ((result 0))
     6420      (do* ((i idx (1+ i))
     6421            (shift 0 (+ shift 7)))
     6422           ((= i limit) (error "integer decoding error"))
     6423        (declare (fixnum i shift))
     6424        (let* ((b (aref vector i))
     6425               (done (not (logbitp 7 b))))
     6426          (declare ((unsigned-byte 8) b))
     6427          (setq b (logand b #x7f)
     6428                result (logior result (ash b shift)))
     6429          (incf idx)
     6430          (when done
     6431            (setf (io-buffer-idx inbuf) idx)
     6432            (return result)))))))
     6433
     6434(defun psi-stream (s)
     6435  (unless (and (typep s 'basic-stream)
     6436               (eq *vector-input-stream-class-wrapper*
     6437                   (basic-stream.wrapper s)))
     6438    (report-bad-arg s 'vector-input-stream))
     6439  (let* ((ioblock (basic-stream-ioblock s))
     6440         (inbuf (progn
     6441                  (check-ioblock-owner ioblock)
     6442                  (ioblock-inbuf ioblock)))
     6443         (idx (io-buffer-idx inbuf))
     6444         (limit (io-buffer-limit inbuf))
     6445         (vector (io-buffer-buffer inbuf)))
     6446    (declare (fixnum idx limit)
     6447             ((simple-array (unsigned-byte 8) (*)) vector))
     6448    (let* ((result 0))
     6449      (do* ((i idx (1+ i))
     6450            (shift 0 (+ shift 7)))
     6451           ((= i limit) (error "integer decoding error"))
     6452        (declare (fixnum i shift))
     6453        (let* ((b (aref vector i))
     6454               (done (not (logbitp 7 b))))
     6455          (declare ((unsigned-byte 8) b))
     6456          (setq b (logand b #x7f)
     6457                result (logior result (ash b shift)))
     6458          (incf idx)
     6459          (when done
     6460            (setf (io-buffer-idx inbuf) idx)
     6461            (if (logbitp 6 b)
     6462              (return (logior result (ash -1 (the fixnum (+ shift 7)))))
     6463              (return result))))))))
     6464
    60866465; end of L1-streams.lisp

  • trunk/source/lib/ccl-export-syms.lisp

    r13405 r13454  
    710710     heap-utilization
    711711     collect-heap-utilization
    712 
     712     parse-unsigned-integer
     713     parse-signed-integer
     714     pui-stream
     715     psi-stream
     716     with-output-to-vector
     717     with-input-from-vector
     718     make-vector-output-stream
     719     make-vector-input-stream
     720     unsigned-integer-to-binary
     721     signed-integer-to-binary
     722     vector-input-stream
     723     vector-output-stream
     724     get-output-stream-vector
     725     
    713726     external-process-creation-failure
    714727

  • trunk/source/lib/macros.lisp

    r13237 r13454  
    14691469        (close ,var)))))
    14701470
     1471(defmacro with-input-from-vector ((var vector &key index (start 0) end external-format) &body forms &environment env)
     1472  (multiple-value-bind (forms decls) (parse-body forms env nil)
     1473    `(let ((,var (%make-vector-input-stream ,vector ,start ,end ,external-format)))
     1474      ,@decls
     1475      (unwind-protect
     1476           (multiple-value-prog1
     1477               (progn ,@forms)
     1478             ,@(if index `((setf ,index (vector-input-stream-index ,var)))))
     1479        (close ,var)))))
     1480
    14711481(defmacro with-output-to-string ((var &optional string &key (element-type 'base-char element-type-p))
    14721482                                 &body body
    … …  
    14761486executed as an implicit progn with VAR bound to an output string stream.
    14771487All output to that string stream is saved in a string."
    1478   (let ((string-var (gensym "string")))
     1488  (let* ((string-p (not (null string))))
    14791489    (multiple-value-bind (forms decls) (parse-body body env nil)
    1480       `(let* ((,string-var ,string)
    1481               (,var (if ,string-var
    1482                       ,@(if element-type-p
    1483                             `((progn
    1484                                 ,element-type
    1485                                 (%make-string-output-stream ,string-var)))
    1486                             `((%make-string-output-stream ,string-var)))
    1487                       ,@(if element-type-p
    1488                             `((make-string-output-stream :element-type ,element-type))
    1489                             `((make-string-output-stream))))))
     1490      `(let* ((,var ,@(if string-p
     1491                          `((,@(if element-type-p
     1492                                   `((progn
     1493                                       ,element-type
     1494                                       (%make-string-output-stream ,string)))
     1495                                   `((%make-string-output-stream ,string)))))
     1496                          `((,@(if element-type-p
     1497                                   `((make-string-output-stream :element-type ,element-type))
     1498                                   `((make-string-output-stream))))))))
     1499        ,@decls
     1500        (unwind-protect
     1501             (progn
     1502               ,@forms
     1503               ,@(if string-p () `((get-output-stream-string ,var))))
     1504          (close ,var))))))
     1505
     1506(defmacro with-output-to-vector ((var &optional vector &key external-format)
     1507                                 &body body
     1508                                 &environment env)
     1509  (let* ((vector-p (not (null vector))))
     1510    (multiple-value-bind (forms decls) (parse-body body env nil)
     1511      `(let* ((,var ,@(if vector-p
     1512                          `((%make-vector-output-stream ,vector ,external-format))
     1513                          `((make-vector-output-stream :external-format ,external-format)))))
    14901514         ,@decls
    14911515         (unwind-protect
    14921516              (progn
    14931517                ,@forms
    1494                 ,@(if string () `((get-output-stream-string ,var))))
     1518                ,@(if vector-p () `((get-output-stream-vector ,var))))
    14951519           (close ,var))))))
    14961520

  • trunk/source/lib/misc.lisp

    r13401 r13454  
    12401240                        (return-from unwatch (%unwatch thing new)))))
    12411241                area-watched)))
     1242
     1243;;; read ULEB128, SLEB128-encoded integers from vectors of element-type
     1244;;; (UNSIGNED-BYTE 8).
     1245
     1246(defun parse-unsigned-integer (vector &optional (start 0) end)
     1247  (setq end (check-sequence-bounds vector start end))
     1248  (let* ((disp 0))
     1249    (declare (fixnum disp))
     1250    (unless (typep vector '(simple-array (unsigned-byte 8) (*)))
     1251      (multiple-value-bind (data offset) (array-data-and-offset vector)
     1252        (unless (typep data '(simple-array (unsigned-byte 8) (*)))
     1253          (report-bad-arg vector '(simple-array (unsigned-byte 8) (*))))
     1254        (incf start offset)
     1255        (incf end offset)
     1256        (setq disp offset)
     1257        (setq vector data)))
     1258    (locally
     1259        (declare (fixnum start end)
     1260                 ((simple-array (unsigned-byte 8) (*)) vector)
     1261                 (optimize (speed 3) (safety 0)))
     1262      (let* ((result 0))
     1263        (do* ((i start (1+ i))
     1264              (shift 0 (+ shift 7)))
     1265             ((= i end) (error "integer encoding error"))
     1266          (declare (fixnum i shift))
     1267          (let* ((b (aref vector i))
     1268                 (done (not (logbitp 7 b))))
     1269            (declare ((unsigned-byte 8) b))
     1270            (setq b (logand b #x7f)
     1271                  result (logior result (ash b shift)))
     1272            (when done (return (values result (the fixnum (- (the fixnum (1+ i)) disp)))))))))))
     1273
     1274(defun parse-signed-integer (vector &optional (start 0) end)
     1275  (setq end (check-sequence-bounds vector start end))
     1276  (let* ((disp 0))
     1277    (declare (fixnum disp))
     1278    (unless (typep vector '(simple-array (unsigned-byte 8) (*)))
     1279      (multiple-value-bind (data offset) (array-data-and-offset vector)
     1280        (unless (typep data '(simple-array (unsigned-byte 8) (*)))
     1281          (report-bad-arg vector '(simple-array (unsigned-byte 8) (*))))
     1282        (incf start offset)
     1283        (incf end offset)
     1284        (setq disp offset)
     1285        (setq vector data)))
     1286    (locally
     1287        (declare (fixnum start end)
     1288                 ((simple-array (unsigned-byte 8) (*)) vector)
     1289                 (optimize (speed 3) (safety 0)))
     1290      (let* ((result 0))
     1291        (do* ((i start (1+ i))
     1292              (shift 0 (+ shift 7)))
     1293             ((= i end) (error "integer encoding error"))
     1294          (declare (fixnum i shift))
     1295          (let* ((b (aref vector i))
     1296                 (done (not (logbitp 7 b))))
     1297            (declare ((unsigned-byte 8) b))
     1298            (setq b (logand b #x7f)
     1299                  result (logior result (ash b shift)))
     1300            (when done
     1301              (let* ((next (- (the fixnum (1+ i)) disp)))
     1302                (declare (fixnum next))
     1303                (if (logbitp 6 b)
     1304                  (return (values (logior result (ash -1 (the fixnum (+ shift 7)))) next))
     1305                  (return (values result next)))))))))))
Note: See TracChangeset for help on using the changeset viewer.