fix certificate problems related to module-begin
svn: r3553
This commit is contained in:
parent
cb8ac0ea05
commit
dd3a4d56ef
|
@ -266,6 +266,8 @@
|
||||||
|
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
|
|
||||||
|
(define orig-inspector (current-code-inspector))
|
||||||
|
|
||||||
(define errortrace-annotate
|
(define errortrace-annotate
|
||||||
(lambda (top-e)
|
(lambda (top-e)
|
||||||
(define (normal e)
|
(define (normal e)
|
||||||
|
@ -280,13 +282,17 @@
|
||||||
[(module name init-import (#%plain-module-begin body ...))
|
[(module name init-import (#%plain-module-begin body ...))
|
||||||
(normal
|
(normal
|
||||||
#`(module name init-import
|
#`(module name init-import
|
||||||
(#%plain-module-begin
|
#,(syntax-recertify
|
||||||
|
#`(#%plain-module-begin
|
||||||
#,((make-syntax-introducer)
|
#,((make-syntax-introducer)
|
||||||
#'(require (lib "errortrace-key.ss" "errortrace")))
|
#'(require (lib "errortrace-key.ss" "errortrace")))
|
||||||
#,((make-syntax-introducer)
|
#,((make-syntax-introducer)
|
||||||
#'(require-for-syntax
|
#'(require-for-syntax
|
||||||
(lib "errortrace-key.ss" "errortrace")))
|
(lib "errortrace-key.ss" "errortrace")))
|
||||||
body ...)))])))]
|
body ...)
|
||||||
|
(list-ref (syntax->list top-e) 3)
|
||||||
|
orig-inspector
|
||||||
|
#f)))])))]
|
||||||
[_else
|
[_else
|
||||||
(normal top-e)])))
|
(normal top-e)])))
|
||||||
|
|
||||||
|
|
|
@ -397,13 +397,20 @@
|
||||||
;; Just wrap body expressions
|
;; Just wrap body expressions
|
||||||
[(module name init-import (#%plain-module-begin body ...))
|
[(module name init-import (#%plain-module-begin body ...))
|
||||||
top?
|
top?
|
||||||
(let ([bodys (syntax->list (syntax (body ...)))])
|
(let ([bodys (syntax->list (syntax (body ...)))]
|
||||||
|
[mb (list-ref (syntax->list expr) 3)])
|
||||||
(let ([bodyl (map (lambda (b)
|
(let ([bodyl (map (lambda (b)
|
||||||
(annotate-top b trans?))
|
(annotate-top b trans?))
|
||||||
bodys)])
|
bodys)])
|
||||||
(certify
|
(certify
|
||||||
expr
|
expr
|
||||||
(rebuild expr (map cons bodys bodyl)))))]
|
(rebuild
|
||||||
|
expr
|
||||||
|
(list (cons
|
||||||
|
mb
|
||||||
|
(certify
|
||||||
|
mb
|
||||||
|
(rebuild mb (map cons bodys bodyl)))))))))]
|
||||||
|
|
||||||
;; No way to wrap
|
;; No way to wrap
|
||||||
[(require i ...) expr]
|
[(require i ...) expr]
|
||||||
|
|
|
@ -77,11 +77,13 @@
|
||||||
(if (memq id syms)
|
(if (memq id syms)
|
||||||
'()
|
'()
|
||||||
(list #`(define #,(datum->syntax-object stx id stx) #,v))))
|
(list #`(define #,(datum->syntax-object stx id stx) #,v))))
|
||||||
|
(syntax-property
|
||||||
#`(#%plain-module-begin
|
#`(#%plain-module-begin
|
||||||
(provide #,@path-exports #,@flag-exports)
|
(provide #,@path-exports #,@flag-exports)
|
||||||
(define name expr) ...
|
(define name expr) ...
|
||||||
#,@(apply append (map (mkdef #'use-default) path-exports))
|
#,@(apply append (map (mkdef #'use-default) path-exports))
|
||||||
#,@(apply append (map (mkdef #'#f) flag-exports))))))])))
|
#,@(apply append (map (mkdef #'#f) flag-exports)))
|
||||||
|
'certify-mode 'transparent))))])))
|
||||||
|
|
||||||
(provide (rename config-module-begin #%module-begin)
|
(provide (rename config-module-begin #%module-begin)
|
||||||
define
|
define
|
||||||
|
|
Loading…
Reference in New Issue
Block a user