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