giles
a8cfd84f18
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Has been cancelled
1574 lines
45 KiB
Plaintext
1574 lines
45 KiB
Plaintext
;; Erlang sequential evaluator — tree-walking interpreter over the
|
|
;; parser AST. Phase 2 of plans/erlang-on-sx.md.
|
|
;;
|
|
;; Entry points:
|
|
;; (erlang-eval-ast SRC) -- parse body, eval, return last value
|
|
;; (er-eval-expr NODE ENV) -- evaluate one AST node
|
|
;; (er-eval-body NODES ENV) -- evaluate a comma-sequence, return last
|
|
;;
|
|
;; Runtime values:
|
|
;; integers / floats -> SX number
|
|
;; atoms -> {:tag "atom" :name <string>}
|
|
;; booleans -> atoms 'true' / 'false'
|
|
;; strings -> SX string (char-list semantics deferred)
|
|
;; empty list -> {:tag "nil"}
|
|
;; cons cell -> {:tag "cons" :head V :tail V}
|
|
;; tuple -> {:tag "tuple" :elements (list V ...)}
|
|
;;
|
|
;; Environment: mutable dict from variable name (string) to value.
|
|
|
|
;; ── value constructors / predicates ────────────────────────────────
|
|
(define er-mk-atom (fn (name) {:name name :tag "atom"}))
|
|
(define er-atom-true (er-mk-atom "true"))
|
|
(define er-atom-false (er-mk-atom "false"))
|
|
(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
|
|
er-is-tagged?
|
|
(fn (v tag) (and (= (type-of v) "dict") (= (get v :tag) tag))))
|
|
(define er-atom? (fn (v) (er-is-tagged? v "atom")))
|
|
(define er-nil? (fn (v) (er-is-tagged? v "nil")))
|
|
(define er-cons? (fn (v) (er-is-tagged? v "cons")))
|
|
(define er-tuple? (fn (v) (er-is-tagged? v "tuple")))
|
|
|
|
(define
|
|
er-is-atom-named?
|
|
(fn (v name) (and (er-atom? v) (= (get v :name) name))))
|
|
(define er-truthy? (fn (v) (er-is-atom-named? v "true")))
|
|
|
|
;; ── environment ───────────────────────────────────────────────────
|
|
(define er-env-new (fn () {}))
|
|
|
|
(define
|
|
er-env-lookup
|
|
(fn
|
|
(env name)
|
|
(if
|
|
(dict-has? env name)
|
|
(get env name)
|
|
(error (str "Erlang: unbound variable '" name "'")))))
|
|
|
|
(define er-env-bind! (fn (env name val) (dict-set! env name val)))
|
|
|
|
;; ── entry ─────────────────────────────────────────────────────────
|
|
(define
|
|
erlang-eval-ast
|
|
(fn
|
|
(src)
|
|
(let
|
|
((st (er-state-make (er-tokenize src))))
|
|
(let
|
|
((body (er-parse-body st)))
|
|
(er-sched-init!)
|
|
(let
|
|
((env (er-env-new)))
|
|
(let
|
|
((main-fun
|
|
(er-mk-fun
|
|
(list
|
|
{:patterns (list)
|
|
:body body
|
|
:guards (list)
|
|
:name nil})
|
|
env)))
|
|
(let
|
|
((main-proc (er-proc-new! env)))
|
|
(dict-set! main-proc :initial-fun main-fun)
|
|
(er-sched-run-all!)
|
|
(let
|
|
((main-pid (get main-proc :pid)))
|
|
(if
|
|
(not (= (er-proc-field main-pid :state) "dead"))
|
|
(error
|
|
"Erlang: deadlock — main process never terminated")
|
|
(er-proc-field main-pid :exit-result))))))))))
|
|
|
|
(define
|
|
er-eval-body
|
|
(fn
|
|
(exprs env)
|
|
(let
|
|
((last (list nil)))
|
|
(for-each
|
|
(fn (i) (set-nth! last 0 (er-eval-expr (nth exprs i) env)))
|
|
(range 0 (len exprs)))
|
|
(nth last 0))))
|
|
|
|
;; ── dispatch ──────────────────────────────────────────────────────
|
|
(define
|
|
er-eval-expr
|
|
(fn
|
|
(node env)
|
|
(let
|
|
((ty (get node :type)))
|
|
(cond
|
|
(= ty "integer") (parse-number (get node :value))
|
|
(= ty "float") (parse-number (get node :value))
|
|
(= ty "atom") (er-mk-atom (get node :value))
|
|
(= ty "string") (get node :value)
|
|
(= ty "nil") (er-mk-nil)
|
|
(= ty "var") (er-eval-var node env)
|
|
(= ty "tuple") (er-eval-tuple node env)
|
|
(= ty "cons") (er-eval-cons node env)
|
|
(= ty "op") (er-eval-op node env)
|
|
(= ty "unop") (er-eval-unop node env)
|
|
(= ty "block") (er-eval-body (get node :exprs) env)
|
|
(= ty "if") (er-eval-if node env)
|
|
(= ty "case") (er-eval-case node env)
|
|
(= ty "call") (er-eval-call node env)
|
|
(= ty "fun") (er-eval-fun node env)
|
|
(= ty "send") (er-eval-send node env)
|
|
(= 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 "'"))))))
|
|
|
|
(define
|
|
er-eval-var
|
|
(fn
|
|
(node env)
|
|
(let
|
|
((name (get node :name)))
|
|
(if
|
|
(= name "_")
|
|
(error "Erlang: '_' cannot be used as a value")
|
|
(er-env-lookup env name)))))
|
|
|
|
(define
|
|
er-eval-tuple
|
|
(fn
|
|
(node env)
|
|
(let
|
|
((out (list)))
|
|
(for-each
|
|
(fn
|
|
(i)
|
|
(append! out (er-eval-expr (nth (get node :elements) i) env)))
|
|
(range 0 (len (get node :elements))))
|
|
(er-mk-tuple out))))
|
|
|
|
(define
|
|
er-eval-cons
|
|
(fn
|
|
(node env)
|
|
(er-mk-cons
|
|
(er-eval-expr (get node :head) env)
|
|
(er-eval-expr (get node :tail) env))))
|
|
|
|
;; ── match expression ─────────────────────────────────────────────
|
|
(define
|
|
er-eval-match
|
|
(fn
|
|
(node env)
|
|
(let
|
|
((lhs (get node :lhs))
|
|
(rhs-val (er-eval-expr (get node :rhs) env)))
|
|
(if
|
|
(er-match! lhs rhs-val env)
|
|
rhs-val
|
|
(error "Erlang: badmatch")))))
|
|
|
|
;; ── pattern matching ─────────────────────────────────────────────
|
|
;; Unifies PAT against VAL, binding fresh vars into ENV.
|
|
;; Returns true on success, false otherwise. On failure ENV may hold
|
|
;; partial bindings — callers trying multiple clauses must snapshot
|
|
;; ENV and restore it between attempts.
|
|
(define
|
|
er-match!
|
|
(fn
|
|
(pat val env)
|
|
(let
|
|
((ty (get pat :type)))
|
|
(cond
|
|
(= ty "var") (er-match-var pat val env)
|
|
(= ty "integer")
|
|
(and (= (type-of val) "number") (= (parse-number (get pat :value)) val))
|
|
(= ty "float")
|
|
(and (= (type-of val) "number") (= (parse-number (get pat :value)) val))
|
|
(= ty "atom") (and (er-atom? val) (= (get val :name) (get pat :value)))
|
|
(= ty "string")
|
|
(and (= (type-of val) "string") (= val (get pat :value)))
|
|
(= 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
|
|
er-match-var
|
|
(fn
|
|
(pat val env)
|
|
(let
|
|
((name (get pat :name)))
|
|
(cond
|
|
(= name "_") true
|
|
(dict-has? env name) (er-equal? (get env name) val)
|
|
:else (do (er-env-bind! env name val) true)))))
|
|
|
|
(define
|
|
er-match-tuple
|
|
(fn
|
|
(pat val env)
|
|
(and
|
|
(er-tuple? val)
|
|
(let
|
|
((ps (get pat :elements)) (vs (get val :elements)))
|
|
(if (not (= (len ps) (len vs))) false (er-match-all ps vs 0 env))))))
|
|
|
|
(define
|
|
er-match-all
|
|
(fn
|
|
(ps vs i env)
|
|
(if
|
|
(>= i (len ps))
|
|
true
|
|
(if
|
|
(er-match! (nth ps i) (nth vs i) env)
|
|
(er-match-all ps vs (+ i 1) env)
|
|
false))))
|
|
|
|
(define
|
|
er-match-cons
|
|
(fn
|
|
(pat val env)
|
|
(and
|
|
(er-cons? val)
|
|
(and
|
|
(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
|
|
(fn
|
|
(env)
|
|
(let
|
|
((out {}))
|
|
(for-each (fn (k) (dict-set! out k (get env k))) (keys env))
|
|
out)))
|
|
|
|
(define
|
|
er-env-restore!
|
|
(fn
|
|
(env snap)
|
|
(for-each (fn (k) (dict-delete! env k)) (keys env))
|
|
(for-each (fn (k) (dict-set! env k (get snap k))) (keys snap))))
|
|
|
|
;; ── case ─────────────────────────────────────────────────────────
|
|
(define
|
|
er-eval-case
|
|
(fn
|
|
(node env)
|
|
(let
|
|
((subject (er-eval-expr (get node :expr) env)))
|
|
(er-eval-case-clauses (get node :clauses) 0 subject env))))
|
|
|
|
(define
|
|
er-eval-case-clauses
|
|
(fn
|
|
(clauses i subject env)
|
|
(if
|
|
(>= i (len clauses))
|
|
(error "Erlang: case_clause: no matching clause")
|
|
(let
|
|
((c (nth clauses i)) (snap (er-env-copy env)))
|
|
(if
|
|
(and
|
|
(er-match! (get c :pattern) subject env)
|
|
(er-eval-guards (get c :guards) env))
|
|
(er-eval-body (get c :body) env)
|
|
(do
|
|
(er-env-restore! env snap)
|
|
(er-eval-case-clauses clauses (+ i 1) subject env)))))))
|
|
|
|
;; ── operators ─────────────────────────────────────────────────────
|
|
(define
|
|
er-eval-op
|
|
(fn
|
|
(node env)
|
|
(let
|
|
((op (get node :op)) (args (get node :args)))
|
|
(cond
|
|
(= op "andalso") (er-eval-andalso args env)
|
|
(= op "orelse") (er-eval-orelse args env)
|
|
:else (er-apply-binop
|
|
op
|
|
(er-eval-expr (nth args 0) env)
|
|
(er-eval-expr (nth args 1) env))))))
|
|
|
|
(define
|
|
er-eval-andalso
|
|
(fn
|
|
(args env)
|
|
(let
|
|
((a (er-eval-expr (nth args 0) env)))
|
|
(if (er-truthy? a) (er-eval-expr (nth args 1) env) a))))
|
|
|
|
(define
|
|
er-eval-orelse
|
|
(fn
|
|
(args env)
|
|
(let
|
|
((a (er-eval-expr (nth args 0) env)))
|
|
(if (er-truthy? a) a (er-eval-expr (nth args 1) env)))))
|
|
|
|
(define
|
|
er-apply-binop
|
|
(fn
|
|
(op a b)
|
|
(cond
|
|
(= op "+") (+ a b)
|
|
(= op "-") (- a b)
|
|
(= op "*") (* a b)
|
|
(= op "/") (/ a b)
|
|
(= op "div") (truncate (/ a b))
|
|
(= op "rem") (remainder a b)
|
|
(= op "==") (er-bool (er-equal? a b))
|
|
(= op "/=") (er-bool (not (er-equal? a b)))
|
|
(= op "=:=") (er-bool (er-exact-equal? a b))
|
|
(= op "=/=") (er-bool (not (er-exact-equal? a b)))
|
|
(= op "<") (er-bool (er-lt? a b))
|
|
(= op ">") (er-bool (er-lt? b a))
|
|
(= op "=<") (er-bool (not (er-lt? b a)))
|
|
(= op ">=") (er-bool (not (er-lt? a b)))
|
|
(= op "++") (er-list-append a b)
|
|
(= op "and") (er-bool (and (er-truthy? a) (er-truthy? b)))
|
|
(= op "or") (er-bool (or (er-truthy? a) (er-truthy? b)))
|
|
:else (error (str "Erlang eval: unsupported operator '" op "'")))))
|
|
|
|
(define
|
|
er-eval-unop
|
|
(fn
|
|
(node env)
|
|
(let
|
|
((op (get node :op)) (a (er-eval-expr (get node :arg) env)))
|
|
(cond
|
|
(= op "-") (- 0 a)
|
|
(= op "+") a
|
|
(= op "not") (er-bool (not (er-truthy? a)))
|
|
:else (error (str "Erlang eval: unsupported unary '" op "'"))))))
|
|
|
|
;; ── equality / comparison ─────────────────────────────────────────
|
|
(define
|
|
er-equal?
|
|
(fn
|
|
(a b)
|
|
(cond
|
|
(and (= (type-of a) "number") (= (type-of b) "number")) (= a b)
|
|
(and (er-atom? a) (er-atom? b)) (= (get a :name) (get b :name))
|
|
(and (er-nil? a) (er-nil? b)) true
|
|
(and (er-cons? a) (er-cons? b))
|
|
(and
|
|
(er-equal? (get a :head) (get b :head))
|
|
(er-equal? (get a :tail) (get b :tail)))
|
|
(and (er-tuple? a) (er-tuple? b))
|
|
(let
|
|
((ea (get a :elements)) (eb (get b :elements)))
|
|
(and
|
|
(= (len ea) (len eb))
|
|
(every?
|
|
(fn (i) (er-equal? (nth ea i) (nth eb i)))
|
|
(range 0 (len ea)))))
|
|
(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.
|
|
(define
|
|
er-exact-equal?
|
|
(fn
|
|
(a b)
|
|
(if
|
|
(and (= (type-of a) "number") (= (type-of b) "number"))
|
|
(and (= (integer? a) (integer? b)) (= a b))
|
|
(er-equal? a b))))
|
|
|
|
(define
|
|
er-lt?
|
|
(fn
|
|
(a b)
|
|
(cond
|
|
(and (= (type-of a) "number") (= (type-of b) "number")) (< a b)
|
|
(and (er-atom? a) (er-atom? b)) (< (get a :name) (get b :name))
|
|
(and (= (type-of a) "string") (= (type-of b) "string")) (< a b)
|
|
:else (< (er-type-order a) (er-type-order b)))))
|
|
|
|
(define
|
|
er-type-order
|
|
(fn
|
|
(v)
|
|
(cond
|
|
(= (type-of v) "number") 0
|
|
(er-atom? v) 1
|
|
(er-tuple? v) 2
|
|
(er-nil? v) 3
|
|
(er-cons? v) 3
|
|
(= (type-of v) "string") 4
|
|
(er-pid? v) 5
|
|
:else 6)))
|
|
|
|
(define
|
|
er-list-append
|
|
(fn
|
|
(a b)
|
|
(cond
|
|
(er-nil? a) b
|
|
(er-cons? a)
|
|
(er-mk-cons (get a :head) (er-list-append (get a :tail) b))
|
|
:else (error "Erlang: ++ left argument is not a proper list"))))
|
|
|
|
;; ── if ────────────────────────────────────────────────────────────
|
|
(define er-eval-if (fn (node env) (er-eval-if-clauses (get node :clauses) 0 env)))
|
|
|
|
(define
|
|
er-eval-if-clauses
|
|
(fn
|
|
(clauses i env)
|
|
(if
|
|
(>= i (len clauses))
|
|
(error "Erlang: if: no clause matched")
|
|
(let
|
|
((c (nth clauses i)))
|
|
(if
|
|
(er-eval-guards (get c :guards) env)
|
|
(er-eval-body (get c :body) env)
|
|
(er-eval-if-clauses clauses (+ i 1) env))))))
|
|
|
|
;; Guards: outer list = OR, inner list = AND. Empty outer = always pass.
|
|
(define
|
|
er-eval-guards
|
|
(fn
|
|
(alts env)
|
|
(if (= (len alts) 0) true (er-eval-guards-any alts 0 env))))
|
|
|
|
(define
|
|
er-eval-guards-any
|
|
(fn
|
|
(alts i env)
|
|
(if
|
|
(>= i (len alts))
|
|
false
|
|
(if
|
|
(er-eval-guard-conj (nth alts i) env)
|
|
true
|
|
(er-eval-guards-any alts (+ i 1) env)))))
|
|
|
|
(define er-eval-guard-conj (fn (conj env) (er-eval-guard-conj-iter conj 0 env)))
|
|
|
|
(define
|
|
er-eval-guard-conj-iter
|
|
(fn
|
|
(conj i env)
|
|
(if
|
|
(>= i (len conj))
|
|
true
|
|
(if
|
|
(er-truthy? (er-eval-expr (nth conj i) env))
|
|
(er-eval-guard-conj-iter conj (+ i 1) env)
|
|
false))))
|
|
|
|
;; ── function calls ───────────────────────────────────────────────
|
|
(define
|
|
er-eval-call
|
|
(fn
|
|
(node env)
|
|
(let
|
|
((fun-node (get node :fun)) (args (get node :args)))
|
|
(cond
|
|
(= (get fun-node :type) "atom")
|
|
(let
|
|
((name (get fun-node :value)) (vs (er-eval-args args env)))
|
|
(cond
|
|
(and (dict-has? env name) (er-fun? (get env name)))
|
|
(er-apply-fun (get env name) vs)
|
|
:else (er-apply-bif name vs)))
|
|
(= (get fun-node :type) "remote")
|
|
(let
|
|
((mod-name (er-resolve-call-name (get fun-node :mod) env "module"))
|
|
(fn-name (er-resolve-call-name (get fun-node :fun) env "function")))
|
|
(er-apply-remote-bif mod-name fn-name (er-eval-args args env)))
|
|
:else
|
|
(let
|
|
((fv (er-eval-expr fun-node env)))
|
|
(if
|
|
(er-fun? fv)
|
|
(er-apply-fun fv (er-eval-args args env))
|
|
(error "Erlang: not a function")))))))
|
|
|
|
(define
|
|
er-eval-args
|
|
(fn
|
|
(args env)
|
|
(let
|
|
((out (list)))
|
|
(for-each
|
|
(fn (i) (append! out (er-eval-expr (nth args i) env)))
|
|
(range 0 (len args)))
|
|
out)))
|
|
|
|
;; Resolve a remote call's module/function reference into a string.
|
|
;; Atom AST nodes use their `:value` directly. For any other shape
|
|
;; (typically a var or another expression), evaluate it and require
|
|
;; the result to be an atom.
|
|
(define
|
|
er-resolve-call-name
|
|
(fn
|
|
(node env kind)
|
|
(cond
|
|
(= (get node :type) "atom") (get node :value)
|
|
:else (let
|
|
((v (er-eval-expr node env)))
|
|
(if
|
|
(er-atom? v)
|
|
(get v :name)
|
|
(error
|
|
(str "Erlang: call " kind " must be an atom, got " (er-format-value v))))))))
|
|
|
|
;; ── fun values ───────────────────────────────────────────────────
|
|
(define
|
|
er-mk-fun
|
|
(fn (clauses env) {:env env :clauses clauses :tag "fun"}))
|
|
(define er-fun? (fn (v) (er-is-tagged? v "fun")))
|
|
|
|
(define
|
|
er-eval-fun
|
|
(fn (node env) (er-mk-fun (get node :clauses) env)))
|
|
|
|
(define
|
|
er-apply-fun
|
|
(fn
|
|
(fv vs)
|
|
(er-apply-fun-clauses (get fv :clauses) vs (get fv :env) 0)))
|
|
|
|
(define
|
|
er-apply-fun-clauses
|
|
(fn
|
|
(clauses vs closure-env i)
|
|
(if
|
|
(>= i (len clauses))
|
|
(error "Erlang: function_clause: no matching fun clause")
|
|
(let
|
|
((c (nth clauses i))
|
|
(ps (get c :patterns))
|
|
(call-env (er-env-copy closure-env)))
|
|
(if
|
|
(not (= (len ps) (len vs)))
|
|
(er-apply-fun-clauses clauses vs closure-env (+ i 1))
|
|
(if
|
|
(and
|
|
(er-match-all ps vs 0 call-env)
|
|
(er-eval-guards (get c :guards) call-env))
|
|
(er-eval-body (get c :body) call-env)
|
|
(er-apply-fun-clauses clauses vs closure-env (+ i 1))))))))
|
|
|
|
;; ── BIFs ─────────────────────────────────────────────────────────
|
|
(define er-atom-ok (er-mk-atom "ok"))
|
|
|
|
(define
|
|
er-apply-bif
|
|
(fn
|
|
(name vs)
|
|
(cond
|
|
(= name "is_integer") (er-bif-is-integer vs)
|
|
(= name "is_atom") (er-bif-is-atom vs)
|
|
(= name "is_list") (er-bif-is-list vs)
|
|
(= name "is_tuple") (er-bif-is-tuple vs)
|
|
(= name "is_number") (er-bif-is-number vs)
|
|
(= name "is_float") (er-bif-is-float vs)
|
|
(= name "is_boolean") (er-bif-is-boolean vs)
|
|
(= name "length") (er-bif-length vs)
|
|
(= name "hd") (er-bif-hd vs)
|
|
(= name "tl") (er-bif-tl vs)
|
|
(= name "element") (er-bif-element vs)
|
|
(= name "tuple_size") (er-bif-tuple-size vs)
|
|
(= name "atom_to_list") (er-bif-atom-to-list vs)
|
|
(= 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)
|
|
(= name "make_ref") (er-bif-make-ref vs)
|
|
(= name "link") (er-bif-link vs)
|
|
(= name "unlink") (er-bif-unlink vs)
|
|
(= name "monitor") (er-bif-monitor vs)
|
|
(= name "demonitor") (er-bif-demonitor vs)
|
|
(= name "process_flag") (er-bif-process-flag vs)
|
|
(= name "register") (er-bif-register vs)
|
|
(= name "unregister") (er-bif-unregister vs)
|
|
(= name "whereis") (er-bif-whereis vs)
|
|
(= name "registered") (er-bif-registered vs)
|
|
(= name "throw") (raise (er-mk-throw-marker (er-bif-arg1 vs "throw")))
|
|
(= name "error") (raise (er-mk-error-marker (er-bif-arg1 vs "error")))
|
|
:else (error
|
|
(str "Erlang: undefined function '" name "/" (len vs) "'")))))
|
|
|
|
(define
|
|
er-apply-remote-bif
|
|
(fn
|
|
(mod name vs)
|
|
(cond
|
|
(dict-has? (er-modules-get) mod)
|
|
(er-apply-user-module mod name vs)
|
|
(= mod "lists") (er-apply-lists-bif name vs)
|
|
(= mod "io") (er-apply-io-bif name vs)
|
|
(= mod "erlang") (er-apply-bif name vs)
|
|
(= mod "ets") (er-apply-ets-bif name vs)
|
|
:else (error
|
|
(str "Erlang: undefined module '" mod "'")))))
|
|
|
|
(define
|
|
er-apply-lists-bif
|
|
(fn
|
|
(name vs)
|
|
(cond
|
|
(= name "reverse") (er-bif-lists-reverse vs)
|
|
(= name "map") (er-bif-lists-map vs)
|
|
(= name "foldl") (er-bif-lists-foldl vs)
|
|
:else (error
|
|
(str "Erlang: undefined 'lists:" name "/" (len vs) "'")))))
|
|
|
|
(define
|
|
er-apply-io-bif
|
|
(fn
|
|
(name vs)
|
|
(cond
|
|
(= name "format") (er-bif-io-format vs)
|
|
:else (error
|
|
(str "Erlang: undefined 'io:" name "/" (len vs) "'")))))
|
|
|
|
(define
|
|
er-bif-arg1
|
|
(fn
|
|
(vs name)
|
|
(if
|
|
(= (len vs) 1)
|
|
(nth vs 0)
|
|
(error (str "Erlang: " name ": wrong arity")))))
|
|
|
|
(define
|
|
er-bif-is-integer
|
|
(fn
|
|
(vs)
|
|
(let
|
|
((v (er-bif-arg1 vs "is_integer")))
|
|
(er-bool (and (= (type-of v) "number") (integer? v))))))
|
|
|
|
(define
|
|
er-bif-is-atom
|
|
(fn (vs) (er-bool (er-atom? (er-bif-arg1 vs "is_atom")))))
|
|
|
|
(define
|
|
er-bif-is-list
|
|
(fn
|
|
(vs)
|
|
(let
|
|
((v (er-bif-arg1 vs "is_list")))
|
|
(er-bool (or (er-nil? v) (er-cons? v))))))
|
|
|
|
(define
|
|
er-bif-is-tuple
|
|
(fn (vs) (er-bool (er-tuple? (er-bif-arg1 vs "is_tuple")))))
|
|
|
|
(define
|
|
er-bif-is-number
|
|
(fn
|
|
(vs)
|
|
(er-bool (= (type-of (er-bif-arg1 vs "is_number")) "number"))))
|
|
|
|
(define
|
|
er-bif-is-float
|
|
(fn
|
|
(vs)
|
|
(let
|
|
((v (er-bif-arg1 vs "is_float")))
|
|
(er-bool (and (= (type-of v) "number") (not (integer? v)))))))
|
|
|
|
(define
|
|
er-bif-is-boolean
|
|
(fn
|
|
(vs)
|
|
(let
|
|
((v (er-bif-arg1 vs "is_boolean")))
|
|
(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"))))
|
|
|
|
(define
|
|
er-list-length
|
|
(fn
|
|
(v)
|
|
(cond
|
|
(er-nil? v) 0
|
|
(er-cons? v) (+ 1 (er-list-length (get v :tail)))
|
|
:else (error "Erlang: length: not a proper list"))))
|
|
|
|
(define
|
|
er-bif-hd
|
|
(fn
|
|
(vs)
|
|
(let
|
|
((v (er-bif-arg1 vs "hd")))
|
|
(if
|
|
(er-cons? v)
|
|
(get v :head)
|
|
(error "Erlang: hd: empty list or non-list")))))
|
|
|
|
(define
|
|
er-bif-tl
|
|
(fn
|
|
(vs)
|
|
(let
|
|
((v (er-bif-arg1 vs "tl")))
|
|
(if
|
|
(er-cons? v)
|
|
(get v :tail)
|
|
(error "Erlang: tl: empty list or non-list")))))
|
|
|
|
(define
|
|
er-bif-element
|
|
(fn
|
|
(vs)
|
|
(if
|
|
(not (= (len vs) 2))
|
|
(error "Erlang: element: arity")
|
|
(let
|
|
((i (nth vs 0)) (t (nth vs 1)))
|
|
(if
|
|
(and (= (type-of i) "number") (er-tuple? t))
|
|
(let
|
|
((elems (get t :elements)))
|
|
(if
|
|
(and (>= i 1) (<= i (len elems)))
|
|
(nth elems (- i 1))
|
|
(error "Erlang: element: badarg (index out of range)")))
|
|
(error "Erlang: element: badarg"))))))
|
|
|
|
(define
|
|
er-bif-tuple-size
|
|
(fn
|
|
(vs)
|
|
(let
|
|
((v (er-bif-arg1 vs "tuple_size")))
|
|
(if
|
|
(er-tuple? v)
|
|
(len (get v :elements))
|
|
(error "Erlang: tuple_size: not a tuple")))))
|
|
|
|
(define
|
|
er-bif-atom-to-list
|
|
(fn
|
|
(vs)
|
|
(let
|
|
((v (er-bif-arg1 vs "atom_to_list")))
|
|
(if
|
|
(er-atom? v)
|
|
(get v :name)
|
|
(error "Erlang: atom_to_list: not an atom")))))
|
|
|
|
(define
|
|
er-bif-list-to-atom
|
|
(fn
|
|
(vs)
|
|
(let
|
|
((v (er-bif-arg1 vs "list_to_atom")))
|
|
(if
|
|
(= (type-of v) "string")
|
|
(er-mk-atom v)
|
|
(error "Erlang: list_to_atom: not a string")))))
|
|
|
|
;; ── lists module ─────────────────────────────────────────────────
|
|
(define
|
|
er-bif-lists-reverse
|
|
(fn
|
|
(vs)
|
|
(er-list-reverse-iter (er-bif-arg1 vs "lists:reverse") (er-mk-nil))))
|
|
|
|
(define
|
|
er-list-reverse-iter
|
|
(fn
|
|
(v acc)
|
|
(cond
|
|
(er-nil? v) acc
|
|
(er-cons? v)
|
|
(er-list-reverse-iter (get v :tail) (er-mk-cons (get v :head) acc))
|
|
:else (error "Erlang: lists:reverse: not a list"))))
|
|
|
|
(define
|
|
er-bif-lists-map
|
|
(fn
|
|
(vs)
|
|
(if
|
|
(not (= (len vs) 2))
|
|
(error "Erlang: lists:map: arity")
|
|
(er-list-reverse-iter
|
|
(er-map-iter (nth vs 0) (nth vs 1) (er-mk-nil))
|
|
(er-mk-nil)))))
|
|
|
|
(define
|
|
er-map-iter
|
|
(fn
|
|
(f lst acc)
|
|
(cond
|
|
(er-nil? lst) acc
|
|
(er-cons? lst)
|
|
(er-map-iter
|
|
f
|
|
(get lst :tail)
|
|
(er-mk-cons (er-apply-fun f (list (get lst :head))) acc))
|
|
:else (error "Erlang: lists:map: not a list"))))
|
|
|
|
(define
|
|
er-bif-lists-foldl
|
|
(fn
|
|
(vs)
|
|
(if
|
|
(not (= (len vs) 3))
|
|
(error "Erlang: lists:foldl: arity")
|
|
(er-foldl-iter (nth vs 0) (nth vs 1) (nth vs 2)))))
|
|
|
|
(define
|
|
er-foldl-iter
|
|
(fn
|
|
(f acc lst)
|
|
(cond
|
|
(er-nil? lst) acc
|
|
(er-cons? lst)
|
|
(er-foldl-iter
|
|
f
|
|
(er-apply-fun f (list (get lst :head) acc))
|
|
(get lst :tail))
|
|
:else (error "Erlang: lists:foldl: not a list"))))
|
|
|
|
;; ── io module ────────────────────────────────────────────────────
|
|
(define er-io-buffer (list ""))
|
|
(define er-io-flush! (fn () (set-nth! er-io-buffer 0 "")))
|
|
(define er-io-buffer-content (fn () (nth er-io-buffer 0)))
|
|
|
|
(define
|
|
er-bif-io-format
|
|
(fn
|
|
(vs)
|
|
(let
|
|
((s
|
|
(cond
|
|
(= (len vs) 1) (er-format-string (nth vs 0) (list))
|
|
(= (len vs) 2)
|
|
(er-format-string (nth vs 0) (er-list-to-sx-list (nth vs 1)))
|
|
:else (error "Erlang: io:format: arity"))))
|
|
(set-nth! er-io-buffer 0 (str (nth er-io-buffer 0) s))
|
|
er-atom-ok)))
|
|
|
|
(define
|
|
er-list-to-sx-list
|
|
(fn
|
|
(lst)
|
|
(let
|
|
((out (list)))
|
|
(er-list-to-sx-collect lst out)
|
|
out)))
|
|
|
|
(define
|
|
er-list-to-sx-collect
|
|
(fn
|
|
(lst out)
|
|
(cond
|
|
(er-nil? lst) nil
|
|
(er-cons? lst)
|
|
(do
|
|
(append! out (get lst :head))
|
|
(er-list-to-sx-collect (get lst :tail) out))
|
|
:else (error "Erlang: expected proper list"))))
|
|
|
|
;; ── format string rendering (~n, ~~, ~p, ~w, ~s) ────────────────
|
|
(define
|
|
er-format-string
|
|
(fn (fmt args) (er-format-walk fmt 0 args 0 "")))
|
|
|
|
(define
|
|
er-format-walk
|
|
(fn
|
|
(fmt i args ai out)
|
|
(if
|
|
(>= i (len fmt))
|
|
out
|
|
(let
|
|
((c (char-at fmt i)))
|
|
(cond
|
|
(and (= c "~") (< (+ i 1) (len fmt)))
|
|
(let
|
|
((d (char-at fmt (+ i 1))))
|
|
(cond
|
|
(= d "n")
|
|
(er-format-walk fmt (+ i 2) args ai (str out "\n"))
|
|
(= d "~") (er-format-walk fmt (+ i 2) args ai (str out "~"))
|
|
(or (= d "p") (= d "w") (= d "s"))
|
|
(er-format-walk
|
|
fmt
|
|
(+ i 2)
|
|
args
|
|
(+ ai 1)
|
|
(str out (er-format-value (nth args ai))))
|
|
:else (er-format-walk
|
|
fmt
|
|
(+ i 2)
|
|
args
|
|
ai
|
|
(str out "~" d))))
|
|
:else (er-format-walk fmt (+ i 1) args ai (str out c)))))))
|
|
|
|
(define
|
|
er-format-value
|
|
(fn
|
|
(v)
|
|
(cond
|
|
(= (type-of v) "number") (str v)
|
|
(= (type-of v) "string") (str "\"" v "\"")
|
|
(er-atom? v) (get v :name)
|
|
(er-nil? v) "[]"
|
|
(er-cons? v) (str "[" (er-format-list-elems v) "]")
|
|
(er-tuple? v) (str "{" (er-format-tuple-elems (get v :elements)) "}")
|
|
(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
|
|
(v)
|
|
(cond
|
|
(er-nil? v) ""
|
|
(and (er-cons? v) (er-nil? (get v :tail)))
|
|
(er-format-value (get v :head))
|
|
(er-cons? v)
|
|
(str
|
|
(er-format-value (get v :head))
|
|
","
|
|
(er-format-list-elems (get v :tail)))
|
|
:else (str "|" (er-format-value v)))))
|
|
|
|
(define
|
|
er-format-tuple-elems
|
|
(fn
|
|
(elems)
|
|
(if
|
|
(= (len elems) 0)
|
|
""
|
|
(let
|
|
((out (list (er-format-value (nth elems 0)))))
|
|
(for-each
|
|
(fn
|
|
(i)
|
|
(append! out ",")
|
|
(append! out (er-format-value (nth elems i))))
|
|
(range 1 (len elems)))
|
|
(reduce str "" out)))))
|
|
|
|
;; ── send: Pid ! Msg ──────────────────────────────────────────────
|
|
;; Target may be a pid or a registered atom name. Atom resolution
|
|
;; goes through the scheduler's `:registered` table.
|
|
(define
|
|
er-eval-send
|
|
(fn
|
|
(node env)
|
|
(let
|
|
((to-val (er-eval-expr (get node :to) env))
|
|
(msg-val (er-eval-expr (get node :msg) env)))
|
|
(let
|
|
((pid (er-resolve-send-target to-val)))
|
|
(when
|
|
(er-proc-exists? pid)
|
|
(er-proc-mailbox-push! pid msg-val)
|
|
(when
|
|
(= (er-proc-field pid :state) "waiting")
|
|
(er-proc-set! pid :state "runnable")
|
|
(er-sched-enqueue! pid)))
|
|
msg-val))))
|
|
|
|
(define
|
|
er-resolve-send-target
|
|
(fn
|
|
(v)
|
|
(cond
|
|
(er-pid? v) v
|
|
(er-atom? v)
|
|
(let
|
|
((name (get v :name)))
|
|
(if
|
|
(dict-has? (er-registered) name)
|
|
(get (er-registered) name)
|
|
(raise
|
|
(er-mk-error-marker
|
|
(er-mk-tuple
|
|
(list (er-mk-atom "badarg") v))))))
|
|
:else (raise
|
|
(er-mk-error-marker
|
|
(er-mk-tuple (list (er-mk-atom "badarg") v)))))))
|
|
|
|
;; ── receive (selective, delimited-continuation suspension) ──────
|
|
(define
|
|
er-eval-receive
|
|
(fn
|
|
(node env)
|
|
(let
|
|
((pid (er-sched-current-pid))
|
|
(after-node (get node :after-ms)))
|
|
(if
|
|
(= after-node nil)
|
|
(er-eval-receive-loop node pid env)
|
|
(er-eval-receive-with-after node pid env after-node)))))
|
|
|
|
(define
|
|
er-eval-receive-loop
|
|
(fn
|
|
(node pid env)
|
|
(let
|
|
((r (er-try-receive (get node :clauses) pid env)))
|
|
(if
|
|
(get r :matched)
|
|
(get r :value)
|
|
(do
|
|
(call/cc
|
|
(fn
|
|
(k)
|
|
(er-proc-set! pid :continuation k)
|
|
(er-proc-set! pid :state "waiting")
|
|
(raise er-suspend-marker)))
|
|
(er-eval-receive-loop node pid env))))))
|
|
|
|
(define
|
|
er-eval-receive-with-after
|
|
(fn
|
|
(node pid env after-node)
|
|
(let
|
|
((ms (er-eval-expr after-node env)))
|
|
(cond
|
|
(and (er-atom? ms) (= (get ms :name) "infinity"))
|
|
(er-eval-receive-loop node pid env)
|
|
(= ms 0) (er-eval-receive-poll node pid env)
|
|
:else (er-eval-receive-timed node pid env)))))
|
|
|
|
;; after 0 — poll once; on no match, run the after-body immediately.
|
|
(define
|
|
er-eval-receive-poll
|
|
(fn
|
|
(node pid env)
|
|
(let
|
|
((r (er-try-receive (get node :clauses) pid env)))
|
|
(if
|
|
(get r :matched)
|
|
(get r :value)
|
|
(er-eval-body (get node :after-body) env)))))
|
|
|
|
;; after Ms — suspend; on resume check :timed-out. When the scheduler
|
|
;; runs out of other work it fires one pending timeout per round.
|
|
(define
|
|
er-eval-receive-timed
|
|
(fn
|
|
(node pid env)
|
|
(let
|
|
((r (er-try-receive (get node :clauses) pid env)))
|
|
(if
|
|
(get r :matched)
|
|
(get r :value)
|
|
(do
|
|
(er-proc-set! pid :has-timeout true)
|
|
(call/cc
|
|
(fn
|
|
(k)
|
|
(er-proc-set! pid :continuation k)
|
|
(er-proc-set! pid :state "waiting")
|
|
(raise er-suspend-marker)))
|
|
(if
|
|
(er-proc-field pid :timed-out)
|
|
(do
|
|
(er-proc-set! pid :timed-out false)
|
|
(er-proc-set! pid :has-timeout false)
|
|
(er-eval-body (get node :after-body) env))
|
|
(er-eval-receive-timed node pid env)))))))
|
|
|
|
;; Scan mailbox in arrival order. For each msg, try every clause.
|
|
;; On first match: remove that msg from mailbox and return body value.
|
|
(define
|
|
er-try-receive
|
|
(fn
|
|
(clauses pid env)
|
|
(let
|
|
((mbox (er-proc-field pid :mailbox)))
|
|
(er-try-receive-loop clauses mbox env 0))))
|
|
|
|
(define
|
|
er-try-receive-loop
|
|
(fn
|
|
(clauses mbox env i)
|
|
(if
|
|
(>= i (er-q-len mbox))
|
|
{:matched false}
|
|
(let
|
|
((msg (er-q-nth mbox i))
|
|
(cr (er-try-receive-clauses clauses msg env 0)))
|
|
(if
|
|
(get cr :matched)
|
|
(do
|
|
(er-q-delete-at! mbox i)
|
|
{:value (er-eval-body (get cr :body) env) :matched true})
|
|
(er-try-receive-loop clauses mbox env (+ i 1)))))))
|
|
|
|
;; Try clauses against a message. On match: bind vars into env and
|
|
;; return `{:matched true :body <clause body>}` WITHOUT evaluating the
|
|
;; body — the caller must remove the message from the mailbox first,
|
|
;; otherwise a recursive `receive` inside the body would re-match the
|
|
;; same msg and loop forever.
|
|
(define
|
|
er-try-receive-clauses
|
|
(fn
|
|
(clauses msg env i)
|
|
(if
|
|
(>= i (len clauses))
|
|
{:matched false}
|
|
(let
|
|
((c (nth clauses i)) (snap (er-env-copy env)))
|
|
(if
|
|
(and
|
|
(er-match! (get c :pattern) msg env)
|
|
(er-eval-guards (get c :guards) env))
|
|
{:body (get c :body) :matched true}
|
|
(do
|
|
(er-env-restore! env snap)
|
|
(er-try-receive-clauses clauses msg env (+ i 1))))))))
|
|
|
|
;; ── try/of/catch/after ────────────────────────────────────────────
|
|
;; The outer guard captures any exception so the `after` body is
|
|
;; guaranteed to run, then re-raises. The inner guard runs the
|
|
;; expression body, optional `of` clauses on success, and `catch`
|
|
;; clauses on a thrown/erred/exited condition. If no catch clause
|
|
;; matches the raised class+pattern, the inner guard's clause
|
|
;; re-raises by returning nothing (handled via re-raise marker).
|
|
(define
|
|
er-eval-try
|
|
(fn
|
|
(node env)
|
|
(let
|
|
((after-body (get node :after))
|
|
(saved-exc (list nil))
|
|
(result-ref (list nil)))
|
|
(guard
|
|
(c (:else (do (set-nth! saved-exc 0 c) nil)))
|
|
(set-nth! result-ref 0 (er-eval-try-inner node env)))
|
|
(when
|
|
(> (len after-body) 0)
|
|
(er-eval-body after-body env))
|
|
(if
|
|
(= (nth saved-exc 0) nil)
|
|
(nth result-ref 0)
|
|
(raise (nth saved-exc 0))))))
|
|
|
|
(define
|
|
er-eval-try-inner
|
|
(fn
|
|
(node env)
|
|
(let
|
|
((catch-clauses (get node :catch-clauses))
|
|
(of-clauses (get node :of-clauses))
|
|
(caught-ref (list false))
|
|
(result-ref (list nil))
|
|
(re-raise-ref (list nil)))
|
|
(guard
|
|
(c
|
|
((er-thrown? c)
|
|
(er-eval-try-catch
|
|
catch-clauses "throw" (get c :reason) env
|
|
caught-ref result-ref re-raise-ref))
|
|
((er-errored? c)
|
|
(er-eval-try-catch
|
|
catch-clauses "error" (get c :reason) env
|
|
caught-ref result-ref re-raise-ref))
|
|
((er-exited? c)
|
|
(er-eval-try-catch
|
|
catch-clauses "exit" (get c :reason) env
|
|
caught-ref result-ref re-raise-ref)))
|
|
(let
|
|
((r (er-eval-body (get node :exprs) env)))
|
|
(if
|
|
(= (len of-clauses) 0)
|
|
(set-nth! result-ref 0 r)
|
|
(set-nth!
|
|
result-ref
|
|
0
|
|
(er-eval-of-clauses of-clauses r env 0)))))
|
|
(when (not (= (nth re-raise-ref 0) nil))
|
|
(raise (nth re-raise-ref 0)))
|
|
(nth result-ref 0))))
|
|
|
|
;; Try catch-clauses against (Class, Reason). If a clause matches,
|
|
;; runs its body and writes to result-ref. If none match, queues a
|
|
;; re-raise marker.
|
|
(define
|
|
er-eval-try-catch
|
|
(fn
|
|
(clauses class-name reason env caught-ref result-ref re-raise-ref)
|
|
(er-eval-try-catch-iter
|
|
clauses class-name reason env 0 caught-ref result-ref re-raise-ref)))
|
|
|
|
(define
|
|
er-eval-try-catch-iter
|
|
(fn
|
|
(clauses class-name reason env i caught-ref result-ref re-raise-ref)
|
|
(if
|
|
(>= i (len clauses))
|
|
(set-nth!
|
|
re-raise-ref
|
|
0
|
|
(er-mk-class-marker class-name reason))
|
|
(let
|
|
((c (nth clauses i))
|
|
(snap (er-env-copy env))
|
|
(clause-class (get (get c :class) :value)))
|
|
(cond
|
|
(not (= clause-class class-name))
|
|
(er-eval-try-catch-iter
|
|
clauses class-name reason env (+ i 1)
|
|
caught-ref result-ref re-raise-ref)
|
|
:else
|
|
(if
|
|
(and
|
|
(er-match! (get c :pattern) reason env)
|
|
(er-eval-guards (get c :guards) env))
|
|
(do
|
|
(set-nth! caught-ref 0 true)
|
|
(set-nth!
|
|
result-ref
|
|
0
|
|
(er-eval-body (get c :body) env)))
|
|
(do
|
|
(er-env-restore! env snap)
|
|
(er-eval-try-catch-iter
|
|
clauses class-name reason env (+ i 1)
|
|
caught-ref result-ref re-raise-ref))))))))
|
|
|
|
(define
|
|
er-mk-class-marker
|
|
(fn
|
|
(class-name reason)
|
|
(cond
|
|
(= class-name "throw") (er-mk-throw-marker reason)
|
|
(= class-name "error") (er-mk-error-marker reason)
|
|
(= class-name "exit") (er-mk-exit-marker reason)
|
|
:else (er-mk-error-marker reason))))
|
|
|
|
(define
|
|
er-eval-of-clauses
|
|
(fn
|
|
(clauses subject env i)
|
|
(if
|
|
(>= i (len clauses))
|
|
(raise
|
|
(er-mk-error-marker
|
|
(er-mk-tuple
|
|
(list (er-mk-atom "try_clause") subject))))
|
|
(let
|
|
((c (nth clauses i)) (snap (er-env-copy env)))
|
|
(if
|
|
(and
|
|
(er-match! (get c :pattern) subject env)
|
|
(er-eval-guards (get c :guards) env))
|
|
(er-eval-body (get c :body) env)
|
|
(do
|
|
(er-env-restore! env snap)
|
|
(er-eval-of-clauses clauses subject env (+ i 1))))))))
|
|
|
|
;; ── list comprehensions ─────────────────────────────────────────
|
|
;; `[E || Pat <- Source, FilterExpr, ...]`. Walk qualifiers in order:
|
|
;; generators iterate their source list and bind the pattern (with
|
|
;; env snapshot/restore so each iteration starts from the same
|
|
;; baseline); filters skip when falsy. At the end of the qualifier
|
|
;; chain, evaluate `head` and append to the accumulator. Build the
|
|
;; final cons chain in O(n) with a single right-fold.
|
|
(define
|
|
er-eval-lc
|
|
(fn
|
|
(node env)
|
|
(let
|
|
((acc (list)))
|
|
(er-lc-walk (get node :qualifiers) 0 (get node :head) env acc)
|
|
(er-list-from-sx-list acc))))
|
|
|
|
(define
|
|
er-lc-walk
|
|
(fn
|
|
(quals i head env acc)
|
|
(if
|
|
(>= i (len quals))
|
|
(append! acc (er-eval-expr head env))
|
|
(let
|
|
((q (nth quals i)))
|
|
(cond
|
|
(= (get q :kind) "gen")
|
|
(let
|
|
((src (er-eval-expr (get q :source) env)))
|
|
(er-lc-iter-gen
|
|
src
|
|
(get q :pattern)
|
|
quals
|
|
i
|
|
head
|
|
env
|
|
acc))
|
|
(= (get q :kind) "filter")
|
|
(when
|
|
(er-truthy? (er-eval-expr (get q :expr) env))
|
|
(er-lc-walk quals (+ i 1) head env acc))
|
|
:else (error "Erlang LC: unknown qualifier"))))))
|
|
|
|
(define
|
|
er-lc-iter-gen
|
|
(fn
|
|
(src pat quals i head env acc)
|
|
(cond
|
|
(er-nil? src) nil
|
|
(er-cons? src)
|
|
(let
|
|
((snap (er-env-copy env)))
|
|
(when
|
|
(er-match! pat (get src :head) env)
|
|
(er-lc-walk quals (+ i 1) head env acc))
|
|
(er-env-restore! env snap)
|
|
(er-lc-iter-gen
|
|
(get src :tail)
|
|
pat
|
|
quals
|
|
i
|
|
head
|
|
env
|
|
acc))
|
|
:else (error "Erlang LC: generator source is not a list"))))
|
|
|
|
(define
|
|
er-list-from-sx-list
|
|
(fn
|
|
(xs)
|
|
(let
|
|
((acc (list (er-mk-nil))))
|
|
(for-each
|
|
(fn
|
|
(i)
|
|
(let
|
|
((j (- (- (len xs) 1) i)))
|
|
(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))))))
|