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

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

(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 {}}))
      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))))
              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))))
              selector)))))))

;; Method lookup: walk superclass chain starting at `cls-name`.
;; class-side? = true searches :class-methods, false searches :methods.
;; Returns the method record (with :defining-class) or nil.
(define
  st-method-lookup
  (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))))

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

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