Changeset 13510


Ignore:
Timestamp:
Mar 9, 2010, 12:20:16 PM (15 years ago)
Author:
gz
Message:

From trunk: bivalent vector streams (r13454 et. al.)

Location:
branches/working-0711/ccl
Files:
5 edited

Legend:

Unmodified
Added
Removed

  • branches/working-0711/ccl

  • branches/working-0711/ccl/level-1/l1-streams.lisp

    r13508 r13510  
    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
     6104(defparameter *vector-output-stream-default-initial-allocation* 64 "Default size of the vector created by (MAKE-VECTOR-OUTPUT-STREAM), in octets.")
     6105
     6106;;; Bivalent vector streams.
     6107(make-built-in-class 'vector-stream 'basic-binary-stream 'basic-character-stream)
     6108
     6109(defmethod print-object ((s vector-stream) out)
     6110  (print-unreadable-object (s out :type t :identity t)
     6111    (unless (open-stream-p s)  (format out " ~s" :closed))))
     6112
     6113
     6114(defstruct (vector-stream-ioblock (:include ioblock))
     6115  (displacement 0)                      ;displaced-index-offset
     6116  )
     6117
     6118(defstruct (vector-output-stream-ioblock (:include vector-stream-ioblock))
     6119  (line-length 80)                      ;for pretty-printer
     6120  displaced                             ;original vector if fill-pointer case
     6121 )
     6122
     6123(defstatic *vector-output-stream-class* (make-built-in-class 'vector-output-stream 'vector-stream 'basic-binary-output-stream 'basic-character-output-stream))
     6124(defstatic *vector-output-stream-class-wrapper* (%class-own-wrapper *vector-output-stream-class*))
     6125(defstatic *vector-input-stream-class* (make-built-in-class 'vector-input-stream 'vector-stream 'basic-binary-input-stream 'basic-character-input-stream))
     6126(defstatic *vector-input-stream-class-wrapper* (%class-own-wrapper *vector-input-stream-class*))
     6127
     6128(defmethod initialize-basic-stream :after ((s vector-stream) &key ioblock &allow-other-keys)
     6129  (setf (basic-stream.state s) ioblock))
     6130
     6131(defmethod stream-force-output ((s vector-output-stream)))
     6132
     6133(defmethod stream-finish-output ((s vector-output-stream)))
     6134
     6135
     6136
     6137(defun %extend-vector-output-stream (s ioblock count finish-p)
     6138  (declare (ignore s count finish-p))
     6139  (check-ioblock-owner ioblock)
     6140  (let* ((displaced (vector-output-stream-ioblock-displaced ioblock))
     6141         (outbuf (ioblock-outbuf ioblock)))
     6142    (cond (displaced
     6143           (let* ((flags (%svref displaced target::arrayH.flags-cell)))
     6144             (declare (fixnum flags))
     6145             (unless (logbitp $arh_adjp_bit flags)
     6146               (%err-disp $XMALADJUST displaced))
     6147             (let* ((len (%svref displaced target::vectorH.physsize-cell))
     6148                    (newlen (max (the fixnum (+ len len)) (+ len *vector-output-stream-default-initial-allocation*)))
     6149                    (new (%alloc-misc newlen target::subtag-u8-vector)))
     6150               (declare (fixnum len newlen)
     6151                        ((simple-array (unsigned-byte 8) (*)) new))
     6152               (multiple-value-bind (data offset)
     6153                   (%array-header-data-and-offset displaced)
     6154                 (declare ((simple-array (unsigned-byte 8) (*)) data)
     6155                          (fixnum offset))
     6156                 (%copy-ivector-to-ivector new 0 data offset len)
     6157                 (setf (vector-output-stream-ioblock-displacement ioblock) 0)
     6158                 (unless (= 0 offset)
     6159                   (setf (io-buffer-idx outbuf) len
     6160                         (io-buffer-count outbuf) len))
     6161                 (setf (io-buffer-limit outbuf) newlen
     6162                       (io-buffer-size outbuf) newlen
     6163                       (io-buffer-buffer outbuf) new)
     6164                 ;; Adjust the displaced vector.
     6165                 (setf (%svref displaced target::vectorH.data-vector-cell) new
     6166                       (%svref displaced target::vectorH.displacement-cell) 0
     6167                       (%svref displaced target::vectorH.physsize-cell) newlen
     6168                       (%svref displaced target::vectorH.flags-cell) (bitclr $arh_exp_disp_bit flags)
     6169                       (%svref displaced target::vectorH.logsize-cell) len)))))
     6170          (t
     6171           ;; Simpler. Honest.
     6172           (let* ((old (io-buffer-buffer outbuf))
     6173                  (len (length old))
     6174                  (newlen (max (the fixnum (+ len len)) 16))
     6175                  (new (%alloc-misc newlen target::subtag-u8-vector)))
     6176             (declare (fixnum len newlen)
     6177                      ((simple-array (unsigned-byte 8) (*)) old new))
     6178             (%copy-ivector-to-ivector new 0 old 0 len)
     6179             (setf (io-buffer-buffer outbuf) new
     6180                   (io-buffer-size outbuf) newlen
     6181                   (io-buffer-limit outbuf) newlen))))))
     6182
     6183(defun %vector-output-stream-close (s ioblock)
     6184  (declare (ignore s))
     6185  ;; If there's a displaced vector, fix its fill pointer.
     6186  (let* ((displaced (vector-output-stream-ioblock-displaced ioblock)))
     6187    (when displaced
     6188      (setf (%svref displaced target::vectorH.logsize-cell)
     6189            (the fixnum (- (the fixnum (io-buffer-count (ioblock-outbuf ioblock)))
     6190                           (the fixnum (vector-output-stream-ioblock-displacement ioblock))))))))
     6191
     6192(defmethod stream-line-length ((s vector-output-stream))
     6193  (let* ((ioblock (basic-stream-ioblock s)))
     6194    (string-output-stream-ioblock-line-length ioblock)))
     6195
     6196(defmethod (setf stream-line-length) (newlen (s vector-output-stream))
     6197  (let* ((ioblock (basic-stream-ioblock s)))
     6198    (setf (vector-output-stream-ioblock-line-length ioblock) newlen)))
     6199
     6200(defun get-output-stream-vector (s)
     6201  (unless (and (typep s 'basic-stream)
     6202               (eq *vector-output-stream-class-wrapper*
     6203                   (basic-stream.wrapper s)))
     6204    (report-bad-arg s 'vector-output-stream))
     6205  (let* ((ioblock (basic-stream-ioblock s))
     6206         (outbuf (progn
     6207                   (check-ioblock-owner ioblock)
     6208                   (ioblock-outbuf ioblock)))
     6209         (v (io-buffer-buffer outbuf))
     6210         (offset (vector-output-stream-ioblock-displacement ioblock))
     6211         (len (the fixnum (- (the fixnum (io-buffer-count outbuf)) offset)))
     6212         (new (%alloc-misc len target::subtag-u8-vector)))
     6213    (declare (fixnum offset len))
     6214    (%copy-ivector-to-ivector v offset new 0 len)
     6215    (setf (io-buffer-idx outbuf) offset
     6216          (io-buffer-count outbuf) offset)
     6217    new))
     6218
     6219
     6220(defun unsigned-integer-to-binary (value len s)
     6221  (declare (fixnum len))
     6222  (unless (and (typep s 'basic-stream)
     6223               (eq *vector-output-stream-class-wrapper*
     6224                   (basic-stream.wrapper s)))
     6225    (report-bad-arg s 'vector-input-stream))
     6226  (let* ((ioblock (basic-stream-ioblock s))
     6227         (outbuf (progn
     6228                   (check-ioblock-owner ioblock)
     6229                   (ioblock-outbuf ioblock)))
     6230         (idx (io-buffer-idx outbuf))
     6231         (limit (io-buffer-limit outbuf))
     6232         (buffer (io-buffer-buffer outbuf)))
     6233    (declare (fixnum idx limit)
     6234             ((simple-array (unsigned-byte 8) (*)) buffer)
     6235             (optimize (speed 3) (safety 0)))
     6236    (etypecase value
     6237      (fixnum
     6238       (if (< (the fixnum value) 0)
     6239         (report-bad-arg value 'unsigned-byte))
     6240       (do* ((shift (ash (the fixnum (1- len)) 3) (- shift 8)))
     6241            ((< shift 0) (progn
     6242                           (setf (io-buffer-idx outbuf) idx)
     6243                           (if (> idx (the fixnum (io-buffer-count outbuf)))
     6244                             (setf (io-buffer-count outbuf) idx))
     6245                           value))
     6246         (declare (fixnum shift))
     6247         (when (= idx limit)
     6248           (%ioblock-force-output ioblock nil)
     6249           (setq limit (io-buffer-limit outbuf)
     6250                 buffer (io-buffer-buffer outbuf)))
     6251         (setf (aref buffer idx) (logand #xff (the fixnum (%iasr shift value))))
     6252         (incf idx)))
     6253      (bignum
     6254       (locally
     6255           (declare ((simple-array (unsigned-byte 8) (*)) value))
     6256         (let* ((nbytes (ash (uvsize value) 2))
     6257                (sign-byte (if (logbitp 7 (the (unsigned-byte 8) (aref value (the fixnum (- nbytes #+big-endian-target 4 #+little-endian-target 1))))) #xff #x00)))
     6258           (declare (fixnum nbytes)
     6259                    ((unsigned-byte 8) sign-byte))
     6260           (unless (zerop sign-byte)
     6261             (report-bad-arg value 'unsigned-byte))
     6262           (do* ((n (1- len) (1- n)))
     6263                ((< n 0) (progn
     6264                           (setf (io-buffer-idx outbuf) idx)
     6265                           (if (> idx (the fixnum (io-buffer-count outbuf)))
     6266                             (setf (io-buffer-count outbuf) idx))
     6267                           value))
     6268             (declare (fixnum n))
     6269             (when (= idx limit)
     6270               (%ioblock-force-output ioblock nil)
     6271               (setq limit (io-buffer-limit outbuf)
     6272                     buffer (io-buffer-buffer outbuf)))
     6273             (setf (aref buffer idx)
     6274                   (if (>= n nbytes)
     6275                     0
     6276                     (aref value #+little-endian-target n #+big-endian-target (the fixnum (logxor n 3)))))
     6277             (incf idx))))))))
     6278
     6279(defun signed-integer-to-binary (value len s)
     6280  (declare (fixnum len))
     6281  (unless (and (typep s 'basic-stream)
     6282               (eq *vector-output-stream-class-wrapper*
     6283                   (basic-stream.wrapper s)))
     6284    (report-bad-arg s 'vector-input-stream))
     6285  (let* ((ioblock (basic-stream-ioblock s))
     6286         (outbuf (progn
     6287                   (check-ioblock-owner ioblock)
     6288                   (ioblock-outbuf ioblock)))
     6289         (idx (io-buffer-idx outbuf))
     6290         (limit (io-buffer-limit outbuf))
     6291         (buffer (io-buffer-buffer outbuf)))
     6292    (declare (fixnum idx limit)
     6293             ((simple-array (unsigned-byte 8) (*)) buffer)
     6294             (optimize (speed 3) (safety 0)))
     6295    (do* ((newidx (+ idx len)))
     6296         ((< newidx limit))
     6297      (declare (fixnum newidx))
     6298      (%ioblock-force-output ioblock nil)
     6299      (setq limit (io-buffer-limit outbuf)
     6300            buffer (io-buffer-buffer outbuf)))
     6301    (etypecase value
     6302      (fixnum
     6303       (do* ((shift (ash (the fixnum (1- len)) 3) (- shift 8)))
     6304            ((< shift 0) (progn
     6305                           (setf (io-buffer-idx outbuf) idx)
     6306                           (if (> idx (the fixnum (io-buffer-count outbuf)))
     6307                             (setf (io-buffer-count outbuf) idx))
     6308                           value))
     6309         (declare (fixnum shift))
     6310         (setf (aref buffer idx) (logand #xff (the fixnum (%iasr shift value))))
     6311         (incf idx)))
     6312      (bignum
     6313       (locally
     6314           (declare ((simple-array (unsigned-byte 8) (*)) value))
     6315         (let* ((nbytes (ash (uvsize value) 2))
     6316                (sign-byte (if (logbitp 7 (the (unsigned-byte 8) (aref value (the fixnum (- nbytes #+big-endian-target 4 #+little-endian-target 1))))) #xff #x00)))
     6317           (declare (fixnum nbytes)
     6318                    ((unsigned-byte 8) sign-byte))
     6319           (do* ((n (1- len) (1- n)))
     6320                ((< n 0) (progn
     6321                           (setf (io-buffer-idx outbuf) idx)
     6322                           (if (> idx (the fixnum (io-buffer-count outbuf)))
     6323                             (setf (io-buffer-count outbuf) idx))
     6324                           value))
     6325             (declare (fixnum n))
     6326             (setf (aref buffer idx)
     6327                   (if (>= n nbytes)
     6328                     sign-byte
     6329                     (aref value #+little-endian-target n #+big-endian-target (the fixnum (logxor n 3)))))
     6330             (incf idx))))))))
     6331     
     6332             
     6333               
     6334
     6335         
     6336
     6337(defun %make-vector-output-stream (vector external-format)
     6338  (let* ((data nil)
     6339         (len nil)
     6340         (offset 0)
     6341         (start 0)
     6342         (displaced nil)
     6343         (external-format (normalize-external-format t external-format))
     6344         (encoding (external-format-character-encoding external-format))
     6345         (line-termination (external-format-line-termination external-format)))
     6346    (cond ((typep vector '(simple-array (unsigned-byte 8) (*)))
     6347           (setq data vector len (length vector)))
     6348          (t
     6349           (multiple-value-setq (data offset) (array-data-and-offset vector))
     6350           (unless (eql (typecode data) target::subtag-u8-vector)
     6351             (report-bad-arg vector '(vector (unsigned-byte 8))))
     6352           (unless (array-has-fill-pointer-p vector)
     6353             (error "~S must be a vector with a fill pointer." vector))
     6354           (setq start (+ (fill-pointer vector) offset)
     6355                 len (+ (array-total-size vector) offset)
     6356                 displaced vector)))
     6357    (make-ioblock-stream *vector-output-stream-class*
     6358                         :ioblock (make-vector-output-stream-ioblock
     6359                                   :outbuf (make-io-buffer :buffer data
     6360                                                           :idx start
     6361                                                           :count start
     6362                                                           :limit len
     6363                                                           :size len)
     6364                                   :displaced displaced
     6365                                   :displacement offset)
     6366                         :encoding encoding
     6367                         :character-p t
     6368                         :element-type '(unsigned-byte 8)
     6369                         :line-termination line-termination
     6370                         :force-output-function '%extend-vector-output-stream
     6371                         :close-function '%vector-output-stream-close)))
     6372
     6373   
     6374(defun make-vector-output-stream (&key (external-format :default))
     6375  (%make-vector-output-stream (make-array *vector-output-stream-default-initial-allocation* :element-type '(unsigned-byte 8))  external-format))
     6376
     6377(defmethod stream-position ((s vector-output-stream) &optional newpos)
     6378  (let* ((ioblock (basic-stream-ioblock s))
     6379         (outbuf (ioblock-outbuf ioblock))
     6380         (origin (vector-stream-ioblock-displacement ioblock)))
     6381    (declare (fixnum origin))
     6382    (if newpos
     6383      (if (and (typep newpos 'fixnum)
     6384               (> (the fixnum newpos) -1)
     6385               (< (the fixnum newpos) (the fixnum (+ origin (the fixnum (io-buffer-limit outbuf))))))
     6386        (let* ((scaled-new (+ origin (the fixnum newpos))))
     6387          (declare (fixnum scaled-new))
     6388          (setf (io-buffer-idx outbuf) scaled-new)
     6389          (if (> (the fixnum (io-buffer-count outbuf)) scaled-new)
     6390            (setf (io-buffer-count outbuf) scaled-new))
     6391          (let* ((displaced (vector-output-stream-ioblock-displaced ioblock)))
     6392            (when displaced
     6393              (setf (fill-pointer displaced) newpos)))
     6394          newpos)
     6395        (report-bad-arg newpos `(integer 0 `(,(- (the fixnum (io-buffer-limit outbuf)) origin)))))
     6396      (the fixnum (- (the fixnum (io-buffer-idx outbuf)) origin)))))
     6397
     6398(defun vector-input-stream-index (s)
     6399  (unless (and (typep s 'basic-stream)
     6400               (eq *vector-input-stream-class-wrapper*
     6401                   (basic-stream.wrapper s)))
     6402    (report-bad-arg s 'vector-input-stream))
     6403  (let* ((ioblock (basic-stream-ioblock s)))
     6404    (check-ioblock-owner ioblock)
     6405    (the fixnum (- (the fixnum (io-buffer-idx (ioblock-inbuf ioblock)))
     6406                   (the fixnum (vector-stream-ioblock-displacement ioblock))))))
     6407           
     6408
     6409(defun %vector-input-stream-untyi (ioblock char)
     6410  (check-ioblock-owner ioblock)
     6411  (let* ((inbuf (ioblock-inbuf ioblock))
     6412         (idx (io-buffer-idx inbuf))
     6413         (encoding (ioblock-encoding ioblock))
     6414         (noctets (if encoding
     6415                    (funcall (character-encoding-character-size-in-octets-function encoding) char)
     6416                    1))
     6417         (newidx (- idx noctets)))
     6418    (declare (fixnum idx noctets newidx))
     6419    (if (>= newidx (the fixnum (vector-stream-ioblock-displacement ioblock)))
     6420      (setf (io-buffer-idx inbuf) newidx)
     6421      (error "Invalid attempt to unread ~s on ~s." char (ioblock-stream ioblock)))))
     6422
     6423 
     6424
     6425(defmethod select-stream-untyi-function ((s vector-input-stream) (direction t))
     6426  '%vector-input-stream-untyi)
     6427
     6428
     6429
     6430
     6431(defun %make-vector-input-stream (vector start end external-format)
     6432  (setq end (check-sequence-bounds vector start end))
     6433  (let* ((data nil)
     6434         (offset 0)
     6435         (external-format (normalize-external-format t external-format))
     6436         (encoding (external-format-character-encoding external-format))
     6437         (line-termination (external-format-line-termination external-format)))
     6438
     6439      (cond ((typep vector '(simple-array (unsigned-byte 8) (*)))
     6440             (setq data vector                   offset start))
     6441            (t (multiple-value-setq (data offset) (array-data-and-offset vector))
     6442               (unless (typep data '(simple-array (unsigned-byte 8) (*)))
     6443                 (report-bad-arg vector '(vector (unsigned-byte 8))))
     6444               (incf start offset)
     6445               (incf end offset)))
     6446      (make-ioblock-stream *vector-input-stream-class*
     6447                           :ioblock (make-vector-stream-ioblock
     6448                                     :inbuf (make-io-buffer
     6449                                             :buffer data
     6450                                             :idx start
     6451                                             :count end
     6452                                             :limit end
     6453                                             :size end)
     6454                                     :displacement start)
     6455                           :direction :input
     6456                           :character-p t
     6457                           :element-type '(unsigned-byte 8)
     6458                           :encoding encoding
     6459                           :line-termination line-termination
     6460                           :listen-function 'false
     6461                           :eofp-function 'true
     6462                           :advance-function 'false
     6463                           :close-function 'false)))
     6464     
     6465(defun make-vector-input-stream (vector &key (start 0) end external-format)
     6466  (%make-vector-input-stream vector start end external-format))
     6467
     6468
     6469
     6470
     6471(defun pui-stream (s count)
     6472  (declare (fixnum count))
     6473  (unless (and (typep s 'basic-stream)
     6474               (eq *vector-input-stream-class-wrapper*
     6475                   (basic-stream.wrapper s)))
     6476    (report-bad-arg s 'vector-input-stream))
     6477  (let* ((ioblock (basic-stream-ioblock s))
     6478         (inbuf (progn
     6479                  (check-ioblock-owner ioblock)
     6480                  (ioblock-inbuf ioblock)))
     6481         (idx (io-buffer-idx inbuf))
     6482         (end (+ idx count))
     6483         (limit (io-buffer-limit inbuf))
     6484         (vector (io-buffer-buffer inbuf)))
     6485    (declare (fixnum idx limit end)
     6486             ((simple-array (unsigned-byte 8) (*)) vector))
     6487    (if (< limit end)
     6488      (error "Integer decoding error"))
     6489    (let* ((result (%parse-unsigned-integer vector idx end)))
     6490      (setf (io-buffer-idx inbuf) end)
     6491      result)))
     6492
     6493(defun psi-stream (s count)
     6494  (declare (fixnum count))
     6495  (unless (and (typep s 'basic-stream)
     6496               (eq *vector-input-stream-class-wrapper*
     6497                   (basic-stream.wrapper s)))
     6498    (report-bad-arg s 'vector-input-stream))
     6499  (let* ((ioblock (basic-stream-ioblock s))
     6500         (inbuf (progn
     6501                  (check-ioblock-owner ioblock)
     6502                  (ioblock-inbuf ioblock)))
     6503         (idx (io-buffer-idx inbuf))
     6504         (end (+ idx count))
     6505         (limit (io-buffer-limit inbuf))
     6506         (vector (io-buffer-buffer inbuf)))
     6507    (declare (fixnum idx limit end))
     6508    (if (< limit end)
     6509      (error "Integer decoding error"))
     6510    (let* ((result (%parse-signed-integer vector idx end)))
     6511      (setf (io-buffer-idx inbuf) end)
     6512      result)))
     6513
     6514(defmethod stream-position ((s vector-input-stream) &optional newpos)
     6515  (let* ((ioblock (basic-stream-ioblock s))
     6516         (inbuf (ioblock-inbuf ioblock))
     6517         (origin (vector-stream-ioblock-displacement ioblock)))
     6518    (declare (fixnum origin))
     6519    (if newpos
     6520      (if (and (typep newpos 'fixnum)
     6521               (> (the fixnum newpos) -1)
     6522               (< (the fixnum newpos) (the fixnum (+ origin (the fixnum (io-buffer-limit inbuf))))))
     6523        (progn
     6524          (setf (io-buffer-idx inbuf) (the fixnum (+ origin (the fixnum newpos))))
     6525          newpos)
     6526        (report-bad-arg newpos `(integer 0 `(,(- (the fixnum (io-buffer-limit inbuf)) origin)))))
     6527      (the fixnum (- (the fixnum (io-buffer-idx inbuf)) origin)))))
     6528
    60866529; end of L1-streams.lisp

  • branches/working-0711/ccl/lib/ccl-export-syms.lisp

    r13505 r13510  
    709709     heap-utilization
    710710     collect-heap-utilization
    711 
     711     parse-unsigned-integer
     712     parse-signed-integer
     713     pui-stream
     714     psi-stream
     715     with-output-to-vector
     716     with-input-from-vector
     717     make-vector-output-stream
     718     make-vector-input-stream
     719     unsigned-integer-to-binary
     720     signed-integer-to-binary
     721     vector-input-stream
     722     vector-output-stream
     723     get-output-stream-vector 
     724     *vector-output-stream-default-initial-allocation*   
    712725     external-process-creation-failure
    713726

  • branches/working-0711/ccl/lib/macros.lisp

    r13236 r13510  
    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

  • branches/working-0711/ccl/lib/misc.lisp

    r13502 r13510  
    12811281                        (return-from unwatch (%unwatch thing new)))))
    12821282                area-watched)))
     1283
     1284(defun %parse-unsigned-integer (vector start end)
     1285  (declare ((simple-array (unsigned-byte 8) (*)) vector)
     1286           (fixnum start end)
     1287           (optimize (speed 3) (safety 0)))
     1288  (let* ((count (- end start))
     1289         (msb 0))
     1290    (declare (fixnum count) ((unsigned-byte 8) msb))
     1291    (or
     1292     (do* ((i start (1+ i)))
     1293          ((>= i end) 0)
     1294       (declare (fixnum i))
     1295       (let* ((b (aref vector i)))
     1296         (declare ((unsigned-byte 8) b))
     1297         (cond ((zerop b) (incf start) (decf count))
     1298               (t (setq msb b) (return)))))
     1299     (cond
     1300       ((or (< count #+64-bit-target 8 #+32-bit-target 4)
     1301            (and (= count #+64-bit-target 8 #+32-bit-target 4)
     1302                 (< msb #+64-bit-target 16 #+32-bit-target 32)))
     1303        ;; Result will be a fixnum.
     1304        (do* ((result 0)
     1305              (shift 0 (+ shift 8))
     1306              (i (1- end) (1- i)))
     1307             ((< i start) result)
     1308          (declare (fixnum result shift i))
     1309          (setq result (logior result (the fixnum (%ilsl shift (aref vector i)))))))
     1310       (t
     1311        ;; Result will be a bignum.  If COUNT is a multiple of 4
     1312        ;; and the most significant bit is set, need to add an
     1313        ;; extra word of zero-extension.
     1314        (let* ((result (allocate-typed-vector :bignum
     1315                                              (if (and (logbitp 7 msb)
     1316                                                       (zerop (the fixnum (logand count 3))))
     1317                                                (the fixnum (1+ (the fixnum (ash count -2))))
     1318                                                (the fixnum (ash (the fixnum (+ count 3)) -2))))))
     1319          (declare ((simple-array (unsigned-byte 8) (*)) result)) ; lie
     1320          (dotimes (i count result)
     1321            (decf end)
     1322            (setf (aref result
     1323                        #+little-endian-target i
     1324                        #+big-endian-target (the fixnum (logxor i 3)))
     1325                  (aref vector end)))))))))
     1326
     1327 
     1328;;; Octets between START and END encode an unsigned integer in big-endian
     1329;;; byte order.
     1330(defun parse-unsigned-integer (vector &optional (start 0) end)
     1331  (setq end (check-sequence-bounds vector start end))
     1332  (locally (declare (fixnum start end))
     1333      (unless (typep vector '(simple-array (unsigned-byte 8) (*)))
     1334        (multiple-value-bind (data offset) (array-data-and-offset vector)
     1335          (declare (fixnum offset))
     1336          (unless (typep data '(simple-array (unsigned-byte 8) (*)))
     1337            (report-bad-arg vector '(vector (unsigned-byte 8))))
     1338          (incf start offset)
     1339          (incf end offset)
     1340          (setq vector data)))
     1341      (%parse-unsigned-integer vector start end)))
     1342
     1343(defun %parse-signed-integer (vector start end)
     1344  (declare ((simple-array (unsigned-byte 8) (*)) vector)
     1345           (fixnum start end)
     1346           (optimize (speed 3) (safety 0)))
     1347  (let* ((count (- end start)))
     1348    (declare (fixnum count))
     1349    (if (zerop count)
     1350      0
     1351      (let* ((sign-byte (aref vector start)))
     1352        (declare (fixnum sign-byte))
     1353        (if (< sign-byte 128)
     1354          (%parse-unsigned-integer vector start end)
     1355          (progn
     1356            (decf sign-byte 256)
     1357            (or
     1358             (do* ()
     1359                  ((= count 1) sign-byte)
     1360               (unless (= sign-byte -1)
     1361                 (return))
     1362               (let* ((next (1+ start))
     1363                      (nextb (aref vector next)))
     1364                 (declare (fixnum next nextb))
     1365                 (if (not (logbitp 7 nextb))
     1366                   (return))
     1367                 (setq sign-byte (- nextb 256)
     1368                       start next
     1369                       count (1- count))))
     1370             (cond ((or (< count #+64-bit-target 8 #+32-bit-target 4)
     1371                        (and (= count #+64-bit-target 8 #+32-bit-target 4)
     1372                             (>= sign-byte
     1373                                 #+64-bit-target -16
     1374                                 #+32-bit-target -32)))
     1375                    ;; Result will be a fixnum
     1376                    (do* ((result 0)
     1377                          (shift 0 (+ shift 8))
     1378                          (i (1- end) (1- i)))
     1379                         ((= i start) (logior result (the fixnum (%ilsl shift sign-byte))))
     1380                      (declare (fixnum result shift i))
     1381                      (setq result (logior result (the fixnum (%ilsl shift (aref vector i)))))))
     1382                   (t
     1383                    (let* ((result (allocate-typed-vector :bignum (the fixnum (ash (the fixnum (+ count 3)) -2)))))
     1384          (declare ((simple-array (unsigned-byte 8) (*)) result)) ; lie
     1385          (dotimes (i count (do* ((i count (1+ i)))
     1386                                 ((= 0 (the fixnum (logand i 3)))
     1387                                  result)
     1388                              (declare (fixnum i))
     1389                              (setf (aref result
     1390                                          #+little-endian-target i
     1391                                          #+big-endian-target (the fixnum (logxor i 3))) #xff)))
     1392            (decf end)
     1393            (setf (aref result
     1394                        #+little-endian-target i
     1395                        #+big-endian-target (the fixnum (logxor i 3)))
     1396                  (aref vector end)))))))))))))
     1397
     1398(defun parse-signed-integer (vector &optional (start 0) end)
     1399  (setq end (check-sequence-bounds vector start end))
     1400  (locally (declare (fixnum start end))
     1401    (unless (typep vector '(simple-array (unsigned-byte 8) (*)))
     1402      (multiple-value-bind (data offset) (array-data-and-offset vector)
     1403        (declare (fixnum offset))
     1404        (unless (typep data '(simple-array (unsigned-byte 8) (*)))
     1405          (report-bad-arg vector '(vector (unsigned-byte 8))))
     1406        (incf start offset)
     1407        (incf end offset)
     1408        (setq vector data)))
     1409    (%parse-signed-integer vector start end)))
Note: See TracChangeset for help on using the changeset viewer.