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

redex: fix bug introduced in recent optimization attempts

Browse Source
This commit is contained in:
Robby Findler 2012-01-02 22:21:21 -06:00
parent 83758881c3
commit 160fcacad6
2 changed files with 76 additions and 12 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

22
collects/redex/private/matcher.rkt
View File

@ -123,7 +123,7 @@ See match-a-pattern.rkt for more details
;; (listof (listof symbol))) -- keeps track of `primary' non-terminals
(define-struct compiled-lang (lang delayed-cclang ht list-ht raw-across-ht raw-across-list-ht
has-hole-ht cache bind-names-cache pict-builder
has-hole-or-hide-hole-ht cache bind-names-cache pict-builder
literals nt-map))
(define (compiled-lang-cclang x) (force (compiled-lang-delayed-cclang x)))
(define (compiled-lang-across-ht x)
@ -154,13 +154,13 @@ See match-a-pattern.rkt for more details
[clang-list-ht (make-hasheq)]
[across-ht (make-hasheq)]
[across-list-ht (make-hasheq)]
[has-hole-ht (build-has-hole-ht lang)]
[has-hole-or-hide-hole-ht (build-has-hole-or-hide-hole-ht lang)]
[cache (make-hash)]
[bind-names-cache (make-hash)]
[literals (extract-literals lang)]
[clang (make-compiled-lang lang #f clang-ht clang-list-ht
across-ht across-list-ht
has-hole-ht
has-hole-or-hide-hole-ht
cache bind-names-cache
pict-info
literals
@ -261,9 +261,9 @@ See match-a-pattern.rkt for more details
(unless (memq pat nts)
(hash-set! ht pat #t)))))])))
; build-has-hole-ht : (listof nt) -> hash[symbol -o> boolean]
; build-has-hole-or-hide-hole-ht : (listof nt) -> hash[symbol -o> boolean]
; produces a map of nonterminal -> whether that nonterminal could produce a hole
(define (build-has-hole-ht lang)
(define (build-has-hole-or-hide-hole-ht lang)
(build-nt-property
lang
(lambda (pattern ht)
@ -284,7 +284,7 @@ See match-a-pattern.rkt for more details
[`(name ,name ,pat) (loop pat)]
[`(mismatch-name ,name ,pat) (loop pat)]
[`(in-hole ,context ,contractum) (loop contractum)]
[`(hide-hole ,arg) #f]
[`(hide-hole ,arg) #t]
[`(side-condition ,pat ,condition ,expr) (loop pat)]
[`(cross ,nt) #f]
[`(list ,pats ...)
@ -686,7 +686,7 @@ See match-a-pattern.rkt for more details
(define (compile-pattern/cross? clang pattern bind-names?)
(define clang-ht (compiled-lang-ht clang))
(define clang-list-ht (compiled-lang-list-ht clang))
(define has-hole-ht (compiled-lang-has-hole-ht clang))
(define has-hole-or-hide-hole-ht (compiled-lang-has-hole-or-hide-hole-ht clang))
(define (compile-pattern/default-cache pattern)
(compile-pattern/cache pattern
@ -755,7 +755,7 @@ See match-a-pattern.rkt for more details
(values match-hole #t #f)]
[`(nt ,nt)
(define in-name? (in-name-parameter))
(define has-hole? (hash-ref has-hole-ht nt))
(define has-hole? (hash-ref has-hole-or-hide-hole-ht nt))
(values
(if has-hole?
(letrec ([try-again
@ -1758,9 +1758,9 @@ See match-a-pattern.rkt for more details
(define (context? x) #t)
(define-values (the-hole the-not-hole hole?)
(let ()
(define-struct hole () #:inspector #f)
(define the-hole (make-hole))
(define the-not-hole (make-hole))
(define-struct hole (id) #:inspector #f)
(define the-hole (make-hole 'the-hole))
(define the-not-hole (make-hole 'the-not-hole))
(values the-hole the-not-hole hole?)))
(define hole->not-hole

66
collects/redex/tests/matcher-test.rkt
View File

@ -619,6 +619,66 @@
(test-xab '(name underscore (nt underscore)) '(+ 1 2) (list (make-mtch (make-bindings (list (make-bind 'underscore '(+ 1 2)))) '(+ 1 2) none)))
(test-xab '(name underscore (nt underscore)) '2 (list (make-mtch (make-bindings (list (make-bind 'underscore 2))) 2 none)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; tests to check on the name/non-name optimization likely
;; many of these are duplicates of the ones above, but it
;; is hard to know which are and which aren't.
;;
(test-xab '(name x (name y 1)) 1 (list (make-mtch (make-bindings (list (make-bind 'x 1) (make-bind 'y 1))) 1 none)))
(test-xab '(list (mismatch-name y_!_1 1)
(mismatch-name y_!_1 2))
'(1 2)
(list (make-mtch (make-bindings '()) '(1 2) none)))
(test-xab '(list (mismatch-name x_!_1 (name a 1))
(mismatch-name x_!_1 (name b 2)))
'(1 2)
(list (make-mtch (make-bindings (list (make-bind 'a 1) (make-bind 'b 2))) '(1 2) none)))
(test-xab '(in-hole (name x hole) (name y 1)) 1 (list (make-mtch (make-bindings (list (make-bind 'x the-hole) (make-bind 'y 1)))
1
none)))
(test-xab '(in-hole (name x hole) 1) 1 (list (make-mtch (make-bindings (list (make-bind 'x the-hole)))
1
none)))
(test-xab '(in-hole hole (name y 1)) 1 (list (make-mtch (make-bindings (list (make-bind 'y 1)))
1
none)))
(test-xab '(in-hole hole 1) 1 (list (make-mtch (make-bindings '()) 1 none)))
(test-xab '(hide-hole (list hole 1)) `(,the-hole 1) (list (make-mtch (make-bindings '()) `(,the-hole 1) none)))
(test-xab '(hide-hole (list 2 1)) `(2 1) (list (make-mtch (make-bindings '()) `(2 1) none)))
(test-xab '(hide-hole (list (name z 2) 1)) `(2 1) (list (make-mtch (make-bindings (list (make-bind 'z 2))) `(2 1) none)))
(test-xab `(side-condition (name x 1) ,(λ (bindings) (equal? bindings (make-bindings (list (make-bind 'x 1))))) 'srcloc)
1
(list (make-mtch (make-bindings (list (make-bind 'x 1))) 1 none)))
(test-xab `(side-condition 2 ,(λ (bindings) (equal? bindings (make-bindings '()))) 'srcloc)
2
(list (make-mtch (make-bindings '()) 2 none)))
(test-xab '(list (repeat (name x 1) #f #f))
'(1 1 1)
(list (make-mtch (make-bindings (list (make-bind 'x '(1 1 1)))) '(1 1 1) none)))
(test-xab '(list (repeat 1 ..._1 #f))
'(1 1 1)
(list (make-mtch (make-bindings (list (make-bind '..._1 3))) '(1 1 1) none)))
(test-xab '(list (repeat 1 #f ..._!_1)
(repeat 2 #f ..._!_1))
'(1 1 2)
(list (make-mtch (make-bindings '()) '(1 1 2) none)))
(test-xab '(list (repeat 1 #f #f))
'(1 1 1)
(list (make-mtch (make-bindings '()) '(1 1 1) none)))
(test-xab '(in-hole (name hh-D (nt hh-D)) whatever)
`(,the-hole whatever)
(list (make-mtch (make-bindings (list (make-bind 'hh-D (list the-hole the-not-hole))))
`(,the-hole whatever)
none)))
;;
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(run-test
(this-line)
'compatible-context-language1
@ -839,6 +899,10 @@
(make-nt 'var (list (make-rhs `variable-not-otherwise-mentioned)))
(make-nt 'underscore (list (make-rhs '(name exp_1 (nt exp)))))
(make-nt 'hh-v (list (make-rhs '(hide-hole (nt hh-D)))))
(make-nt 'hh-D (list (make-rhs 'hole) (make-rhs '(list (nt hh-v) (nt hh-D)))))
)])
(set! xab-lang
(compile-language 'pict-stuff-not-used
@ -851,7 +915,7 @@
ans))
(define ab-lang #f)
;; test-xab : sexp[pattern] sexp[term] answer -> void
;; test-ab : sexp[pattern] sexp[term] answer -> void
;; returns #t if pat matching exp with a simple language produces ans.
(define (test-ab line pat exp ans)
(unless ab-lang