diff --git a/collects/scribblings/reference/stx-trans.scrbl b/collects/scribblings/reference/stx-trans.scrbl index 7120454734..4d0c387ea7 100644 --- a/collects/scribblings/reference/stx-trans.scrbl +++ b/collects/scribblings/reference/stx-trans.scrbl @@ -623,6 +623,9 @@ Thus, the result is an identifier corresponding to the innermost shadowing of @racket[id-stx] in the current context if it is shadowed, and a module-contextless version of @racket[id-stx] otherwise. +If @racket[id-stx] is @tech{tainted} or @tech{armed}, then the +resulting identifier is @tech{tainted}. + @transform-time[]} @@ -699,7 +702,11 @@ instance of @racket[_orig-id], so that it captures uses with the same lexical context as the use of @racket[_m-id]. More typically, however, @racket[syntax-local-make-delta-introducer] -should be used, since it cooperates with @tech{rename transformers}.} +should be used, since it cooperates with @tech{rename transformers}. + +If @racket[ext-stx] is @tech{tainted} or @tech{armed}, then an +identifier result from the created procedure is @tech{tainted}.} + @defproc[(syntax-local-make-delta-introducer [id identifier?]) (identifier? . -> . identifier?)]{ diff --git a/collects/tests/racket/stx.rktl b/collects/tests/racket/stx.rktl index 70b593f317..d6d10758de 100644 --- a/collects/tests/racket/stx.rktl +++ b/collects/tests/racket/stx.rktl @@ -1526,6 +1526,37 @@ (test #t syntax-tainted? (syntax-touch (round-trip (syntax-arm (quote-syntax foo))))) (test #t syntax-tainted? (round-trip (syntax-touch (syntax-arm (quote-syntax foo)))))) +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Check that attacks are thwarted via `syntax-local-get-shadower' +;; or `make-syntax-delta-introducer': + +(module secret-value-42 racket + (define secret 42) + (define-syntax-rule (m) (even? secret)) + (provide m)) +(require 'secret-value-42) + +(define-syntax (evil-via-shadower stx) + (syntax-case stx () + [(_ e) + (let* ([ee (local-expand #'e 'expression null)] + [id (with-syntax ([(app f x) ee]) #'f)] + [okid (syntax-local-get-shadower id)]) + #`(let ([#,okid values]) + #,ee))])) + +(define-syntax (evil-via-delta-introducer stx) + (syntax-case stx () + [(_ e) + (let* ([ee (local-expand #'e 'expression null)] + [id (with-syntax ([(app f x) ee]) #'f)] + [okid ((make-syntax-delta-introducer id #'e) #'even?)]) + #`(let ([#,okid values]) + #,ee))])) + +(syntax-test #'(evil-via-shadower (m))) +(syntax-test #'(evil-via-delta-introducer (m))) + ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (report-errs) diff --git a/src/racket/src/env.c b/src/racket/src/env.c index 2787e824d6..0273f4959d 100644 --- a/src/racket/src/env.c +++ b/src/racket/src/env.c @@ -2088,6 +2088,10 @@ local_get_shadower(int argc, Scheme_Object *argv[]) sym = scheme_stx_strip_module_context(sym); /* Add current module context, if any */ sym = local_module_introduce(1, &sym); + + if (!scheme_stx_is_clean(orig_sym)) + sym = scheme_stx_taint(sym); + return sym; } @@ -2102,6 +2106,9 @@ local_get_shadower(int argc, Scheme_Object *argv[]) result = scheme_add_rename(result, rn); + if (!scheme_stx_is_clean(orig_sym)) + result = scheme_stx_taint(result); + return result; } } diff --git a/src/racket/src/syntax.c b/src/racket/src/syntax.c index c37049d23c..08f673025b 100644 --- a/src/racket/src/syntax.c +++ b/src/racket/src/syntax.c @@ -7970,7 +7970,7 @@ Scheme_Object *scheme_transfer_srcloc(Scheme_Object *to, Scheme_Object *from) static Scheme_Object *delta_introducer(int argc, struct Scheme_Object *argv[], Scheme_Object *p) { - Scheme_Object *r, *delta; + Scheme_Object *r, *delta, *taint_p; r = argv[0]; @@ -7978,11 +7978,15 @@ static Scheme_Object *delta_introducer(int argc, struct Scheme_Object *argv[], S scheme_wrong_type("delta-introducer", "syntax", 0, argc, argv); delta = SCHEME_PRIM_CLOSURE_ELS(p)[0]; + taint_p = SCHEME_PRIM_CLOSURE_ELS(p)[1]; for(; !SCHEME_NULLP(delta); delta = SCHEME_CDR(delta)) { r = scheme_add_remove_mark(r, SCHEME_CAR(delta)); } + if (SCHEME_TRUEP(taint_p)) + r = scheme_stx_taint(r); + return r; } @@ -8018,7 +8022,7 @@ static Scheme_Object *extract_phase(const char *who, int pos, int argc, Scheme_O Scheme_Object *scheme_syntax_make_transfer_intro(int argc, Scheme_Object **argv) { - Scheme_Object *orig_m1, *m1, *m2, *delta, *a[1]; + Scheme_Object *orig_m1, *m1, *m2, *delta, *a[2]; int l1, l2; Scheme_Object *phase; @@ -8091,8 +8095,12 @@ Scheme_Object *scheme_syntax_make_transfer_intro(int argc, Scheme_Object **argv) } a[0] = delta; + if (scheme_stx_is_clean(argv[0])) + a[1] = scheme_false; + else + a[2] = scheme_true; - return scheme_make_prim_closure_w_arity(delta_introducer, 1, a, "delta-introducer", 1, 1); + return scheme_make_prim_closure_w_arity(delta_introducer, 2, a, "delta-introducer", 1, 1); } static Scheme_Object *bound_eq(int argc, Scheme_Object **argv)