suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

added a cycle check to define-language so grammars like this one:

Browse Source 
(define-language L
     (e e))

are rejected as syntax errors
This commit is contained in:
Robby Findler 2012-01-08 16:24:01 -06:00
parent ec02c2f83a
commit 93c21e34de
2 changed files with 55 additions and 2 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

49
collects/redex/private/cycle-check.rkt Normal file
View File

@ -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)))

8
collects/redex/private/reduction-semantics.rkt
View File

@ -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 ...) ...)