giles
937342bbf0
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 54s
Sugar for fun + match. AST (:function CLAUSES) -> unary closure that runs ocaml-match-clauses on its arg. let rec recognises :function as a recursive rhs and ties the knot via cell, so let rec map f = function | [] -> [] | h::t -> f h :: map f t works. ocaml-match-eval refactored to share clause-walk with function.
448 lines
18 KiB
Plaintext
448 lines
18 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))))))
|
|
|
|
(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)))
|
|
|
|
(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 "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 "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-run — convenience wrapper: parse + eval.
|
|
(define ocaml-run
|
|
(fn (src)
|
|
(ocaml-eval (ocaml-parse src) (ocaml-empty-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-empty-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 "expr")
|
|
(set! last (ocaml-eval (nth decl 1) env)))
|
|
(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))))
|