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

@@ -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)
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

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)])
+         ;; Keeps 'paren-shape and any other properties:
-	   (let ([shape (syntax-property orig 'paren-shape)])
+	 (datum->syntax orig datum orig orig)))
-	     (if shape
-		 (syntax-property stx 'paren-shape shape)
-		 stx)))))
 
   (-define (catch-ellipsis-error thunk sexp sloc)
       ((let/ec esc

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;
 

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);

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,