suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

fixed a bug with holes used in certain places in patterns

Browse Source 
svn: r14684
This commit is contained in:
Robby Findler 2009-05-02 00:57:18 +00:00
parent 930eec2d02
commit 55a98bf037
5 changed files with 21 additions and 27 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
collects/redex/private/core-layout.ss
View File

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

4
collects/redex/private/reduction-semantics.ss
View File

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

18
collects/redex/private/rewrite-side-conditions.ss
View File

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

2
collects/redex/private/term.ss
View File

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

14
collects/redex/private/tl-test.ss
View File

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