ocaml: phase 2+3 'when' guard in try/with (+3 tests, 467 total)
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 27s
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 27s
parse-try now consumes optional 'when GUARD-EXPR' before -> and emits (:case-when PAT GUARD BODY). Eval try clause loop dispatches on case / case-when and falls through on guard false — same semantics as match. Examples: try raise (E 5) with | E n when n > 0 -> n | _ -> 0 = 5 try raise (E (-3)) with | E n when n > 0 -> n | _ -> 0 = 0 try raise (E 5) with | E n when n > 100 -> n | E n -> n + 1000 = 1005
This commit is contained in:
@@ -592,8 +592,9 @@
|
||||
(loop)))))
|
||||
nil)))
|
||||
((= tag "try")
|
||||
;; (:try EXPR CLAUSES) — evaluate EXPR; if it raises, match the
|
||||
;; raised value against CLAUSES. Re-raise on no-match.
|
||||
;; (:try EXPR CLAUSES) — evaluate EXPR; if it raises, match
|
||||
;; the raised value against CLAUSES (case + case-when).
|
||||
;; Re-raise on no-match.
|
||||
(let ((expr (nth ast 1)) (clauses (nth ast 2)) (env-cap env))
|
||||
(guard (e
|
||||
(else
|
||||
@@ -604,13 +605,26 @@
|
||||
((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))))))))))
|
||||
(let ((ctag (nth clause 0)))
|
||||
(cond
|
||||
((= ctag "case")
|
||||
(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))))))
|
||||
((= ctag "case-when")
|
||||
(let ((pat (nth clause 1))
|
||||
(g (nth clause 2))
|
||||
(body (nth clause 3)))
|
||||
(let ((env2 (ocaml-match-pat pat e env-cap)))
|
||||
(cond
|
||||
((= env2 ocaml-match-fail) (try-clauses (rest cs)))
|
||||
((not (ocaml-eval g env2)) (try-clauses (rest cs)))
|
||||
(else (ocaml-eval body env2))))))
|
||||
(else (raise e)))))))))
|
||||
(try-clauses clauses))))
|
||||
(ocaml-eval expr env-cap))))
|
||||
((= tag "while")
|
||||
|
||||
@@ -773,11 +773,18 @@
|
||||
(begin
|
||||
(define one
|
||||
(fn ()
|
||||
(let ((p (parse-pattern)))
|
||||
(let ((p (parse-pattern)) (guard nil))
|
||||
(begin
|
||||
(when (at-kw? "when")
|
||||
(begin (advance-tok!)
|
||||
(set! guard (parse-expr-no-seq))))
|
||||
(consume! "op" "->")
|
||||
(let ((body (parse-expr)))
|
||||
(append! cases (list :case p body)))))))
|
||||
(cond
|
||||
((= guard nil)
|
||||
(append! cases (list :case p body)))
|
||||
(else
|
||||
(append! cases (list :case-when p guard body)))))))))
|
||||
(one)
|
||||
(define loop
|
||||
(fn ()
|
||||
|
||||
@@ -1148,6 +1148,14 @@ cat > "$TMPFILE" << 'EPOCHS'
|
||||
(epoch 4402)
|
||||
(eval "(ocaml-run \"(function | n when n > 0 -> 1 | n when n < 0 -> -1 | _ -> 0) 0\")")
|
||||
|
||||
;; ── try/with `when` guard ─────────────────────────────────────
|
||||
(epoch 4500)
|
||||
(eval "(ocaml-run \"try raise (E 5) with | E n when n > 0 -> n | _ -> 0\")")
|
||||
(epoch 4501)
|
||||
(eval "(ocaml-run \"try raise (E (-3)) with | E n when n > 0 -> n | _ -> 0\")")
|
||||
(epoch 4502)
|
||||
(eval "(ocaml-run \"try raise (E 5) with | E n when n > 100 -> n | E n -> n + 1000\")")
|
||||
|
||||
EPOCHS
|
||||
|
||||
OUTPUT=$(timeout 180 "$SX_SERVER" < "$TMPFILE" 2>/dev/null)
|
||||
@@ -1818,6 +1826,11 @@ check 4400 "function when 5" '1'
|
||||
check 4401 "function when -3" '0'
|
||||
check 4402 "function sign 0" '0'
|
||||
|
||||
# ── try/with `when` guard ──────────────────────────────────────
|
||||
check 4500 "try when guard fires" '5'
|
||||
check 4501 "try when guard skips" '0'
|
||||
check 4502 "try when fall through" '1005'
|
||||
|
||||
TOTAL=$((PASS + FAIL))
|
||||
if [ $FAIL -eq 0 ]; then
|
||||
echo "ok $PASS/$TOTAL OCaml-on-SX tests passed"
|
||||
|
||||
@@ -407,6 +407,10 @@ _Newest first._
|
||||
binary search tree (`type 'a tree = Leaf | Node of 'a * 'a tree *
|
||||
'a tree`) with insert + in-order traversal. Tests parametric ADT,
|
||||
recursive match, List.append, List.fold_left.
|
||||
- 2026-05-08 Phase 2+3 — `try ... with | pat when GUARD -> body` guard
|
||||
support (+3 tests, 467 total). parse-try mirrors match/function;
|
||||
eval-try clause loop now dispatches on `case`/`case-when` and falls
|
||||
through to next clause when guard is false.
|
||||
- 2026-05-08 Phase 1+3 — `function | pat when GUARD -> body | …`
|
||||
guard support (+3 tests, 464 total). `parse-function` mirrors the
|
||||
match-clause when-handling.
|
||||
|
||||
Reference in New Issue
Block a user