A fix for my example hide hole based models

svn: r15715

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)))

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)))
     
 

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?)

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 ".")
 

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 ()