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

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

@ -87,10 +87,11 @@
(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
'compatible-closure (rewrite-side-conditions/check-errs (language-id-nts #'lang 'compatible-closure)
#t 'compatible-closure
(syntax (cross nt)))]) #t
(syntax (cross nt)))])
(syntax (do-context-closure red lang `side-conditions-rewritten 'compatible-closure)))] (syntax (do-context-closure red lang `side-conditions-rewritten 'compatible-closure)))]
[(_ red lang nt) [(_ red lang nt)
(raise-syntax-error 'compatible-closure "expected a non-terminal as last argument" stx (syntax nt))])) (raise-syntax-error 'compatible-closure "expected a non-terminal as last argument" stx (syntax nt))]))
@ -98,10 +99,11 @@
(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
'context-closure (rewrite-side-conditions/check-errs (language-id-nts #'lang 'context-closure)
#t 'context-closure
(syntax pattern))]) #t
(syntax pattern))])
(syntax (syntax
(do-context-closure (do-context-closure
red red
@ -996,39 +998,41 @@
(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)
(build-metafunction (let ([sc `(side-conditions-rewritten ...)]
lang [dsc `dom-side-conditions-rewritten])
(list `side-conditions-rewritten ...) (build-metafunction
(list rhs-fns ...) lang
#,(if prev-metafunction sc
(let ([term-fn (syntax-local-value prev-metafunction)]) (list rhs-fns ...)
#`(metafunc-proc-cps #,(term-fn-get-id term-fn))) #,(if prev-metafunction
#''()) (let ([term-fn (syntax-local-value prev-metafunction)])
#,(if prev-metafunction #`(metafunc-proc-cps #,(term-fn-get-id term-fn)))
(let ([term-fn (syntax-local-value prev-metafunction)]) #''())
#`(metafunc-proc-rhss #,(term-fn-get-id term-fn))) #,(if prev-metafunction
#''()) (let ([term-fn (syntax-local-value prev-metafunction)])
(λ (f/dom cps rhss) #`(metafunc-proc-rhss #,(term-fn-get-id term-fn)))
(make-metafunc-proc #''())
(let ([name (lambda (x) (f/dom x))]) name) (λ (f/dom cps rhss)
(list (list (to-lw lhs-for-lw) (make-metafunc-proc
(list (to-lw/uq side-cond) ...) (let ([name (lambda (x) (f/dom x))]) name)
(list (cons (to-lw bind-id) (list (list (to-lw lhs-for-lw)
(to-lw bind-pat)) (list (to-lw/uq side-cond) ...)
...) (list (cons (to-lw bind-id)
(to-lw rhs)) (to-lw bind-pat))
...) ...)
lang (to-lw rhs))
#t ;; multi-args? ...)
'name lang
cps #t ;; multi-args?
rhss 'name
(let ([name (lambda (x) (name-predicate x))]) name) cps
`dom-side-conditions-rewritten rhss
`(side-conditions-rewritten ...))) (let ([name (lambda (x) (name-predicate x))]) name)
`dom-side-conditions-rewritten dsc
`codom-side-conditions-rewritten sc))
'name)) dsc
'codom-side-conditions-rewritten
'name)))
(term-define-fn name name2)))))))))] (term-define-fn name name2)))))))))]
[(_ prev-metafunction name lang clauses ...) [(_ prev-metafunction name lang clauses ...)
(begin (begin