Bindat: new macro-expansion based data layout language

Thorough redesign of the Bindat system, which makes it possible
to define new Bindat type forms, define recursive types, control
the values returned when unpacking, freely mix arbitrary computations
with type definitions, as well as support for arbitrary sized
integers.

This also reverts the recent addition of the `bindat-spec` macro and
the support for 64bit integers in the old Bindat language since that
is now considered obsolete anyway.

* doc/lispref/processes.texi (Bindat Types): Rename from `Bindat Spec`
and rewrite for the new sublanguage.
(Bindat Functions): Adjust to the new terminology.
(Bindat Computed Types): New node.

* lisp/emacs-lisp/bindat.el (bindat--type): New type.
(bindat--unpack-u64, bindat--unpack-u64r): Delete functions.
(bindat--unpack-item, bindat--pack-item, bindat--fixed-length-alist):
Revert addition of support for 64bit integers.
(bindat--unpack-group, bindat--length-group, bindat--pack-group):
Handle the new `bindat--type` values.
(bindat-spec): Revert addition of this macro.
(bindat--unpack-uint, bindat--unpack-uintr, bindat--pack-uint)
(bindat--pack-uintr): New functions.
(bindat-type, bindat-defmacro, bindat--pcase): New macros.
(bindat-type): New Edebug elem.
(bindat--type): New generic function.
(bindat--primitives): New constant.
(bindat--macroenv, bindat--op): New vars.
(bindat--make-docstring, bindat--fun, bindat--makefun, bindat--toplevel):
New functions.

* test/lisp/emacs-lisp/bindat-tests.el: Use `bindat-type`.
(ip): New Bindat type.
(header-bindat-spec, data-bindat-spec, packet-bindat-spec): Adjust to
new `bindat-type` macro.
(bindat-test-unpack): Simplify now that the order of fields is preserved.
(bindat-test--int-websocket-type, bindat-test--LEB128): New consts.
(bindat-test--pack-val, bindat-test--sint, bindat-test--recursive):
New tests.

1 files changed, 74 insertions, 33 deletions

diff --git a/test/lisp/emacs-lisp/bindat-tests.el b/test/lisp/emacs-lisp/bindat-tests.el
index 9c417c855c7..911a5f0c7b1 100644
--- a/test/lisp/emacs-lisp/bindat-tests.el
+++ b/test/lisp/emacs-lisp/bindat-tests.el
@@ -23,29 +23,32 @@
 (require 'bindat)
 (require 'cl-lib)
 
+(bindat-defmacro ip () "An IPv4 address"     '(vec 4 byte))
+
 (defconst header-bindat-spec
-  (bindat-spec
+  (bindat-type
     (dest-ip ip)
     (src-ip ip)
-    (dest-port u16)
-    (src-port u16)))
+    (dest-port uint 16)
+    (src-port uint 16)))
 
 (defconst data-bindat-spec
-  (bindat-spec
+  (bindat-type
     (type u8)
     (opcode u8)
-    (length u16r) ;; little endian order
+    (length uintr 16) ;; little endian order
     (id strz 8)
-    (data vec (length))
-    (align 4)))
+    (data vec length)
+    (_ align 4)))
+
 
 (defconst packet-bindat-spec
-  (bindat-spec
-    (header struct header-bindat-spec)
+  (bindat-type
+    (header type header-bindat-spec)
     (items u8)
-    (fill 3)
-    (item repeat (items)
-          (struct data-bindat-spec))))
+    (_ fill 3)
+    (item repeat items
+          (_ type data-bindat-spec))))
 
 (defconst struct-bindat
   '((header
@@ -77,27 +80,7 @@
   (should (equal
            (bindat-unpack packet-bindat-spec
                           (bindat-pack packet-bindat-spec struct-bindat))
-           '((item
-              ((data .
-	             [1 2 3 4 5])
-               (id . "ABCDEF")
-               (length . 5)
-               (opcode . 3)
-               (type . 2))
-              ((data .
-	             [6 7 8 9 10 11 12])
-               (id . "BCDEFG")
-               (length . 7)
-               (opcode . 4)
-               (type . 1)))
-             (items . 2)
-             (header
-              (src-port . 5408)
-              (dest-port . 284)
-              (src-ip .
-	              [192 168 1 101])
-              (dest-ip .
-                       [192 168 1 100]))))))
+           struct-bindat)))
 
 (ert-deftest bindat-test-pack/multibyte-string-fails ()
   (should-error (bindat-pack nil nil "ö")))
@@ -121,4 +104,62 @@
   (should (equal (bindat-ip-to-string [192 168 0 1]) "192.168.0.1"))
   (should (equal (bindat-ip-to-string "\300\250\0\1") "192.168.0.1")))
 
+(defconst bindat-test--int-websocket-type
+  (bindat-type
+    :pack-var value
+    (n1 u8
+        :pack-val (if (< value 126) value (if (< value 65536) 126 127)))
+    (n2 uint (pcase n1 (127 64) (126 16) (_ 0))
+        :pack-val value)
+    :unpack-val (if (< n1 126) n1 n2)))
+
+(ert-deftest bindat-test--pack-val ()
+  ;; This is intended to test the :(un)pack-val feature that offers
+  ;; control over the unpacked representation of the data.
+  (dolist (n '(0 42 125 126 127 128 150 255 5000 65535 65536 8769786876))
+    (should
+     (equal (bindat-unpack bindat-test--int-websocket-type
+                           (bindat-pack bindat-test--int-websocket-type n))
+            n))))
+
+(ert-deftest bindat-test--sint ()
+  (dotimes (kind 32)
+    (let ((bitlen (* 8 (/ kind 2)))
+          (r (zerop (% kind 2))))
+      (dotimes (_ 100)
+        (let* ((n (random (ash 1 bitlen)))
+               (i (- n (ash 1 (1- bitlen)))))
+          (should (equal (bindat-unpack
+                          (bindat-type sint bitlen r)
+                          (bindat-pack (bindat-type sint bitlen r) i))
+                         i))
+          (when (>= i 0)
+            (should (equal (bindat-pack
+                            (bindat-type if r (uintr bitlen) (uint bitlen)) i)
+                           (bindat-pack (bindat-type sint bitlen r) i)))
+            (should (equal (bindat-unpack
+                            (bindat-type if r (uintr bitlen) (uint bitlen))
+                            (bindat-pack (bindat-type sint bitlen r) i))
+                           i))))))))
+
+(defconst bindat-test--LEB128
+  (bindat-type
+   letrec ((loop
+            (struct :pack-var n
+                    (head u8
+                          :pack-val (+ (logand n 127) (if (> n 127) 128 0)))
+                    (tail if (< head 128) (unit 0) loop
+                          :pack-val (ash n -7))
+                    :unpack-val (+ (logand head 127) (ash tail 7)))))
+   loop))
+
+(ert-deftest bindat-test--recursive ()
+  (dotimes (n 10)
+    (let ((max (ash 1 (* n 10))))
+      (dotimes (_ 10)
+        (let ((n (random max)))
+          (should (equal (bindat-unpack bindat-test--LEB128
+                                        (bindat-pack bindat-test--LEB128 n))
+                         n)))))))
+
 ;;; bindat-tests.el ends here