giles
4965be71ca
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Has been cancelled
442 lines
13 KiB
Plaintext
442 lines
13 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)) (env (er-env-new)))
|
|
(er-eval-body body env)))))
|
|
|
|
(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 "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)
|
|
: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
|
|
:else 5)))
|
|
|
|
(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))))
|