Changeset 13459


Ignore:
Timestamp:
Feb 23, 2010, 6:24:05 AM (10 years ago)
Author:
gb
Message:

Replace LEB128 encoding of integers with fixed-width, big-endian
encoding.

STREAM-POSITION on vector streams.

Location:
trunk/source
Files:
2 edited

Legend:

Unmodified
Added
Removed
  • trunk/source/level-1/l1-streams.lisp

    r13454 r13459  
    62146214    new))
    62156215
    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)))))))))
     6216;;; return something equivalent to (LOGAND #xFF (ASH M (- (* N 8)))),
     6217;;; though try to do it more quickly.
     6218(declaim (inline nth-octet-of-signed-integer))
     6219(defun nth-octet-of-signed-integer (m n)
     6220  (declare (fixnum n))
     6221  (etypecase m
     6222    (fixnum
     6223     (locally
     6224         (declare (fixnum m))
     6225       (logand #xff (the fixnum (%iasr (the fixnum (ash n 3)) m)))))
     6226    (bignum
     6227     (let* ((nbytes (ash (the fixnum (uvsize m)) 2)))
     6228       (declare (fixnum nbytes))
     6229       (declare (type (simple-array (unsigned-byte 8) (*)) m)
     6230                (optimize (speed 3) (safety 0)))
     6231       (if (< n nbytes)
     6232         (aref m #+big-endian-target (the fixnum (logxor n 3)) #+little-endian-target n)
     6233         (if (logbitp 7 (the (unsigned-byte 8) (aref m (the fixnum (- nbytes #+big-endian-target 4 #+little-endian-target 1)))))
     6234           #xff
     6235           #x00))))))
     6236
     6237(declaim (inline nth-octet-of-unsigned-integer))
     6238(defun nth-octet-of-unsigned-integer (m n)
     6239  (declare (fixnum n))
     6240  (etypecase m
     6241    (fixnum
     6242     (locally
     6243         (declare (fixnum m))
     6244       (logand #xff (the fixnum (%ilsr (the fixnum (ash n 3)) m)))))
     6245    (bignum
     6246     (let* ((nbytes (ash (the fixnum (uvsize m)) 2)))
     6247       (declare (fixnum nbytes))
     6248       (declare (type (simple-array (unsigned-byte 8) (*)) m)
     6249                (optimize (speed 3) (safety 0)))
     6250       (if (< n nbytes)
     6251         (aref m #+big-endian-target (the fixnum (logxor n 3)) #+little-endian-target n)
     6252         0)))))
     6253
     6254
     6255(defun unsigned-integer-to-binary (value len s)
     6256  (declare (fixnum len))
     6257  (unless (and (typep s 'basic-stream)
     6258               (eq *vector-output-stream-class-wrapper*
     6259                   (basic-stream.wrapper s)))
     6260    (report-bad-arg s 'vector-input-stream))
     6261  (let* ((ioblock (basic-stream-ioblock s))
     6262         (outbuf (progn
     6263                   (check-ioblock-owner ioblock)
     6264                   (ioblock-outbuf ioblock)))
     6265         (idx (io-buffer-idx outbuf))
     6266         (limit (io-buffer-limit outbuf))
     6267         (buffer (io-buffer-buffer outbuf)))
     6268    (declare (fixnum idx limit)
     6269             ((simple-array (unsigned-byte 8) (*)) buffer)
     6270             (optimize (speed 3) (safety 0)))
     6271    (do* ((n (1- len) (1- n)))
     6272         ((< n 0) (progn
     6273                    (setf (io-buffer-idx outbuf) idx
     6274                          (io-buffer-count outbuf) idx)
     6275                    value))
     6276      (declare (fixnum n))
     6277      (when (= idx limit)
     6278        (%ioblock-force-output ioblock nil)
     6279        (setq limit (io-buffer-limit outbuf)
     6280              buffer (io-buffer-buffer outbuf)))
     6281      (setf (aref buffer idx) (nth-octet-of-unsigned-integer value n))
     6282      (incf idx))))
     6283
     6284(defun signed-integer-to-binary (value len s)
     6285  (declare (fixnum len))
     6286  (unless (and (typep s 'basic-stream)
     6287               (eq *vector-output-stream-class-wrapper*
     6288                   (basic-stream.wrapper s)))
     6289    (report-bad-arg s 'vector-input-stream))
     6290  (let* ((ioblock (basic-stream-ioblock s))
     6291         (outbuf (progn
     6292                   (check-ioblock-owner ioblock)
     6293                   (ioblock-outbuf ioblock)))
     6294         (idx (io-buffer-idx outbuf))
     6295         (limit (io-buffer-limit outbuf))
     6296         (buffer (io-buffer-buffer outbuf)))
     6297    (declare (fixnum idx limit)
     6298             ((simple-array (unsigned-byte 8) (*)) buffer)
     6299             (optimize (speed 3) (safety 0)))
     6300    (do* ((n (1- len) (1- n)))
     6301         ((< n 0) (progn
     6302                    (setf (io-buffer-idx outbuf) idx
     6303                          (io-buffer-count outbuf) idx)
     6304                    value))
     6305      (declare (fixnum n))
     6306      (when (= idx limit)
     6307        (%ioblock-force-output ioblock nil)
     6308        (setq limit (io-buffer-limit outbuf)
     6309              buffer (io-buffer-buffer outbuf)))
     6310      (setf (aref buffer idx) (nth-octet-of-signed-integer value n))
     6311      (incf idx))))
    62876312             
    62886313               
     
    63306355  (%make-vector-output-stream (make-array 64 :element-type '(unsigned-byte 8))  external-format))
    63316356
     6357(defmethod stream-position ((s vector-output-stream) &optional newpos)
     6358  (let* ((ioblock (basic-stream-ioblock s))
     6359         (outbuf (ioblock-outbuf ioblock))
     6360         (origin (vector-stream-ioblock-displacement ioblock)))
     6361    (declare (fixnum origin))
     6362    (if newpos
     6363      (if (and (typep newpos 'fixnum)
     6364               (> (the fixnum newpos) -1)
     6365               (< (the fixnum newpos) (the fixnum (+ origin (the fixnum (io-buffer-limit outbuf))))))
     6366        (let* ((scaled-new (+ origin (the fixnum newpos))))
     6367          (declare (fixnum scaled-new))
     6368          (setf (io-buffer-idx outbuf) scaled-new
     6369                (io-buffer-count outbuf) scaled-new)
     6370          newpos)
     6371        (report-bad-arg newpos `(integer 0 `(,(+ origin (the fixnum (io-buffer-limit outbuf)))))))
     6372      (the fixnum (- (the fixnum (io-buffer-idx outbuf)) origin)))))
     6373
    63326374(defun vector-input-stream-index (s)
    63336375  (unless (and (typep s 'basic-stream)
     
    64036445
    64046446
    6405 (defun pui-stream (s)
     6447(defun pui-stream (s count)
     6448  (declare (fixnum count))
    64066449  (unless (and (typep s 'basic-stream)
    64076450               (eq *vector-input-stream-class-wrapper*
     
    64136456                  (ioblock-inbuf ioblock)))
    64146457         (idx (io-buffer-idx inbuf))
     6458         (end (+ idx count))
    64156459         (limit (io-buffer-limit inbuf))
    64166460         (vector (io-buffer-buffer inbuf)))
    6417     (declare (fixnum idx limit)
     6461    (declare (fixnum idx limit end)
    64186462             ((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)
     6463    (if (< limit end)
     6464      (error "Integer decoding error"))
     6465    (let* ((result (%parse-unsigned-integer vector idx end)))
     6466      (setf (io-buffer-idx inbuf) end)
     6467      result)))
     6468
     6469(defun psi-stream (s count)
     6470  (declare (fixnum count))
    64356471  (unless (and (typep s 'basic-stream)
    64366472               (eq *vector-input-stream-class-wrapper*
     
    64426478                  (ioblock-inbuf ioblock)))
    64436479         (idx (io-buffer-idx inbuf))
     6480         (end (+ idx count))
    64446481         (limit (io-buffer-limit inbuf))
    64456482         (vector (io-buffer-buffer inbuf)))
    6446     (declare (fixnum idx limit)
     6483    (declare (fixnum idx limit end)
    64476484             ((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))))))))
     6485    (if (< limit end)
     6486      (error "Integer decoding error"))
     6487    (let* ((result (%parse-signed-integer vector idx end)))
     6488      (setf (io-buffer-idx inbuf) end)
     6489      result)))
     6490
     6491(defmethod stream-position ((s vector-input-stream) &optional newpos)
     6492  (let* ((ioblock (basic-stream-ioblock s))
     6493         (inbuf (ioblock-inbuf ioblock))
     6494         (origin (vector-stream-ioblock-displacement ioblock)))
     6495    (declare (fixnum origin))
     6496    (if newpos
     6497      (if (and (typep newpos 'fixnum)
     6498               (> (the fixnum newpos) -1)
     6499               (< (the fixnum newpos) (the fixnum (+ origin (the fixnum (io-buffer-limit inbuf))))))
     6500        (progn
     6501          (setf (io-buffer-idx inbuf) (the fixnum (+ origin (the fixnum newpos))))
     6502          newpos)
     6503        (report-bad-arg newpos `(integer 0 `(,(+ origin (the fixnum (io-buffer-limit inbuf)))))))
     6504      (the fixnum (- (the fixnum (io-buffer-idx inbuf)) origin)))))
    64646505
    64656506; end of L1-streams.lisp
  • trunk/source/lib/misc.lisp

    r13454 r13459  
    12411241                area-watched)))
    12421242
    1243 ;;; read ULEB128, SLEB128-encoded integers from vectors of element-type
    1244 ;;; (UNSIGNED-BYTE 8).
    1245 
     1243(defun %parse-unsigned-integer (vector start end)
     1244  (declare ((simple-array (unsigned-byte 8) (*)) vector)
     1245           (fixnum start end)
     1246           (optimize (speed 3) (safety 0)))
     1247  (let* ((count (- end start)))
     1248    (declare (fixnum count))
     1249    (cond
     1250      ((and (> count 4) (<= count 8))
     1251       (%stack-block ((buf 8))
     1252         (unless (= count 8) (setf (%%get-unsigned-longlong buf 0) 0))
     1253         (dotimes (i count (%%get-unsigned-longlong buf 0))
     1254           (decf end)
     1255           (setf (%get-unsigned-byte buf
     1256                                     #+little-endian-target i
     1257                                     #+big-endian-target (the fixnum (- 7 i)))
     1258                 (aref vector end)))))
     1259      ((= count 4)
     1260       (%stack-block ((buf 4))
     1261         (dotimes (i count (%get-unsigned-long buf))
     1262           (decf end)
     1263           (setf (%get-unsigned-byte buf
     1264                                     #+little-endian-target i
     1265                                     #+big-endian-target (the fixnum (- 3 i)))
     1266                 (aref vector end)))))
     1267      ((= count 2) (logior (the fixnum (ash (the (unsigned-byte 8) (aref vector start)) 8)) (the (unsigned-byte 8) (aref vector (the fixnum (1+ start))))))
     1268      ((= count 0) 0)
     1269      ((= count 1) (aref vector start))
     1270
     1271      ((= count 3) (logior (the fixnum (ash (the (unsigned-byte 8) (aref vector start)) 16))
     1272                           (the fixnum (logior (the fixnum (ash (the (unsigned-byte 8) (aref vector (the fixnum (1+ start)))) 8))
     1273                                               (aref vector (the fixnum (+ start 2)))))))
     1274      (t
     1275       (let* ((result 0))
     1276         (do* ((shift (ash (1- count) 8) (- shift 8))
     1277               (i start (1+ i)))
     1278              ((= i end) result)
     1279           (declare (fixnum i shift))
     1280           (setq result (logior result (ash (aref vector i) shift)))))))))
     1281 
     1282;;; Octets between START and N encode an unsigned integer in big-endian
     1283;;; byte order.
    12461284(defun parse-unsigned-integer (vector &optional (start 0) end)
    12471285  (setq end (check-sequence-bounds vector start end))
    1248   (let* ((disp 0))
    1249     (declare (fixnum disp))
     1286  (locally (declare (fixnum start end))
     1287      (unless (typep vector '(simple-array (unsigned-byte 8) (*)))
     1288        (multiple-value-bind (data offset) (array-data-and-offset vector)
     1289          (declare (fixnum offset))
     1290          (unless (typep data '(simple-array (unsigned-byte 8) (*)))
     1291            (report-bad-arg vector '(simple-array (unsigned-byte 8) (*))))
     1292          (incf start offset)
     1293          (incf end offset)
     1294          (setq vector data)))
     1295      (%parse-unsigned-integer vector start end)))
     1296
     1297(defun %parse-signed-integer (vector start end)
     1298  (declare ((simple-array (unsigned-byte 8) (*)) vector)
     1299           (fixnum start end)
     1300           (optimize (speed 3) (safety 0)))
     1301  (let* ((count (- end start)))
     1302    (declare (fixnum count))
     1303    (if (zerop count)
     1304      0
     1305      (let* ((sign-byte (aref vector start))
     1306             (negative (logbitp 7 sign-byte)))
     1307        (declare (fixnum sign-byte))
     1308        (if (> sign-byte 127)
     1309          (decf sign-byte 256))
     1310        (cond
     1311          ((and (> count 4) (<= count 8))
     1312           (%stack-block ((buf 8))
     1313             (unless (= 8 count)
     1314               (setf (%%get-signed-longlong buf 0)
     1315                     (if negative -1 0)))
     1316             (dotimes (i count (%%get-signed-longlong buf 0))
     1317               (decf end)
     1318               (setf (%get-unsigned-byte buf
     1319                                         #+little-endian-target i
     1320                                         #+big-endian-target (the fixnum (- 7 i)))
     1321                     (aref vector end)))))
     1322          ((= count 4)
     1323           (%stack-block ((buf 4))
     1324             (dotimes (i count (%get-signed-long buf))
     1325               (decf end)
     1326               (setf (%get-unsigned-byte buf
     1327                                         #+little-endian-target i
     1328                                         #+big-endian-target (the fixnum (- 3 i)))
     1329                     (aref vector end)))))             
     1330          ((= count 1) sign-byte)
     1331          ((= count 2) (logior (the fixnum (ash sign-byte 8))
     1332                               (the (unsigned-byte 8) (aref vector (the fixnum (1+ start))))))
     1333          ((= count 3)
     1334           (logior
     1335            (the fixnum (ash sign-byte 16))
     1336            (the fixnum (logior (the fixnum (ash (the (unsigned-byte 8) (aref vector (the fixnum (1+ start)))) 8))
     1337                                (the (unsigned-byte 8)
     1338                                  (aref vector (the fixnum (+ start 2))))))))
     1339          (t
     1340           (decf count)
     1341           (incf start)
     1342           (let* ((result (ash sign-byte (ash count 8))))
     1343             (do* ((shift (ash (1- count) 8) (- shift 8))
     1344                   (i start (1+ i)))
     1345                  ((= i end) result)
     1346               (declare (fixnum i shift))
     1347               (setq result (logior result (ash (aref vector i) shift)))))))))))
     1348
     1349(defun parse-signed-integer (vector &optional (start 0) end)
     1350  (setq end (check-sequence-bounds vector start end))
     1351  (locally (declare (fixnum start end))
    12501352    (unless (typep vector '(simple-array (unsigned-byte 8) (*)))
    12511353      (multiple-value-bind (data offset) (array-data-and-offset vector)
     1354        (declare (fixnum offset))
    12521355        (unless (typep data '(simple-array (unsigned-byte 8) (*)))
    12531356          (report-bad-arg vector '(simple-array (unsigned-byte 8) (*))))
    12541357        (incf start offset)
    12551358        (incf end offset)
    1256         (setq disp offset)
    12571359        (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)))))))))))
     1360    (%parse-signed-integer vector start end)))
Note: See TracChangeset for help on using the changeset viewer.