started to build an implementation of contexts as procedures that do the plugging, but ran into trouble with name patterns
svn: r929
This commit is contained in:
Robby Findler
parent
728f65e9af
commit
2986059cf2
|
|
@ -2,37 +2,39 @@
|
|||
(require "matcher.ss"
|
||||
(lib "list.ss"))
|
||||
|
||||
(define (make-test-mtch a b c) (make-mtch a (build-flat-context b) c))
|
||||
|
||||
(define (test)
|
||||
(print-struct #t)
|
||||
(test-empty 'any 1 (list (make-mtch (make-bindings null) 1 none)))
|
||||
(test-empty 'any 'true (list (make-mtch (make-bindings null) 'true none)))
|
||||
(test-empty 'any "a" (list (make-mtch (make-bindings null) "a" none)))
|
||||
(test-empty 'any '(a b) (list (make-mtch (make-bindings null) '(a b) none)))
|
||||
(test-empty 1 1 (list (make-mtch (make-bindings null) 1 none)))
|
||||
(test-empty 'any 1 (list (make-test-mtch (make-bindings null) 1 none)))
|
||||
(test-empty 'any 'true (list (make-test-mtch (make-bindings null) 'true none)))
|
||||
(test-empty 'any "a" (list (make-test-mtch (make-bindings null) "a" none)))
|
||||
(test-empty 'any '(a b) (list (make-test-mtch (make-bindings null) '(a b) none)))
|
||||
(test-empty 1 1 (list (make-test-mtch (make-bindings null) 1 none)))
|
||||
(test-empty 99999999999999999999999999999999999999999999999
|
||||
99999999999999999999999999999999999999999999999
|
||||
(list (make-mtch (make-bindings null)
|
||||
(list (make-test-mtch (make-bindings null)
|
||||
99999999999999999999999999999999999999999999999
|
||||
none)))
|
||||
(test-empty 'x 'x (list (make-mtch (make-bindings null) 'x none)))
|
||||
(test-empty 'x 'x (list (make-test-mtch (make-bindings null) 'x none)))
|
||||
(test-empty 1 2 #f)
|
||||
(test-empty "a" "b" #f)
|
||||
(test-empty "a" "a" (list (make-mtch (make-bindings null) "a" none)))
|
||||
(test-empty 'number 1 (list (make-mtch (make-bindings null) 1 none)))
|
||||
(test-empty "a" "a" (list (make-test-mtch (make-bindings null) "a" none)))
|
||||
(test-empty 'number 1 (list (make-test-mtch (make-bindings null) 1 none)))
|
||||
(test-empty 'number 'x #f)
|
||||
(test-empty 'string "a" (list (make-mtch (make-bindings null) "a" none)))
|
||||
(test-empty 'string "a" (list (make-test-mtch (make-bindings null) "a" none)))
|
||||
(test-empty 'string 1 #f)
|
||||
(test-empty 'variable 'x (list (make-mtch (make-bindings null) 'x none)))
|
||||
(test-empty 'variable 'x (list (make-test-mtch (make-bindings null) 'x none)))
|
||||
(test-empty 'variable 1 #f)
|
||||
(test-empty '(variable-except x) 1 #f)
|
||||
(test-empty '(variable-except x) 'x #f)
|
||||
(test-empty '(variable-except x) 'y (list (make-mtch (make-bindings null) 'y none)))
|
||||
(test-empty '(variable-except x) 'y (list (make-test-mtch (make-bindings null) 'y none)))
|
||||
(test-empty 'hole 1 #f)
|
||||
(test-empty '(hole hole-name) 1 #f)
|
||||
(test-empty '(name x number) 1 (list (make-mtch (make-bindings (list (make-rib 'x 1))) 1 none)))
|
||||
(test-empty 'number_x 1 (list (make-mtch (make-bindings (list (make-rib 'number_x 1))) 1 none)))
|
||||
(test-empty 'string_y "b" (list (make-mtch (make-bindings (list (make-rib 'string_y "b"))) "b" none)))
|
||||
(test-empty 'any_z '(a b) (list (make-mtch (make-bindings (list (make-rib 'any_z '(a b)))) '(a b) none)))
|
||||
(test-empty '(name x number) 1 (list (make-test-mtch (make-bindings (list (make-rib 'x 1))) 1 none)))
|
||||
(test-empty 'number_x 1 (list (make-test-mtch (make-bindings (list (make-rib 'number_x 1))) 1 none)))
|
||||
(test-empty 'string_y "b" (list (make-test-mtch (make-bindings (list (make-rib 'string_y "b"))) "b" none)))
|
||||
(test-empty 'any_z '(a b) (list (make-test-mtch (make-bindings (list (make-rib 'any_z '(a b)))) '(a b) none)))
|
||||
|
||||
(test-ellipses '(a) '(a))
|
||||
(test-ellipses '(a ...) `(,(make-repeat 'a '())))
|
||||
|
|
@ -59,219 +61,223 @@
|
|||
`(,(make-repeat '(in-hole (name x a) (name y b))
|
||||
(list (make-rib 'x '()) (make-rib 'y '())))))
|
||||
|
||||
(test-empty '() '() (list (make-mtch (make-bindings null) '() none)))
|
||||
(test-empty '(a) '(a) (list (make-mtch (make-bindings null) '(a) none)))
|
||||
(test-empty '() '() (list (make-test-mtch (make-bindings null) '() none)))
|
||||
(test-empty '(a) '(a) (list (make-test-mtch (make-bindings null) '(a) none)))
|
||||
(test-empty '(a) '(b) #f)
|
||||
(test-empty '(a b) '(a b) (list (make-mtch (make-bindings null) '(a b) none)))
|
||||
(test-empty '(a b) '(a b) (list (make-test-mtch (make-bindings null) '(a b) none)))
|
||||
(test-empty '(a b) '(a c) #f)
|
||||
(test-empty '() 1 #f)
|
||||
(test-empty '(#f x) '(#f x) (list (make-mtch (make-bindings null) '(#f x) none)))
|
||||
(test-empty '(#f x) '(#f x) (list (make-test-mtch (make-bindings null) '(#f x) none)))
|
||||
(test-empty '(#f (name y any)) '(#f) #f)
|
||||
(test-empty '(in-hole (z hole) a) '(z a) (list (make-mtch (make-bindings (list)) '(z a) none)))
|
||||
(test-empty '(in-hole (z hole) a) '(z a) (list (make-test-mtch (make-bindings (list)) '(z a) none)))
|
||||
(test-empty '(in-hole (z hole) (in-hole (x hole) a))
|
||||
'(z (x a))
|
||||
(list (make-mtch (make-bindings (list)) '(z (x a)) none)))
|
||||
(list (make-test-mtch (make-bindings (list)) '(z (x a)) none)))
|
||||
|
||||
(test-empty '(in-named-hole h1 (z (hole h1)) a)
|
||||
'(z a)
|
||||
(list (make-mtch (make-bindings (list)) '(z a) none)))
|
||||
(list (make-test-mtch (make-bindings (list)) '(z a) none)))
|
||||
|
||||
(test-empty '(in-named-hole h1 (z (hole h1)) a) '(z a) (list (make-mtch (make-bindings (list)) '(z a) none)))
|
||||
(test-empty '(in-named-hole h1 (z (hole h1)) a) '(z a) (list (make-test-mtch (make-bindings (list)) '(z a) none)))
|
||||
(test-empty '(in-named-hole c (any (hole c)) y)
|
||||
'(x y)
|
||||
(list (make-mtch (make-bindings (list)) '(x y) none)))
|
||||
(list (make-test-mtch (make-bindings (list)) '(x y) none)))
|
||||
(test-empty '(in-named-hole a (in-named-hole b (x (hole b)) (hole a)) y)
|
||||
'(x y)
|
||||
(list (make-mtch (make-bindings (list)) '(x y) none)))
|
||||
(list (make-test-mtch (make-bindings (list)) '(x y) none)))
|
||||
(test-empty '(in-hole (in-hole (x hole) hole) y)
|
||||
'(x y)
|
||||
(list (make-mtch (make-bindings (list)) '(x y) none)))
|
||||
(list (make-test-mtch (make-bindings (list)) '(x y) none)))
|
||||
|
||||
(test-empty '((name x number) (name x number)) '(1 1) (list (make-mtch (make-bindings (list (make-rib 'x 1))) '(1 1) none)))
|
||||
(test-empty '((name x number) (name x number)) '(1 1) (list (make-test-mtch (make-bindings (list (make-rib 'x 1))) '(1 1) none)))
|
||||
(test-empty '((name x number) (name x number)) '(1 2) #f)
|
||||
|
||||
(test-empty '(a ...) '() (list (make-mtch (make-bindings empty) '() none)))
|
||||
(test-empty '(a ...) '(a) (list (make-mtch (make-bindings empty) '(a) none)))
|
||||
(test-empty '(a ...) '(a a) (list (make-mtch (make-bindings empty) '(a a) none)))
|
||||
(test-empty '((name x a) ...) '() (list (make-mtch (make-bindings (list (make-rib 'x '()))) '() none)))
|
||||
(test-empty '((name x a) ...) '(a) (list (make-mtch (make-bindings (list (make-rib 'x '(a)))) '(a) none)))
|
||||
(test-empty '((name x a) ...) '(a a) (list (make-mtch (make-bindings (list (make-rib 'x '(a a)))) '(a a) none)))
|
||||
(test-empty '(a ...) '() (list (make-test-mtch (make-bindings empty) '() none)))
|
||||
(test-empty '(a ...) '(a) (list (make-test-mtch (make-bindings empty) '(a) none)))
|
||||
(test-empty '(a ...) '(a a) (list (make-test-mtch (make-bindings empty) '(a a) none)))
|
||||
(test-empty '((name x a) ...) '() (list (make-test-mtch (make-bindings (list (make-rib 'x '()))) '() none)))
|
||||
(test-empty '((name x a) ...) '(a) (list (make-test-mtch (make-bindings (list (make-rib 'x '(a)))) '(a) none)))
|
||||
(test-empty '((name x a) ...) '(a a) (list (make-test-mtch (make-bindings (list (make-rib 'x '(a a)))) '(a a) none)))
|
||||
|
||||
(test-empty '(b ... a ...) '() (list (make-mtch (make-bindings empty) '() none)))
|
||||
(test-empty '(b ... a ...) '(a) (list (make-mtch (make-bindings empty) '(a) none)))
|
||||
(test-empty '(b ... a ...) '(b) (list (make-mtch (make-bindings empty) '(b) none)))
|
||||
(test-empty '(b ... a ...) '(b a) (list (make-mtch (make-bindings empty) '(b a) none)))
|
||||
(test-empty '(b ... a ...) '(b b a a) (list (make-mtch (make-bindings empty) '(b b a a) none)))
|
||||
(test-empty '(b ... a ...) '(a a) (list (make-mtch (make-bindings empty) '(a a) none)))
|
||||
(test-empty '(b ... a ...) '(b b) (list (make-mtch (make-bindings empty) '(b b) none)))
|
||||
(test-empty '(b ... a ...) '() (list (make-test-mtch (make-bindings empty) '() none)))
|
||||
(test-empty '(b ... a ...) '(a) (list (make-test-mtch (make-bindings empty) '(a) none)))
|
||||
(test-empty '(b ... a ...) '(b) (list (make-test-mtch (make-bindings empty) '(b) none)))
|
||||
(test-empty '(b ... a ...) '(b a) (list (make-test-mtch (make-bindings empty) '(b a) none)))
|
||||
(test-empty '(b ... a ...) '(b b a a) (list (make-test-mtch (make-bindings empty) '(b b a a) none)))
|
||||
(test-empty '(b ... a ...) '(a a) (list (make-test-mtch (make-bindings empty) '(a a) none)))
|
||||
(test-empty '(b ... a ...) '(b b) (list (make-test-mtch (make-bindings empty) '(b b) none)))
|
||||
|
||||
(test-empty '((name y b) ... (name x a) ...) '()
|
||||
(list (make-mtch (make-bindings (list (make-rib 'x '())
|
||||
(list (make-test-mtch (make-bindings (list (make-rib 'x '())
|
||||
(make-rib 'y '())))
|
||||
'()
|
||||
none)))
|
||||
(test-empty '((name y b) ... (name x a) ...) '(a)
|
||||
(list (make-mtch (make-bindings (list (make-rib 'x '(a))
|
||||
(list (make-test-mtch (make-bindings (list (make-rib 'x '(a))
|
||||
(make-rib 'y '())))
|
||||
'(a)
|
||||
none)))
|
||||
(test-empty '((name y b) ... (name x a) ...) '(b)
|
||||
(list (make-mtch (make-bindings (list (make-rib 'x '())
|
||||
(list (make-test-mtch (make-bindings (list (make-rib 'x '())
|
||||
(make-rib 'y '(b))))
|
||||
'(b)
|
||||
none)))
|
||||
(test-empty '((name y b) ... (name x a) ...) '(b b a a)
|
||||
(list (make-mtch (make-bindings (list (make-rib 'x '(a a))
|
||||
(list (make-test-mtch (make-bindings (list (make-rib 'x '(a a))
|
||||
(make-rib 'y '(b b))))
|
||||
'(b b a a)
|
||||
none)))
|
||||
(test-empty '((name y a) ... (name x a) ...) '(a)
|
||||
(list (make-mtch (make-bindings (list (make-rib 'x '())
|
||||
(list (make-test-mtch (make-bindings (list (make-rib 'x '())
|
||||
(make-rib 'y '(a))))
|
||||
'(a)
|
||||
none)
|
||||
(make-mtch (make-bindings (list (make-rib 'x '(a))
|
||||
(make-test-mtch (make-bindings (list (make-rib 'x '(a))
|
||||
(make-rib 'y '())))
|
||||
'(a)
|
||||
none)))
|
||||
(test-empty '((name y a) ... (name x a) ...) '(a a)
|
||||
(list (make-mtch (make-bindings (list (make-rib 'x '())
|
||||
(list (make-test-mtch (make-bindings (list (make-rib 'x '())
|
||||
(make-rib 'y '(a a))))
|
||||
'(a a)
|
||||
none)
|
||||
(make-mtch (make-bindings (list (make-rib 'x '(a))
|
||||
(make-test-mtch (make-bindings (list (make-rib 'x '(a))
|
||||
(make-rib 'y '(a))))
|
||||
'(a a)
|
||||
none)
|
||||
(make-mtch (make-bindings (list (make-rib 'x '(a a))
|
||||
(make-test-mtch (make-bindings (list (make-rib 'x '(a a))
|
||||
(make-rib 'y '())))
|
||||
'(a a)
|
||||
none)))
|
||||
|
||||
(test-ab '(bb_y ... aa_x ...) '()
|
||||
(list (make-mtch (make-bindings (list (make-rib 'aa_x '())
|
||||
(list (make-test-mtch (make-bindings (list (make-rib 'aa_x '())
|
||||
(make-rib 'bb_y '())))
|
||||
'()
|
||||
none)))
|
||||
(test-ab '(bb_y ... aa_x ...) '(a)
|
||||
(list (make-mtch (make-bindings (list (make-rib 'aa_x '(a))
|
||||
(list (make-test-mtch (make-bindings (list (make-rib 'aa_x '(a))
|
||||
(make-rib 'bb_y '())))
|
||||
'(a)
|
||||
none)))
|
||||
(test-ab '(bb_y ... aa_x ...) '(b)
|
||||
(list (make-mtch (make-bindings (list (make-rib 'aa_x '())
|
||||
(list (make-test-mtch (make-bindings (list (make-rib 'aa_x '())
|
||||
(make-rib 'bb_y '(b))))
|
||||
'(b)
|
||||
none)))
|
||||
(test-ab '(bb_y ... aa_x ...) '(b b a a)
|
||||
(list (make-mtch (make-bindings (list (make-rib 'aa_x '(a a))
|
||||
(list (make-test-mtch (make-bindings (list (make-rib 'aa_x '(a a))
|
||||
(make-rib 'bb_y '(b b))))
|
||||
'(b b a a)
|
||||
none)))
|
||||
(test-ab '(aa_y ... aa_x ...) '(a)
|
||||
(list (make-mtch (make-bindings (list (make-rib 'aa_x '())
|
||||
(list (make-test-mtch (make-bindings (list (make-rib 'aa_x '())
|
||||
(make-rib 'aa_y '(a))))
|
||||
'(a)
|
||||
none)
|
||||
(make-mtch (make-bindings (list (make-rib 'aa_x '(a))
|
||||
(make-test-mtch (make-bindings (list (make-rib 'aa_x '(a))
|
||||
(make-rib 'aa_y '())))
|
||||
'(a)
|
||||
none)))
|
||||
(test-ab '(aa_y ... aa_x ...) '(a a)
|
||||
(list (make-mtch (make-bindings (list (make-rib 'aa_x '())
|
||||
(list (make-test-mtch (make-bindings (list (make-rib 'aa_x '())
|
||||
(make-rib 'aa_y '(a a))))
|
||||
'(a a)
|
||||
none)
|
||||
(make-mtch (make-bindings (list (make-rib 'aa_x '(a))
|
||||
(make-test-mtch (make-bindings (list (make-rib 'aa_x '(a))
|
||||
(make-rib 'aa_y '(a))))
|
||||
'(a a)
|
||||
none)
|
||||
(make-mtch (make-bindings (list (make-rib 'aa_x '(a a))
|
||||
(make-test-mtch (make-bindings (list (make-rib 'aa_x '(a a))
|
||||
(make-rib 'aa_y '())))
|
||||
'(a a)
|
||||
none)))
|
||||
|
||||
(test-empty '((name x number) ...) '(1 2) (list (make-mtch (make-bindings (list (make-rib 'x '(1 2)))) '(1 2) none)))
|
||||
(test-empty '((name x number) ...) '(1 2) (list (make-test-mtch (make-bindings (list (make-rib 'x '(1 2)))) '(1 2) none)))
|
||||
|
||||
(test-empty '(a ...) '(b) #f)
|
||||
(test-empty '(a ... b ...) '(c) #f)
|
||||
(test-empty '(a ... b) '(b c) #f)
|
||||
(test-empty '(a ... b) '(a b c) #f)
|
||||
|
||||
(test-xab 'exp 1 (list (make-mtch (make-bindings null) 1 none)))
|
||||
(test-xab 'exp '(+ 1 2) (list (make-mtch (make-bindings null) '(+ 1 2) none)))
|
||||
(test-xab 'exp 1 (list (make-test-mtch (make-bindings null) 1 none)))
|
||||
(test-xab 'exp '(+ 1 2) (list (make-test-mtch (make-bindings null) '(+ 1 2) none)))
|
||||
(test-xab '(in-hole ctxt any)
|
||||
'1
|
||||
(list (make-mtch (make-bindings (list)) 1 none)))
|
||||
(list (make-test-mtch (make-bindings (list)) 1 none)))
|
||||
(test-xab '(in-hole ctxt (name x any))
|
||||
'1
|
||||
(list (make-mtch (make-bindings (list (make-rib 'x 1))) 1 none)))
|
||||
(list (make-test-mtch (make-bindings (list (make-rib 'x 1))) 1 none)))
|
||||
(test-xab '(in-hole (name c ctxt) (name x any))
|
||||
'(+ 1 2)
|
||||
(list (make-mtch (make-bindings (list (make-rib 'c hole) (make-rib 'x '(+ 1 2)))) '(+ 1 2) none)
|
||||
(make-mtch (make-bindings (list (make-rib 'c `(+ ,hole 2)) (make-rib 'x 1))) '(+ 1 2) none)
|
||||
(make-mtch (make-bindings (list (make-rib 'c `(+ 1 ,hole)) (make-rib 'x 2))) '(+ 1 2) none)))
|
||||
(list (make-test-mtch (make-bindings (list (make-rib 'c (build-context hole)) (make-rib 'x '(+ 1 2)))) '(+ 1 2) none)
|
||||
(make-test-mtch (make-bindings (list (make-rib 'c (build-context `(+ ,hole 2)))
|
||||
(make-rib 'x 1)))
|
||||
'(+ 1 2) none)
|
||||
(make-test-mtch (make-bindings (list (make-rib 'c (build-context `(+ 1 ,hole)))
|
||||
(make-rib 'x 2))) '(+ 1 2) none)))
|
||||
(test-xab '(in-hole (name c ctxt) (name i (+ number number)))
|
||||
'(+ (+ 1 2) (+ 3 4))
|
||||
(list (make-mtch (make-bindings (list (make-rib 'i '(+ 1 2)) (make-rib 'c `(+ ,hole (+ 3 4)))))
|
||||
'(+ (+ 1 2) (+ 3 4))
|
||||
none)
|
||||
(make-mtch (make-bindings (list (make-rib 'i '(+ 3 4)) (make-rib 'c `(+ (+ 1 2) ,hole))))
|
||||
(list (make-test-mtch
|
||||
(make-bindings (list (make-rib 'i '(+ 1 2)) (make-rib 'c (build-context `(+ ,hole (+ 3 4))))))
|
||||
'(+ (+ 1 2) (+ 3 4))
|
||||
none)
|
||||
(make-test-mtch (make-bindings (list (make-rib 'i '(+ 3 4)) (make-rib 'c `(+ (+ 1 2) ,hole))))
|
||||
'(+ (+ 1 2) (+ 3 4))
|
||||
none)))
|
||||
|
||||
(test-empty '(in-hole ((z hole)) (name x any))
|
||||
'((z a))
|
||||
(list (make-mtch (make-bindings (list (make-rib 'x 'a))) '((z a)) none)))
|
||||
(list (make-test-mtch (make-bindings (list (make-rib 'x 'a))) '((z a)) none)))
|
||||
(test-empty '(in-hole (name c (z ... hole z ...)) any)
|
||||
'(z z)
|
||||
(list
|
||||
(make-mtch (make-bindings (list (make-rib 'c `(z ,hole)))) '(z z) none)
|
||||
(make-mtch (make-bindings (list (make-rib 'c `(,hole z)))) '(z z) none)))
|
||||
(make-test-mtch (make-bindings (list (make-rib 'c `(z ,hole)))) '(z z) none)
|
||||
(make-test-mtch (make-bindings (list (make-rib 'c `(,hole z)))) '(z z) none)))
|
||||
(test-empty '(in-hole (name c (z ... hole z ...)) any)
|
||||
'(z z z)
|
||||
(list
|
||||
(make-mtch (make-bindings (list (make-rib 'c `(z z ,hole)))) '(z z z) none)
|
||||
(make-mtch (make-bindings (list (make-rib 'c `(z ,hole z)))) '(z z z) none)
|
||||
(make-mtch (make-bindings (list (make-rib 'c `(,hole z z)))) '(z z z) none)))
|
||||
(make-test-mtch (make-bindings (list (make-rib 'c `(z z ,hole)))) '(z z z) none)
|
||||
(make-test-mtch (make-bindings (list (make-rib 'c `(z ,hole z)))) '(z z z) none)
|
||||
(make-test-mtch (make-bindings (list (make-rib 'c `(,hole z z)))) '(z z z) none)))
|
||||
|
||||
(test-empty '(z (in-hole (name c (z hole)) a))
|
||||
'(z (z a))
|
||||
(list
|
||||
(make-mtch (make-bindings (list (make-rib 'c `(z ,hole))))
|
||||
(make-test-mtch (make-bindings (list (make-rib 'c `(z ,hole))))
|
||||
'(z (z a))
|
||||
none)))
|
||||
|
||||
(test-empty '(a (in-hole (name c1 (b (in-hole (name c2 (c hole)) d) hole)) e))
|
||||
'(a (b (c d) e))
|
||||
(list
|
||||
(make-mtch (make-bindings (list (make-rib 'c2 `(c ,hole))
|
||||
(make-test-mtch (make-bindings (list (make-rib 'c2 `(c ,hole))
|
||||
(make-rib 'c1 `(b (c d) ,hole))))
|
||||
'(a (b (c d) e))
|
||||
none)))
|
||||
|
||||
(test-empty '(in-hole (in-hole hole hole) a)
|
||||
'a
|
||||
(list (make-mtch (make-bindings (list)) 'a none)))
|
||||
(list (make-test-mtch (make-bindings (list)) 'a none)))
|
||||
|
||||
(test-empty '(a (b (in-hole (name c1 (in-hole (name c2 (c hole)) (d hole))) e)))
|
||||
'(a (b (c (d e))))
|
||||
(list
|
||||
(make-mtch (make-bindings (list (make-rib 'c1 `(c (d ,hole)))
|
||||
(make-test-mtch (make-bindings (list (make-rib 'c1 `(c (d ,hole)))
|
||||
(make-rib 'c2 `(c ,hole))))
|
||||
'(a (b (c (d e))))
|
||||
none)))
|
||||
|
||||
(test-empty `(+ 1 (side-condition any ,(lambda (bindings) #t)))
|
||||
'(+ 1 b)
|
||||
(list (make-mtch (make-bindings '()) '(+ 1 b) none)))
|
||||
(list (make-test-mtch (make-bindings '()) '(+ 1 b) none)))
|
||||
(test-empty `(+ 1 (side-condition any ,(lambda (bindings) #f)))
|
||||
'(+ 1 b)
|
||||
#f)
|
||||
|
||||
(test-empty `(+ 1 (side-condition b ,(lambda (bindings) #t)))
|
||||
'(+ 1 b)
|
||||
(list (make-mtch (make-bindings '()) '(+ 1 b) none)))
|
||||
(list (make-test-mtch (make-bindings '()) '(+ 1 b) none)))
|
||||
(test-empty `(+ 1 (side-condition a ,(lambda (bindings) #t)))
|
||||
'(+ 1 b)
|
||||
#f)
|
||||
|
|
@ -279,14 +285,14 @@
|
|||
(test-empty `(side-condition (name x any) ,(lambda (bindings) (eq? (lookup-binding bindings 'x) 'a)))
|
||||
'a
|
||||
(list
|
||||
(make-mtch (make-bindings (list (make-rib 'x 'a)))
|
||||
(make-test-mtch (make-bindings (list (make-rib 'x 'a)))
|
||||
'a
|
||||
none)))
|
||||
|
||||
(test-empty `(+ 1 (side-condition (name x any) ,(lambda (bindings) (eq? (lookup-binding bindings 'x) 'a))))
|
||||
'(+ 1 a)
|
||||
(list
|
||||
(make-mtch (make-bindings (list (make-rib 'x 'a)))
|
||||
(make-test-mtch (make-bindings (list (make-rib 'x 'a)))
|
||||
'(+ 1 a)
|
||||
none)))
|
||||
|
||||
|
|
@ -300,10 +306,10 @@
|
|||
|
||||
(test-xab 'exp_1
|
||||
'(+ 1 2)
|
||||
(list (make-mtch (make-bindings (list (make-rib 'exp_1 '(+ 1 2)))) '(+ 1 2) none)))
|
||||
(list (make-test-mtch (make-bindings (list (make-rib 'exp_1 '(+ 1 2)))) '(+ 1 2) none)))
|
||||
(test-xab '(exp_1 exp_2)
|
||||
'((+ 1 2) (+ 3 4))
|
||||
(list (make-mtch (make-bindings (list (make-rib 'exp_1 '(+ 1 2)) (make-rib 'exp_2 '(+ 3 4))))
|
||||
(list (make-test-mtch (make-bindings (list (make-rib 'exp_1 '(+ 1 2)) (make-rib 'exp_2 '(+ 3 4))))
|
||||
'((+ 1 2) (+ 3 4))
|
||||
none)))
|
||||
(test-xab '(exp_1 exp_1)
|
||||
|
|
@ -311,23 +317,23 @@
|
|||
#f)
|
||||
(test-xab 'nesting-names
|
||||
'b
|
||||
(list (make-mtch (make-bindings (list)) 'b none)))
|
||||
(list (make-test-mtch (make-bindings (list)) 'b none)))
|
||||
(test-xab 'nesting-names
|
||||
'(a b)
|
||||
(list (make-mtch (make-bindings (list)) '(a b) none)))
|
||||
(list (make-test-mtch (make-bindings (list)) '(a b) none)))
|
||||
(test-xab 'nesting-names
|
||||
'(a (a b))
|
||||
(list (make-mtch (make-bindings (list)) '(a (a b)) none)))
|
||||
(list (make-test-mtch (make-bindings (list)) '(a (a b)) none)))
|
||||
(test-xab '((name x a) nesting-names)
|
||||
'(a (a (a b)))
|
||||
(list (make-mtch (make-bindings (list (make-rib 'x 'a))) '(a (a (a b))) none)))
|
||||
(list (make-test-mtch (make-bindings (list (make-rib 'x 'a))) '(a (a (a b))) none)))
|
||||
(test-xab 'nesting-names
|
||||
'(a (a (a (a b))))
|
||||
(list (make-mtch (make-bindings (list)) '(a (a (a (a b)))) none)))
|
||||
(list (make-test-mtch (make-bindings (list)) '(a (a (a (a b)))) none)))
|
||||
|
||||
(test-xab 'same-in-nt
|
||||
'(x x)
|
||||
(list (make-mtch (make-bindings (list)) '(x x) none)))
|
||||
(list (make-test-mtch (make-bindings (list)) '(x x) none)))
|
||||
(test-xab 'same-in-nt
|
||||
'(x y)
|
||||
#f)
|
||||
|
|
@ -556,12 +562,13 @@
|
|||
(and (pair? snd)
|
||||
(loop (car fst) (car snd))
|
||||
(loop (cdr fst) (cdr snd)))]
|
||||
[(and (mtch? fst)
|
||||
(mtch? snd))
|
||||
(and (loop (mtch-bindings fst)
|
||||
[(mtch? fst)
|
||||
(and (mtch? snd)
|
||||
(loop (mtch-bindings fst)
|
||||
(mtch-bindings snd))
|
||||
(equal? (mtch-context fst)
|
||||
(mtch-context snd))
|
||||
(let ([g1 (gensym 'run-match-test-sym)])
|
||||
(equal? (plug (mtch-context fst) g1)
|
||||
(plug (mtch-context snd) g1)))
|
||||
(equal? (mtch-hole fst)
|
||||
(mtch-hole snd)))]
|
||||
[(bindings? fst)
|
||||
|
|
@ -574,8 +581,27 @@
|
|||
loop
|
||||
(quicksort fst-table rib-lt)
|
||||
(quicksort snd-table rib-lt)))))]
|
||||
[(and (rib? fst)
|
||||
(rib? snd)
|
||||
(context? (rib-exp fst))
|
||||
(context? (rib-exp snd)))
|
||||
(and (equal? (rib-name fst) (rib-name snd))
|
||||
(let ([g (gensym 'run-match-test-sym2)])
|
||||
(equal? (plug (rib-exp fst) g)
|
||||
(plug (rib-exp snd) g))))]
|
||||
[else (equal? fst snd)])))
|
||||
|
||||
(define (build-context c)
|
||||
(let loop ([c c])
|
||||
(cond
|
||||
[(eq? c hole) hole]
|
||||
[(pair? c) (build-cons-context (loop (car c)) (loop (cdr c)))]
|
||||
[(or (null? c)
|
||||
(number? c)
|
||||
(symbol? c))
|
||||
(build-flat-context c)]
|
||||
[else (error 'build-context "unknown ~s" c)])))
|
||||
|
||||
;; rib-lt : rib rib -> boolean
|
||||
(define (rib-lt r1 r2) (string<=? (format "~s" (rib-name r1))
|
||||
(format "~s" (rib-name r2))))
|
||||
|
|
|
|||
|
|
@ -66,10 +66,6 @@ before the pattern compiler is invoked.
|
|||
(define-struct none ())
|
||||
(make-none)))
|
||||
(define (none? x) (eq? x none))
|
||||
(define hole
|
||||
(let ()
|
||||
(define-struct hole ())
|
||||
(make-hole)))
|
||||
|
||||
;; compiled-lang : (make-compiled-lang (listof nt)
|
||||
;; hash-table[sym -o> compiled-pattern]
|
||||
|
|
@ -344,27 +340,40 @@ before the pattern compiler is invoked.
|
|||
(match pattern
|
||||
[`any
|
||||
(values
|
||||
(lambda (exp hole-info) (list (make-mtch (make-bindings null) exp none)))
|
||||
(lambda (exp hole-info) (list (make-mtch
|
||||
(make-bindings null)
|
||||
(build-flat-context exp)
|
||||
none)))
|
||||
#f)]
|
||||
[`number
|
||||
(values
|
||||
(lambda (exp hole-info) (and (number? exp) (list (make-mtch (make-bindings null) exp none))))
|
||||
(lambda (exp hole-info) (and (number? exp) (list (make-mtch
|
||||
(make-bindings null)
|
||||
(build-flat-context exp)
|
||||
none))))
|
||||
#f)]
|
||||
[`string
|
||||
(values
|
||||
(lambda (exp hole-info) (and (string? exp) (list (make-mtch (make-bindings null) exp none))))
|
||||
(lambda (exp hole-info) (and (string? exp) (list (make-mtch
|
||||
(make-bindings null)
|
||||
(build-flat-context exp)
|
||||
none))))
|
||||
#f)]
|
||||
[`variable
|
||||
(values
|
||||
(lambda (exp hole-info)
|
||||
(and (symbol? exp) (list (make-mtch (make-bindings null) exp none))))
|
||||
(and (symbol? exp) (list (make-mtch (make-bindings null)
|
||||
(build-flat-context exp)
|
||||
none))))
|
||||
#f)]
|
||||
[`(variable-except ,@(vars ...))
|
||||
(values
|
||||
(lambda (exp hole-info)
|
||||
(and (symbol? exp)
|
||||
(not (memq exp vars))
|
||||
(list (make-mtch (make-bindings null) exp none))))
|
||||
(list (make-mtch (make-bindings null)
|
||||
(build-flat-context exp)
|
||||
none))))
|
||||
#f)]
|
||||
[`hole (values (match-hole none) #t)]
|
||||
[`(hole ,hole-id) (values (match-hole hole-id) #t)]
|
||||
|
|
@ -373,7 +382,9 @@ before the pattern compiler is invoked.
|
|||
(lambda (exp hole-info)
|
||||
(and (string? exp)
|
||||
(string=? exp pattern)
|
||||
(list (make-mtch (make-bindings null) exp none))))
|
||||
(list (make-mtch (make-bindings null)
|
||||
(build-flat-context exp)
|
||||
none))))
|
||||
#f)]
|
||||
[(? symbol?)
|
||||
(cond
|
||||
|
|
@ -392,7 +403,9 @@ before the pattern compiler is invoked.
|
|||
(compile-pattern/cache `(name ,pattern ,before)))]
|
||||
[else
|
||||
(values
|
||||
(lambda (exp hole-info) (and (eq? exp pattern) (list (make-mtch (make-bindings null) exp none))))
|
||||
(lambda (exp hole-info) (and (eq? exp pattern) (list (make-mtch (make-bindings null)
|
||||
(build-flat-context exp)
|
||||
none))))
|
||||
#f)])]
|
||||
|
||||
[`(cross ,(? symbol? pre-id))
|
||||
|
|
@ -461,12 +474,13 @@ before the pattern compiler is invoked.
|
|||
(values
|
||||
(lambda (exp hole-info)
|
||||
(and (eqv? pattern exp)
|
||||
(list (make-mtch (make-bindings null) exp none))))
|
||||
(list (make-mtch (make-bindings null)
|
||||
(build-flat-context exp)
|
||||
none))))
|
||||
#f)]))
|
||||
|
||||
(compile-pattern/cache pattern))
|
||||
|
||||
|
||||
;; split-underscore : symbol -> symbol
|
||||
;; returns the text before the underscore in a symbol (as a symbol)
|
||||
;; raise an error if there is more than one underscore in the input
|
||||
|
|
@ -580,18 +594,13 @@ before the pattern compiler is invoked.
|
|||
(make-mtch (make-bindings
|
||||
(append (bindings-table contractum-bindings)
|
||||
(bindings-table bindings)))
|
||||
(plug (mtch-context mtch) (mtch-context contractum-mtch))
|
||||
(build-nested-context
|
||||
(mtch-context mtch)
|
||||
(mtch-context contractum-mtch))
|
||||
(mtch-hole contractum-mtch))
|
||||
acc)))]))
|
||||
(loop (cdr mtches) acc)))]))))))
|
||||
|
||||
(define (plug exp hole-stuff)
|
||||
(let loop ([exp exp])
|
||||
(cond
|
||||
[(pair? exp) (cons (loop (car exp)) (loop (cdr exp)))]
|
||||
[(eq? exp hole) hole-stuff]
|
||||
[else exp])))
|
||||
|
||||
;; match-list : (listof (union repeat compiled-pattern)) sexp hole-info -> (union #f (listof bindings))
|
||||
(define (match-list patterns exp hole-info)
|
||||
(let (;; raw-match : (listof (listof (listof mtch)))
|
||||
|
|
@ -638,7 +647,7 @@ before the pattern compiler is invoked.
|
|||
(if (or (null? exp) (pair? exp))
|
||||
(let ([r-pat (repeat-pat fst-pat)]
|
||||
[r-mt (make-mtch (make-bindings (repeat-empty-bindings fst-pat))
|
||||
'()
|
||||
(build-flat-context '())
|
||||
none)])
|
||||
(apply
|
||||
append
|
||||
|
|
@ -675,7 +684,7 @@ before the pattern compiler is invoked.
|
|||
[match (fst-pat fst-exp hole-info)])
|
||||
(if match
|
||||
(let ([exp-match (map (λ (mtch) (make-mtch (mtch-bindings mtch)
|
||||
(list (mtch-context mtch))
|
||||
(build-list-context (mtch-context mtch))
|
||||
(mtch-hole mtch)))
|
||||
match)])
|
||||
(map (lambda (x) (cons exp-match x))
|
||||
|
|
@ -709,8 +718,9 @@ before the pattern compiler is invoked.
|
|||
(hash-table-put! ht key (cons (rib-exp single-rib) rst))))
|
||||
(bindings-table single-bindings))
|
||||
(make-mtch (make-bindings (hash-table-map ht make-rib))
|
||||
(cons (mtch-context single-match)
|
||||
(mtch-context multiple-match))
|
||||
(build-cons-context
|
||||
(mtch-context single-match)
|
||||
(mtch-context multiple-match))
|
||||
(pick-hole (mtch-hole single-match)
|
||||
(mtch-hole multiple-match))))))
|
||||
bindingss)))
|
||||
|
|
@ -734,7 +744,7 @@ before the pattern compiler is invoked.
|
|||
(make-rib (rib-name rib)
|
||||
(reverse (rib-exp rib))))
|
||||
(bindings-table bindings)))
|
||||
(reverse (mtch-context match))
|
||||
(reverse-context (mtch-context match))
|
||||
(mtch-hole match))))
|
||||
matches))
|
||||
|
||||
|
|
@ -842,7 +852,7 @@ before the pattern compiler is invoked.
|
|||
(define (combine-matches matchess)
|
||||
(let loop ([matchess matchess])
|
||||
(cond
|
||||
[(null? matchess) (list (make-mtch (make-bindings null) '() none))]
|
||||
[(null? matchess) (list (make-mtch (make-bindings null) (build-flat-context '()) none))]
|
||||
[else (combine-pair (car matchess) (loop (cdr matchess)))])))
|
||||
|
||||
;; combine-pair : (listof mtch) (listof mtch) -> (listof mtch)
|
||||
|
|
@ -855,7 +865,7 @@ before the pattern compiler is invoked.
|
|||
(set! mtchs (cons (make-mtch
|
||||
(make-bindings (append (bindings-table (mtch-bindings mtch1))
|
||||
(bindings-table (mtch-bindings mtch2))))
|
||||
(append (mtch-context mtch1) (mtch-context mtch2))
|
||||
(build-append-context (mtch-context mtch1) (mtch-context mtch2))
|
||||
(pick-hole (mtch-hole mtch1)
|
||||
(mtch-hole mtch2)))
|
||||
mtchs)))
|
||||
|
|
@ -869,6 +879,51 @@ before the pattern compiler is invoked.
|
|||
#t))
|
||||
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;
|
||||
;; context adt
|
||||
;;
|
||||
|
||||
#|
|
||||
This ADT isn't right yet -- need to figure out what to do about (name ...) patterns.
|
||||
|
||||
(define-values (struct:context make-context context? context-ref context-set!)
|
||||
(make-struct-type 'context #f 1 0 #f '() #f 0))
|
||||
(define hole values)
|
||||
(define (build-flat-context exp) (make-context (lambda (x) exp)))
|
||||
(define (build-cons-context c1 c2) (make-context (lambda (x) (cons (c1 x) (c2 x)))))
|
||||
(define (build-append-context l1 l2) (make-context (lambda (x) (append (l1 x) (l2 x)))))
|
||||
(define (build-list-context l) (make-context (lambda (x) (list (l x)))))
|
||||
(define (build-nested-context c1 c2) (make-context (lambda (x) (c1 (c2 x)))))
|
||||
(define (plug exp hole-stuff) (exp hole-stuff))
|
||||
(define (reverse-context c) (make-context (lambda (x) (reverse (c x)))))
|
||||
|#
|
||||
(define (context? x) #t)
|
||||
(define hole
|
||||
(let ()
|
||||
(define-struct hole ())
|
||||
(make-hole)))
|
||||
|
||||
(define (build-flat-context exp) exp)
|
||||
(define (build-cons-context e1 e2) (cons e1 e2))
|
||||
(define (build-append-context e1 e2) (append e1 e2))
|
||||
(define (build-list-context x) (list x))
|
||||
(define (reverse-context x) (reverse x))
|
||||
(define (build-nested-context c1 c2) (plug c1 c2))
|
||||
(define (plug exp hole-stuff)
|
||||
(let loop ([exp exp])
|
||||
(cond
|
||||
[(pair? exp) (cons (loop (car exp)) (loop (cdr exp)))]
|
||||
[(eq? exp hole) hole-stuff]
|
||||
[else exp])))
|
||||
|
||||
;;
|
||||
;; end context adt
|
||||
;;
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
|
||||
|
||||
(provide/contract
|
||||
(match-pattern (compiled-pattern any/c . -> . (union false/c (listof mtch?))))
|
||||
(compile-pattern (compiled-lang? any/c . -> . compiled-pattern))
|
||||
|
|
@ -888,6 +943,11 @@ before the pattern compiler is invoked.
|
|||
(rib-name (rib? . -> . symbol?))
|
||||
(rib-exp (rib? . -> . any/c)))
|
||||
|
||||
;; for test suite
|
||||
(provide build-cons-context
|
||||
build-flat-context
|
||||
context?)
|
||||
|
||||
(provide (struct nt (name rhs))
|
||||
(struct rhs (pattern))
|
||||
(struct compiled-lang (lang ht across-ht has-hole-ht cache))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user