giles
78dab5b28c
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 27s
Added kernel-make-primitive-applicative-with-env in eval.sx — IMPL receives (args dyn-env), needed by combinators that re-enter the evaluator. map/filter/reduce in runtime.sx use it to call user-supplied combiners on each element with the caller's dynamic env preserved. Sketched the env-blind vs env-aware applicative split as a new entry in the proposed combiner.sx reflective API. 289 tests total.
804 lines
28 KiB
Plaintext
804 lines
28 KiB
Plaintext
;; lib/kernel/runtime.sx — the operative–applicative substrate and the
|
||
;; standard Kernel environment.
|
||
;;
|
||
;; Phase 3 supplied four user-visible combiners ($vau, $lambda, wrap,
|
||
;; unwrap). Phase 4 fills out the rest of the R-1RK core: $if, $define!,
|
||
;; $sequence, eval, make-environment, get-current-environment, plus
|
||
;; arithmetic, equality, list/pair, and boolean primitives — enough to
|
||
;; write factorial.
|
||
;;
|
||
;; The standard env is built by EXTENDING the base env, not replacing
|
||
;; it. So `kernel-standard-env` includes everything from `kernel-base-env`.
|
||
;;
|
||
;; Public API
|
||
;; (kernel-base-env) — Phase 3 combiners
|
||
;; (kernel-standard-env) — Phase 4 standard environment
|
||
|
||
(define
|
||
knl-eparam-sentinel
|
||
(fn
|
||
(sym)
|
||
(cond
|
||
((= sym "_") :knl-ignore)
|
||
((= sym "#ignore") :knl-ignore)
|
||
(:else sym))))
|
||
|
||
(define
|
||
knl-formals-ok?
|
||
(fn
|
||
(formals)
|
||
(cond
|
||
((not (list? formals)) false)
|
||
((= (length formals) 0) true)
|
||
((string? (first formals)) (knl-formals-ok? (rest formals)))
|
||
(:else false))))
|
||
|
||
;; ── $vau ─────────────────────────────────────────────────────────
|
||
|
||
(define
|
||
kernel-vau-impl
|
||
(fn
|
||
(args dyn-env)
|
||
(cond
|
||
((< (length args) 3)
|
||
(error "$vau: expects (formals env-param body...)"))
|
||
(:else
|
||
(let
|
||
((formals (first args))
|
||
(eparam-raw (nth args 1))
|
||
(body-forms (rest (rest args))))
|
||
(cond
|
||
((not (knl-formals-ok? formals))
|
||
(error "$vau: formals must be a list of symbols"))
|
||
((not (string? eparam-raw))
|
||
(error "$vau: env-param must be a symbol"))
|
||
(:else
|
||
(kernel-make-user-operative
|
||
formals
|
||
(knl-eparam-sentinel eparam-raw)
|
||
body-forms
|
||
dyn-env))))))))
|
||
|
||
(define
|
||
kernel-vau-operative
|
||
(kernel-make-primitive-operative kernel-vau-impl))
|
||
|
||
;; ── $lambda ──────────────────────────────────────────────────────
|
||
|
||
(define
|
||
kernel-lambda-impl
|
||
(fn
|
||
(args dyn-env)
|
||
(cond
|
||
((< (length args) 2)
|
||
(error "$lambda: expects (formals body...)"))
|
||
(:else
|
||
(let
|
||
((formals (first args)) (body-forms (rest args)))
|
||
(cond
|
||
((not (knl-formals-ok? formals))
|
||
(error "$lambda: formals must be a list of symbols"))
|
||
(:else
|
||
(kernel-wrap
|
||
(kernel-make-user-operative
|
||
formals
|
||
:knl-ignore
|
||
body-forms
|
||
dyn-env)))))))))
|
||
|
||
(define
|
||
kernel-lambda-operative
|
||
(kernel-make-primitive-operative kernel-lambda-impl))
|
||
|
||
;; ── wrap / unwrap / predicates ───────────────────────────────────
|
||
|
||
(define
|
||
kernel-wrap-applicative
|
||
(kernel-make-primitive-applicative
|
||
(fn
|
||
(args)
|
||
(cond
|
||
((not (= (length args) 1))
|
||
(error "wrap: expects exactly 1 argument"))
|
||
(:else (kernel-wrap (first args)))))))
|
||
|
||
(define
|
||
kernel-unwrap-applicative
|
||
(kernel-make-primitive-applicative
|
||
(fn
|
||
(args)
|
||
(cond
|
||
((not (= (length args) 1))
|
||
(error "unwrap: expects exactly 1 argument"))
|
||
(:else (kernel-unwrap (first args)))))))
|
||
|
||
(define
|
||
kernel-operative?-applicative
|
||
(kernel-make-primitive-applicative
|
||
(fn (args) (kernel-operative? (first args)))))
|
||
|
||
(define
|
||
kernel-applicative?-applicative
|
||
(kernel-make-primitive-applicative
|
||
(fn (args) (kernel-applicative? (first args)))))
|
||
|
||
(define
|
||
kernel-base-env
|
||
(fn
|
||
()
|
||
(let
|
||
((env (kernel-make-env)))
|
||
(kernel-env-bind! env "$vau" kernel-vau-operative)
|
||
(kernel-env-bind! env "$lambda" kernel-lambda-operative)
|
||
(kernel-env-bind! env "wrap" kernel-wrap-applicative)
|
||
(kernel-env-bind! env "unwrap" kernel-unwrap-applicative)
|
||
(kernel-env-bind! env "operative?" kernel-operative?-applicative)
|
||
(kernel-env-bind! env "applicative?" kernel-applicative?-applicative)
|
||
env)))
|
||
|
||
;; ── $if / $define! / $sequence ───────────────────────────────────
|
||
|
||
(define
|
||
kernel-if-operative
|
||
(kernel-make-primitive-operative
|
||
(fn
|
||
(args dyn-env)
|
||
(cond
|
||
((not (= (length args) 3))
|
||
(error "$if: expects (condition then-expr else-expr)"))
|
||
(:else
|
||
(let
|
||
((c (kernel-eval (first args) dyn-env)))
|
||
(if
|
||
c
|
||
(kernel-eval (nth args 1) dyn-env)
|
||
(kernel-eval (nth args 2) dyn-env))))))))
|
||
|
||
(define
|
||
kernel-define!-operative
|
||
(kernel-make-primitive-operative
|
||
(fn
|
||
(args dyn-env)
|
||
(cond
|
||
((not (= (length args) 2))
|
||
(error "$define!: expects (name expr)"))
|
||
((not (string? (first args)))
|
||
(error "$define!: name must be a symbol"))
|
||
(:else
|
||
(let
|
||
((v (kernel-eval (nth args 1) dyn-env)))
|
||
(kernel-env-bind! dyn-env (first args) v)
|
||
v))))))
|
||
|
||
(define
|
||
kernel-sequence-operative
|
||
(kernel-make-primitive-operative
|
||
(fn
|
||
(args dyn-env)
|
||
(cond
|
||
((or (nil? args) (= (length args) 0)) nil)
|
||
((= (length args) 1) (kernel-eval (first args) dyn-env))
|
||
(:else
|
||
(begin
|
||
(kernel-eval (first args) dyn-env)
|
||
((get kernel-sequence-operative :impl) (rest args) dyn-env)))))))
|
||
|
||
;; ── eval / make-environment / get-current-environment ───────────
|
||
|
||
(define
|
||
kernel-quote-operative
|
||
(kernel-make-primitive-operative
|
||
(fn
|
||
(args dyn-env)
|
||
(cond
|
||
((not (= (length args) 1)) (error "$quote: expects 1 argument"))
|
||
(:else (first args))))))
|
||
|
||
;; Quasiquote: walks the template, evaluating `$unquote` forms in the
|
||
;; dynamic env and splicing `$unquote-splicing` list results.
|
||
(define knl-quasi-walk
|
||
(fn (form dyn-env)
|
||
(cond
|
||
((not (list? form)) form)
|
||
((= (length form) 0) form)
|
||
((and (string? (first form)) (= (first form) "$unquote"))
|
||
(cond
|
||
((not (= (length form) 2))
|
||
(error "$unquote: expects exactly 1 argument"))
|
||
(:else (kernel-eval (nth form 1) dyn-env))))
|
||
(:else (knl-quasi-walk-list form dyn-env)))))
|
||
|
||
(define knl-quasi-walk-list
|
||
(fn (forms dyn-env)
|
||
(cond
|
||
((or (nil? forms) (= (length forms) 0)) (list))
|
||
(:else
|
||
(let ((head (first forms)))
|
||
(cond
|
||
((and (list? head)
|
||
(= (length head) 2)
|
||
(string? (first head))
|
||
(= (first head) "$unquote-splicing"))
|
||
(let ((spliced (kernel-eval (nth head 1) dyn-env)))
|
||
(cond
|
||
((not (list? spliced))
|
||
(error "$unquote-splicing: value must be a list"))
|
||
(:else
|
||
(knl-list-concat
|
||
spliced
|
||
(knl-quasi-walk-list (rest forms) dyn-env))))))
|
||
(:else
|
||
(cons (knl-quasi-walk head dyn-env)
|
||
(knl-quasi-walk-list (rest forms) dyn-env)))))))))
|
||
|
||
(define knl-list-concat
|
||
(fn (xs ys)
|
||
(cond
|
||
((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))))))))
|
||
|
||
;; $and? — short-circuit AND. Operative (not applicative) so untaken
|
||
;; clauses are NOT evaluated. Empty $and? returns true (the identity).
|
||
(define knl-and?-impl
|
||
(fn (args dyn-env)
|
||
(cond
|
||
((or (nil? args) (= (length args) 0)) true)
|
||
((= (length args) 1) (kernel-eval (first args) dyn-env))
|
||
(:else
|
||
(let ((v (kernel-eval (first args) dyn-env)))
|
||
(cond
|
||
(v (knl-and?-impl (rest args) dyn-env))
|
||
(:else v)))))))
|
||
|
||
(define kernel-and?-operative
|
||
(kernel-make-primitive-operative knl-and?-impl))
|
||
|
||
;; $or? — short-circuit OR. Operative; untaken clauses NOT evaluated.
|
||
;; Empty $or? returns false (the identity).
|
||
(define knl-or?-impl
|
||
(fn (args dyn-env)
|
||
(cond
|
||
((or (nil? args) (= (length args) 0)) false)
|
||
((= (length args) 1) (kernel-eval (first args) dyn-env))
|
||
(:else
|
||
(let ((v (kernel-eval (first args) dyn-env)))
|
||
(cond
|
||
(v v)
|
||
(:else (knl-or?-impl (rest args) dyn-env))))))))
|
||
|
||
(define kernel-or?-operative
|
||
(kernel-make-primitive-operative knl-or?-impl))
|
||
|
||
;; $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)
|
||
(cond
|
||
((not (= (length args) 1))
|
||
(error "$quasiquote: expects exactly 1 argument"))
|
||
(:else (knl-quasi-walk (first args) dyn-env))))))
|
||
|
||
(define
|
||
kernel-eval-applicative
|
||
(kernel-make-primitive-applicative
|
||
(fn
|
||
(args)
|
||
(cond
|
||
((not (= (length args) 2))
|
||
(error "eval: expects (expr env)"))
|
||
((not (kernel-env? (nth args 1)))
|
||
(error "eval: second arg must be a kernel env"))
|
||
(:else (kernel-eval (first args) (nth args 1)))))))
|
||
|
||
(define
|
||
kernel-make-environment-applicative
|
||
(kernel-make-primitive-applicative
|
||
(fn
|
||
(args)
|
||
(cond
|
||
((= (length args) 0) (kernel-make-env))
|
||
((= (length args) 1)
|
||
(cond
|
||
((not (kernel-env? (first args)))
|
||
(error "make-environment: parent must be a kernel env"))
|
||
(:else (kernel-extend-env (first args)))))
|
||
(:else (error "make-environment: 0 or 1 argument"))))))
|
||
|
||
;; ── arithmetic and comparison (binary; trivial to extend later) ─
|
||
|
||
(define
|
||
kernel-get-current-env-operative
|
||
(kernel-make-primitive-operative
|
||
(fn
|
||
(args dyn-env)
|
||
(cond
|
||
((not (= (length args) 0))
|
||
(error "get-current-environment: expects 0 arguments"))
|
||
(:else dyn-env)))))
|
||
|
||
(define
|
||
knl-bin-app
|
||
(fn
|
||
(name f)
|
||
(kernel-make-primitive-applicative
|
||
(fn
|
||
(args)
|
||
(cond
|
||
((not (= (length args) 2))
|
||
(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
|
||
knl-unary-app
|
||
(fn
|
||
(name f)
|
||
(kernel-make-primitive-applicative
|
||
(fn
|
||
(args)
|
||
(cond
|
||
((not (= (length args) 1))
|
||
(error (str name ": expects 1 argument")))
|
||
(:else (f (first args))))))))
|
||
|
||
(define kernel-cons-applicative (knl-bin-app "cons" (fn (a b) (cons a b))))
|
||
|
||
(define
|
||
kernel-car-applicative
|
||
(knl-unary-app
|
||
"car"
|
||
(fn
|
||
(xs)
|
||
(cond
|
||
((or (nil? xs) (and (list? xs) (= (length xs) 0)))
|
||
(error "car: empty list"))
|
||
(:else (first xs))))))
|
||
|
||
(define
|
||
kernel-cdr-applicative
|
||
(knl-unary-app
|
||
"cdr"
|
||
(fn
|
||
(xs)
|
||
(cond
|
||
((or (nil? xs) (and (list? xs) (= (length xs) 0)))
|
||
(error "cdr: empty list"))
|
||
(:else (rest xs))))))
|
||
|
||
(define
|
||
kernel-list-applicative
|
||
(kernel-make-primitive-applicative (fn (args) args)))
|
||
|
||
(define
|
||
kernel-length-applicative
|
||
(knl-unary-app "length" (fn (xs) (length xs))))
|
||
|
||
(define
|
||
kernel-null?-applicative
|
||
(knl-unary-app
|
||
"null?"
|
||
(fn (v) (or (nil? v) (and (list? v) (= (length v) 0))))))
|
||
|
||
;; ── boolean / equality ──────────────────────────────────────────
|
||
|
||
(define
|
||
kernel-pair?-applicative
|
||
(knl-unary-app
|
||
"pair?"
|
||
(fn (v) (and (list? v) (> (length v) 0)))))
|
||
|
||
(define kernel-not-applicative (knl-unary-app "not" (fn (v) (not v))))
|
||
|
||
(define kernel-eq?-applicative (knl-bin-app "eq?" (fn (a b) (= a b))))
|
||
|
||
;; ── the standard environment ────────────────────────────────────
|
||
|
||
(define
|
||
kernel-equal?-applicative
|
||
(knl-bin-app "equal?" (fn (a b) (= a b))))
|
||
|
||
;; ── List combinators: map / filter / reduce ─────────────────────
|
||
;; These re-enter the evaluator on each element, so they use the
|
||
;; with-env applicative constructor.
|
||
|
||
(define knl-map-step
|
||
(fn (fn-val xs dyn-env)
|
||
(cond
|
||
((or (nil? xs) (= (length xs) 0)) (list))
|
||
(:else
|
||
(cons (kernel-combine fn-val (list (first xs)) dyn-env)
|
||
(knl-map-step fn-val (rest xs) dyn-env))))))
|
||
|
||
(define kernel-map-applicative
|
||
(kernel-make-primitive-applicative-with-env
|
||
(fn (args dyn-env)
|
||
(cond
|
||
((not (= (length args) 2))
|
||
(error "map: expects (fn list)"))
|
||
((not (kernel-combiner? (first args)))
|
||
(error "map: first arg must be a combiner"))
|
||
((not (list? (nth args 1)))
|
||
(error "map: second arg must be a list"))
|
||
(:else (knl-map-step (first args) (nth args 1) dyn-env))))))
|
||
|
||
(define knl-filter-step
|
||
(fn (pred xs dyn-env)
|
||
(cond
|
||
((or (nil? xs) (= (length xs) 0)) (list))
|
||
(:else
|
||
(let ((keep? (kernel-combine pred (list (first xs)) dyn-env)))
|
||
(cond
|
||
(keep?
|
||
(cons (first xs)
|
||
(knl-filter-step pred (rest xs) dyn-env)))
|
||
(:else (knl-filter-step pred (rest xs) dyn-env))))))))
|
||
|
||
(define kernel-filter-applicative
|
||
(kernel-make-primitive-applicative-with-env
|
||
(fn (args dyn-env)
|
||
(cond
|
||
((not (= (length args) 2))
|
||
(error "filter: expects (pred list)"))
|
||
((not (kernel-combiner? (first args)))
|
||
(error "filter: first arg must be a combiner"))
|
||
((not (list? (nth args 1)))
|
||
(error "filter: second arg must be a list"))
|
||
(:else (knl-filter-step (first args) (nth args 1) dyn-env))))))
|
||
|
||
(define knl-reduce-step
|
||
(fn (fn-val xs acc dyn-env)
|
||
(cond
|
||
((or (nil? xs) (= (length xs) 0)) acc)
|
||
(:else
|
||
(knl-reduce-step
|
||
fn-val
|
||
(rest xs)
|
||
(kernel-combine fn-val (list acc (first xs)) dyn-env)
|
||
dyn-env)))))
|
||
|
||
(define kernel-reduce-applicative
|
||
(kernel-make-primitive-applicative-with-env
|
||
(fn (args dyn-env)
|
||
(cond
|
||
((not (= (length args) 3))
|
||
(error "reduce: expects (fn init list)"))
|
||
((not (kernel-combiner? (first args)))
|
||
(error "reduce: first arg must be a combiner"))
|
||
((not (list? (nth args 2)))
|
||
(error "reduce: third arg must be a list"))
|
||
(:else
|
||
(knl-reduce-step (first args) (nth args 2)
|
||
(nth args 1) dyn-env))))))
|
||
|
||
;; ── Encapsulations: Kernel's opaque-type idiom ──────────────────
|
||
;;
|
||
;; (make-encapsulation-type) → (encapsulator predicate decapsulator)
|
||
;;
|
||
;; Each call returns three applicatives over a fresh family identity.
|
||
;; - (encapsulator V) → an opaque wrapper around V.
|
||
;; - (predicate V) → true iff V was wrapped by THIS family.
|
||
;; - (decapsulator W) → the inner value; errors on wrong family.
|
||
;;
|
||
;; Family identity is a fresh empty dict; SX compares dicts by reference,
|
||
;; so two `(make-encapsulation-type)` calls return distinct families.
|
||
;;
|
||
;; Pattern usage (Phase 5 lacks destructuring, so accessors are explicit):
|
||
;; ($define! triple (make-encapsulation-type))
|
||
;; ($define! wrap-promise (car triple))
|
||
;; ($define! promise? (car (cdr triple)))
|
||
;; ($define! unwrap-promise (car (cdr (cdr triple))))
|
||
|
||
(define kernel-make-encap-type-impl
|
||
(fn (args)
|
||
(cond
|
||
((not (= (length args) 0))
|
||
(error "make-encapsulation-type: expects 0 arguments"))
|
||
(:else
|
||
(let ((family {}))
|
||
(let ((encap
|
||
(kernel-make-primitive-applicative
|
||
(fn (vargs)
|
||
(cond
|
||
((not (= (length vargs) 1))
|
||
(error "encapsulator: expects 1 argument"))
|
||
(:else
|
||
{:knl-tag :encap
|
||
:family family
|
||
:value (first vargs)})))))
|
||
(pred
|
||
(kernel-make-primitive-applicative
|
||
(fn (vargs)
|
||
(cond
|
||
((not (= (length vargs) 1))
|
||
(error "predicate: expects 1 argument"))
|
||
(:else
|
||
(let ((v (first vargs)))
|
||
(and (dict? v)
|
||
(= (get v :knl-tag) :encap)
|
||
(= (get v :family) family))))))))
|
||
(decap
|
||
(kernel-make-primitive-applicative
|
||
(fn (vargs)
|
||
(cond
|
||
((not (= (length vargs) 1))
|
||
(error "decapsulator: expects 1 argument"))
|
||
(:else
|
||
(let ((v (first vargs)))
|
||
(cond
|
||
((not (and (dict? v)
|
||
(= (get v :knl-tag) :encap)))
|
||
(error "decapsulator: not an encapsulation"))
|
||
((not (= (get v :family) family))
|
||
(error "decapsulator: wrong family"))
|
||
(:else (get v :value))))))))))
|
||
(list encap pred decap)))))))
|
||
|
||
(define kernel-make-encap-type-applicative
|
||
(kernel-make-primitive-applicative kernel-make-encap-type-impl))
|
||
|
||
;; ── Hygiene: $let, $define-in!, make-environment ────────────────
|
||
;;
|
||
;; Kernel-on-SX is hygienic *by default* because user-defined operatives
|
||
;; (Phase 3) bind their formals + any $define! in a CHILD env extending
|
||
;; the operative's static-env, never the dyn-env. The caller's env is
|
||
;; only mutated when code explicitly says so (e.g. `(eval expr env-arg)`).
|
||
;;
|
||
;; Phase 6 adds two helpers that make the property easy to lean on:
|
||
;;
|
||
;; ($let ((NAME EXPR) ...) BODY)
|
||
;; Evaluates each EXPR in the calling env, binds NAME in a fresh
|
||
;; child env, evaluates BODY in that child env. NAMES don't leak.
|
||
;;
|
||
;; ($define-in! ENV NAME EXPR)
|
||
;; Binds NAME=value-of-EXPR in the *specified* env, not the dyn-env.
|
||
;; Useful for operatives that need to mutate a sandbox env without
|
||
;; touching their caller's env.
|
||
;;
|
||
;; Shutt's full scope-set / frame-stamp hygiene (lifted symbols carrying
|
||
;; provenance markers so introduced bindings can shadow without
|
||
;; capturing) is research-grade and not implemented here. Notes for
|
||
;; `lib/guest/reflective/hygiene.sx` candidate API below the std env.
|
||
|
||
(define knl-bind-let-vals!
|
||
(fn (local bindings dyn-env)
|
||
(cond
|
||
((or (nil? bindings) (= (length bindings) 0)) nil)
|
||
(:else
|
||
(let ((b (first bindings)))
|
||
(cond
|
||
((not (and (list? b) (= (length b) 2)))
|
||
(error "$let: each binding must be (name expr)"))
|
||
((not (string? (first b)))
|
||
(error "$let: binding name must be a symbol"))
|
||
(:else
|
||
(begin
|
||
(kernel-env-bind! local
|
||
(first b)
|
||
(kernel-eval (nth b 1) dyn-env))
|
||
(knl-bind-let-vals! local (rest bindings) dyn-env)))))))))
|
||
|
||
(define kernel-let-operative
|
||
(kernel-make-primitive-operative
|
||
(fn (args dyn-env)
|
||
(cond
|
||
((< (length args) 2)
|
||
(error "$let: expects (bindings body...)"))
|
||
((not (list? (first args)))
|
||
(error "$let: bindings must be a list"))
|
||
(:else
|
||
(let ((local (kernel-extend-env dyn-env)))
|
||
(knl-bind-let-vals! local (first args) dyn-env)
|
||
(knl-eval-body (rest args) local)))))))
|
||
|
||
;; $let* — sequential let. Each binding sees prior names in scope.
|
||
;; Implemented by nesting envs one per binding; the body runs in the
|
||
;; innermost env, so later bindings shadow earlier ones if names repeat.
|
||
(define knl-let*-step
|
||
(fn (bindings env body-forms)
|
||
(cond
|
||
((or (nil? bindings) (= (length bindings) 0))
|
||
(knl-eval-body body-forms env))
|
||
(:else
|
||
(let ((b (first bindings)))
|
||
(cond
|
||
((not (and (list? b) (= (length b) 2)))
|
||
(error "$let*: each binding must be (name expr)"))
|
||
((not (string? (first b)))
|
||
(error "$let*: binding name must be a symbol"))
|
||
(:else
|
||
(let ((child (kernel-extend-env env)))
|
||
(kernel-env-bind! child
|
||
(first b)
|
||
(kernel-eval (nth b 1) env))
|
||
(knl-let*-step (rest bindings) child body-forms)))))))))
|
||
|
||
(define kernel-let*-operative
|
||
(kernel-make-primitive-operative
|
||
(fn (args dyn-env)
|
||
(cond
|
||
((< (length args) 2)
|
||
(error "$let*: expects (bindings body...)"))
|
||
((not (list? (first args)))
|
||
(error "$let*: bindings must be a list"))
|
||
(:else
|
||
(knl-let*-step (first args) dyn-env (rest args)))))))
|
||
|
||
(define kernel-define-in!-operative
|
||
(kernel-make-primitive-operative
|
||
(fn (args dyn-env)
|
||
(cond
|
||
((not (= (length args) 3))
|
||
(error "$define-in!: expects (env-expr name expr)"))
|
||
((not (string? (nth args 1)))
|
||
(error "$define-in!: name must be a symbol"))
|
||
(:else
|
||
(let ((target (kernel-eval (first args) dyn-env)))
|
||
(cond
|
||
((not (kernel-env? target))
|
||
(error "$define-in!: first arg must evaluate to an env"))
|
||
(:else
|
||
(let ((v (kernel-eval (nth args 2) dyn-env)))
|
||
(kernel-env-bind! target (nth args 1) v)
|
||
v)))))))))
|
||
|
||
(define
|
||
kernel-standard-env
|
||
(fn
|
||
()
|
||
(let
|
||
((env (kernel-base-env)))
|
||
(kernel-env-bind! env "$if" kernel-if-operative)
|
||
(kernel-env-bind! env "$define!" kernel-define!-operative)
|
||
(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 "$and?" kernel-and?-operative)
|
||
(kernel-env-bind! env "$or?" kernel-or?-operative)
|
||
(kernel-env-bind! env "eval" kernel-eval-applicative)
|
||
(kernel-env-bind!
|
||
env
|
||
"make-environment"
|
||
kernel-make-environment-applicative)
|
||
(kernel-env-bind!
|
||
env
|
||
"get-current-environment"
|
||
kernel-get-current-env-operative)
|
||
(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)
|
||
(kernel-env-bind! env "cons" kernel-cons-applicative)
|
||
(kernel-env-bind! env "car" kernel-car-applicative)
|
||
(kernel-env-bind! env "cdr" kernel-cdr-applicative)
|
||
(kernel-env-bind! env "list" kernel-list-applicative)
|
||
(kernel-env-bind! env "length" kernel-length-applicative)
|
||
(kernel-env-bind! env "null?" kernel-null?-applicative)
|
||
(kernel-env-bind! env "pair?" kernel-pair?-applicative)
|
||
(kernel-env-bind! env "map" kernel-map-applicative)
|
||
(kernel-env-bind! env "filter" kernel-filter-applicative)
|
||
(kernel-env-bind! env "reduce" kernel-reduce-applicative)
|
||
(kernel-env-bind! env "not" kernel-not-applicative)
|
||
(kernel-env-bind! env "make-encapsulation-type"
|
||
kernel-make-encap-type-applicative)
|
||
(kernel-env-bind! env "$let" kernel-let-operative)
|
||
(kernel-env-bind! env "$let*" kernel-let*-operative)
|
||
(kernel-env-bind! env "$define-in!" kernel-define-in!-operative)
|
||
env)))
|