kernel: $cond/$when/$unless + 12 tests [nothing]
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 28s
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 28s
Standard Kernel control flow. $cond walks clauses in order with `else` catch-all; clauses past the first match are NOT evaluated. $when/$unless are simple guards. 12 tests, 242 total.
This commit is contained in:
@@ -237,6 +237,70 @@
|
||||
((or (nil? xs) (= (length xs) 0)) ys)
|
||||
(:else (cons (first xs) (knl-list-concat (rest xs) ys))))))
|
||||
|
||||
;; $cond — multi-clause branch.
|
||||
;; ($cond (TEST1 EXPR1 ...) (TEST2 EXPR2 ...) ...)
|
||||
;; Evaluates each TEST in order; first truthy one runs its EXPRs (in
|
||||
;; sequence) and returns the last; if no TEST is truthy, returns nil.
|
||||
;; A clause with TEST = `else` always matches (sugar for $if's default).
|
||||
(define knl-cond-impl
|
||||
(fn (clauses dyn-env)
|
||||
(cond
|
||||
((or (nil? clauses) (= (length clauses) 0)) nil)
|
||||
(:else
|
||||
(let ((clause (first clauses)))
|
||||
(cond
|
||||
((not (list? clause))
|
||||
(error "$cond: each clause must be a list"))
|
||||
((= (length clause) 0)
|
||||
(error "$cond: empty clause"))
|
||||
((and (string? (first clause)) (= (first clause) "else"))
|
||||
(knl-cond-eval-body (rest clause) dyn-env))
|
||||
(:else
|
||||
(let ((test-val (kernel-eval (first clause) dyn-env)))
|
||||
(cond
|
||||
(test-val (knl-cond-eval-body (rest clause) dyn-env))
|
||||
(:else (knl-cond-impl (rest clauses) dyn-env)))))))))))
|
||||
|
||||
(define knl-cond-eval-body
|
||||
(fn (body dyn-env)
|
||||
(cond
|
||||
((or (nil? body) (= (length body) 0)) nil)
|
||||
((= (length body) 1) (kernel-eval (first body) dyn-env))
|
||||
(:else
|
||||
(begin
|
||||
(kernel-eval (first body) dyn-env)
|
||||
(knl-cond-eval-body (rest body) dyn-env))))))
|
||||
|
||||
(define kernel-cond-operative
|
||||
(kernel-make-primitive-operative
|
||||
(fn (args dyn-env) (knl-cond-impl args dyn-env))))
|
||||
|
||||
;; $when COND BODY... — evaluate body iff COND is truthy; else nil.
|
||||
(define kernel-when-operative
|
||||
(kernel-make-primitive-operative
|
||||
(fn (args dyn-env)
|
||||
(cond
|
||||
((< (length args) 1)
|
||||
(error "$when: expects (cond body...)"))
|
||||
(:else
|
||||
(let ((c (kernel-eval (first args) dyn-env)))
|
||||
(cond
|
||||
(c (knl-cond-eval-body (rest args) dyn-env))
|
||||
(:else nil))))))))
|
||||
|
||||
;; $unless COND BODY... — evaluate body iff COND is falsy; else nil.
|
||||
(define kernel-unless-operative
|
||||
(kernel-make-primitive-operative
|
||||
(fn (args dyn-env)
|
||||
(cond
|
||||
((< (length args) 1)
|
||||
(error "$unless: expects (cond body...)"))
|
||||
(:else
|
||||
(let ((c (kernel-eval (first args) dyn-env)))
|
||||
(cond
|
||||
(c nil)
|
||||
(:else (knl-cond-eval-body (rest args) dyn-env)))))))))
|
||||
|
||||
(define kernel-quasiquote-operative
|
||||
(kernel-make-primitive-operative
|
||||
(fn (args dyn-env)
|
||||
@@ -514,6 +578,9 @@
|
||||
(kernel-env-bind! env "$sequence" kernel-sequence-operative)
|
||||
(kernel-env-bind! env "$quote" kernel-quote-operative)
|
||||
(kernel-env-bind! env "$quasiquote" kernel-quasiquote-operative)
|
||||
(kernel-env-bind! env "$cond" kernel-cond-operative)
|
||||
(kernel-env-bind! env "$when" kernel-when-operative)
|
||||
(kernel-env-bind! env "$unless" kernel-unless-operative)
|
||||
(kernel-env-bind! env "eval" kernel-eval-applicative)
|
||||
(kernel-env-bind!
|
||||
env
|
||||
|
||||
@@ -285,4 +285,38 @@
|
||||
(ks-eval-in "`(a ,@x b)" env)))
|
||||
:raised)
|
||||
|
||||
;; ── $cond / $when / $unless ─────────────────────────────────────
|
||||
(ks-test "cond: first match"
|
||||
(ks-eval "($cond (#f 1) (#t 2) (#t 3))") 2)
|
||||
(ks-test "cond: else fallback"
|
||||
(ks-eval "($cond (#f 1) (else 99))") 99)
|
||||
(ks-test "cond: no match returns nil"
|
||||
(ks-eval "($cond (#f 1) (#f 2))") nil)
|
||||
(ks-test "cond: empty clauses returns nil"
|
||||
(ks-eval "($cond)") nil)
|
||||
(ks-test "cond: multi-expr body"
|
||||
(ks-eval "($cond (#t 1 2 3))") 3)
|
||||
(ks-test "cond: doesn't evaluate untaken clauses"
|
||||
;; If the second clause's test were evaluated, the unbound `nope` would error.
|
||||
(ks-eval "($cond (#t 7) (nope ignored))") 7)
|
||||
(ks-test "cond: predicate evaluation"
|
||||
(let ((env (kernel-standard-env)))
|
||||
(ks-eval-in "($define! n 5)" env)
|
||||
(ks-eval-in "($cond ((< n 0) ($quote negative)) ((= n 0) ($quote zero)) (else ($quote positive)))" env))
|
||||
"positive")
|
||||
|
||||
(ks-test "when: true runs body"
|
||||
(ks-eval "($when #t 1 2 3)") 3)
|
||||
(ks-test "when: false returns nil"
|
||||
(ks-eval "($when #f 1 2 3)") nil)
|
||||
(ks-test "when: skips body when false"
|
||||
(ks-eval "($when #f nope)") nil)
|
||||
|
||||
(ks-test "unless: false runs body"
|
||||
(ks-eval "($unless #f 99)") 99)
|
||||
(ks-test "unless: true returns nil"
|
||||
(ks-eval "($unless #t 99)") nil)
|
||||
(ks-test "unless: skips body when true"
|
||||
(ks-eval "($unless #t nope)") nil)
|
||||
|
||||
(define ks-tests-run! (fn () {:total (+ ks-test-pass ks-test-fail) :passed ks-test-pass :failed ks-test-fail :fails ks-test-fails}))
|
||||
|
||||
Reference in New Issue
Block a user