smalltalk: super send + top-level temps + 9 super tests
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Has been cancelled
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Has been cancelled
This commit is contained in:
@@ -289,13 +289,13 @@
|
||||
(st-test
|
||||
"return statement at top level"
|
||||
(st-parse "^ 1")
|
||||
{:type "seq"
|
||||
{:type "seq" :temps (list)
|
||||
:exprs (list {:type "return" :expr {:type "lit-int" :value 1}})})
|
||||
|
||||
(st-test
|
||||
"two statements"
|
||||
(st-parse "x := 1. y := 2")
|
||||
{:type "seq"
|
||||
{:type "seq" :temps (list)
|
||||
:exprs (list
|
||||
{:type "assign" :name "x" :expr {:type "lit-int" :value 1}}
|
||||
{:type "assign" :name "y" :expr {:type "lit-int" :value 2}})})
|
||||
@@ -303,7 +303,7 @@
|
||||
(st-test
|
||||
"trailing dot allowed"
|
||||
(st-parse "1. 2.")
|
||||
{:type "seq"
|
||||
{:type "seq" :temps (list)
|
||||
:exprs (list {:type "lit-int" :value 1} {:type "lit-int" :value 2})})
|
||||
|
||||
;; ── 12. Method headers ──
|
||||
|
||||
149
lib/smalltalk/tests/super.sx
Normal file
149
lib/smalltalk/tests/super.sx
Normal file
@@ -0,0 +1,149 @@
|
||||
;; super-send tests.
|
||||
;;
|
||||
;; super looks up methods starting at the *defining class*'s superclass —
|
||||
;; not the receiver's class. This means an inherited method that uses
|
||||
;; `super` always reaches the same parent regardless of where in the
|
||||
;; subclass chain the receiver actually sits.
|
||||
|
||||
(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. Basic super: subclass override calls parent ──
|
||||
(st-class-define! "Animal" "Object" (list))
|
||||
(st-class-add-method! "Animal" "speak"
|
||||
(st-parse-method "speak ^ #generic"))
|
||||
|
||||
(st-class-define! "Dog" "Animal" (list))
|
||||
(st-class-add-method! "Dog" "speak"
|
||||
(st-parse-method "speak ^ super speak"))
|
||||
|
||||
(st-test
|
||||
"super reaches parent's speak"
|
||||
(str (evp "^ Dog new speak"))
|
||||
"generic")
|
||||
|
||||
(st-class-add-method! "Dog" "loud"
|
||||
(st-parse-method "loud ^ super speak , #'!' asString"))
|
||||
;; The above tries to use `, #'!' asString` which won't quite work with my
|
||||
;; primitives. Replace with a simpler test.
|
||||
(st-class-add-method! "Dog" "loud"
|
||||
(st-parse-method "loud | s | s := super speak. ^ s"))
|
||||
|
||||
(st-test
|
||||
"method calls super and returns same"
|
||||
(str (evp "^ Dog new loud"))
|
||||
"generic")
|
||||
|
||||
;; ── 2. Super with argument ──
|
||||
(st-class-add-method! "Animal" "greet:"
|
||||
(st-parse-method "greet: name ^ name , ' (animal)'"))
|
||||
(st-class-add-method! "Dog" "greet:"
|
||||
(st-parse-method "greet: name ^ super greet: name"))
|
||||
|
||||
(st-test
|
||||
"super with arg reaches parent and threads value"
|
||||
(evp "^ Dog new greet: 'Rex'")
|
||||
"Rex (animal)")
|
||||
|
||||
;; ── 3. Inherited method uses *defining* class for super ──
|
||||
;; A defines speak ^ 'A'
|
||||
;; A defines speakLog: which sends `super speak`. super starts at Object → no
|
||||
;; speak there → DNU. So invoke speakLog from A subclass to test that super
|
||||
;; resolves to A's parent (Object), not the subclass's parent.
|
||||
(st-class-define! "RootSpeaker" "Object" (list))
|
||||
(st-class-add-method! "RootSpeaker" "speak"
|
||||
(st-parse-method "speak ^ #root"))
|
||||
(st-class-add-method! "RootSpeaker" "speakDelegate"
|
||||
(st-parse-method "speakDelegate ^ super speak"))
|
||||
;; Object has no speak (and we add a temporary DNU for testing).
|
||||
(st-class-add-method! "Object" "doesNotUnderstand:"
|
||||
(st-parse-method "doesNotUnderstand: aMessage ^ #dnu"))
|
||||
|
||||
(st-class-define! "ChildSpeaker" "RootSpeaker" (list))
|
||||
(st-class-add-method! "ChildSpeaker" "speak"
|
||||
(st-parse-method "speak ^ #child"))
|
||||
|
||||
(st-test
|
||||
"inherited speakDelegate uses RootSpeaker's super, not ChildSpeaker's"
|
||||
(str (evp "^ ChildSpeaker new speakDelegate"))
|
||||
"dnu")
|
||||
|
||||
;; A non-inherited path: ChildSpeaker overrides speak, but speakDelegate is
|
||||
;; inherited from RootSpeaker. The super inside speakDelegate must resolve to
|
||||
;; *Object* (RootSpeaker's parent), not to RootSpeaker (ChildSpeaker's parent).
|
||||
(st-test
|
||||
"inherited method's super does not call subclass override"
|
||||
(str (evp "^ ChildSpeaker new speak"))
|
||||
"child")
|
||||
|
||||
;; Remove the Object DNU shim now that those tests are done.
|
||||
(st-class-remove-method! "Object" "doesNotUnderstand:")
|
||||
|
||||
;; ── 4. Multi-level: A → B → C ──
|
||||
(st-class-define! "GA" "Object" (list))
|
||||
(st-class-add-method! "GA" "level"
|
||||
(st-parse-method "level ^ #ga"))
|
||||
|
||||
(st-class-define! "GB" "GA" (list))
|
||||
(st-class-add-method! "GB" "level"
|
||||
(st-parse-method "level ^ super level"))
|
||||
|
||||
(st-class-define! "GC" "GB" (list))
|
||||
(st-class-add-method! "GC" "level"
|
||||
(st-parse-method "level ^ super level"))
|
||||
|
||||
(st-test
|
||||
"super chains to grandparent"
|
||||
(str (evp "^ GC new level"))
|
||||
"ga")
|
||||
|
||||
;; ── 5. Super inside a block ──
|
||||
(st-class-add-method! "Dog" "delayed"
|
||||
(st-parse-method "delayed ^ [super speak] value"))
|
||||
(st-test
|
||||
"super inside a block resolves correctly"
|
||||
(str (evp "^ Dog new delayed"))
|
||||
"generic")
|
||||
|
||||
;; ── 6. Super send keeps receiver as self ──
|
||||
(st-class-define! "Counter" "Object" (list "count"))
|
||||
(st-class-add-method! "Counter" "init"
|
||||
(st-parse-method "init count := 0. ^ self"))
|
||||
(st-class-add-method! "Counter" "incr"
|
||||
(st-parse-method "incr count := count + 1. ^ self"))
|
||||
(st-class-add-method! "Counter" "count"
|
||||
(st-parse-method "count ^ count"))
|
||||
|
||||
(st-class-define! "DoubleCounter" "Counter" (list))
|
||||
(st-class-add-method! "DoubleCounter" "incr"
|
||||
(st-parse-method "incr super incr. super incr. ^ self"))
|
||||
|
||||
(st-test
|
||||
"super uses same receiver — ivars on self update"
|
||||
(evp "| c | c := DoubleCounter new init. c incr. ^ c count")
|
||||
2)
|
||||
|
||||
;; ── 7. Super on a class without an immediate parent definition ──
|
||||
;; Mid-chain class with no override at this level: super resolves correctly
|
||||
;; through the missing rung.
|
||||
(st-class-define! "Mid" "Animal" (list))
|
||||
(st-class-define! "Pup" "Mid" (list))
|
||||
(st-class-add-method! "Pup" "speak"
|
||||
(st-parse-method "speak ^ super speak"))
|
||||
|
||||
(st-test
|
||||
"super walks past intermediate class with no override"
|
||||
(str (evp "^ Pup new speak"))
|
||||
"generic")
|
||||
|
||||
;; ── 8. Super outside any method errors ──
|
||||
;; (We don't have try/catch in SX from here; skip the negative test —
|
||||
;; documented behaviour is that st-super-send errors when method-class is nil.)
|
||||
|
||||
(list st-test-pass st-test-fail)
|
||||
Reference in New Issue
Block a user