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

repair interaction of taints and submodule expansion

Browse Source
This commit is contained in:
Matthew Flatt 2013-06-26 04:28:57 +02:00
parent 5f35290bbe
commit dc11090f6b
3 changed files with 78 additions and 16 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

24
pkgs/racket-pkgs/racket-test/tests/racket/submodule.rktl
View File

@ -853,6 +853,30 @@
(test 'ok dynamic-require '(submod 'check-module-meta-2 main) 'v)
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Check an interaciton of submodules and taints
(module m racket
(module q racket
(provide (except-out (all-from-out racket)
#%module-begin)
(rename-out [module-begin #%module-begin]))
(define-syntax (module-begin stx)
(syntax-case stx ()
[(_ . r)
(local-expand #`(#%module-begin . r) 'module-begin null)])))
(module p (submod ".." q)
(module n racket
(provide #%module-begin)
(define-syntax (#%module-begin stx)
(define (arm p)
(syntax-property (syntax-arm p) 'taint-mode 'opaque))
(with-syntax ([mod #'(module m racket/base (add1 0))])
(arm #'(#%plain-module-begin (begin-for-syntax mod))))))
(module m (submod ".." n))))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(report-errs)

14
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/utils/arm.rkt
View File

@ -5,21 +5,25 @@
;; For simplicity, protect everything produced by Typed Racket.
(define (arm stx)
(syntax-case stx (module #%plain-module-begin
(syntax-case stx (module module* #%plain-module-begin
#%require #%provide begin
define-values define-syntaxes
define-values-for-syntax)
begin-for-syntax)
[(module name initial-import mb)
(quasisyntax/loc stx (module name initial-import #,(arm #'mb)))]
[(#%plain-module-begin . _) (syntax-arm stx)]
[(module* name initial-import mb)
(quasisyntax/loc stx (module* name initial-import #,(arm #'mb)))]
[(#%plain-module-begin . _) (syntax-property (syntax-arm stx)
'taint-mode
'opaque)]
[(#%require . _) stx]
[(#%provide . _) stx]
[(begin form ...)
(quasisyntax/loc stx (begin #,@(stx-map arm #'(form ...))))]
[(begin-for-syntax form ...)
(quasisyntax/loc stx (begin-for-syntax #,@(stx-map arm #'(form ...))))]
[(define-values ids expr)
(quasisyntax/loc stx (define-values ids #,(arm #'expr)))]
[(define-syntaxes ids expr)
(quasisyntax/loc stx (define-syntaxes ids #,(arm #'expr)))]
[(define-values-for-syntax ids expr)
(quasisyntax/loc stx (define-values-for-syntax ids #,(arm #'expr)))]
[_ (syntax-arm stx)]))

56
racket/src/racket/src/module.c
View File

@ -6685,9 +6685,10 @@ static Scheme_Object *strip_lexical_context(Scheme_Object *stx)
}
#endif
if (SCHEME_STXP(stx))
if (SCHEME_STXP(stx)) {
stx = scheme_stx_taint_disarm(stx, NULL);
v = SCHEME_STX_VAL(stx);
else
} else
v = stx;
if (SCHEME_PAIRP(v)) {
@ -6713,11 +6714,18 @@ static Scheme_Object *strip_lexical_context(Scheme_Object *stx)
return v;
}
static void check_not_tainted(Scheme_Object *orig)
{
if (scheme_stx_is_tainted(orig))
scheme_wrong_syntax(NULL, orig, NULL,
"cannot expand module body tainted by macro expansion");
}
static Scheme_Object *do_annotate_submodules_k(void);
Scheme_Object *do_annotate_submodules(Scheme_Object *fm, int phase, int incl_star)
{
Scheme_Object *a, *d, *v;
Scheme_Object *a, *d, *v, *fm2;
int changed = 0;
#ifdef DO_STACK_CHECK
@ -6731,11 +6739,20 @@ Scheme_Object *do_annotate_submodules(Scheme_Object *fm, int phase, int incl_sta
}
#endif
if (SCHEME_STXP(fm))
check_not_tainted(fm);
if (!SCHEME_STX_PAIRP(fm))
return fm;
a = SCHEME_STX_CAR(fm);
if (SCHEME_STXP(fm))
fm2 = scheme_stx_taint_disarm(fm, NULL);
else
fm2 = fm;
a = SCHEME_STX_CAR(fm2);
if (SCHEME_STX_PAIRP(a)) {
a = scheme_stx_taint_disarm(a, NULL);
v = SCHEME_STX_CAR(a);
if (SCHEME_STX_SYMBOLP(v)) {
if (scheme_stx_module_eq3(scheme_module_stx, v,
@ -6773,7 +6790,7 @@ Scheme_Object *do_annotate_submodules(Scheme_Object *fm, int phase, int incl_sta
}
}
v = SCHEME_STX_CDR(fm);
v = SCHEME_STX_CDR(fm2);
d = do_annotate_submodules(v, phase, incl_star);
if (!changed && SAME_OBJ(v, d))
@ -6826,11 +6843,17 @@ static Scheme_Object *rebuild_with_phase_shift(Scheme_Object *orig, Scheme_Objec
Scheme_Object *ps)
{
if (!a) {
a = SCHEME_STX_CAR(orig);
a = orig;
if (SCHEME_STXP(a))
a = scheme_stx_taint_disarm(a, NULL);
a = SCHEME_STX_CAR(a);
a = scheme_add_rename(a, ps);
}
if (!d) {
d = SCHEME_STX_CDR(orig);
d = orig;
if (SCHEME_STXP(d))
d = scheme_stx_taint_disarm(d, NULL);
d = SCHEME_STX_CDR(d);
d = phase_shift_tail(d, ps);
}
@ -6839,6 +6862,8 @@ static Scheme_Object *rebuild_with_phase_shift(Scheme_Object *orig, Scheme_Objec
if (SCHEME_PAIRP(orig))
return a;
check_not_tainted(orig);
orig = scheme_add_rename(orig, ps);
return scheme_datum_to_syntax(a, orig, orig, 0, 2);
}
@ -6861,12 +6886,16 @@ static Scheme_Object *phase_shift_skip_submodules(Scheme_Object *fm, Scheme_Obje
#endif
if (phase == -1) {
/* at top: */
v0 = SCHEME_STX_CDR(fm);
/* at top, so this is a `module[*]' form: */
v0 = fm;
if (SCHEME_STXP(v0))
v0 = scheme_stx_taint_disarm(v0, NULL);
v0 = SCHEME_STX_CDR(v0);
v1 = SCHEME_STX_CDR(v0);
v2 = SCHEME_STX_CDR(v1);
v3 = SCHEME_STX_CAR(v2);
v4 = SCHEME_STX_CDR(v3);
v4 = scheme_stx_taint_disarm(v3, NULL);
v4 = SCHEME_STX_CDR(v4);
naya = phase_shift_skip_submodules(v4, ps, 0);
if (SAME_OBJ(naya, v4)) {
@ -6881,9 +6910,14 @@ static Scheme_Object *phase_shift_skip_submodules(Scheme_Object *fm, Scheme_Obje
} else if (SCHEME_STX_NULLP(fm)) {
return fm;
} else {
v1 = SCHEME_STX_CAR(fm);
v0 = fm;
if (SCHEME_STXP(v0))
v0 = scheme_stx_taint_disarm(v0, NULL);
v1 = SCHEME_STX_CAR(v0);
if (SCHEME_STX_PAIRP(v1)) {
if (SCHEME_STXP(v1))
v1 = scheme_stx_taint_disarm(v1, NULL);
v2 = SCHEME_STX_CAR(v1);
if (SCHEME_STX_SYMBOLP(v2)) {
if (scheme_stx_module_eq_x(scheme_module_stx, v2, phase)