giles
45147bd8a6
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Has been cancelled
398 lines
12 KiB
Plaintext
398 lines
12 KiB
Plaintext
;; 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"))
|
|
"ok")))
|
|
|
|
;; Initialise on load. Tests can re-bootstrap to reset state.
|
|
(st-bootstrap-classes!)
|