Goto

8.16

Goto🔗ℹ

Noah Ma <noahstorym@gmail.com>

(require goto)

package: goto

(require typed/goto)

package: typed-goto

1 Overview🔗ℹ

This package provides label and goto constructs that simulate jump using call/cc.

2 API Reference🔗ℹ

procedure
(goto k) → none/c
k : continuation?

Sets current continuation.

(define (goto k) (k k))

procedure
(label [prompt-tag]) → continuation?
prompt-tag : continuation-prompt-tag?
= (default-continuation-prompt-tag)

Gets current continuation.

(define (label [prompt-tag (default-continuation-prompt-tag)])
(call/cc goto prompt-tag))

procedure
(current-continuation) → continuation?
(current-continuation k) → none/c
k : continuation?

(define current-continuation
  (case-λ
    [() (label)]
    [(k) (goto k)]))

procedure
(cc) → continuation?
(cc k) → none/c
k : continuation?

The cc binding is an alias for current-continuation.

type constructor
(Goto a)

(define-type (Goto a) (∪ a (→ a Nothing)))

type
Label

Is the fixed point of Goto.

(define-type Label (Goto Label))

3 Examples🔗ℹ

3.1 Loop🔗ℹ

(let ([x 0])
  (define loop (label))
  (set! x (add1 x))
  (when (< x 7) (goto loop))
  (displayln x))

3.2 Yin-Yang Puzzle🔗ℹ

(let ([yin (current-continuation)])
  (display #\@)
  (let ([yang (current-continuation)])
    (display #\*)
    (yin yang)))

((begin0 (cc) (display #\@))
(begin0 (cc) (display #\*)))

3.3 Call with Current Continuation🔗ℹ

(define (call/cc proc)
  (define tag 0)
  (define k (call-with-values cc const*))
  (case/eq tag
    [(0) (set! tag 1) (proc (k))]
    [(1) (k)]))

3.4 Light-Weight Process🔗ℹ

(let ([lwp-queue (make-queue)])
  (define (start)
    (when (non-empty-queue? lwp-queue)
      (goto (dequeue! lwp-queue))))
  (define (lwp-enqueue! break continue)
    (define first? #t)
    (define l (label))
    (case/eq first?
      [(#t)
       (set! first? #f)
       (enqueue! lwp-queue l)
       (break)]
      [(#f) (continue)]))
  (define (pause) (lwp-enqueue! start void))
  (define (lwp thk) (lwp-enqueue! void (λ () (thk) (start))))

  (lwp (λ () (goto (begin0 (label) (pause) (display #\h)))))
  (lwp (λ () (goto (begin0 (label) (pause) (display #\e)))))
  (lwp (λ () (goto (begin0 (label) (pause) (display #\y)))))
  (lwp (λ () (goto (begin0 (label) (pause) (display #\!)))))
  (lwp (λ () (goto (begin0 (label) (pause) (newline)))))
  (start))

3.5 Ambiguous Operator🔗ℹ

(let ([task* '()])
  (define (fail)
    (if (null? task*)
        (error "Amb tree exhausted")
        (goto (car task*))))
  (define (amb* . alt*)
    (define first? #t)
    (define task (label))
    (when (null? alt*) (fail))
    (when first?
      (set! first? #f)
      (set! task* (cons task task*)))
    (define alt (car alt*))
    (set! alt* (cdr alt*))
    (when (null? alt*)
      (set! task* (cdr task*)))
    (alt))
  (define-syntax-rule (amb exp* ...) (amb* (λ () exp*) ...))

  (let ([w-1 (amb "the" "that" "a")]
        [w-2 (amb "frog" "elephant" "thing")]
        [w-3 (amb "walked" "treaded" "grows")]
        [w-4 (amb "slowly" "quickly")])
    (define (joins? left right)
      (equal?
       (string-ref left (sub1 (string-length left)))
       (string-ref right 0)))
    (unless (joins? w-1 w-2) (amb))
    (unless (joins? w-2 w-3) (amb))
    (unless (joins? w-3 w-4) (amb))
    (list w-1 w-2 w-3 w-4)))