giles
c8bfd22786
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 53s
Host primitives _string_length / _string_sub / _char_code / etc. exposed in the base env (underscore-prefixed to avoid user clash). lib/ocaml/ runtime.sx wraps them into OCaml-syntax modules: String (length, get, sub, concat, uppercase/lowercase_ascii, starts_with), Char (code, chr, lowercase/uppercase_ascii), Int (to_string, of_string, abs, max, min), Float.to_string, Printf stubs. Also added print_string / print_endline / print_int IO builtins.
771 lines
34 KiB
Plaintext
771 lines
34 KiB
Plaintext
;; lib/ocaml/eval.sx — OCaml AST evaluator (Phase 2 slice).
|
|
;;
|
|
;; Walks the AST produced by ocaml-parse / ocaml-parse-program and yields
|
|
;; SX values.
|
|
;;
|
|
;; Coverage in this slice:
|
|
;; atoms int/float/string/char/bool/unit
|
|
;; :var env lookup
|
|
;; :app curried application
|
|
;; :op arithmetic, comparison, boolean, ^ string concat, mod, ::
|
|
;; :neg unary minus
|
|
;; :not boolean negation
|
|
;; :if conditional
|
|
;; :seq sequence — discard all but last
|
|
;; :tuple SX (:tuple v1 v2 …)
|
|
;; :list SX list
|
|
;; :fun closure (auto-curried via host SX lambda)
|
|
;; :let non-recursive binding
|
|
;; :let-rec recursive binding for function values (mutable ref cell)
|
|
;;
|
|
;; Out of scope: pattern matching, refs (`ref`/`!`/`:=`), modules, ADTs,
|
|
;; mutable records, for/while, try/with.
|
|
;;
|
|
;; Environment representation: an assoc list of (name value) pairs. Most
|
|
;; recent binding shadows older ones.
|
|
|
|
;; Initial environment provides OCaml stdlib functions that are values,
|
|
;; not language keywords (e.g. `not`, `succ`, `pred`). Phase 6 adds the
|
|
;; full stdlib slice; this just unblocks Phase 2 tests.
|
|
(define ocaml-empty-env
|
|
(fn ()
|
|
(list
|
|
(list "not" (fn (x) (not x)))
|
|
(list "succ" (fn (x) (+ x 1)))
|
|
(list "pred" (fn (x) (- x 1)))
|
|
(list "abs" (fn (x) (if (< x 0) (- 0 x) x)))
|
|
(list "max" (fn (a) (fn (b) (if (> a b) a b))))
|
|
(list "min" (fn (a) (fn (b) (if (< a b) a b))))
|
|
(list "fst" (fn (p) (nth p 1)))
|
|
(list "snd" (fn (p) (nth p 2)))
|
|
(list "ignore" (fn (x) nil))
|
|
;; References. A ref cell is a one-element list; ! reads it and
|
|
;; := mutates it via set-nth!.
|
|
(list "ref" (fn (x) (list x)))
|
|
;; Exceptions: `raise e` invokes the host-SX raise; values are
|
|
;; tagged like other ctors so `try ... with | Exn x -> handler`
|
|
;; can pattern-match them.
|
|
(list "raise" (fn (e) (raise e)))
|
|
(list "failwith" (fn (msg) (raise (list "Failure" msg))))
|
|
(list "invalid_arg" (fn (msg) (raise (list "Invalid_argument" msg)))
|
|
)
|
|
;; Host primitives exposed for the OCaml stdlib (lib/ocaml/runtime.sx).
|
|
;; Underscore-prefixed to avoid clashing with user names.
|
|
(list "_string_length" (fn (s) (len s)))
|
|
(list "_string_get" (fn (s) (fn (i) (nth s i))))
|
|
(list "_string_sub" (fn (s) (fn (i) (fn (n) (slice s i (+ i n))))))
|
|
(list "_string_concat" (fn (sep) (fn (xs) (join sep xs))))
|
|
(list "_string_upper" (fn (s) (upper s)))
|
|
(list "_string_lower" (fn (s) (lower s)))
|
|
(list "_string_starts_with" (fn (p) (fn (s) (starts-with? s p))))
|
|
(list "_int_of_string" (fn (s) (parse-number s)))
|
|
(list "_string_of_int" (fn (i) (str i)))
|
|
(list "_string_of_float" (fn (f) (str f)))
|
|
(list "_char_code" (fn (c) (char-code c)))
|
|
(list "_char_chr" (fn (n) (char-from-code n)))
|
|
;; Print: prints to host stdout via println.
|
|
(list "print_string" (fn (s) (begin (print s) nil)))
|
|
(list "print_endline" (fn (s) (begin (println s) nil)))
|
|
(list "print_int" (fn (i) (begin (print (str i)) nil))))))
|
|
|
|
(define ocaml-env-lookup
|
|
(fn (env name)
|
|
(cond
|
|
((= env (list)) nil)
|
|
((= (first (first env)) name) (nth (first env) 1))
|
|
(else (ocaml-env-lookup (rest env) name)))))
|
|
|
|
(define ocaml-env-has?
|
|
(fn (env name)
|
|
(cond
|
|
((= env (list)) false)
|
|
((= (first (first env)) name) true)
|
|
(else (ocaml-env-has? (rest env) name)))))
|
|
|
|
(define ocaml-env-extend
|
|
(fn (env name val)
|
|
(cons (list name val) env)))
|
|
|
|
;; Resolve a module path / functor-application expression to a module dict.
|
|
;; Mirrors the field-access escape hatch where `(:con NAME)` is treated as
|
|
;; an env lookup rather than a nullary ctor; also handles `(:app FN ARG)`
|
|
;; for functor applications, `(:field …)` for sub-modules, and `(:var …)`
|
|
;; for lower-case bindings.
|
|
(define ocaml-resolve-module-path
|
|
(fn (path-expr env)
|
|
(let ((tag (ocaml-tag-of path-expr)))
|
|
(cond
|
|
((= tag "con")
|
|
(cond
|
|
((ocaml-env-has? env (nth path-expr 1))
|
|
(ocaml-env-lookup env (nth path-expr 1)))
|
|
(else (error (str "ocaml-eval: unknown module " (nth path-expr 1))))))
|
|
((= tag "var")
|
|
(cond
|
|
((ocaml-env-has? env (nth path-expr 1))
|
|
(ocaml-env-lookup env (nth path-expr 1)))
|
|
(else (error (str "ocaml-eval: unknown module-var " (nth path-expr 1))))))
|
|
((= tag "field")
|
|
(let ((parent (ocaml-resolve-module-path (nth path-expr 1) env)))
|
|
(cond
|
|
((dict? parent) (get parent (nth path-expr 2)))
|
|
(else (error
|
|
(str "ocaml-eval: not a module on path: " parent))))))
|
|
((= tag "app")
|
|
(let ((fn-val (ocaml-resolve-module-path (nth path-expr 1) env))
|
|
(arg-val (ocaml-resolve-module-path (nth path-expr 2) env)))
|
|
(fn-val arg-val)))
|
|
((= tag "unit") {})
|
|
(else (ocaml-eval path-expr env))))))
|
|
|
|
;; Merge a dict's bindings into an env (used by `open`/`include`).
|
|
;; Iterates keys; each (k, get d k) becomes a fresh env binding.
|
|
(define ocaml-env-merge-dict
|
|
(fn (env d)
|
|
(let ((result env) (ks (keys d)))
|
|
(begin
|
|
(define loop
|
|
(fn (xs)
|
|
(when (not (= xs (list)))
|
|
(let ((k (first xs)))
|
|
(begin
|
|
(set! result (cons (list k (get d k)) result))
|
|
(loop (rest xs)))))))
|
|
(loop ks)
|
|
result))))
|
|
|
|
(define ocaml-tag-of (fn (ast) (nth ast 0)))
|
|
|
|
(define ocaml-eval (fn (ast env) nil))
|
|
|
|
;; Pattern matcher — returns the extended env on success, or :fail on
|
|
;; mismatch (using the keyword :fail so nil values don't ambiguate).
|
|
;;
|
|
;; Pattern shapes (from parser):
|
|
;; (:pwild) match anything, no binding
|
|
;; (:pvar NAME) match anything, bind NAME → val
|
|
;; (:plit LITAST) literal compare
|
|
;; (:pcon NAME PATS...) ctor: val must be (NAME ARGS...) and arity match
|
|
;; (:pcons HEAD TAIL) non-empty list: match head + tail
|
|
;; (:plist PATS...) list of exact length, item-wise match
|
|
;; (:ptuple PATS...) val must be ("tuple" ITEMS...) of same arity
|
|
(define ocaml-match-fail :fail)
|
|
|
|
(define ocaml-eval-lit
|
|
(fn (lit-ast)
|
|
(let ((tag (nth lit-ast 0)))
|
|
(cond
|
|
((= tag "int") (nth lit-ast 1))
|
|
((= tag "float") (nth lit-ast 1))
|
|
((= tag "string") (nth lit-ast 1))
|
|
((= tag "char") (nth lit-ast 1))
|
|
((= tag "bool") (nth lit-ast 1))
|
|
((= tag "unit") nil)
|
|
(else (error (str "ocaml-eval-lit: bad literal " tag)))))))
|
|
|
|
(define ocaml-match-pat (fn (pat val env) ocaml-match-fail))
|
|
|
|
(define ocaml-match-list
|
|
(fn (pats vals env)
|
|
(cond
|
|
((and (= (len pats) 0) (= (len vals) 0)) env)
|
|
((or (= (len pats) 0) (= (len vals) 0)) ocaml-match-fail)
|
|
(else
|
|
(let ((env2 (ocaml-match-pat (first pats) (first vals) env)))
|
|
(cond
|
|
((= env2 ocaml-match-fail) ocaml-match-fail)
|
|
(else (ocaml-match-list (rest pats) (rest vals) env2))))))))
|
|
|
|
(set! ocaml-match-pat
|
|
(fn (pat val env)
|
|
(let ((tag (nth pat 0)))
|
|
(cond
|
|
((= tag "pwild") env)
|
|
((= tag "pvar")
|
|
(ocaml-env-extend env (nth pat 1) val))
|
|
((= tag "plit")
|
|
(if (= (ocaml-eval-lit (nth pat 1)) val) env ocaml-match-fail))
|
|
((= tag "pcon")
|
|
;; (:pcon NAME PATS...) — val must be (NAME VALS...) with same arity.
|
|
(let ((name (nth pat 1)) (arg-pats (rest (rest pat))))
|
|
(cond
|
|
((and (list? val) (not (empty? val)) (= (first val) name)
|
|
(= (len (rest val)) (len arg-pats)))
|
|
(ocaml-match-list arg-pats (rest val) env))
|
|
(else ocaml-match-fail))))
|
|
((= tag "pcons")
|
|
;; (:pcons HEAD TAIL) — val must be a non-empty list.
|
|
(cond
|
|
((and (list? val) (not (empty? val))
|
|
(not (and (not (empty? val)) (string? (first val)))))
|
|
;; OCaml lists are SX lists (not tagged like ctors). Match
|
|
;; head pattern against (first val), tail against (rest val).
|
|
(let ((env2 (ocaml-match-pat (nth pat 1) (first val) env)))
|
|
(cond
|
|
((= env2 ocaml-match-fail) ocaml-match-fail)
|
|
(else (ocaml-match-pat (nth pat 2) (rest val) env2)))))
|
|
;; Allow lists whose first element happens to be a string —
|
|
;; ambiguous with ctors; treat them as plain lists.
|
|
((and (list? val) (not (empty? val)))
|
|
(let ((env2 (ocaml-match-pat (nth pat 1) (first val) env)))
|
|
(cond
|
|
((= env2 ocaml-match-fail) ocaml-match-fail)
|
|
(else (ocaml-match-pat (nth pat 2) (rest val) env2)))))
|
|
(else ocaml-match-fail)))
|
|
((= tag "plist")
|
|
;; (:plist PATS...) — val must be a list of exact length.
|
|
(let ((item-pats (rest pat)))
|
|
(cond
|
|
((and (list? val) (= (len val) (len item-pats)))
|
|
(ocaml-match-list item-pats val env))
|
|
(else ocaml-match-fail))))
|
|
((= tag "ptuple")
|
|
(let ((item-pats (rest pat)))
|
|
(cond
|
|
((and (list? val) (not (empty? val))
|
|
(= (first val) "tuple")
|
|
(= (len (rest val)) (len item-pats)))
|
|
(ocaml-match-list item-pats (rest val) env))
|
|
(else ocaml-match-fail))))
|
|
(else (error (str "ocaml-match-pat: unknown pattern tag " tag)))))))
|
|
|
|
(define ocaml-match-clauses
|
|
(fn (val clauses env)
|
|
(begin
|
|
(define try-clauses
|
|
(fn (cs)
|
|
(cond
|
|
((empty? cs)
|
|
(error (str "ocaml-eval: match failure on " val)))
|
|
(else
|
|
(let ((clause (first cs)))
|
|
(let ((pat (nth clause 1)) (body (nth clause 2)))
|
|
(let ((env2 (ocaml-match-pat pat val env)))
|
|
(cond
|
|
((= env2 ocaml-match-fail) (try-clauses (rest cs)))
|
|
(else (ocaml-eval body env2))))))))))
|
|
(try-clauses clauses))))
|
|
|
|
(define ocaml-match-eval
|
|
(fn (scrut-ast clauses env)
|
|
(ocaml-match-clauses (ocaml-eval scrut-ast env) clauses env)))
|
|
|
|
;; Auto-curry: (:fun ("x" "y" "z") body) → (fn (x) (fn (y) (fn (z) body))).
|
|
;; A zero-param lambda evaluates the body immediately on first call —
|
|
;; OCaml does not have nullary functions; `()`-taking functions still
|
|
;; receive the unit argument via a one-param lambda.
|
|
(define ocaml-make-curried
|
|
(fn (params body env)
|
|
(cond
|
|
((= (len params) 0)
|
|
(ocaml-eval body env))
|
|
((= (len params) 1)
|
|
(fn (arg)
|
|
(ocaml-eval body
|
|
(ocaml-env-extend env (nth params 0) arg))))
|
|
(else
|
|
(fn (arg)
|
|
(ocaml-make-curried
|
|
(rest params)
|
|
body
|
|
(ocaml-env-extend env (nth params 0) arg)))))))
|
|
|
|
(define ocaml-eval-op
|
|
(fn (op lhs rhs)
|
|
(cond
|
|
((= op "+") (+ lhs rhs))
|
|
((= op "-") (- lhs rhs))
|
|
((= op "*") (* lhs rhs))
|
|
((= op "/") (/ lhs rhs))
|
|
((= op "mod") (mod lhs rhs))
|
|
((= op "%") (mod lhs rhs))
|
|
((= op "**") (pow lhs rhs))
|
|
((= op "^") (str lhs rhs))
|
|
((= op "@") (concat lhs rhs))
|
|
((= op "::") (cons lhs rhs))
|
|
((= op "=") (= lhs rhs))
|
|
((= op "<>") (not (= lhs rhs)))
|
|
((= op "==") (= lhs rhs))
|
|
((= op "!=") (not (= lhs rhs)))
|
|
((= op "<") (< lhs rhs))
|
|
((= op ">") (> lhs rhs))
|
|
((= op "<=") (<= lhs rhs))
|
|
((= op ">=") (>= lhs rhs))
|
|
((= op "&&") (and lhs rhs))
|
|
((= op "||") (or lhs rhs))
|
|
((= op "or") (or lhs rhs))
|
|
((= op "|>") (rhs lhs))
|
|
(else (error (str "ocaml-eval: unknown operator " op))))))
|
|
|
|
(set! ocaml-eval
|
|
(fn (ast env)
|
|
(let ((tag (ocaml-tag-of ast)))
|
|
(cond
|
|
((= tag "int") (nth ast 1))
|
|
((= tag "float") (nth ast 1))
|
|
((= tag "string") (nth ast 1))
|
|
((= tag "char") (nth ast 1))
|
|
((= tag "bool") (nth ast 1))
|
|
((= tag "unit") nil)
|
|
((= tag "var")
|
|
(let ((name (nth ast 1)))
|
|
(cond
|
|
((ocaml-env-has? env name) (ocaml-env-lookup env name))
|
|
(else (error (str "ocaml-eval: unbound variable " name))))))
|
|
((= tag "neg") (- 0 (ocaml-eval (nth ast 1) env)))
|
|
((= tag "not") (not (ocaml-eval (nth ast 1) env)))
|
|
((= tag "deref")
|
|
(let ((cell (ocaml-eval (nth ast 1) env)))
|
|
(nth cell 0)))
|
|
((= tag "op")
|
|
(let ((op (nth ast 1)))
|
|
(cond
|
|
;; := mutates the lhs cell — short-circuit before generic
|
|
;; eval-op so we still evaluate lhs (to obtain the cell).
|
|
((= op ":=")
|
|
(let ((cell (ocaml-eval (nth ast 2) env))
|
|
(new-val (ocaml-eval (nth ast 3) env)))
|
|
(begin (set-nth! cell 0 new-val) nil)))
|
|
(else
|
|
(ocaml-eval-op op
|
|
(ocaml-eval (nth ast 2) env)
|
|
(ocaml-eval (nth ast 3) env))))))
|
|
((= tag "if")
|
|
(if (ocaml-eval (nth ast 1) env)
|
|
(ocaml-eval (nth ast 2) env)
|
|
(ocaml-eval (nth ast 3) env)))
|
|
((= tag "seq")
|
|
(let ((items (rest ast)) (last nil))
|
|
(begin
|
|
(define loop
|
|
(fn (xs)
|
|
(when (not (= xs (list)))
|
|
(begin
|
|
(set! last (ocaml-eval (first xs) env))
|
|
(loop (rest xs))))))
|
|
(loop items)
|
|
last)))
|
|
((= tag "tuple")
|
|
(cons :tuple
|
|
(map (fn (e) (ocaml-eval e env)) (rest ast))))
|
|
((= tag "list")
|
|
(map (fn (e) (ocaml-eval e env)) (rest ast)))
|
|
((= tag "fun")
|
|
(ocaml-make-curried (nth ast 1) (nth ast 2) env))
|
|
((= tag "con")
|
|
;; Standalone ctor — produces a nullary tagged value.
|
|
(list (nth ast 1)))
|
|
((= tag "app")
|
|
(let ((fn-ast (nth ast 1)))
|
|
(cond
|
|
;; Constructor application: build a tagged value, flattening
|
|
;; a tuple arg into multiple ctor args (so `Pair (a, b)`
|
|
;; becomes ("Pair" va vb) — matches the parser's pattern
|
|
;; flattening).
|
|
((= (ocaml-tag-of fn-ast) "con")
|
|
(let ((name (nth fn-ast 1))
|
|
(arg-val (ocaml-eval (nth ast 2) env)))
|
|
(cond
|
|
((and (list? arg-val) (not (empty? arg-val))
|
|
(= (first arg-val) "tuple"))
|
|
(cons name (rest arg-val)))
|
|
(else (list name arg-val)))))
|
|
(else
|
|
(let ((fn-val (ocaml-eval fn-ast env))
|
|
(arg-val (ocaml-eval (nth ast 2) env)))
|
|
(fn-val arg-val))))))
|
|
((= tag "match")
|
|
(ocaml-match-eval (nth ast 1) (nth ast 2) env))
|
|
((= tag "function")
|
|
;; `function | pat -> body | …` — produces a unary closure that
|
|
;; matches its argument against the clauses.
|
|
(let ((clauses (nth ast 1)) (captured env))
|
|
(fn (arg) (ocaml-match-clauses arg clauses captured))))
|
|
((= tag "field")
|
|
;; `e.name` — evaluate e, expect a dict (record/module), get name.
|
|
;; Special case: `(:field (:con "M") "x")` looks up M as a module
|
|
;; binding rather than evaluating it as a nullary ctor.
|
|
(let ((target-ast (nth ast 1)) (fname (nth ast 2)))
|
|
(let ((target
|
|
(cond
|
|
((= (ocaml-tag-of target-ast) "con")
|
|
(cond
|
|
((ocaml-env-has? env (nth target-ast 1))
|
|
(ocaml-env-lookup env (nth target-ast 1)))
|
|
(else (list (nth target-ast 1)))))
|
|
(else (ocaml-eval target-ast env)))))
|
|
(cond
|
|
((dict? target) (get target fname))
|
|
(else (error
|
|
(str "ocaml-eval: not a record/module on .field: " target)))))))
|
|
((= tag "for")
|
|
;; (:for NAME LO HI DIR BODY) — DIR is "ascend" or "descend".
|
|
(let ((name (nth ast 1))
|
|
(lo (ocaml-eval (nth ast 2) env))
|
|
(hi (ocaml-eval (nth ast 3) env))
|
|
(dir (nth ast 4))
|
|
(body (nth ast 5)))
|
|
(begin
|
|
(cond
|
|
((= dir "ascend")
|
|
(let ((i lo))
|
|
(begin
|
|
(define loop
|
|
(fn ()
|
|
(when (<= i hi)
|
|
(begin
|
|
(ocaml-eval body
|
|
(ocaml-env-extend env name i))
|
|
(set! i (+ i 1))
|
|
(loop)))))
|
|
(loop))))
|
|
((= dir "descend")
|
|
(let ((i lo))
|
|
(begin
|
|
(define loop
|
|
(fn ()
|
|
(when (>= i hi)
|
|
(begin
|
|
(ocaml-eval body
|
|
(ocaml-env-extend env name i))
|
|
(set! i (- i 1))
|
|
(loop)))))
|
|
(loop)))))
|
|
nil)))
|
|
((= tag "try")
|
|
;; (:try EXPR CLAUSES) — evaluate EXPR; if it raises, match the
|
|
;; raised value against CLAUSES. Re-raise on no-match.
|
|
(let ((expr (nth ast 1)) (clauses (nth ast 2)) (env-cap env))
|
|
(guard (e
|
|
(else
|
|
(begin
|
|
(define try-clauses
|
|
(fn (cs)
|
|
(cond
|
|
((empty? cs) (raise e))
|
|
(else
|
|
(let ((clause (first cs)))
|
|
(let ((pat (nth clause 1))
|
|
(body (nth clause 2)))
|
|
(let ((env2 (ocaml-match-pat pat e env-cap)))
|
|
(cond
|
|
((= env2 ocaml-match-fail)
|
|
(try-clauses (rest cs)))
|
|
(else (ocaml-eval body env2))))))))))
|
|
(try-clauses clauses))))
|
|
(ocaml-eval expr env-cap))))
|
|
((= tag "while")
|
|
(let ((cond-ast (nth ast 1)) (body (nth ast 2)))
|
|
(begin
|
|
(define loop
|
|
(fn ()
|
|
(when (ocaml-eval cond-ast env)
|
|
(begin
|
|
(ocaml-eval body env)
|
|
(loop)))))
|
|
(loop)
|
|
nil)))
|
|
((= tag "let")
|
|
(let ((name (nth ast 1)) (params (nth ast 2))
|
|
(rhs (nth ast 3)) (body (nth ast 4)))
|
|
(let ((rhs-val
|
|
(if (= (len params) 0)
|
|
(ocaml-eval rhs env)
|
|
(ocaml-make-curried params rhs env))))
|
|
(ocaml-eval body (ocaml-env-extend env name rhs-val)))))
|
|
((= tag "let-rec")
|
|
;; Tie the knot via a mutable cell when rhs is function-typed.
|
|
;; The placeholder closure dereferences the cell on each call.
|
|
(let ((name (nth ast 1)) (params (nth ast 2))
|
|
(rhs (nth ast 3)) (body (nth ast 4)))
|
|
(let ((rhs-fn?
|
|
(or (> (len params) 0)
|
|
(= (ocaml-tag-of rhs) "fun")
|
|
(= (ocaml-tag-of rhs) "function"))))
|
|
(cond
|
|
(rhs-fn?
|
|
(let ((cell (list nil)))
|
|
(let ((env2 (ocaml-env-extend env name
|
|
(fn (arg) ((nth cell 0) arg)))))
|
|
(let ((rhs-val
|
|
(if (= (len params) 0)
|
|
(ocaml-eval rhs env2)
|
|
(ocaml-make-curried params rhs env2))))
|
|
(begin
|
|
(set-nth! cell 0 rhs-val)
|
|
(ocaml-eval body env2))))))
|
|
(else
|
|
(let ((rhs-val (ocaml-eval rhs env)))
|
|
(ocaml-eval body
|
|
(ocaml-env-extend env name rhs-val))))))))
|
|
(else (error
|
|
(str "ocaml-eval: unknown AST tag " tag)))))))
|
|
|
|
;; ocaml-make-functor — build a curried host-SX closure that accepts
|
|
;; argument modules (one per param) and returns the resulting module dict
|
|
;; produced by evaluating the functor's body.
|
|
(define ocaml-make-functor
|
|
(fn (params decls captured-env)
|
|
(cond
|
|
((= (len params) 1)
|
|
(fn (arg-mod)
|
|
(ocaml-eval-module decls
|
|
(ocaml-env-extend captured-env (first params) arg-mod))))
|
|
(else
|
|
(fn (arg-mod)
|
|
(ocaml-make-functor (rest params) decls
|
|
(ocaml-env-extend captured-env (first params) arg-mod)))))))
|
|
|
|
;; ocaml-eval-module — evaluate a list of decls in a fresh sub-env layered
|
|
;; on top of the parent. Returns a dict mapping each declared name to its
|
|
;; value. Used by `module M = struct DECLS end`.
|
|
(define ocaml-eval-module
|
|
(fn (decls parent-env)
|
|
(let ((env parent-env) (result {}))
|
|
(begin
|
|
(define run-decl
|
|
(fn (decl)
|
|
(let ((tag (ocaml-tag-of decl)))
|
|
(cond
|
|
((= tag "def")
|
|
(let ((name (nth decl 1)) (params (nth decl 2)) (rhs (nth decl 3)))
|
|
(let ((v (if (= (len params) 0)
|
|
(ocaml-eval rhs env)
|
|
(ocaml-make-curried params rhs env))))
|
|
(begin
|
|
(set! env (ocaml-env-extend env name v))
|
|
(set! result (merge result (dict name v)))))))
|
|
((= tag "def-rec")
|
|
(let ((name (nth decl 1)) (params (nth decl 2)) (rhs (nth decl 3)))
|
|
(let ((rhs-fn?
|
|
(or (> (len params) 0)
|
|
(= (ocaml-tag-of rhs) "fun")
|
|
(= (ocaml-tag-of rhs) "function"))))
|
|
(cond
|
|
(rhs-fn?
|
|
(let ((cell (list nil)))
|
|
(let ((env2 (ocaml-env-extend env name
|
|
(fn (arg) ((nth cell 0) arg)))))
|
|
(let ((v (if (= (len params) 0)
|
|
(ocaml-eval rhs env2)
|
|
(ocaml-make-curried params rhs env2))))
|
|
(begin
|
|
(set-nth! cell 0 v)
|
|
(set! env env2)
|
|
(set! result (merge result (dict name v))))))))
|
|
(else
|
|
(let ((v (ocaml-eval rhs env)))
|
|
(begin
|
|
(set! env (ocaml-env-extend env name v))
|
|
(set! result (merge result (dict name v))))))))))
|
|
((= tag "expr")
|
|
(ocaml-eval (nth decl 1) env))
|
|
((= tag "module-def")
|
|
(let ((mname (nth decl 1)) (mdecls (nth decl 2)))
|
|
(let ((mod-val (ocaml-eval-module mdecls env)))
|
|
(begin
|
|
(set! env (ocaml-env-extend env mname mod-val))
|
|
(set! result (merge result (dict mname mod-val)))))))
|
|
((= tag "functor-def")
|
|
(let ((mname (nth decl 1))
|
|
(mparams (nth decl 2))
|
|
(mdecls (nth decl 3)))
|
|
(let ((fn-val (ocaml-make-functor mparams mdecls env)))
|
|
(begin
|
|
(set! env (ocaml-env-extend env mname fn-val))
|
|
(set! result (merge result (dict mname fn-val)))))))
|
|
((= tag "module-alias")
|
|
(let ((mname (nth decl 1)) (body-src (nth decl 2)))
|
|
(let ((body-expr (ocaml-parse body-src)))
|
|
(let ((mod-val (ocaml-resolve-module-path body-expr env)))
|
|
(begin
|
|
(set! env (ocaml-env-extend env mname mod-val))
|
|
(set! result (merge result (dict mname mod-val))))))))
|
|
((= tag "open")
|
|
(let ((mod-val (ocaml-resolve-module-path (nth decl 1) env)))
|
|
(cond
|
|
((dict? mod-val)
|
|
(set! env (ocaml-env-merge-dict env mod-val)))
|
|
(else (error
|
|
(str "ocaml-eval: open on non-module: " mod-val))))))
|
|
((= tag "include")
|
|
;; `include M` brings M's bindings into scope AND into
|
|
;; the surrounding module's exports.
|
|
(let ((mod-val (ocaml-resolve-module-path (nth decl 1) env)))
|
|
(cond
|
|
((dict? mod-val)
|
|
(begin
|
|
(set! env (ocaml-env-merge-dict env mod-val))
|
|
(set! result (merge result mod-val))))
|
|
(else (error
|
|
(str "ocaml-eval: include on non-module: " mod-val))))))
|
|
(else (error (str "ocaml-eval-module: bad decl " tag)))))))
|
|
(define loop
|
|
(fn (xs)
|
|
(when (not (= xs (list)))
|
|
(begin (run-decl (first xs)) (loop (rest xs))))))
|
|
(loop decls)
|
|
result))))
|
|
|
|
;; ocaml-run — convenience wrapper: parse + eval. Layers the stdlib env
|
|
;; (List, Option, Result) underneath the empty env so user code can use
|
|
;; `List.map` etc. without explicit setup.
|
|
;; Variable guarded so eval.sx is loadable without runtime.sx. runtime.sx
|
|
;; sets ocaml-stdlib-env once loaded; before that, fall back to the empty
|
|
;; env so the existing tests continue to work without stdlib.
|
|
(define ocaml-stdlib-env nil)
|
|
(define ocaml-base-env
|
|
(fn ()
|
|
(cond
|
|
((not (= ocaml-stdlib-env nil)) ocaml-stdlib-env)
|
|
(else (ocaml-empty-env)))))
|
|
|
|
(define ocaml-run
|
|
(fn (src)
|
|
(ocaml-eval (ocaml-parse src) (ocaml-base-env))))
|
|
|
|
;; ocaml-run-program — evaluate a program (sequence of decls + bare exprs).
|
|
;; Threads an env through decls; returns the value of the last form.
|
|
(define ocaml-run-program
|
|
(fn (src)
|
|
(let ((prog (ocaml-parse-program src)) (env (ocaml-base-env)) (last nil))
|
|
(begin
|
|
(define run-decl
|
|
(fn (decl)
|
|
(let ((tag (ocaml-tag-of decl)))
|
|
(cond
|
|
((= tag "def")
|
|
(let ((name (nth decl 1)) (params (nth decl 2)) (rhs (nth decl 3)))
|
|
(let ((v (if (= (len params) 0)
|
|
(ocaml-eval rhs env)
|
|
(ocaml-make-curried params rhs env))))
|
|
(begin
|
|
(set! env (ocaml-env-extend env name v))
|
|
(set! last v)))))
|
|
((= tag "def-rec")
|
|
(let ((name (nth decl 1)) (params (nth decl 2)) (rhs (nth decl 3)))
|
|
(let ((rhs-fn?
|
|
(or (> (len params) 0)
|
|
(= (ocaml-tag-of rhs) "fun")
|
|
(= (ocaml-tag-of rhs) "function"))))
|
|
(cond
|
|
(rhs-fn?
|
|
(let ((cell (list nil)))
|
|
(let ((env2 (ocaml-env-extend env name
|
|
(fn (arg) ((nth cell 0) arg)))))
|
|
(let ((v
|
|
(if (= (len params) 0)
|
|
(ocaml-eval rhs env2)
|
|
(ocaml-make-curried params rhs env2))))
|
|
(begin
|
|
(set-nth! cell 0 v)
|
|
(set! env env2)
|
|
(set! last v))))))
|
|
(else
|
|
(let ((v (ocaml-eval rhs env)))
|
|
(begin
|
|
(set! env (ocaml-env-extend env name v))
|
|
(set! last v))))))))
|
|
((= tag "def-mut")
|
|
;; let x = ... and y = ... — non-recursive; each rhs is
|
|
;; evaluated in the parent env, then all names bind in
|
|
;; sequence.
|
|
(let ((bs (nth decl 1)))
|
|
(begin
|
|
(define run-one
|
|
(fn (b)
|
|
(let ((nm (nth b 0)) (ps (nth b 1)) (rh (nth b 2)))
|
|
(let ((v (if (= (len ps) 0)
|
|
(ocaml-eval rh env)
|
|
(ocaml-make-curried ps rh env))))
|
|
(begin
|
|
(set! env (ocaml-env-extend env nm v))
|
|
(set! last v))))))
|
|
(define loop
|
|
(fn (xs)
|
|
(when (not (= xs (list)))
|
|
(begin (run-one (first xs)) (loop (rest xs))))))
|
|
(loop bs))))
|
|
((= tag "def-rec-mut")
|
|
;; let rec f = ... and g = ... — mutually recursive;
|
|
;; bind all names with placeholder cells first, then
|
|
;; evaluate each rhs in the joint env, finally fill cells.
|
|
(let ((bs (nth decl 1)) (cells (list)) (env2 env))
|
|
(begin
|
|
(define alloc
|
|
(fn (xs)
|
|
(when (not (= xs (list)))
|
|
(let ((b (first xs)))
|
|
(let ((c (list nil)) (nm (nth b 0)))
|
|
(begin
|
|
(append! cells c)
|
|
(set! env2 (ocaml-env-extend env2 nm
|
|
(fn (a) ((nth c 0) a))))
|
|
(alloc (rest xs))))))))
|
|
(alloc bs)
|
|
(let ((idx 0))
|
|
(begin
|
|
(define fill
|
|
(fn (xs)
|
|
(when (not (= xs (list)))
|
|
(let ((b (first xs)))
|
|
(let ((nm (nth b 0)) (ps (nth b 1)) (rh (nth b 2)))
|
|
(let ((v (if (= (len ps) 0)
|
|
(ocaml-eval rh env2)
|
|
(ocaml-make-curried ps rh env2))))
|
|
(begin
|
|
(set-nth! (nth cells idx) 0 v)
|
|
(set! idx (+ idx 1))
|
|
(set! last v)
|
|
(fill (rest xs)))))))))
|
|
(fill bs)
|
|
(set! env env2))))))
|
|
((= tag "expr")
|
|
(set! last (ocaml-eval (nth decl 1) env)))
|
|
((= tag "module-def")
|
|
;; module M = struct DECLS end — evaluate the inner
|
|
;; decls in a fresh sub-env layered on the current
|
|
;; one, then collect the new bindings into a dict that
|
|
;; we bind under M.
|
|
(let ((mname (nth decl 1)) (mdecls (nth decl 2)))
|
|
(let ((mod-val (ocaml-eval-module mdecls env)))
|
|
(begin
|
|
(set! env (ocaml-env-extend env mname mod-val))
|
|
(set! last mod-val)))))
|
|
((= tag "functor-def")
|
|
;; module F (M1) (M2) ... = struct DECLS end — bind F
|
|
;; to a curried function from module dicts to a module
|
|
;; dict.
|
|
(let ((mname (nth decl 1))
|
|
(mparams (nth decl 2))
|
|
(mdecls (nth decl 3)))
|
|
(let ((functor-val
|
|
(ocaml-make-functor mparams mdecls env)))
|
|
(begin
|
|
(set! env (ocaml-env-extend env mname functor-val))
|
|
(set! last functor-val)))))
|
|
((= tag "module-alias")
|
|
;; module N = M / module N = F(A) / module N = M.Sub
|
|
(let ((mname (nth decl 1)) (body-src (nth decl 2)))
|
|
(let ((body-expr (ocaml-parse body-src)))
|
|
(let ((mod-val (ocaml-resolve-module-path body-expr env)))
|
|
(begin
|
|
(set! env (ocaml-env-extend env mname mod-val))
|
|
(set! last mod-val))))))
|
|
((or (= tag "open") (= tag "include"))
|
|
;; open M / include M — bring M's bindings into scope.
|
|
(let ((mod-val (ocaml-resolve-module-path (nth decl 1) env)))
|
|
(cond
|
|
((dict? mod-val)
|
|
(begin
|
|
(set! env (ocaml-env-merge-dict env mod-val))
|
|
(set! last mod-val)))
|
|
(else (error (str "ocaml-eval: open/include on non-module: " mod-val))))))
|
|
(else (error (str "ocaml-run-program: bad decl " tag)))))))
|
|
(define loop
|
|
(fn (xs)
|
|
(when (not (= xs (list)))
|
|
(begin (run-decl (first xs)) (loop (rest xs))))))
|
|
(loop (rest prog))
|
|
last))))
|