smalltalk: non-local return via captured ^k + 14 nlr tests

lib/smalltalk/eval.sx

@@ -1,28 +1,28 @@
 ;; Smalltalk AST evaluator — sequential semantics. Method dispatch uses the
 ;; class table from runtime.sx; native receivers fall back to a primitive
-;; method table. Non-local return is implemented via a sentinel marker; the
-;; full continuation-based escape is the Phase 3 showcase.
+;; method table. Non-local return is implemented via captured continuations:
+;; each method invocation wraps its body in `call/cc`, the captured k is
+;; stored on the frame as `:return-k`, and `^expr` invokes that k. Blocks
+;; capture their creating method's k so `^` from inside a block returns
+;; from the *creating* method, not the invoking one — this is Smalltalk's
+;; non-local return, the headline of Phase 3.
 ;;
 ;; Frame:
 ;;   {:self V                 ; receiver
 ;;    :method-class N         ; defining class of the executing method
 ;;    :locals (mutable dict)  ; param + temp bindings
-;;    :parent P}              ; outer frame for blocks (nil for top-level)
-;;
-;; `smalltalk-eval-ast(ast, frame)` returns the value or a return marker.
-;; Method invocation unwraps return markers; sequences propagate them.
+;;    :parent P               ; outer frame for blocks (nil for top-level)
+;;    :return-k K}            ; the ^k that ^expr should invoke
 
 (define
   st-make-frame
   (fn
-    (self method-class parent)
-    {:self self :method-class method-class :locals {} :parent parent}))
-
-(define st-return-marker (fn (v) {:st-return true :value v}))
-
-(define
-  st-return-marker?
-  (fn (v) (and (dict? v) (has-key? v :st-return) (= (get v :st-return) true))))
+    (self method-class parent return-k)
+    {:self self
+     :method-class method-class
+     :locals {}
+     :parent parent
+     :return-k return-k}))
 
 (define
   st-make-block
@@ -32,7 +32,10 @@
      :params (get ast :params)
      :temps (get ast :temps)
      :body (get ast :body)
-     :env frame}))
+     :env frame
+     ;; capture the creating method's return continuation so that `^expr`
+     ;; from inside this block always returns from that method
+     :return-k (if (= frame nil) nil (get frame :return-k))}))
 
 (define
   st-block?
@@ -149,7 +152,12 @@
             ((= ty "assign")
               (st-assign! frame (get ast :name) (smalltalk-eval-ast (get ast :expr) frame)))
             ((= ty "return")
-              (st-return-marker (smalltalk-eval-ast (get ast :expr) frame)))
+              (let ((v (smalltalk-eval-ast (get ast :expr) frame)))
+                (let ((k (get frame :return-k)))
+                  (cond
+                    ((= k nil)
+                      (error "smalltalk-eval-ast: return outside method context"))
+                    (else (k v))))))
             ((= ty "block") (st-make-block ast frame))
             ((= ty "seq") (st-eval-seq (get ast :exprs) frame))
             ((= ty "send")
@@ -157,43 +165,20 @@
             ((= ty "cascade") (st-eval-cascade ast frame))
             (else (error (str "smalltalk-eval-ast: unknown type '" ty "'")))))))))
 
+;; Evaluate a sequence; return the last expression's value. `^expr`
+;; mid-sequence transfers control via the frame's :return-k and never
+;; returns to this loop, so we don't need any return-marker plumbing.
 (define
   st-eval-seq
   (fn
     (exprs frame)
     (let ((result nil))
       (begin
-        (define
-          sq-loop
-          (fn
-            (rest)
-            (cond
-              ((= (len rest) 0) nil)
-              (else
-                (let ((v (smalltalk-eval-ast (nth rest 0) frame)))
-                  (cond
-                    ((st-return-marker? v) (set! result v))
-                    ((= (len rest) 1) (set! result v))
-                    (else (sq-loop (rest-of rest)))))))))
-        (sq-loop exprs)
+        (for-each
+          (fn (e) (set! result (smalltalk-eval-ast e frame)))
+          exprs)
         result))))
 
-(define
-  rest-of
-  (fn
-    (lst)
-    (let ((out (list)) (i 1) (n (len lst)))
-      (begin
-        (define
-          ro-loop
-          (fn
-            ()
-            (when
-              (< i n)
-              (begin (append! out (nth lst i)) (set! i (+ i 1)) (ro-loop)))))
-        (ro-loop)
-        out))))
-
 (define
   st-eval-send
   (fn
@@ -333,6 +318,12 @@
                         (else p)))))))))))))
 
 ;; ── Method invocation ──────────────────────────────────────────────────
+;;
+;; Method body is wrapped in (call/cc (fn (k) ...)). The k is bound on the
+;; method's frame as :return-k. `^expr` invokes k, which abandons the body
+;; and resumes call/cc with v. Blocks that escape with `^` capture the
+;; *creating* method's k, so non-local return reaches back through any
+;; number of nested block.value calls.
 (define
   st-invoke
   (fn
@@ -349,35 +340,35 @@
               (get method :selector)
               " expected " (len params) " got " (len args))))
         (else
-          (let
-            ((frame (st-make-frame receiver defining-class nil)))
-            (begin
-              ;; Bind params
-              (let ((i 0))
+          (call/cc
+            (fn (k)
+              (let ((frame (st-make-frame receiver defining-class nil k)))
                 (begin
-                  (define
-                    pb-loop
-                    (fn
-                      ()
-                      (when
-                        (< i (len params))
-                        (begin
-                          (dict-set!
-                            (get frame :locals)
-                            (nth params i)
-                            (nth args i))
-                          (set! i (+ i 1))
-                          (pb-loop)))))
-                  (pb-loop)))
-              ;; Bind temps to nil
-              (for-each
-                (fn (t) (dict-set! (get frame :locals) t nil))
-                temps)
-              ;; Execute body
-              (let ((result (st-eval-seq body frame)))
-                (cond
-                  ((st-return-marker? result) (get result :value))
-                  (else receiver))))))))))
+                  ;; Bind params
+                  (let ((i 0))
+                    (begin
+                      (define
+                        pb-loop
+                        (fn
+                          ()
+                          (when
+                            (< i (len params))
+                            (begin
+                              (dict-set!
+                                (get frame :locals)
+                                (nth params i)
+                                (nth args i))
+                              (set! i (+ i 1))
+                              (pb-loop)))))
+                      (pb-loop)))
+                  ;; Bind temps to nil
+                  (for-each
+                    (fn (t) (dict-set! (get frame :locals) t nil))
+                    temps)
+                  ;; Execute body. If body finishes without ^, the implicit
+                  ;; return value in Smalltalk is `self` — match that.
+                  (st-eval-seq body frame)
+                  receiver)))))))))
 
 ;; ── Block dispatch ─────────────────────────────────────────────────────
 (define
@@ -429,7 +420,10 @@
             ((frame (st-make-frame
                      (if (= env nil) nil (get env :self))
                      (if (= env nil) nil (get env :method-class))
-                     env)))
+                     env
+                     ;; Use the block's captured ^k so `^expr` returns from
+                     ;; the *creating* method, not whoever invoked the block.
+                     (get block :return-k))))
             (begin
               (let ((i 0))
                 (begin
@@ -698,25 +692,26 @@
   smalltalk-eval
   (fn
     (src)
-    (let
-      ((ast (st-parse-expr src))
-        (frame (st-make-frame nil nil nil)))
-      (smalltalk-eval-ast ast frame))))
+    (call/cc
+      (fn (k)
+        (let
+          ((ast (st-parse-expr src))
+            (frame (st-make-frame nil nil nil k)))
+          (smalltalk-eval-ast ast frame))))))
 
 ;; Evaluate a sequence of statements at the top level.
 (define
   smalltalk-eval-program
   (fn
     (src)
-    (let
-      ((ast (st-parse src)) (frame (st-make-frame nil nil nil)))
-      (begin
-        (when
-          (and (dict? ast) (has-key? ast :temps))
-          (for-each
-            (fn (t) (dict-set! (get frame :locals) t nil))
-            (get ast :temps)))
-        (let ((result (smalltalk-eval-ast ast frame)))
-          (cond
-            ((st-return-marker? result) (get result :value))
-            (else result)))))))
+    (call/cc
+      (fn (k)
+        (let
+          ((ast (st-parse src)) (frame (st-make-frame nil nil nil k)))
+          (begin
+            (when
+              (and (dict? ast) (has-key? ast :temps))
+              (for-each
+                (fn (t) (dict-set! (get frame :locals) t nil))
+                (get ast :temps)))
+            (smalltalk-eval-ast ast frame)))))))