Changeset 13459

Timestamp:

Feb 22, 2010, 10:24:05 PM (15 years ago)

Author:

Gary Byers

Message:

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

STREAM-POSITION on vector streams.

Location:

trunk/source

Files:

• level-1/l1-streams.lisp (modified) (5 diffs)
• lib/misc.lisp (modified) (1 diff)

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

@@ -6214 +6214 @@
     new))
 
-(defun unsigned-integer-to-binary (value s)
-  (if (< value 0)
-    (signed-integer-to-binary value s)
-    (progn
-      (unless (and (typep s 'basic-stream)
-                   (eq *vector-output-stream-class-wrapper*
-                       (basic-stream.wrapper s)))
-        (report-bad-arg s 'vector-input-stream))
-      (let* ((ioblock (basic-stream-ioblock s))
-             (outbuf (progn
-                       (check-ioblock-owner ioblock)
-                       (ioblock-outbuf ioblock)))
-             (idx (io-buffer-idx outbuf))
-             (limit (io-buffer-limit outbuf))
-             (buffer (io-buffer-buffer outbuf)))
-        (declare (fixnum idx limit)
-                 ((simple-array (unsigned-byte 8) (*)) buffer))
-        (loop
-          (let* ((b (logand value #x7f)))
-            (declare ((unsigned-byte 7) b))
-            (setq value (ash value -7))
-            (when (= idx limit)
-              (%ioblock-force-output ioblock nil)
-              (setq limit (io-buffer-limit outbuf)
-                    buffer (io-buffer-buffer outbuf)))
-            (if (eql 0 value)
-              (progn
-                (setf (aref buffer idx) b)
-                (incf idx)
-                (setf (io-buffer-idx outbuf) idx
-                      (io-buffer-count outbuf) idx)
-                (return))
-              (progn
-                (setf (aref buffer idx) (logior b #x80))
-                (incf idx)))))))))
-
-(defun signed-integer-to-binary (value s)
-  (if (< value 0)
-    (signed-integer-to-binary value s)
-    (progn
-      (unless (and (typep s 'basic-stream)
-                   (eq *vector-output-stream-class-wrapper*
-                       (basic-stream.wrapper s)))
-        (report-bad-arg s 'vector-input-stream))
-      (let* ((ioblock (basic-stream-ioblock s))
-             (outbuf (progn
-                       (check-ioblock-owner ioblock)
-                       (ioblock-outbuf ioblock)))
-             (idx (io-buffer-idx outbuf))
-             (limit (io-buffer-limit outbuf))
-             (buffer (io-buffer-buffer outbuf)))
-        (declare (fixnum idx limit)
-                 ((simple-array (unsigned-byte 8) (*)) buffer))
-        (loop
-          (let* ((b (logand value #x7f)))
-            (declare ((unsigned-byte 7) b))
-            (setq value (ash value -7))
-            (when (= idx limit)
-              (%ioblock-force-output ioblock nil)
-              (setq limit (io-buffer-limit outbuf)
-                    buffer (io-buffer-buffer outbuf)))
-            (if (eql -1 value)
-              (progn
-                (setf (aref buffer idx) b)
-                (incf idx)
-                (setf (io-buffer-idx outbuf) idx
-                      (io-buffer-count outbuf) idx)
-                (return))
-              (progn
-                (setf (aref buffer idx) (logior b #x80))
-                (incf idx)))))))))
+;;; return something equivalent to (LOGAND #xFF (ASH M (- (* N 8)))),
+;;; though try to do it more quickly.
+(declaim (inline nth-octet-of-signed-integer))
+(defun nth-octet-of-signed-integer (m n)
+  (declare (fixnum n))
+  (etypecase m
+    (fixnum
+     (locally
+         (declare (fixnum m))
+       (logand #xff (the fixnum (%iasr (the fixnum (ash n 3)) m)))))
+    (bignum
+     (let* ((nbytes (ash (the fixnum (uvsize m)) 2)))
+       (declare (fixnum nbytes))
+       (declare (type (simple-array (unsigned-byte 8) (*)) m)
+                (optimize (speed 3) (safety 0)))
+       (if (< n nbytes)
+         (aref m #+big-endian-target (the fixnum (logxor n 3)) #+little-endian-target n)
+         (if (logbitp 7 (the (unsigned-byte 8) (aref m (the fixnum (- nbytes #+big-endian-target 4 #+little-endian-target 1)))))
+           #xff
+           #x00))))))
+
+(declaim (inline nth-octet-of-unsigned-integer))
+(defun nth-octet-of-unsigned-integer (m n)
+  (declare (fixnum n))
+  (etypecase m
+    (fixnum
+     (locally
+         (declare (fixnum m))
+       (logand #xff (the fixnum (%ilsr (the fixnum (ash n 3)) m)))))
+    (bignum
+     (let* ((nbytes (ash (the fixnum (uvsize m)) 2)))
+       (declare (fixnum nbytes))
+       (declare (type (simple-array (unsigned-byte 8) (*)) m)
+                (optimize (speed 3) (safety 0)))
+       (if (< n nbytes)
+         (aref m #+big-endian-target (the fixnum (logxor n 3)) #+little-endian-target n)
+         0)))))
+
+
+(defun unsigned-integer-to-binary (value len s)
+  (declare (fixnum len))
+  (unless (and (typep s 'basic-stream)
+               (eq *vector-output-stream-class-wrapper*
+                   (basic-stream.wrapper s)))
+    (report-bad-arg s 'vector-input-stream))
+  (let* ((ioblock (basic-stream-ioblock s))
+         (outbuf (progn
+                   (check-ioblock-owner ioblock)
+                   (ioblock-outbuf ioblock)))
+         (idx (io-buffer-idx outbuf))
+         (limit (io-buffer-limit outbuf))
+         (buffer (io-buffer-buffer outbuf)))
+    (declare (fixnum idx limit)
+             ((simple-array (unsigned-byte 8) (*)) buffer)
+             (optimize (speed 3) (safety 0)))
+    (do* ((n (1- len) (1- n)))
+         ((< n 0) (progn
+                    (setf (io-buffer-idx outbuf) idx
+                          (io-buffer-count outbuf) idx)
+                    value))
+      (declare (fixnum n))
+      (when (= idx limit)
+        (%ioblock-force-output ioblock nil)
+        (setq limit (io-buffer-limit outbuf)
+              buffer (io-buffer-buffer outbuf)))
+      (setf (aref buffer idx) (nth-octet-of-unsigned-integer value n))
+      (incf idx))))
+
+(defun signed-integer-to-binary (value len s)
+  (declare (fixnum len))
+  (unless (and (typep s 'basic-stream)
+               (eq *vector-output-stream-class-wrapper*
+                   (basic-stream.wrapper s)))
+    (report-bad-arg s 'vector-input-stream))
+  (let* ((ioblock (basic-stream-ioblock s))
+         (outbuf (progn
+                   (check-ioblock-owner ioblock)
+                   (ioblock-outbuf ioblock)))
+         (idx (io-buffer-idx outbuf))
+         (limit (io-buffer-limit outbuf))
+         (buffer (io-buffer-buffer outbuf)))
+    (declare (fixnum idx limit)
+             ((simple-array (unsigned-byte 8) (*)) buffer)
+             (optimize (speed 3) (safety 0)))
+    (do* ((n (1- len) (1- n)))
+         ((< n 0) (progn
+                    (setf (io-buffer-idx outbuf) idx
+                          (io-buffer-count outbuf) idx)
+                    value))
+      (declare (fixnum n))
+      (when (= idx limit)
+        (%ioblock-force-output ioblock nil)
+        (setq limit (io-buffer-limit outbuf)
+              buffer (io-buffer-buffer outbuf)))
+      (setf (aref buffer idx) (nth-octet-of-signed-integer value n))
+      (incf idx))))
              
                
@@ -6330 +6355 @@
   (%make-vector-output-stream (make-array 64 :element-type '(unsigned-byte 8))  external-format))
 
+(defmethod stream-position ((s vector-output-stream) &optional newpos)
+  (let* ((ioblock (basic-stream-ioblock s))
+         (outbuf (ioblock-outbuf ioblock))
+         (origin (vector-stream-ioblock-displacement ioblock)))
+    (declare (fixnum origin))
+    (if newpos
+      (if (and (typep newpos 'fixnum)
+               (> (the fixnum newpos) -1)
+               (< (the fixnum newpos) (the fixnum (+ origin (the fixnum (io-buffer-limit outbuf))))))
+        (let* ((scaled-new (+ origin (the fixnum newpos))))
+          (declare (fixnum scaled-new))
+          (setf (io-buffer-idx outbuf) scaled-new
+                (io-buffer-count outbuf) scaled-new)
+          newpos)
+        (report-bad-arg newpos `(integer 0 `(,(+ origin (the fixnum (io-buffer-limit outbuf)))))))
+      (the fixnum (- (the fixnum (io-buffer-idx outbuf)) origin)))))
+
 (defun vector-input-stream-index (s)
   (unless (and (typep s 'basic-stream)
@@ -6403 +6445 @@
 
 
-(defun pui-stream (s)
+(defun pui-stream (s count)
+  (declare (fixnum count))
   (unless (and (typep s 'basic-stream)
                (eq *vector-input-stream-class-wrapper*
@@ -6413 +6456 @@
                   (ioblock-inbuf ioblock)))
          (idx (io-buffer-idx inbuf))
+         (end (+ idx count))
          (limit (io-buffer-limit inbuf))
          (vector (io-buffer-buffer inbuf)))
-    (declare (fixnum idx limit)
+    (declare (fixnum idx limit end)
              ((simple-array (unsigned-byte 8) (*)) vector))
-    (let* ((result 0))
-      (do* ((i idx (1+ i))
-            (shift 0 (+ shift 7)))
-           ((= i limit) (error "integer decoding error"))
-        (declare (fixnum i shift))
-        (let* ((b (aref vector i))
-               (done (not (logbitp 7 b))))
-          (declare ((unsigned-byte 8) b))
-          (setq b (logand b #x7f)
-                result (logior result (ash b shift)))
-          (incf idx)
-          (when done
-            (setf (io-buffer-idx inbuf) idx)
-            (return result)))))))
-
-(defun psi-stream (s)
+    (if (< limit end)
+      (error "Integer decoding error"))
+    (let* ((result (%parse-unsigned-integer vector idx end)))
+      (setf (io-buffer-idx inbuf) end)
+      result)))
+
+(defun psi-stream (s count)
+  (declare (fixnum count))
   (unless (and (typep s 'basic-stream)
                (eq *vector-input-stream-class-wrapper*
@@ -6442 +6478 @@
                   (ioblock-inbuf ioblock)))
          (idx (io-buffer-idx inbuf))
+         (end (+ idx count))
          (limit (io-buffer-limit inbuf))
          (vector (io-buffer-buffer inbuf)))
-    (declare (fixnum idx limit)
+    (declare (fixnum idx limit end)
              ((simple-array (unsigned-byte 8) (*)) vector))
-    (let* ((result 0))
-      (do* ((i idx (1+ i))
-            (shift 0 (+ shift 7)))
-           ((= i limit) (error "integer decoding error"))
-        (declare (fixnum i shift))
-        (let* ((b (aref vector i))
-               (done (not (logbitp 7 b))))
-          (declare ((unsigned-byte 8) b))
-          (setq b (logand b #x7f)
-                result (logior result (ash b shift)))
-          (incf idx)
-          (when done
-            (setf (io-buffer-idx inbuf) idx)
-            (if (logbitp 6 b)
-              (return (logior result (ash -1 (the fixnum (+ shift 7)))))
-              (return result))))))))
+    (if (< limit end)
+      (error "Integer decoding error"))
+    (let* ((result (%parse-signed-integer vector idx end)))
+      (setf (io-buffer-idx inbuf) end)
+      result)))
+
+(defmethod stream-position ((s vector-input-stream) &optional newpos)
+  (let* ((ioblock (basic-stream-ioblock s))
+         (inbuf (ioblock-inbuf ioblock))
+         (origin (vector-stream-ioblock-displacement ioblock)))
+    (declare (fixnum origin))
+    (if newpos
+      (if (and (typep newpos 'fixnum)
+               (> (the fixnum newpos) -1)
+               (< (the fixnum newpos) (the fixnum (+ origin (the fixnum (io-buffer-limit inbuf))))))
+        (progn
+          (setf (io-buffer-idx inbuf) (the fixnum (+ origin (the fixnum newpos))))
+          newpos)
+        (report-bad-arg newpos `(integer 0 `(,(+ origin (the fixnum (io-buffer-limit inbuf)))))))
+      (the fixnum (- (the fixnum (io-buffer-idx inbuf)) origin)))))
 
 ; end of L1-streams.lisp

trunk/source/lib/misc.lisp

@@ -1241 +1241 @@
                 area-watched)))
 
-;;; read ULEB128, SLEB128-encoded integers from vectors of element-type
-;;; (UNSIGNED-BYTE 8).
-
+(defun %parse-unsigned-integer (vector start end)
+  (declare ((simple-array (unsigned-byte 8) (*)) vector)
+           (fixnum start end)
+           (optimize (speed 3) (safety 0)))
+  (let* ((count (- end start)))
+    (declare (fixnum count))
+    (cond
+      ((and (> count 4) (<= count 8))
+       (%stack-block ((buf 8))
+         (unless (= count 8) (setf (%%get-unsigned-longlong buf 0) 0))
+         (dotimes (i count (%%get-unsigned-longlong buf 0))
+           (decf end)
+           (setf (%get-unsigned-byte buf
+                                     #+little-endian-target i
+                                     #+big-endian-target (the fixnum (- 7 i)))
+                 (aref vector end)))))
+      ((= count 4)
+       (%stack-block ((buf 4))
+         (dotimes (i count (%get-unsigned-long buf))
+           (decf end)
+           (setf (%get-unsigned-byte buf
+                                     #+little-endian-target i
+                                     #+big-endian-target (the fixnum (- 3 i)))
+                 (aref vector end)))))
+      ((= count 2) (logior (the fixnum (ash (the (unsigned-byte 8) (aref vector start)) 8)) (the (unsigned-byte 8) (aref vector (the fixnum (1+ start))))))
+      ((= count 0) 0)
+      ((= count 1) (aref vector start))
+
+      ((= count 3) (logior (the fixnum (ash (the (unsigned-byte 8) (aref vector start)) 16))
+                           (the fixnum (logior (the fixnum (ash (the (unsigned-byte 8) (aref vector (the fixnum (1+ start)))) 8))
+                                               (aref vector (the fixnum (+ start 2)))))))
+      (t
+       (let* ((result 0))
+         (do* ((shift (ash (1- count) 8) (- shift 8))
+               (i start (1+ i)))
+              ((= i end) result)
+           (declare (fixnum i shift))
+           (setq result (logior result (ash (aref vector i) shift)))))))))
+  
+;;; Octets between START and N encode an unsigned integer in big-endian
+;;; byte order.
 (defun parse-unsigned-integer (vector &optional (start 0) end)
   (setq end (check-sequence-bounds vector start end))
-  (let* ((disp 0))
-    (declare (fixnum disp))
+  (locally (declare (fixnum start end))
+      (unless (typep vector '(simple-array (unsigned-byte 8) (*)))
+        (multiple-value-bind (data offset) (array-data-and-offset vector)
+          (declare (fixnum offset))
+          (unless (typep data '(simple-array (unsigned-byte 8) (*)))
+            (report-bad-arg vector '(simple-array (unsigned-byte 8) (*))))
+          (incf start offset)
+          (incf end offset)
+          (setq vector data)))
+      (%parse-unsigned-integer vector start end)))
+
+(defun %parse-signed-integer (vector start end)
+  (declare ((simple-array (unsigned-byte 8) (*)) vector)
+           (fixnum start end)
+           (optimize (speed 3) (safety 0)))
+  (let* ((count (- end start)))
+    (declare (fixnum count))
+    (if (zerop count)
+      0
+      (let* ((sign-byte (aref vector start))
+             (negative (logbitp 7 sign-byte)))
+        (declare (fixnum sign-byte))
+        (if (> sign-byte 127)
+          (decf sign-byte 256))
+        (cond
+          ((and (> count 4) (<= count 8))
+           (%stack-block ((buf 8))
+             (unless (= 8 count)
+               (setf (%%get-signed-longlong buf 0)
+                     (if negative -1 0)))
+             (dotimes (i count (%%get-signed-longlong buf 0))
+               (decf end)
+               (setf (%get-unsigned-byte buf
+                                         #+little-endian-target i
+                                         #+big-endian-target (the fixnum (- 7 i)))
+                     (aref vector end)))))
+          ((= count 4)
+           (%stack-block ((buf 4))
+             (dotimes (i count (%get-signed-long buf))
+               (decf end)
+               (setf (%get-unsigned-byte buf
+                                         #+little-endian-target i
+                                         #+big-endian-target (the fixnum (- 3 i)))
+                     (aref vector end)))))              
+          ((= count 1) sign-byte)
+          ((= count 2) (logior (the fixnum (ash sign-byte 8))
+                               (the (unsigned-byte 8) (aref vector (the fixnum (1+ start))))))
+          ((= count 3)
+           (logior
+            (the fixnum (ash sign-byte 16))
+            (the fixnum (logior (the fixnum (ash (the (unsigned-byte 8) (aref vector (the fixnum (1+ start)))) 8))
+                                (the (unsigned-byte 8)
+                                  (aref vector (the fixnum (+ start 2))))))))
+          (t
+           (decf count)
+           (incf start)
+           (let* ((result (ash sign-byte (ash count 8))))
+             (do* ((shift (ash (1- count) 8) (- shift 8))
+                   (i start (1+ i)))
+                  ((= i end) result)
+               (declare (fixnum i shift))
+               (setq result (logior result (ash (aref vector i) shift)))))))))))
+
+(defun parse-signed-integer (vector &optional (start 0) end)
+  (setq end (check-sequence-bounds vector start end))
+  (locally (declare (fixnum start end))
     (unless (typep vector '(simple-array (unsigned-byte 8) (*)))
       (multiple-value-bind (data offset) (array-data-and-offset vector)
+        (declare (fixnum offset))
         (unless (typep data '(simple-array (unsigned-byte 8) (*)))
           (report-bad-arg vector '(simple-array (unsigned-byte 8) (*))))
         (incf start offset)
         (incf end offset)
-        (setq disp offset)
         (setq vector data)))
-    (locally
-        (declare (fixnum start end)
-                 ((simple-array (unsigned-byte 8) (*)) vector)
-                 (optimize (speed 3) (safety 0)))
-      (let* ((result 0))
-        (do* ((i start (1+ i))
-              (shift 0 (+ shift 7)))
-             ((= i end) (error "integer encoding error"))
-          (declare (fixnum i shift))
-          (let* ((b (aref vector i))
-                 (done (not (logbitp 7 b))))
-            (declare ((unsigned-byte 8) b))
-            (setq b (logand b #x7f)
-                  result (logior result (ash b shift)))
-            (when done (return (values result (the fixnum (- (the fixnum (1+ i)) disp)))))))))))
-
-(defun parse-signed-integer (vector &optional (start 0) end)
-  (setq end (check-sequence-bounds vector start end))
-  (let* ((disp 0))
-    (declare (fixnum disp))
-    (unless (typep vector '(simple-array (unsigned-byte 8) (*)))
-      (multiple-value-bind (data offset) (array-data-and-offset vector)
-        (unless (typep data '(simple-array (unsigned-byte 8) (*)))
-          (report-bad-arg vector '(simple-array (unsigned-byte 8) (*))))
-        (incf start offset)
-        (incf end offset)
-        (setq disp offset)
-        (setq vector data)))
-    (locally
-        (declare (fixnum start end)
-                 ((simple-array (unsigned-byte 8) (*)) vector)
-                 (optimize (speed 3) (safety 0)))
-      (let* ((result 0))
-        (do* ((i start (1+ i))
-              (shift 0 (+ shift 7)))
-             ((= i end) (error "integer encoding error"))
-          (declare (fixnum i shift))
-          (let* ((b (aref vector i))
-                 (done (not (logbitp 7 b))))
-            (declare ((unsigned-byte 8) b))
-            (setq b (logand b #x7f)
-                  result (logior result (ash b shift)))
-            (when done
-              (let* ((next (- (the fixnum (1+ i)) disp)))
-                (declare (fixnum next))
-                (if (logbitp 6 b)
-                  (return (values (logior result (ash -1 (the fixnum (+ shift 7)))) next))
-                  (return (values result next)))))))))))
+    (%parse-signed-integer vector start end)))