method-chain: plan — current status + future-consumer notes

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.

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.
+;; CLOS-side adapter for lib/guest/reflective/class-chain.sx. Classes
-(define
+;; live in clos-class-registry; :parents is a list of parent class
-  clos-specificity
+;; names (CLOS supports multiple inheritance).
-  (let
+(define clos-class-cfg
-    ((registry clos-class-registry))
+  {:parents-of (fn (cn)
-    (fn
+                 (let ((rec (clos-find-class cn)))
-      (class-name spec-name)
+                   (cond ((nil? rec) (list))
-      (define
+                         (:else (or (get rec "parents") (list))))))
-        walk
+   :class?     (fn (n) (not (nil? (clos-find-class n))))})
-        (fn
+
-          (cn depth)
+;; Precedence distance: how far class-name is from spec-name up the
-          (if
+;; hierarchy. Delegates to refl-class-chain-depth-with which handles
-            (= cn spec-name)
+;; the multi-parent DFS with min-depth selection.
-            depth
+(define clos-specificity
-            (let
+  (fn (class-name spec-name)
-              ((rec (get registry cn)))
+    (refl-class-chain-depth-with clos-class-cfg class-name spec-name)))
-              (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))))
 
 (define
   clos-method-more-specific?

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"

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

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

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
+  (fn (cls-name selector class-side?)
-    (cls-name selector class-side?)
+    (refl-class-chain-find-with
-    (let
+      st-class-cfg
-      ((found nil))
+      cls-name
-      (begin
+      (fn (cn)
-        (define
+        (let ((c (st-class-get cn)))
-          ml-loop
+          (cond
-          (fn
+            ((nil? c) nil)
-            (cur)
+            (:else
-            (when
+              (let ((dict (if class-side?
-              (and (= found nil) (not (= cur nil)) (st-class-exists? cur))
+                            (get c :class-methods)
-              (let
+                            (get c :methods))))
-                ((c (st-class-get cur)))
+                (cond
-                (let
+                  ((has-key? dict selector) (get dict selector))
-                  ((dict (if class-side? (get c :class-methods) (get c :methods))))
+                  (:else nil))))))))))
-                  (cond
-                    ((has-key? dict selector) (set! found (get dict selector)))
-                    (else (ml-loop (get c :superclass)))))))))
-        (ml-loop cls-name)
-        found))))
 
 ;; Cached lookup. Misses are stored as :not-found so doesNotUnderstand paths
 ;; don't re-walk on every send.

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

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.