diff --git a/lib/kernel/runtime.sx b/lib/kernel/runtime.sx index 03480b32..38841c8a 100644 --- a/lib/kernel/runtime.sx +++ b/lib/kernel/runtime.sx @@ -391,6 +391,45 @@ (error (str name ": expects 2 arguments"))) (:else (f (first args) (nth args 1)))))))) +;; Variadic left-fold helper. ZERO-RES is the identity (`(+)` → 0); +;; ONE-FN handles single-arg case (`(- x)` negates; `(+ x)` returns x). +(define knl-fold-step + (fn (f acc rest-args) + (cond + ((or (nil? rest-args) (= (length rest-args) 0)) acc) + (:else + (knl-fold-step f (f acc (first rest-args)) (rest rest-args)))))) + +(define knl-fold-app + (fn (name f zero-res one-fn) + (kernel-make-primitive-applicative + (fn (args) + (cond + ((= (length args) 0) zero-res) + ((= (length args) 1) (one-fn (first args))) + (:else (knl-fold-step f (first args) (rest args)))))))) + +;; Variadic n-ary chained comparison: `(< 1 2 3)` ≡ `(< 1 2)` AND `(< 2 3)`. +(define knl-chain-step + (fn (cmp prev rest-args) + (cond + ((or (nil? rest-args) (= (length rest-args) 0)) true) + (:else + (let ((next (first rest-args))) + (cond + ((cmp prev next) + (knl-chain-step cmp next (rest rest-args))) + (:else false))))))) + +(define knl-chain-cmp + (fn (name cmp) + (kernel-make-primitive-applicative + (fn (args) + (cond + ((< (length args) 2) + (error (str name ": expects at least 2 arguments"))) + (:else (knl-chain-step cmp (first args) (rest args)))))))) + ;; ── list / pair primitives ────────────────────────────────────── (define @@ -657,14 +696,18 @@ env "get-current-environment" kernel-get-current-env-operative) - (kernel-env-bind! env "+" (knl-bin-app "+" (fn (a b) (+ a b)))) - (kernel-env-bind! env "-" (knl-bin-app "-" (fn (a b) (- a b)))) - (kernel-env-bind! env "*" (knl-bin-app "*" (fn (a b) (* a b)))) - (kernel-env-bind! env "/" (knl-bin-app "/" (fn (a b) (/ a b)))) - (kernel-env-bind! env "<" (knl-bin-app "<" (fn (a b) (< a b)))) - (kernel-env-bind! env ">" (knl-bin-app ">" (fn (a b) (> a b)))) - (kernel-env-bind! env "<=?" (knl-bin-app "<=?" (fn (a b) (<= a b)))) - (kernel-env-bind! env ">=?" (knl-bin-app ">=?" (fn (a b) (>= a b)))) + (kernel-env-bind! env "+" + (knl-fold-app "+" (fn (a b) (+ a b)) 0 (fn (x) x))) + (kernel-env-bind! env "-" + (knl-fold-app "-" (fn (a b) (- a b)) 0 (fn (x) (- 0 x)))) + (kernel-env-bind! env "*" + (knl-fold-app "*" (fn (a b) (* a b)) 1 (fn (x) x))) + (kernel-env-bind! env "/" + (knl-fold-app "/" (fn (a b) (/ a b)) 1 (fn (x) (/ 1 x)))) + (kernel-env-bind! env "<" (knl-chain-cmp "<" (fn (a b) (< a b)))) + (kernel-env-bind! env ">" (knl-chain-cmp ">" (fn (a b) (> a b)))) + (kernel-env-bind! env "<=?" (knl-chain-cmp "<=?" (fn (a b) (<= a b)))) + (kernel-env-bind! env ">=?" (knl-chain-cmp ">=?" (fn (a b) (>= a b)))) (kernel-env-bind! env "=?" kernel-eq?-applicative) (kernel-env-bind! env "equal?" kernel-equal?-applicative) (kernel-env-bind! env "eq?" kernel-eq?-applicative) diff --git a/lib/kernel/tests/standard.sx b/lib/kernel/tests/standard.sx index ee70ea58..c637f02e 100644 --- a/lib/kernel/tests/standard.sx +++ b/lib/kernel/tests/standard.sx @@ -337,4 +337,30 @@ (ks-test "or: middle truthy" (ks-eval "($or? #f 42 nope)") 42) +;; ── variadic arithmetic ───────────────────────────────────────── +(ks-test "+: zero args = 0" (ks-eval "(+)") 0) +(ks-test "+: one arg = arg" (ks-eval "(+ 7)") 7) +(ks-test "+: two args" (ks-eval "(+ 3 4)") 7) +(ks-test "+: five args" (ks-eval "(+ 1 2 3 4 5)") 15) + +(ks-test "*: zero args = 1" (ks-eval "(*)") 1) +(ks-test "*: one arg" (ks-eval "(* 7)") 7) +(ks-test "*: four args" (ks-eval "(* 1 2 3 4)") 24) + +(ks-test "-: one arg negates" (ks-eval "(- 10)") -10) +(ks-test "-: two args" (ks-eval "(- 10 3)") 7) +(ks-test "-: four args fold" (ks-eval "(- 100 1 2 3)") 94) + +(ks-test "/: two args" (ks-eval "(/ 20 5)") 4) +(ks-test "/: three args fold" (ks-eval "(/ 100 2 5)") 10) + +;; ── variadic chained comparison ───────────────────────────────── +(ks-test "<: chained ascending" (ks-eval "(< 1 2 3 4 5)") true) +(ks-test "<: not strict" (ks-eval "(< 1 2 2 3)") false) +(ks-test "<: anti-monotonic" (ks-eval "(< 5 3)") false) +(ks-test ">: chained descending" (ks-eval "(> 5 4 3 2 1)") true) +(ks-test "<=? ascending equals" (ks-eval "(<=? 1 1 2 3 3)") true) +(ks-test "<=? violation" (ks-eval "(<=? 1 2 1)") false) +(ks-test ">=? descending equals" (ks-eval "(>=? 3 3 2 1)") true) + (define ks-tests-run! (fn () {:total (+ ks-test-pass ks-test-fail) :passed ks-test-pass :failed ks-test-fail :fails ks-test-fails})) diff --git a/plans/kernel-on-sx.md b/plans/kernel-on-sx.md index cffb4885..6643d0ab 100644 --- a/plans/kernel-on-sx.md +++ b/plans/kernel-on-sx.md @@ -160,6 +160,7 @@ The motivation is that SX's host `make-env` family is registered only in HTTP/si ## Progress log +- 2026-05-11 — Variadic `+ - * /` and chained `< > <=? >=?`. `(+ 1 2 3)` = 6, `(+)` = 0, `(+ 7)` = 7. `(- 10 1 2 3)` = 4 (left fold); single-arg `-` negates. `(* 1 2 3 4)` = 24, `(*)` = 1. Chained comparison: `(< 1 2 3)` ≡ `(< 1 2) ∧ (< 2 3)`. Implementation: `knl-fold-app` for n-ary fold with zero-arity identity and one-arity special-case; `knl-chain-cmp` for chained boolean. 19 new tests. chisel: nothing (mechanical extension of existing arithmetic primitives). 279 tests total. - 2026-05-11 — `$let*` sequential let. Each binding evaluated in scope where earlier bindings are visible, so `($let* ((x 1) (y (+ x 1))) y)` returns 2. Implemented by nesting envs one per binding — `knl-let*-step` recursively builds the env chain. `$let` and `$let*` now both accept multi-expression bodies (`knl-eval-body` re-used). 8 new tests in `tests/hygiene.sx`. chisel: nothing (a standard derived form). 260 tests total. - 2026-05-11 — `$and?` / `$or?` short-circuit booleans. Operatives (not applicatives) so untaken arguments are NOT evaluated. Identity values: `$and?` empty = true, `$or?` empty = false. Returns the last evaluated value (Kernel convention — not coerced to bool). 10 new tests including the short-circuit verification (`($and? #f nope)` returns false without evaluating `nope`). chisel: shapes-reflective. Sketched `lib/guest/reflective/short-circuit.sx` API; the protocol is identical across reflective Lisps because short-circuit FORCES operative semantics — an applicative variant would defeat the purpose. 252 tests total. - 2026-05-11 — `$cond` / `$when` / `$unless`. Standard Kernel control flow added: `$cond` walks clauses in order, evaluates first truthy test, runs that clause's body in sequence; `else` is the catch-all symbol; empty cond and no-match cond return nil. `$when` and `$unless` are simple conditional execution. All three preserve hygiene (clauses not taken are NOT evaluated). 12 new tests in `tests/standard.sx`. chisel: nothing. 242 tests total. (Third `nothing` in a row but allowable here — these are textbook Kernel idioms with no novel reflective angle.)