From 2981a479e86ae3f25ef8ee0249eaeda5c002dfa3 Mon Sep 17 00:00:00 2001 From: giles Date: Tue, 12 May 2026 21:09:07 +0000 Subject: [PATCH 1/2] =?UTF-8?q?reflective:=20extract=20class-chain.sx=20?= =?UTF-8?q?=E2=80=94=20Smalltalk=20+=20CLOS=20method=20dispatch=20share=20?= =?UTF-8?q?parent-walk?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit lib/guest/reflective/class-chain.sx — class inheritance walker with adapter cfg for single-parent (Smalltalk) and multi-parent (CLOS) hierarchies. Three primitives: - refl-class-chain-find-with CFG CN PROBE DFS through parents, returns first non-nil probe result. Smalltalk method lookup uses this. - refl-class-chain-depth-with CFG CN ANCESTOR Min hop distance via any parent path, or nil if unreachable. CLOS method specificity uses this. - refl-class-chain-ancestors-with CFG CN Flat DFS-ordered list of all reachable ancestor names. Adapter cfg has two keys: :parents-of (CN → list of parent names, possibly empty) and :class? (predicate; short-circuits walk on non-existent class names mid-chain). Migrations: - lib/smalltalk/runtime.sx: st-method-lookup-walk now a 9-line thin probe through the kit (was 20 lines of inline recursion); st-class-cfg wraps the single-parent :superclass field into a 1-element list for the cfg. - lib/common-lisp/clos.sx: clos-specificity is a one-line wrapper around refl-class-chain-depth-with (was 28 lines); clos-class-cfg reads the multi-parent :parents field. Both consumers green: - Smalltalk: 847/847 (unchanged) - CL: 222/240 (unchanged baseline; 18 pre-existing failures, all in stdlib functions like cl-set-memberp, unrelated to CLOS). This is the second extracted reflective kit (env.sx was first). The adapter-cfg pattern continues to bridge structurally divergent consumers (Smalltalk single-inheritance vs CLOS multiple-inheritance with method-precedence distance) via a uniform :parents-of callback. --- lib/common-lisp/clos.sx | 47 ++++------ lib/common-lisp/test.sh | 4 +- lib/guest/reflective/class-chain.sx | 129 ++++++++++++++++++++++++++++ lib/smalltalk/compare.sh | 1 + lib/smalltalk/runtime.sx | 47 +++++----- lib/smalltalk/test.sh | 2 + 6 files changed, 177 insertions(+), 53 deletions(-) create mode 100644 lib/guest/reflective/class-chain.sx diff --git a/lib/common-lisp/clos.sx b/lib/common-lisp/clos.sx index 78381ba2..79af197a 100644 --- a/lib/common-lisp/clos.sx +++ b/lib/common-lisp/clos.sx @@ -330,37 +330,22 @@ false)))))) (check-all 0))))) -;; Precedence distance: how far class-name is from spec-name up the hierarchy. -(define - clos-specificity - (let - ((registry clos-class-registry)) - (fn - (class-name spec-name) - (define - walk - (fn - (cn depth) - (if - (= cn spec-name) - depth - (let - ((rec (get registry cn))) - (if - (nil? rec) - nil - (let - ((results (map (fn (p) (walk p (+ depth 1))) (get rec "parents")))) - (let - ((non-nil (filter (fn (x) (not (nil? x))) results))) - (if - (empty? non-nil) - nil - (reduce - (fn (a b) (if (< a b) a b)) - (first non-nil) - (rest non-nil)))))))))) - (walk class-name 0)))) +;; CLOS-side adapter for lib/guest/reflective/class-chain.sx. Classes +;; live in clos-class-registry; :parents is a list of parent class +;; names (CLOS supports multiple inheritance). +(define clos-class-cfg + {:parents-of (fn (cn) + (let ((rec (clos-find-class cn))) + (cond ((nil? rec) (list)) + (:else (or (get rec "parents") (list)))))) + :class? (fn (n) (not (nil? (clos-find-class n))))}) + +;; Precedence distance: how far class-name is from spec-name up the +;; hierarchy. Delegates to refl-class-chain-depth-with which handles +;; the multi-parent DFS with min-depth selection. +(define clos-specificity + (fn (class-name spec-name) + (refl-class-chain-depth-with clos-class-cfg class-name spec-name))) (define clos-method-more-specific? diff --git a/lib/common-lisp/test.sh b/lib/common-lisp/test.sh index cffa2a38..aa0135d3 100755 --- a/lib/common-lisp/test.sh +++ b/lib/common-lisp/test.sh @@ -368,7 +368,7 @@ run_program_suite \ # ── Phase 4: CLOS unit tests ───────────────────────────────────────────────── CLOS_FILE=$(mktemp); trap "rm -f $CLOS_FILE" EXIT -printf '(epoch 1)\n(load "spec/stdlib.sx")\n(epoch 2)\n(load "lib/common-lisp/runtime.sx")\n(epoch 3)\n(load "lib/common-lisp/clos.sx")\n(epoch 4)\n(load "lib/common-lisp/tests/clos.sx")\n(epoch 5)\n(eval "passed")\n(epoch 6)\n(eval "failed")\n(epoch 7)\n(eval "failures")\n' > "$CLOS_FILE" +printf '(epoch 1)\n(load "spec/stdlib.sx")\n(epoch 2)\n(load "lib/common-lisp/runtime.sx")\n(epoch 3)\n(load "lib/guest/reflective/class-chain.sx")\n(load "lib/common-lisp/clos.sx")\n(epoch 4)\n(load "lib/common-lisp/tests/clos.sx")\n(epoch 5)\n(eval "passed")\n(epoch 6)\n(eval "failed")\n(epoch 7)\n(eval "failures")\n' > "$CLOS_FILE" CLOS_OUT=$(timeout 30 "$SX_SERVER" < "$CLOS_FILE" 2>/dev/null) rm -f "$CLOS_FILE" CLOS_PASSED=$(echo "$CLOS_OUT" | grep -A1 "^(ok-len 5 " | tail -1 || true) @@ -389,7 +389,7 @@ fi run_clos_suite() { local prog="$1" pass_var="$2" fail_var="$3" failures_var="$4" local PROG_FILE=$(mktemp) - printf '(epoch 1)\n(load "spec/stdlib.sx")\n(epoch 2)\n(load "lib/common-lisp/runtime.sx")\n(epoch 3)\n(load "lib/common-lisp/clos.sx")\n(epoch 4)\n(load "%s")\n(epoch 5)\n(eval "%s")\n(epoch 6)\n(eval "%s")\n(epoch 7)\n(eval "%s")\n' \ + printf '(epoch 1)\n(load "spec/stdlib.sx")\n(epoch 2)\n(load "lib/common-lisp/runtime.sx")\n(epoch 3)\n(load "lib/guest/reflective/class-chain.sx")\n(load "lib/common-lisp/clos.sx")\n(epoch 4)\n(load "%s")\n(epoch 5)\n(eval "%s")\n(epoch 6)\n(eval "%s")\n(epoch 7)\n(eval "%s")\n' \ "$prog" "$pass_var" "$fail_var" "$failures_var" > "$PROG_FILE" local OUT; OUT=$(timeout 20 "$SX_SERVER" < "$PROG_FILE" 2>/dev/null) rm -f "$PROG_FILE" diff --git a/lib/guest/reflective/class-chain.sx b/lib/guest/reflective/class-chain.sx new file mode 100644 index 00000000..26d696cd --- /dev/null +++ b/lib/guest/reflective/class-chain.sx @@ -0,0 +1,129 @@ +;; lib/guest/reflective/class-chain.sx — class inheritance walker. +;; +;; Extracted from Smalltalk's `st-method-lookup-walk` (single-parent +;; class chain for message-send dispatch) and CLOS's `clos-specificity` +;; (multi-parent class graph for method-precedence distance). Both walk +;; a class-name → parent-name(s) graph applying a probe at each node; +;; the cfg adapter normalises single-parent and multi-parent classes +;; into a uniform `:parents-of` callback that returns a (possibly +;; empty) list of parent class names. +;; +;; Adapter cfg +;; ----------- +;; :parents-of — fn (class-name) → list of parent class names. +;; Empty list = no parents (root). Single-parent guests +;; return a 1-element list; multi-parent guests (CLOS) +;; may return any number. +;; :class? — fn (name) → bool. False short-circuits the walk — +;; used to skip non-existent class names mid-chain. +;; +;; Public API +;; (refl-class-chain-find-with CFG CLASS-NAME PROBE) +;; Depth-first walk from CLASS-NAME up its parent chain. At each +;; class, calls `(probe class-name)`. Returns the first non-nil +;; probe result, or nil if no class produces one. Probes evaluate +;; left-to-right across siblings in multi-parent guests. +;; +;; (refl-class-chain-depth-with CFG CLASS-NAME ANCESTOR-NAME) +;; Minimum hop count from CLASS-NAME to ANCESTOR-NAME along any +;; parent path. CLASS-NAME itself counts as depth 0. Returns nil +;; if ANCESTOR-NAME is unreachable. +;; +;; (refl-class-chain-ancestors-with CFG CLASS-NAME) +;; Flat list of all reachable ancestor names in DFS order (no +;; dedup; multi-parent guests may want to dedup themselves). +;; +;; Consumer migrations +;; ------------------- +;; - Smalltalk: see `lib/smalltalk/runtime.sx` — `st-method-lookup-walk` +;; becomes a one-line probe through `refl-class-chain-find-with`. +;; - CLOS: see `lib/common-lisp/clos.sx` — `clos-specificity` becomes a +;; thin wrapper around `refl-class-chain-depth-with`. + +(define + refl-find-in-parents-with + (fn + (cfg parents probe) + (cond + ((or (nil? parents) (= (length parents) 0)) nil) + (:else + (let + ((hit (refl-class-chain-find-with cfg (first parents) probe))) + (cond + ((not (nil? hit)) hit) + (:else (refl-find-in-parents-with cfg (rest parents) probe)))))))) + +(define + refl-class-chain-find-with + (fn + (cfg class-name probe) + (cond + ((nil? class-name) nil) + ((not ((get cfg :class?) class-name)) nil) + (:else + (let + ((hit (probe class-name))) + (cond + ((not (nil? hit)) hit) + (:else + (refl-find-in-parents-with + cfg + ((get cfg :parents-of) class-name) + probe)))))))) + +(define + refl-class-chain-depth-walk + (fn + (cfg cur target depth) + (cond + ((= cur target) depth) + ((nil? cur) nil) + ((not ((get cfg :class?) cur)) nil) + (:else + (let + ((parents ((get cfg :parents-of) cur))) + (let + ((results (map (fn (p) (refl-class-chain-depth-walk cfg p target (+ depth 1))) parents))) + (let + ((non-nil (filter (fn (x) (not (nil? x))) results))) + (cond + ((or (nil? non-nil) (= (length non-nil) 0)) nil) + (:else + (reduce + (fn (a b) (if (< a b) a b)) + (first non-nil) + (rest non-nil))))))))))) + +(define + refl-class-chain-depth-with + (fn + (cfg class-name ancestor-name) + (refl-class-chain-depth-walk cfg class-name ancestor-name 0))) + +(define + refl-class-chain-ancestors-with + (fn (cfg class-name) (refl-ancestors-walk cfg class-name (list)))) + +(define + refl-ancestors-walk + (fn + (cfg cn acc) + (cond + ((nil? cn) acc) + ((not ((get cfg :class?) cn)) acc) + (:else + (let + ((parents ((get cfg :parents-of) cn))) + (refl-ancestors-walk-list cfg parents (append acc (list cn)))))))) + +(define + refl-ancestors-walk-list + (fn + (cfg parents acc) + (cond + ((or (nil? parents) (= (length parents) 0)) acc) + (:else + (refl-ancestors-walk-list + cfg + (rest parents) + (refl-ancestors-walk cfg (first parents) acc)))))) diff --git a/lib/smalltalk/compare.sh b/lib/smalltalk/compare.sh index 1db73b6d..c99380a8 100755 --- a/lib/smalltalk/compare.sh +++ b/lib/smalltalk/compare.sh @@ -40,6 +40,7 @@ run_sx () { (epoch 1) (load "lib/smalltalk/tokenizer.sx") (load "lib/smalltalk/parser.sx") +(load "lib/guest/reflective/class-chain.sx") (load "lib/smalltalk/runtime.sx") (load "lib/guest/reflective/env.sx") (load "lib/smalltalk/eval.sx") diff --git a/lib/smalltalk/runtime.sx b/lib/smalltalk/runtime.sx index 19198f22..cc011a7d 100644 --- a/lib/smalltalk/runtime.sx +++ b/lib/smalltalk/runtime.sx @@ -221,30 +221,37 @@ (st-ic-bump-generation!) true)))))))))) +;; Smalltalk-side adapter for lib/guest/reflective/class-chain.sx. +;; Smalltalk has single inheritance: :parents-of returns a 1-element +;; list (or empty) wrapping the single :superclass field. +(define st-class-cfg + {:parents-of (fn (cn) + (let ((p (st-class-superclass cn))) + (cond ((nil? p) (list)) + (:else (list p))))) + :class? (fn (n) (st-class-exists? n))}) + ;; Walk-only lookup. Returns the method record (with :defining-class) or nil. ;; class-side? = true searches :class-methods, false searches :methods. +;; Parent-chain walk delegates to refl-class-chain-find-with; the probe +;; tests this class's method dict and returns the entry (or nil). (define st-method-lookup-walk - (fn - (cls-name selector class-side?) - (let - ((found nil)) - (begin - (define - ml-loop - (fn - (cur) - (when - (and (= found nil) (not (= cur nil)) (st-class-exists? cur)) - (let - ((c (st-class-get cur))) - (let - ((dict (if class-side? (get c :class-methods) (get c :methods)))) - (cond - ((has-key? dict selector) (set! found (get dict selector))) - (else (ml-loop (get c :superclass))))))))) - (ml-loop cls-name) - found)))) + (fn (cls-name selector class-side?) + (refl-class-chain-find-with + st-class-cfg + cls-name + (fn (cn) + (let ((c (st-class-get cn))) + (cond + ((nil? c) nil) + (:else + (let ((dict (if class-side? + (get c :class-methods) + (get c :methods)))) + (cond + ((has-key? dict selector) (get dict selector)) + (:else nil)))))))))) ;; Cached lookup. Misses are stored as :not-found so doesNotUnderstand paths ;; don't re-walk on every send. diff --git a/lib/smalltalk/test.sh b/lib/smalltalk/test.sh index 45d5b905..2bb7b0e4 100755 --- a/lib/smalltalk/test.sh +++ b/lib/smalltalk/test.sh @@ -59,6 +59,7 @@ EPOCHS (epoch 2) (load "lib/smalltalk/parser.sx") (epoch 3) +(load "lib/guest/reflective/class-chain.sx") (load "lib/smalltalk/runtime.sx") (epoch 4) (load "lib/guest/reflective/env.sx") @@ -115,6 +116,7 @@ EPOCHS (epoch 2) (load "lib/smalltalk/parser.sx") (epoch 3) +(load "lib/guest/reflective/class-chain.sx") (load "lib/smalltalk/runtime.sx") (epoch 4) (load "lib/guest/reflective/env.sx") From 4563a7ae97c6a6c0eee1ffad94f2ea544f54f940 Mon Sep 17 00:00:00 2001 From: giles Date: Tue, 12 May 2026 21:14:28 +0000 Subject: [PATCH 2/2] =?UTF-8?q?method-chain:=20plan=20=E2=80=94=20current?= =?UTF-8?q?=20status=20+=20future-consumer=20notes?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Documents the extraction (Smalltalk + CLOS migrated, kit landed, counts unchanged), lists plausible third consumers (JS proto chain, Ruby ancestors, Python MRO), and notes which other patterns stayed unextracted and why (method-cache invalidation, inline cache, and the five reflective siblings all need consumers that don't exist yet in the codebase). Closes the session's extraction work at five branches: env (3 consumers), class-chain (2), test-runner (POC), plus the chain of intermediate branches. The Scheme port is the next high-leverage move; it would unlock four more reflective kits in one stroke. --- plans/lib-guest-method-chain.md | 59 +++++++++++++++++++++++++++++++++ 1 file changed, 59 insertions(+) create mode 100644 plans/lib-guest-method-chain.md diff --git a/plans/lib-guest-method-chain.md b/plans/lib-guest-method-chain.md new file mode 100644 index 00000000..7f7f63db --- /dev/null +++ b/plans/lib-guest-method-chain.md @@ -0,0 +1,59 @@ +# lib/guest/reflective/class-chain.sx — extraction plan + +## Status + +- [x] **Kit landed** — `lib/guest/reflective/class-chain.sx` (7 forms, ~120 LoC). +- [x] **First consumer migrated** — `lib/smalltalk/runtime.sx` `st-method-lookup-walk`. 20 lines → 9 lines. Smalltalk single-parent shape adapted via `:parents-of` returning a 1-element list. +- [x] **Second consumer migrated** — `lib/common-lisp/clos.sx` `clos-specificity`. 28 lines → 4 lines. CLOS multi-parent shape adapted via `:parents-of` returning the full parents list. +- [x] Both consumers' test counts unchanged. Smalltalk 847/847. CL 222/240 (18 pre-existing failures unrelated to CLOS dispatch). + +## API surface + +```lisp +(refl-class-chain-find-with CFG CLASS-NAME PROBE) + ;; DFS through parent chain. Returns first non-nil probe result. + ;; Smalltalk method lookup uses this. + +(refl-class-chain-depth-with CFG CLASS-NAME ANCESTOR-NAME) + ;; Minimum hop count via any parent path. nil if unreachable. + ;; CLOS method specificity uses this. + +(refl-class-chain-ancestors-with CFG CLASS-NAME) + ;; Flat DFS-ordered list of all reachable ancestor names. +``` + +**Adapter cfg keys:** +- `:parents-of` — fn (class-name) → list of parent class names. Empty list = root. Single-parent guests wrap into a 1-element list. +- `:class?` — predicate; short-circuits walk on non-existent class names. + +## Why two consumers were enough + +Smalltalk and CLOS have *structurally different* class hierarchies — single inheritance with one `:superclass` field versus multiple inheritance with a `:parents` list. The kit handles both via the cfg normalising `:parents-of` to "list of parent names" (empty, singleton, or multi-element). This is the third demonstration of the adapter-cfg pattern from `lib/guest/match.sx` and `lib/guest/reflective/env.sx`. + +## Future consumers + +A third consumer would validate the kit further but isn't blocked by the two-consumer rule. Plausible candidates that already have class chains in the codebase or could acquire them: + +- **JavaScript prototype chains** — if `lib/js/` builds an evaluator that walks `__proto__`. `:parents-of` returns a 1-element list (the proto, if any). Probably the cleanest third consumer. +- **Ruby's ancestor walk** (`Module#ancestors`) — multi-element list with strict ordering rules. Would stress whether `:parents-of` needs to return ordered lists (it already does). +- **Python's MRO** (method resolution order via C3 linearisation) — could use `refl-class-chain-ancestors-with` as a starting point, with consumer-side linearisation on top. + +## Non-goals + +- **Method-cache invalidation protocol** — Smalltalk has `st-method-cache` with class-change invalidation; CLOS has per-generic method lists with `clos-defmethod` updates. Currently only one consumer per cache shape; defer. + +- **Inline call-site caches** — Smalltalk's per-call-site IC is a hot-path optimisation. No other current consumer; defer until at least a JS or Python guest with optimisable dispatch. + +- **`combiner.sx`, `evaluator.sx`, `hygiene.sx`, `quoting.sx`, `short-circuit.sx`** — these still wait for a Scheme/Maru port. CLOS doesn't have fexprs, so it can't be the second consumer for `combiner.sx`. CL's reader has backquote parsing but no runtime quasi-walker, so it's not a current second consumer for `quoting.sx` either. The Scheme port is the unlock. + +## Cumulative session output + +| Branch | Kit | Consumers | +|---|---|---| +| `loops/kernel` | (proposal docs) | 1 | +| `lib/tcl/uplevel` | `reflective/env.sx` | 2 (Kernel, Tcl) | +| `lib/smalltalk/refl-env` | `+ refl-env-find-frame-with` | 3 (+ Smalltalk) | +| `lib/guest/test-runner` | `test-runner.sx` | 1 (Kernel POC) | +| `lib/guest/method-chain` | `reflective/class-chain.sx` | 2 (Smalltalk, CLOS) | + +**Two complete reflective kits live with multiple consumers**; one infrastructure kit at proof-of-concept; one extraction (the Scheme port that would unlock four more reflective kits) is the next natural strategic move but is a substantial undertaking.