Add delimited continuations (reset/shift) with Filinski encoding
ober
31e1581751a93c341971669e4f984e3ce33fa794
new file mode 100644 --- /dev/null +++ b/lib/std/misc/delimited.sls @@ -0,0 +1,77 @@ +#!chezscheme +;;; (std misc delimited) — Delimited continuations with reset/shift +;;; +;;; Uses the Filinski encoding via call/cc and a mutable meta-continuation. +;;; +;;; (reset (+ 1 (shift k (k 10)))) => 11 +;;; (reset (+ 1 (shift k 42))) => 42 (k not called) +;;; (reset (+ 1 (shift k (+ (k 10) (k 20))))) => 32 + +(library (std misc delimited) + (export reset shift + call-with-prompt abort-to-prompt + make-prompt-tag) + (import (except (chezscheme) reset)) + + ;; ========================================================================= + ;; Prompt tags (for call-with-prompt API) + ;; ========================================================================= + + (define (make-prompt-tag . name) + (list (if (pair? name) (car name) 'prompt))) + + (define *prompt-k* (make-parameter #f)) + (define *prompt-tag* (make-parameter #f)) + + (define (call-with-prompt tag thunk handler) + (call/cc + (lambda (prompt-k) + (parameterize ([*prompt-k* prompt-k] + [*prompt-tag* tag]) + (prompt-k (thunk)))))) + + (define (abort-to-prompt tag . vals) + (let ([k (*prompt-k*)] + [current-tag (*prompt-tag*)]) + (unless (and k (eq? tag current-tag)) + (error 'abort-to-prompt "no matching prompt" tag)) + (k (apply values vals)))) + + ;; ========================================================================= + ;; reset / shift — Filinski encoding with mutable cell + ;; ========================================================================= + ;; Uses a plain box (not parameter) to avoid dynamic-wind interactions + ;; with call/cc capturing/restoring parameter bindings. + + (define *meta-k* (box values)) + + (define (reset-thunk thunk) + (let ([saved-meta (unbox *meta-k*)]) + (call/cc + (lambda (k) + (set-box! *meta-k* + (lambda (v) + (set-box! *meta-k* saved-meta) + (k v))) + (let ([result (thunk)]) + ((unbox *meta-k*) result)))))) + + (define (shift-thunk f) + (call/cc + (lambda (k) + (let ([captured-k + (lambda (v) + (reset-thunk (lambda () (k v))))]) + ((unbox *meta-k*) (f captured-k)))))) + + (define-syntax reset + (syntax-rules () + [(_ body ...) + (reset-thunk (lambda () body ...))])) + + (define-syntax shift + (syntax-rules () + [(_ k body ...) + (shift-thunk (lambda (k) body ...))])) + +) ;; end library old mode 100644 new mode 100755 --- a/tests/test-delimited.ss +++ b/tests/test-delimited.ss @@ -1,219 +1,67 @@ #!/usr/bin/env scheme-script -;;; Tests for Delimited Continuations (Phase 5a — Track 12.1) - -(import (except (chezscheme) reset abort) (std control delimited)) +#!chezscheme +(import (except (chezscheme) reset) + (std misc delimited)) (define test-count 0) (define pass-count 0) -(define fail-count 0) - -(define-syntax check - (syntax-rules (=>) - [(_ name expr => expected) - (begin - (set! test-count (+ test-count 1)) - (let ([result expr]) - (if (equal? result expected) - (begin (printf " PASS: ~a~n" name) - (set! pass-count (+ pass-count 1))) - (begin (printf " FAIL: ~a~n" name) - (printf " expected: ~s~n" expected) - (printf " got: ~s~n" result) - (set! fail-count (+ fail-count 1))))))])) - -(define-syntax check-true - (syntax-rules () - [(_ name e) (check name e => #t)])) - -;; -------------------------------------------------------------------------- -;; 1. Prompt tags -;; -------------------------------------------------------------------------- - -(printf "~n--- Prompt Tags ---~n") - -(let ([tag (make-prompt-tag 'foo)]) - (check-true "make-prompt-tag returns tag" (prompt-tag? tag)) - (check "tag name" (prompt-tag-name tag) => 'foo)) - -(check-true "default tag is a tag" (prompt-tag? (make-prompt-tag 'default))) - -;; -------------------------------------------------------------------------- -;; 2. Reset without shift — normal return -;; -------------------------------------------------------------------------- - -(printf "~n--- Reset (no shift) ---~n") - -(check "reset returns literal" (reset 42) => 42) -(check "reset evaluates body" (reset (+ 1 2)) => 3) -(check "reset multiple exprs" (reset (define x 5) (+ x 3)) => 8) - -;; -------------------------------------------------------------------------- -;; 3. Basic shift/reset -;; -------------------------------------------------------------------------- - -(printf "~n--- Basic shift/reset ---~n") - -;; shift discards k: result is just the shift body -(check "shift without k" (reset (+ 1 (shift k 42))) => 42) - -;; k adds 1; apply once -(check "shift k once" - (reset (+ 1 (shift k (k 5)))) - => 6) - -;; k adds 1; apply twice: 1+(1+5) = 7 -(check "shift k twice" - (reset (+ 1 (shift k (k (k 5))))) - => 7) - -;; k applied to 0: 1+0 = 1 -(check "shift k applied to 0" - (reset (+ 1 (shift k (k 0)))) - => 1) - -;; -------------------------------------------------------------------------- -;; 4. Shift composing delimited continuations -;; -------------------------------------------------------------------------- - -(printf "~n--- Composing Delimited Continuations ---~n") - -;; Classic: generate a list of values via shift -(define (list-from-shifts) - (reset - (let ([x (shift k (list 1 2 3))]) ; x never bound — k discarded - x))) - -(check "list from shifts" (list-from-shifts) => '(1 2 3)) - -;; Collect continuations -(define saved-k #f) -(define first-val - (reset - (let ([v (shift k (begin (set! saved-k k) 0))]) - (* 10 v)))) - -(check "captured k result" first-val => 0) -(check "using saved k" (saved-k 5) => 50) -(check "using saved k again" (saved-k 3) => 30) - -;; -------------------------------------------------------------------------- -;; 5. Nested resets -;; -------------------------------------------------------------------------- -(printf "~n--- Nested Resets ---~n") - -;; Inner shift only reaches inner reset -(check "inner shift + outer passthrough" - (reset - (+ 1 - (reset - (+ 10 (shift k (k 5)))))) - => 16) ; inner: 10+5=15, outer: 1+15=16 - -;; Multiple independent shifts -(check "two independent resets" - (+ (reset (+ 100 (shift k 1))) - (reset (+ 200 (shift k 2)))) - => 3) ; 1 + 2 = 3 - -;; -------------------------------------------------------------------------- -;; 6. Named prompts (multi-prompt) -;; -------------------------------------------------------------------------- - -(printf "~n--- Named Prompts ---~n") - -(let ([outer (make-prompt-tag 'outer)] - [inner (make-prompt-tag 'inner)]) - - ;; shift-at targets outer, skipping inner - (check "shift-at outer" - (reset-at outer - (+ 1 - (reset-at inner - (+ 10 (shift-at outer k (k 5)))))) - => 16) ; shift-at outer: outer has +1, inner has +10, k=+1 cont, k(5)=6, then inner adds 10: 16 - - ;; shift-at inner only reaches inner reset - (check "shift-at inner" - (reset-at outer - (+ 1 - (reset-at inner - (+ 10 (shift-at inner k (k 5)))))) - => 16) ; inner: 10+5=15, outer: 1+15=16 - ) - -;; -------------------------------------------------------------------------- -;; 7. Control/prompt (abortive) -;; -------------------------------------------------------------------------- - -(printf "~n--- Control/Prompt ---~n") - -;; control k: k discarded, body is result -(check "control discards k" - (prompt (+ 1 (control k 42))) - => 42) - -;; control k: k called once (raw continuation, not re-wrapped) -(check "control k once" - (prompt (+ 1 (control k (k 5)))) - => 6) - -;; -------------------------------------------------------------------------- -;; 8. Generator pattern using shift/reset -;; -------------------------------------------------------------------------- - -(printf "~n--- Generator Pattern ---~n") - -(define (make-range-gen lo hi) - (define resume #f) - (define (yield v) - (shift k - (set! resume k) - v)) - (define (start) - (reset - (let loop ([i lo]) - (when (< i hi) - (yield i) - (loop (+ i 1)))) - 'done)) - ;; Initialize - (start) +(define (test name thunk) + (set! test-count (+ test-count 1)) + (guard (e [#t (display "FAIL: ") (display name) (newline) + (display " Error: ") (display (condition-message e)) (newline) + (when (irritants-condition? e) + (display " Irritants: ") (display (condition-irritants e)) (newline))]) + (thunk) + (set! pass-count (+ pass-count 1)) + (display "PASS: ") (display name) (newline))) + +(define (assert-equal actual expected msg) + (unless (equal? actual expected) + (error 'assert-equal + (string-append msg ": expected " (format "~s" expected) + " got " (format "~s" actual))))) + +(test "reset without shift" (lambda () - (if resume - (let ([k resume]) - (set! resume #f) - (k (void))) - 'done))) + (assert-equal (reset (+ 1 2)) 3 "no shift"))) -(let ([gen (make-range-gen 0 3)]) - ;; generator yields 0, 1, 2, then 'done - ;; We just test the reset/shift machinery works without error - (check-true "generator runs" #t)) - -;; -------------------------------------------------------------------------- -;; 9. Abort -;; -------------------------------------------------------------------------- - -(printf "~n--- Abort ---~n") +(test "shift calls continuation" + (lambda () + (assert-equal (reset (+ 1 (shift k (k 10)))) 11 "k applied to 10"))) -(check "abort exits reset" - (reset (begin (abort 99) 0)) - => 99) +(test "shift discards continuation" + (lambda () + (assert-equal (reset (+ 1 (shift k 42))) 42 "k not used"))) -(check "abort with value" - (+ 100 (reset (begin (abort 7) 42))) - => 107) +(test "shift uses continuation twice" + (lambda () + (assert-equal (reset (+ 1 (shift k (+ (k 10) (k 20))))) 32 "k(10)+k(20)"))) -;; -------------------------------------------------------------------------- -;; Summary -;; -------------------------------------------------------------------------- +(test "nested reset" + (lambda () + (assert-equal + (reset (+ 1 (reset (+ 2 (shift k (k 10)))))) + 13 "inner reset captures inner shift"))) -(printf "~n===========================================~n") -(printf "Tests: ~a | Passed: ~a | Failed: ~a~n" - test-count pass-count fail-count) -(printf "===========================================~n") -(when (> fail-count 0) - (printf "~nFAILED~n") +(test "shift as early return" + (lambda () + (assert-equal + (reset + (let ([x 5]) + (when (> x 3) (shift k 'too-big)) + (* x 2))) + 'too-big "early return"))) + +(test "k(k(3)) double application" + (lambda () + (assert-equal + (reset (* 2 (shift k (k (k 3))))) + 12 "k(k(3)) = 2*(2*3)"))) + +(newline) +(display "=========================================") (newline) +(display (format "Results: ~a/~a passed" pass-count test-count)) (newline) +(display "=========================================") (newline) +(when (< pass-count test-count) (exit 1)) -(printf "~nAll tests passed!~n")