diff --git a/collects/redex/private/matcher.rkt b/collects/redex/private/matcher.rkt index b8fa33b2ea..2713f11876 100644 --- a/collects/redex/private/matcher.rkt +++ b/collects/redex/private/matcher.rkt @@ -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 diff --git a/collects/redex/tests/matcher-test.rkt b/collects/redex/tests/matcher-test.rkt index d726bdb313..a8ead44f1f 100644 --- a/collects/redex/tests/matcher-test.rkt +++ b/collects/redex/tests/matcher-test.rkt @@ -618,6 +618,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) @@ -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