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

avoid duplicating some compiled patterns in the generated code

Browse Source 
svn: r13254
This commit is contained in:
Robby Findler 2009-01-22 02:03:37 +00:00
parent db12513b65
commit 49f015d55b
1 changed files with 45 additions and 41 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -87,7 +87,8 @@
(syntax-case stx ()
[(_ red lang nt)
(identifier? (syntax nt))
(with-syntax ([side-conditions-rewritten (rewrite-side-conditions/check-errs (language-id-nts #'lang 'compatible-closure)
(with-syntax ([side-conditions-rewritten
(rewrite-side-conditions/check-errs (language-id-nts #'lang 'compatible-closure)
'compatible-closure
#t
(syntax (cross nt)))])
@ -98,7 +99,8 @@
(define-syntax (context-closure stx)
(syntax-case stx ()
[(_ red lang pattern)
(with-syntax ([side-conditions-rewritten (rewrite-side-conditions/check-errs (language-id-nts #'lang 'context-closure)
(with-syntax ([side-conditions-rewritten
(rewrite-side-conditions/check-errs (language-id-nts #'lang 'context-closure)
'context-closure
#t
(syntax pattern))])
@ -996,9 +998,11 @@
(map extract-pattern-binds (syntax->list #'(lhs ...)))])
#`(begin
(define-values (name2 name-predicate)
(let ([sc `(side-conditions-rewritten ...)]
[dsc `dom-side-conditions-rewritten])
(build-metafunction
lang
(list `side-conditions-rewritten ...)
sc
(list rhs-fns ...)
#,(if prev-metafunction
(let ([term-fn (syntax-local-value prev-metafunction)])
@ -1024,11 +1028,11 @@
cps
rhss
(let ([name (lambda (x) (name-predicate x))]) name)
`dom-side-conditions-rewritten
`(side-conditions-rewritten ...)))
`dom-side-conditions-rewritten
`codom-side-conditions-rewritten
'name))
dsc
sc))
dsc
'codom-side-conditions-rewritten
'name)))
(term-define-fn name name2)))))))))]
[(_ prev-metafunction name lang clauses ...)
(begin