From 9efbf4ad380ab1835e8e1f6723e367b55149675c Mon Sep 17 00:00:00 2001 From: giles Date: Tue, 12 May 2026 15:19:19 +0000 Subject: [PATCH] =?UTF-8?q?reflective:=20third=20consumer=20=E2=80=94=20Sm?= =?UTF-8?q?alltalk=20frame=20adopts=20env.sx=20=E2=80=94=20847+322+427=20t?= =?UTF-8?q?ests=20green?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit lib/guest/reflective/env.sx — added refl-env-find-frame-with (returns the scope where NAME is bound, or nil). Needed by consumers like Smalltalk that mutate variables at the source frame rather than shadowing at the current one. Also added refl-env-find-frame for the canonical shape. lib/smalltalk/eval.sx — new st-frame-cfg adapter for the kit. st-lookup-local now delegates parent-walk to refl-env-find-frame-with while preserving its Smalltalk-flavoured {:found :value :frame} return shape (which is used to mutate at the binding's source frame, not the current one). lib/smalltalk/test.sh + compare.sh — load lib/guest/reflective/env.sx before lib/smalltalk/eval.sx. Three genuinely different wire shapes now share the parent-walk: - Kernel: {:refl-tag :env :bindings :parent} mutable bindings - Tcl: {:level :locals :parent} functional update - Smalltalk: {:self :method-class :locals :parent mutable bindings, :return-k :active-cell} rich metadata All three consumers' full test suites unchanged: Smalltalk 847/847, Kernel 322/322, Tcl 427/427. The cfg adapter pattern (modelled after lib/guest/match.sx) cleanly handles all three. --- lib/guest/reflective/env.sx | 21 +++++++++++++++++++++ lib/smalltalk/compare.sh | 1 + lib/smalltalk/eval.sx | 30 ++++++++++++++++++++++++------ lib/smalltalk/test.sh | 2 ++ 4 files changed, 48 insertions(+), 6 deletions(-) diff --git a/lib/guest/reflective/env.sx b/lib/guest/reflective/env.sx index b83aba28..595f80fe 100644 --- a/lib/guest/reflective/env.sx +++ b/lib/guest/reflective/env.sx @@ -42,6 +42,9 @@ ;; (refl-env-has?-with CFG SCOPE NAME) ;; (refl-env-lookup-with CFG SCOPE NAME) ;; (refl-env-lookup-or-nil-with CFG SCOPE NAME) +;; (refl-env-find-frame-with CFG SCOPE NAME) +;; — returns the scope in the chain that contains NAME (or nil). +;; Consumers needing source-frame mutation use this. ;; ;; (refl-canonical-cfg) — the default cfg, exposed so consumers ;; can compare or extend it. @@ -131,6 +134,24 @@ (:else (refl-env-lookup-or-nil-with cfg ((get cfg :parent-of) scope) name))))) +;; Returns the SCOPE in the chain that contains NAME, or nil if no +;; scope binds it. Consumers (e.g. Smalltalk) use this to mutate the +;; binding at its source frame rather than introducing a new shadow +;; binding at the current frame. Pairs with `refl-env-lookup-with` +;; for callers that need both the value and the defining scope. + +(define refl-env-find-frame-with + (fn (cfg scope name) + (cond + ((nil? scope) nil) + ((not ((get cfg :env?) scope)) nil) + ((dict-has? ((get cfg :bindings-of) scope) name) scope) + (:else + (refl-env-find-frame-with cfg ((get cfg :parent-of) scope) name))))) + +(define refl-env-find-frame + (fn (env name) (refl-env-find-frame-with refl-canonical-cfg env name))) + ;; ── Default canonical cfg ─────────────────────────────────────── ;; Exposed so consumers can use it explicitly, compose with it, or ;; check adapter-correctness against the canonical implementation. diff --git a/lib/smalltalk/compare.sh b/lib/smalltalk/compare.sh index d28c883a..1db73b6d 100755 --- a/lib/smalltalk/compare.sh +++ b/lib/smalltalk/compare.sh @@ -41,6 +41,7 @@ run_sx () { (load "lib/smalltalk/tokenizer.sx") (load "lib/smalltalk/parser.sx") (load "lib/smalltalk/runtime.sx") +(load "lib/guest/reflective/env.sx") (load "lib/smalltalk/eval.sx") (epoch 2) (eval "(begin (st-bootstrap-classes!) (smalltalk-load \"Object subclass: #B instanceVariableNames: ''! !B methodsFor: 'x'! fib: n n < 2 ifTrue: [^ n]. ^ (self fib: n - 1) + (self fib: n - 2)! !\") (smalltalk-eval-program \"^ B new fib: 22\"))") diff --git a/lib/smalltalk/eval.sx b/lib/smalltalk/eval.sx index 500ae5a3..9c049566 100644 --- a/lib/smalltalk/eval.sx +++ b/lib/smalltalk/eval.sx @@ -60,16 +60,34 @@ st-class-ref? (fn (v) (and (dict? v) (has-key? v :type) (= (get v :type) "st-class")))) -;; Walk the frame chain looking for a local binding. +;; Smalltalk-side adapter for lib/guest/reflective/env.sx. The +;; Smalltalk frame carries language-specific metadata (:self, +;; :method-class, :return-k, :active-cell) but the parent-walk for +;; local-binding lookup is the same algorithm Kernel and Tcl use. +;; Third consumer of the env kit; cfg routes through :locals and +;; :parent and uses mutable dict-set! for binding. +(define st-frame-cfg + {:bindings-of (fn (f) (get f :locals)) + :parent-of (fn (f) (get f :parent)) + :extend (fn (f) (st-make-frame nil nil f nil nil)) + :bind! (fn (f n v) + (dict-set! (get f :locals) n v) f) + :env? (fn (v) (and (dict? v) (dict? (get v :locals))))}) + +;; Walk the frame chain looking for a local binding. Returns the +;; Smalltalk-flavoured {:found :value :frame} shape callers expect; +;; the parent-walk delegates to refl-env-find-frame-with. (define st-lookup-local (fn (frame name) - (cond - ((= frame nil) {:found false :value nil :frame nil}) - ((has-key? (get frame :locals) name) - {:found true :value (get (get frame :locals) name) :frame frame}) - (else (st-lookup-local (get frame :parent) name))))) + (let ((src (refl-env-find-frame-with st-frame-cfg frame name))) + (cond + ((nil? src) {:found false :value nil :frame nil}) + (:else + {:found true + :value (get (get src :locals) name) + :frame src}))))) ;; Walk the frame chain looking for the frame whose self has this ivar. (define diff --git a/lib/smalltalk/test.sh b/lib/smalltalk/test.sh index ce782993..45d5b905 100755 --- a/lib/smalltalk/test.sh +++ b/lib/smalltalk/test.sh @@ -61,6 +61,7 @@ EPOCHS (epoch 3) (load "lib/smalltalk/runtime.sx") (epoch 4) +(load "lib/guest/reflective/env.sx") (load "lib/smalltalk/eval.sx") (epoch 5) (load "lib/smalltalk/sunit.sx") @@ -116,6 +117,7 @@ EPOCHS (epoch 3) (load "lib/smalltalk/runtime.sx") (epoch 4) +(load "lib/guest/reflective/env.sx") (load "lib/smalltalk/eval.sx") (epoch 5) (load "lib/smalltalk/sunit.sx")