smalltalk: Behavior>>compile: + addSelector:/removeSelector: + 9 tests

lib/smalltalk/eval.sx

@@ -872,6 +872,29 @@
              (= selector "category:")
              (= selector "comment:"))
           cref)
+        ;; Behavior>>compile: parses the source string as a method and
+        ;; installs it. Returns the selector as a symbol.
+        ;; Sister forms: compile:classified: and compile:notifying:
+        ;; ignore the extra arg, mirroring Pharo's tolerant behaviour.
+        ((or (= selector "compile:")
+             (= selector "compile:classified:")
+             (= selector "compile:notifying:"))
+          (let ((src (nth args 0)))
+            (let ((method-ast (st-parse-method (str src))))
+              (st-class-add-method!
+                name (get method-ast :selector) method-ast)
+              (make-symbol (get method-ast :selector)))))
+        ((or (= selector "addSelector:withMethod:")
+             (= selector "addSelector:method:"))
+          (let
+            ((sel (str (nth args 0)))
+              (method-ast (nth args 1)))
+            (begin
+              (st-class-add-method! name sel method-ast)
+              (make-symbol sel))))
+        ((= selector "removeSelector:")
+          (let ((sel (str (nth args 0))))
+            (st-class-remove-method! name sel)))
         ((= selector "printString") name)
         ((= selector "class") (st-class-ref "Metaclass"))
         ((= selector "==") (and (st-class-ref? (nth args 0))

lib/smalltalk/tests/reflection.sx

@@ -189,4 +189,53 @@
 (st-test "respondsTo: with string arg"
   (evp "^ Cat new respondsTo: 'miaow'") true)
 
-(list st-test-pass st-test-fail)
+;; ── 18. Behavior>>compile: — runtime method addition ──
+(st-test "compile: a unary method"
+  (begin
+    (evp "Cat compile: 'whisker ^ 99'")
+    (evp "^ Cat new whisker"))
+  99)
+
+(st-test "compile: returns the selector as a symbol"
+  (str (evp "^ Cat compile: 'twitch ^ #twitch'"))
+  "twitch")
+
+(st-test "compile: a keyword method"
+  (begin
+    (evp "Cat compile: 'doubled: x ^ x * 2'")
+    (evp "^ Cat new doubled: 21"))
+  42)
+
+(st-test "compile: a method with temps and blocks"
+  (begin
+    (evp "Cat compile: 'sumTo: n | s | s := 0. 1 to: n do: [:i | s := s + i]. ^ s'")
+    (evp "^ Cat new sumTo: 10"))
+  55)
+
+(st-test "recompile overrides existing method"
+  (begin
+    (evp "Cat compile: 'miaow ^ #ahem'")
+    (str (evp "^ Cat new miaow")))
+  "ahem")
+
+;; methodDict reflects the new method.
+(st-test "compile: registers in methodDict"
+  (has-key? (ev "Cat methodDict") "whisker") true)
+
+;; respondsTo: notices the new method.
+(st-test "respondsTo: sees compiled method"
+  (evp "^ Cat new respondsTo: #whisker") true)
+
+;; Behavior>>removeSelector: takes a method back out.
+(st-test "removeSelector: drops the method"
+  (begin
+    (evp "Cat removeSelector: #whisker")
+    (evp "^ Cat new respondsTo: #whisker"))
+  false)
+
+;; compile:classified: ignores the extra arg.
+(st-test "compile:classified: works"
+  (begin
+    (evp "Cat compile: 'taggedMethod ^ #yes' classified: 'demo'")
+    (str (evp "^ Cat new taggedMethod")))
+  "yes")