giles
1c4ac47450
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Has been cancelled
193 lines
7.4 KiB
Plaintext
193 lines
7.4 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)
|
|
|
|
(list st-test-pass st-test-fail)
|