diff --git a/collects/redex/private/matcher.rkt b/collects/redex/private/matcher.rkt index dc8d2e74b4..b63388aae3 100644 --- a/collects/redex/private/matcher.rkt +++ b/collects/redex/private/matcher.rkt @@ -2,18 +2,19 @@ #| -Note: the patterns described in the doc.txt file are +Note: the patterns described in the documentation are slightly different than the patterns processed here. The difference is in the form of the side-condition expressions. Here they are procedures that accept binding structures, instead of expressions. The -reduction (And other) macros do this transformation -before the pattern compiler is invoked. +rewrite-side-conditions/check-errs macro does this +transformation before the pattern compiler is invoked. |# (require scheme/list scheme/match scheme/contract + racket/promise "underscore-allowed.rkt") (define-struct compiled-pattern (cp)) @@ -85,9 +86,16 @@ before the pattern compiler is invoked. ;; (listof symbol) ;; (listof (listof symbol))) -- keeps track of `primary' non-terminals -(define-struct compiled-lang (lang cclang ht list-ht across-ht across-list-ht +(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 literals nt-map)) +(define (compiled-lang-cclang x) (force (compiled-lang-delayed-cclang x))) +(define (compiled-lang-across-ht x) + (compiled-lang-cclang x) ;; ensure this is computed + (compiled-lang-raw-across-ht x)) +(define (compiled-lang-across-list-ht x) + (compiled-lang-cclang x) ;; ensure this is computed + (compiled-lang-raw-across-list-ht x)) ;; lookup-binding : bindings (union sym (cons sym sym)) [(-> any)] -> any (define (lookup-binding bindings @@ -160,15 +168,18 @@ before the pattern compiler is invoked. (when (has-underscore? nt) (error 'compile-language "cannot use underscore in nonterminal name, ~s" nt)))) - (let ([compatible-context-language - (build-compatible-context-language clang-ht lang)]) - (for-each (lambda (nt) - (hash-set! across-ht (nt-name nt) null) - (hash-set! across-list-ht (nt-name nt) null)) - compatible-context-language) - (do-compilation clang-ht clang-list-ht lang #t) - (do-compilation across-ht across-list-ht compatible-context-language #f) - (struct-copy compiled-lang clang [cclang compatible-context-language])))) + (define compatible-context-language + (delay + (let ([compatible-context-language + (build-compatible-context-language clang-ht lang)]) + (for-each (lambda (nt) + (hash-set! across-ht (nt-name nt) null) + (hash-set! across-list-ht (nt-name nt) null)) + compatible-context-language) + (do-compilation across-ht across-list-ht compatible-context-language #f) + compatible-context-language))) + (do-compilation clang-ht clang-list-ht lang #t) + (struct-copy compiled-lang clang [delayed-cclang compatible-context-language]))) ;; extract-literals : (listof nt) -> (listof symbol) (define (extract-literals nts) @@ -633,8 +644,6 @@ before the pattern compiler is invoked. (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 across-ht (compiled-lang-across-ht clang)) - (define across-list-ht (compiled-lang-across-list-ht clang)) (define (compile-pattern/default-cache pattern) (compile-pattern/cache pattern @@ -709,19 +718,21 @@ before the pattern compiler is invoked. match-raw-name) has-hole?))])] [`(cross ,(? symbol? pre-id)) - (let ([id (if prefix-cross? - (symbol-append pre-id '- pre-id) - pre-id)]) - (cond - [(hash-maps? across-ht id) - (values - (lambda (exp hole-info) - (match-nt (hash-ref across-list-ht id) - (hash-ref across-ht id) - id exp hole-info)) - #t)] - [else - (error 'compile-pattern "unknown cross reference ~a" id)]))] + (define across-ht (compiled-lang-across-ht clang)) + (define across-list-ht (compiled-lang-across-list-ht clang)) + (define id (if prefix-cross? + (symbol-append pre-id '- pre-id) + pre-id)) + (cond + [(hash-maps? across-ht id) + (values + (lambda (exp hole-info) + (match-nt (hash-ref across-list-ht id) + (hash-ref across-ht id) + id exp hole-info)) + #t)] + [else + (error 'compile-pattern "unknown cross reference ~a" id)])] [`(name ,name ,pat) (let-values ([(match-pat has-hole?) (compile-pattern/default-cache pat)]) @@ -1613,6 +1624,7 @@ before the pattern compiler is invoked. (provide (struct-out nt) (struct-out rhs) (struct-out compiled-lang) + compiled-lang-cclang lookup-binding diff --git a/collects/redex/private/rg.rkt b/collects/redex/private/rg.rkt index 8b6a81579c..0640d96d9f 100644 --- a/collects/redex/private/rg.rkt +++ b/collects/redex/private/rg.rkt @@ -1,4 +1,4 @@ -#lang scheme +#lang scheme/base (require "matcher.rkt" "reduction-semantics.rkt" @@ -6,10 +6,18 @@ "term.rkt" "error.rkt" "struct.rkt" - (for-syntax "rewrite-side-conditions.rkt") - (for-syntax "term-fn.rkt") - (for-syntax "reduction-semantics.rkt") - (for-syntax "keyword-macros.rkt") + (for-syntax scheme/base + "rewrite-side-conditions.rkt" + "term-fn.rkt" + "reduction-semantics.rkt" + "keyword-macros.rkt") + scheme/dict + scheme/contract + scheme/promise + scheme/unit + scheme/match + scheme/pretty + scheme/function mrlib/tex-table) (define redex-pseudo-random-generator @@ -149,7 +157,8 @@ [min-size (apply min/f sizes)]) (map cadr (filter (λ (x) (equal? min-size (car x))) (map list sizes prods))))) -(define-struct rg-lang (non-cross cross base-cases)) +(define-struct rg-lang (non-cross delayed-cross base-cases)) +(define (rg-lang-cross x) (force (rg-lang-delayed-cross x))) (define (prepare-lang lang) (let ([parsed (parse-language lang)]) (values parsed (map symbol->string (compiled-lang-literals lang)) (find-base-cases parsed)))) @@ -405,7 +414,7 @@ (λ (lang bases any?) (make-rg-lang (compile-non-terminals (compiled-lang-lang lang) any?) - (compile-non-terminals (compiled-lang-cclang lang) any?) + (delay (compile-non-terminals (compiled-lang-cclang lang) any?)) bases))] [(langc sexpc compile-pattern) (values @@ -422,7 +431,8 @@ [else t])) (bindings e))))))))) -(define-struct base-cases (cross non-cross)) +(define-struct base-cases (delayed-cross non-cross)) +(define (base-cases-cross x) (force (base-cases-delayed-cross x))) ;; find-base-cases : (list/c nt) -> base-cases (define (find-base-cases lang) @@ -469,7 +479,7 @@ (loop a) (loop b)] [_ (void)])) - nts)) + nts)) ;; build-table : (listof nt) -> hash (define (build-table nts) @@ -479,15 +489,23 @@ nts) tbl)) + ;; we can delay the work of computing the base cases for + ;; the cross part of the language since none of the productions + ;; refer to it (as that's not allowed in general and would be + ;; quite confusing if it were...) (let loop () (set! changed? #f) (for-each (process-nt #f) (compiled-lang-lang lang)) - (for-each (process-nt #t) (compiled-lang-cclang lang)) (when changed? (loop))) - (make-base-cases - (build-table (compiled-lang-cclang lang)) + (delay (begin + (let loop () + (set! changed? #f) + (for-each (process-nt #t) (compiled-lang-cclang lang)) + (when changed? + (loop))) + (build-table (compiled-lang-cclang lang)))) (build-table (compiled-lang-lang lang)))) (define min/f @@ -623,10 +641,10 @@ (define ((parse-rhs mode) rhs) (make-rhs (reassign-classes (parse-pattern (rhs-pattern rhs) lang mode)))) - (struct-copy + (struct-copy compiled-lang lang [lang (map (parse-nt 'grammar) (compiled-lang-lang lang))] - [cclang (map (parse-nt 'cross) (compiled-lang-cclang lang))])) + [delayed-cclang (delay (map (parse-nt 'cross) (compiled-lang-cclang lang)))])) ;; unparse-pattern: parsed-pattern -> pattern (define unparse-pattern @@ -1051,7 +1069,7 @@ (struct-out class) (struct-out binder) (struct-out rg-lang) - (struct-out base-cases) + (struct-out base-cases) base-cases-cross (struct-out counterexample) (struct-out exn:fail:redex:test))