diff --git a/collects/redex/private/cycle-check.rkt b/collects/redex/private/cycle-check.rkt new file mode 100644 index 0000000000..e47e8c12c6 --- /dev/null +++ b/collects/redex/private/cycle-check.rkt @@ -0,0 +1,49 @@ +#lang racket/base +(require racket/match) + +(provide check-for-cycles) + +;; doesn't check for cycles via things like: +;; a ::= hole +;; b ::= (in-hole a b) +(define (check-for-cycles stx ntss/stx prodss/stx) + + (define ntss (syntax->datum ntss/stx)) + (define prodss (syntax->datum prodss/stx)) + + ;; hash[sym[nt] -o> (listof sym[nt]) + (define table (make-hash)) + + ;; build the graph + (for ([nts (in-list ntss)] + [prods (in-list prodss)]) + (define base-nt (car nts)) + (for ([nt (in-list (cdr nts))]) + (hash-set! table nt (list base-nt))) + (hash-set! table base-nt '()) + (for ([prod (in-list prods)]) + (match prod + [`(nt ,name) + (hash-set! table base-nt (cons name (hash-ref table base-nt)))] + [_ (void)]))) + + ;; traverse the graph looking for cycles + (define cycle + (for/or ([(nt neighbors) (in-hash table)]) + (define visited (make-hash)) + (for/or ([neighbor (in-list neighbors)]) + (let loop ([current-node neighbor]) + (cond + [(eq? current-node nt) nt] + [(hash-ref visited current-node #f) #f] + [else + (hash-set! visited current-node #t) + (for/or ([neighbor (in-list (hash-ref table current-node))]) + (loop neighbor))]))))) + + (when cycle + (raise-syntax-error 'define-language + (format + "found a cycle that includes the non-terminal ~a" + cycle) + stx))) \ No newline at end of file diff --git a/collects/redex/private/reduction-semantics.rkt b/collects/redex/private/reduction-semantics.rkt index a5dcfff531..b9fec26f41 100644 --- a/collects/redex/private/reduction-semantics.rkt +++ b/collects/redex/private/reduction-semantics.rkt @@ -6,6 +6,7 @@ "fresh.rkt" "loc-wrapper.rkt" "error.rkt" + (for-syntax "cycle-check.rkt") racket/trace racket/contract racket/list @@ -2369,7 +2370,7 @@ (let ([non-terms (parse-non-terminals #'nt-defs stx)]) (with-syntax ([((names prods ...) ...) non-terms] [(all-names ...) (apply append (map car non-terms))]) - (syntax/loc stx + (quasisyntax/loc stx (begin (define-syntax lang-name (make-set!-transformer @@ -2383,10 +2384,12 @@ (identifier? #'x) #'define-language-name])) '(all-names ...)))) - (define define-language-name (language form-name lang-name (all-names ...) (names prods ...) ...))))))))])) + (define define-language-name + #,(syntax/loc stx (language form-name lang-name (all-names ...) (names prods ...) ...)))))))))])) (define-struct binds (source binds)) + (define-syntax (language stx) (syntax-case stx () [(_ form-name lang-id (all-names ...) (name rhs ...) ...) @@ -2420,6 +2423,7 @@ (append (loop (car stx)) (loop (cdr stx)))] [else '()]))]) + (check-for-cycles stx #'(name ...) #'((r-rhs ...) ...)) (with-syntax ([(the-stx ...) (cdr (syntax-e stx))] [(all-names ...) all-names] [((uniform-names ...) ...)