diff --git a/lib/scheme/runtime.sx b/lib/scheme/runtime.sx index 86999f5b..df62a23f 100644 --- a/lib/scheme/runtime.sx +++ b/lib/scheme/runtime.sx @@ -510,4 +510,25 @@ "equal?" (scm-binary "equal?" (fn (a b) (= a b)))) (scheme-env-bind! env "eq?" (scm-binary "eq?" (fn (a b) (= a b)))) + ;; ── call/cc (R7RS first-class continuations) ──────────── + ;; Captures the host SX continuation, wraps it as a Scheme + ;; procedure (fn (vargs) ...) and passes it to the user proc. + ;; Calling the captured k with one value re-enters the + ;; continuation; with multiple values, passes them as a list. + (scheme-env-bind! env "call/cc" + (fn (args) + (cond + ((not (= (length args) 1)) + (error "call/cc: expects 1 argument")) + (:else + (call/cc + (fn (k) + (let ((scheme-k + (fn (vargs) + (cond + ((= (length vargs) 1) (k (first vargs))) + (:else (k vargs)))))) + (scheme-apply (first args) (list scheme-k))))))))) + (scheme-env-bind! env "call-with-current-continuation" + (refl-env-lookup env "call/cc")) env))) diff --git a/lib/scheme/tests/control.sx b/lib/scheme/tests/control.sx new file mode 100644 index 00000000..c897a7ac --- /dev/null +++ b/lib/scheme/tests/control.sx @@ -0,0 +1,72 @@ +;; lib/scheme/tests/control.sx — call/cc, dynamic-wind, exceptions. + +(define scm-ctl-pass 0) +(define scm-ctl-fail 0) +(define scm-ctl-fails (list)) + +(define + scm-ctl-test + (fn + (name actual expected) + (if + (= actual expected) + (set! scm-ctl-pass (+ scm-ctl-pass 1)) + (begin + (set! scm-ctl-fail (+ scm-ctl-fail 1)) + (append! scm-ctl-fails {:name name :actual actual :expected expected}))))) + +(define + scm-ctl + (fn (src) (scheme-eval (scheme-parse src) (scheme-standard-env)))) + +(define + scm-ctl-all + (fn + (src) + (scheme-eval-program (scheme-parse-all src) (scheme-standard-env)))) + +;; ── call/cc — escape continuations ────────────────────────────── +;; Single-shot only: when k is invoked, control jumps out of the +;; surrounding call/cc and the result of the entire call/cc form is +;; whatever was passed to k. + +(scm-ctl-test + "call/cc: no escape" + (scm-ctl "(call/cc (lambda (k) 42))") + 42) +(scm-ctl-test + "call/cc: simple escape" + (scm-ctl "(call/cc (lambda (k) (+ 1 (k 42))))") + 42) +(scm-ctl-test + "call/cc: escape past *" + (scm-ctl "(+ 10 (call/cc (lambda (k) (* 2 (k 5)))))") + 15) +(scm-ctl-test + "call/cc: alias call-with-current-continuation" + (scm-ctl "(call-with-current-continuation (lambda (k) (k 99)))") + 99) +(scm-ctl-test + "call/cc: doesn't escape if k unused" + (scm-ctl "(+ 1 (call/cc (lambda (k) (* 100 1))))") + 101) + +;; ── call/cc as early-exit for list search ─────────────────────── +(scm-ctl-test + "call/cc: detect-via-escape" + (scm-ctl-all + "(define (detect pred xs)\n (call/cc\n (lambda (return)\n (for-each\n (lambda (x) (if (pred x) (return x) #f))\n xs)\n #f)))\n (detect (lambda (x) (> x 10)) '(1 5 7 12 20))") + 12) +(scm-ctl-test + "call/cc: detect returns #f when no match" + (scm-ctl-all + "(define (detect pred xs)\n (call/cc\n (lambda (return)\n (for-each\n (lambda (x) (if (pred x) (return x) #f))\n xs)\n #f)))\n (detect (lambda (x) (> x 100)) '(1 5 7))") + false) + +;; ── call/cc producing the captured k value ────────────────────── +(scm-ctl-test + "call/cc: k is a procedure" + (scm-ctl "(procedure? (call/cc (lambda (k) k)))") + true) + +(define scm-ctl-tests-run! (fn () {:total (+ scm-ctl-pass scm-ctl-fail) :passed scm-ctl-pass :failed scm-ctl-fail :fails scm-ctl-fails}))