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

propagate module-begin certificates on src2src optimization

Browse Source 
svn: r4073
This commit is contained in:
Matthew Flatt 2006-08-16 23:10:13 +00:00
parent 87e78e0f96
commit ca973ccae1
1 changed files with 17 additions and 10 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

27
collects/compiler/src2src.ss
View File

@ -1388,7 +1388,7 @@
(define module% (define module%
(class exp% (class exp%
(init-field body et-body name init-req req-prov tables) (init-field body et-body name init-req req-prov tables src-module-begin-stx)
(super-instantiate ()) (super-instantiate ())
(inherit-field src-stx) (inherit-field src-stx)
@ -1543,13 +1543,17 @@
[(body ...) (map get-sexpr body)] [(body ...) (map get-sexpr body)]
[(et-body ...) (map get-sexpr et-body)] [(et-body ...) (map get-sexpr et-body)]
[(req-prov ...) (map get-sexpr req-prov)]) [(req-prov ...) (map get-sexpr req-prov)])
(recertify (with-syntax ([body
(syntax/loc src-stx (syntax-recertify #'(#%plain-module-begin
(module name init-req req-prov ...
(#%plain-module-begin body ...
req-prov ... et-body ...)
body ... src-module-begin-stx
et-body ...)))))) recert-insp
#f)])
(recertify
(syntax/loc src-stx
(module name init-req body))))))
(define/override (body-sexpr) (define/override (body-sexpr)
(list (sexpr))))) (list (sexpr)))))
@ -1808,7 +1812,10 @@
(syntax name) (syntax name)
(syntax init-require) (syntax init-require)
req-prov req-prov
tables stx))] tables
(syntax-case stx ()
[(m n ir mb) #'mb])
stx))]
[(require . i) (make-object require/provide% stx)] [(require . i) (make-object require/provide% stx)]
[(require-for-syntax . i) (make-object require/provide% stx)] [(require-for-syntax . i) (make-object require/provide% stx)]
@ -1833,7 +1840,7 @@
(opt-lambda (e [for-mzc? #f]) (opt-lambda (e [for-mzc? #f])
(let ([p (parse-top e null #f #f (create-tables))]) (let ([p (parse-top e null #f #f (create-tables))])
(send p set-mutability) (send p set-mutability)
(send p reorganize) (send p reorganize)
(send p set-known-values) (send p set-known-values)
(let ([p (send p simplify (make-context 'all null))]) (let ([p (send p simplify (make-context 'all null))])
(let ([v (get-sexpr (if for-mzc? (let ([v (get-sexpr (if for-mzc?