giles
4ced16f04e
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Has been cancelled
145 lines
5.0 KiB
Plaintext
145 lines
5.0 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.
|
|
|
|
(list st-test-pass st-test-fail)
|