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

kernel: variadic +-*/, chained <>=? + 19 tests [nothing]
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 25s
Details

Browse Source 
knl-fold-app for n-ary fold with zero-arity identity and one-arity
special-case (- negates, / inverts). knl-chain-cmp for chained
boolean comparison. 279 tests total.
This commit is contained in:
giles
2026-05-11 21:13:13 +00:00
parent b80871ac4f
commit 1fb852ef64
3 changed files with 78 additions and 8 deletions
Download Patch File Download Diff File Expand all files Collapse all files

59
lib/kernel/runtime.sx
View File

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