From 55a98bf037f64453536b72a0a30950afea73c20a Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sat, 2 May 2009 00:57:18 +0000 Subject: [PATCH] fixed a bug with holes used in certain places in patterns svn: r14684 --- collects/redex/private/core-layout.ss | 10 ---------- collects/redex/private/reduction-semantics.ss | 4 ++-- .../redex/private/rewrite-side-conditions.ss | 18 ++++-------------- collects/redex/private/term.ss | 2 +- collects/redex/private/tl-test.ss | 14 ++++++++++++++ 5 files changed, 21 insertions(+), 27 deletions(-) diff --git a/collects/redex/private/core-layout.ss b/collects/redex/private/core-layout.ss index b6cb0df392..5125fb3686 100644 --- a/collects/redex/private/core-layout.ss +++ b/collects/redex/private/core-layout.ss @@ -75,16 +75,6 @@ (equal? (lw-e thing-in-hole) 'hole)) (list (blank) context (blank)) (list (blank) context "" "[" thing-in-hole "]"))))) - (in-named-hole ,(λ (args) - (let ([name (lw-e (list-ref args 2))] - [context (list-ref args 3)] - [thing-in-hole (list-ref args 4)]) - (if (and (lw? thing-in-hole) - (equal? (lw-e thing-in-hole) 'hole)) - (list (blank) context "[]" - (basic-text (format "~a" name) (non-terminal-subscript-style))) - (list (blank) context "" "[" thing-in-hole "]" - (basic-text (format "~a" name) (non-terminal-subscript-style))))))) (hide-hole ,(λ (args) (list (blank) (list-ref args 2) diff --git a/collects/redex/private/reduction-semantics.ss b/collects/redex/private/reduction-semantics.ss index 7fdb50eb2c..b4504a23bf 100644 --- a/collects/redex/private/reduction-semantics.ss +++ b/collects/redex/private/reduction-semantics.ss @@ -1008,8 +1008,8 @@ (with-syntax ([(side-conditions-rewritten ...) (map (λ (x) (rewrite-side-conditions/check-errs lang-nts - #t 'define-metafunction + #t x)) (syntax->list (syntax ((side-condition lhs (and tl-side-conds ...)) ...))))] [dom-side-conditions-rewritten @@ -1398,7 +1398,7 @@ (for-each (λ (name) (let ([x (syntax->datum name)]) - (when (memq x '(any number string variable natural integer real variable-except variable-prefix hole name in-hole in-named-hole hide-hole side-condition cross ...)) + (when (memq x '(any number string variable natural integer real variable-except variable-prefix hole name in-hole hide-hole side-condition cross ...)) (raise-syntax-error 'language (format "cannot use pattern language keyword ~a as non-terminal" x) diff --git a/collects/redex/private/rewrite-side-conditions.ss b/collects/redex/private/rewrite-side-conditions.ss index 58da06c255..2d41087d01 100644 --- a/collects/redex/private/rewrite-side-conditions.ss +++ b/collects/redex/private/rewrite-side-conditions.ss @@ -33,7 +33,7 @@ (define (expected-arguments name stx) (raise-syntax-error what (format "~a expected to have arguments" name) orig-stx stx)) (let loop ([term orig-stx]) - (syntax-case term (side-condition variable-except variable-prefix hole name in-hole in-named-hole hide-hole side-condition cross) + (syntax-case term (side-condition variable-except variable-prefix hole name in-hole hide-hole side-condition cross) [(side-condition pre-pat (and)) ;; rewriting metafunctions (and possibly other things) that have no where, etc clauses ;; end up with side-conditions that are empty 'and' expressions, so we just toss them here. @@ -58,20 +58,15 @@ [(variable-prefix a ...) (expected-exact 'variable-prefix 1 term)] [variable-prefix (expected-arguments 'variable-prefix term)] [hole term] - [(hole a) #`(hole #,(loop #'a))] - [(hole a ...) (raise-syntax-error what "hole expected to stand alone or to have one argument")] [(name x y) #`(name #,(loop #'x) #,(loop #'y))] [(name x ...) (expected-exact 'name 2 term)] [name (expected-arguments 'name term)] [(in-hole a b) #`(in-hole #,(loop #'a) #,(loop #'b))] [(in-hole a ...) (expected-exact 'in-hole 2 term)] [in-hole (expected-arguments 'in-hole term)] - [(in-named-hole a b c) #`(in-named-hole #,(loop #'a) #,(loop #'b) #,(loop #'c))] - [(in-named-hole a ...) (expected-exact 'in-named-hole 3 term)] - [in-named-hole (expected-arguments 'in-named-hole term)] [(hide-hole a) #`(hide-hole #,(loop #'a))] - [(in-named-hole a ...) (expected-exact 'hide-hole 1 term)] - [in-named-hole (expected-arguments 'hide-hole term)] + [(hide-hole a ...) (expected-exact 'hide-hole 1 term)] + [hide-hole (expected-arguments 'hide-hole term)] [(cross a) #`(cross #,(loop #'a))] [(cross a ...) (expected-exact 'cross 1 term)] [cross (expected-arguments 'cross term)] @@ -96,17 +91,12 @@ (let loop ([stx orig-stx] [names null] [depth 0]) - (syntax-case stx (name in-hole in-named-hole side-condition) + (syntax-case stx (name in-hole side-condition) [(name sym pat) (identifier? (syntax sym)) (loop (syntax pat) (cons (make-id/depth (syntax sym) depth) names) depth)] - [(in-named-hole hlnm sym pat1 pat2) - (identifier? (syntax sym)) - (loop (syntax pat1) - (loop (syntax pat2) names depth) - depth)] [(in-hole pat1 pat2) (loop (syntax pat1) (loop (syntax pat2) names depth) diff --git a/collects/redex/private/term.ss b/collects/redex/private/term.ss index 20b7e03cbb..e739cc8f7c 100644 --- a/collects/redex/private/term.ss +++ b/collects/redex/private/term.ss @@ -34,7 +34,7 @@ (define (rewrite/has-term-let-bound-id? stx) (let loop ([stx stx] [depth 0]) - (syntax-case stx (unquote unquote-splicing in-hole in-named-hole hole) + (syntax-case stx (unquote unquote-splicing in-hole hole) [(metafunc-name arg ...) (and (identifier? (syntax metafunc-name)) (term-fn? (syntax-local-value (syntax metafunc-name) (λ () #f)))) diff --git a/collects/redex/private/tl-test.ss b/collects/redex/private/tl-test.ss index a35495e14a..4532823cbd 100644 --- a/collects/redex/private/tl-test.ss +++ b/collects/redex/private/tl-test.ss @@ -546,6 +546,20 @@ (test (term (f ((((x)))))) (term x))) + (let () + (define-language lamv + (z variable hole)) + + (define-metafunction lamv + foo : z -> any + [(foo hole) dontcare] + [(foo variable) docare]) + + (test (term (foo hole)) + (term dontcare)) + (test (term (foo y)) + (term docare))) + ;; test that tracing works properly ;; note that caching comes into play here (which is why we don't see the recursive calls) (let ()