diff --git a/collects/redex/private/hole-test.ss b/collects/redex/private/hole-test.ss new file mode 100644 index 0000000000..b983d4e582 --- /dev/null +++ b/collects/redex/private/hole-test.ss @@ -0,0 +1,17 @@ +#lang scheme +(require redex) + +(define-language tl-grammar + [v (cont (hide-hole E))] + [E hole + (v ... E)]) + +(define the-test + (reduction-relation + tl-grammar + [--> (in-hole E_1 (explode)) + (in-hole E_1 1)])) + +(test--> the-test + (term ((cont hole) (explode))) + (term ((cont hole) 1))) \ No newline at end of file diff --git a/collects/redex/private/matcher-test.ss b/collects/redex/private/matcher-test.ss index 2c1af7ccc4..94fc3ff8ea 100644 --- a/collects/redex/private/matcher-test.ss +++ b/collects/redex/private/matcher-test.ss @@ -72,8 +72,8 @@ (test-empty '(in-hole (name E_1 ((hide-hole hole) hole)) x) `(,the-hole x) - (list (make-test-mtch (make-bindings (list (make-bind 'E_1 `(,the-hole ,the-hole)))) - `(x ,the-hole) + (list (make-test-mtch (make-bindings (list (make-bind 'E_1 `(,the-not-hole ,the-hole)))) + `(,the-hole x) none))) diff --git a/collects/redex/private/matcher.ss b/collects/redex/private/matcher.ss index eeb9e59466..5bc715f8f6 100644 --- a/collects/redex/private/matcher.ss +++ b/collects/redex/private/matcher.ss @@ -761,7 +761,7 @@ before the pattern compiler is invoked. (lambda (exp hole-info) (let ([matches (match-pat exp #f)]) (and matches - (map (λ (match) (make-mtch (mtch-bindings match) (mtch-context match) none)) + (map (λ (match) (make-mtch (mtch-bindings match) (hole->not-hole (mtch-context match)) none)) matches)))) #f))] @@ -1562,6 +1562,18 @@ before the pattern compiler is invoked. (define-struct hole () #:inspector #f) (define the-hole (make-hole)) (values the-hole hole?))) +(define-values (the-not-hole not-hole?) + (let () + (define-struct not-hole () #:inspector #f) + (define the-not-hole (make-not-hole)) + (values the-not-hole not-hole?))) + +(define hole->not-hole + (match-lambda + [(? hole?) the-not-hole] + [(list-rest f r) + (cons (hole->not-hole f) (hole->not-hole r))] + [x x])) (define (build-flat-context exp) exp) (define (build-cons-context e1 e2) (cons e1 e2)) @@ -1579,13 +1591,14 @@ before the pattern compiler is invoked. (cond [(pair? exp) (cons (loop (car exp)) - (if done? - (cdr exp) - (loop (cdr exp))))] - + (loop (cdr exp)))] + [(not-hole? exp) + the-hole] [(hole? exp) - (set! done? #t) - hole-stuff] + (if done? + the-hole + (begin (set! done? #t) + hole-stuff))] [else exp])))])) ;; @@ -1641,7 +1654,7 @@ before the pattern compiler is invoked. none? none make-repeat - the-hole hole? + the-not-hole the-hole hole? rewrite-ellipses build-compatible-context-language caching-enabled?) diff --git a/collects/redex/private/run-tests.ss b/collects/redex/private/run-tests.ss index bdbfb0a8e9..fd4ed9992b 100644 --- a/collects/redex/private/run-tests.ss +++ b/collects/redex/private/run-tests.ss @@ -12,7 +12,8 @@ "keyword-macros-test.ss" "core-layout-test.ss" "bitmap-test.ss" - "pict-test.ss")) + "pict-test.ss" + "hole-test.ss")) (define-runtime-path here ".") diff --git a/collects/redex/private/test-util.ss b/collects/redex/private/test-util.ss index 627e351dc5..e973b69762 100644 --- a/collects/redex/private/test-util.ss +++ b/collects/redex/private/test-util.ss @@ -8,7 +8,7 @@ (define syn-err-test-namespace (make-base-namespace)) (parameterize ([current-namespace syn-err-test-namespace]) - (eval '(require "../reduction-semantics.ss"))) + (eval '(require redex/reduction-semantics))) (define-syntax (test stx) (syntax-case stx ()