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

fixed a bug in the way recursive metafunctions bound the recursive calls for use in 'where' clauses

Browse Source 
svn: r13809
This commit is contained in:
Robby Findler 2009-02-24 01:36:48 +00:00
parent ab47ac0f10
commit b6e60bdd6e
3 changed files with 17 additions and 3 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -977,9 +977,9 @@
[((tl-var tl-exp) ...) bindings]) [((tl-var tl-exp) ...) bindings])
(syntax (syntax
(λ (name bindings) (λ (name bindings)
(term-let-fn ((name name))
(term-let ([names/ellipses (lookup-binding bindings 'names)] ...) (term-let ([names/ellipses (lookup-binding bindings 'names)] ...)
(term-let ([tl-var (term tl-exp)] ...) (term-let ([tl-var (term tl-exp)] ...)
(term-let-fn ((name name))
(term rhs))))))))) (term rhs)))))))))
(syntax->list (syntax (lhs ...))) (syntax->list (syntax (lhs ...)))
(syntax->list (syntax (rhs ...))) (syntax->list (syntax (rhs ...)))

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

@ -34,6 +34,10 @@
(raise-syntax-error what (format "~a expected to have arguments" name) orig-stx stx)) (raise-syntax-error what (format "~a expected to have arguments" name) orig-stx stx))
(let loop ([term orig-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 in-named-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.
(loop #'pre-pat)]
[(side-condition pre-pat exp) [(side-condition pre-pat exp)
(with-syntax ([pat (loop (syntax pre-pat))]) (with-syntax ([pat (loop (syntax pre-pat))])
(let-values ([(names names/ellipses) (extract-names all-nts what bind-names? (syntax pat))]) (let-values ([(names names/ellipses) (extract-names all-nts what bind-names? (syntax pat))])

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

@ -536,6 +536,16 @@
'no-exn) 'no-exn)
'no-exn)) 'no-exn))
(let ()
;; test that 'where' clauses can contain recursive calls.
(define-metafunction empty-language
[(f (any))
x
(where x (f any))]
[(f any) any])
(test (term (f ((((x))))))
(term x)))
;; test that tracing works properly ;; test that tracing works properly
;; note that caching comes into play here (which is why we don't see the recursive calls) ;; note that caching comes into play here (which is why we don't see the recursive calls)
(let () (let ()