;;; begin-with-goto.scm -- Jens Axel Søgaard -- 7th July 2007 ; This file implements a simple begin with gotos. ; For a more general version use tagged-begin. ; See the bottom of this file for examples. #;(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 (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)]) ; Are all labels identifiers? (for-each (lambda (name) (unless (identifier? name) (raise-syntax-error 'begin/goto "labels must be identifiers" name))) names) ; Are the duplicate labels? (cond [(check-duplicate-identifier names) => (lambda (name) (raise-syntax-error 'begin/goto "duplicate label found: " name))]))])) (define-syntax (begin/goto stx) (error-check-begin/goto stx) (syntax-case stx (label) [(_) #'(void)] [(_ (label start) 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 (let-syntax ([goto (lambda (stx) (syntax-case stx (goto) [(_ name) (begin (unless (identifier? #'name) (raise-syntax-error 'goto "identifier expected" #'name)) (cond [#t #;(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