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

fixed a bug reported by Zane and Ahmed via Matthias

Browse Source 
svn: r13483
This commit is contained in:
Robby Findler 2009-02-07 13:09:11 +00:00
parent 30763e3b84
commit 12560f3a23
2 changed files with 105 additions and 27 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

100
collects/redex/private/reduction-semantics.ss
View File

@ -1532,8 +1532,7 @@
(syntax->list #'(name ...))))]) (syntax->list #'(name ...))))])
(syntax/loc stx (syntax/loc stx
(do-extend-language lang (do-extend-language lang
(list (make-nt 'first-names (list (make-rhs `r-rhs '()) ...)) ... (list (make-nt '(uniform-names ...) (list (make-rhs `r-rhs '()) ...)) ...)
(make-nt 'new-name (list (make-rhs 'orig-name '()))) ...)
(list (list '(uniform-names ...) (to-lw rhs) ...) ...))))] (list (list '(uniform-names ...) (to-lw rhs) ...) ...))))]
[(_ lang (name rhs ...) ...) [(_ lang (name rhs ...) ...)
(begin (begin
@ -1565,41 +1564,81 @@
(define extend-nt-ellipses '(....)) (define extend-nt-ellipses '(....))
;; do-extend-language : compiled-lang (listof (listof nt)) ? -> compiled-lang ;; do-extend-language : compiled-lang (listof (listof nt)) ? -> compiled-lang
;; note: the nts that come here are an abuse of the `nt' struct; they have
;; lists of symbols in the nt-name field.
(define (do-extend-language old-lang new-nts new-pict-infos) (define (do-extend-language old-lang new-nts new-pict-infos)
(unless (compiled-lang? old-lang) (unless (compiled-lang? old-lang)
(error 'extend-language "expected a language as first argument, got ~e" old-lang)) (error 'extend-language "expected a language as first argument, got ~e" old-lang))
(let ([old-nts (compiled-lang-lang old-lang)] (let ([old-nts (compiled-lang-lang old-lang)]
[old-ht (make-hasheq)] [old-ht (make-hasheq)]
[new-ht (make-hasheq)]) [new-ht (make-hasheq)])
(for-each (λ (nt) (for-each (λ (nt)
(hash-set! old-ht (nt-name nt) nt) (hash-set! old-ht (nt-name nt) nt)
(hash-set! new-ht (nt-name nt) nt)) (hash-set! new-ht (nt-name nt) nt))
old-nts) old-nts)
(let ([extended-nts '()]) (for-each (λ (raw-nt)
(for-each (λ (raw-nt) (let* ([names (nt-name raw-nt)]
(let ([primary-name (find-primary-nt (nt-name raw-nt) old-lang)]) [rhs (nt-rhs raw-nt)]
(when (and primary-name (member primary-name extended-nts)) [primary-names (map (λ (name) (find-primary-nt name old-lang)) names)]
(error 'extend-language "the non-terminal ~s was extended twice" primary-name)) [main-primary (car primary-names)])
(let ([nt (make-nt (or primary-name (nt-name raw-nt))
(nt-rhs raw-nt))]) ;; error checking
(cond (when (and (ormap not primary-names)
[(ormap (λ (rhs) (member (rhs-pattern rhs) extend-nt-ellipses)) (ormap symbol? primary-names))
(nt-rhs nt)) (error 'extend-language "new language extends old non-terminal ~a and also adds new shortcut ~a"
(unless (hash-ref old-ht (nt-name nt) #f) (ormap (λ (x y) (and (symbol? x) y)) primary-names names)
(error 'extend-language (ormap (λ (x y) (and (not x) y)) primary-names names)))
"the language extends the ~s non-terminal, but that non-terminal is not in the old language"
(nt-name raw-nt))) ;; error checking
(hash-set! new-ht (when (andmap symbol? primary-names)
(nt-name nt) (let ([main-orig (car names)])
(make-nt (let loop ([primary-names (cdr primary-names)]
(nt-name nt) [names (cdr names)])
(append (nt-rhs (hash-ref old-ht (nt-name nt))) (cond
(filter (λ (rhs) (not (member (rhs-pattern rhs) extend-nt-ellipses))) [(null? primary-names) void]
(nt-rhs nt)))))] [else
[else (unless (eq? main-primary (car primary-names))
(hash-set! new-ht (nt-name nt) nt)])))) (error 'extend-language
new-nts)) (string-append
"new language does not have the same non-terminal aliases as the old,"
" non-terminal ~a was not in the same group as ~a in the old language")
(car names)
main-orig))
(loop (cdr primary-names) (cdr names))]))))
;; rebind original nt
(let ([nt (make-nt (or main-primary (car names)) rhs)])
(cond
[(ormap (λ (rhs) (member (rhs-pattern rhs) extend-nt-ellipses))
(nt-rhs nt))
(unless (hash-ref old-ht (nt-name nt) #f)
(error 'extend-language
"the language extends the ~s non-terminal, but that non-terminal is not in the old language"
(nt-name nt)))
(hash-set! new-ht
(nt-name nt)
(make-nt
(nt-name nt)
(append (nt-rhs (hash-ref old-ht (nt-name nt)))
(filter (λ (rhs) (not (member (rhs-pattern rhs) extend-nt-ellipses)))
(nt-rhs nt)))))]
[else
(hash-set! new-ht (nt-name nt) nt)]))
;; add new shortcuts (if necessary)
(unless main-primary
(for-each (λ (shortcut-name)
(hash-set! new-ht
shortcut-name
(make-nt shortcut-name (list (make-rhs (car names) '())))))
(cdr names)))))
new-nts)
(compile-language (vector (compiled-lang-pict-builder old-lang) (compile-language (vector (compiled-lang-pict-builder old-lang)
new-pict-infos) new-pict-infos)
@ -1609,9 +1648,16 @@
;; find-primary-nt : symbol lang -> symbol or #f ;; find-primary-nt : symbol lang -> symbol or #f
;; returns the primary non-terminal for a given nt, or #f if `nt' isn't bound in the language. ;; returns the primary non-terminal for a given nt, or #f if `nt' isn't bound in the language.
(define (find-primary-nt nt lang) (define (find-primary-nt nt lang)
(let ([combined (find-combined-nts nt lang)])
(and combined
(car combined))))
;; find-combined-nts : symbol lang -> (listof symbol) or #f
;; returns the combined set of non-terminals for 'nt' from lang
(define (find-combined-nts nt lang)
(ormap (λ (nt-line) (ormap (λ (nt-line)
(and (member nt nt-line) (and (member nt nt-line)
(car nt-line))) nt-line))
(compiled-lang-nt-map lang))) (compiled-lang-nt-map lang)))
(define (apply-reduction-relation* reductions exp) (define (apply-reduction-relation* reductions exp)

32
collects/redex/private/tl-test.ss
View File

@ -191,6 +191,37 @@
(test (pair? (redex-match iswim-cont W (term QQ))) (test (pair? (redex-match iswim-cont W (term QQ)))
#t)) #t))
(let ()
(define-language okay
[(X Y) z])
(define-extended-language replace-both
okay
[(X Y) q])
;; this test ran into an infinite loop in an earlier version of redex.
(test (redex-match replace-both X (term explode)) #f))
(test (with-handlers ([exn? exn-message])
(let ()
(define-language main
[(X Y) z])
(define-extended-language new
main
[(X Y Z) q])
(void)))
"extend-language: new language extends old non-terminal X and also adds new shortcut Z")
(test (with-handlers ([exn? exn-message])
(let ()
(define-language main
[(X Y) z]
[(P Q) w])
(define-extended-language new
main
[(X P) q])
(void)))
"extend-language: new language does not have the same non-terminal aliases as the old, non-terminal P was not in the same group as X in the old language")
;; test caching ;; test caching
(let () (let ()
@ -231,6 +262,7 @@
(test rhs-eval-count 2)) (test rhs-eval-count 2))
; ;
; ;
; ;;; ; ; ;;; ;