The (aux continuation) modules

Classic operators, escapers, amb and Collatz sequences

 Posted on October 21, 2026  |   18 min  |   Massimo Nocentini

(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 ""))
Categories: scheme 

See also

The (aux anthropic) module The Anthropic Messages API, offline The (aux cml) module Events, threads, synchronous variables, the library and I/O The (aux hakaru10) modules Random sources, distributions, the language, exact inference and examples The (aux kanren) modules Arithmetic, dates, presentation of answers and a union-find miniKanren The (aux games dice-of-doom) module Dice of Doom The (aux machine) modules Environments, the SC machine and the SECD machine The (aux schemer seasoned) module The Seasoned Schemer The (aux category) modules Monads: list, maybe, probability, ziplist, difference lists and state The (aux timsort) module Sorting and the trace buffer The (aux fds) modules Functional queues and union-find The (aux sxml) module Rendering SXML to HTML The (aux variable) module Logic variables introduced by fresh The (aux tabling) module Memoization and tabled definitions The (aux commons) module Learning tests for CHICKEN Scheme Promises delay and make-promise The Ackermann function On unary numbers, as lists Concurrent ML for CHICKEN Scheme Porting SML/NJ CML as the (aux cml) library CHICKEN Scheme Versions and implementation notes The SBRAL data structure Skew Binary Random-Access Lists Pattern matching Scheme macrology: a generalized pattern matcher The (aux hansei) modules Inference, random sources, lazy lists, logic programming and example models The (aux nondeterministic) module Learning tests for Scheme The (aux stream) modules Streams, streams after SICP, and sequences and power series The (aux unittest) module Bootstrapping a unittest framework Scheme lang: Chez, 48 and Chicken Some docs, refs and containers, respectively. The Reasoned Schemer miniKanren, microKanren and some implementations Aggregation predicates for µkanren Groups, window functions, sets and enumerations miniKanren, live and untagged Quine generation via relational interpreters Pure, declarative, and constructive arithmetic relations A declarative pearl Final shift for call/cc Direct implementation of shift and reset Call with Current Continuation Patterns Cogen in six lines The Seasoned Schemer The Little Schemer Adding generic functions to Scheme Handling control