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

Fixed bug in may-be-non-list-pattern?/internal and stored compatible

Browse Source 
context language in compiled-lang, for use in term generator.

svn: r11537
This commit is contained in:
Casey Klein 2008-09-04 19:30:45 +00:00
parent 5e963dccea
commit 1c654c35d2
2 changed files with 28 additions and 13 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

13
collects/redex/private/matcher-test.ss
View File

@ -42,6 +42,8 @@
(test-empty '(variable-except x) 1 #f)
(test-empty '(variable-except x) 'x #f)
(test-empty '(variable-except x) 'y (list (make-test-mtch (make-bindings null) 'y none)))
(test-lang 'x 'y (list (make-mtch (make-bindings (list (make-bind 'x 'y))) 'y none))
(list (make-nt 'x (list (make-rhs '(variable-except x) '())))))
(test-empty '(variable-prefix x:) 'x: (list (make-test-mtch (make-bindings null) 'x: none)))
(test-empty '(variable-prefix x:) 'x:x (list (make-test-mtch (make-bindings null) 'x:x none)))
(test-empty '(variable-prefix x:) ': #f)
@ -616,6 +618,17 @@
exp)
ans))
;; test-lang : sexp[pattern] sexp[term] answer (list/c nt) -> void
;; returns #t if pat matching exp with the language defined by the given nts
(define (test-lang pat exp ans nts)
(let ([nt-map (map (λ (x) (list (nt-name x))) nts)])
(run-match-test
`(match-pattern (compile-pattern (compile-language 'pict-stuff-not-used ',nts ',nt-map) ',pat #t) ',exp)
(match-pattern
(compile-pattern (compile-language 'pict-stuff-not-used nts nt-map) pat #t)
exp)
ans)))
(define xab-lang #f)
;; test-xab : sexp[pattern] sexp[term] answer -> void
;; returns #t if pat matching exp with a simple language produces ans.

28
collects/redex/private/matcher.ss
View File

@ -90,9 +90,9 @@ before the pattern compiler is invoked.
;; #f means we're not in a `in-hole' context
;; none means we're looking for a hole
(define-struct compiled-lang (lang ht list-ht across-ht across-list-ht has-hole-ht
cache bind-names-cache pict-builder literals
nt-map))
(define-struct compiled-lang (lang cclang ht list-ht across-ht across-list-ht
has-hole-ht cache bind-names-cache pict-builder
literals nt-map))
;; lookup-binding : bindings (union sym (cons sym sym)) [(-> any)] -> any
(define (lookup-binding bindings
@ -118,7 +118,7 @@ before the pattern compiler is invoked.
[cache (make-hash)]
[bind-names-cache (make-hash)]
[literals (extract-literals lang)]
[clang (make-compiled-lang lang clang-ht clang-list-ht
[clang (make-compiled-lang lang #f clang-ht clang-list-ht
across-ht across-list-ht
has-hole-ht
cache bind-names-cache
@ -140,13 +140,15 @@ before the pattern compiler is invoked.
(hash-set!
ht
(nt-name nt)
(cons compiled-pattern (hash-ref ht (nt-name nt)))))])
(when (may-be-non-list-pattern? (rhs-pattern rhs)
non-list-nt-table)
(add-to-ht ht))
(when (may-be-list-pattern? (rhs-pattern rhs)
list-nt-table)
(add-to-ht list-ht)))))
(cons compiled-pattern (hash-ref ht (nt-name nt)))))]
[may-be-non-list? (may-be-non-list-pattern? (rhs-pattern rhs) non-list-nt-table)]
[may-be-list? (may-be-list-pattern? (rhs-pattern rhs) list-nt-table)])
(when may-be-non-list? (add-to-ht ht))
(when may-be-list? (add-to-ht list-ht))
(unless (or may-be-non-list? may-be-list?)
(error 'compile-language
"unable to determine whether pattern matches lists, non-lists, or both: ~s"
(rhs-pattern rhs))))))
(nt-rhs nt)))
lang))]
[init-ht
@ -171,7 +173,7 @@ before the pattern compiler is invoked.
compatible-context-language)
(do-compilation clang-ht clang-list-ht lang #t)
(do-compilation across-ht across-list-ht compatible-context-language #f)
clang)))
(struct-copy compiled-lang clang [cclang compatible-context-language]))))
;; extract-literals : (listof nt) -> (listof symbol)
(define (extract-literals nts)
@ -495,7 +497,7 @@ before the pattern compiler is invoked.
[`number #t]
[`string #t]
[`variable #t]
[`(variable-except vars ...) #t]
[`(variable-except ,vars ...) #t]
[`variable-not-otherwise-mentioned #t]
[`(variable-prefix ,prefix) #t]
[`hole #t]