smalltalk: respondsTo:/isKindOf:/isMemberOf: + 26 tests

lib/smalltalk/eval.sx

@@ -539,6 +539,32 @@
              (= selector "perform:with:with:with:")
              (= selector "perform:with:with:with:with:"))
           (st-send receiver (str (nth args 0)) (slice args 1 (len args))))
+        ;; respondsTo: aSymbol — searches user method dicts only. Native
+        ;; primitive selectors aren't enumerated, so e.g. `42 respondsTo:
+        ;; #+` returns false. (The send still works because dispatch falls
+        ;; through to st-num-send.) Documented limitation.
+        ((= selector "respondsTo:")
+          (let
+            ((sel-str (str (nth args 0)))
+              (target-cls (if (st-class-ref? receiver) (get receiver :name) cls))
+              (class-side? (st-class-ref? receiver)))
+            (not (= (st-method-lookup target-cls sel-str class-side?) nil))))
+        ;; isKindOf: aClass — true iff the receiver's class chain reaches it.
+        ((= selector "isKindOf:")
+          (let
+            ((arg (nth args 0))
+              (target-cls (if (st-class-ref? receiver) "Metaclass" cls)))
+            (cond
+              ((not (st-class-ref? arg)) false)
+              (else (st-class-inherits-from? target-cls (get arg :name))))))
+        ;; isMemberOf: aClass — exact class match.
+        ((= selector "isMemberOf:")
+          (let
+            ((arg (nth args 0))
+              (target-cls (if (st-class-ref? receiver) "Metaclass" cls)))
+            (cond
+              ((not (st-class-ref? arg)) false)
+              (else (= target-cls (get arg :name))))))
         ((or (= cls "SmallInteger") (= cls "Float"))
           (st-num-send receiver selector args))
         ((or (= cls "String") (= cls "Symbol"))

lib/smalltalk/tests/reflection.sx

@@ -141,4 +141,52 @@
 ;; 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)