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