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")