smalltalk: Object>>perform: family + 10 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:
@@ -529,6 +529,16 @@
|
||||
(cond
|
||||
((st-class-ref? receiver) (st-class-ref "Metaclass"))
|
||||
(else (st-class-ref cls))))
|
||||
;; perform: / perform:with: / perform:withArguments:
|
||||
((= selector "perform:")
|
||||
(st-send receiver (str (nth args 0)) (list)))
|
||||
((= selector "perform:withArguments:")
|
||||
(st-send receiver (str (nth args 0)) (nth args 1)))
|
||||
((or (= selector "perform:with:")
|
||||
(= selector "perform:with:with:")
|
||||
(= selector "perform:with:with:with:")
|
||||
(= selector "perform:with:with:with:with:"))
|
||||
(st-send receiver (str (nth args 0)) (slice args 1 (len args))))
|
||||
((or (= cls "SmallInteger") (= cls "Float"))
|
||||
(st-num-send receiver selector args))
|
||||
((or (= cls "String") (= cls "Symbol"))
|
||||
|
||||
@@ -85,4 +85,60 @@
|
||||
(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)
|
||||
|
||||
@@ -80,7 +80,7 @@ Core mapping:
|
||||
|
||||
### Phase 4 — reflection + MOP
|
||||
- [x] `Object>>class`, `class>>name`, `class>>superclass`, `class>>methodDict`, `class>>selectors`. `class` is universal in `st-primitive-send` (returns `Metaclass` for class-refs, the receiver's class otherwise). Class-side dispatch gains `methodDict`/`classMethodDict` (raw dict), `selectors`/`classSelectors` (Array of symbols), `instanceVariableNames` (own), `allInstVarNames` (inherited + own). 26 tests in `lib/smalltalk/tests/reflection.sx`.
|
||||
- [ ] `Object>>perform:` / `perform:with:` / `perform:withArguments:`
|
||||
- [x] `Object>>perform:` / `perform:with:` / `perform:with:with:` / `perform:with:with:with:` / `perform:with:with:with:with:` / `perform:withArguments:`. Universal in `st-primitive-send`; routes back through `st-send` so user methods, primitives, super, and DNU all still apply. Selector arg can be a symbol or string (we `str` it). 10 new tests in `lib/smalltalk/tests/reflection.sx`.
|
||||
- [ ] `Object>>respondsTo:`, `Object>>isKindOf:`, `Object>>isMemberOf:`
|
||||
- [ ] `Behavior>>compile:` — runtime method addition
|
||||
- [ ] `Object>>becomeForward:` (one-way become; rewrites the class field of `aReceiver`)
|
||||
@@ -108,6 +108,7 @@ Core mapping:
|
||||
|
||||
_Newest first. Agent appends on every commit._
|
||||
|
||||
- 2026-04-25: `Object>>perform:` family + 10 tests. Universal dispatch via `st-send` after `(str (nth args 0))` for the selector. 439/439 total.
|
||||
- 2026-04-25: Phase 4 reflection accessors (`lib/smalltalk/tests/reflection.sx`, 26 tests). Universal `Object>>class`, plus `methodDict`/`selectors`/`instanceVariableNames`/`allInstVarNames`/`classMethodDict`/`classSelectors` on class-refs. 429/429 total.
|
||||
- 2026-04-25: conformance.sh + scoreboard.{json,md} (`lib/smalltalk/conformance.sh`, `lib/smalltalk/scoreboard.json`, `lib/smalltalk/scoreboard.md`). Single-pass runner over `test.sh -v`; baseline at 5 programs / 39 corpus tests / 403 total. **Phase 3 complete.**
|
||||
- 2026-04-25: classic-corpus #5 Life (`tests/programs/life.st`, 4 tests). Spec-interpreter Conway's Life with edge handling. Block + blinker + glider initial setup verified; larger step counts pending JIT (each spec-interpreter step is ~5-8s on a 5x5 grid). Added `{e1. e2. e3}` dynamic array literal to parser + evaluator. 403/403 total.
|
||||
|
||||
Reference in New Issue
Block a user