Changeset 13459 for trunk/source/level-1


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

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

STREAM-POSITION on vector streams.

File:
1 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
Note: See TracChangeset for help on using the changeset viewer.