rose-ash/lib/smalltalk/tests/runtime.sx

;; Smalltalk runtime tests — class table, type→class mapping, instances.
;;
;; Reuses helpers (st-test, st-deep=?) from tokenize.sx. Counters reset
;; here so this file's summary covers runtime tests only.

(set! st-test-pass 0)
(set! st-test-fail 0)
(set! st-test-fails (list))

;; Fresh hierarchy for every test file.
(st-bootstrap-classes!)

;; ── 1. Bootstrap installed expected classes ──
(st-test "Object exists" (st-class-exists? "Object") true)
(st-test "Behavior exists" (st-class-exists? "Behavior") true)
(st-test "Metaclass exists" (st-class-exists? "Metaclass") true)
(st-test "True/False/UndefinedObject"
  (and
    (st-class-exists? "True")
    (st-class-exists? "False")
    (st-class-exists? "UndefinedObject"))
  true)
(st-test "SmallInteger / Float / Symbol exist"
  (and
    (st-class-exists? "SmallInteger")
    (st-class-exists? "Float")
    (st-class-exists? "Symbol"))
  true)
(st-test "BlockClosure exists" (st-class-exists? "BlockClosure") true)

;; ── 2. Superclass chain ──
(st-test "Object has no superclass" (st-class-superclass "Object") nil)
(st-test "Behavior super = Object" (st-class-superclass "Behavior") "Object")
(st-test "True super = Boolean" (st-class-superclass "True") "Boolean")
(st-test "Symbol super = String" (st-class-superclass "Symbol") "String")
(st-test
  "String chain"
  (st-class-chain "String")
  (list "String" "ArrayedCollection" "SequenceableCollection" "Collection" "Object"))
(st-test
  "SmallInteger chain"
  (st-class-chain "SmallInteger")
  (list "SmallInteger" "Integer" "Number" "Magnitude" "Object"))

;; ── 3. inherits-from? ──
(st-test "True inherits from Boolean" (st-class-inherits-from? "True" "Boolean") true)
(st-test "True inherits from Object" (st-class-inherits-from? "True" "Object") true)
(st-test "True inherits from True" (st-class-inherits-from? "True" "True") true)
(st-test
  "True does not inherit from Number"
  (st-class-inherits-from? "True" "Number")
  false)
(st-test
  "Object does not inherit from Number"
  (st-class-inherits-from? "Object" "Number")
  false)

;; ── 4. type→class mapping ──
(st-test "class-of nil" (st-class-of nil) "UndefinedObject")
(st-test "class-of true" (st-class-of true) "True")
(st-test "class-of false" (st-class-of false) "False")
(st-test "class-of int" (st-class-of 42) "SmallInteger")
(st-test "class-of zero" (st-class-of 0) "SmallInteger")
(st-test "class-of negative int" (st-class-of -3) "SmallInteger")
(st-test "class-of float" (st-class-of 3.14) "Float")
(st-test "class-of string" (st-class-of "hi") "String")
(st-test "class-of symbol" (st-class-of (quote foo)) "Symbol")
(st-test "class-of list" (st-class-of (list 1 2)) "Array")
(st-test "class-of empty list" (st-class-of (list)) "Array")
(st-test "class-of lambda" (st-class-of (fn (x) x)) "BlockClosure")
(st-test "class-of dict" (st-class-of {:a 1}) "Dictionary")

;; ── 5. User class definition ──
(st-class-define! "Account" "Object" (list "balance" "owner"))
(st-class-define! "SavingsAccount" "Account" (list "rate"))

(st-test "Account exists" (st-class-exists? "Account") true)
(st-test "Account super = Object" (st-class-superclass "Account") "Object")
(st-test
  "SavingsAccount chain"
  (st-class-chain "SavingsAccount")
  (list "SavingsAccount" "Account" "Object"))
(st-test
  "SavingsAccount own ivars"
  (get (st-class-get "SavingsAccount") :ivars)
  (list "rate"))
(st-test
  "SavingsAccount inherited+own ivars"
  (st-class-all-ivars "SavingsAccount")
  (list "balance" "owner" "rate"))

;; ── 6. Instance construction ──
(define a1 (st-make-instance "Account"))
(st-test "instance is st-instance" (st-instance? a1) true)
(st-test "instance class" (get a1 :class) "Account")
(st-test "instance ivars start nil" (st-iv-get a1 "balance") nil)
(st-test
  "instance has all expected ivars"
  (sort (keys (get a1 :ivars)))
  (sort (list "balance" "owner")))
(define a2 (st-iv-set! a1 "balance" 100))
(st-test "iv-set! returns updated copy" (st-iv-get a2 "balance") 100)
(st-test "iv-set! does not mutate original" (st-iv-get a1 "balance") nil)
(st-test "class-of instance" (st-class-of a1) "Account")

(define s1 (st-make-instance "SavingsAccount"))
(st-test
  "subclass instance has all inherited ivars"
  (sort (keys (get s1 :ivars)))
  (sort (list "balance" "owner" "rate")))

;; ── 7. Method install + lookup ──
(st-class-add-method!
  "Account"
  "balance"
  (st-parse-method "balance ^ balance"))
(st-class-add-method!
  "Account"
  "deposit:"
  (st-parse-method "deposit: amount balance := balance + amount. ^ self"))

(st-test
  "method registered"
  (has-key? (get (st-class-get "Account") :methods) "balance")
  true)

(st-test
  "method lookup direct"
  (= (st-method-lookup "Account" "balance" false) nil)
  false)

(st-test
  "method lookup walks superclass"
  (= (st-method-lookup "SavingsAccount" "deposit:" false) nil)
  false)

(st-test
  "method lookup unknown selector"
  (st-method-lookup "Account" "frobnicate" false)
  nil)

(st-test
  "method lookup records defining class"
  (get (st-method-lookup "SavingsAccount" "balance" false) :defining-class)
  "Account")

;; SavingsAccount overrides deposit:
(st-class-add-method!
  "SavingsAccount"
  "deposit:"
  (st-parse-method "deposit: amount ^ super deposit: amount + 1"))

(st-test
  "subclass override picked first"
  (get (st-method-lookup "SavingsAccount" "deposit:" false) :defining-class)
  "SavingsAccount")

(st-test
  "Account still finds its own deposit:"
  (get (st-method-lookup "Account" "deposit:" false) :defining-class)
  "Account")

;; ── 8. Class-side methods ──
(st-class-add-class-method!
  "Account"
  "new"
  (st-parse-method "new ^ super new"))
(st-test
  "class-side lookup"
  (= (st-method-lookup "Account" "new" true) nil)
  false)
(st-test
  "instance-side does not find class method"
  (st-method-lookup "Account" "new" false)
  nil)

;; ── 9. Re-bootstrap resets table ──
(st-bootstrap-classes!)
(st-test "after re-bootstrap Account gone" (st-class-exists? "Account") false)
(st-test "after re-bootstrap Object stays" (st-class-exists? "Object") true)

;; ── 10. Method-lookup cache ──
(st-bootstrap-classes!)
(st-class-define! "Foo" "Object" (list))
(st-class-define! "Bar" "Foo" (list))
(st-class-add-method! "Foo" "greet" (st-parse-method "greet ^ 1"))

;; Bootstrap clears cache; record stats from now.
(st-method-cache-reset-stats!)

;; First lookup is a miss; second is a hit.
(st-method-lookup "Bar" "greet" false)
(st-test
  "first lookup recorded as miss"
  (get (st-method-cache-stats) :misses)
  1)
(st-test
  "first lookup recorded as hit count zero"
  (get (st-method-cache-stats) :hits)
  0)

(st-method-lookup "Bar" "greet" false)
(st-test
  "second lookup hits cache"
  (get (st-method-cache-stats) :hits)
  1)

;; Misses are also cached as :not-found.
(st-method-lookup "Bar" "frobnicate" false)
(st-method-lookup "Bar" "frobnicate" false)
(st-test
  "negative-result caches"
  (get (st-method-cache-stats) :hits)
  2)

;; Adding a new method invalidates the cache.
(st-class-add-method! "Bar" "greet" (st-parse-method "greet ^ 2"))
(st-test
  "cache cleared on method add"
  (get (st-method-cache-stats) :size)
  0)
(st-test
  "after invalidation lookup picks up override"
  (get (st-method-lookup "Bar" "greet" false) :defining-class)
  "Bar")

;; Removing a method also invalidates and exposes the inherited one.
(st-class-remove-method! "Bar" "greet")
(st-test
  "after remove lookup falls through to Foo"
  (get (st-method-lookup "Bar" "greet" false) :defining-class)
  "Foo")

;; Cache survives across unrelated class-table mutations? No — define! clears.
(st-method-lookup "Foo" "greet" false)  ; warm cache
(st-class-define! "Baz" "Object" (list))
(st-test
  "class-define clears cache"
  (get (st-method-cache-stats) :size)
  0)

;; Class-side and instance-side cache entries are separate keys.
(st-class-add-class-method! "Foo" "make" (st-parse-method "make ^ self new"))
(st-method-lookup "Foo" "make" true)
(st-method-lookup "Foo" "make" false)
(st-test
  "class-side hit found, instance-side stored as not-found"
  (= (st-method-lookup "Foo" "make" true) nil)
  false)
(st-test
  "instance-side same selector returns nil"
  (st-method-lookup "Foo" "make" false)
  nil)

(list st-test-pass st-test-fail)