giles
fdd8e18cc3
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Has been cancelled
305 lines
10 KiB
Plaintext
305 lines
10 KiB
Plaintext
;; 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)
|