diff --git a/lib/guest/reflective/env.sx b/lib/guest/reflective/env.sx new file mode 100644 index 00000000..b83aba28 --- /dev/null +++ b/lib/guest/reflective/env.sx @@ -0,0 +1,138 @@ +;; lib/guest/reflective/env.sx — first-class environment kit. +;; +;; Extracted from Kernel-on-SX (lib/kernel/eval.sx) when Tcl's +;; uplevel/upvar machinery (lib/tcl/runtime.sx) materialised as a +;; second consumer needing the same scope-chain semantics. +;; +;; Canonical wire shape +;; -------------------- +;; {:refl-tag :env :bindings DICT :parent ENV-OR-NIL} +;; +;; - :bindings is a mutable SX dict keyed by symbol name. +;; - :parent is either another env or nil (root). +;; - Lookup walks the parent chain until a hit or nil. +;; - Default cfg uses dict-set! to mutate bindings in place. +;; +;; Consumers with their own shape (e.g., Tcl's {:level :locals :parent}) +;; pass an adapter cfg dict — same trick as lib/guest/match.sx's cfg +;; for unification over guest-specific term shapes. +;; +;; Adapter cfg keys +;; ---------------- +;; :bindings-of — fn (scope) → DICT +;; :parent-of — fn (scope) → SCOPE-OR-NIL +;; :extend — fn (scope) → SCOPE (push a fresh child) +;; :bind! — fn (scope name val) → scope (functional or mutable) +;; :env? — fn (v) → bool (predicate; cheap shape check) +;; +;; Public API — canonical shape, mutable, raises on miss +;; +;; (refl-make-env) +;; (refl-extend-env PARENT) +;; (refl-env? V) +;; (refl-env-bind! ENV NAME VAL) +;; (refl-env-has? ENV NAME) +;; (refl-env-lookup ENV NAME) +;; (refl-env-lookup-or-nil ENV NAME) +;; +;; Public API — adapter-cfg, any shape +;; +;; (refl-env-extend-with CFG SCOPE) +;; (refl-env-bind!-with CFG SCOPE NAME VAL) +;; (refl-env-has?-with CFG SCOPE NAME) +;; (refl-env-lookup-with CFG SCOPE NAME) +;; (refl-env-lookup-or-nil-with CFG SCOPE NAME) +;; +;; (refl-canonical-cfg) — the default cfg, exposed so consumers +;; can compare or extend it. + +;; ── Canonical-shape predicates and constructors ───────────────── + +(define refl-env? (fn (v) (and (dict? v) (= (get v :refl-tag) :env)))) + +(define refl-make-env (fn () {:parent nil :refl-tag :env :bindings {}})) + +(define refl-extend-env (fn (parent) {:parent parent :refl-tag :env :bindings {}})) + +(define + refl-env-bind! + (fn (env name val) (dict-set! (get env :bindings) name val) env)) + +(define + refl-env-has? + (fn + (env name) + (cond + ((nil? env) false) + ((not (refl-env? env)) false) + ((dict-has? (get env :bindings) name) true) + (:else (refl-env-has? (get env :parent) name))))) + +(define + refl-env-lookup + (fn + (env name) + (cond + ((nil? env) (error (str "refl-env-lookup: unbound symbol: " name))) + ((not (refl-env? env)) + (error (str "refl-env-lookup: corrupt env: " env))) + ((dict-has? (get env :bindings) name) (get (get env :bindings) name)) + (:else (refl-env-lookup (get env :parent) name))))) + +(define + refl-env-lookup-or-nil + (fn + (env name) + (cond + ((nil? env) nil) + ((not (refl-env? env)) nil) + ((dict-has? (get env :bindings) name) (get (get env :bindings) name)) + (:else (refl-env-lookup-or-nil (get env :parent) name))))) + +;; ── Adapter-cfg variants — any wire shape ─────────────────────── + +(define refl-env-extend-with (fn (cfg scope) ((get cfg :extend) scope))) + +(define + refl-env-bind!-with + (fn (cfg scope name val) ((get cfg :bind!) scope name val))) + +(define + refl-env-has?-with + (fn + (cfg scope name) + (cond + ((nil? scope) false) + ((not ((get cfg :env?) scope)) false) + ((dict-has? ((get cfg :bindings-of) scope) name) true) + (:else (refl-env-has?-with cfg ((get cfg :parent-of) scope) name))))) + +(define + refl-env-lookup-with + (fn + (cfg scope name) + (cond + ((nil? scope) (error (str "refl-env-lookup: unbound symbol: " name))) + ((not ((get cfg :env?) scope)) + (error (str "refl-env-lookup: corrupt scope: " scope))) + ((dict-has? ((get cfg :bindings-of) scope) name) + (get ((get cfg :bindings-of) scope) name)) + (:else (refl-env-lookup-with cfg ((get cfg :parent-of) scope) name))))) + +(define + refl-env-lookup-or-nil-with + (fn + (cfg scope name) + (cond + ((nil? scope) nil) + ((not ((get cfg :env?) scope)) nil) + ((dict-has? ((get cfg :bindings-of) scope) name) + (get ((get cfg :bindings-of) scope) name)) + (:else + (refl-env-lookup-or-nil-with cfg ((get cfg :parent-of) scope) name))))) + +;; ── Default canonical cfg ─────────────────────────────────────── +;; Exposed so consumers can use it explicitly, compose with it, or +;; check adapter-correctness against the canonical implementation. + +(define refl-canonical-cfg {:bind! (fn (e n v) (refl-env-bind! e n v)) :parent-of (fn (e) (get e :parent)) :env? (fn (v) (refl-env? v)) :bindings-of (fn (e) (get e :bindings)) :extend (fn (e) (refl-extend-env e))}) diff --git a/lib/kernel/eval.sx b/lib/kernel/eval.sx index 99a78a88..276c5c08 100644 --- a/lib/kernel/eval.sx +++ b/lib/kernel/eval.sx @@ -7,9 +7,11 @@ ;; ;; Tagged values ;; ------------- -;; {:knl-tag :env :bindings DICT :parent PARENT-OR-NIL} +;; {:refl-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. +;; keyed by symbol name; parent walks up the lookup chain. Shape +;; and operations are inherited from lib/guest/reflective/env.sx +;; (canonical wire shape) — Kernel-side names are thin wrappers. ;; ;; {:knl-tag :operative :impl FN} ;; Primitive operative. FN receives (args dyn-env) — args are the @@ -42,38 +44,16 @@ ;; ;; Consumes: lib/kernel/parser.sx (kernel-string?, kernel-string-value) -;; ── Environments — first-class, pure-SX (binding dict + parent) ── +;; ── Environments — delegated to lib/guest/reflective/env.sx ────── +;; The env values themselves now carry `:refl-tag :env` (shared with the +;; reflective kit). Kernel's API names stay; bodies are thin wrappers. -(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))))) +(define kernel-env? refl-env?) +(define kernel-make-env refl-make-env) +(define kernel-extend-env refl-extend-env) +(define kernel-env-bind! refl-env-bind!) +(define kernel-env-has? refl-env-has?) +(define kernel-env-lookup refl-env-lookup) ;; ── Tagged-value constructors and predicates ─────────────────────