giles
2e7e3141d4
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 56s
Phase 1 of the lib-guest-reflective extraction plan.
lib/guest/reflective/env.sx — canonical wire shape
{:refl-tag :env :bindings DICT :parent ENV-OR-NIL} with mutable
defaults (dict-set!), plus *-with adapter-cfg variants for consumers
with their own shape (modelled after lib/guest/match.sx). 13 forms,
~5 KB.
lib/kernel/eval.sx — env block collapses from ~30 lines to 6 thin
wrappers (kernel-env? = refl-env?, etc.). No semantic change; envs
now carry :refl-tag :env instead of :knl-tag :env. All 322 Kernel
tests pass unchanged across 7 suites (parse 62, eval 36, vau 38,
standard 127, encap 19, hygiene 26, metacircular 14).
Next: Phase 2 — Tcl adapter cfg in lib/tcl/runtime.sx using
refl-env-lookup-with against the existing :level/:locals/:parent
frame shape.
139 lines
4.8 KiB
Plaintext
139 lines
4.8 KiB
Plaintext
;; 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))})
|