rose-ash/lib/smalltalk/runtime.sx

;; 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 {})))

(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!)
              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!)
              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!)
                    true))))))))))

;; Walk-only lookup. Returns the method record (with :defining-class) or nil.
;; class-side? = true searches :class-methods, false searches :methods.
(define
  st-method-lookup-walk
  (fn
    (cls-name selector class-side?)
    (let
      ((found nil))
      (begin
        (define
          ml-loop
          (fn
            (cur)
            (when
              (and (= found nil) (not (= cur nil)) (st-class-exists? cur))
              (let
                ((c (st-class-get cur)))
                (let
                  ((dict (if class-side? (get c :class-methods) (get c :methods))))
                  (cond
                    ((has-key? dict selector) (set! found (get dict selector)))
                    (else (ml-loop (get c :superclass)))))))))
        (ml-loop cls-name)
        found))))

;; 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! "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"))
      (st-class-define! "Dictionary" "Collection" (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))
      "ok")))

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