;; Smalltalk AST evaluator — sequential semantics. Method dispatch uses the
;; class table from runtime.sx; native receivers fall back to a primitive
;; method table. Non-local return is implemented via captured continuations:
;; each method invocation wraps its body in `call/cc`, the captured k is
;; stored on the frame as `:return-k`, and `^expr` invokes that k. Blocks
;; capture their creating method's k so `^` from inside a block returns
;; from the *creating* method, not the invoking one — this is Smalltalk's
;; non-local return, the headline of Phase 3.
;;
;; Frame:
;;   {:self V                 ; receiver
;;    :method-class N         ; defining class of the executing method
;;    :locals (mutable dict)  ; param + temp bindings
;;    :parent P               ; outer frame for blocks (nil for top-level)
;;    :return-k K}            ; the ^k that ^expr should invoke

(define
  st-make-frame
  (fn
    (self method-class parent return-k active-cell)
    {:self self
     :method-class method-class
     :locals {}
     :parent parent
     :return-k return-k
     ;; A small mutable dict shared between the method-frame and any
     ;; block created in its scope. While the method is on the stack
     ;; :active is true; once st-invoke finishes (normally or via the
     ;; captured ^k) it flips to false. ^expr from a block whose
     ;; active-cell is dead raises cannotReturn:.
     :active-cell active-cell}))

(define
  st-make-block
  (fn
    (ast frame)
    {:type "st-block"
     :params (get ast :params)
     :temps (get ast :temps)
     :body (get ast :body)
     :env frame
     ;; capture the creating method's return continuation so that `^expr`
     ;; from inside this block always returns from that method
     :return-k (if (= frame nil) nil (get frame :return-k))
     ;; Pair the captured ^k with the active-cell — invoking ^k after
     ;; the originating method has returned must raise cannotReturn:.
     :active-cell (if (= frame nil) nil (get frame :active-cell))}))

(define
  st-block?
  (fn
    (v)
    (and (dict? v) (has-key? v :type) (= (get v :type) "st-block"))))

(define
  st-class-ref
  (fn (name) {:type "st-class" :name name}))

(define
  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.
(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)))))

;; Walk the frame chain looking for the frame whose self has this ivar.
(define
  st-lookup-ivar-frame
  (fn
    (frame name)
    (cond
      ((= frame nil) nil)
      ((let ((self (get frame :self)))
         (and (st-instance? self) (has-key? (get self :ivars) name)))
        frame)
      (else (st-lookup-ivar-frame (get frame :parent) name)))))

;; Resolve an identifier in eval order: local → ivar → class → error.
(define
  st-resolve-ident
  (fn
    (frame name)
    (let
      ((local-result (st-lookup-local frame name)))
      (cond
        ((get local-result :found) (get local-result :value))
        (else
          (let
            ((iv-frame (st-lookup-ivar-frame frame name)))
            (cond
              ((not (= iv-frame nil))
                (get (get (get iv-frame :self) :ivars) name))
              ((st-class-exists? name) (st-class-ref name))
              (else
                (error
                  (str "smalltalk-eval-ast: undefined variable '" name "'"))))))))))

;; Assign to an existing local in the frame chain or, failing that, an ivar
;; on self. Errors if neither exists.
(define
  st-assign!
  (fn
    (frame name value)
    (let
      ((local-result (st-lookup-local frame name)))
      (cond
        ((get local-result :found)
          (begin
            (dict-set! (get (get local-result :frame) :locals) name value)
            value))
        (else
          (let
            ((iv-frame (st-lookup-ivar-frame frame name)))
            (cond
              ((not (= iv-frame nil))
                (begin
                  (dict-set! (get (get iv-frame :self) :ivars) name value)
                  value))
              (else
                ;; Smalltalk allows new locals to be introduced; for our subset
                ;; we treat unknown writes as errors so test mistakes surface.
                (error
                  (str "smalltalk-eval-ast: cannot assign undefined '" name "'"))))))))))

;; ── Main evaluator ─────────────────────────────────────────────────────
(define
  smalltalk-eval-ast
  (fn
    (ast frame)
    (cond
      ((not (dict? ast)) (error (str "smalltalk-eval-ast: bad ast " ast)))
      (else
        (let
          ((ty (get ast :type)))
          (cond
            ((= ty "lit-int") (get ast :value))
            ((= ty "lit-float") (get ast :value))
            ((= ty "lit-string") (get ast :value))
            ((= ty "lit-char") (get ast :value))
            ((= ty "lit-symbol") (make-symbol (get ast :value)))
            ((= ty "lit-nil") nil)
            ((= ty "lit-true") true)
            ((= ty "lit-false") false)
            ((= ty "lit-array")
              ;; map returns an immutable list — Smalltalk arrays must be
              ;; mutable so that `at:put:` works. Build via append! so each
              ;; literal yields a fresh mutable list.
              (let ((out (list)))
                (begin
                  (for-each
                    (fn (e) (append! out (smalltalk-eval-ast e frame)))
                    (get ast :elements))
                  out)))
            ((= ty "dynamic-array")
              ;; { e1. e2. ... } — each element is a full expression
              ;; evaluated at runtime. Returns a fresh mutable array.
              (let ((out (list)))
                (begin
                  (for-each
                    (fn (e) (append! out (smalltalk-eval-ast e frame)))
                    (get ast :elements))
                  out)))
            ((= ty "lit-byte-array") (get ast :elements))
            ((= ty "self") (get frame :self))
            ((= ty "super") (get frame :self))
            ((= ty "thisContext") frame)
            ((= ty "ident") (st-resolve-ident frame (get ast :name)))
            ((= ty "assign")
              (st-assign! frame (get ast :name) (smalltalk-eval-ast (get ast :expr) frame)))
            ((= ty "return")
              (let ((v (smalltalk-eval-ast (get ast :expr) frame)))
                (let
                  ((k (get frame :return-k))
                    (cell (get frame :active-cell)))
                  (cond
                    ((= k nil)
                      (error "smalltalk-eval-ast: return outside method context"))
                    ((and (not (= cell nil))
                          (not (get cell :active)))
                      (error
                        (str
                          "BlockContext>>cannotReturn: — ^expr after the "
                          "creating method has already returned (value was "
                          v ")")))
                    (else (k v))))))
            ((= ty "block") (st-make-block ast frame))
            ((= ty "seq") (st-eval-seq (get ast :exprs) frame))
            ((= ty "send")
              (st-eval-send ast frame (= (get (get ast :receiver) :type) "super")))
            ((= ty "cascade") (st-eval-cascade ast frame))
            (else (error (str "smalltalk-eval-ast: unknown type '" ty "'")))))))))

;; Evaluate a sequence; return the last expression's value. `^expr`
;; mid-sequence transfers control via the frame's :return-k and never
;; returns to this loop, so we don't need any return-marker plumbing.
(define
  st-eval-seq
  (fn
    (exprs frame)
    (let ((result nil))
      (begin
        (for-each
          (fn (e) (set! result (smalltalk-eval-ast e frame)))
          exprs)
        result))))

;; Per-call-site monomorphic inline cache: each `send` AST node stores
;; the receiver class and method record from the last dispatch. When the
;; next dispatch sees the same class AND the runtime's IC generation
;; hasn't changed, we skip the global method-lookup. Mutations to the
;; class table bump `st-ic-generation` (defined in runtime.sx) so stale
;; method records can't fire.
(define st-ic-hits 0)
(define st-ic-misses 0)

(define
  st-ic-reset-stats!
  (fn () (begin (set! st-ic-hits 0) (set! st-ic-misses 0))))

(define
  st-ic-stats
  (fn () {:hits st-ic-hits :misses st-ic-misses :gen st-ic-generation}))

;; Counter for intrinsified block sends — incremented when a known
;; control-flow idiom fires inline instead of going through dispatch.
(define st-intrinsic-hits 0)
(define
  st-intrinsic-stats
  (fn () {:hits st-intrinsic-hits}))
(define
  st-intrinsic-reset!
  (fn () (set! st-intrinsic-hits 0)))

(define
  st-simple-block-ast?
  (fn
    (a)
    (and (dict? a)
         (= (get a :type) "block")
         (= (len (get a :params)) 0)
         (= (len (get a :temps)) 0))))

;; AST-level recognition of control-flow idioms. When the call site looks
;; like `cond ifTrue: [body]`, `cond ifTrue:ifFalse:`, or
;; `[cond] whileTrue: [body]` and the block arguments are simple
;; (no params, no temps), short-circuit the entire dispatch chain and
;; evaluate the bodies inline in the current frame. ^expr inside an
;; inlined body still escapes correctly because the frame's :return-k
;; is unchanged.
(define
  st-try-intrinsify
  (fn
    (ast frame)
    (let
      ((selector (get ast :selector))
        (args-ast (get ast :args)))
      (cond
        ((and (= selector "ifTrue:")
              (= (len args-ast) 1)
              (st-simple-block-ast? (nth args-ast 0)))
          (let ((c (smalltalk-eval-ast (get ast :receiver) frame)))
            (begin
              (set! st-intrinsic-hits (+ st-intrinsic-hits 1))
              (cond
                ((= c true) (st-eval-seq (get (nth args-ast 0) :body) frame))
                (else nil)))))
        ((and (= selector "ifFalse:")
              (= (len args-ast) 1)
              (st-simple-block-ast? (nth args-ast 0)))
          (let ((c (smalltalk-eval-ast (get ast :receiver) frame)))
            (begin
              (set! st-intrinsic-hits (+ st-intrinsic-hits 1))
              (cond
                ((= c false) (st-eval-seq (get (nth args-ast 0) :body) frame))
                (else nil)))))
        ((and (= selector "ifTrue:ifFalse:")
              (= (len args-ast) 2)
              (st-simple-block-ast? (nth args-ast 0))
              (st-simple-block-ast? (nth args-ast 1)))
          (let ((c (smalltalk-eval-ast (get ast :receiver) frame)))
            (begin
              (set! st-intrinsic-hits (+ st-intrinsic-hits 1))
              (cond
                ((= c true) (st-eval-seq (get (nth args-ast 0) :body) frame))
                (else (st-eval-seq (get (nth args-ast 1) :body) frame))))))
        ((and (= selector "ifFalse:ifTrue:")
              (= (len args-ast) 2)
              (st-simple-block-ast? (nth args-ast 0))
              (st-simple-block-ast? (nth args-ast 1)))
          (let ((c (smalltalk-eval-ast (get ast :receiver) frame)))
            (begin
              (set! st-intrinsic-hits (+ st-intrinsic-hits 1))
              (cond
                ((= c true) (st-eval-seq (get (nth args-ast 1) :body) frame))
                (else (st-eval-seq (get (nth args-ast 0) :body) frame))))))
        ((and (= selector "and:")
              (= (len args-ast) 1)
              (st-simple-block-ast? (nth args-ast 0)))
          (let ((c (smalltalk-eval-ast (get ast :receiver) frame)))
            (begin
              (set! st-intrinsic-hits (+ st-intrinsic-hits 1))
              (cond
                ((= c true) (st-eval-seq (get (nth args-ast 0) :body) frame))
                (else false)))))
        ((and (= selector "or:")
              (= (len args-ast) 1)
              (st-simple-block-ast? (nth args-ast 0)))
          (let ((c (smalltalk-eval-ast (get ast :receiver) frame)))
            (begin
              (set! st-intrinsic-hits (+ st-intrinsic-hits 1))
              (cond
                ((= c true) true)
                (else (st-eval-seq (get (nth args-ast 0) :body) frame))))))
        ((and (= selector "whileTrue:")
              (st-simple-block-ast? (get ast :receiver))
              (= (len args-ast) 1)
              (st-simple-block-ast? (nth args-ast 0)))
          (let
            ((cond-body (get (get ast :receiver) :body))
              (body-body (get (nth args-ast 0) :body)))
            (begin
              (set! st-intrinsic-hits (+ st-intrinsic-hits 1))
              (define
                wt-loop
                (fn
                  ()
                  (let
                    ((c (st-eval-seq cond-body frame)))
                    (when
                      (= c true)
                      (begin (st-eval-seq body-body frame) (wt-loop))))))
              (wt-loop)
              nil)))
        ((and (= selector "whileFalse:")
              (st-simple-block-ast? (get ast :receiver))
              (= (len args-ast) 1)
              (st-simple-block-ast? (nth args-ast 0)))
          (let
            ((cond-body (get (get ast :receiver) :body))
              (body-body (get (nth args-ast 0) :body)))
            (begin
              (set! st-intrinsic-hits (+ st-intrinsic-hits 1))
              (define
                wf-loop
                (fn
                  ()
                  (let
                    ((c (st-eval-seq cond-body frame)))
                    (when
                      (= c false)
                      (begin (st-eval-seq body-body frame) (wf-loop))))))
              (wf-loop)
              nil)))
        (else :no-intrinsic)))))

(define
  st-eval-send
  (fn
    (ast frame super?)
    (cond
      (super?
        (let
          ((selector (get ast :selector))
            (args (map (fn (a) (smalltalk-eval-ast a frame)) (get ast :args))))
          (st-super-send (get frame :self) selector args (get frame :method-class))))
      (else
        (let ((intrinsified (st-try-intrinsify ast frame)))
          (cond
            ((not (= intrinsified :no-intrinsic)) intrinsified)
            (else (st-eval-send-dispatch ast frame))))))))

(define
  st-eval-send-dispatch
  (fn
    (ast frame)
    (let
      ((receiver (smalltalk-eval-ast (get ast :receiver) frame))
        (selector (get ast :selector))
        (args (map (fn (a) (smalltalk-eval-ast a frame)) (get ast :args))))
      (let ((cls (st-class-of-for-send receiver)))
        (cond
          ;; Inline-cache hit: same receiver class, same generation.
          ((and (has-key? ast :ic-class)
                (= (get ast :ic-class) cls)
                (has-key? ast :ic-gen)
                (= (get ast :ic-gen) st-ic-generation)
                (has-key? ast :ic-method))
            (begin
              (set! st-ic-hits (+ st-ic-hits 1))
              (st-invoke (get ast :ic-method) receiver args)))
          (else
            (begin
              (set! st-ic-misses (+ st-ic-misses 1))
              (let
                ((class-side? (st-class-ref? receiver))
                  (recv-class (if (st-class-ref? receiver)
                                  (get receiver :name)
                                  cls)))
                    (let ((method (st-method-lookup recv-class selector class-side?)))
                      (cond
                        ((not (= method nil))
                          (begin
                            (dict-set! ast :ic-class cls)
                            (dict-set! ast :ic-method method)
                            (dict-set! ast :ic-gen st-ic-generation)
                            (st-invoke method receiver args)))
                        (else (st-send receiver selector args))))))))))))

(define
  st-eval-cascade
  (fn
    (ast frame)
    (let
      ((receiver (smalltalk-eval-ast (get ast :receiver) frame))
        (msgs (get ast :messages))
        (last nil))
      (begin
        (for-each
          (fn
            (m)
            (let
              ((sel (get m :selector))
                (args (map (fn (a) (smalltalk-eval-ast a frame)) (get m :args))))
              (set! last (st-send receiver sel args))))
          msgs)
        last))))

;; ── Send dispatch ──────────────────────────────────────────────────────
(define
  st-send
  (fn
    (receiver selector args)
    (let
      ((cls (st-class-of-for-send receiver)))
      (let
        ((class-side? (st-class-ref? receiver))
          (recv-class (if (st-class-ref? receiver) (get receiver :name) cls)))
        (let
          ((method
             (if class-side?
               (st-method-lookup recv-class selector true)
               (st-method-lookup recv-class selector false))))
          (cond
            ((not (= method nil))
              (st-invoke method receiver args))
            ((st-block? receiver)
              (let ((bd (st-block-dispatch receiver selector args)))
                (cond
                  ((= bd :unhandled) (st-dnu receiver selector args))
                  (else bd))))
            (else
              (let ((primitive-result (st-primitive-send receiver selector args)))
                (cond
                  ((= primitive-result :unhandled)
                    (st-dnu receiver selector args))
                  (else primitive-result))))))))))

;; Construct a Message object for doesNotUnderstand:.
(define
  st-make-message
  (fn
    (selector args)
    (let ((msg (st-make-instance "Message")))
      (begin
        (dict-set! (get msg :ivars) "selector" (make-symbol selector))
        (dict-set! (get msg :ivars) "arguments" args)
        msg))))

;; Trigger doesNotUnderstand:. If the receiver's class chain defines an
;; override, invoke it with a freshly-built Message; otherwise raise.
(define
  st-dnu
  (fn
    (receiver selector args)
    (let
      ((cls (st-class-of-for-send receiver))
        (class-side? (st-class-ref? receiver)))
      (let
        ((recv-class (if class-side? (get receiver :name) cls)))
        (let
          ((method (st-method-lookup recv-class "doesNotUnderstand:" class-side?)))
          (cond
            ((not (= method nil))
              (let ((msg (st-make-message selector args)))
                (st-invoke method receiver (list msg))))
            (else
              (error
                (str "doesNotUnderstand: " recv-class " >> " selector)))))))))

(define
  st-class-of-for-send
  (fn
    (v)
    (cond
      ((st-class-ref? v) "Class")
      (else (st-class-of v)))))

;; super send: lookup starts at the *defining* class's superclass, not the
;; receiver class. This is what makes inherited methods compose correctly
;; under refinement — a method on Foo that calls `super bar` resolves to
;; Foo's superclass's `bar` regardless of the dynamic receiver class.
(define
  st-super-send
  (fn
    (receiver selector args defining-class)
    (cond
      ((= defining-class nil)
        (error (str "super send outside method context: " selector)))
      (else
        (let
          ((super (st-class-superclass defining-class))
            (class-side? (st-class-ref? receiver)))
          (cond
            ((= super nil)
              (error (str "super send past root: " selector " in " defining-class)))
            (else
              (let ((method (st-method-lookup super selector class-side?)))
                (cond
                  ((not (= method nil))
                    (st-invoke method receiver args))
                  (else
                    ;; Try primitives starting from super's perspective too —
                    ;; for native receivers the primitive table is global, so
                    ;; super basically reaches the same primitives. The point
                    ;; of super is to skip user overrides on the receiver's
                    ;; class chain below `super`, which method-lookup above
                    ;; already enforces.
                    (let ((p (st-primitive-send receiver selector args)))
                      (cond
                        ((= p :unhandled)
                          (st-dnu receiver selector args))
                        (else p)))))))))))))

;; ── Method invocation ──────────────────────────────────────────────────
;;
;; Method body is wrapped in (call/cc (fn (k) ...)). The k is bound on the
;; method's frame as :return-k. `^expr` invokes k, which abandons the body
;; and resumes call/cc with v. Blocks that escape with `^` capture the
;; *creating* method's k, so non-local return reaches back through any
;; number of nested block.value calls.
(define
  st-invoke
  (fn
    (method receiver args)
    (let
      ((params (get method :params))
        (temps (get method :temps))
        (body (get method :body))
        (defining-class (get method :defining-class)))
      (cond
        ((not (= (len params) (len args)))
          (error
            (str "smalltalk-eval-ast: arity mismatch for "
              (get method :selector)
              " expected " (len params) " got " (len args))))
        (else
          (let ((cell {:active true}))
            (let
              ((result
                (call/cc
                  (fn (k)
                    (let ((frame (st-make-frame receiver defining-class nil k cell)))
                      (begin
                        ;; Bind params
                        (let ((i 0))
                          (begin
                            (define
                              pb-loop
                              (fn
                                ()
                                (when
                                  (< i (len params))
                                  (begin
                                    (dict-set!
                                      (get frame :locals)
                                      (nth params i)
                                      (nth args i))
                                    (set! i (+ i 1))
                                    (pb-loop)))))
                            (pb-loop)))
                        ;; Bind temps to nil
                        (for-each
                          (fn (t) (dict-set! (get frame :locals) t nil))
                          temps)
                        ;; Execute body. If body finishes without ^, the implicit
                        ;; return value in Smalltalk is `self` — match that.
                        (st-eval-seq body frame)
                        receiver))))))
              (begin
                ;; Method invocation is finished — flip the cell so any block
                ;; that captured this method's ^k can no longer return.
                (dict-set! cell :active false)
                result))))))))

;; ── Block dispatch ─────────────────────────────────────────────────────
(define
  st-block-value-selector?
  (fn
    (s)
    (or
      (= s "value")
      (= s "value:")
      (= s "value:value:")
      (= s "value:value:value:")
      (= s "value:value:value:value:"))))

(define
  st-block-dispatch
  (fn
    (block selector args)
    (cond
      ((st-block-value-selector? selector) (st-block-apply block args))
      ((= selector "valueWithArguments:") (st-block-apply block (nth args 0)))
      ((= selector "whileTrue:")
        (st-block-while block (nth args 0) true))
      ((= selector "whileFalse:")
        (st-block-while block (nth args 0) false))
      ((= selector "whileTrue") (st-block-while block nil true))
      ((= selector "whileFalse") (st-block-while block nil false))
      ((= selector "numArgs") (len (get block :params)))
      ((= selector "class") (st-class-ref "BlockClosure"))
      ((= selector "==") (= block (nth args 0)))
      ((= selector "printString") "a BlockClosure")
      ;; Smalltalk exception machinery on top of SX guard/raise.
      ((= selector "on:do:")
        (st-block-on-do block (nth args 0) (nth args 1)))
      ((= selector "ensure:")
        (st-block-ensure block (nth args 0)))
      ((= selector "ifCurtailed:")
        (st-block-if-curtailed block (nth args 0)))
      (else :unhandled))))

;; on: ExceptionClass do: aHandler — run the receiver block, catching
;; raised st-instances whose class isKindOf: the given Exception class.
;; Other raises propagate. The handler receives the caught exception.
(define
  st-block-on-do
  (fn
    (block exc-class-ref handler)
    (let
      ((target-name
         (cond
           ((st-class-ref? exc-class-ref) (get exc-class-ref :name))
           (else "Exception"))))
      (guard
        (caught
          ((and (st-instance? caught)
                (st-class-inherits-from? (get caught :class) target-name))
            (st-block-apply handler (list caught))))
        (st-block-apply block (list))))))

;; ensure: cleanup — run the receiver block, then run cleanup whether the
;; receiver completed normally or raised. On raise, cleanup runs and the
;; exception propagates. The side-effect predicate pattern lets cleanup
;; run inside the guard clause without us needing to call (raise c)
;; explicitly (which has issues in nested handlers).
(define
  st-block-ensure
  (fn
    (block cleanup)
    (let ((result nil) (raised false))
      (begin
        (guard
          (caught
            ((begin
               (set! raised true)
               (st-block-apply cleanup (list))
               false)
              nil))
          (set! result (st-block-apply block (list))))
        (when (not raised) (st-block-apply cleanup (list)))
        result))))

;; ifCurtailed: cleanup — run cleanup ONLY if the receiver block raises.
(define
  st-block-if-curtailed
  (fn
    (block cleanup)
    (guard
      (caught
        ((begin (st-block-apply cleanup (list)) false) nil))
      (st-block-apply block (list)))))

(define
  st-block-apply
  (fn
    (block args)
    (let
      ((params (get block :params))
        (temps (get block :temps))
        (body (get block :body))
        (env (get block :env)))
      (cond
        ((not (= (len params) (len args)))
          (error
            (str "BlockClosure: arity mismatch — block expects "
              (len params) " got " (len args))))
        (else
          (let
            ((frame (st-make-frame
                     (if (= env nil) nil (get env :self))
                     (if (= env nil) nil (get env :method-class))
                     env
                     ;; Use the block's captured ^k so `^expr` returns from
                     ;; the *creating* method, not whoever invoked the block.
                     (get block :return-k)
                     ;; Same active-cell as the creating method's frame; if
                     ;; the method has returned, ^expr through this frame
                     ;; raises cannotReturn:.
                     (get block :active-cell))))
            (begin
              (let ((i 0))
                (begin
                  (define
                    pb-loop
                    (fn
                      ()
                      (when
                        (< i (len params))
                        (begin
                          (dict-set!
                            (get frame :locals)
                            (nth params i)
                            (nth args i))
                          (set! i (+ i 1))
                          (pb-loop)))))
                  (pb-loop)))
              (for-each
                (fn (t) (dict-set! (get frame :locals) t nil))
                temps)
              (st-eval-seq body frame))))))))

;; whileTrue: / whileTrue / whileFalse: / whileFalse — the receiver is the
;; condition block; the optional argument is the body block. Per ANSI / Pharo
;; convention, the loop returns nil regardless of how many iterations ran.
(define
  st-block-while
  (fn
    (cond-block body-block target)
    (begin
      (define
        wh-loop
        (fn
          ()
          (let
            ((c (st-block-apply cond-block (list))))
            (when
              (= c target)
              (begin
                (cond
                  ((not (= body-block nil))
                    (st-block-apply body-block (list))))
                (wh-loop))))))
      (wh-loop)
      nil)))

;; ── Primitive method table for native receivers ────────────────────────
;; Returns the result, or the sentinel :unhandled if no primitive matches —
;; in which case st-send falls back to doesNotUnderstand:.
(define
  st-primitive-send
  (fn
    (receiver selector args)
    (let ((cls (st-class-of receiver)))
      ;; Universal Object messages — work on any receiver type.
      (cond
        ((= selector "class")
          (cond
            ((st-class-ref? receiver) (st-class-ref "Metaclass"))
            (else (st-class-ref cls))))
        ;; perform: / perform:with: / perform:withArguments:
        ((= selector "perform:")
          (st-send receiver (str (nth args 0)) (list)))
        ((= selector "perform:withArguments:")
          (st-send receiver (str (nth args 0)) (nth args 1)))
        ((or (= selector "perform:with:")
             (= selector "perform:with:with:")
             (= selector "perform:with:with:with:")
             (= selector "perform:with:with:with:with:"))
          (st-send receiver (str (nth args 0)) (slice args 1 (len args))))
        ;; respondsTo: aSymbol — searches user method dicts only. Native
        ;; primitive selectors aren't enumerated, so e.g. `42 respondsTo:
        ;; #+` returns false. (The send still works because dispatch falls
        ;; through to st-num-send.) Documented limitation.
        ((= selector "respondsTo:")
          (let
            ((sel-str (str (nth args 0)))
              (target-cls (if (st-class-ref? receiver) (get receiver :name) cls))
              (class-side? (st-class-ref? receiver)))
            (not (= (st-method-lookup target-cls sel-str class-side?) nil))))
        ;; isKindOf: aClass — true iff the receiver's class chain reaches it.
        ((= selector "isKindOf:")
          (let
            ((arg (nth args 0))
              (target-cls (if (st-class-ref? receiver) "Metaclass" cls)))
            (cond
              ((not (st-class-ref? arg)) false)
              (else (st-class-inherits-from? target-cls (get arg :name))))))
        ;; Universal printOn: — send `printString` (so user overrides win)
        ;; and write the result to the stream argument. Coerce the
        ;; printString result via SX `str` so it's an iterable String —
        ;; if a user method returns a Symbol, the stream's nextPutAll:
        ;; (which loops with `do:`) needs a String to walk character by
        ;; character.
        ((= selector "printOn:")
          (let
            ((stream (nth args 0))
              (s (str (st-send receiver "printString" (list)))))
            (begin
              (st-send stream "nextPutAll:" (list s))
              receiver)))
        ;; Universal printString fallback for receivers no primitive table
        ;; handles (notably user st-instances). Native types implement
        ;; their own printString in the primitive senders below.
        ((and (= selector "printString")
              (or (st-instance? receiver) (st-class-ref? receiver)))
          (st-printable-string receiver))
        ;; isMemberOf: aClass — exact class match.
        ((= selector "isMemberOf:")
          (let
            ((arg (nth args 0))
              (target-cls (if (st-class-ref? receiver) "Metaclass" cls)))
            (cond
              ((not (st-class-ref? arg)) false)
              (else (= target-cls (get arg :name))))))
        ;; Smalltalk Exception system — `signal` raises the receiver via
        ;; SX raise. The argument to signal: sets messageText.
        ;; on:do: / ensure: / ifCurtailed: are implemented on BlockClosure
        ;; in `st-block-dispatch`.
        ((and (= selector "signal")
              (st-instance? receiver)
              (st-class-inherits-from? cls "Exception"))
          (raise receiver))
        ((and (= selector "signal:")
              (st-instance? receiver)
              (st-class-inherits-from? cls "Exception"))
          (begin
            (dict-set! (get receiver :ivars) "messageText" (nth args 0))
            (raise receiver)))
        ((and (= selector "signal")
              (st-class-ref? receiver)
              (st-class-inherits-from? (get receiver :name) "Exception"))
          (raise (st-make-instance (get receiver :name))))
        ((and (= selector "signal:")
              (st-class-ref? receiver)
              (st-class-inherits-from? (get receiver :name) "Exception"))
          (let ((inst (st-make-instance (get receiver :name))))
            (begin
              (dict-set! (get inst :ivars) "messageText" (nth args 0))
              (raise inst))))
        ;; Object>>becomeForward: aReceiver — one-way become. The receiver's
        ;; class and ivars are mutated in place to match the target. Every
        ;; existing reference to the receiver dict sees the new identity.
        ;; Note: receiver and target remain distinct dicts (not == in the
        ;; SX-identity sense), but receiver behaves as though it were the
        ;; target — which is the practical Pharo guarantee.
        ((= selector "becomeForward:")
          (let ((other (nth args 0)))
            (cond
              ((not (st-instance? receiver))
                (error "becomeForward: only supported on user instances"))
              ((not (st-instance? other))
                (error "becomeForward: target must be a user instance"))
              (else
                (begin
                  (dict-set! receiver :class (get other :class))
                  (dict-set! receiver :ivars (get other :ivars))
                  receiver)))))
        ((or (= cls "SmallInteger") (= cls "Float"))
          (st-num-send receiver selector args))
        ((or (= cls "String") (= cls "Symbol"))
          (st-string-send receiver selector args))
        ((= cls "True") (st-bool-send true selector args))
        ((= cls "False") (st-bool-send false selector args))
        ((= cls "UndefinedObject") (st-nil-send selector args))
        ((= cls "Array") (st-array-send receiver selector args))
        ((st-class-ref? receiver) (st-class-side-send receiver selector args))
        (else :unhandled)))))

;; Default printable representation. User instances render as
;; "an X" (or "a X" for vowel-initial classes); class-refs render as
;; their name. Native types are handled by their primitive senders.
(define
  st-printable-string
  (fn
    (v)
    (cond
      ((st-class-ref? v) (get v :name))
      ((st-instance? v)
        (let ((cls (get v :class)))
          (let ((article (if (st-vowel-initial? cls) "an " "a ")))
            (str article cls))))
      (else (str v)))))

(define
  st-vowel-initial?
  (fn
    (s)
    (cond
      ((= (len s) 0) false)
      (else
        (let ((c (nth s 0)))
          (or (= c "A") (= c "E") (= c "I") (= c "O") (= c "U")
              (= c "a") (= c "e") (= c "i") (= c "o") (= c "u")))))))

;; Pharo-style {N}-substitution. Walks the source, when a '{' starts a
;; valid numeric index, substitutes the corresponding (1-indexed) item
;; from the args collection. Unmatched braces are preserved.
(define
  st-format-step
  (fn
    (src args out i n)
    (let ((c (nth src i)))
      (cond
        ((not (= c "{"))
          {:emit c :advance 1})
        (else
          (let ((close (st-find-close-brace src i)))
            (cond
              ((= close -1) {:emit c :advance 1})
              (else
                (let ((idx (parse-number (slice src (+ i 1) close))))
                  (cond
                    ((and (number? idx)
                          (integer? idx)
                          (> idx 0)
                          (<= idx (len args)))
                      {:emit (str (nth args (- idx 1)))
                       :advance (- (+ close 1) i)})
                    (else
                      {:emit c :advance 1})))))))))))

(define
  st-format-string
  (fn
    (src args)
    (let ((out (list)) (i 0) (n (len src)))
      (begin
        (define
          fmt-loop
          (fn
            ()
            (when
              (< i n)
              (let ((step (st-format-step src args out i n)))
                (begin
                  (append! out (get step :emit))
                  (set! i (+ i (get step :advance)))
                  (fmt-loop))))))
        (fmt-loop)
        (join "" out)))))

(define
  st-find-close-brace
  (fn
    (src start)
    (let ((i (+ start 1)) (n (len src)) (found -1))
      (begin
        (define
          fc-loop
          (fn
            ()
            (when
              (and (< i n) (= found -1))
              (cond
                ((= (nth src i) "}") (set! found i))
                (else (begin (set! i (+ i 1)) (fc-loop)))))))
        (fc-loop)
        found))))

(define
  st-num-send
  (fn
    (n selector args)
    (cond
      ((= selector "+") (+ n (nth args 0)))
      ((= selector "-") (- n (nth args 0)))
      ((= selector "*") (* n (nth args 0)))
      ((= selector "/") (/ n (nth args 0)))
      ((= selector "//") (/ n (nth args 0)))
      ((= selector "\\\\") (mod n (nth args 0)))
      ((= selector "<") (< n (nth args 0)))
      ((= selector ">") (> n (nth args 0)))
      ((= selector "<=") (<= n (nth args 0)))
      ((= selector ">=") (>= n (nth args 0)))
      ((= selector "=") (= n (nth args 0)))
      ((= selector "~=") (not (= n (nth args 0))))
      ((= selector "==") (= n (nth args 0)))
      ((= selector "~~") (not (= n (nth args 0))))
      ((= selector "negated") (- 0 n))
      ((= selector "abs") (if (< n 0) (- 0 n) n))
      ((= selector "floor") (floor n))
      ((= selector "ceiling")
        ;; ceiling(x) = -floor(-x); fast for both signs.
        (- 0 (floor (- 0 n))))
      ((= selector "truncated") (truncate n))
      ((= selector "rounded") (round n))
      ((= selector "sqrt") (sqrt n))
      ((= selector "squared") (* n n))
      ((= selector "raisedTo:")
        (let ((p (nth args 0)) (acc 1) (i 0))
          (begin
            (define
              rt-loop
              (fn ()
                (when (< i p)
                  (begin (set! acc (* acc n)) (set! i (+ i 1)) (rt-loop)))))
            (rt-loop)
            acc)))
      ((= selector "factorial")
        (let ((acc 1) (i 2))
          (begin
            (define
              ft-loop
              (fn ()
                (when (<= i n)
                  (begin (set! acc (* acc i)) (set! i (+ i 1)) (ft-loop)))))
            (ft-loop)
            acc)))
      ((= selector "even") (= (mod n 2) 0))
      ((= selector "odd") (= (mod n 2) 1))
      ((= selector "isInteger") (integer? n))
      ((= selector "isFloat") (and (number? n) (not (integer? n))))
      ((= selector "isNumber") true)
      ((= selector "gcd:")
        (let ((a (if (< n 0) (- 0 n) n))
              (b (if (< (nth args 0) 0) (- 0 (nth args 0)) (nth args 0))))
          (begin
            (define
              gcd-loop
              (fn ()
                (cond
                  ((= b 0) a)
                  (else
                    (let ((t (mod a b)))
                      (begin (set! a b) (set! b t) (gcd-loop)))))))
            (gcd-loop))))
      ((= selector "lcm:")
        (let ((g (st-num-send n "gcd:" args)))
          (cond ((= g 0) 0)
                (else (* (/ n g) (nth args 0))))))
      ((= selector "max:") (if (> n (nth args 0)) n (nth args 0)))
      ((= selector "min:") (if (< n (nth args 0)) n (nth args 0)))
      ((= selector "printString") (str n))
      ((= selector "asString") (str n))
      ((= selector "class")
        (st-class-ref (st-class-of n)))
      ((= selector "isNil") false)
      ((= selector "notNil") true)
      ((= selector "isZero") (= n 0))
      ((= selector "between:and:")
        (and (>= n (nth args 0)) (<= n (nth args 1))))
      ((= selector "to:do:")
        (let ((i n) (stop (nth args 0)) (block (nth args 1)))
          (begin
            (define
              td-loop
              (fn
                ()
                (when
                  (<= i stop)
                  (begin
                    (st-block-apply block (list i))
                    (set! i (+ i 1))
                    (td-loop)))))
            (td-loop)
            n)))
      ((= selector "timesRepeat:")
        (let ((i 0) (block (nth args 0)))
          (begin
            (define
              tr-loop
              (fn
                ()
                (when
                  (< i n)
                  (begin
                    (st-block-apply block (list))
                    (set! i (+ i 1))
                    (tr-loop)))))
            (tr-loop)
            n)))
      (else :unhandled))))

(define
  st-string-send
  (fn
    (s selector args)
    (cond
      ((= selector ",") (str s (nth args 0)))
      ((= selector "size") (len s))
      ((= selector "=") (= s (nth args 0)))
      ((= selector "~=") (not (= s (nth args 0))))
      ((= selector "==") (= s (nth args 0)))
      ((= selector "~~") (not (= s (nth args 0))))
      ((= selector "isEmpty") (= (len s) 0))
      ((= selector "notEmpty") (> (len s) 0))
      ((= selector "printString") (str "'" s "'"))
      ((= selector "asString") s)
      ((= selector "asSymbol") (make-symbol (if (symbol? s) (str s) s)))
      ;; 1-indexed character access; returns the character (a 1-char string).
      ((= selector "at:") (nth s (- (nth args 0) 1)))
      ((= selector "do:")
        (let ((i 0) (n (len s)) (block (nth args 0)))
          (begin
            (define
              sd-loop
              (fn ()
                (when (< i n)
                  (begin
                    (st-block-apply block (list (nth s i)))
                    (set! i (+ i 1))
                    (sd-loop)))))
            (sd-loop)
            s)))
      ((= selector "first") (nth s 0))
      ((= selector "last") (nth s (- (len s) 1)))
      ((= selector "copyFrom:to:")
        (slice s (- (nth args 0) 1) (nth args 1)))
      ;; String>>format: — Pharo-style {N}-substitution.
      ;;   '{1} loves {2}' format: #('Alice' 'Bob') → 'Alice loves Bob'
      ;; Indexes are 1-based. Unmatched braces are kept literally.
      ((= selector "format:")
        (st-format-string s (nth args 0)))
      ((= selector "class") (st-class-ref (st-class-of s)))
      ((= selector "isNil") false)
      ((= selector "notNil") true)
      (else :unhandled))))

(define
  st-bool-send
  (fn
    (b selector args)
    (cond
      ((= selector "not") (not b))
      ((= selector "&") (and b (nth args 0)))
      ((= selector "|") (or b (nth args 0)))
      ((= selector "and:")
        (cond (b (st-block-apply (nth args 0) (list))) (else false)))
      ((= selector "or:")
        (cond (b true) (else (st-block-apply (nth args 0) (list)))))
      ((= selector "ifTrue:")
        (cond (b (st-block-apply (nth args 0) (list))) (else nil)))
      ((= selector "ifFalse:")
        (cond (b nil) (else (st-block-apply (nth args 0) (list)))))
      ((= selector "ifTrue:ifFalse:")
        (cond
          (b (st-block-apply (nth args 0) (list)))
          (else (st-block-apply (nth args 1) (list)))))
      ((= selector "ifFalse:ifTrue:")
        (cond
          (b (st-block-apply (nth args 1) (list)))
          (else (st-block-apply (nth args 0) (list)))))
      ((= selector "=") (= b (nth args 0)))
      ((= selector "~=") (not (= b (nth args 0))))
      ((= selector "==") (= b (nth args 0)))
      ((= selector "printString") (if b "true" "false"))
      ((= selector "class") (st-class-ref (if b "True" "False")))
      ((= selector "isNil") false)
      ((= selector "notNil") true)
      (else :unhandled))))

(define
  st-nil-send
  (fn
    (selector args)
    (cond
      ((= selector "isNil") true)
      ((= selector "notNil") false)
      ((= selector "ifNil:") (st-block-apply (nth args 0) (list)))
      ((= selector "ifNotNil:") nil)
      ((= selector "ifNil:ifNotNil:") (st-block-apply (nth args 0) (list)))
      ((= selector "ifNotNil:ifNil:") (st-block-apply (nth args 1) (list)))
      ((= selector "=") (= nil (nth args 0)))
      ((= selector "~=") (not (= nil (nth args 0))))
      ((= selector "==") (= nil (nth args 0)))
      ((= selector "printString") "nil")
      ((= selector "class") (st-class-ref "UndefinedObject"))
      (else :unhandled))))

(define
  st-array-send
  (fn
    (a selector args)
    (cond
      ((= selector "size") (len a))
      ((= selector "at:")
        ;; 1-indexed
        (nth a (- (nth args 0) 1)))
      ((= selector "at:put:")
        (begin
          (set-nth! a (- (nth args 0) 1) (nth args 1))
          (nth args 1)))
      ((= selector "first") (nth a 0))
      ((= selector "last") (nth a (- (len a) 1)))
      ((= selector "isEmpty") (= (len a) 0))
      ((= selector "notEmpty") (> (len a) 0))
      ((= selector "do:")
        (begin
          (for-each
            (fn (e) (st-block-apply (nth args 0) (list e)))
            a)
          a))
      ((= selector "add:")
        (begin (append! a (nth args 0)) (nth args 0)))
      ((= selector "collect:")
        (map (fn (e) (st-block-apply (nth args 0) (list e))) a))
      ((= selector "select:")
        (filter (fn (e) (st-block-apply (nth args 0) (list e))) a))
      ((= selector ",")
        (let ((out (list)))
          (begin
            (for-each (fn (e) (append! out e)) a)
            (for-each (fn (e) (append! out e)) (nth args 0))
            out)))
      ((= selector "=") (= a (nth args 0)))
      ((= selector "==") (= a (nth args 0)))
      ((= selector "printString")
        (str "#(" (join " " (map (fn (e) (str e)) a)) ")"))
      ((= selector "class") (st-class-ref "Array"))
      ((= selector "isNil") false)
      ((= selector "notNil") true)
      (else :unhandled))))

;; Split a Smalltalk-style "x y z" instance-variable string into a list of
;; ivar names. Whitespace-delimited.
(define
  st-split-ivars
  (fn
    (s)
    (let ((out (list)) (n (len s)) (i 0) (start nil))
      (begin
        (define
          flush!
          (fn ()
            (when
              (not (= start nil))
              (begin (append! out (slice s start i)) (set! start nil)))))
        (define
          si-loop
          (fn ()
            (when
              (< i n)
              (let ((c (nth s i)))
                (cond
                  ((or (= c " ") (= c "\t") (= c "\n") (= c "\r"))
                    (begin (flush!) (set! i (+ i 1)) (si-loop)))
                  (else
                    (begin
                      (when (= start nil) (set! start i))
                      (set! i (+ i 1))
                      (si-loop))))))))
        (si-loop)
        (flush!)
        out))))

(define
  st-class-side-send
  (fn
    (cref selector args)
    (let ((name (get cref :name)))
      (cond
        ((= selector "new")
          (cond
            ((= name "Array") (list))
            (else (st-make-instance name))))
        ((= selector "new:")
          (cond
            ((= name "Array")
              (let ((size (nth args 0)) (out (list)))
                (begin
                  (let ((i 0))
                    (begin
                      (define
                        an-loop
                        (fn ()
                          (when
                            (< i size)
                            (begin
                              (append! out nil)
                              (set! i (+ i 1))
                              (an-loop)))))
                      (an-loop)))
                  out)))
            (else (st-make-instance name))))
        ((= selector "name") name)
        ((= selector "superclass")
          (let ((s (st-class-superclass name)))
            (cond ((= s nil) nil) (else (st-class-ref s)))))
        ((= selector "methodDict")
          ;; The class's own method dictionary (instance side).
          (get (st-class-get name) :methods))
        ((= selector "classMethodDict")
          (get (st-class-get name) :class-methods))
        ((= selector "selectors")
          ;; Own instance-side selectors as an Array of symbols.
          (let ((out (list)))
            (begin
              (for-each
                (fn (k) (append! out (make-symbol k)))
                (keys (get (st-class-get name) :methods)))
              out)))
        ((= selector "classSelectors")
          (let ((out (list)))
            (begin
              (for-each
                (fn (k) (append! out (make-symbol k)))
                (keys (get (st-class-get name) :class-methods)))
              out)))
        ((= selector "instanceVariableNames")
          ;; Own ivars as an Array of strings (matches Pharo).
          (get (st-class-get name) :ivars))
        ((= selector "allInstVarNames")
          ;; Inherited + own ivars in declaration order (root first).
          (st-class-all-ivars name))
        ;; Class definition: `Object subclass: #Foo instanceVariableNames: 'x y'`.
        ;; Supports the short `subclass:` and the full
        ;; `subclass:instanceVariableNames:classVariableNames:package:` form.
        ((or (= selector "subclass:")
             (= selector "subclass:instanceVariableNames:")
             (= selector "subclass:instanceVariableNames:classVariableNames:")
             (= selector "subclass:instanceVariableNames:classVariableNames:package:")
             (= selector "subclass:instanceVariableNames:classVariableNames:poolDictionaries:category:"))
          (let
            ((sub-sym (nth args 0))
              (iv-string (if (> (len args) 1) (nth args 1) "")))
            (let
              ((sub-name (str sub-sym)))
              (begin
                (st-class-define!
                  sub-name
                  name
                  (st-split-ivars (if (string? iv-string) iv-string (str iv-string))))
                (st-class-ref sub-name)))))
        ;; methodsFor: / methodsFor:stamp: are Pharo file-in markers — at
        ;; the expression level they just return the class for further
        ;; cascades. Method bodies are loaded by the chunk-stream loader.
        ((or (= selector "methodsFor:")
             (= selector "methodsFor:stamp:")
             (= selector "category:")
             (= selector "comment:"))
          cref)
        ;; Behavior>>compile: parses the source string as a method and
        ;; installs it. Returns the selector as a symbol.
        ;; Sister forms: compile:classified: and compile:notifying:
        ;; ignore the extra arg, mirroring Pharo's tolerant behaviour.
        ((or (= selector "compile:")
             (= selector "compile:classified:")
             (= selector "compile:notifying:"))
          (let ((src (nth args 0)))
            (let ((method-ast (st-parse-method (str src))))
              (st-class-add-method!
                name (get method-ast :selector) method-ast)
              (make-symbol (get method-ast :selector)))))
        ((or (= selector "addSelector:withMethod:")
             (= selector "addSelector:method:"))
          (let
            ((sel (str (nth args 0)))
              (method-ast (nth args 1)))
            (begin
              (st-class-add-method! name sel method-ast)
              (make-symbol sel))))
        ((= selector "removeSelector:")
          (let ((sel (str (nth args 0))))
            (st-class-remove-method! name sel)))
        ((= selector "printString") name)
        ((= selector "class") (st-class-ref "Metaclass"))
        ((= selector "==") (and (st-class-ref? (nth args 0))
                                (= name (get (nth args 0) :name))))
        ((= selector "=") (and (st-class-ref? (nth args 0))
                                (= name (get (nth args 0) :name))))
        ((= selector "isNil") false)
        ((= selector "notNil") true)
        (else :unhandled)))))

;; Run a chunk-format Smalltalk program. Do-it expressions execute in a
;; fresh top-level frame (with an active-cell so ^expr works). Method
;; chunks register on the named class.
(define
  smalltalk-load
  (fn
    (src)
    (let ((entries (st-parse-chunks src)) (last-result nil))
      (begin
        (for-each
          (fn (entry)
            (let ((kind (get entry :kind)))
              (cond
                ((= kind "expr")
                  (let ((cell {:active true}))
                    (set!
                      last-result
                      (call/cc
                        (fn (k)
                          (smalltalk-eval-ast
                            (get entry :ast)
                            (st-make-frame nil nil nil k cell)))))
                    (dict-set! cell :active false)))
                ((= kind "method")
                  (cond
                    ((get entry :class-side?)
                      (st-class-add-class-method!
                        (get entry :class)
                        (get (get entry :ast) :selector)
                        (get entry :ast)))
                    (else
                      (st-class-add-method!
                        (get entry :class)
                        (get (get entry :ast) :selector)
                        (get entry :ast)))))
                (else nil))))
          entries)
        last-result))))

;; Convenience: parse and evaluate a Smalltalk expression with no receiver.
(define
  smalltalk-eval
  (fn
    (src)
    (let ((cell {:active true}))
      (let
        ((result
           (call/cc
             (fn (k)
               (let
                 ((ast (st-parse-expr src))
                   (frame (st-make-frame nil nil nil k cell)))
                 (smalltalk-eval-ast ast frame))))))
        (begin (dict-set! cell :active false) result)))))

;; Evaluate a sequence of statements at the top level.
(define
  smalltalk-eval-program
  (fn
    (src)
    (let ((cell {:active true}))
      (let
        ((result
           (call/cc
             (fn (k)
               (let
                 ((ast (st-parse src))
                   (frame (st-make-frame nil nil nil k cell)))
                 (begin
                   (when
                     (and (dict? ast) (has-key? ast :temps))
                     (for-each
                       (fn (t) (dict-set! (get frame :locals) t nil))
                       (get ast :temps)))
                   (smalltalk-eval-ast ast frame)))))))
        (begin (dict-set! cell :active false) result)))))