diff --git a/lib/ocaml/eval.sx b/lib/ocaml/eval.sx index e6176172..f7dd1f8a 100644 --- a/lib/ocaml/eval.sx +++ b/lib/ocaml/eval.sx @@ -156,23 +156,26 @@ (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) - (let ((val (ocaml-eval scrut-ast 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))))) + (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 — @@ -300,6 +303,11 @@ (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)) @@ -354,30 +362,30 @@ (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. + ;; 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))) - (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))))))))) + (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))))))) @@ -406,21 +414,28 @@ (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))))))))) + (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))))))) diff --git a/lib/ocaml/parser.sx b/lib/ocaml/parser.sx index 3e548b5c..8e93415a 100644 --- a/lib/ocaml/parser.sx +++ b/lib/ocaml/parser.sx @@ -573,6 +573,28 @@ (begin (advance-tok!) (one) (loop))))) (loop) (cons :match (cons scrut (list cases))))))))) + (define parse-function + (fn () + ;; `function | pat -> body | …` ≡ fun x -> match x with | pat -> body + (let () + (begin + (when (at-op? "|") (advance-tok!)) + (let ((cases (list))) + (begin + (define one + (fn () + (let ((p (parse-pattern))) + (begin + (consume! "op" "->") + (let ((body (parse-expr))) + (append! cases (list :case p body))))))) + (one) + (define loop + (fn () + (when (at-op? "|") + (begin (advance-tok!) (one) (loop))))) + (loop) + (list :function cases))))))) (define parse-for (fn () (let ((name (ocaml-tok-value (consume! "ident" nil)))) @@ -609,6 +631,7 @@ ((at-kw? "let") (begin (advance-tok!) (parse-let))) ((at-kw? "if") (begin (advance-tok!) (parse-if))) ((at-kw? "match") (begin (advance-tok!) (parse-match))) + ((at-kw? "function") (begin (advance-tok!) (parse-function))) ((at-kw? "for") (begin (advance-tok!) (parse-for))) ((at-kw? "while") (begin (advance-tok!) (parse-while))) (else (parse-tuple))))) diff --git a/lib/ocaml/test.sh b/lib/ocaml/test.sh index abd32a5d..ac93a4a7 100755 --- a/lib/ocaml/test.sh +++ b/lib/ocaml/test.sh @@ -507,6 +507,16 @@ cat > "$TMPFILE" << 'EPOCHS' (epoch 624) (eval "(ocaml-run \"let p = ref 1 in for i = 1 to 5 do p := !p * i done; !p\")") +;; ── function (sugar for fun + match) ─────────────────────────── +(epoch 640) +(eval "(ocaml-run \"(function | None -> 0 | Some x -> x) (Some 7)\")") +(epoch 641) +(eval "(ocaml-run \"let f = function | None -> 0 | Some x -> x in f None\")") +(epoch 642) +(eval "(ocaml-run \"let rec len = function | [] -> 0 | _ :: t -> 1 + len t in len [1; 2; 3]\")") +(epoch 643) +(eval "(ocaml-run-program \"let rec map f = function | [] -> [] | h :: t -> f h :: map f t;; map (fun x -> x * x) [1; 2; 3; 4]\")") + EPOCHS OUTPUT=$(timeout 60 "$SX_SERVER" < "$TMPFILE" 2>/dev/null) @@ -808,6 +818,12 @@ check 622 "while loop" '15' check 623 "for 1..100 sum" '5050' check 624 "for 1..5 product = 120" '120' +# ── function ──────────────────────────────────────────────────── +check 640 "function None|Some Some 7" '7' +check 641 "function None=0" '0' +check 642 "rec function len" '3' +check 643 "rec function map x*x" '(1 4 9 16)' + TOTAL=$((PASS + FAIL)) if [ $FAIL -eq 0 ]; then echo "ok $PASS/$TOTAL OCaml-on-SX tests passed" diff --git a/plans/ocaml-on-sx.md b/plans/ocaml-on-sx.md index 4c0975e2..6cfb681c 100644 --- a/plans/ocaml-on-sx.md +++ b/plans/ocaml-on-sx.md @@ -148,8 +148,7 @@ SX CEK evaluator (both JS and OCaml hosts) - [~] `let`/`let rec`/`let ... in` (single-binding done; mutually recursive `and` deferred). - [x] Lambda + application (curried by default — auto-curry multi-param defs). -- [ ] `fun`/`function` (single-arg lambda with immediate match on arg). _(`fun` - done; `function` blocked on parser support.)_ +- [x] `fun`/`function` (single-arg lambda with immediate match on arg). - [x] `if`/`then`/`else`, `begin`/`end`, sequence `;`. - [x] Arithmetic, comparison, boolean ops, string `^`, `mod`. - [x] Unit `()` value; `ignore`. @@ -321,6 +320,13 @@ the "mother tongue" closure: OCaml → SX → OCaml. This means: _Newest first._ +- 2026-05-08 Phase 2 — `function | pat -> body | …` parser + eval. + Sugar for `fun x -> match x with | …`. AST: `(:function CLAUSES)` + evaluated to a unary closure that runs `ocaml-match-clauses` on the + argument. `let rec` knot also triggers when rhs is `:function`, so + `let rec map f = function | [] -> [] | h::t -> f h :: map f t` works. + ocaml-match-eval refactored to share `ocaml-match-clauses` with the + function form. 198/198 (+4). - 2026-05-08 Phase 2 — `for`/`while` loops. `(:for NAME LO HI DIR BODY)` with `:ascend`/`:descend` direction (`to`/`downto`); `(:while COND BODY)`. Both eval to unit and re-bind the loop var per iteration. 194/194 (+5).