;; Reflection accessors: Object>>class, class>>name, class>>superclass,
;; class>>methodDict, class>>selectors. Phase 4 starting point.

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

(st-bootstrap-classes!)
(define ev (fn (src) (smalltalk-eval src)))
(define evp (fn (src) (smalltalk-eval-program src)))

;; ── 1. Object>>class on native receivers ──
(st-test "42 class name"        (ev "42 class name")     "SmallInteger")
(st-test "3.14 class name"      (ev "3.14 class name")   "Float")
(st-test "'hi' class name"      (ev "'hi' class name")   "String")
(st-test "#foo class name"      (ev "#foo class name")   "Symbol")
(st-test "true class name"      (ev "true class name")   "True")
(st-test "false class name"     (ev "false class name")  "False")
(st-test "nil class name"       (ev "nil class name")    "UndefinedObject")
(st-test "$a class name"        (ev "$a class name")     "String")
(st-test "#(1 2 3) class name"  (ev "#(1 2 3) class name") "Array")
(st-test "[42] class name"      (ev "[42] class name")   "BlockClosure")

;; ── 2. Object>>class on user instances ──
(st-class-define! "Cat" "Object" (list "name"))
(st-test "user instance class name"
  (evp "^ Cat new class name") "Cat")
(st-test "user instance class superclass name"
  (evp "^ Cat new class superclass name") "Object")

;; ── 3. class>>name / class>>superclass ──
(st-test "class>>name on Object" (ev "Object name") "Object")
(st-test "class>>superclass on Object" (ev "Object superclass") nil)
(st-test "class>>superclass on Symbol"
  (ev "Symbol superclass name") "String")
(st-test "class>>superclass on String"
  (ev "String superclass name") "ArrayedCollection")

;; ── 4. class>>class returns Metaclass ──
(st-test "Cat class is Metaclass"
  (ev "Cat class name") "Metaclass")

;; ── 5. class>>methodDict ──
(st-class-add-method! "Cat" "miaow" (st-parse-method "miaow ^ #miaow"))
(st-class-add-method! "Cat" "purr"  (st-parse-method "purr ^ #purr"))

(st-test
  "methodDict has expected keys"
  (sort (keys (ev "Cat methodDict")))
  (sort (list "miaow" "purr")))

(st-test
  "methodDict size after two adds"
  (len (keys (ev "Cat methodDict")))
  2)

;; ── 6. class>>selectors ──
(st-test
  "selectors returns Array of symbols"
  (sort (map (fn (s) (str s)) (ev "Cat selectors")))
  (sort (list "miaow" "purr")))

;; ── 7. class>>instanceVariableNames ──
(st-test "instance variable names"
  (ev "Cat instanceVariableNames") (list "name"))

(st-class-define! "Kitten" "Cat" (list "age"))
(st-test "subclass own ivars"
  (ev "Kitten instanceVariableNames") (list "age"))
(st-test "subclass allInstVarNames includes inherited"
  (ev "Kitten allInstVarNames") (list "name" "age"))

;; ── 8. methodDict reflects new methods ──
(st-class-add-method! "Cat" "scratch" (st-parse-method "scratch ^ #scratch"))
(st-test "methodDict updated after add"
  (len (keys (ev "Cat methodDict"))) 3)

;; ── 9. classMethodDict / classSelectors ──
(st-class-add-class-method! "Cat" "named:"
  (st-parse-method "named: aName ^ self new"))
(st-test "classSelectors"
  (map (fn (s) (str s)) (ev "Cat classSelectors")) (list "named:"))

;; ── 10. Method records are usable values ──
(st-test "methodDict at: returns method record dict"
  (dict? (get (ev "Cat methodDict") "miaow")) true)

;; ── 11. Object>>perform: ──
(st-test "perform: a unary selector"
  (str (evp "^ Cat new perform: #miaow"))
  "miaow")

(st-test "perform: works on native receiver"
  (ev "42 perform: #printString")
  "42")

(st-test "perform: with no method falls back to DNU"
  ;; With no Object DNU defined here, perform: a missing selector raises.
  ;; Wrap in guard to catch.
  (let ((caught false))
    (begin
      (guard (c (true (set! caught true)))
        (evp "^ Cat new perform: #nonexistent"))
      caught))
  true)

;; ── 12. Object>>perform:with: ──
(st-class-add-method! "Cat" "say:"
  (st-parse-method "say: aMsg ^ aMsg"))

(st-test "perform:with: passes arg through"
  (evp "^ Cat new perform: #say: with: 'hi'") "hi")

(st-test "perform:with: on native"
  (ev "10 perform: #+ with: 5") 15)

;; ── 13. Object>>perform:with:with: (multi-arg form) ──
(st-class-add-method! "Cat" "describe:and:"
  (st-parse-method "describe: a and: b ^ a , b"))

(st-test "perform:with:with: keyword selector"
  (evp "^ Cat new perform: #describe:and: with: 'foo' with: 'bar'")
  "foobar")

;; ── 14. Object>>perform:withArguments: ──
(st-test "perform:withArguments: empty array"
  (str (evp "^ Cat new perform: #miaow withArguments: #()"))
  "miaow")

(st-test "perform:withArguments: 1 element"
  (evp "^ Cat new perform: #say: withArguments: #('hello')")
  "hello")

(st-test "perform:withArguments: 2 elements"
  (evp "^ Cat new perform: #describe:and: withArguments: #('a' 'b')")
  "ab")

(st-test "perform:withArguments: on native receiver"
  (ev "20 perform: #+ withArguments: #(5)") 25)

;; perform: routes through ordinary dispatch, so super, DNU, primitives
;; all still apply naturally. No special test for that — it's free.

;; ── 15. isKindOf: walks the class chain ──
(st-test "42 isKindOf: SmallInteger"  (ev "42 isKindOf: SmallInteger") true)
(st-test "42 isKindOf: Integer"        (ev "42 isKindOf: Integer")      true)
(st-test "42 isKindOf: Number"         (ev "42 isKindOf: Number")       true)
(st-test "42 isKindOf: Magnitude"      (ev "42 isKindOf: Magnitude")    true)
(st-test "42 isKindOf: Object"         (ev "42 isKindOf: Object")       true)
(st-test "42 isKindOf: String"         (ev "42 isKindOf: String")       false)
(st-test "3.14 isKindOf: Float"        (ev "3.14 isKindOf: Float")      true)
(st-test "3.14 isKindOf: Number"       (ev "3.14 isKindOf: Number")     true)

(st-test "'hi' isKindOf: String"        (ev "'hi' isKindOf: String")     true)
(st-test "'hi' isKindOf: ArrayedCollection"
  (ev "'hi' isKindOf: ArrayedCollection") true)
(st-test "true isKindOf: Boolean"       (ev "true isKindOf: Boolean")    true)
(st-test "nil isKindOf: UndefinedObject"
  (ev "nil isKindOf: UndefinedObject") true)

;; User-class chain.
(st-test "Cat new isKindOf: Cat"     (evp "^ Cat new isKindOf: Cat")    true)
(st-test "Cat new isKindOf: Object"  (evp "^ Cat new isKindOf: Object") true)
(st-test "Cat new isKindOf: Boolean"
  (evp "^ Cat new isKindOf: Boolean") false)
(st-test "Kitten new isKindOf: Cat"
  (evp "^ Kitten new isKindOf: Cat") true)

;; ── 16. isMemberOf: requires exact class match ──
(st-test "42 isMemberOf: SmallInteger" (ev "42 isMemberOf: SmallInteger") true)
(st-test "42 isMemberOf: Integer"      (ev "42 isMemberOf: Integer")      false)
(st-test "42 isMemberOf: Number"       (ev "42 isMemberOf: Number")       false)
(st-test "Cat new isMemberOf: Cat"
  (evp "^ Cat new isMemberOf: Cat") true)
(st-test "Cat new isMemberOf: Kitten"
  (evp "^ Cat new isMemberOf: Kitten") false)

;; ── 17. respondsTo: — user method dictionary search ──
(st-test "Cat respondsTo: #miaow"
  (evp "^ Cat new respondsTo: #miaow") true)
(st-test "Cat respondsTo: inherited (only own/super in dict)"
  (evp "^ Kitten new respondsTo: #miaow") true)
(st-test "Cat respondsTo: missing"
  (evp "^ Cat new respondsTo: #noSuchSelector") false)
(st-test "respondsTo: on class-ref searches class side"
  (evp "^ Cat respondsTo: #named:") true)

;; Non-symbol arg coerces via str — also accepts strings.
(st-test "respondsTo: with string arg"
  (evp "^ Cat new respondsTo: 'miaow'") true)

;; ── 18. Behavior>>compile: — runtime method addition ──
(st-test "compile: a unary method"
  (begin
    (evp "Cat compile: 'whisker ^ 99'")
    (evp "^ Cat new whisker"))
  99)

(st-test "compile: returns the selector as a symbol"
  (str (evp "^ Cat compile: 'twitch ^ #twitch'"))
  "twitch")

(st-test "compile: a keyword method"
  (begin
    (evp "Cat compile: 'doubled: x ^ x * 2'")
    (evp "^ Cat new doubled: 21"))
  42)

(st-test "compile: a method with temps and blocks"
  (begin
    (evp "Cat compile: 'sumTo: n | s | s := 0. 1 to: n do: [:i | s := s + i]. ^ s'")
    (evp "^ Cat new sumTo: 10"))
  55)

(st-test "recompile overrides existing method"
  (begin
    (evp "Cat compile: 'miaow ^ #ahem'")
    (str (evp "^ Cat new miaow")))
  "ahem")

;; methodDict reflects the new method.
(st-test "compile: registers in methodDict"
  (has-key? (ev "Cat methodDict") "whisker") true)

;; respondsTo: notices the new method.
(st-test "respondsTo: sees compiled method"
  (evp "^ Cat new respondsTo: #whisker") true)

;; Behavior>>removeSelector: takes a method back out.
(st-test "removeSelector: drops the method"
  (begin
    (evp "Cat removeSelector: #whisker")
    (evp "^ Cat new respondsTo: #whisker"))
  false)

;; compile:classified: ignores the extra arg.
(st-test "compile:classified: works"
  (begin
    (evp "Cat compile: 'taggedMethod ^ #yes' classified: 'demo'")
    (str (evp "^ Cat new taggedMethod")))
  "yes")

;; ── 19. Object>>becomeForward: ──
(st-class-define! "Box" "Object" (list "value"))
(st-class-add-method! "Box" "value"  (st-parse-method "value ^ value"))
(st-class-add-method! "Box" "value:" (st-parse-method "value: v value := v. ^ self"))
(st-class-add-method! "Box" "kind"   (st-parse-method "kind ^ #box"))

(st-class-define! "Crate" "Object" (list "value"))
(st-class-add-method! "Crate" "value"  (st-parse-method "value ^ value"))
(st-class-add-method! "Crate" "value:" (st-parse-method "value: v value := v. ^ self"))
(st-class-add-method! "Crate" "kind"   (st-parse-method "kind ^ #crate"))

(st-test "before becomeForward: instance reports its class"
  (str (evp "^ (Box new value: 1) class name"))
  "Box")

(st-test "becomeForward: changes the receiver's class"
  (evp
    "| a b |
     a := Box new value: 1.
     b := Crate new value: 99.
     a becomeForward: b.
     ^ a class name")
  "Crate")

(st-test "becomeForward: routes future sends through new class"
  (evp
    "| a b |
     a := Box new value: 1.
     b := Crate new value: 99.
     a becomeForward: b.
     ^ a kind")
  (make-symbol "crate"))

(st-test "becomeForward: takes target's ivars"
  (evp
    "| a b |
     a := Box new value: 1.
     b := Crate new value: 99.
     a becomeForward: b.
     ^ a value")
  99)

(st-test "becomeForward: leaves the *target* instance unchanged"
  (evp
    "| a b |
     a := Box new value: 1.
     b := Crate new value: 99.
     a becomeForward: b.
     ^ b kind")
  (make-symbol "crate"))

(st-test "every reference to the receiver sees the new identity"
  (evp
    "| a alias b |
     a := Box new value: 1.
     alias := a.
     b := Crate new value: 99.
     a becomeForward: b.
     ^ alias kind")
  (make-symbol "crate"))

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