tagbody.scm

(library (tagbody)
(export tagbody go)         
(import (rnrs)
        (for (tagbody utils) expand)
        (for (srfi :8 receive) expand))

(define (go tag)
  (tag #f))

(define-syntax tagbody
  (lambda (stx)
    (define (make-group tag statements next)
      #`(call/cc
         (lambda (escape)
           (call/cc
            (lambda (k)
              (set! #,tag k)
              (escape k)))
           #,@statements
           #,(if next
                 #`(go #,next)
                 #'#f))))
    (define (exprs->groups first-tag list)
      (unzip (plist->alist identifier?
                           (cons first-tag list))))
    (syntax-case stx ()
      [(tagbody tags-or-statements ...)
       (let ((init #'init))
         (receive (tags groups) (exprs->groups
                                 init
                                 (syntax->list #'(tags-or-statements ...)))
           (with-syntax (((entry-point ...) (generate-temporaries tags))
                         ((tag ...) tags)
                         ((group ...)
                          (map make-group tags groups (shift-left tags #f))))
             #`(let ((tag #f) ... (done #f))
                 (let ((entry-point group) ...)
                   (unless done
                     (set! done #t)
                     (go #,init)))))))])))

)