giles
c363856df6
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Has been cancelled
1091 lines
31 KiB
Plaintext
1091 lines
31 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-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 "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)
|
|
: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)))))
|
|
|
|
;; ── 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))
|
|
: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")
|
|
(er-apply-bif (get fun-node :value) (er-eval-args args env))
|
|
(= (get fun-node :type) "remote")
|
|
(er-apply-remote-bif
|
|
(get (get fun-node :mod) :value)
|
|
(get (get fun-node :fun) :value)
|
|
(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)))
|
|
|
|
;; ── 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 "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)
|
|
:else (error
|
|
(str "Erlang: undefined function '" name "/" (len vs) "'")))))
|
|
|
|
(define
|
|
er-apply-remote-bif
|
|
(fn
|
|
(mod name vs)
|
|
(cond
|
|
(= mod "lists") (er-apply-lists-bif name vs)
|
|
(= mod "io") (er-apply-io-bif name vs)
|
|
(= mod "erlang") (er-apply-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"))))))
|
|
|
|
;; ── 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) ">")
|
|
:else (str v))))
|
|
|
|
(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 ──────────────────────────────────────────────
|
|
(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)))
|
|
(if
|
|
(not (er-pid? to-val))
|
|
(error "Erlang: '!': target is not a pid")
|
|
(do
|
|
(when
|
|
(er-proc-exists? to-val)
|
|
(er-proc-mailbox-push! to-val msg-val)
|
|
(when
|
|
(= (er-proc-field to-val :state) "waiting")
|
|
(er-proc-set! to-val :state "runnable")
|
|
(er-sched-enqueue! to-val)))
|
|
msg-val)))))
|
|
|
|
;; ── 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))))))))
|