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

fix certificate problems related to module-begin

Browse Source 
svn: r3553
This commit is contained in:
Matthew Flatt 2006-06-30 00:10:47 +00:00
parent cb8ac0ea05
commit dd3a4d56ef
3 changed files with 32 additions and 17 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

20
collects/errortrace/errortrace-lib.ss
View File

@ -266,6 +266,8 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define orig-inspector (current-code-inspector))
(define errortrace-annotate
(lambda (top-e)
(define (normal e)
@ -280,13 +282,17 @@
[(module name init-import (#%plain-module-begin body ...))
(normal
#`(module name init-import
(#%plain-module-begin
#,((make-syntax-introducer)
#'(require (lib "errortrace-key.ss" "errortrace")))
#,((make-syntax-introducer)
#'(require-for-syntax
(lib "errortrace-key.ss" "errortrace")))
body ...)))])))]
#,(syntax-recertify
#`(#%plain-module-begin
#,((make-syntax-introducer)
#'(require (lib "errortrace-key.ss" "errortrace")))
#,((make-syntax-introducer)
#'(require-for-syntax
(lib "errortrace-key.ss" "errortrace")))
body ...)
(list-ref (syntax->list top-e) 3)
orig-inspector
#f)))])))]
[_else
(normal top-e)])))

15
collects/errortrace/stacktrace.ss
View File

@ -397,13 +397,20 @@
;; Just wrap body expressions
[(module name init-import (#%plain-module-begin body ...))
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)
(annotate-top b trans?))
bodys)])
(certify
expr
(rebuild expr (map cons bodys bodyl)))))]
(certify
expr
(rebuild
expr
(list (cons
mb
(certify
mb
(rebuild mb (map cons bodys bodyl)))))))))]
;; No way to wrap
[(require i ...) expr]

12
collects/setup/configtab.ss
View File

@ -77,11 +77,13 @@
(if (memq id syms)
'()
(list #`(define #,(datum->syntax-object stx id stx) #,v))))
#`(#%plain-module-begin
(provide #,@path-exports #,@flag-exports)
(define name expr) ...
#,@(apply append (map (mkdef #'use-default) path-exports))
#,@(apply append (map (mkdef #'#f) flag-exports))))))])))
(syntax-property
#`(#%plain-module-begin
(provide #,@path-exports #,@flag-exports)
(define name expr) ...
#,@(apply append (map (mkdef #'use-default) path-exports))
#,@(apply append (map (mkdef #'#f) flag-exports)))
'certify-mode 'transparent))))])))
(provide (rename config-module-begin #%module-begin)
define