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

ocaml: phase 2 function | pat -> body (+4 tests, 198 total)
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 54s
Details

Browse Source 
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.
This commit is contained in:
giles
2026-05-08 08:15:38 +00:00
parent 9b8b0b4325
commit 937342bbf0
4 changed files with 114 additions and 54 deletions
Download Patch File Download Diff File Expand all files Collapse all files

119
lib/ocaml/eval.sx
View File

@@ -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)))))))