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) 1 #f)
(test-empty '(variable-except x) 'x #f) (test-empty '(variable-except x) 'x #f)
(test-empty '(variable-except x) 'y (list (make-test-mtch (make-bindings null) 'y none))) (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: (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:) 'x:x (list (make-test-mtch (make-bindings null) 'x:x none)))
(test-empty '(variable-prefix x:) ': #f) (test-empty '(variable-prefix x:) ': #f)
@ -616,6 +618,17 @@
exp) exp)
ans)) 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) (define xab-lang #f)
;; test-xab : sexp[pattern] sexp[term] answer -> void ;; test-xab : sexp[pattern] sexp[term] answer -> void
;; returns #t if pat matching exp with a simple language produces ans. ;; 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 ;; #f means we're not in a `in-hole' context
;; none means we're looking for a hole ;; none means we're looking for a hole
(define-struct compiled-lang (lang ht list-ht across-ht across-list-ht has-hole-ht (define-struct compiled-lang (lang cclang ht list-ht across-ht across-list-ht
cache bind-names-cache pict-builder literals has-hole-ht cache bind-names-cache pict-builder
nt-map)) literals nt-map))
;; lookup-binding : bindings (union sym (cons sym sym)) [(-> any)] -> any ;; lookup-binding : bindings (union sym (cons sym sym)) [(-> any)] -> any
(define (lookup-binding bindings (define (lookup-binding bindings
@ -118,7 +118,7 @@ before the pattern compiler is invoked.
[cache (make-hash)] [cache (make-hash)]
[bind-names-cache (make-hash)] [bind-names-cache (make-hash)]
[literals (extract-literals lang)] [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 across-ht across-list-ht
has-hole-ht has-hole-ht
cache bind-names-cache cache bind-names-cache
@ -140,13 +140,15 @@ before the pattern compiler is invoked.
(hash-set! (hash-set!
ht ht
(nt-name nt) (nt-name nt)
(cons compiled-pattern (hash-ref ht (nt-name nt)))))]) (cons compiled-pattern (hash-ref ht (nt-name nt)))))]
(when (may-be-non-list-pattern? (rhs-pattern rhs) [may-be-non-list? (may-be-non-list-pattern? (rhs-pattern rhs) non-list-nt-table)]
non-list-nt-table) [may-be-list? (may-be-list-pattern? (rhs-pattern rhs) list-nt-table)])
(add-to-ht ht)) (when may-be-non-list? (add-to-ht ht))
(when (may-be-list-pattern? (rhs-pattern rhs) (when may-be-list? (add-to-ht list-ht))
list-nt-table) (unless (or may-be-non-list? may-be-list?)
(add-to-ht list-ht))))) (error 'compile-language
"unable to determine whether pattern matches lists, non-lists, or both: ~s"
(rhs-pattern rhs))))))
(nt-rhs nt))) (nt-rhs nt)))
lang))] lang))]
[init-ht [init-ht
@ -171,7 +173,7 @@ before the pattern compiler is invoked.
compatible-context-language) compatible-context-language)
(do-compilation clang-ht clang-list-ht lang #t) (do-compilation clang-ht clang-list-ht lang #t)
(do-compilation across-ht across-list-ht compatible-context-language #f) (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) ;; extract-literals : (listof nt) -> (listof symbol)
(define (extract-literals nts) (define (extract-literals nts)
@ -495,7 +497,7 @@ before the pattern compiler is invoked.
[`number #t] [`number #t]
[`string #t] [`string #t]
[`variable #t] [`variable #t]
[`(variable-except vars ...) #t] [`(variable-except ,vars ...) #t]
[`variable-not-otherwise-mentioned #t] [`variable-not-otherwise-mentioned #t]
[`(variable-prefix ,prefix) #t] [`(variable-prefix ,prefix) #t]
[`hole #t] [`hole #t]