From 8f9d4860fd6e891c871b69b0fac6d2317a3db4a3 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 7 Dec 2016 09:10:49 -0700 Subject: [PATCH] change `syntax` to preserve all properties on a template In (with-syntax ([x ....]) #'(x y)) and property on the source syntax object `(x y)` was lost in constructing a new syntax object to substitute for `x`, while properties on preserved literal syntax objects, such as `y` were intact. Change `syntax` to preserve properties for reconstructed parts of the template. This change exposes a problem with 'transparent taint modes, where the internal "is original?" property was preserved while losing scopes that wuld cancel originalness. So, that's fixed here, too. --- pkgs/racket-test-core/tests/racket/stx.rktl | 29 ++++++++++++++- racket/collects/racket/private/stxcase.rkt | 7 ++-- racket/src/racket/src/fun.c | 11 +++++- racket/src/racket/src/schpriv.h | 3 ++ racket/src/racket/src/syntax.c | 39 ++++++++++++++++----- 5 files changed, 73 insertions(+), 16 deletions(-) diff --git a/pkgs/racket-test-core/tests/racket/stx.rktl b/pkgs/racket-test-core/tests/racket/stx.rktl index f20bb9462a..fcb3b390f0 100644 --- a/pkgs/racket-test-core/tests/racket/stx.rktl +++ b/pkgs/racket-test-core/tests/racket/stx.rktl @@ -201,6 +201,33 @@ (test #f syntax-property s 'testing) + +(define-syntax mcr0 + (lambda (stx) + (syntax-case stx () + [(_) (syntax (begin 0))]))) + +(define s (quote-syntax (mcr0))) +(define se (expand-once s)) + +(test #t syntax-original? s) +(test #f syntax-original? se) + +;; Check that a property in a template is preserved by #' + +(define-syntax (define-define-stx stx) + (syntax-case stx () + [(_ stx) + (with-syntax ([template (syntax-property #'(x) + 'x + 'y)]) + #'(define stx + (with-syntax ([x #'hi]) + #'template)))])) + +(define-define-stx stx-with-property) +(test 'y syntax-property stx-with-property 'x) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Plain s, se derived from part of s @@ -252,7 +279,7 @@ (test '(12 . 10) syntax-property se 'testing) (test '(mcr2) (tree-map syntax-e) (syntax-property se 'origin)) -(test #f syntax-original? s) +(test #t syntax-original? s) (test #t syntax-original? se) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; diff --git a/racket/collects/racket/private/stxcase.rkt b/racket/collects/racket/private/stxcase.rkt index fb581ffa26..cc3b2ec158 100644 --- a/racket/collects/racket/private/stxcase.rkt +++ b/racket/collects/racket/private/stxcase.rkt @@ -10,11 +10,8 @@ (-define (datum->syntax/shape orig datum) (if (syntax? datum) datum - (let ([stx (datum->syntax orig datum orig #f orig)]) - (let ([shape (syntax-property orig 'paren-shape)]) - (if shape - (syntax-property stx 'paren-shape shape) - stx))))) + ;; Keeps 'paren-shape and any other properties: + (datum->syntax orig datum orig orig))) (-define (catch-ellipsis-error thunk sexp sloc) ((let/ec esc diff --git a/racket/src/racket/src/fun.c b/racket/src/racket/src/fun.c index d5d7a79156..5cacd04c81 100644 --- a/racket/src/racket/src/fun.c +++ b/racket/src/racket/src/fun.c @@ -1889,7 +1889,16 @@ cert_with_specials(Scheme_Object *code, if (SCHEME_PAIRP(code)) return v; - return scheme_datum_to_syntax(v, code, scheme_false, 0, 1); + v = scheme_datum_to_syntax(v, code, scheme_false, 0, 1); + + if (scheme_syntax_is_original(v) + && !scheme_syntax_is_original(code)) { + /* Since we copied properties without scopes, we need to + explicitly remove originalness */ + v = scheme_syntax_remove_original(v); + } + + return v; } else if (SCHEME_STX_NULLP(code)) return code; diff --git a/racket/src/racket/src/schpriv.h b/racket/src/racket/src/schpriv.h index 1c6cf7a8c8..28d2803898 100644 --- a/racket/src/racket/src/schpriv.h +++ b/racket/src/racket/src/schpriv.h @@ -1281,6 +1281,9 @@ Scheme_Object *scheme_stx_track(Scheme_Object *naya, int scheme_stx_has_empty_wraps(Scheme_Object *stx, Scheme_Object *phase); +int scheme_syntax_is_original(Scheme_Object *_stx); +Scheme_Object *scheme_syntax_remove_original(Scheme_Object *_stx); + XFORM_NONGCING Scheme_Object *scheme_stx_root_scope(); Scheme_Object *scheme_new_scope(int kind); Scheme_Object *scheme_scope_printed_form(Scheme_Object *m); diff --git a/racket/src/racket/src/syntax.c b/racket/src/racket/src/syntax.c index 758f2ae41b..e2d458343c 100644 --- a/racket/src/racket/src/syntax.c +++ b/racket/src/racket/src/syntax.c @@ -8122,20 +8122,26 @@ static Scheme_Object *syntax_tainted_p(int argc, Scheme_Object **argv) static Scheme_Object *syntax_original_p(int argc, Scheme_Object **argv) { - Scheme_Stx *stx; - Scheme_Object *key, *val; - intptr_t i; - if (!SCHEME_STXP(argv[0])) scheme_wrong_contract("syntax-original?", "syntax?", 0, argc, argv); - stx = (Scheme_Stx *)argv[0]; + if (scheme_syntax_is_original(argv[0])) + return scheme_true; + else + return scheme_false; +} + +int scheme_syntax_is_original(Scheme_Object *_stx) +{ + Scheme_Stx *stx = (Scheme_Stx *)_stx; + Scheme_Object *key, *val; + intptr_t i; if (stx->props) { if (!scheme_hash_tree_get(stx->props, source_symbol)) - return scheme_false; + return 0; } else - return scheme_false; + return 0; /* Look for any non-original scope: */ i = scope_set_next(stx->scopes->simple_scopes, -1); @@ -8143,12 +8149,27 @@ static Scheme_Object *syntax_original_p(int argc, Scheme_Object **argv) scope_set_index(stx->scopes->simple_scopes, i, &key, &val); if (SCHEME_SCOPE_KIND(key) == SCHEME_STX_MACRO_SCOPE) - return scheme_false; + return 0; i = scope_set_next(stx->scopes->simple_scopes, i); } - return scheme_true; + return 1; +} + +Scheme_Object *scheme_syntax_remove_original(Scheme_Object *_stx) +{ + Scheme_Stx *stx = (Scheme_Stx *)_stx; + Scheme_Hash_Tree *props = stx->props; + + if (!props) + return (Scheme_Object *)stx; + + props = scheme_hash_tree_set(props, source_symbol, NULL); + stx = (Scheme_Stx *)clone_stx((Scheme_Object *)stx, NULL); + stx->props = props; + + return (Scheme_Object *)stx; } Scheme_Object *scheme_stx_property2(Scheme_Object *_stx,