(begin/goto
(label foo)
1
(label bar)
(goto foo))
(letrec ([foo (lambda ()
1
(goto bar))]
[bar (lambda ()
(goto foo))])
(foo))
(module begin-with-goto mzscheme
(provide begin/goto)
(require-for-syntax
(only (lib "1.ss" "srfi") take-while)
(only (lib "1.ss" "srfi") drop-while)
(only (lib "1.ss" "srfi") filter)
(prefix srfi: (lib "1.ss" "srfi"))
(lib "stx.ss" "syntax"))
(define-for-syntax (label? stx)
(syntax-case stx (label)
[(label label-name) #t]
[_else #f]))
(define-for-syntax (goto? stx)
(syntax-case stx (goto)
[(goto label-name) #t]
[_else #f]))
(define-for-syntax (non-label? stx)
(not (label? stx)))
(define-for-syntax (first-label-and-block+more stx)
(syntax-case stx (label)
[((label label-name) label-or-expr ...)
(with-syntax ([(expr ...)
(let ([exprs
(take-while non-label?
(syntax->list #'(label-or-expr ...)))])
(if (null? exprs) (list #'(void)) exprs))]
[more
(drop-while non-label?
(syntax->list #'(label-or-expr ...)))])
(values #'(label-name (expr ...))
#'more))]))
(define-for-syntax (labels-and-exprs->blocks stx)
(syntax-case stx (label)
[() '()]
[_else (let-values ([(first more) (first-label-and-block+more stx)])
(cons first (labels-and-exprs->blocks more)))]))
(define-for-syntax (name-of-label stx)
(syntax-case stx (label)
[(label name) #'name]))
(define-for-syntax (error-check-begin/goto stx)
(syntax-case stx ()
[(_ label-or-expr ...)
(let* ([labels (filter label? (syntax->list #'(label-or-expr ...)))]
[names (map name-of-label labels)])
(for-each (lambda (name)
(unless (identifier? name)
(raise-syntax-error 'begin/goto
"labels must be identifiers" name)))
names)
(cond
[(check-duplicate-identifier names)
=> (lambda (name)
(raise-syntax-error 'begin/goto
"duplicate label found: "
name))]))]))
(define-for-syntax (introduce-labels-after-goto stx)
(syntax-case stx (goto label)
[((goto label-name) (label label-name1) label-or-expr ...)
(with-syntax ([((goto label-name) (label label-name1) label-or-expr ...)
stx])
(with-syntax ([(label-or-expr ...)
(introduce-labels-after-goto
#'(label-or-expr ...))])
(syntax/loc stx
((goto label-name) (label label-name1) label-or-expr ...))))]
[((goto label-name) expr label-or-expr ...)
(with-syntax ([((goto label-name) expr label-or-expr ...) stx])
(with-syntax ([(lab) (generate-temporaries (list #'lab))])
(introduce-labels-after-goto
(syntax/loc stx
((goto label-name) (label lab) expr label-or-expr ...)))))]
[(label-or-expr1 label-or-expr ...)
(with-syntax ([(label-or-expr ...)
(introduce-labels-after-goto
#'(label-or-expr ...))])
(syntax/loc stx
(label-or-expr1 label-or-expr ...)))]
[_else
stx]))
(define-syntax (begin/goto stx)
(error-check-begin/goto stx)
(syntax-case stx (label)
[(_)
#'(void)]
[(_ (label start) label-or-expr ...)
(with-syntax ([(label-or-expr ...)
(introduce-labels-after-goto #'(label-or-expr ...))])
(with-syntax ([((label-name (expr ... last-expr)) ... (end-label-name (end-expr ...)))
(labels-and-exprs->blocks #'((label start) label-or-expr ...))])
(with-syntax ([(next-label ...)
(cdr (syntax->list #'(label-name ... end-label-name)))])
(with-syntax ([(continue ...)
(map (lambda (last-expr next-label)
(syntax-case last-expr (goto)
[(goto name) last-expr]
[_else #`(begin #,last-expr (#,next-label))]))
(syntax->list #'(last-expr ...))
(syntax->list #'(next-label ...)))])
(with-syntax ([(name1 ...)
(map name-of-label
(filter label? (syntax->list #'((label start) label-or-expr ...))))])
(with-syntax ([goto (syntax-local-introduce #'goto)])
(syntax/loc stx
(letrec-syntaxes+values
([(goto) (lambda (stx)
(syntax-case stx (goto)
[(_ name)
(begin
(unless (identifier? #'name)
(raise-syntax-error 'goto "identifier expected" #'name))
(cond
[(srfi:member #'name (syntax->list #'(name1 ...)) module-identifier=?)
(syntax/loc stx
(name))]
[else
(raise-syntax-error 'goto "unknown label" stx)]))]
[_else
(raise-syntax-error 'goto "expected (goto <label>), got" stx)]))])
([(label-name) (lambda () expr ... continue)]
...
[(end-label-name) (lambda () end-expr ...)])
(start)))))))))]
[(_ expr label-or-expr ...)
(syntax/loc stx
(begin/goto (label start) expr label-or-expr ...))]))
)