rose-ash/lib/erlang/tests/vm.sx

;; Phase 9 — stub VM opcode dispatcher tests.
;; Verifies the dispatcher shape (mirrors plans/sx-vm-opcode-extension.md
;; for when 9a integrates) and the three pattern-match opcodes (9b)
;; route to the correct er-match-* impl.

(define er-vm-test-count 0)
(define er-vm-test-pass 0)
(define er-vm-test-fails (list))

(define
  er-vm-test
  (fn
    (name actual expected)
    (set! er-vm-test-count (+ er-vm-test-count 1))
    (if
      (= actual expected)
      (set! er-vm-test-pass (+ er-vm-test-pass 1))
      (append! er-vm-test-fails {:name name :expected expected :actual actual}))))

;; ── dispatcher core ─────────────────────────────────────────────
(er-vm-test
  "tuple opcode registered"
  (= (er-vm-lookup-opcode-by-id 128) nil)
  false)

(er-vm-test
  "tuple opcode name"
  (get (er-vm-lookup-opcode-by-id 128) :name)
  "OP_PATTERN_TUPLE")

(er-vm-test
  "list opcode by name"
  (get (er-vm-lookup-opcode-by-name "OP_PATTERN_LIST") :id)
  129)

(er-vm-test
  "binary opcode by name"
  (get (er-vm-lookup-opcode-by-name "OP_PATTERN_BINARY") :id)
  130)

(er-vm-test "lookup miss by id" (er-vm-lookup-opcode-by-id 999) nil)

(er-vm-test "lookup miss by name" (er-vm-lookup-opcode-by-name "OP_NOPE") nil)

(er-vm-test
  "opcode list has 3+"
  (>= (len (er-vm-list-opcodes)) 3)
  true)

;; ── OP_PATTERN_TUPLE ────────────────────────────────────────────
;; Pattern: {ok, X} matches value {ok, 42} → X bound to 42
(define er-vm-t1-env (er-env-new))
(define er-vm-t1-pat {:type "tuple" :elements (list {:type "atom" :value "ok"} {:name "X" :type "var"})})
(define er-vm-t1-val (er-mk-tuple (list (er-mk-atom "ok") 42)))
(er-vm-test
  "OP_PATTERN_TUPLE match"
  (er-vm-dispatch 128 (list er-vm-t1-pat er-vm-t1-val er-vm-t1-env))
  true)
(er-vm-test "OP_PATTERN_TUPLE binds var" (get er-vm-t1-env "X") 42)

;; Same pattern against {error, ...} → false
(define er-vm-t2-env (er-env-new))
(define er-vm-t2-val (er-mk-tuple (list (er-mk-atom "error") 7)))
(er-vm-test
  "OP_PATTERN_TUPLE no-match"
  (er-vm-dispatch 128 (list er-vm-t1-pat er-vm-t2-val er-vm-t2-env))
  false)

;; Wrong arity tuple — pattern has 2 elements, value has 3
(define er-vm-t3-env (er-env-new))
(define
  er-vm-t3-val
  (er-mk-tuple (list (er-mk-atom "ok") 1 2)))
(er-vm-test
  "OP_PATTERN_TUPLE arity mismatch"
  (er-vm-dispatch 128 (list er-vm-t1-pat er-vm-t3-val er-vm-t3-env))
  false)

;; ── OP_PATTERN_LIST (cons) ──────────────────────────────────────
;; Pattern: [H | T] matches [1, 2, 3] → H=1, T=[2,3]
(define er-vm-l1-env (er-env-new))
(define er-vm-l1-pat {:type "cons" :tail {:name "T" :type "var"} :head {:name "H" :type "var"}})
(define
  er-vm-l1-val
  (er-mk-cons
    1
    (er-mk-cons 2 (er-mk-cons 3 (er-mk-nil)))))
(er-vm-test
  "OP_PATTERN_LIST match"
  (er-vm-dispatch 129 (list er-vm-l1-pat er-vm-l1-val er-vm-l1-env))
  true)
(er-vm-test "OP_PATTERN_LIST binds head" (get er-vm-l1-env "H") 1)
(er-vm-test
  "OP_PATTERN_LIST tail is cons"
  (er-cons? (get er-vm-l1-env "T"))
  true)

;; [H|T] against empty list → false
(define er-vm-l2-env (er-env-new))
(er-vm-test
  "OP_PATTERN_LIST no-match on nil"
  (er-vm-dispatch 129 (list er-vm-l1-pat (er-mk-nil) er-vm-l2-env))
  false)

;; ── OP_PATTERN_BINARY ───────────────────────────────────────────
;; Pattern <<A:8>> against <<42>> → A bound to 42
(define er-vm-b1-env (er-env-new))
(define er-vm-b1-pat {:type "binary" :segments (list {:value {:name "A" :type "var"} :size {:type "integer" :value "8"} :spec "integer"})})
(define er-vm-b1-val (er-mk-binary (list 42)))
(er-vm-test
  "OP_PATTERN_BINARY match"
  (er-vm-dispatch 130 (list er-vm-b1-pat er-vm-b1-val er-vm-b1-env))
  true)
(er-vm-test
  "OP_PATTERN_BINARY binds segment"
  (get er-vm-b1-env "A")
  42)

;; Same pattern against wrong-size binary (2 bytes) → false
(define er-vm-b2-env (er-env-new))
(define er-vm-b2-val (er-mk-binary (list 42 99)))
(er-vm-test
  "OP_PATTERN_BINARY size mismatch"
  (er-vm-dispatch 130 (list er-vm-b1-pat er-vm-b2-val er-vm-b2-env))
  false)

;; ── dispatch error path ────────────────────────────────────────
(define er-vm-err-caught (list nil))
(guard
  (c (:else (set-nth! er-vm-err-caught 0 (str c))))
  (er-vm-dispatch 999 (list)))
(er-vm-test
  "unknown opcode raises"
  (string-contains? (str (nth er-vm-err-caught 0)) "unknown opcode")
  true)


;; ── Phase 9c — OP_PERFORM / OP_HANDLE ───────────────────────────
(er-vm-test "perform opcode by id"
  (get (er-vm-lookup-opcode-by-id 131) :name) "OP_PERFORM")
(er-vm-test "handle opcode by id"
  (get (er-vm-lookup-opcode-by-id 132) :name) "OP_HANDLE")

(define er-vm-pf-caught (list nil))
(guard (c (:else (set-nth! er-vm-pf-caught 0 c)))
  (er-vm-dispatch 131 (list "yield" (list 42))))
(er-vm-test "perform raises tagged"
  (get (nth er-vm-pf-caught 0) :tag) "vm-effect")
(er-vm-test "perform effect name"
  (get (nth er-vm-pf-caught 0) :effect) "yield")
(er-vm-test "perform args carried"
  (nth (get (nth er-vm-pf-caught 0) :args) 0) 42)

(er-vm-test "handle catches matching effect"
  (er-vm-dispatch 132
    (list
      (fn () (er-vm-dispatch 131 (list "yield" (list 7))))
      "yield"
      (fn (args) (+ (nth args 0) 100))))
  107)

(er-vm-test "handle no-effect returns thunk result"
  (er-vm-dispatch 132
    (list
      (fn () 99)
      "yield"
      (fn (args) "handler ran")))
  99)

(define er-vm-rt-caught (list nil))
(guard (c (:else (set-nth! er-vm-rt-caught 0 c)))
  (er-vm-dispatch 132
    (list
      (fn () (er-vm-dispatch 131 (list "other" (list))))
      "yield"
      (fn (args) "wrong"))))
(er-vm-test "handle rethrows non-matching"
  (get (nth er-vm-rt-caught 0) :effect) "other")

(er-vm-test "nested handles separate effect names"
  (er-vm-dispatch 132
    (list
      (fn ()
        (er-vm-dispatch 132
          (list
            (fn () (er-vm-dispatch 131 (list "b" (list 5))))
            "a"
            (fn (args) "inner-handled"))))
      "b"
      (fn (args) (+ (nth args 0) 1000))))
  1005)

(define er-vm-test-summary (str "vm " er-vm-test-pass "/" er-vm-test-count))