The (aux continuation) modules

Classic operators, escapers, amb and Collatz sequences

Posted on October 21, 2026 · by Massimo Nocentini · 18-minute read · Scheme

`(aux continuation classic)`: classic continuation operators

Classic continuation operators

Ported from on-scheme's continuations.scm, after The Seasoned Schemer.

Implementation

(module
  (aux continuation classic)
  *
  (import
    scheme
    (chicken base)
    (chicken continuation)
    (only (chicken fixnum) fx+ fx- fx<)
    (only srfi-1 last)
    (aux base)
    (aux continuation))
  (define (continuation-rewind! winds n)
    (cond ((eq? ##sys#dynamic-winds winds) (void))
          ((fx< n 0)
           (continuation-rewind! (cdr winds) (fx+ n 1))
           ((car (car winds)))
           (set! ##sys#dynamic-winds winds))
          (else
           (let1 (after (cdr (car ##sys#dynamic-winds)))
                 (set! ##sys#dynamic-winds (cdr ##sys#dynamic-winds))
                 (after)
                 (continuation-rewind! winds (fx- n 1))))))
  (define continuation->λ
    (λ (raw)
       (##sys#check-structure raw 'continuation 'continuation->λ)
       (let1 (winds (##sys#slot raw 2))
             (λ args
                (unless
                  (eq? ##sys#dynamic-winds winds)
                  (continuation-rewind!
                    winds
                    (fx- (length ##sys#dynamic-winds) (length winds))))
                (apply continuation-return raw args)))))
  (define-syntax-rule
    (letcc/raw (raw hop) body ...)
    (continuation-capture
      (λ (raw) (let1 (hop (continuation->λ raw)) body ...))))
  (define (apply/cc f . args)
    (letcc k (apply f (append (butlast args) (last args) (list k)))))
  (define-syntax
    escapecc
    (syntax-rules
      (else =>)
      ((escapecc (out α) (else β)) (letcc out α β))
      ((escapecc (out α) (=> f)) (letcc out (let1 (result α) (f result))))))
  (define-syntax
    trycc/named
    (syntax-rules
      (else =>)
      ((trycc/named (skip α) ... (else β))
       (letcc success (letcc skip (success α)) ... β))
      ((trycc/named (skip α) ... (else => f))
       (letcc success
              (let1 (outputs (list (letcc skip (success α)) ...))
                    (f outputs))))))
  (define-syntax-rule (set/cc! v) (set! v (letcc/raw (raw hop) hop)))
  (define-syntax
    cond/cc
    (syntax-rules
      (else)
      ((cond/cc (pred? handling) ... (else recv))
       (letcc/raw
         (cont hop)
         (cond ((continuation? cont) (recv hop))
               ((pred? cont) (handling cont))
               ...
               (else (error "Contract violation")))))))
  (define current-continuation/cont
    (τ (continuation-capture (λ (cont) ((continuation->λ cont) cont)))))
  (define current-continuation/λ
    (τ (continuation-capture (compose Φ continuation->λ))))
  (define-syntax-rule
    (letcc/escaper escaper body ...)
    ((letcc top
            (let1 (escaper (λ (proc) (λ args (top (τ (apply proc args))))))
                  (τ body ...))))))

`test/letcc`: pass

(define (test/letcc _)
  (⊦= 1 (letcc hop 1))
  (⊦= 1 (letcc hop (hop 1)))
  (⊦= 1 (letcc hop (add1 (hop 1))))
  (⊦= 10 (+ 9 (letcc hop (add1 (hop 1)))))
  (⊦= 1 (letcc/raw (raw hop) 1))
  (⊦= 1 (letcc/raw (raw hop) (hop 1)))
  (⊦= 1 (letcc/raw (raw hop) (add1 (hop 1))))
  (⊦= 10 (+ 9 (letcc/raw (raw hop) (add1 (hop 1))))))

((eta 0.0) (memory #(12582912 2195640 1048576)) (stdout "") (stderr ""))

`test/trycc/named`: pass

(define (test/trycc/named _)
  (let ((identity-applicative&return (λ (x skip) x))
        (identity-applicative&skip (λ (x skip) (skip 'discard))))
    (⊦= 1
        (trycc/named
          (skip (identity-applicative&return 1 skip))
          (else (eternity))))
    (⊦= 2 (trycc/named (skip (identity-applicative&skip 1 skip)) (else 2)))
    (⊦= '(1)
        (trycc/named
          (skip1 (list 1))
          (skip2 'useless)
          (else 'even-more-useless)))
    (⊦= '(2)
        (trycc/named
          (skip1 (list 1 (skip1 'discard)))
          (skip2 (list 2))
          (else 'useless)))
    (⊦= '(3)
        (trycc/named
          (skip1 (list 1 (skip1 'discard)))
          (skip2 (list 2 (skip2 'discard)))
          (else (list 3))))))

((eta 0.0) (memory #(12582912 2197104 1048576)) (stdout "") (stderr ""))

`test/trycc/named/=>`: pass

(define (test/trycc/named/=> _)
  (⊦= '(discard discard)
      (trycc/named
        (skip1 (list 1 (skip1 'discard)))
        (skip2 (list 2 (skip2 'discard)))
        (else => identity)))
  (⊦= '(1)
      (trycc/named
        (skip1 (list 1))
        (skip2 (list 2 (skip2 'discard)))
        (else => identity))))

((eta 0.0) (memory #(12582912 2196152 1048576)) (stdout "") (stderr ""))

`test/letcc/output`: pass

(define (test/letcc/output _)
  (⊦= "I got here\nThis string was passed to the continuation.\n"
      (with-output-to-string
        (τ (display
             (letcc cont
                    (display "I got here\n")
                    (cont "This string was passed to the continuation.\n")
                    (display "...but not here")))))))

((eta 0.0) (memory #(12582912 2200232 1048576)) (stdout "") (stderr ""))

`test/set/cc!`: pass

(define (test/set/cc! _)
  (let1 (port (open-output-string))
        (⊨ (condition-case
             (begin
               (let ((start #f))
                 (unless start (set/cc! start))
                 (display "Going to invoke `(start)`\n" port)
                 (start))
               #f)
             ((exn) #t)))
        (⊦= "Going to invoke `(start)`\nGoing to invoke `(start)`\n"
            (get-output-string port))))

((eta 0.0) (memory #(12582912 2205760 1048576)) (stdout "") (stderr ""))

`test/cond/cc`: pass

(define (test/cond/cc _)
  (⊦= 3 (cond/cc (number? add1) (else (λ (cont) (+ 2 (cont 3)))))))

((eta 0.0) (memory #(12582912 2209600 1048576)) (stdout "") (stderr ""))

`test/letcc/raw`: pass

(define (test/letcc/raw _)
  (⊦= 5
      (let ((start #f))
        (letcc/raw
          (cont λ)
          (unless start (set! start λ))
          (cond ((continuation? cont) (λ 3))
                ((number? cont) (add1 cont))
                (else (error "e")))
          (start)
          (λ 7))
        5)))

((eta 0.0) (memory #(12582912 2213320 1048576)) (stdout "") (stderr ""))

`test/escapecc`: pass

(define (test/escapecc _)
  (let ((leftmost
          (λ (l)
             (escapecc
               (hop (let L ((ll l))
                      (cond ((null? ll) '(no symbol here))
                            ((symbol? (car ll)) (hop (car ll)))
                            (else (begin (L (car ll)) (L (cdr ll)))))))
               (else l)))))
    (⊦= 'a (leftmost '(((a) b) (c d))))
    (⊦= 'a (leftmost '(((a) ()) () (e))))
    (⊦= '((() ())) (leftmost '((() ())))))
  (⊦= 3 (escapecc (out (+ 1 (out 3))) (=> add1)))
  (⊦= 5 (escapecc (out (+ 1 3)) (=> add1)))
  (⊦= 'done (escapecc (out (+ 1 3)) (else 'done))))

((eta 0.0) (memory #(12582912 2204656 1048576)) (stdout "") (stderr ""))

`test/apply/cc`: pass

(define (test/apply/cc _)
  (⊦= '(1 2 3 4) (apply/cc (λ (a b c d k) (list a b c d)) 1 2 '(3 4)))
  (⊦= 'escaped (apply/cc (λ (a b k) (cons a (k 'escaped))) '(1 2)))
  (⊦= '(1 . 2) (apply/cc (λ (a b k) (cons a b)) 1 '(2)))
  (⊦= 'no (apply/cc (λ (k) (+ 1 (k 'no))) '())))

((eta 0.0) (memory #(12582912 2207856 1048576)) (stdout "") (stderr ""))

`test/continuation->λ`: pass

(define (test/continuation->λ _)
  (⊦= '(1 2)
      (call-with-values
        (τ (continuation-capture (λ (raw) ((continuation->λ raw) 1 2))))
        list))
  (⊦= 3
      (+ 1 (continuation-capture (λ (raw) (* 10 ((continuation->λ raw) 2)))))))

((eta 0.0) (memory #(12582912 2208856 1048576)) (stdout "") (stderr ""))

`test/continuation->λ/dynamic-wind`: pass

(define (test/continuation->λ/dynamic-wind _)
  (define q (make-parameter 'outer))
  (define wlog '())
  (⊦= '((2 inner) (1 inner) (0 inner))
      (let ((n 2) (acc '()) (k #f))
        (parameterize
          ((q 'inner))
          (dynamic-wind
            (τ (push! 'in wlog))
            (τ (letcc/raw (raw hop) (set! k hop)) (push! (list n (q)) acc))
            (τ (push! 'out wlog))))
        (unless (zero? n) (set! n (sub1 n)) (k 'again))
        (reverse acc)))
  (⊦= 'outer (q))
  (⊦= '(in out in out in out) (reverse wlog)))

((eta 0.0) (memory #(12582912 2209816 1048576)) (stdout "") (stderr ""))

`test/current-continuation`: pass

(define (test/current-continuation _)
  (⊨ (continuation? (current-continuation/cont)))
  (⊨ (procedure? (current-continuation/λ)))
  (⊦= '(0 1 2 3)
      (let ((n 3) (acc '()))
        (let1 (k (current-continuation/λ))
              (push! n acc)
              (unless (zero? n) (set! n (sub1 n)) (k k)))
        acc))
  (⊦= '(0 1 2 3)
      (let ((n 3) (acc '()))
        (let1 (c (current-continuation/cont))
              (push! n acc)
              (unless (zero? n) (set! n (sub1 n)) (continuation-return c c)))
        acc)))

((eta 0.0) (memory #(12582912 2209856 1048576)) (stdout "") (stderr ""))

`test/letcc/escaper`: pass

(define (test/letcc/escaper _)
  (⊦= 10 (letcc/escaper escaper (+ ((escaper *) 5 2) 3)))
  (⊦= 15
      (letcc/escaper
        escaper
        (+ ((escaper (λ (x) (- ((escaper *) x 3) 7))) 5) 4)))
  (⊦= -1 (letcc/escaper escaper ((escaper add1) ((escaper sub1) 0))))
  (⊦= '(3)
      (letcc/escaper
        escaper
        (let ((escape-cons (escaper cons)))
          (escape-cons 1 (escape-cons 2 (escape-cons 3 '()))))))
  (⊦= '(a b d)
      (letcc/escaper
        escaper
        (let ((receiver (escaper (λ (proc) (cons 'c (proc (list 'd)))))))
          (cons 'a (cons 'b (call-with-current-continuation receiver)))))))

((eta 0.0) (memory #(12582912 2212008 1048576)) (stdout "") (stderr ""))

`(aux continuation classic)`: escapers, after Scheme and the Art of Programming

Escape procedures and `call/cc`

Exercises of chapter 16 of Springer and Friedman, Scheme and the Art of Programming, on contexts, escape procedures and call/cc.

`test/contexts`: pass

(define (test/contexts _)
  (⊦= (+ 3 (* 4 (+ 5 6))) ((λ (▢) (+ 3 (* 4 ▢))) (+ 5 6)))
  (⊦= 47 ((λ (▢) (+ 3 (* 4 ▢))) (+ 5 6)))
  (⊦= (letrec ((sum+n (λ (n) (if (zero? n) 1 (+ (add1 n) (sum+n (sub1 n)))))))
        (* 10 (sum+n 5)))
      ((λ (▢) (* 10 (+ 6 (+ 5 (+ ▢ (+ 3 (+ 2 1))))))) (add1 3)))
  (⊦= 210 ((λ (▢) (* 10 (+ 6 (+ 5 (+ ▢ (+ 3 (+ 2 1))))))) (add1 3)))
  (let* ((out (open-output-string))
         (v (begin
              (display 0 out)
              (let ((n 1))
                (if (zero? n)
                  (display (+ 3 (* 4 (+ 5 6))) out)
                  (display (* (+ (* 3 4) 5) 2) out))
                (set! n (+ n 2))
                n))))
    (⊦= "034" (get-output-string out))
    (⊦= 3 v))
  (let* ((out (open-output-string))
         (n 1)
         (context
           (λ (▢)
              (begin
                (display 0 out)
                (display (* (+ ▢ 5) 2) out)
                (set! n (+ n 2))
                n))))
    (⊦= 3 (context (* 3 4)))
    (⊦= 5 (context (* 3 4)))
    (⊦= "034034" (get-output-string out))))

((eta 0.0) (memory #(12582912 2461072 1048576)) (stdout "") (stderr ""))

`test/escaper/first`: pass

(define (test/escaper/first _)
  (⊦= 10
      (letcc/escaper
        escaper
        (let ((escape-* (escaper *))) (+ (escape-* 5 2) 3)))))

((eta 0.0) (memory #(12582912 2464848 1048576)) (stdout "") (stderr ""))

`test/escaper`: pass

(define (test/escaper _)
  (⊦= 10 (letcc/escaper escaper (+ ((escaper *) 5 2) 3)))
  (⊦= 8 (letcc/escaper escaper (+ ((escaper (λ (x) (- (* x 3) 7))) 5) 4)))
  (⊦= 8
      (letcc/escaper
        escaper
        (+ ((escaper (λ (x) ((escaper -) (* x 3) 7))) 5) 4)))
  (⊦= 15 ((λ (x) (* x 3)) 5))
  (⊦= 15
      (letcc/escaper
        escaper
        (+ ((escaper (λ (x) (- ((escaper *) x 3) 7))) 5) 4)))
  (⊦= 15
      (letcc/escaper
        escaper
        (+ ((escaper (λ (x) ((escaper -) ((escaper *) x 3) 7))) 5) 4))))

((eta 0.0) (memory #(12582912 2465752 1048576)) (stdout "") (stderr ""))

`test/escaper/abandons`: pass

(define (test/escaper/abandons _)
  (⊦= 8
      (letcc/escaper escaper (/ (+ ((escaper (λ (x) (- (* x 3) 7))) 5) 4) 2)))
  (⊦= -1 (letcc/escaper escaper ((escaper add1) ((escaper sub1) 0))))
  (⊦= '(3)
      (letcc/escaper
        escaper
        (let ((escape-cons (escaper cons)))
          (escape-cons 1 (escape-cons 2 (escape-cons 3 '()))))))
  (⊦= "reset invoked"
      (with-output-to-string
        (τ (letcc/escaper
             escaper
             (let ((reset (λ ()
                             (let ((escape
                                     (escaper (λ () (display "reset invoked")))))
                               (escape)))))
               (cons 1 (reset)))))))
  (⊨ (void? (letcc/escaper
              escaper
              (let ((reset (λ ()
                              (let ((escape (escaper (λ () (void))))) (escape)))))
                (cons 1 (reset))))))
  (⊦= '(2)
      (letcc/escaper
        escaper
        (let ((reset (λ () ((escaper (λ () '(2))))))) (cons 1 (reset))))))

((eta 0.0) (memory #(12582912 2467232 1048576)) (stdout "") (stderr ""))

`test/receiver/escaper`: pass

(define (test/receiver/escaper _)
  (⊦= 27
      (letcc/escaper
        escaper
        (let ((receiver (λ (continuation) 6)) (context (λ (▢) (+ 3 (* 4 ▢)))))
          (+ 3 (* 4 (receiver (escaper context)))))))
  (⊦= 27
      (letcc/escaper
        escaper
        (let ((receiver (λ (continuation) (continuation 6)))
              (context (λ (▢) (+ 3 (* 4 ▢)))))
          (+ 3 (* 4 (receiver (escaper context)))))))
  (⊦= 27
      (letcc/escaper
        escaper
        (let ((receiver (λ (continuation) (+ 2 (continuation 6))))
              (context (λ (▢) (+ 3 (* 4 ▢)))))
          (+ 3 (* 4 (receiver (escaper context))))))))

((eta 0.0) (memory #(12582912 2468368 1048576)) (stdout "") (stderr ""))

`test/receiver/call/cc`: pass

(define (test/receiver/call/cc _)
  (⊦= 27
      (let ((receiver (λ (continuation) 6))) (+ 3 (* 4 (call/cc receiver)))))
  (⊦= 27
      (let ((receiver (λ (continuation) (continuation 6))))
        (+ 3 (* 4 (call/cc receiver)))))
  (⊦= 27
      (let ((receiver (λ (continuation) (+ 2 (continuation 6)))))
        (+ 3 (* 4 (call/cc receiver))))))

((eta 0.0) (memory #(12582912 2471544 1048576)) (stdout "") (stderr ""))

`test/16.9`: pass

(define (test/16.9 _)
  (⊦= -22
      (letcc/escaper
        escaper
        (let ((context (λ (▢) (- 3 (* 5 ▢))))
              (receiver (λ (continuation) (continuation 5))))
          (- 3 (* 5 (receiver (escaper context)))))))
  (⊦= -22
      (let ((receiver (λ (continuation) (continuation 5))))
        (- 3 (* 5 (call/cc receiver)))))
  (⊦= -22
      (letcc/escaper
        escaper
        (let ((context (λ (▢) (- 3 (* 5 ▢)))) (receiver (λ (continuation) 5)))
          (- 3 (* 5 (receiver (escaper context)))))))
  (⊦= -22
      (let ((receiver (λ (continuation) 5))) (- 3 (* 5 (call/cc receiver)))))
  (⊦= -22
      (letcc/escaper
        escaper
        (let ((context (λ (▢) (- 3 (* 5 ▢))))
              (receiver (λ (continuation) (+ 1000 (continuation 5)))))
          (- 3 (* 5 (receiver (escaper context)))))))
  (⊦= -22
      (let ((receiver (λ (continuation) (+ 1000 (continuation 5)))))
        (- 3 (* 5 (call/cc receiver))))))

((eta 0.0) (memory #(12582912 2470472 1048576)) (stdout "") (stderr ""))

`test/experiment/first`: pass

(define (test/experiment/first _)
  (let* ((port (open-output-string))
         (call (λ (receiver) (receiver (display/return/port port))))
         (result (void)))
    (set! result ((answer-maker/port port) (call receiver-1)))
    (⊦= "(1)(1)" (get-output-string port))
    (⊦= '(answer-is 1) result))
  (let* ((port (open-output-string)) (result/cc (void)))
    (set! result/cc ((answer-maker/port port) (call/cc receiver-1)))
    (⊦= "(1)" (get-output-string port))
    (⊦= '(answer-is 1) result/cc)))

((eta 0.0) (memory #(12582912 2472152 1048576)) (stdout "") (stderr ""))

`test/experiment/second`: pass

(define (test/experiment/second _)
  (let* ((port (open-output-string))
         (call (λ (receiver) (receiver (display/return/port port))))
         (result (void)))
    (set! result ((answer-maker/port port) (call receiver-2)))
    (⊦= "(2)((2))((2))" (get-output-string port))
    (⊦= '(answer-is (2)) result))
  (let* ((port (open-output-string)) (result/cc (void)))
    (set! result/cc ((answer-maker/port port) (call/cc receiver-2)))
    (⊦= "(2)" (get-output-string port))
    (⊦= '(answer-is 2) result/cc)))

((eta 0.0) (memory #(12582912 2472648 1048576)) (stdout "") (stderr ""))

`test/experiment/third`: pass

(define (test/experiment/third _)
  (let* ((port (open-output-string))
         (display/return (display/return/port port))
         (call (λ (receiver) (receiver display/return)))
         (result (void)))
    (set! result ((answer-maker/port port) (call receiver-3)))
    (⊦= "(3 #<procedure>)((3 #<procedure>))((3 #<procedure>))"
        (procedure-names/normalise (get-output-string port)))
    (⊦= `(answer-is (3 ,display/return)) result)
    (let1 (mark (string-length (get-output-string port)))
          (⊦= '(1000) ((cadr (cadr result)) (list 1000)))
          (⊦= "(1000)" (substring (get-output-string port) mark)))
    (⊦= `(answer-is (3 ,display/return)) result)))

((eta 0.0) (memory #(12582912 2479112 1048576)) (stdout "") (stderr ""))

`test/experiment/third/call/cc`: pass

(define (test/experiment/third/call/cc _)
  (let* ((phase 0) (port (open-output-string)) (mark 0) (result/cc (void)))
    (set! result/cc ((answer-maker/port port) (call/cc receiver-3)))
    (set! phase (add1 phase))
    (cond ((= phase 1)
           (⊦= "(3 #<procedure>)"
               (procedure-names/normalise (get-output-string port)))
           (⊦= `(answer-is 3 ,(caddr result/cc)) result/cc)
           (⊨ (procedure? (caddr result/cc)))
           (set! mark (string-length (get-output-string port)))
           ((caddr result/cc) (list 1000))
           (⊭ 'unreachable))
          (else
           (⊦= 2 phase)
           (⊦= "(1000)" (substring (get-output-string port) mark))
           (⊦= '(answer-is 1000) result/cc)))))

((eta 0.0) (memory #(12582912 2481144 1048576)) (stdout "") (stderr ""))

`test/experiment/fourth`: pass

(define (test/experiment/fourth _)
  (let* ((port (open-output-string))
         (display/return (display/return/port port))
         (call (λ (receiver) (receiver display/return)))
         (result (void)))
    (⊦= 'done
        (begin
          (set! result ((answer-maker/port port) (call receiver-3)))
          'done))
    (⊦= "(3 #<procedure>)((3 #<procedure>))((3 #<procedure>))"
        (procedure-names/normalise (get-output-string port)))
    (⊦= `(answer-is (3 ,display/return)) result)
    (let1 (mark (string-length (get-output-string port)))
          (⊦= '(1000) ((cadr (cadr result)) (list 1000)))
          (⊦= "(1000)" (substring (get-output-string port) mark)))
    (⊦= `(answer-is (3 ,display/return)) result)))

((eta 0.0) (memory #(12582912 2482512 1048576)) (stdout "") (stderr ""))

`test/experiment/fourth/call/cc`: pass

(define (test/experiment/fourth/call/cc _)
  (let* ((phase 0) (port (open-output-string)) (mark 0) (result/cc (void)))
    (let1 (v (begin
               (set! result/cc ((answer-maker/port port) (call/cc receiver-3)))
               'done))
          (set! phase (add1 phase))
          (⊦= 'done v)
          (cond ((= phase 1)
                 (⊦= "(3 #<procedure>)"
                     (procedure-names/normalise (get-output-string port)))
                 (⊦= `(answer-is 3 ,(caddr result/cc)) result/cc)
                 (set! mark (string-length (get-output-string port)))
                 ((caddr result/cc) (list 1000))
                 (⊭ 'unreachable))
                (else
                 (⊦= 2 phase)
                 (⊦= "(1000)" (substring (get-output-string port) mark))
                 (⊦= '(answer-is 1000) result/cc))))))

((eta 0.0) (memory #(12582912 2483672 1048576)) (stdout "") (stderr ""))

`test/16.14`: pass

(define (test/16.14 _)
  (let ((receiver
          (λ (continuation)
             (if (zero? (pseudo-random-integer 2))
               (+ 1000 6)
               (continuation 6)))))
    (do ((i 0 (add1 i)))
        ((= i 32))
      (⊨ (member? (* (+ (call/cc receiver) 3) 8) '(72 8072)))
      (⊨ (member?
           (+ (* (+ (call/cc receiver) 3) 8) (* (+ (call/cc receiver) 3) 8))
           '(144 8144 16144)))))
  (let ((receiver
          (λ (continuation)
             (continuation
               (if (zero? (continuation (pseudo-random-integer 2)))
                 (+ 1000 6)
                 6)))))
    (do ((i 0 (add1 i)))
        ((= i 32))
      (⊨ (member?
           (+ (* (+ (call/cc receiver) 3) 8) (* (+ (call/cc receiver) 3) 8))
           '(48 56 64))))))

((eta 0.0) (memory #(12582912 2483896 1048576)) (stdout "") (stderr ""))

`test/16.16`: pass

(define (test/16.16 _)
  (let* ((deep (void))
         (map-sub1
           (letrec ((M (λ (ls)
                          (if (null? ls)
                            (call/cc
                              (λ (continuation) (set! deep continuation) '()))
                            (cons (sub1 (car ls)) (M (cdr ls)))))))
             M))
         (run (λ (ls)
                 (let ((phase 0) (results '()))
                   (let1 (v (cons 1000 (map-sub1 ls)))
                         (push! v results)
                         (set! phase (add1 phase))
                         (when (= phase 1) (cons 2000 (deep '(a b c)))))
                   (reverse results)))))
    (⊦= '((1000) (1000 a b c)) (run '()))
    (⊦= '((1000 -1) (1000 -1 a b c)) (run '(0)))
    (⊦= '((1000 0 -1) (1000 0 -1 a b c)) (run '(1 0)))
    (⊦= '((1000 4 3 2 1 0 -1) (1000 4 3 2 1 0 -1 a b c))
        (run '(5 4 3 2 1 0)))))

((eta 0.0) (memory #(12582912 2487560 1048576)) (stdout "") (stderr ""))

`test/escaper/thunk`: pass

(define (test/escaper/thunk _)
  (⊦= 7 (letcc/escaper escaper ((escaper (τ (add1 6))))))
  (⊦= 7 (letcc/escaper escaper (+ 5 ((escaper (τ (add1 6))))))))

((eta 0.0) (memory #(12582912 2488520 1048576)) (stdout "") (stderr ""))

`test/escaper/receiver`: pass

(define (test/escaper/receiver _)
  (⊦= '(a b d)
      (letcc/escaper
        escaper
        (let ((receiver (escaper (λ (proc) (cons 'c (proc (list 'd)))))))
          (cons 'a (cons 'b (call/cc receiver))))))
  (⊦= '(c d)
      (letcc/escaper
        escaper
        (let ((receiver (escaper (λ (proc) '(c d)))))
          (cons 'a (cons 'b (call/cc receiver))))))
  (⊦= '(c d)
      (letcc/escaper
        new-escaper
        (let ((receiver (new-escaper (λ (proc) '(c d)))))
          (cons 'a (cons 'b (call/cc receiver)))))))

((eta 0.001) (memory #(12582912 2490248 1048576)) (stdout "") (stderr ""))

`test/countdown`: pass

(define (test/countdown _)
  (let* ((countdown
           (λ (n attempt)
              (format #t "~%This string will appear only once~%")
              (let* ((message
                       (λ (direction value)
                          (format
                            #t
                            "\t~Aing `attempt` function with value ~A~%"
                            direction
                            value)
                          value))
                     (pair (message 'exit (attempt (message 'enter n))))
                     (v (car pair))
                     (returner (cadr pair)))
                (format #t "\tnon-negative number: ~A~%" v)
                (if (positive? v)
                  (returner (list (sub1 v) returner))
                  (format #t "Blastoff")))))
         (v (void)))
    (⊦= "\nThis string will appear only once\n\tentering `attempt` function with value 3\n\texiting `attempt` function with value (3 #<procedure>)\n\tnon-negative number: 3\n"
        (procedure-names/normalise
          (with-output-to-string
            (τ (set! v
                 (let ((attempt
                         (λ (n)
                            (let ((receiver (λ (proc) (list n proc))))
                              (receiver (λ (x) x))))))
                   (countdown 3 attempt)))))))
    (⊦= 2 (car v))
    (⊨ (procedure? (cadr v)))
    (⊦= "\nThis string will appear only once\n\tentering `attempt` function with value 3\n\texiting `attempt` function with value (3 #<procedure>)\n\tnon-negative number: 3\n\texiting `attempt` function with value (2 #<procedure>)\n\tnon-negative number: 2\n\texiting `attempt` function with value (1 #<procedure>)\n\tnon-negative number: 1\n\texiting `attempt` function with value (0 #<procedure>)\n\tnon-negative number: 0\nBlastoff"
        (procedure-names/normalise
          (with-output-to-string
            (τ (let ((attempt
                       (λ (n)
                          (let ((receiver (λ (proc) (list n proc))))
                            (call/cc receiver)))))
                 (countdown 3 attempt))))))))

((eta 0.0) (memory #(12582912 2491808 1048576)) (stdout "") (stderr ""))

`test/three-phases`: pass

(define (test/three-phases _)
  (⊦= "beginbeginmiddlebeginend"
      (with-output-to-string
        (τ (let ((receiver (λ (continuation) (continuation continuation)))
                 (three-phases
                   (λ (continuation)
                      (display 'begin)
                      (call/cc continuation)
                      (display 'middle)
                      (call/cc continuation)
                      (display 'end))))
             (three-phases (call/cc receiver)))))))

((eta 0.0) (memory #(12582912 2496048 1048576)) (stdout "") (stderr ""))

`(aux continuation amb)`: McCarthy’s `amb` and a SAT solver

McCarthy's `amb` and a SAT solver

Ported from on-scheme's continuations.scm.

Implementation

(module
  (aux continuation classic)
  *
  (import
    scheme
    (chicken base)
    (chicken continuation)
    (only (chicken fixnum) fx+ fx- fx<)
    (only srfi-1 last)
    (aux base)
    (aux continuation))
  (define (continuation-rewind! winds n)
    (cond ((eq? ##sys#dynamic-winds winds) (void))
          ((fx< n 0)
           (continuation-rewind! (cdr winds) (fx+ n 1))
           ((car (car winds)))
           (set! ##sys#dynamic-winds winds))
          (else
           (let1 (after (cdr (car ##sys#dynamic-winds)))
                 (set! ##sys#dynamic-winds (cdr ##sys#dynamic-winds))
                 (after)
                 (continuation-rewind! winds (fx- n 1))))))
  (define continuation->λ
    (λ (raw)
       (##sys#check-structure raw 'continuation 'continuation->λ)
       (let1 (winds (##sys#slot raw 2))
             (λ args
                (unless
                  (eq? ##sys#dynamic-winds winds)
                  (continuation-rewind!
                    winds
                    (fx- (length ##sys#dynamic-winds) (length winds))))
                (apply continuation-return raw args)))))
  (define-syntax-rule
    (letcc/raw (raw hop) body ...)
    (continuation-capture
      (λ (raw) (let1 (hop (continuation->λ raw)) body ...))))
  (define (apply/cc f . args)
    (letcc k (apply f (append (butlast args) (last args) (list k)))))
  (define-syntax
    escapecc
    (syntax-rules
      (else =>)
      ((escapecc (out α) (else β)) (letcc out α β))
      ((escapecc (out α) (=> f)) (letcc out (let1 (result α) (f result))))))
  (define-syntax
    trycc/named
    (syntax-rules
      (else =>)
      ((trycc/named (skip α) ... (else β))
       (letcc success (letcc skip (success α)) ... β))
      ((trycc/named (skip α) ... (else => f))
       (letcc success
              (let1 (outputs (list (letcc skip (success α)) ...))
                    (f outputs))))))
  (define-syntax-rule (set/cc! v) (set! v (letcc/raw (raw hop) hop)))
  (define-syntax
    cond/cc
    (syntax-rules
      (else)
      ((cond/cc (pred? handling) ... (else recv))
       (letcc/raw
         (cont hop)
         (cond ((continuation? cont) (recv hop))
               ((pred? cont) (handling cont))
               ...
               (else (error "Contract violation")))))))
  (define current-continuation/cont
    (τ (continuation-capture (λ (cont) ((continuation->λ cont) cont)))))
  (define current-continuation/λ
    (τ (continuation-capture (compose Φ continuation->λ))))
  (define-syntax-rule
    (letcc/escaper escaper body ...)
    ((letcc top
            (let1 (escaper (λ (proc) (λ args (top (τ (apply proc args))))))
                  (τ body ...))))))

`test/amb/pythagorean`: pass

(define (test/amb/pythagorean _)
  (⊦= '((3 4 5) (4 3 5))
      (amb (λ (ε ? ✗ ✓)
              (let ((a (ε (list 1 2 3 4 5 6 7)))
                    (b (ε (list 1 2 3 4 5 6 7)))
                    (c (ε (list 1 2 3 4 5 6 7))))
                (? (= (* c c) (+ (* a a) (* b b))))
                (✓ (list a b c))
                (✗))))))

((eta 0.001) (memory #(6291456 2056688 1048576)) (stdout "") (stderr ""))

`test/amb/ordered`: pass

(define (test/amb/ordered _)
  (⊦= '((4 3 5))
      (amb (λ (ε ? ✗ ✓)
              (let* ((a (ε (list 1 2 3 4 5 6 7)))
                     (b (ε (list 1 2 3 4 5 6 7)))
                     (c (ε (list 1 2 3 4 5 6 7))))
                (? (= (* c c) (+ (* a a) (* b b))))
                (? (< b a))
                (✓ (list a b c))
                (✗)))))
  (⊦= '() (amb (λ (ε ? ✗ ✓) (✗))))
  (⊦= '() (amb (λ (ε ? ✗ ✓) (ε '())))))

((eta 0.001) (memory #(6291456 2058648 1048576)) (stdout "") (stderr ""))

`test/amb/parameterize`: pass

(define (test/amb/parameterize _)
  (define q (make-parameter 'outer))
  (⊦= '((1 inner outer) (2 inner outer) (3 inner outer))
      (amb (λ (ε ? ✗ ✓)
              (let* ((inside #f)
                     (a (parameterize
                          ((q 'inner))
                          (let1 (a (ε '(1 2 3))) (set! inside (q)) a))))
                (✓ (list a inside (q)))
                (✗)))))
  (⊦= 'outer (q)))

((eta 0.0) (memory #(6291456 2063472 1048576)) (stdout "") (stderr ""))

`test/amb/dynamic-wind`: pass

(define (test/amb/dynamic-wind _)
  (define wlog '())
  (⊦= '(1 2 3)
      (amb (λ (ε ? ✗ ✓)
              (let1 (a (dynamic-wind
                         (τ (push! 'in wlog))
                         (τ (ε '(1 2 3)))
                         (τ (push! 'out wlog))))
                    (✓ a)
                    (✗)))))
  (⊦= '(in out in out in out in out) (reverse wlog)))

((eta 0.0) (memory #(6291456 2064032 1048576)) (stdout "") (stderr ""))

`test/sat-solve`: pass

(define (test/sat-solve _)
  (⊦= (list (list #t) (list #f)) (sat-solve (x) (or #t x)))
  (⊦= '((#t #t) (#t #f)) (sat-solve (x y) (or x y)))
  (⊦= (list (list #f #f #t))
      (sat-solve (a b c) (and (implies a (not b)) (not a) c)))
  (⊦= (list (list #f #t #t #t) (list #f #t #t #t))
      (sat-solve
        (x1 x3 x4 x5)
        (and (or x1 (not x5) x4) (or (not x1) x5 x3 x4)))))

((eta 0.0) (memory #(6291456 2065312 1048576)) (stdout "") (stderr ""))

`test/implies`: pass

(define (test/implies _)
  (⊨ (implies #f #f))
  (⊨ (implies #f #t))
  (⊭ (implies #t #f))
  (⊨ (implies #t #t)))

((eta 0.0) (memory #(6291456 2066576 1048576)) (stdout "") (stderr ""))

`(aux continuation)`: Collatz sequences with `letcc`

Collatz 3x+1 problem

Direct, continuation-passing and call/cc versions, after Kozen's recitation on CPS.

`test/collatz`: pass

(define (test/collatz _)
  (let ((expected
          '(51
            154
            77
            232
            116
            58
            29
            88
            44
            22
            11
            34
            17
            52
            26
            13
            40
            20
            10
            5
            16
            8
            4
            2
            1)))
    (⊦= expected (collatz 51))
    (⊦= expected (collatz&co 51))
    (⊦= expected (collatz&co-abridged 51))
    (⊦= expected (collatz&co-abridged2 51))
    (⊦= expected (collatz&cc 51))
    (⊦= expected (collatz&cc-abridged 51))))

((eta 0.0) (memory #(6291456 1905560 1048576)) (stdout "") (stderr ""))

(aux continuation classic): classic continuation operators#

(aux continuation classic): escapers, after Scheme and the Art of Programming#

(aux continuation amb): McCarthy’s amb and a SAT solver#

(aux continuation): Collatz sequences with letcc#

`(aux continuation classic)`: classic continuation operators

`(aux continuation classic)`: escapers, after Scheme and the Art of Programming

`(aux continuation amb)`: McCarthy’s `amb` and a SAT solver

`(aux continuation)`: Collatz sequences with `letcc`