;; Smalltalk runtime — class table, bootstrap hierarchy, type→class mapping,
;; instance construction. Method dispatch / eval-ast live in a later layer.
;;
;; Class record shape:
;;   {:name "Foo"
;;    :superclass "Object"          ; or nil for Object itself
;;    :ivars (list "x" "y")          ; instance variable names declared on this class
;;    :methods   (dict selector→method-record)
;;    :class-methods (dict selector→method-record)}
;;
;; A method record is the AST returned by st-parse-method, plus a :defining-class
;; field so super-sends can resolve from the right place. (Methods are registered
;; via runtime helpers that fill the field.)
;;
;; The class table is a single dict keyed by class name. Bootstrap installs the
;; canonical hierarchy. Test code resets it via (st-bootstrap-classes!).

(define st-class-table {})

;; ── Method-lookup cache ────────────────────────────────────────────────
;; Cache keys are "class|selector|side"; side is "i" (instance) or "c" (class).
;; Misses are stored as the sentinel :not-found so we don't re-walk for
;; every doesNotUnderstand call.
(define st-method-cache {})
(define st-method-cache-hits 0)
(define st-method-cache-misses 0)

(define
  st-method-cache-clear!
  (fn () (set! st-method-cache {})))

;; Inline-cache generation. Eval-time IC slots check this; bumping it
;; invalidates every cached call-site method record across the program.
(define st-ic-generation 0)

(define
  st-ic-bump-generation!
  (fn () (set! st-ic-generation (+ st-ic-generation 1))))

(define
  st-method-cache-key
  (fn (cls sel class-side?) (str cls "|" sel "|" (if class-side? "c" "i"))))

(define
  st-method-cache-stats
  (fn
    ()
    {:hits st-method-cache-hits
     :misses st-method-cache-misses
     :size (len (keys st-method-cache))}))

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

(define
  st-class-table-clear!
  (fn ()
    (begin
      (set! st-class-table {})
      (st-method-cache-clear!))))

(define
  st-class-define!
  (fn
    (name superclass ivars)
    (begin
      (set!
        st-class-table
        (assoc
          st-class-table
          name
          {:name name
           :superclass superclass
           :ivars ivars
           :methods {}
           :class-methods {}}))
      ;; A redefined class can invalidate any cache entries that walked
      ;; through its old position in the chain. Cheap + correct: drop all.
      (st-method-cache-clear!)
      name)))

(define
  st-class-get
  (fn (name) (if (has-key? st-class-table name) (get st-class-table name) nil)))

(define
  st-class-exists?
  (fn (name) (has-key? st-class-table name)))

(define
  st-class-superclass
  (fn
    (name)
    (let
      ((c (st-class-get name)))
      (cond ((= c nil) nil) (else (get c :superclass))))))

;; Walk class chain root-to-leaf? No, follow superclass chain leaf-to-root.
;; Returns list of class names starting at `name` and ending with the root.
(define
  st-class-chain
  (fn
    (name)
    (let ((acc (list)) (cur name))
      (begin
        (define
          ch-loop
          (fn
            ()
            (when
              (and (not (= cur nil)) (st-class-exists? cur))
              (begin
                (append! acc cur)
                (set! cur (st-class-superclass cur))
                (ch-loop)))))
        (ch-loop)
        acc))))

;; Inherited + own ivars in declaration order from root to leaf.
(define
  st-class-all-ivars
  (fn
    (name)
    (let ((chain (reverse (st-class-chain name))) (out (list)))
      (begin
        (for-each
          (fn
            (cn)
            (let
              ((c (st-class-get cn)))
              (when
                (not (= c nil))
                (for-each (fn (iv) (append! out iv)) (get c :ivars)))))
          chain)
        out))))

;; Method install. The defining-class field is stamped on the method record
;; so super-sends look up from the right point in the chain.
(define
  st-class-add-method!
  (fn
    (cls-name selector method-ast)
    (let
      ((cls (st-class-get cls-name)))
      (cond
        ((= cls nil) (error (str "st-class-add-method!: unknown class " cls-name)))
        (else
          (let
            ((m (assoc method-ast :defining-class cls-name)))
            (begin
              (set!
                st-class-table
                (assoc
                  st-class-table
                  cls-name
                  (assoc
                    cls
                    :methods
                    (assoc (get cls :methods) selector m))))
              (st-method-cache-clear!)
              (st-ic-bump-generation!)
              selector)))))))

(define
  st-class-add-class-method!
  (fn
    (cls-name selector method-ast)
    (let
      ((cls (st-class-get cls-name)))
      (cond
        ((= cls nil) (error (str "st-class-add-class-method!: unknown class " cls-name)))
        (else
          (let
            ((m (assoc method-ast :defining-class cls-name)))
            (begin
              (set!
                st-class-table
                (assoc
                  st-class-table
                  cls-name
                  (assoc
                    cls
                    :class-methods
                    (assoc (get cls :class-methods) selector m))))
              (st-method-cache-clear!)
              (st-ic-bump-generation!)
              selector)))))))

;; Remove a method from a class (instance side). Mostly for tests; runtime
;; reflection in Phase 4 will use the same primitive.
(define
  st-class-remove-method!
  (fn
    (cls-name selector)
    (let ((cls (st-class-get cls-name)))
      (cond
        ((= cls nil) (error (str "st-class-remove-method!: unknown class " cls-name)))
        (else
          (let ((md (get cls :methods)))
            (cond
              ((not (has-key? md selector)) false)
              (else
                (let ((new-md {}))
                  (begin
                    (for-each
                      (fn (k)
                        (when (not (= k selector))
                          (dict-set! new-md k (get md k))))
                      (keys md))
                    (set!
                      st-class-table
                      (assoc
                        st-class-table
                        cls-name
                        (assoc cls :methods new-md)))
                    (st-method-cache-clear!)
                    (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?)
    (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.
(define
  st-method-lookup
  (fn
    (cls-name selector class-side?)
    (let ((key (st-method-cache-key cls-name selector class-side?)))
      (cond
        ((has-key? st-method-cache key)
          (begin
            (set! st-method-cache-hits (+ st-method-cache-hits 1))
            (let ((v (get st-method-cache key)))
              (cond ((= v :not-found) nil) (else v)))))
        (else
          (begin
            (set! st-method-cache-misses (+ st-method-cache-misses 1))
            (let ((found (st-method-lookup-walk cls-name selector class-side?)))
              (begin
                (set!
                  st-method-cache
                  (assoc
                    st-method-cache
                    key
                    (cond ((= found nil) :not-found) (else found))))
                found))))))))

;; SX value → Smalltalk class name. Native types are not boxed.
(define
  st-class-of
  (fn
    (v)
    (cond
      ((= v nil) "UndefinedObject")
      ((= v true) "True")
      ((= v false) "False")
      ((integer? v) "SmallInteger")
      ((number? v) "Float")
      ((string? v) "String")
      ((symbol? v) "Symbol")
      ((list? v) "Array")
      ((and (dict? v) (has-key? v :type) (= (get v :type) "st-instance"))
        (get v :class))
      ((and (dict? v) (has-key? v :type) (= (get v :type) "block"))
        "BlockClosure")
      ((and (dict? v) (has-key? v :st-block?) (get v :st-block?))
        "BlockClosure")
      ((dict? v) "Dictionary")
      ((lambda? v) "BlockClosure")
      (else "Object"))))

;; Construct a fresh instance of cls-name. Ivars (own + inherited) start as nil.
(define
  st-make-instance
  (fn
    (cls-name)
    (cond
      ((not (st-class-exists? cls-name))
        (error (str "st-make-instance: unknown class " cls-name)))
      (else
        (let
          ((iv-names (st-class-all-ivars cls-name)) (ivars {}))
          (begin
            (for-each (fn (n) (set! ivars (assoc ivars n nil))) iv-names)
            {:type "st-instance" :class cls-name :ivars ivars}))))))

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

(define
  st-iv-get
  (fn
    (inst name)
    (let ((ivs (get inst :ivars)))
      (if (has-key? ivs name) (get ivs name) nil))))

(define
  st-iv-set!
  (fn
    (inst name value)
    (let
      ((new-ivars (assoc (get inst :ivars) name value)))
      (assoc inst :ivars new-ivars))))

;; Inherits-from check: is `descendant` either equal to `ancestor` or a subclass?
(define
  st-class-inherits-from?
  (fn
    (descendant ancestor)
    (let ((found false) (cur descendant))
      (begin
        (define
          ih-loop
          (fn
            ()
            (when
              (and (not found) (not (= cur nil)) (st-class-exists? cur))
              (cond
                ((= cur ancestor) (set! found true))
                (else
                  (begin
                    (set! cur (st-class-superclass cur))
                    (ih-loop)))))))
        (ih-loop)
        found))))

;; Bootstrap the canonical class hierarchy. Reset and rebuild.
(define
  st-bootstrap-classes!
  (fn
    ()
    (begin
      (st-class-table-clear!)
      ;; Root
      (st-class-define! "Object" nil (list))
      ;; Class side machinery
      (st-class-define! "Behavior" "Object" (list "superclass" "methodDict" "format"))
      (st-class-define! "ClassDescription" "Behavior" (list "instanceVariables" "organization"))
      (st-class-define! "Class" "ClassDescription" (list "name" "subclasses"))
      (st-class-define! "Metaclass" "ClassDescription" (list "thisClass"))
      ;; Pseudo-variable types
      (st-class-define! "UndefinedObject" "Object" (list))
      (st-class-define! "Boolean" "Object" (list))
      (st-class-define! "True" "Boolean" (list))
      (st-class-define! "False" "Boolean" (list))
      ;; Magnitudes
      (st-class-define! "Magnitude" "Object" (list))
      (st-class-define! "Number" "Magnitude" (list))
      (st-class-define! "Integer" "Number" (list))
      (st-class-define! "SmallInteger" "Integer" (list))
      (st-class-define! "LargePositiveInteger" "Integer" (list))
      (st-class-define! "Float" "Number" (list))
      (st-class-define! "Fraction" "Number" (list "numerator" "denominator"))
      (st-class-define! "Character" "Magnitude" (list "value"))
      ;; Collections
      (st-class-define! "Collection" "Object" (list))
      (st-class-define! "SequenceableCollection" "Collection" (list))
      (st-class-define! "ArrayedCollection" "SequenceableCollection" (list))
      (st-class-define! "Array" "ArrayedCollection" (list))
      (st-class-define! "String" "ArrayedCollection" (list))
      (st-class-define! "Symbol" "String" (list))
      (st-class-define! "OrderedCollection" "SequenceableCollection" (list "array" "firstIndex" "lastIndex"))
      ;; Hashed collection family
      (st-class-define! "HashedCollection" "Collection" (list "array"))
      (st-class-define! "Set" "HashedCollection" (list))
      ;; Blocks / contexts
      (st-class-define! "BlockClosure" "Object" (list))
      ;; Reflection support — Message holds the selector/args for a DNU send.
      (st-class-define! "Message" "Object" (list "selector" "arguments"))
      (st-class-add-method! "Message" "selector"
        (st-parse-method "selector ^ selector"))
      (st-class-add-method! "Message" "arguments"
        (st-parse-method "arguments ^ arguments"))
      (st-class-add-method! "Message" "selector:"
        (st-parse-method "selector: aSym selector := aSym"))
      (st-class-add-method! "Message" "arguments:"
        (st-parse-method "arguments: anArray arguments := anArray"))
      ;; Exception hierarchy — Smalltalk's standard error system on top of
      ;; SX's `guard`/`raise`. Subclassing Exception gives you on:do:,
      ;; ensure:, ifCurtailed: catching out of the box.
      (st-class-define! "Exception" "Object" (list "messageText"))
      (st-class-add-method! "Exception" "messageText"
        (st-parse-method "messageText ^ messageText"))
      (st-class-add-method! "Exception" "messageText:"
        (st-parse-method "messageText: aString messageText := aString. ^ self"))
      (st-class-define! "Error" "Exception" (list))
      (st-class-define! "ZeroDivide" "Error" (list))
      (st-class-define! "MessageNotUnderstood" "Error" (list))
      ;; SequenceableCollection — shared iteration / inspection methods.
      ;; Defined on the parent class so Array, String, Symbol, and
      ;; OrderedCollection all inherit. Each method calls `self do:`,
      ;; which dispatches to the receiver's primitive do: implementation.
      (st-class-add-method! "SequenceableCollection" "inject:into:"
        (st-parse-method
          "inject: initial into: aBlock
             | acc |
             acc := initial.
             self do: [:e | acc := aBlock value: acc value: e].
             ^ acc"))
      (st-class-add-method! "SequenceableCollection" "detect:"
        (st-parse-method
          "detect: aBlock
             self do: [:e | (aBlock value: e) ifTrue: [^ e]].
             ^ nil"))
      (st-class-add-method! "SequenceableCollection" "detect:ifNone:"
        (st-parse-method
          "detect: aBlock ifNone: noneBlock
             self do: [:e | (aBlock value: e) ifTrue: [^ e]].
             ^ noneBlock value"))
      (st-class-add-method! "SequenceableCollection" "count:"
        (st-parse-method
          "count: aBlock
             | n |
             n := 0.
             self do: [:e | (aBlock value: e) ifTrue: [n := n + 1]].
             ^ n"))
      (st-class-add-method! "SequenceableCollection" "allSatisfy:"
        (st-parse-method
          "allSatisfy: aBlock
             self do: [:e | (aBlock value: e) ifFalse: [^ false]].
             ^ true"))
      (st-class-add-method! "SequenceableCollection" "anySatisfy:"
        (st-parse-method
          "anySatisfy: aBlock
             self do: [:e | (aBlock value: e) ifTrue: [^ true]].
             ^ false"))
      (st-class-add-method! "SequenceableCollection" "includes:"
        (st-parse-method
          "includes: target
             self do: [:e | e = target ifTrue: [^ true]].
             ^ false"))
      (st-class-add-method! "SequenceableCollection" "do:separatedBy:"
        (st-parse-method
          "do: aBlock separatedBy: sepBlock
             | first |
             first := true.
             self do: [:e |
               first ifFalse: [sepBlock value].
               first := false.
               aBlock value: e].
             ^ self"))
      (st-class-add-method! "SequenceableCollection" "indexOf:"
        (st-parse-method
          "indexOf: target
             | idx |
             idx := 1.
             self do: [:e | e = target ifTrue: [^ idx]. idx := idx + 1].
             ^ 0"))
      (st-class-add-method! "SequenceableCollection" "indexOf:ifAbsent:"
        (st-parse-method
          "indexOf: target ifAbsent: noneBlock
             | idx |
             idx := 1.
             self do: [:e | e = target ifTrue: [^ idx]. idx := idx + 1].
             ^ noneBlock value"))
      (st-class-add-method! "SequenceableCollection" "reject:"
        (st-parse-method
          "reject: aBlock ^ self select: [:e | (aBlock value: e) not]"))
      (st-class-add-method! "SequenceableCollection" "isEmpty"
        (st-parse-method "isEmpty ^ self size = 0"))
      (st-class-add-method! "SequenceableCollection" "notEmpty"
        (st-parse-method "notEmpty ^ self size > 0"))
      ;; (no asString here — Symbol/String have their own primitive
      ;; impls; SequenceableCollection-level fallback would overwrite
      ;; the bare-name-for-Symbol behaviour.)
      ;; Array class-side constructors for small fixed-arity literals.
      (st-class-add-class-method! "Array" "with:"
        (st-parse-method
          "with: x | a | a := Array new: 1. a at: 1 put: x. ^ a"))
      (st-class-add-class-method! "Array" "with:with:"
        (st-parse-method
          "with: a with: b
             | r | r := Array new: 2.
             r at: 1 put: a. r at: 2 put: b. ^ r"))
      (st-class-add-class-method! "Array" "with:with:with:"
        (st-parse-method
          "with: a with: b with: c
             | r | r := Array new: 3.
             r at: 1 put: a. r at: 2 put: b. r at: 3 put: c. ^ r"))
      (st-class-add-class-method! "Array" "with:with:with:with:"
        (st-parse-method
          "with: a with: b with: c with: d
             | r | r := Array new: 4.
             r at: 1 put: a. r at: 2 put: b. r at: 3 put: c. r at: 4 put: d. ^ r"))
      ;; ── HashedCollection / Set / Dictionary ──
      ;; Implemented as user instances with array-backed storage. Sets
      ;; use a single `array` ivar; Dictionaries use parallel `keys`/
      ;; `values` arrays. New is class-side and routes through `init`.
      (st-class-add-method! "HashedCollection" "init"
        (st-parse-method "init array := Array new: 0. ^ self"))
      (st-class-add-method! "HashedCollection" "size"
        (st-parse-method "size ^ array size"))
      (st-class-add-method! "HashedCollection" "isEmpty"
        (st-parse-method "isEmpty ^ array isEmpty"))
      (st-class-add-method! "HashedCollection" "notEmpty"
        (st-parse-method "notEmpty ^ array notEmpty"))
      (st-class-add-method! "HashedCollection" "do:"
        (st-parse-method "do: aBlock array do: aBlock. ^ self"))
      (st-class-add-method! "HashedCollection" "asArray"
        (st-parse-method "asArray ^ array"))
      (st-class-add-class-method! "Set" "new"
        (st-parse-method "new ^ super new init"))
      (st-class-add-method! "Set" "add:"
        (st-parse-method
          "add: anObject
             (self includes: anObject) ifFalse: [array add: anObject].
             ^ anObject"))
      (st-class-add-method! "Set" "addAll:"
        (st-parse-method
          "addAll: aCollection
             aCollection do: [:e | self add: e].
             ^ aCollection"))
      (st-class-add-method! "Set" "remove:"
        (st-parse-method
          "remove: anObject
             array := array reject: [:e | e = anObject].
             ^ anObject"))
      (st-class-add-method! "Set" "includes:"
        (st-parse-method "includes: anObject ^ array includes: anObject"))
      (st-class-define! "Dictionary" "HashedCollection" (list "keys" "values"))
      (st-class-add-class-method! "Dictionary" "new"
        (st-parse-method "new ^ super new init"))
      (st-class-add-method! "Dictionary" "init"
        (st-parse-method
          "init keys := Array new: 0. values := Array new: 0. ^ self"))
      (st-class-add-method! "Dictionary" "size"
        (st-parse-method "size ^ keys size"))
      (st-class-add-method! "Dictionary" "isEmpty"
        (st-parse-method "isEmpty ^ keys isEmpty"))
      (st-class-add-method! "Dictionary" "notEmpty"
        (st-parse-method "notEmpty ^ keys notEmpty"))
      (st-class-add-method! "Dictionary" "keys"
        (st-parse-method "keys ^ keys"))
      (st-class-add-method! "Dictionary" "values"
        (st-parse-method "values ^ values"))
      (st-class-add-method! "Dictionary" "at:"
        (st-parse-method
          "at: aKey
             | i |
             i := keys indexOf: aKey.
             i = 0 ifTrue: [^ nil].
             ^ values at: i"))
      (st-class-add-method! "Dictionary" "at:ifAbsent:"
        (st-parse-method
          "at: aKey ifAbsent: aBlock
             | i |
             i := keys indexOf: aKey.
             i = 0 ifTrue: [^ aBlock value].
             ^ values at: i"))
      (st-class-add-method! "Dictionary" "at:put:"
        (st-parse-method
          "at: aKey put: aValue
             | i |
             i := keys indexOf: aKey.
             i = 0
               ifTrue: [keys add: aKey. values add: aValue]
               ifFalse: [values at: i put: aValue].
             ^ aValue"))
      (st-class-add-method! "Dictionary" "includesKey:"
        (st-parse-method "includesKey: aKey ^ (keys indexOf: aKey) > 0"))
      (st-class-add-method! "Dictionary" "removeKey:"
        (st-parse-method
          "removeKey: aKey
             | i nk nv j |
             i := keys indexOf: aKey.
             i = 0 ifTrue: [^ nil].
             nk := Array new: 0. nv := Array new: 0.
             j := 1.
             [j <= keys size] whileTrue: [
               j = i ifFalse: [
                 nk add: (keys at: j).
                 nv add: (values at: j)].
               j := j + 1].
             keys := nk. values := nv.
             ^ aKey"))
      (st-class-add-method! "Dictionary" "do:"
        (st-parse-method "do: aBlock values do: aBlock. ^ self"))
      (st-class-add-method! "Dictionary" "keysDo:"
        (st-parse-method "keysDo: aBlock keys do: aBlock. ^ self"))
      (st-class-add-method! "Dictionary" "valuesDo:"
        (st-parse-method "valuesDo: aBlock values do: aBlock. ^ self"))
      (st-class-add-method! "Dictionary" "keysAndValuesDo:"
        (st-parse-method
          "keysAndValuesDo: aBlock
             | i |
             i := 1.
             [i <= keys size] whileTrue: [
               aBlock value: (keys at: i) value: (values at: i).
               i := i + 1].
             ^ self"))
      (st-class-define! "IdentityDictionary" "Dictionary" (list))
      ;; ── Stream hierarchy ──
      ;; Streams wrap a collection with a 0-based `position`. Read/peek
      ;; advance via `at:` (1-indexed Smalltalk-style) on the collection.
      ;; Write streams require a mutable collection (Array works; String
      ;; doesn't, see Phase 5 follow-up).
      (st-class-define! "Stream" "Object" (list))
      (st-class-define! "PositionableStream" "Stream" (list "collection" "position"))
      (st-class-define! "ReadStream" "PositionableStream" (list))
      (st-class-define! "WriteStream" "PositionableStream" (list))
      (st-class-define! "ReadWriteStream" "WriteStream" (list))
      (st-class-add-class-method! "ReadStream" "on:"
        (st-parse-method "on: aColl ^ super new on: aColl"))
      (st-class-add-class-method! "WriteStream" "on:"
        (st-parse-method "on: aColl ^ super new on: aColl"))
      (st-class-add-class-method! "WriteStream" "with:"
        (st-parse-method
          "with: aColl
             | s |
             s := super new on: aColl.
             s setToEnd.
             ^ s"))
      (st-class-add-class-method! "ReadWriteStream" "on:"
        (st-parse-method "on: aColl ^ super new on: aColl"))
      (st-class-add-method! "PositionableStream" "on:"
        (st-parse-method
          "on: aColl collection := aColl. position := 0. ^ self"))
      (st-class-add-method! "PositionableStream" "atEnd"
        (st-parse-method "atEnd ^ position >= collection size"))
      (st-class-add-method! "PositionableStream" "position"
        (st-parse-method "position ^ position"))
      (st-class-add-method! "PositionableStream" "position:"
        (st-parse-method "position: n position := n. ^ self"))
      (st-class-add-method! "PositionableStream" "reset"
        (st-parse-method "reset position := 0. ^ self"))
      (st-class-add-method! "PositionableStream" "setToEnd"
        (st-parse-method "setToEnd position := collection size. ^ self"))
      (st-class-add-method! "PositionableStream" "contents"
        (st-parse-method "contents ^ collection"))
      (st-class-add-method! "PositionableStream" "skip:"
        (st-parse-method "skip: n position := position + n. ^ self"))
      (st-class-add-method! "ReadStream" "next"
        (st-parse-method
          "next
             self atEnd ifTrue: [^ nil].
             position := position + 1.
             ^ collection at: position"))
      (st-class-add-method! "ReadStream" "peek"
        (st-parse-method
          "peek
             self atEnd ifTrue: [^ nil].
             ^ collection at: position + 1"))
      (st-class-add-method! "ReadStream" "upToEnd"
        (st-parse-method
          "upToEnd
             | result |
             result := Array new: 0.
             [self atEnd] whileFalse: [result add: self next].
             ^ result"))
      (st-class-add-method! "ReadStream" "next:"
        (st-parse-method
          "next: n
             | result i |
             result := Array new: 0.
             i := 0.
             [(i < n) and: [self atEnd not]] whileTrue: [
               result add: self next.
               i := i + 1].
             ^ result"))
      (st-class-add-method! "WriteStream" "nextPut:"
        (st-parse-method
          "nextPut: anObject
             collection add: anObject.
             position := position + 1.
             ^ anObject"))
      (st-class-add-method! "WriteStream" "nextPutAll:"
        (st-parse-method
          "nextPutAll: aCollection
             aCollection do: [:e | self nextPut: e].
             ^ aCollection"))
      ;; ReadWriteStream inherits from WriteStream + ReadStream behaviour;
      ;; for the simple linear-position model, both nextPut: and next work.
      (st-class-add-method! "ReadWriteStream" "next"
        (st-parse-method
          "next
             self atEnd ifTrue: [^ nil].
             position := position + 1.
             ^ collection at: position"))
      (st-class-add-method! "ReadWriteStream" "peek"
        (st-parse-method
          "peek
             self atEnd ifTrue: [^ nil].
             ^ collection at: position + 1"))
      ;; ── Fraction ──
      ;; Rational numbers stored as numerator/denominator, normalized
      ;; (sign on numerator, denominator > 0, reduced via gcd).
      (st-class-add-class-method! "Fraction" "numerator:denominator:"
        (st-parse-method
          "numerator: n denominator: d
             | f |
             f := super new.
             ^ f setNumerator: n denominator: d"))
      (st-class-add-method! "Fraction" "setNumerator:denominator:"
        (st-parse-method
          "setNumerator: n denominator: d
             | g s nn dd |
             d = 0 ifTrue: [Error signal: 'Fraction denominator cannot be zero'].
             s := (d < 0) ifTrue: [-1] ifFalse: [1].
             nn := n * s. dd := d * s.
             g := nn abs gcd: dd.
             g = 0 ifTrue: [g := 1].
             numerator := nn / g.
             denominator := dd / g.
             ^ self"))
      (st-class-add-method! "Fraction" "numerator"
        (st-parse-method "numerator ^ numerator"))
      (st-class-add-method! "Fraction" "denominator"
        (st-parse-method "denominator ^ denominator"))
      (st-class-add-method! "Fraction" "+"
        (st-parse-method
          "+ other
             ^ Fraction
                 numerator: numerator * other denominator + (other numerator * denominator)
                 denominator: denominator * other denominator"))
      (st-class-add-method! "Fraction" "-"
        (st-parse-method
          "- other
             ^ Fraction
                 numerator: numerator * other denominator - (other numerator * denominator)
                 denominator: denominator * other denominator"))
      (st-class-add-method! "Fraction" "*"
        (st-parse-method
          "* other
             ^ Fraction
                 numerator: numerator * other numerator
                 denominator: denominator * other denominator"))
      (st-class-add-method! "Fraction" "/"
        (st-parse-method
          "/ other
             ^ Fraction
                 numerator: numerator * other denominator
                 denominator: denominator * other numerator"))
      (st-class-add-method! "Fraction" "negated"
        (st-parse-method
          "negated ^ Fraction numerator: numerator negated denominator: denominator"))
      (st-class-add-method! "Fraction" "reciprocal"
        (st-parse-method
          "reciprocal ^ Fraction numerator: denominator denominator: numerator"))
      (st-class-add-method! "Fraction" "="
        (st-parse-method
          "= other
             ^ numerator = other numerator and: [denominator = other denominator]"))
      (st-class-add-method! "Fraction" "<"
        (st-parse-method
          "< other
             ^ numerator * other denominator < (other numerator * denominator)"))
      (st-class-add-method! "Fraction" "asFloat"
        (st-parse-method "asFloat ^ numerator / denominator"))
      (st-class-add-method! "Fraction" "printString"
        (st-parse-method
          "printString ^ numerator printString , '/' , denominator printString"))
      (st-class-add-method! "Fraction" "isFraction"
        (st-parse-method "isFraction ^ true"))
      "ok")))

;; Initialise on load. Tests can re-bootstrap to reset state.
(st-bootstrap-classes!)
