erlang: binary pattern matching <<...>> (+21 tests)

lib/erlang/transpile.sx

@@ -24,6 +24,8 @@
 (define er-mk-nil (fn () {:tag "nil"}))
 (define er-mk-cons (fn (h t) {:tag "cons" :head h :tail t}))
 (define er-mk-tuple (fn (elems) {:tag "tuple" :elements elems}))
+(define er-mk-binary (fn (bytes) {:tag "binary" :bytes bytes}))
+(define er-binary? (fn (v) (er-is-tagged? v "binary")))
 (define er-bool (fn (b) (if b er-atom-true er-atom-false)))
 
 (define
@@ -124,6 +126,7 @@
         (= ty "receive") (er-eval-receive node env)
         (= ty "try") (er-eval-try node env)
         (= ty "lc") (er-eval-lc node env)
+        (= ty "binary") (er-eval-binary node env)
         (= ty "match") (er-eval-match node env)
         :else (error (str "Erlang eval: unsupported node type '" ty "'"))))))
 
@@ -195,6 +198,7 @@
         (= ty "nil") (er-nil? val)
         (= ty "tuple") (er-match-tuple pat val env)
         (= ty "cons") (er-match-cons pat val env)
+        (= ty "binary") (er-match-binary pat val env)
         :else (error (str "Erlang match: unsupported pattern type '" ty "'"))))))
 
 (define
@@ -240,6 +244,95 @@
         (er-match! (get pat :head) (get val :head) env)
         (er-match! (get pat :tail) (get val :tail) env)))))
 
+;; Match `<<Seg1, Seg2, ...>>` against a binary value. Walks the
+;; segment list left-to-right, consuming bytes from the front of the
+;; binary for each segment. Integer segments decode big-endian and
+;; bind/check the pattern; binary-spec segments without size capture
+;; the trailing bytes as a binary value.
+(define
+  er-match-binary
+  (fn
+    (pat val env)
+    (and
+      (er-binary? val)
+      (let
+        ((segs (get pat :segments)) (cursor (list 0)))
+        (and
+          (er-match-binary-segs segs val env cursor 0)
+          (= (nth cursor 0) (len (get val :bytes))))))))
+
+(define
+  er-match-binary-segs
+  (fn
+    (segs val env cursor i)
+    (cond
+      (>= i (len segs)) true
+      :else (let
+        ((seg (nth segs i)))
+        (let
+          ((spec (get seg :spec))
+            (size-node (get seg :size)))
+          (cond
+            (= spec "integer")
+            (er-match-binary-int seg val env cursor segs i)
+            (= spec "binary")
+            (er-match-binary-tail seg val env cursor segs i)
+            :else false))))))
+
+(define
+  er-match-binary-int
+  (fn
+    (seg val env cursor segs i)
+    (let
+      ((bits (cond
+               (= (get seg :size) nil) 8
+               :else (er-eval-expr (get seg :size) env))))
+      (cond
+        (or (not (= (remainder bits 8) 0)) (<= bits 0)) false
+        :else (let
+          ((nbytes (truncate (/ bits 8))) (bytes (get val :bytes)) (start (nth cursor 0)))
+          (cond
+            (> (+ start nbytes) (len bytes)) false
+            :else (let
+              ((decoded (er-decode-int bytes start nbytes)))
+              (set-nth! cursor 0 (+ start nbytes))
+              (and
+                (er-match! (get seg :value) decoded env)
+                (er-match-binary-segs segs val env cursor (+ i 1))))))))))
+
+(define
+  er-decode-int
+  (fn
+    (bytes start nbytes)
+    (let
+      ((acc (list 0)))
+      (for-each
+        (fn
+          (j)
+          (set-nth!
+            acc
+            0
+            (+ (* (nth acc 0) 256) (nth bytes (+ start j)))))
+        (range 0 nbytes))
+      (nth acc 0))))
+
+(define
+  er-match-binary-tail
+  (fn
+    (seg val env cursor segs i)
+    (cond
+      (not (= (get seg :size) nil)) false
+      (not (= (+ i 1) (len segs))) false
+      :else (let
+        ((bytes (get val :bytes))
+          (start (nth cursor 0))
+          (rest-bytes (list)))
+        (for-each
+          (fn (k) (append! rest-bytes (nth bytes k)))
+          (range start (len bytes)))
+        (set-nth! cursor 0 (len bytes))
+        (er-match! (get seg :value) (er-mk-binary rest-bytes) env)))))
+
 ;; ── env snapshot / restore ────────────────────────────────────────
 (define
   er-env-copy
@@ -375,6 +468,12 @@
       (and (= (type-of a) "string") (= (type-of b) "string")) (= a b)
       (and (er-pid? a) (er-pid? b)) (= (get a :id) (get b :id))
       (and (er-ref? a) (er-ref? b)) (= (get a :id) (get b :id))
+      (and (er-binary? a) (er-binary? b))
+      (let
+        ((ba (get a :bytes)) (bb (get b :bytes)))
+        (and
+          (= (len ba) (len bb))
+          (every? (fn (i) (= (nth ba i) (nth bb i))) (range 0 (len ba)))))
       :else false)))
 
 ;; Exact equality: 1 =/= 1.0 in Erlang.
@@ -589,6 +688,8 @@
       (= name "list_to_atom") (er-bif-list-to-atom vs)
       (= name "is_pid") (er-bif-is-pid vs)
       (= name "is_reference") (er-bif-is-reference vs)
+      (= name "is_binary") (er-bif-is-binary vs)
+      (= name "byte_size") (er-bif-byte-size vs)
       (= name "self") (er-bif-self vs)
       (= name "spawn") (er-bif-spawn vs)
       (= name "exit") (er-bif-exit vs)
@@ -696,6 +797,20 @@
       (er-bool
         (or (er-is-atom-named? v "true") (er-is-atom-named? v "false"))))))
 
+(define
+  er-bif-is-binary
+  (fn (vs) (er-bool (er-binary? (er-bif-arg1 vs "is_binary")))))
+
+(define
+  er-bif-byte-size
+  (fn
+    (vs)
+    (let
+      ((v (er-bif-arg1 vs "byte_size")))
+      (cond
+        (er-binary? v) (len (get v :bytes))
+        :else (raise (er-mk-error-marker (er-mk-atom "badarg")))))))
+
 ;; ── list / tuple BIFs ────────────────────────────────────────────
 (define er-bif-length (fn (vs) (er-list-length (er-bif-arg1 vs "length"))))
 
@@ -936,8 +1051,22 @@
       (er-fun? v) "#Fun"
       (er-pid? v) (str "<pid:" (get v :id) ">")
       (er-ref? v) (str "#Ref<" (get v :id) ">")
+      (er-binary? v) (str "<<" (er-format-bytes (get v :bytes)) ">>")
       :else (str v))))
 
+(define
+  er-format-bytes
+  (fn
+    (bs)
+    (cond
+      (= (len bs) 0) ""
+      :else (let
+        ((out (list (str (nth bs 0)))))
+        (for-each
+          (fn (i) (append! out ",") (append! out (str (nth bs i))))
+          (range 1 (len bs)))
+        (reduce str "" out)))))
+
 (define
   er-format-list-elems
   (fn
@@ -1363,3 +1492,81 @@
             (set-nth! acc 0 (er-mk-cons (nth xs j) (nth acc 0)))))
         (range 0 (len xs)))
       (nth acc 0))))
+
+;; ── binaries ────────────────────────────────────────────────────
+;; Each segment is `Value : Size / Spec`. Supported specs: `integer`
+;; (default; size in bits, must be multiple of 8 — 8/16/24/32 typical)
+;; and `binary` (concatenate the segment's binary value into the
+;; result). Default size for `integer` segments is 8 bits.
+(define
+  er-eval-binary
+  (fn
+    (node env)
+    (let
+      ((segs (get node :segments)) (out (list)))
+      (for-each
+        (fn (i) (er-eval-binary-segment (nth segs i) env out))
+        (range 0 (len segs)))
+      (er-mk-binary out))))
+
+(define
+  er-eval-binary-segment
+  (fn
+    (seg env out)
+    (let
+      ((spec (get seg :spec))
+        (val (er-eval-expr (get seg :value) env))
+        (size (er-eval-binary-size (get seg :size) env)))
+      (cond
+        (= spec "integer")
+        (let
+          ((bits (if (= size nil) 8 size)))
+          (er-emit-int! out val bits))
+        (= spec "binary")
+        (cond
+          (er-binary? val)
+          (for-each
+            (fn (i) (append! out (nth (get val :bytes) i)))
+            (range 0 (len (get val :bytes))))
+          :else (raise
+            (er-mk-error-marker (er-mk-atom "badarg"))))
+        :else (error
+          (str "Erlang: binary spec '" spec "' not supported"))))))
+
+(define
+  er-eval-binary-size
+  (fn
+    (node env)
+    (cond
+      (= node nil) nil
+      :else (er-eval-expr node env))))
+
+;; Big-endian byte emission for an N-bit integer (N must be multiple
+;; of 8). For bits=8 this is just `(append! out (mod v 256))`.
+(define
+  er-emit-int!
+  (fn
+    (out v bits)
+    (cond
+      (or (not (= (remainder bits 8) 0)) (<= bits 0))
+      (error
+        (str "Erlang: binary integer size must be a positive multiple of 8 (got " bits ")"))
+      :else (let
+        ((nbytes (truncate (/ bits 8))))
+        (for-each
+          (fn
+            (i)
+            (let
+              ((shift (* 8 (- (- nbytes 1) i))))
+              (append!
+                out
+                (remainder (truncate (/ v (er-int-pow 2 shift))) 256))))
+          (range 0 nbytes))))))
+
+(define
+  er-int-pow
+  (fn
+    (b e)
+    (cond
+      (= e 0) 1
+      :else (* b (er-int-pow b (- e 1))))))