coop/rose-ash
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

ocaml: phase 2 evaluator slice (+42 tests, 165 total)
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 52s
Details

Browse Source 
ocaml-eval walks the AST and yields SX values. ocaml-run / ocaml-run-program
wrap parse + eval. Coverage: atoms, vars, app (curried), 22 binary ops,
prefix - and not, if/seq/tuple/list, fun (auto-curried via host SX
lambdas), let, let-rec (mutable-cell knot for recursive functions).
Initial env: not/succ/pred/abs/max/min/fst/snd/ignore. Tests: arithmetic,
comparison, string concat, closures, fact 5 / fib 10 / sum 100,
top-level decls, |> pipe.
This commit is contained in:
giles
2026-05-08 07:57:20 +00:00
parent a6ab944c39
commit 4dca583ee3
3 changed files with 436 additions and 7 deletions
Download Patch File Download Diff File Expand all files Collapse all files

244
lib/ocaml/eval.sx Normal file
View File

@@ -0,0 +1,244 @@
;; 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)))))
(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))
;; 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 "op")
(ocaml-eval-op
(nth ast 1)
(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 "app")
(let ((fn-val (ocaml-eval (nth ast 1) env))
(arg-val (ocaml-eval (nth ast 2) env)))
(fn-val arg-val)))
((= 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")
;; For function bindings: tie the knot via a mutable cell. The
;; placeholder closure that's bound first dereferences the cell
;; on each call, so the function can call itself once the cell
;; is set to the real closure.
(let ((name (nth ast 1)) (params (nth ast 2))
(rhs (nth ast 3)) (body (nth ast 4)))
(cond
((= (len params) 0)
;; Non-functional let-rec — OCaml only allows this when the
;; rhs is "syntactically a function or constructor". For the
;; common case of a value, evaluate non-recursively.
(let ((rhs-val (ocaml-eval rhs env)))
(ocaml-eval body (ocaml-env-extend env name rhs-val))))
(else
;; Use a one-element list as a mutable cell to tie the
;; recursive knot. The placeholder closure dereferences
;; the cell on each call.
(let ((cell (list nil)))
(let ((env2 (ocaml-env-extend env name
(fn (arg) ((nth cell 0) arg)))))
(let ((rhs-val (ocaml-make-curried params rhs env2)))
(begin
(set-nth! cell 0 rhs-val)
(ocaml-eval body env2)))))))))
(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)))
(cond
((= (len params) 0)
(let ((v (ocaml-eval rhs env)))
(begin
(set! env (ocaml-env-extend env name v))
(set! last v))))
(else
(let ((cell (list nil)))
(let ((env2 (ocaml-env-extend env name
(fn (arg) ((nth cell 0) arg)))))
(let ((v (ocaml-make-curried params rhs env2)))
(begin
(set-nth! cell 0 v)
(set! env env2)
(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))))

173
lib/ocaml/test.sh
View File

@@ -32,6 +32,7 @@ cat > "$TMPFILE" << 'EPOCHS'
(load "lib/guest/pratt.sx")
(load "lib/ocaml/tokenizer.sx")
(load "lib/ocaml/parser.sx")
(load "lib/ocaml/eval.sx")
(load "lib/ocaml/tests/tokenize.sx")
;; ── empty / eof ────────────────────────────────────────────────
@@ -322,6 +323,113 @@ cat > "$TMPFILE" << 'EPOCHS'
(epoch 329)
(eval "(ocaml-parse \"match x with | _ -> a; b\")")
;; ── Phase 2: evaluator ─────────────────────────────────────────
;; Atoms
(epoch 400)
(eval "(ocaml-run \"42\")")
(epoch 401)
(eval "(ocaml-run \"3.14\")")
(epoch 402)
(eval "(ocaml-run \"true\")")
(epoch 403)
(eval "(ocaml-run \"false\")")
(epoch 404)
(eval "(ocaml-run \"\\\"hi\\\"\")")
;; Arithmetic
(epoch 410)
(eval "(ocaml-run \"1 + 2\")")
(epoch 411)
(eval "(ocaml-run \"10 - 3\")")
(epoch 412)
(eval "(ocaml-run \"4 * 5\")")
(epoch 413)
(eval "(ocaml-run \"20 / 4\")")
(epoch 414)
(eval "(ocaml-run \"10 mod 3\")")
(epoch 415)
(eval "(ocaml-run \"2 ** 10\")")
(epoch 416)
(eval "(ocaml-run \"(1 + 2) * 3\")")
(epoch 417)
(eval "(ocaml-run \"1 + 2 * 3\")")
(epoch 418)
(eval "(ocaml-run \"-5 + 10\")")
;; Comparison & boolean
(epoch 420)
(eval "(ocaml-run \"1 < 2\")")
(epoch 421)
(eval "(ocaml-run \"3 > 2\")")
(epoch 422)
(eval "(ocaml-run \"2 = 2\")")
(epoch 423)
(eval "(ocaml-run \"1 <> 2\")")
(epoch 424)
(eval "(ocaml-run \"true && false\")")
(epoch 425)
(eval "(ocaml-run \"true || false\")")
(epoch 426)
(eval "(ocaml-run \"not false\")")
;; String
(epoch 430)
(eval "(ocaml-run \"\\\"a\\\" ^ \\\"b\\\"\")")
(epoch 431)
(eval "(ocaml-run \"\\\"hello\\\" ^ \\\" \\\" ^ \\\"world\\\"\")")
;; Conditional
(epoch 440)
(eval "(ocaml-run \"if true then 1 else 2\")")
(epoch 441)
(eval "(ocaml-run \"if 1 > 2 then 100 else 200\")")
;; Let / lambda / app
(epoch 450)
(eval "(ocaml-run \"let x = 5 in x * 2\")")
(epoch 451)
(eval "(ocaml-run \"let f x = x + 1 in f 41\")")
(epoch 452)
(eval "(ocaml-run \"let f x y = x + y in f 3 4\")")
(epoch 453)
(eval "(ocaml-run \"(fun x -> x * x) 7\")")
(epoch 454)
(eval "(ocaml-run \"(fun x -> fun y -> x + y) 10 20\")")
(epoch 455)
(eval "(ocaml-run \"let f = fun x -> x + 1 in f 9\")")
;; Closures capture
(epoch 460)
(eval "(ocaml-run \"let x = 10 in let f y = x + y in f 5\")")
(epoch 461)
(eval "(ocaml-run \"let make_adder n = fun x -> n + x in (make_adder 100) 1\")")
;; Recursion
(epoch 470)
(eval "(ocaml-run \"let rec fact n = if n = 0 then 1 else n * fact (n - 1) in fact 5\")")
(epoch 471)
(eval "(ocaml-run \"let rec fib n = if n < 2 then n else fib (n - 1) + fib (n - 2) in fib 10\")")
(epoch 472)
(eval "(ocaml-run \"let rec sum n = if n = 0 then 0 else n + sum (n - 1) in sum 100\")")
;; Sequence
(epoch 480)
(eval "(ocaml-run \"1; 2; 3\")")
(epoch 481)
(eval "(ocaml-run \"begin 10 end\")")
;; Programs (top-level decls)
(epoch 490)
(eval "(ocaml-run-program \"let x = 1;; let y = 2;; x + y\")")
(epoch 491)
(eval "(ocaml-run-program \"let rec fact n = if n = 0 then 1 else n * fact (n - 1);; fact 6\")")
(epoch 492)
(eval "(ocaml-run-program \"let inc x = x + 1;; let double x = x * 2;; double (inc 4)\")")
;; Pipe
(epoch 495)
(eval "(ocaml-run \"let f x = x * 2 in 5 |> f\")")
EPOCHS
OUTPUT=$(timeout 60 "$SX_SERVER" < "$TMPFILE" 2>/dev/null)
@@ -510,6 +618,71 @@ check 327 "trailing ; OK" '("seq" ("int" 1) ("int" 2))'
check 328 "begin a; end singleton seq" '("seq" ("var" "a"))'
check 329 "match clause body absorbs ;" '("case" ("pwild") ("seq" ("var" "a") ("var" "b")))'
# ── Phase 2: evaluator ──────────────────────────────────────────
# atoms
check 400 "eval int" '42'
check 401 "eval float" '3.14'
check 402 "eval true" 'true'
check 403 "eval false" 'false'
check 404 "eval string" '"hi"'
# arithmetic
check 410 "eval 1+2" '3'
check 411 "eval 10-3" '7'
check 412 "eval 4*5" '20'
check 413 "eval 20/4" '5'
check 414 "eval 10 mod 3" '1'
check 415 "eval 2 ** 10" '1024'
check 416 "eval (1+2)*3" '9'
check 417 "eval 1+2*3 prec" '7'
check 418 "eval -5+10" '5'
# comparison & boolean
check 420 "eval 1<2" 'true'
check 421 "eval 3>2" 'true'
check 422 "eval 2=2" 'true'
check 423 "eval 1<>2" 'true'
check 424 "eval true && false" 'false'
check 425 "eval true || false" 'true'
check 426 "eval not false" 'true'
# string
check 430 'eval "a" ^ "b"' '"ab"'
check 431 "eval string concat 3" '"hello world"'
# conditional
check 440 "eval if true 1 else 2" '1'
check 441 "eval if 1>2 100 else 200" '200'
# let / lambda / app
check 450 "eval let x=5 x*2" '10'
check 451 "eval let f x = x+1; f 41" '42'
check 452 "eval let f x y = x+y; f 3 4" '7'
check 453 "eval (fun x -> x*x) 7" '49'
check 454 "eval curried lambdas" '30'
check 455 "eval named lambda" '10'
# closures
check 460 "eval closure capture" '15'
check 461 "eval make_adder" '101'
# recursion
check 470 "eval fact 5" '120'
check 471 "eval fib 10" '55'
check 472 "eval sum 100" '5050'
# sequence
check 480 "eval 1; 2; 3 → 3" '3'
check 481 "eval begin 10 end" '10'
# programs
check 490 "run-prog x+y" '3'
check 491 "run-prog fact 6" '720'
check 492 "run-prog inc + double" '10'
# pipe
check 495 "eval x |> f" '10'
TOTAL=$((PASS + FAIL))
if [ $FAIL -eq 0 ]; then
echo "ok $PASS/$TOTAL OCaml-on-SX tests passed"