Compare commits
3 Commits
architectu
...
loops/kern
| Author | SHA1 | Date | |
|---|---|---|---|
| 0da39de68a | |||
| 7e57e0b215 | |||
| cbba642d7f |
@@ -1279,7 +1279,7 @@ let run_foundation_tests () =
|
||||
assert_true "sx_truthy \"\"" (Bool (sx_truthy (String "")));
|
||||
assert_eq "not truthy nil" (Bool false) (Bool (sx_truthy Nil));
|
||||
assert_eq "not truthy false" (Bool false) (Bool (sx_truthy (Bool false)));
|
||||
let l = { l_params = ["x"]; l_body = Symbol "x"; l_closure = Sx_types.make_env (); l_name = None; l_compiled = None; l_call_count = 0 } in
|
||||
let l = { l_params = ["x"]; l_body = Symbol "x"; l_closure = Sx_types.make_env (); l_name = None; l_compiled = None } in
|
||||
assert_true "is_lambda" (Bool (Sx_types.is_lambda (Lambda l)));
|
||||
ignore (Sx_types.set_lambda_name (Lambda l) "my-fn");
|
||||
assert_eq "lambda name mutated" (String "my-fn") (lambda_name (Lambda l))
|
||||
|
||||
@@ -4109,25 +4109,4 @@ let () =
|
||||
| k :: v :: rest -> ignore (env_bind child (value_to_string k) v); add_bindings rest
|
||||
| [_] -> raise (Eval_error "env-extend: odd number of key-val pairs") in
|
||||
add_bindings pairs;
|
||||
Env child);
|
||||
|
||||
(* JIT cache control & observability — backed by refs in sx_types.ml to
|
||||
avoid creating a sx_primitives → sx_vm dependency cycle. sx_vm reads
|
||||
these refs to decide when to JIT. *)
|
||||
register "jit-stats" (fun _args ->
|
||||
let d = Hashtbl.create 8 in
|
||||
Hashtbl.replace d "threshold" (Number (float_of_int !Sx_types.jit_threshold));
|
||||
Hashtbl.replace d "compiled" (Number (float_of_int !Sx_types.jit_compiled_count));
|
||||
Hashtbl.replace d "compile-failed" (Number (float_of_int !Sx_types.jit_skipped_count));
|
||||
Hashtbl.replace d "below-threshold" (Number (float_of_int !Sx_types.jit_threshold_skipped_count));
|
||||
Dict d);
|
||||
register "jit-set-threshold!" (fun args ->
|
||||
match args with
|
||||
| [Number n] -> Sx_types.jit_threshold := int_of_float n; Nil
|
||||
| [Integer n] -> Sx_types.jit_threshold := n; Nil
|
||||
| _ -> raise (Eval_error "jit-set-threshold!: (n) where n is integer"));
|
||||
register "jit-reset-counters!" (fun _args ->
|
||||
Sx_types.jit_compiled_count := 0;
|
||||
Sx_types.jit_skipped_count := 0;
|
||||
Sx_types.jit_threshold_skipped_count := 0;
|
||||
Nil)
|
||||
Env child)
|
||||
|
||||
@@ -138,7 +138,6 @@ and lambda = {
|
||||
l_closure : env;
|
||||
mutable l_name : string option;
|
||||
mutable l_compiled : vm_closure option; (** Lazy JIT cache *)
|
||||
mutable l_call_count : int; (** Tiered-compilation counter — JIT after threshold calls *)
|
||||
}
|
||||
|
||||
and component = {
|
||||
@@ -450,20 +449,7 @@ let make_lambda params body closure =
|
||||
| List items -> List.map value_to_string items
|
||||
| _ -> value_to_string_list params
|
||||
in
|
||||
Lambda { l_params = ps; l_body = body; l_closure = unwrap_env_val closure; l_name = None; l_compiled = None; l_call_count = 0 }
|
||||
|
||||
(** {1 JIT cache control}
|
||||
|
||||
Tiered compilation: only JIT a lambda after it's been called [jit_threshold]
|
||||
times. This filters out one-shot lambdas (test harness, dynamic eval, REPLs)
|
||||
so they never enter the JIT cache. Counters are exposed to SX as [(jit-stats)].
|
||||
|
||||
These live here (in sx_types) rather than sx_vm so [sx_primitives] can read
|
||||
them without creating a sx_primitives → sx_vm dependency cycle. *)
|
||||
let jit_threshold = ref 4
|
||||
let jit_compiled_count = ref 0
|
||||
let jit_skipped_count = ref 0
|
||||
let jit_threshold_skipped_count = ref 0
|
||||
Lambda { l_params = ps; l_body = body; l_closure = unwrap_env_val closure; l_name = None; l_compiled = None }
|
||||
|
||||
let make_component name params has_children body closure affinity =
|
||||
let n = value_to_string name in
|
||||
|
||||
@@ -57,9 +57,6 @@ let () = Sx_types._convert_vm_suspension := (fun exn ->
|
||||
let jit_compile_ref : (lambda -> (string, value) Hashtbl.t -> vm_closure option) ref =
|
||||
ref (fun _ _ -> None)
|
||||
|
||||
(* JIT threshold and counters live in Sx_types so primitives can read them
|
||||
without creating a sx_primitives → sx_vm dependency cycle. *)
|
||||
|
||||
(** Sentinel closure indicating JIT compilation was attempted and failed.
|
||||
Prevents retrying compilation on every call. *)
|
||||
let jit_failed_sentinel = {
|
||||
@@ -367,21 +364,13 @@ and vm_call vm f args =
|
||||
| None ->
|
||||
if l.l_name <> None
|
||||
then begin
|
||||
l.l_call_count <- l.l_call_count + 1;
|
||||
if l.l_call_count >= !Sx_types.jit_threshold then begin
|
||||
l.l_compiled <- Some jit_failed_sentinel;
|
||||
match !jit_compile_ref l vm.globals with
|
||||
| Some cl ->
|
||||
incr Sx_types.jit_compiled_count;
|
||||
l.l_compiled <- Some cl;
|
||||
push_closure_frame vm cl args
|
||||
| None ->
|
||||
incr Sx_types.jit_skipped_count;
|
||||
push vm (cek_call_or_suspend vm f (List args))
|
||||
end else begin
|
||||
incr Sx_types.jit_threshold_skipped_count;
|
||||
l.l_compiled <- Some jit_failed_sentinel;
|
||||
match !jit_compile_ref l vm.globals with
|
||||
| Some cl ->
|
||||
l.l_compiled <- Some cl;
|
||||
push_closure_frame vm cl args
|
||||
| None ->
|
||||
push vm (cek_call_or_suspend vm f (List args))
|
||||
end
|
||||
end
|
||||
else
|
||||
push vm (cek_call_or_suspend vm f (List args)))
|
||||
|
||||
216
lib/kernel/eval.sx
Normal file
216
lib/kernel/eval.sx
Normal file
@@ -0,0 +1,216 @@
|
||||
;; lib/kernel/eval.sx — Kernel evaluator.
|
||||
;;
|
||||
;; The evaluator is `lookup-and-combine`: there are no hardcoded special
|
||||
;; forms. Even $if / $define! / $lambda are ordinary operatives bound in
|
||||
;; the standard environment (Phase 4). This file builds the dispatch
|
||||
;; machinery and the operative/applicative tagged-value protocol.
|
||||
;;
|
||||
;; Tagged values
|
||||
;; -------------
|
||||
;; {:knl-tag :env :bindings DICT :parent PARENT-OR-NIL}
|
||||
;; A first-class Kernel environment. Bindings is a mutable SX dict
|
||||
;; keyed by symbol name; parent walks up the lookup chain.
|
||||
;;
|
||||
;; {:knl-tag :operative :impl FN}
|
||||
;; Primitive operative. FN receives (args dyn-env) — args are the
|
||||
;; UN-evaluated argument expressions, dyn-env is the calling env.
|
||||
;;
|
||||
;; {:knl-tag :operative :params P :env-param EP :body B :static-env SE}
|
||||
;; User-defined operative (built by $vau). Same tag; dispatch in
|
||||
;; kernel-call-operative forks on which keys are present.
|
||||
;;
|
||||
;; {:knl-tag :applicative :underlying OP}
|
||||
;; An applicative wraps an operative. Calls evaluate args first,
|
||||
;; then forward to the underlying operative.
|
||||
;;
|
||||
;; The env-param of a user operative may be the sentinel :knl-ignore,
|
||||
;; in which case the dynamic env is not bound.
|
||||
;;
|
||||
;; Public API
|
||||
;; (kernel-eval EXPR ENV) — primary entry
|
||||
;; (kernel-combine COMBINER ARGS DYN-ENV)
|
||||
;; (kernel-call-operative OP ARGS DYN-ENV)
|
||||
;; (kernel-bind-params! ENV PARAMS ARGS)
|
||||
;; (kernel-make-env) / (kernel-extend-env P)
|
||||
;; (kernel-env-bind! E N V) / (kernel-env-lookup E N)
|
||||
;; (kernel-env-has? E N) / (kernel-env? V)
|
||||
;; (kernel-make-primitive-operative IMPL)
|
||||
;; (kernel-make-primitive-applicative IMPL)
|
||||
;; (kernel-make-user-operative PARAMS EPARAM BODY STATIC-ENV)
|
||||
;; (kernel-wrap OP) / (kernel-unwrap APP)
|
||||
;; (kernel-operative? V) / (kernel-applicative? V) / (kernel-combiner? V)
|
||||
;;
|
||||
;; Consumes: lib/kernel/parser.sx (kernel-string?, kernel-string-value)
|
||||
|
||||
;; ── Environments — first-class, pure-SX (binding dict + parent) ──
|
||||
|
||||
(define kernel-env? (fn (v) (and (dict? v) (= (get v :knl-tag) :env))))
|
||||
|
||||
(define kernel-make-env (fn () {:parent nil :knl-tag :env :bindings {}}))
|
||||
|
||||
(define kernel-extend-env (fn (parent) {:parent parent :knl-tag :env :bindings {}}))
|
||||
|
||||
(define
|
||||
kernel-env-bind!
|
||||
(fn (env name val) (dict-set! (get env :bindings) name val) val))
|
||||
|
||||
(define
|
||||
kernel-env-has?
|
||||
(fn
|
||||
(env name)
|
||||
(cond
|
||||
((nil? env) false)
|
||||
((not (kernel-env? env)) false)
|
||||
((dict-has? (get env :bindings) name) true)
|
||||
(:else (kernel-env-has? (get env :parent) name)))))
|
||||
|
||||
(define
|
||||
kernel-env-lookup
|
||||
(fn
|
||||
(env name)
|
||||
(cond
|
||||
((nil? env) (error (str "kernel-eval: unbound symbol: " name)))
|
||||
((not (kernel-env? env))
|
||||
(error (str "kernel-eval: corrupt env: " env)))
|
||||
((dict-has? (get env :bindings) name) (get (get env :bindings) name))
|
||||
(:else (kernel-env-lookup (get env :parent) name)))))
|
||||
|
||||
;; ── Tagged-value constructors and predicates ─────────────────────
|
||||
|
||||
(define kernel-make-primitive-operative (fn (impl) {:impl impl :knl-tag :operative}))
|
||||
|
||||
(define
|
||||
kernel-make-user-operative
|
||||
(fn (params eparam body static-env) {:knl-tag :operative :static-env static-env :params params :body body :env-param eparam}))
|
||||
|
||||
(define
|
||||
kernel-operative?
|
||||
(fn (v) (and (dict? v) (= (get v :knl-tag) :operative))))
|
||||
|
||||
(define
|
||||
kernel-applicative?
|
||||
(fn (v) (and (dict? v) (= (get v :knl-tag) :applicative))))
|
||||
|
||||
(define
|
||||
kernel-combiner?
|
||||
(fn (v) (or (kernel-operative? v) (kernel-applicative? v))))
|
||||
|
||||
(define
|
||||
kernel-wrap
|
||||
(fn
|
||||
(op)
|
||||
(cond
|
||||
((kernel-operative? op) {:knl-tag :applicative :underlying op})
|
||||
(:else (error "kernel-wrap: argument must be an operative")))))
|
||||
|
||||
(define
|
||||
kernel-unwrap
|
||||
(fn
|
||||
(app)
|
||||
(cond
|
||||
((kernel-applicative? app) (get app :underlying))
|
||||
(:else (error "kernel-unwrap: argument must be an applicative")))))
|
||||
|
||||
(define
|
||||
kernel-make-primitive-applicative
|
||||
(fn
|
||||
(impl)
|
||||
(kernel-wrap
|
||||
(kernel-make-primitive-operative (fn (args dyn-env) (impl args))))))
|
||||
|
||||
;; ── The evaluator ────────────────────────────────────────────────
|
||||
|
||||
(define
|
||||
kernel-eval
|
||||
(fn
|
||||
(expr env)
|
||||
(cond
|
||||
((number? expr) expr)
|
||||
((boolean? expr) expr)
|
||||
((nil? expr) expr)
|
||||
((kernel-string? expr) (kernel-string-value expr))
|
||||
((string? expr) (kernel-env-lookup env expr))
|
||||
((list? expr)
|
||||
(cond
|
||||
((= (length expr) 0) expr)
|
||||
(:else
|
||||
(let
|
||||
((combiner (kernel-eval (first expr) env))
|
||||
(args (rest expr)))
|
||||
(kernel-combine combiner args env)))))
|
||||
(:else (error (str "kernel-eval: unknown form: " expr))))))
|
||||
|
||||
(define
|
||||
kernel-combine
|
||||
(fn
|
||||
(combiner args dyn-env)
|
||||
(cond
|
||||
((kernel-operative? combiner)
|
||||
(kernel-call-operative combiner args dyn-env))
|
||||
((kernel-applicative? combiner)
|
||||
(kernel-combine
|
||||
(get combiner :underlying)
|
||||
(kernel-eval-args args dyn-env)
|
||||
dyn-env))
|
||||
(:else (error (str "kernel-eval: not a combiner: " combiner))))))
|
||||
|
||||
;; Operatives may be primitive (:impl is a host fn) or user-defined
|
||||
;; (carry :params / :env-param / :body / :static-env). The dispatch
|
||||
;; fork is here so kernel-combine stays small.
|
||||
(define
|
||||
kernel-call-operative
|
||||
(fn
|
||||
(op args dyn-env)
|
||||
(cond
|
||||
((dict-has? op :impl) ((get op :impl) args dyn-env))
|
||||
((dict-has? op :body)
|
||||
(let
|
||||
((local (kernel-extend-env (get op :static-env))))
|
||||
(kernel-bind-params! local (get op :params) args)
|
||||
(let
|
||||
((eparam (get op :env-param)))
|
||||
(when
|
||||
(not (= eparam :knl-ignore))
|
||||
(kernel-env-bind! local eparam dyn-env)))
|
||||
(kernel-eval (get op :body) local)))
|
||||
(:else (error "kernel-call-operative: malformed operative")))))
|
||||
|
||||
;; Phase 3 supports a flat parameter list only — destructuring later.
|
||||
(define
|
||||
kernel-bind-params!
|
||||
(fn
|
||||
(env params args)
|
||||
(cond
|
||||
((or (nil? params) (= (length params) 0))
|
||||
(cond
|
||||
((or (nil? args) (= (length args) 0)) nil)
|
||||
(:else (error "kernel-call: too many arguments"))))
|
||||
((or (nil? args) (= (length args) 0))
|
||||
(error "kernel-call: too few arguments"))
|
||||
(:else
|
||||
(begin
|
||||
(kernel-env-bind! env (first params) (first args))
|
||||
(kernel-bind-params! env (rest params) (rest args)))))))
|
||||
|
||||
(define
|
||||
kernel-eval-args
|
||||
(fn
|
||||
(args env)
|
||||
(cond
|
||||
((or (nil? args) (= (length args) 0)) (list))
|
||||
(:else
|
||||
(cons
|
||||
(kernel-eval (first args) env)
|
||||
(kernel-eval-args (rest args) env))))))
|
||||
|
||||
(define
|
||||
kernel-eval-program
|
||||
(fn
|
||||
(forms env)
|
||||
(cond
|
||||
((or (nil? forms) (= (length forms) 0)) nil)
|
||||
((= (length forms) 1) (kernel-eval (first forms) env))
|
||||
(:else
|
||||
(begin
|
||||
(kernel-eval (first forms) env)
|
||||
(kernel-eval-program (rest forms) env))))))
|
||||
240
lib/kernel/parser.sx
Normal file
240
lib/kernel/parser.sx
Normal file
@@ -0,0 +1,240 @@
|
||||
;; lib/kernel/parser.sx — Kernel s-expression reader.
|
||||
;;
|
||||
;; Reads R-1RK lexical syntax: numbers, strings, symbols, booleans (#t/#f),
|
||||
;; the empty list (), nested lists, and ; line comments. Reader macros
|
||||
;; (' ` , ,@) deferred to Phase 6 per the plan.
|
||||
;;
|
||||
;; Public AST shape:
|
||||
;; number → SX number
|
||||
;; #t / #f → SX true / false
|
||||
;; () → SX empty list (Kernel's nil — the empty list)
|
||||
;; "..." → {:knl-string "..."} wrapped to distinguish from symbols
|
||||
;; foo → "foo" bare SX string is a Kernel symbol
|
||||
;; (a b c) → SX list of forms
|
||||
;;
|
||||
;; Public API:
|
||||
;; (kernel-parse SRC) — first form; errors on extra trailing input
|
||||
;; (kernel-parse-all SRC) — all top-level forms, as SX list
|
||||
;; (kernel-string? V) — recognise wrapped string literal
|
||||
;; (kernel-string-value V) — extract the underlying string
|
||||
;;
|
||||
;; Consumes: lib/guest/lex.sx (lex-digit?, lex-whitespace?)
|
||||
|
||||
(define kernel-string-make (fn (s) {:knl-string s}))
|
||||
(define
|
||||
kernel-string?
|
||||
(fn (v) (and (dict? v) (string? (get v :knl-string)))))
|
||||
(define kernel-string-value (fn (v) (get v :knl-string)))
|
||||
|
||||
;; Atom delimiters: characters that end a symbol or numeric token.
|
||||
(define
|
||||
knl-delim?
|
||||
(fn
|
||||
(c)
|
||||
(or
|
||||
(nil? c)
|
||||
(lex-whitespace? c)
|
||||
(= c "(")
|
||||
(= c ")")
|
||||
(= c "\"")
|
||||
(= c ";"))))
|
||||
|
||||
;; Numeric grammar: [+-]? (digit+ ('.' digit+)? | '.' digit+) ([eE][+-]?digit+)?
|
||||
(define
|
||||
knl-numeric?
|
||||
(fn
|
||||
(s)
|
||||
(let
|
||||
((n (string-length s)))
|
||||
(cond
|
||||
((= n 0) false)
|
||||
(:else
|
||||
(let
|
||||
((c0 (substring s 0 1)))
|
||||
(let
|
||||
((start (if (or (= c0 "+") (= c0 "-")) 1 0)))
|
||||
(knl-num-body? s start n))))))))
|
||||
|
||||
(define
|
||||
knl-num-body?
|
||||
(fn
|
||||
(s start n)
|
||||
(cond
|
||||
((>= start n) false)
|
||||
((= (substring s start (+ start 1)) ".")
|
||||
(knl-num-need-digits? s (+ start 1) n false))
|
||||
((lex-digit? (substring s start (+ start 1)))
|
||||
(knl-num-int-tail? s (+ start 1) n))
|
||||
(:else false))))
|
||||
|
||||
(define
|
||||
knl-num-int-tail?
|
||||
(fn
|
||||
(s i n)
|
||||
(cond
|
||||
((>= i n) true)
|
||||
((lex-digit? (substring s i (+ i 1)))
|
||||
(knl-num-int-tail? s (+ i 1) n))
|
||||
((= (substring s i (+ i 1)) ".")
|
||||
(knl-num-need-digits? s (+ i 1) n true))
|
||||
((or (= (substring s i (+ i 1)) "e") (= (substring s i (+ i 1)) "E"))
|
||||
(knl-num-exp-sign? s (+ i 1) n))
|
||||
(:else false))))
|
||||
|
||||
(define
|
||||
knl-num-need-digits?
|
||||
(fn
|
||||
(s i n had-int)
|
||||
(cond
|
||||
((>= i n) had-int)
|
||||
((lex-digit? (substring s i (+ i 1)))
|
||||
(knl-num-frac-tail? s (+ i 1) n))
|
||||
(:else false))))
|
||||
|
||||
(define
|
||||
knl-num-frac-tail?
|
||||
(fn
|
||||
(s i n)
|
||||
(cond
|
||||
((>= i n) true)
|
||||
((lex-digit? (substring s i (+ i 1)))
|
||||
(knl-num-frac-tail? s (+ i 1) n))
|
||||
((or (= (substring s i (+ i 1)) "e") (= (substring s i (+ i 1)) "E"))
|
||||
(knl-num-exp-sign? s (+ i 1) n))
|
||||
(:else false))))
|
||||
|
||||
(define
|
||||
knl-num-exp-sign?
|
||||
(fn
|
||||
(s i n)
|
||||
(cond
|
||||
((>= i n) false)
|
||||
((or (= (substring s i (+ i 1)) "+") (= (substring s i (+ i 1)) "-"))
|
||||
(knl-num-exp-digits? s (+ i 1) n false))
|
||||
(:else (knl-num-exp-digits? s i n false)))))
|
||||
|
||||
(define
|
||||
knl-num-exp-digits?
|
||||
(fn
|
||||
(s i n had)
|
||||
(cond
|
||||
((>= i n) had)
|
||||
((lex-digit? (substring s i (+ i 1)))
|
||||
(knl-num-exp-digits? s (+ i 1) n true))
|
||||
(:else false))))
|
||||
|
||||
;; Reader: a closure over (src, pos). Exposes :read-form and :read-all.
|
||||
(define
|
||||
knl-make-reader
|
||||
(fn
|
||||
(src)
|
||||
(let
|
||||
((pos 0) (n (string-length src)))
|
||||
(define
|
||||
at
|
||||
(fn () (if (< pos n) (substring src pos (+ pos 1)) nil)))
|
||||
(define adv (fn () (set! pos (+ pos 1))))
|
||||
(define
|
||||
skip-line
|
||||
(fn () (when (and (at) (not (= (at) "\n"))) (adv) (skip-line))))
|
||||
(define
|
||||
skip-ws
|
||||
(fn
|
||||
()
|
||||
(cond
|
||||
((nil? (at)) nil)
|
||||
((lex-whitespace? (at)) (do (adv) (skip-ws)))
|
||||
((= (at) ";") (do (adv) (skip-line) (skip-ws)))
|
||||
(:else nil))))
|
||||
(define
|
||||
read-string-body
|
||||
(fn
|
||||
(acc)
|
||||
(cond
|
||||
((nil? (at)) (error "kernel-parse: unterminated string"))
|
||||
((= (at) "\"") (do (adv) acc))
|
||||
((= (at) "\\")
|
||||
(do
|
||||
(adv)
|
||||
(let
|
||||
((c (at)))
|
||||
(when (nil? c) (error "kernel-parse: trailing backslash"))
|
||||
(adv)
|
||||
(read-string-body
|
||||
(str
|
||||
acc
|
||||
(cond
|
||||
((= c "n") "\n")
|
||||
((= c "t") "\t")
|
||||
((= c "r") "\r")
|
||||
((= c "\"") "\"")
|
||||
((= c "\\") "\\")
|
||||
(:else c)))))))
|
||||
(:else
|
||||
(let ((c (at))) (adv) (read-string-body (str acc c)))))))
|
||||
(define
|
||||
read-atom-body
|
||||
(fn
|
||||
(acc)
|
||||
(cond
|
||||
((knl-delim? (at)) acc)
|
||||
(:else (let ((c (at))) (adv) (read-atom-body (str acc c)))))))
|
||||
(define
|
||||
classify-atom
|
||||
(fn
|
||||
(s)
|
||||
(cond
|
||||
((= s "#t") true)
|
||||
((= s "#f") false)
|
||||
((knl-numeric? s) (string->number s))
|
||||
(:else s))))
|
||||
(define
|
||||
read-form
|
||||
(fn
|
||||
()
|
||||
(skip-ws)
|
||||
(cond
|
||||
((nil? (at)) :knl-eof)
|
||||
((= (at) ")") (error "kernel-parse: unexpected ')'"))
|
||||
((= (at) "(") (do (adv) (read-list (list))))
|
||||
((= (at) "\"")
|
||||
(do (adv) (kernel-string-make (read-string-body ""))))
|
||||
(:else (classify-atom (read-atom-body ""))))))
|
||||
(define
|
||||
read-list
|
||||
(fn
|
||||
(acc)
|
||||
(skip-ws)
|
||||
(cond
|
||||
((nil? (at)) (error "kernel-parse: unterminated list"))
|
||||
((= (at) ")") (do (adv) acc))
|
||||
(:else (read-list (append acc (list (read-form))))))))
|
||||
(define
|
||||
read-all
|
||||
(fn
|
||||
(acc)
|
||||
(skip-ws)
|
||||
(if (nil? (at)) acc (read-all (append acc (list (read-form)))))))
|
||||
{:read-form read-form :read-all read-all})))
|
||||
|
||||
(define
|
||||
kernel-parse-all
|
||||
(fn (src) ((get (knl-make-reader src) :read-all) (list))))
|
||||
|
||||
(define
|
||||
kernel-parse
|
||||
(fn
|
||||
(src)
|
||||
(let
|
||||
((r (knl-make-reader src)))
|
||||
(let
|
||||
((form ((get r :read-form))))
|
||||
(cond
|
||||
((= form :knl-eof) (error "kernel-parse: empty input"))
|
||||
(:else
|
||||
(let
|
||||
((next ((get r :read-form))))
|
||||
(if
|
||||
(= next :knl-eof)
|
||||
form
|
||||
(error "kernel-parse: trailing input after first form")))))))))
|
||||
167
lib/kernel/runtime.sx
Normal file
167
lib/kernel/runtime.sx
Normal file
@@ -0,0 +1,167 @@
|
||||
;; lib/kernel/runtime.sx — the operative–applicative substrate.
|
||||
;;
|
||||
;; Builds the first user-visible operatives so Kernel programs can
|
||||
;; construct their own combiners:
|
||||
;;
|
||||
;; $vau — primitive operative that returns a user operative
|
||||
;; $lambda — primitive operative; sugar for (wrap ($vau …))
|
||||
;; wrap — primitive applicative; wraps an operative
|
||||
;; unwrap — primitive applicative; extracts the underlying op
|
||||
;;
|
||||
;; In Kernel, $lambda is *defined* in terms of $vau and wrap:
|
||||
;; ($define! $lambda
|
||||
;; ($vau (formals . body) #ignore
|
||||
;; (wrap (eval (list $vau formals #ignore (cons $sequence body)) env))))
|
||||
;; Phase 3 supplies it natively (single-expression body) so tests can
|
||||
;; build applicatives without a working $define!/$sequence yet. The
|
||||
;; native-then-portable migration is a Phase 4 concern.
|
||||
;;
|
||||
;; The env-param sentinel
|
||||
;; ----------------------
|
||||
;; A user operative records an `:env-param` slot. If the source said
|
||||
;; `#ignore`, the slot holds the keyword :knl-ignore and kernel-call-
|
||||
;; operative skips binding the dynamic env. The parser doesn't recognise
|
||||
;; `#ignore` yet (Phase 1 covered #t/#f only); guests must spell it
|
||||
;; `_` for now — the spelling-to-sentinel conversion lives here in
|
||||
;; knl-eparam-sentinel.
|
||||
;;
|
||||
;; Public API
|
||||
;; (kernel-base-env) — fresh env with $vau, $lambda, wrap, unwrap
|
||||
;;
|
||||
;; Consumes: lib/kernel/eval.sx (everything tagged kernel-*).
|
||||
|
||||
(define
|
||||
knl-eparam-sentinel
|
||||
(fn
|
||||
(sym)
|
||||
(cond
|
||||
((= sym "_") :knl-ignore)
|
||||
((= sym "#ignore") :knl-ignore)
|
||||
(:else sym))))
|
||||
|
||||
;; Validate that a formals list is a plain list of symbol names.
|
||||
(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 ─────────────────────────────────────────────────────────
|
||||
;; ($vau FORMALS ENV-PARAM BODY) → user operative.
|
||||
;;
|
||||
;; FORMALS — unevaluated list of parameter symbols.
|
||||
;; ENV-PARAM — symbol (or `_` / `#ignore`).
|
||||
;; BODY — single expression (Phase 3 limitation; $sequence later).
|
||||
;;
|
||||
;; The returned operative closes over the env where $vau was invoked.
|
||||
|
||||
(define
|
||||
kernel-vau-impl
|
||||
(fn
|
||||
(args dyn-env)
|
||||
(cond
|
||||
((not (= (length args) 3))
|
||||
(error "$vau: expects (formals env-param body)"))
|
||||
(:else
|
||||
(let
|
||||
((formals (first args))
|
||||
(eparam-raw (nth args 1))
|
||||
(body (nth args 2)))
|
||||
(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
|
||||
dyn-env))))))))
|
||||
|
||||
(define
|
||||
kernel-vau-operative
|
||||
(kernel-make-primitive-operative kernel-vau-impl))
|
||||
|
||||
;; ── $lambda ──────────────────────────────────────────────────────
|
||||
;; ($lambda FORMALS BODY) → user applicative.
|
||||
;;
|
||||
;; Equivalent to (wrap ($vau FORMALS #ignore BODY)) — args are evaluated
|
||||
;; before the operative body runs, and the operative ignores the dynamic
|
||||
;; environment.
|
||||
|
||||
(define
|
||||
kernel-lambda-impl
|
||||
(fn
|
||||
(args dyn-env)
|
||||
(cond
|
||||
((not (= (length args) 2))
|
||||
(error "$lambda: expects (formals body)"))
|
||||
(:else
|
||||
(let
|
||||
((formals (first args)) (body (nth args 1)))
|
||||
(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 dyn-env)))))))))
|
||||
|
||||
(define
|
||||
kernel-lambda-operative
|
||||
(kernel-make-primitive-operative kernel-lambda-impl))
|
||||
|
||||
;; ── wrap / unwrap as Kernel applicatives ─────────────────────────
|
||||
|
||||
(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)))))))
|
||||
|
||||
;; Convenience predicates as applicatives too — tests want them.
|
||||
(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)))))
|
||||
|
||||
;; ── Base environment ─────────────────────────────────────────────
|
||||
;; A fresh env with the Phase 3 combiners bound. Standard env (Phase 4)
|
||||
;; will extend this with $if, $define!, arithmetic, list ops, etc.
|
||||
|
||||
(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)))
|
||||
270
lib/kernel/tests/eval.sx
Normal file
270
lib/kernel/tests/eval.sx
Normal file
@@ -0,0 +1,270 @@
|
||||
;; lib/kernel/tests/eval.sx — exercises lib/kernel/eval.sx.
|
||||
;;
|
||||
;; Phase 2 covers literal evaluation, symbol lookup, and combiner
|
||||
;; dispatch (operative vs applicative). Standard-environment operatives
|
||||
;; ($if, $define!, $lambda, …) arrive in Phase 4, so tests build a
|
||||
;; minimal env on the fly and verify the dispatch contract directly.
|
||||
|
||||
(define ke-test-pass 0)
|
||||
(define ke-test-fail 0)
|
||||
(define ke-test-fails (list))
|
||||
|
||||
(define
|
||||
ke-test
|
||||
(fn
|
||||
(name actual expected)
|
||||
(if
|
||||
(= actual expected)
|
||||
(set! ke-test-pass (+ ke-test-pass 1))
|
||||
(begin
|
||||
(set! ke-test-fail (+ ke-test-fail 1))
|
||||
(append! ke-test-fails {:name name :actual actual :expected expected})))))
|
||||
|
||||
;; ── helpers ──────────────────────────────────────────────────────
|
||||
|
||||
(define ke-eval-src (fn (src env) (kernel-eval (kernel-parse src) env)))
|
||||
|
||||
(define
|
||||
ke-make-test-env
|
||||
(fn
|
||||
()
|
||||
(let
|
||||
((env (kernel-make-env)))
|
||||
(kernel-env-bind!
|
||||
env
|
||||
"+"
|
||||
(kernel-make-primitive-applicative
|
||||
(fn (args) (+ (first args) (nth args 1)))))
|
||||
(kernel-env-bind!
|
||||
env
|
||||
"list"
|
||||
(kernel-make-primitive-applicative (fn (args) args)))
|
||||
(kernel-env-bind!
|
||||
env
|
||||
"$quote"
|
||||
(kernel-make-primitive-operative (fn (args dyn-env) (first args))))
|
||||
(kernel-env-bind!
|
||||
env
|
||||
"$if"
|
||||
(kernel-make-primitive-operative
|
||||
(fn
|
||||
(args dyn-env)
|
||||
(if
|
||||
(kernel-eval (first args) dyn-env)
|
||||
(kernel-eval (nth args 1) dyn-env)
|
||||
(kernel-eval (nth args 2) dyn-env)))))
|
||||
env)))
|
||||
|
||||
;; ── literal evaluation ───────────────────────────────────────────
|
||||
(ke-test "lit: number" (ke-eval-src "42" (kernel-make-env)) 42)
|
||||
(ke-test "lit: zero" (ke-eval-src "0" (kernel-make-env)) 0)
|
||||
(ke-test "lit: float" (ke-eval-src "3.14" (kernel-make-env)) 3.14)
|
||||
(ke-test "lit: true" (ke-eval-src "#t" (kernel-make-env)) true)
|
||||
(ke-test "lit: false" (ke-eval-src "#f" (kernel-make-env)) false)
|
||||
(ke-test "lit: string" (ke-eval-src "\"hello\"" (kernel-make-env)) "hello")
|
||||
(ke-test "lit: empty list" (ke-eval-src "()" (kernel-make-env)) (list))
|
||||
|
||||
;; ── symbol lookup ────────────────────────────────────────────────
|
||||
(ke-test
|
||||
"sym: bound to number"
|
||||
(let
|
||||
((env (kernel-make-env)))
|
||||
(kernel-env-bind! env "x" 100)
|
||||
(ke-eval-src "x" env))
|
||||
100)
|
||||
|
||||
(ke-test
|
||||
"sym: bound to string"
|
||||
(let
|
||||
((env (kernel-make-env)))
|
||||
(kernel-env-bind! env "name" "kernel")
|
||||
(ke-eval-src "name" env))
|
||||
"kernel")
|
||||
|
||||
(ke-test
|
||||
"sym: parent-chain lookup"
|
||||
(let
|
||||
((p (kernel-make-env)))
|
||||
(kernel-env-bind! p "outer" 1)
|
||||
(let
|
||||
((c (kernel-extend-env p)))
|
||||
(kernel-env-bind! c "inner" 2)
|
||||
(+ (ke-eval-src "outer" c) (ke-eval-src "inner" c))))
|
||||
3)
|
||||
|
||||
(ke-test
|
||||
"sym: child shadows parent"
|
||||
(let
|
||||
((p (kernel-make-env)))
|
||||
(kernel-env-bind! p "x" 1)
|
||||
(let
|
||||
((c (kernel-extend-env p)))
|
||||
(kernel-env-bind! c "x" 2)
|
||||
(ke-eval-src "x" c)))
|
||||
2)
|
||||
|
||||
(ke-test
|
||||
"env-has?: present"
|
||||
(let
|
||||
((env (kernel-make-env)))
|
||||
(kernel-env-bind! env "x" 1)
|
||||
(kernel-env-has? env "x"))
|
||||
true)
|
||||
|
||||
(ke-test
|
||||
"env-has?: missing"
|
||||
(kernel-env-has? (kernel-make-env) "nope")
|
||||
false)
|
||||
|
||||
;; ── tagged-value predicates ─────────────────────────────────────
|
||||
(ke-test
|
||||
"tag: operative?"
|
||||
(kernel-operative? (kernel-make-primitive-operative (fn (a e) nil)))
|
||||
true)
|
||||
|
||||
(ke-test
|
||||
"tag: applicative?"
|
||||
(kernel-applicative? (kernel-make-primitive-applicative (fn (a) nil)))
|
||||
true)
|
||||
|
||||
(ke-test
|
||||
"tag: combiner? operative"
|
||||
(kernel-combiner? (kernel-make-primitive-operative (fn (a e) nil)))
|
||||
true)
|
||||
|
||||
(ke-test
|
||||
"tag: combiner? applicative"
|
||||
(kernel-combiner? (kernel-make-primitive-applicative (fn (a) nil)))
|
||||
true)
|
||||
|
||||
(ke-test "tag: combiner? number" (kernel-combiner? 42) false)
|
||||
|
||||
(ke-test "tag: number is not operative" (kernel-operative? 42) false)
|
||||
|
||||
;; ── wrap / unwrap ────────────────────────────────────────────────
|
||||
(ke-test
|
||||
"wrap+unwrap roundtrip"
|
||||
(let
|
||||
((op (kernel-make-primitive-operative (fn (a e) :sentinel))))
|
||||
(= (kernel-unwrap (kernel-wrap op)) op))
|
||||
true)
|
||||
|
||||
(ke-test
|
||||
"wrap produces applicative"
|
||||
(kernel-applicative?
|
||||
(kernel-wrap (kernel-make-primitive-operative (fn (a e) nil))))
|
||||
true)
|
||||
|
||||
(ke-test
|
||||
"unwrap of primitive-applicative is operative"
|
||||
(kernel-operative?
|
||||
(kernel-unwrap (kernel-make-primitive-applicative (fn (a) nil))))
|
||||
true)
|
||||
|
||||
;; ── combiner dispatch — applicatives evaluate their args ─────────
|
||||
(ke-test
|
||||
"applicative: simple call"
|
||||
(ke-eval-src "(+ 2 3)" (ke-make-test-env))
|
||||
5)
|
||||
|
||||
(ke-test
|
||||
"applicative: nested"
|
||||
(ke-eval-src "(+ (+ 1 2) (+ 3 4))" (ke-make-test-env))
|
||||
10)
|
||||
|
||||
(ke-test
|
||||
"applicative: receives evaluated args"
|
||||
(let
|
||||
((env (ke-make-test-env)))
|
||||
(kernel-env-bind! env "x" 10)
|
||||
(kernel-env-bind! env "y" 20)
|
||||
(ke-eval-src "(+ x y)" env))
|
||||
30)
|
||||
|
||||
(ke-test
|
||||
"applicative: list builds an SX list of values"
|
||||
(let
|
||||
((env (ke-make-test-env)))
|
||||
(kernel-env-bind! env "a" 1)
|
||||
(kernel-env-bind! env "b" 2)
|
||||
(ke-eval-src "(list a b 99)" env))
|
||||
(list 1 2 99))
|
||||
|
||||
;; ── combiner dispatch — operatives DO NOT evaluate their args ───
|
||||
(ke-test
|
||||
"operative: $quote returns symbol unevaluated"
|
||||
(ke-eval-src "($quote foo)" (ke-make-test-env))
|
||||
"foo")
|
||||
|
||||
(ke-test
|
||||
"operative: $quote returns list unevaluated"
|
||||
(ke-eval-src "($quote (+ 1 2))" (ke-make-test-env))
|
||||
(list "+" 1 2))
|
||||
|
||||
(ke-test
|
||||
"operative: $if true branch"
|
||||
(ke-eval-src "($if #t 1 2)" (ke-make-test-env))
|
||||
1)
|
||||
|
||||
(ke-test
|
||||
"operative: $if false branch"
|
||||
(ke-eval-src "($if #f 1 2)" (ke-make-test-env))
|
||||
2)
|
||||
|
||||
(ke-test
|
||||
"operative: $if doesn't eval untaken branch"
|
||||
(ke-eval-src "($if #t 99 unbound)" (ke-make-test-env))
|
||||
99)
|
||||
|
||||
(ke-test
|
||||
"operative: $if takes dynamic env for branches"
|
||||
(let
|
||||
((env (ke-make-test-env)))
|
||||
(kernel-env-bind! env "x" 7)
|
||||
(ke-eval-src "($if #t x 0)" env))
|
||||
7)
|
||||
|
||||
;; ── operative built ON-THE-FLY can inspect raw expressions ──────
|
||||
(ke-test
|
||||
"operative: sees raw symbol head"
|
||||
(let
|
||||
((env (kernel-make-env)))
|
||||
(kernel-env-bind!
|
||||
env
|
||||
"head"
|
||||
(kernel-make-primitive-operative (fn (args dyn-env) (first args))))
|
||||
(ke-eval-src "(head (+ 1 2))" env))
|
||||
(list "+" 1 2))
|
||||
|
||||
(ke-test
|
||||
"operative: sees dynamic env"
|
||||
(let
|
||||
((env (kernel-make-env)))
|
||||
(kernel-env-bind! env "x" 999)
|
||||
(kernel-env-bind!
|
||||
env
|
||||
"$probe"
|
||||
(kernel-make-primitive-operative
|
||||
(fn (args dyn-env) (kernel-env-lookup dyn-env "x"))))
|
||||
(ke-eval-src "($probe ignored)" env))
|
||||
999)
|
||||
|
||||
;; ── error cases ──────────────────────────────────────────────────
|
||||
(ke-test
|
||||
"error: unbound symbol"
|
||||
(guard
|
||||
(e (true :raised))
|
||||
(kernel-eval (kernel-parse "nope") (kernel-make-env)))
|
||||
:raised)
|
||||
|
||||
(ke-test
|
||||
"error: combine non-combiner"
|
||||
(guard
|
||||
(e (true :raised))
|
||||
(let
|
||||
((env (kernel-make-env)))
|
||||
(kernel-env-bind! env "x" 42)
|
||||
(kernel-eval (kernel-parse "(x 1)") env)))
|
||||
:raised)
|
||||
|
||||
(define ke-tests-run! (fn () {:total (+ ke-test-pass ke-test-fail) :passed ke-test-pass :failed ke-test-fail :fails ke-test-fails}))
|
||||
134
lib/kernel/tests/parse.sx
Normal file
134
lib/kernel/tests/parse.sx
Normal file
@@ -0,0 +1,134 @@
|
||||
;; lib/kernel/tests/parse.sx — exercises lib/kernel/parser.sx.
|
||||
|
||||
(define knl-test-pass 0)
|
||||
(define knl-test-fail 0)
|
||||
(define knl-test-fails (list))
|
||||
|
||||
(define
|
||||
knl-test
|
||||
(fn
|
||||
(name actual expected)
|
||||
(if
|
||||
(= actual expected)
|
||||
(set! knl-test-pass (+ knl-test-pass 1))
|
||||
(begin
|
||||
(set! knl-test-fail (+ knl-test-fail 1))
|
||||
(append! knl-test-fails {:name name :actual actual :expected expected})))))
|
||||
|
||||
;; ── atoms: numbers ────────────────────────────────────────────────
|
||||
(knl-test "num: integer" (kernel-parse "42") 42)
|
||||
(knl-test "num: zero" (kernel-parse "0") 0)
|
||||
(knl-test "num: negative integer" (kernel-parse "-7") -7)
|
||||
(knl-test "num: positive sign" (kernel-parse "+5") 5)
|
||||
(knl-test "num: float" (kernel-parse "3.14") 3.14)
|
||||
(knl-test "num: negative float" (kernel-parse "-2.5") -2.5)
|
||||
(knl-test "num: leading dot" (kernel-parse ".5") 0.5)
|
||||
(knl-test "num: exponent" (kernel-parse "1e3") 1000)
|
||||
(knl-test "num: exponent with sign" (kernel-parse "2.5e-1") 0.25)
|
||||
(knl-test "num: capital E exponent" (kernel-parse "1E2") 100)
|
||||
|
||||
;; ── atoms: booleans ───────────────────────────────────────────────
|
||||
(knl-test "bool: true" (kernel-parse "#t") true)
|
||||
(knl-test "bool: false" (kernel-parse "#f") false)
|
||||
|
||||
;; ── atoms: empty list (Kernel nil) ────────────────────────────────
|
||||
(knl-test "nil: ()" (kernel-parse "()") (list))
|
||||
(knl-test "nil: (= () (list))" (= (kernel-parse "()") (list)) true)
|
||||
|
||||
;; ── atoms: symbols ────────────────────────────────────────────────
|
||||
(knl-test "sym: word" (kernel-parse "foo") "foo")
|
||||
(knl-test "sym: hyphenated" (kernel-parse "foo-bar") "foo-bar")
|
||||
(knl-test "sym: dollar-bang" (kernel-parse "$define!") "$define!")
|
||||
(knl-test "sym: question" (kernel-parse "null?") "null?")
|
||||
(knl-test "sym: lt-eq" (kernel-parse "<=") "<=")
|
||||
(knl-test "sym: bare plus" (kernel-parse "+") "+")
|
||||
(knl-test "sym: bare minus" (kernel-parse "-") "-")
|
||||
(knl-test "sym: plus-letter" (kernel-parse "+a") "+a")
|
||||
(knl-test "sym: arrow" (kernel-parse "->") "->")
|
||||
(knl-test "sym: dot-prefixed" (kernel-parse ".foo") ".foo")
|
||||
|
||||
;; ── atoms: strings ────────────────────────────────────────────────
|
||||
(knl-test "str: empty" (kernel-string-value (kernel-parse "\"\"")) "")
|
||||
(knl-test
|
||||
"str: hello"
|
||||
(kernel-string-value (kernel-parse "\"hello\""))
|
||||
"hello")
|
||||
(knl-test "str: predicate" (kernel-string? (kernel-parse "\"x\"")) true)
|
||||
(knl-test "str: not symbol" (kernel-string? (kernel-parse "x")) false)
|
||||
(knl-test
|
||||
"str: escape newline"
|
||||
(kernel-string-value (kernel-parse "\"a\\nb\""))
|
||||
"a\nb")
|
||||
(knl-test
|
||||
"str: escape tab"
|
||||
(kernel-string-value (kernel-parse "\"a\\tb\""))
|
||||
"a\tb")
|
||||
(knl-test
|
||||
"str: escape quote"
|
||||
(kernel-string-value (kernel-parse "\"a\\\"b\""))
|
||||
"a\"b")
|
||||
(knl-test
|
||||
"str: escape backslash"
|
||||
(kernel-string-value (kernel-parse "\"a\\\\b\""))
|
||||
"a\\b")
|
||||
|
||||
;; ── lists ─────────────────────────────────────────────────────────
|
||||
(knl-test "list: flat" (kernel-parse "(a b c)") (list "a" "b" "c"))
|
||||
(knl-test
|
||||
"list: nested"
|
||||
(kernel-parse "(a (b c) d)")
|
||||
(list "a" (list "b" "c") "d"))
|
||||
(knl-test
|
||||
"list: deeply nested"
|
||||
(kernel-parse "(((x)))")
|
||||
(list (list (list "x"))))
|
||||
(knl-test
|
||||
"list: mixed atoms"
|
||||
(kernel-parse "(1 #t foo)")
|
||||
(list 1 true "foo"))
|
||||
(knl-test
|
||||
"list: empty inside"
|
||||
(kernel-parse "(a () b)")
|
||||
(list "a" (list) "b"))
|
||||
|
||||
;; ── whitespace + comments ─────────────────────────────────────────
|
||||
(knl-test "ws: leading" (kernel-parse " 42") 42)
|
||||
(knl-test "ws: trailing" (kernel-parse "42 ") 42)
|
||||
(knl-test "ws: tabs/newlines" (kernel-parse "\n\t 42 \n") 42)
|
||||
(knl-test "comment: line" (kernel-parse "; nope\n42") 42)
|
||||
(knl-test "comment: trailing" (kernel-parse "42 ; tail") 42)
|
||||
(knl-test
|
||||
"comment: inside list"
|
||||
(kernel-parse "(a ; mid\n b)")
|
||||
(list "a" "b"))
|
||||
|
||||
;; ── parse-all ─────────────────────────────────────────────────────
|
||||
(knl-test "all: empty input" (kernel-parse-all "") (list))
|
||||
(knl-test "all: only whitespace" (kernel-parse-all " ") (list))
|
||||
(knl-test "all: only comment" (kernel-parse-all "; nope") (list))
|
||||
(knl-test
|
||||
"all: three forms"
|
||||
(kernel-parse-all "1 2 3")
|
||||
(list 1 2 3))
|
||||
(knl-test
|
||||
"all: mixed"
|
||||
(kernel-parse-all "($if #t 1 2) foo")
|
||||
(list (list "$if" true 1 2) "foo"))
|
||||
|
||||
;; ── classic Kernel programs (smoke) ───────────────────────────────
|
||||
(knl-test
|
||||
"klisp: vau form"
|
||||
(kernel-parse "($vau (x e) e (eval x e))")
|
||||
(list "$vau" (list "x" "e") "e" (list "eval" "x" "e")))
|
||||
(knl-test
|
||||
"klisp: define lambda"
|
||||
(kernel-parse "($define! sq ($lambda (x) (* x x)))")
|
||||
(list "$define!" "sq" (list "$lambda" (list "x") (list "*" "x" "x"))))
|
||||
|
||||
;; ── round-trip identity for primitive symbols ─────────────────────
|
||||
(knl-test "identity: $vau" (kernel-parse "$vau") "$vau")
|
||||
(knl-test "identity: $lambda" (kernel-parse "$lambda") "$lambda")
|
||||
(knl-test "identity: wrap" (kernel-parse "wrap") "wrap")
|
||||
(knl-test "identity: unwrap" (kernel-parse "unwrap") "unwrap")
|
||||
|
||||
(define knl-tests-run! (fn () {:total (+ knl-test-pass knl-test-fail) :passed knl-test-pass :failed knl-test-fail :fails knl-test-fails}))
|
||||
289
lib/kernel/tests/vau.sx
Normal file
289
lib/kernel/tests/vau.sx
Normal file
@@ -0,0 +1,289 @@
|
||||
;; lib/kernel/tests/vau.sx — exercises lib/kernel/runtime.sx.
|
||||
;;
|
||||
;; Verifies the Phase 3 promise: user-defined operatives and applicatives
|
||||
;; constructible from inside the language. Tests build a Kernel
|
||||
;; base-env, bind a few helper applicatives (+, *, list, =, $if), and
|
||||
;; run programs that construct and use custom combiners.
|
||||
|
||||
(define kv-test-pass 0)
|
||||
(define kv-test-fail 0)
|
||||
(define kv-test-fails (list))
|
||||
|
||||
(define
|
||||
kv-test
|
||||
(fn
|
||||
(name actual expected)
|
||||
(if
|
||||
(= actual expected)
|
||||
(set! kv-test-pass (+ kv-test-pass 1))
|
||||
(begin
|
||||
(set! kv-test-fail (+ kv-test-fail 1))
|
||||
(append! kv-test-fails {:name name :actual actual :expected expected})))))
|
||||
|
||||
(define kv-eval-src (fn (src env) (kernel-eval (kernel-parse src) env)))
|
||||
|
||||
(define
|
||||
kv-make-env
|
||||
(fn
|
||||
()
|
||||
(let
|
||||
((env (kernel-base-env)))
|
||||
(kernel-env-bind!
|
||||
env
|
||||
"+"
|
||||
(kernel-make-primitive-applicative
|
||||
(fn (args) (+ (first args) (nth args 1)))))
|
||||
(kernel-env-bind!
|
||||
env
|
||||
"*"
|
||||
(kernel-make-primitive-applicative
|
||||
(fn (args) (* (first args) (nth args 1)))))
|
||||
(kernel-env-bind!
|
||||
env
|
||||
"-"
|
||||
(kernel-make-primitive-applicative
|
||||
(fn (args) (- (first args) (nth args 1)))))
|
||||
(kernel-env-bind!
|
||||
env
|
||||
"="
|
||||
(kernel-make-primitive-applicative
|
||||
(fn (args) (= (first args) (nth args 1)))))
|
||||
(kernel-env-bind!
|
||||
env
|
||||
"list"
|
||||
(kernel-make-primitive-applicative (fn (args) args)))
|
||||
(kernel-env-bind!
|
||||
env
|
||||
"cons"
|
||||
(kernel-make-primitive-applicative
|
||||
(fn (args) (cons (first args) (nth args 1)))))
|
||||
(kernel-env-bind!
|
||||
env
|
||||
"$quote"
|
||||
(kernel-make-primitive-operative (fn (args dyn-env) (first args))))
|
||||
(kernel-env-bind!
|
||||
env
|
||||
"$if"
|
||||
(kernel-make-primitive-operative
|
||||
(fn
|
||||
(args dyn-env)
|
||||
(if
|
||||
(kernel-eval (first args) dyn-env)
|
||||
(kernel-eval (nth args 1) dyn-env)
|
||||
(kernel-eval (nth args 2) dyn-env)))))
|
||||
env)))
|
||||
|
||||
;; ── $vau: builds an operative ───────────────────────────────────
|
||||
(kv-test
|
||||
"vau: identity returns first arg unevaluated"
|
||||
(kv-eval-src "(($vau (a) _ a) hello)" (kv-make-env))
|
||||
"hello")
|
||||
|
||||
(kv-test
|
||||
"vau: returns args as raw expressions"
|
||||
(kv-eval-src "(($vau (a b) _ (list a b)) (+ 1 2) (+ 3 4))" (kv-make-env))
|
||||
(list (list "+" 1 2) (list "+" 3 4)))
|
||||
|
||||
(kv-test
|
||||
"vau: env-param is a kernel env"
|
||||
(kernel-env? (kv-eval-src "(($vau () e e))" (kv-make-env)))
|
||||
true)
|
||||
|
||||
(kv-test
|
||||
"vau: returns operative"
|
||||
(kernel-operative? (kv-eval-src "($vau (x) _ x)" (kv-make-env)))
|
||||
true)
|
||||
|
||||
(kv-test
|
||||
"vau: returns operative not applicative"
|
||||
(kernel-applicative? (kv-eval-src "($vau (x) _ x)" (kv-make-env)))
|
||||
false)
|
||||
|
||||
(kv-test
|
||||
"vau: zero-arg body"
|
||||
(kv-eval-src "(($vau () _ 42))" (kv-make-env))
|
||||
42)
|
||||
|
||||
(kv-test
|
||||
"vau: static-env closure captured"
|
||||
(let
|
||||
((outer (kv-make-env)))
|
||||
(kernel-env-bind! outer "captured" 17)
|
||||
(let
|
||||
((op (kv-eval-src "($vau () _ captured)" outer))
|
||||
(caller (kv-make-env)))
|
||||
(kernel-env-bind! caller "captured" 99)
|
||||
(kernel-combine op (list) caller)))
|
||||
17)
|
||||
|
||||
(kv-test
|
||||
"vau: env-param exposes caller's dynamic env"
|
||||
(let
|
||||
((outer (kv-make-env)))
|
||||
(kernel-env-bind! outer "x" 1)
|
||||
(let
|
||||
((op (kv-eval-src "($vau () e e)" outer)) (caller (kv-make-env)))
|
||||
(kernel-env-bind! caller "x" 2)
|
||||
(let
|
||||
((e-val (kernel-combine op (list) caller)))
|
||||
(kernel-env-lookup e-val "x"))))
|
||||
2)
|
||||
|
||||
;; ── $lambda: applicatives evaluate their args ───────────────────
|
||||
(kv-test
|
||||
"lambda: identity"
|
||||
(kv-eval-src "(($lambda (x) x) 42)" (kv-make-env))
|
||||
42)
|
||||
|
||||
(kv-test
|
||||
"lambda: addition"
|
||||
(kv-eval-src "(($lambda (x y) (+ x y)) 3 4)" (kv-make-env))
|
||||
7)
|
||||
|
||||
(kv-test
|
||||
"lambda: args are evaluated before bind"
|
||||
(kv-eval-src "(($lambda (x) x) (+ 2 3))" (kv-make-env))
|
||||
5)
|
||||
|
||||
(kv-test
|
||||
"lambda: zero args"
|
||||
(kv-eval-src "(($lambda () 99))" (kv-make-env))
|
||||
99)
|
||||
|
||||
(kv-test
|
||||
"lambda: returns applicative"
|
||||
(kernel-applicative? (kv-eval-src "($lambda (x) x)" (kv-make-env)))
|
||||
true)
|
||||
|
||||
(kv-test
|
||||
"lambda: returns applicative not operative"
|
||||
(kernel-operative? (kv-eval-src "($lambda (x) x)" (kv-make-env)))
|
||||
false)
|
||||
|
||||
(kv-test
|
||||
"lambda: higher-order"
|
||||
(kv-eval-src "(($lambda (f) (f 10)) ($lambda (x) (+ x 1)))" (kv-make-env))
|
||||
11)
|
||||
|
||||
;; ── wrap / unwrap as user-callable applicatives ─────────────────
|
||||
|
||||
(kv-test
|
||||
"wrap: makes applicative from operative"
|
||||
(kernel-applicative? (kv-eval-src "(wrap ($vau (x) _ x))" (kv-make-env)))
|
||||
true)
|
||||
|
||||
(kv-test
|
||||
"wrap: result evaluates its arg"
|
||||
(kv-eval-src "((wrap ($vau (x) _ x)) (+ 1 2))" (kv-make-env))
|
||||
3)
|
||||
|
||||
(kv-test
|
||||
"unwrap: extracts operative from applicative"
|
||||
(kernel-operative? (kv-eval-src "(unwrap ($lambda (x) x))" (kv-make-env)))
|
||||
true)
|
||||
|
||||
(kv-test
|
||||
"wrap/unwrap roundtrip preserves identity"
|
||||
(kv-eval-src
|
||||
"(($lambda (op) (= op (unwrap (wrap op)))) ($vau (x) _ x))"
|
||||
(kv-make-env))
|
||||
true)
|
||||
|
||||
;; ── operative? / applicative? as user-visible predicates ────────
|
||||
|
||||
(kv-test
|
||||
"operative? on vau result"
|
||||
(kv-eval-src "(operative? ($vau (x) _ x))" (kv-make-env))
|
||||
true)
|
||||
|
||||
(kv-test
|
||||
"operative? on lambda result"
|
||||
(kv-eval-src "(operative? ($lambda (x) x))" (kv-make-env))
|
||||
false)
|
||||
|
||||
(kv-test
|
||||
"applicative? on lambda result"
|
||||
(kv-eval-src "(applicative? ($lambda (x) x))" (kv-make-env))
|
||||
true)
|
||||
|
||||
(kv-test
|
||||
"applicative? on vau result"
|
||||
(kv-eval-src "(applicative? ($vau (x) _ x))" (kv-make-env))
|
||||
false)
|
||||
|
||||
(kv-test
|
||||
"operative? on number"
|
||||
(kv-eval-src "(operative? 42)" (kv-make-env))
|
||||
false)
|
||||
|
||||
;; ── Build BOTH layers from user code ────────────────────────────
|
||||
;; The headline Phase 3 test: defining an operative on top of an
|
||||
;; applicative defined on top of a vau.
|
||||
|
||||
(kv-test
|
||||
"custom: applicative + operative compose"
|
||||
(let
|
||||
((env (kv-make-env)))
|
||||
(kernel-env-bind! env "square" (kv-eval-src "($lambda (x) (* x x))" env))
|
||||
(kv-eval-src "(square 4)" env))
|
||||
16)
|
||||
|
||||
(kv-test "custom: operative captures argument syntax"
|
||||
;; ($capture x) returns the raw expression `x`, regardless of value.
|
||||
(let ((env (kv-make-env)))
|
||||
(kernel-env-bind! env "$capture"
|
||||
(kv-eval-src "($vau (form) _ form)" env))
|
||||
(kv-eval-src "($capture (+ 1 2))" env))
|
||||
(list "+" 1 2))
|
||||
|
||||
(kv-test "custom: applicative re-wraps an operative"
|
||||
;; Build a captured operative, then wrap it into an applicative that
|
||||
;; evaluates args before re-entry. This exercises wrap+$vau composed.
|
||||
(let ((env (kv-make-env)))
|
||||
(kernel-env-bind! env "id-app"
|
||||
(kv-eval-src "(wrap ($vau (x) _ x))" env))
|
||||
(kv-eval-src "(id-app (+ 10 20))" env))
|
||||
30)
|
||||
|
||||
;; ── Error cases ──────────────────────────────────────────────────
|
||||
|
||||
(kv-test
|
||||
"vau: rejects non-list formals"
|
||||
(guard (e (true :raised)) (kv-eval-src "($vau x _ x)" (kv-make-env)))
|
||||
:raised)
|
||||
|
||||
(kv-test
|
||||
"vau: rejects non-symbol formal"
|
||||
(guard (e (true :raised)) (kv-eval-src "($vau (1) _ x)" (kv-make-env)))
|
||||
:raised)
|
||||
|
||||
(kv-test
|
||||
"vau: rejects non-symbol env-param"
|
||||
(guard (e (true :raised)) (kv-eval-src "($vau (x) 7 x)" (kv-make-env)))
|
||||
:raised)
|
||||
|
||||
(kv-test
|
||||
"vau: too few args at call site"
|
||||
(guard
|
||||
(e (true :raised))
|
||||
(kv-eval-src "(($vau (x y) _ x) 1)" (kv-make-env)))
|
||||
:raised)
|
||||
|
||||
(kv-test
|
||||
"vau: too many args at call site"
|
||||
(guard
|
||||
(e (true :raised))
|
||||
(kv-eval-src "(($vau (x) _ x) 1 2)" (kv-make-env)))
|
||||
:raised)
|
||||
|
||||
(kv-test
|
||||
"wrap: rejects non-operative"
|
||||
(guard (e (true :raised)) (kv-eval-src "(wrap 42)" (kv-make-env)))
|
||||
:raised)
|
||||
|
||||
(kv-test
|
||||
"unwrap: rejects non-applicative"
|
||||
(guard (e (true :raised)) (kv-eval-src "(unwrap 42)" (kv-make-env)))
|
||||
:raised)
|
||||
|
||||
(define kv-tests-run! (fn () {:total (+ kv-test-pass kv-test-fail) :passed kv-test-pass :failed kv-test-fail :fails kv-test-fails}))
|
||||
@@ -164,22 +164,13 @@ gets the same API for free.
|
||||
|
||||
## Rollout
|
||||
|
||||
**Phase 1: Tiered compilation — IMPLEMENTED (commit b9d63112)**
|
||||
- ✅ `l_call_count : int` field on lambda type (sx_types.ml)
|
||||
- ✅ Counter increment + threshold check in cek_call_or_suspend Lambda case (sx_vm.ml)
|
||||
- ✅ Module-level refs in sx_types: `jit_threshold` (default 4), `jit_compiled_count`,
|
||||
`jit_skipped_count`, `jit_threshold_skipped_count`. Refs live in sx_types so
|
||||
sx_primitives can read them without creating an import cycle.
|
||||
- ✅ Primitives: `jit-stats`, `jit-set-threshold!`, `jit-reset-counters!` (sx_primitives.ml)
|
||||
- Verified: 4771/1111 OCaml run_tests, identical to baseline — no regressions.
|
||||
|
||||
**WASM rollout note:** The native binary has Phase 1 active. The browser
|
||||
WASM (`shared/static/wasm/sx_browser.bc.js`) needs to be rebuilt, but the
|
||||
new build uses a different value-wrapping ABI ({_type, __sx_handle} for
|
||||
numbers) incompatible with the current test runner (`tests/hs-run-filtered.js`).
|
||||
For now the test tree pins the pre-rewrite WASM. Resolving the ABI gap
|
||||
is a separate task — either update the test runner to unwrap, or expose
|
||||
a value-marshalling helper from the kernel.
|
||||
**Phase 1: Tiered compilation (1-2 days)**
|
||||
- Add `l_call_count` to lambda type
|
||||
- Wire counter increment in `cek_call_or_suspend`
|
||||
- Add `jit-set-threshold!` primitive
|
||||
- Default threshold = 1 (no change in behavior)
|
||||
- Bump default to 4 once test suite confirms stability
|
||||
- Verify: HS conformance full-suite run completes without JIT saturation
|
||||
|
||||
**Phase 2: LRU cache (3-5 days)**
|
||||
- Extract `Lambda.l_compiled` into central `sx_jit_cache.ml`
|
||||
|
||||
@@ -56,23 +56,23 @@ The whole interesting thing: there are no special forms hardcoded in the evaluat
|
||||
## Roadmap
|
||||
|
||||
### Phase 1 — Parser
|
||||
- [ ] S-expression reader with the standard atoms (number, string, symbol, boolean, nil) and lists.
|
||||
- [x] S-expression reader with the standard atoms (number, string, symbol, boolean, nil) and lists.
|
||||
- [ ] Reader macros optional; defer to Phase 6.
|
||||
- [ ] Tests in `lib/kernel/tests/parse.sx`.
|
||||
- [x] Tests in `lib/kernel/tests/parse.sx`.
|
||||
|
||||
### Phase 2 — Core evaluator with first-class environments
|
||||
- [ ] `kernel-eval expr env` — primary entry, walks AST, threads env as a value.
|
||||
- [ ] Symbol lookup → environment value (using SX env-as-value primitives).
|
||||
- [ ] List → look up head, dispatch on tag (applicative vs operative).
|
||||
- [ ] No hardcoded special forms — even `if`/`define`/`lambda` are env-bound.
|
||||
- [ ] Tests in `lib/kernel/tests/eval.sx`.
|
||||
- [x] `kernel-eval expr env` — primary entry, walks AST, threads env as a value.
|
||||
- [x] Symbol lookup → environment value (using SX env-as-value primitives).
|
||||
- [x] List → look up head, dispatch on tag (applicative vs operative).
|
||||
- [x] No hardcoded special forms — even `if`/`define`/`lambda` are env-bound.
|
||||
- [x] Tests in `lib/kernel/tests/eval.sx`.
|
||||
|
||||
### Phase 3 — `$vau` / `$lambda` / `wrap` / `unwrap`
|
||||
- [ ] Operative tagged value: `{:type :operative :params :env-param :body :static-env}`.
|
||||
- [ ] Applicative tagged value wraps an operative + the "evaluate args first" contract.
|
||||
- [ ] `$vau` builds operatives; `$lambda` is `wrap` ∘ `$vau`.
|
||||
- [ ] `wrap` / `unwrap` round-trip cleanly.
|
||||
- [ ] Tests: define a custom operative, define a custom applicative on top of it.
|
||||
- [x] Operative tagged value: `{:type :operative :params :env-param :body :static-env}`.
|
||||
- [x] Applicative tagged value wraps an operative + the "evaluate args first" contract.
|
||||
- [x] `$vau` builds operatives; `$lambda` is `wrap` ∘ `$vau`.
|
||||
- [x] `wrap` / `unwrap` round-trip cleanly.
|
||||
- [x] Tests: define a custom operative, define a custom applicative on top of it.
|
||||
|
||||
### Phase 4 — Standard environment
|
||||
- [ ] Standard env construction: bind `$if`, `$define!`, `$lambda`, `$vau`, `wrap`, `unwrap`, `eval`, `make-environment`, `get-current-environment`, plus arithmetic and list primitives.
|
||||
@@ -100,6 +100,25 @@ The whole interesting thing: there are no special forms hardcoded in the evaluat
|
||||
|
||||
**May propose:** `lib/guest/reflective/` sub-layer — environment manipulation, evaluator-as-value, applicative/operative dispatch protocols.
|
||||
|
||||
**Proposed `lib/guest/reflective/combiner.sx` API** (from Phase 3 chiselling — pending second consumer):
|
||||
- `(refl-make-primitive-operative IMPL)` — IMPL receives `(args dyn-env)`, args unevaluated.
|
||||
- `(refl-make-user-operative PARAMS EPARAM BODY STATIC-ENV)` — for $vau-like constructors. The EPARAM sentinel for "ignore dyn-env" is a fixed keyword (`:refl-ignore` in the proposal).
|
||||
- `(refl-wrap OP)` / `(refl-unwrap APP)` — round-trip pair.
|
||||
- `(refl-operative? V)` / `(refl-applicative? V)` / `(refl-combiner? V)`.
|
||||
- `(refl-call-combiner COMBINER ARGS DYN-ENV)` — the dispatch fork. Pairs with `refl-eval` from the evaluator kit.
|
||||
- Representation: `{:refl-tag :operative :impl FN}` or `{:refl-tag :operative :params P :env-param EP :body B :static-env SE}`; applicatives are `{:refl-tag :applicative :underlying OP}`. The dispatch decision lives in one fork: presence of `:impl` is primitive, presence of `:body` is user-defined.
|
||||
- Driving insight: every reflective Lisp must distinguish "eval my args first" from "hand me the syntax". The tag protocol is identical across Kernel, CL fexprs, vau-style Schemes, possibly Forth's IMMEDIATE words.
|
||||
|
||||
**Proposed `lib/guest/reflective/env.sx` API** (from Phase 2 chiselling — pending second consumer per the two-consumer rule):
|
||||
- `(refl-make-env)` / `(refl-extend-env PARENT)` — fresh / chained envs, plain SX dicts so they're easy to introspect.
|
||||
- `(refl-env? V)` — predicate.
|
||||
- `(refl-env-bind! ENV NAME VAL)` — local bind; parent is untouched.
|
||||
- `(refl-env-has? ENV NAME)` — recursive presence check.
|
||||
- `(refl-env-lookup ENV NAME)` — recursive lookup, raises on miss.
|
||||
- Representation: `{:refl-tag :env :bindings DICT :parent ENV-OR-NIL}`. Pure-SX dicts so any guest can serialize, diff, snapshot, or rewind environments without help from the host.
|
||||
|
||||
The motivation is that SX's host `make-env` family is registered only in HTTP/site-mode platform setup, so a guest that needs first-class envs in CLI / test contexts has to roll its own anyway. A shared kit means the next reflective consumer (CL macro evaluator? metacircular Scheme?) doesn't need to redo the work.
|
||||
|
||||
**What it teaches:** whether SX's recent env-as-value direction generalises to "evaluator-as-value." If Kernel implements cleanly in <2000 lines, env-as-value is real. If it requires substrate fixes at every turn, env-as-value was incomplete and the substrate is telling us what's missing.
|
||||
|
||||
## References
|
||||
@@ -108,7 +127,10 @@ The whole interesting thing: there are no special forms hardcoded in the evaluat
|
||||
- Klisp implementation (Andres Navarro) — pragmatic reference.
|
||||
|
||||
## Progress log
|
||||
_(awaiting Phase 1 — depends on stable env-as-value substrate state)_
|
||||
|
||||
- 2026-05-11 — Phase 3 operatives landed. `lib/kernel/runtime.sx` adds `$vau` (primitive operative that returns a user operative), `$lambda` (sugar for `wrap ∘ $vau`), `wrap` and `unwrap` (Kernel-level applicatives), plus `operative?` and `applicative?` predicates. `kernel-base-env` wires them all into a fresh env. `kernel-eval.sx` now dispatches in `kernel-call-operative` between primitive ops (carry `:impl`) and user ops (carry `:params :env-param :body :static-env`). Parameter binding is a flat list — destructuring/`&rest` deferred. Env-param sentinel: spell `_` or `#ignore` → `:knl-ignore`, which skips the dyn-env bind. 34 tests in `tests/vau.sx`, including the headline custom-operative + custom-applicative composition. chisel: shapes-reflective. Two further reflective-API candidates surfaced: (a) the operative/applicative tag protocol — `make-primitive-operative`, `make-user-operative`, `wrap`, `unwrap` are general for any Lisp-of-fexprs; (b) the call-dispatch fork (primitive vs user) is a *single decision* that every reflective evaluator hits. Both shape go into the proposed `lib/guest/reflective/combiner.sx` candidate.
|
||||
- 2026-05-10 — Phase 2 evaluator landed. `lib/kernel/eval.sx` is `lookup-and-combine`: zero hardcoded special forms. `kernel-eval EXPR ENV` dispatches on shape — literals self-evaluate, Kernel strings unwrap, symbols lookup, lists evaluate head and combine. `kernel-combine` distinguishes operatives (impl receives un-evaluated args + dynamic env) from applicatives (eval args, recurse into underlying op). `kernel-wrap`/`kernel-unwrap` round-trip cleanly. 36 tests verify literal evaluation, symbol lookup with parent-chain shadowing, tagged-value predicates, and the operative-vs-applicative contract (notably `$if` only evaluates the chosen branch, `$quote` returns its arg unevaluated). chisel: shapes-reflective. Substrate gap surfaced: SX's `make-env` / `env-bind!` family is only registered in HTTP/site mode (`http_setup_platform_constructors`), not in CLI epoch mode used for tests. So Kernel envs are modelled in pure SX as `{:knl-tag :env :bindings DICT :parent P}` — a binding-dict + parent-pointer + recursive lookup walk. This is exactly the `lib/guest/reflective/env.sx` candidate API: any reflective language needs first-class env values that can be extended, queried, and walked. Recording the shape (constructor, extend, bind!, has?, lookup) here for the eventual Phase 7 extraction.
|
||||
- 2026-05-10 — Phase 1 parser landed. `lib/kernel/parser.sx` reads R-1RK lexical syntax: numbers (int/float/exp), strings (with escapes), symbols (permissive — anything non-delimiting), booleans `#t`/`#f`, the empty list `()`, nested lists, and `;` line comments. Reader macros (`'` `,` `,@`) deferred per plan. AST: numbers/booleans/lists pass through; strings are wrapped as `{:knl-string …}` to distinguish from symbols which are bare SX strings. 54 tests in `lib/kernel/tests/parse.sx` pass via `sx_server.exe` epoch protocol. chisel: consumes-lex (uses `lex-digit?` and `lex-whitespace?` from `lib/guest/lex.sx` — pratt deliberately not consumed because Kernel is plain s-expressions, no precedence climbing).
|
||||
|
||||
## Blockers
|
||||
_(none yet — main risk is substrate gap discovery during Phase 2)_
|
||||
|
||||
@@ -1,216 +0,0 @@
|
||||
# miniKanren-on-SX: deferred work
|
||||
|
||||
The main plan (`plans/minikanren-on-sx.md`) carries Phases 1–7 through the
|
||||
naive-tabling milestone. This file collects the four pieces left on the
|
||||
shelf, with enough scope and design notes to drive a follow-up loop.
|
||||
|
||||
Branch convention: keep the same `loops/minikanren` worktree; commit and
|
||||
push to `origin/loops/minikanren`. Squash-merge to `architecture` only
|
||||
when each numbered piece is shipped + tests green.
|
||||
|
||||
Cumulative test count snapshot at squash-merge: **644** across
|
||||
**71 test files**. Every change below should grow the number, not break
|
||||
existing tests.
|
||||
|
||||
## The four pieces
|
||||
|
||||
### Piece A — Phase 7 SLG (cyclic patho, mutual recursion, fixed-point iteration)
|
||||
|
||||
**Problem.** Naive tabling drains the answer stream eagerly, then caches.
|
||||
Recursive tabled calls with the SAME ground key see an empty cache (the
|
||||
in-progress entry never exists), so they recurse and the host
|
||||
overflows. Fibonacci works only because each recursive call has a
|
||||
*different* key; cyclic `patho` and any genuinely self-recursive tabled
|
||||
predicate diverge.
|
||||
|
||||
**Approach** — a small subset of SLG / OLDT resolution, enough to handle
|
||||
the demos in the brief.
|
||||
|
||||
1. **In-progress sentinel.** When a tabled call `T(args)` starts, store
|
||||
`(:in-progress nil)` under its key. Recursive calls into `T(args)`
|
||||
from inside its own computation see the sentinel and return only
|
||||
the answers accumulated so far (initially empty).
|
||||
2. **Answer accumulator.** As each new answer is found, push it into
|
||||
the cache entry: `(:in-progress accumulated-answers)`. After a
|
||||
cycling caller returns, the outer continuation can re-consult the
|
||||
updated cache.
|
||||
3. **Fixed-point iteration.** The driver repeatedly re-runs the goal
|
||||
until no new answers appear in a full pass, then transitions the
|
||||
cache from `:in-progress` to `:done`.
|
||||
4. **Subgoal table.** Track (subgoal, last-seen-cache-version) per
|
||||
subscriber so each consumer only re-reads what it hasn't seen.
|
||||
|
||||
**Suggested artefacts.**
|
||||
- `lib/minikanren/tabling-slg.sx` — new module with `table-slg-2`
|
||||
(parallel to `table-2` from naive tabling). Keep `table-2` working
|
||||
unchanged so Fibonacci/Ackermann don't regress.
|
||||
- `lib/minikanren/tests/cyclic-graph-tabled.sx` — the canonical demo:
|
||||
two-cycle `patho` from a→b→a→b plus a→b→c. With SLG, `(run* q
|
||||
(tab-patho :a :c q))` returns the single shortest path, not divergence.
|
||||
- `lib/minikanren/tests/mutual-recursion.sx` — even/odd via mutual
|
||||
recursion (`even-o n` ↔ `odd-o (n-1)`), tabled at both names.
|
||||
|
||||
**Reference reading.**
|
||||
- TRS chapter on tabling.
|
||||
- "Tabled Logic Programming" — Sagonas & Swift (the XSB / SLG paper).
|
||||
- core.logic's `tabled` macro for an SX-dialect-friendly precedent.
|
||||
|
||||
**Risk.** This is the brief's "research-grade complexity, not a
|
||||
one-iteration item". Plan for 4–6 commits: in-progress sentinel,
|
||||
answer accumulator, fixed-point driver, then one demo per commit.
|
||||
|
||||
### Piece B — Phase 6 polish: bounds-consistency for `fd-plus` / `fd-times`
|
||||
|
||||
**Problem.** Current `fd-plus-prop` and `fd-times-prop` propagate only
|
||||
when two of three operands walk to ground numbers. When all three are
|
||||
domain-bounded vars, the propagator returns `s` unchanged — search has
|
||||
to label down to ground before any narrowing happens.
|
||||
|
||||
**Approach** — narrow domains via interval reasoning even when no operand
|
||||
is ground.
|
||||
|
||||
For `(fd-plus x y z)` with bounded x, y, z:
|
||||
- `x ∈ [z.min − y.max .. z.max − y.min]`
|
||||
- `y ∈ [z.min − x.max .. z.max − x.min]`
|
||||
- `z ∈ [x.min + y.min .. x.max + y.max]`
|
||||
|
||||
For `(fd-times x y z)`: same shape, but with multiplication; need to
|
||||
handle sign cases (negative domain ranges) and the divisor-when-not-zero
|
||||
constraint already in place.
|
||||
|
||||
**Suggested artefacts.**
|
||||
- Patch `fd-plus-prop` and `fd-times-prop` in `lib/minikanren/clpfd.sx`
|
||||
with new `:else` branches that compute new domain bounds and call
|
||||
`fd-set-domain` for each var.
|
||||
- New tests in `lib/minikanren/tests/clpfd-plus.sx` /
|
||||
`clpfd-times.sx` exercising the all-domain case: two domain-bounded
|
||||
vars in the body of a goal, with no labelling, after which their
|
||||
domains have narrowed.
|
||||
- A demo: cryptarithmetic puzzle (see Piece D) using bounds
|
||||
consistency to avoid labelling explosion.
|
||||
|
||||
**Risk.** Low. The math is well-known; just careful min/max arithmetic
|
||||
and watch for edge cases (empty domain after narrowing).
|
||||
|
||||
### Piece C — `=/=` disequality with constraint store
|
||||
|
||||
**Problem.** `nafc` is sound only on ground args; `fd-neq` only on FD
|
||||
domains. There is no general-purpose Prolog-style structural
|
||||
disequality `=/=` that works on logic terms.
|
||||
|
||||
**Approach.** Generalise the FD constraint store to a uniform
|
||||
"constraint store" that carries:
|
||||
- domain map (existing)
|
||||
- *pending disequalities* — a list of `(u v)` pairs that must remain
|
||||
non-unifiable under any future extension.
|
||||
|
||||
After every `==` / `mk-unify`, re-check each pending disequality:
|
||||
- If `(u v)` are now unifiable, fail.
|
||||
- If they're now structurally distinct (no shared substitution can
|
||||
unify), drop from the store (the constraint is satisfied).
|
||||
- Otherwise leave in store.
|
||||
|
||||
**Where it bites.** The kernel currently uses `mk-unify` everywhere.
|
||||
Either:
|
||||
1. Replace `mk-unify` with a constraint-aware wrapper everywhere
|
||||
(intrusive, but principled).
|
||||
2. Keep `mk-unify` for goals that don't use `=/=`, and provide a
|
||||
parallel `==-cs` / `=/=-cs` pair plus an alternative `run*-cs`
|
||||
driver that fires the constraint check after each binding.
|
||||
|
||||
Option 2 mirrors the `fd-fire-store` pattern and stays out of the
|
||||
common path.
|
||||
|
||||
**Suggested artefacts.**
|
||||
- `lib/minikanren/diseq.sx` — disequality store on top of the
|
||||
existing `_fd` reserved key (re-using the constraint list, just
|
||||
with disequality-shaped closures instead of FD propagators).
|
||||
- `=/=` goal that posts a disequality and immediately checks it.
|
||||
- `=/=-test` integration: rewrite a few Phase 5 puzzles using `=/=`
|
||||
instead of `nafc + ==`.
|
||||
- Tests covering: ground-pair fail, partial-pair satisfied later by
|
||||
binding, partial-pair *contradicted* later by binding.
|
||||
|
||||
**Risk.** Medium. The hard cases are *eventual* unifiability — a
|
||||
disequality `(=/= (cons a 1) (cons 2 b))` should hold until both `a`
|
||||
gets bound to `2` and `b` gets bound to `1`. Implementations like
|
||||
core.logic's encode this as a list of "violating bindings" the
|
||||
disequality remembers.
|
||||
|
||||
### Piece D — Bigger CLP(FD) demos: send-more-money + Sudoku 4×4
|
||||
|
||||
**Problem.** The current N-queens demo only verifies the constraint
|
||||
chain end-to-end. The brief's full Phase 6 list includes
|
||||
"send-more-money, N-queens with CLP(FD), map coloring,
|
||||
cryptarithmetic" — most of which exercise *more* than just `fd-neq +
|
||||
fd-distinct`.
|
||||
|
||||
**Approach.** Two concrete puzzles that both stress
|
||||
bounds-consistency (Piece B) once it lands:
|
||||
|
||||
#### send-more-money
|
||||
|
||||
```
|
||||
S E N D
|
||||
+ M O R E
|
||||
---------
|
||||
M O N E Y
|
||||
```
|
||||
|
||||
8 distinct digits ∈ {0..9}, S ≠ 0, M ≠ 0. Encoded as a sum-of-digits
|
||||
equation using `fd-plus` + carry chains.
|
||||
|
||||
Without Piece B (bounds-consistency), the search labels every digit
|
||||
combination upfront — slow but tractable on a fast machine. With
|
||||
Piece B, the impossible high-digit cases prune early.
|
||||
|
||||
Test: a single solution `(9 5 6 7 1 0 8 2)`.
|
||||
|
||||
#### Sudoku 4×4
|
||||
|
||||
Easier than 9×9 but exercises the full pattern:
|
||||
- 16 cells, each ∈ {1..4}
|
||||
- 4 rows, 4 cols, 4 2×2 boxes — 12 `fd-distinct` constraints
|
||||
- Some cells fixed as clues
|
||||
|
||||
A small solver should handle 4×4 in well under a second once
|
||||
bounds-consistency narrows columns / boxes after each label step.
|
||||
|
||||
**Suggested artefacts.**
|
||||
- `lib/minikanren/tests/send-more-money.sx` — single-solution test.
|
||||
- `lib/minikanren/tests/sudoku-4x4.sx` — at least three cluesets:
|
||||
unique solution, multiple solutions, no solution.
|
||||
- Optional: `lib/minikanren/sudoku.sx` with a parameterised
|
||||
`sudoku-n` for both 4×4 and a 9×9 stress test.
|
||||
|
||||
**Risk.** Low–medium for 4×4 + send-more-money once Piece B lands.
|
||||
9×9 Sudoku is a stretch; treat it as a stretch goal once the smaller
|
||||
demos are green.
|
||||
|
||||
## Suggested ordering
|
||||
|
||||
1. **Piece B first** (bounds-consistency for `fd-plus` / `fd-times`).
|
||||
Self-contained, low-risk, and unlocks Piece D's harder puzzles.
|
||||
2. **Piece D** (the two demos). Validates Piece B with concrete
|
||||
puzzles. Doubles as the brief's missing canary tests.
|
||||
3. **Piece C** (`=/=`). Independent track; once shipped, refactor the
|
||||
pet/diff puzzles in Phase 5 to use it instead of nafc.
|
||||
4. **Piece A** (SLG tabling). Last because it's the highest-risk
|
||||
piece; do it when the rest of the library is stable so regressions
|
||||
are easy to spot.
|
||||
|
||||
## Operating ground rules (carry over from the original brief)
|
||||
|
||||
- **Scope:** `lib/minikanren/**` and the two plan files (this one and
|
||||
the original).
|
||||
- **Commit cadence:** one feature per commit. Short factual messages
|
||||
(`mk: piece B — bounds-consistency for fd-plus`).
|
||||
- **Plan updates:** tick boxes here as pieces land; mirror status in
|
||||
`plans/minikanren-on-sx.md` Roadmap.
|
||||
- **Test discipline:** every commit ends with the cumulative count
|
||||
green. No-regression rule from the original brief still applies.
|
||||
- **`sx-tree` MCP only** for `.sx` edits. `sx_validate` after every
|
||||
structural edit.
|
||||
- **Pushing:** `origin/loops/minikanren` only. Never `main`. Squash to
|
||||
`architecture` only with explicit user permission, as we did for
|
||||
the v1 merge.
|
||||
Reference in New Issue
Block a user