expander: 'implicit-made-explicit property on introduced #%app, etc.

pkgs/racket-doc/scribblings/reference/syntax-model.scrbl

@@ -356,7 +356,8 @@ the @tech{syntax object} being expanded:
        @tech{binding}, that @tech{binding} is used to continue. If the @tech{identifier}
        is @tech{unbound}, a new @tech{syntax-object} symbol
        @racket['#%top] is created using the @tech{lexical information}
-       of the @tech{identifier}; if this @racketidfont{#%top}
+       of the @tech{identifier} with @tech{implicit-made-explicit properties};
+       if this @racketidfont{#%top}
        @tech{identifier} has no @tech{binding}, then parsing fails with an
        @racket[exn:fail:syntax] exception. Otherwise, the new
        @tech{identifier} is combined with the original
@@ -376,7 +377,8 @@ the @tech{syntax object} being expanded:
 
  @item{If it is a @tech{syntax-object} pair of any other form, then a
        new @tech{syntax-object} symbol @racket['#%app] is created
-       using the @tech{lexical information} of the pair. If the
+       using the @tech{lexical information} of the pair with
+       @tech{implicit-made-explicit properties}. If the
        resulting @racketidfont{#%app} @tech{identifier} has no
        binding, parsing fails with an @racket[exn:fail:syntax]
        exception. Otherwise, the new @tech{identifier} is combined
@@ -388,7 +390,7 @@ the @tech{syntax object} being expanded:
  @item{If it is any other syntax object, then a new
        @tech{syntax-object} symbol @racket['#%datum] is created using
        the @tech{lexical information} of the original @tech{syntax
-       object}. If the resulting @racketidfont{#%datum}
+       object} with @tech{implicit-made-explicit properties}. If the resulting @racketidfont{#%datum}
        @tech{identifier} has no @tech{binding}, parsing fails with an
        @racket[exn:fail:syntax] exception. Otherwise, the new
        @tech{identifier} is combined with the original @tech{syntax
@@ -436,6 +438,18 @@ things:
 
 ]
 
+When a @racketidfont{#%top}, @racketidfont{#%app}, or
+@racketidfont{#%datum} identifier is added by the expander, it is
+given @deftech{implicit-made-explicit properties}: an
+@racket['implicit-made-explicit] @tech{syntax property} whose value is
+@racket[#t], and a hidden property to indicate that the implicit
+identifier is original in the sense of @racket[syntax-original?] if
+the syntax object that gives the identifier its @tech{lexical information}
+has that property.
+
+@history[#:changed "7.9.0.13" @elem{Added @tech{implicit-made-explicit
+                                    properties}.}]
+
 @;- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 @subsection[#:tag "expand-context-model"]{Expansion Context}
 

pkgs/racket-test-core/tests/racket/macro.rktl

@@ -1060,7 +1060,9 @@
                   [else #f])))])
   ;; expecting `#%app` from `racket/base` to reqrite to core `#%app`
   (test #t syntax-original? (find (expand #'(+ 1 2)) '#%app))
-  (test #f syntax-original? (find (expand (datum->syntax #'here '(+ 1 2))) '#%app)))
+  (test #t syntax-property (find (expand #'(+ 1 2)) '#%app) 'implicit-made-explicit)
+  (test #f syntax-original? (find (expand (datum->syntax #'here '(+ 1 2))) '#%app))
+  (test #t syntax-property (find (expand (datum->syntax #'here '(+ 1 2))) '#%app) 'implicit-made-explicit))
 
 ;; ----------------------------------------
 

racket/src/bc/src/startup.inc

@@ -7963,12 +7963,7 @@ static const char *startup_source =
 "(syntax-inspector the-struct_0)))"
 "                  (raise-argument-error 'struct-copy \"syntax?\" the-struct_0)))"
 " s_0)))))))"
-"(define-values"
+"(define-values(syntax-has-property?)(lambda(from-s_0 key_0)(begin(hash-ref(syntax-props from-s_0) key_0 #f))))"
-"(syntax-property-copy)"
-"(lambda(from-s_0 key_0)"
-"(begin"
-"(let-values(((v_0)(hash-ref(syntax-props from-s_0) key_0 #f)))"
-"(if v_0(hash-set empty-props key_0 v_0) empty-props)))))"
 "(define-values"
 "(taint-content)"
 "(lambda(d_0)"
@@ -44367,6 +44362,10 @@ static const char *startup_source =
 " for-loop_0)"
 " null"
 " lst_0)))))))"
+"(define-values(implicit-made-explicit-properties)(hasheq 'implicit-made-explicit #t))"
+"(define-values"
+"(original-implicit-made-explicit-properties)"
+"(hash-set implicit-made-explicit-properties original-property-sym #t))"
 "(define-values"
 "(expand.1)"
 "(lambda(alternate-id1_0 fail-non-transformer2_0 s5_0 ctx6_0)"
@@ -44711,7 +44710,9 @@ static const char *startup_source =
 " disarmed-s_0"
 " sym_0"
 " s_0"
-"(syntax-property-copy s_0 original-property-sym)"
+"(if(syntax-has-property? s_0 original-property-sym)"
+" original-implicit-made-explicit-properties"
+" implicit-made-explicit-properties)"
 " insp_0)))"
 "(let-values(((new-s_0)"
 "(syntax-rearm$1"

racket/src/cs/schemified/expander.scm

@@ -9554,10 +9554,8 @@
                           (syntax-inspector s_0))))))))
              (raise-argument-error 'struct-copy "syntax?" s_0))
            s_0))))))
-(define syntax-property-copy
+(define syntax-has-property?
-  (lambda (from-s_0 key_0)
+  (lambda (from-s_0 key_0) (hash-ref (syntax-props from-s_0) key_0 #f)))
-    (let ((v_0 (hash-ref (syntax-props from-s_0) key_0 #f)))
-      (if v_0 (hash-set empty-props key_0 v_0) empty-props))))
 (define taint-content
   (letrec ((procz1 (|#%name| f (lambda (tail?_0 x_0) (begin x_0))))
            (gf_0
@@ -50495,6 +50493,9 @@
                        (for-loop_0 fold-var_1 rest_0))))
                  fold-var_0))))))
         (for-loop_0 null l_0))))))
+(define implicit-made-explicit-properties (hasheq 'implicit-made-explicit #t))
+(define original-implicit-made-explicit-properties
+  (hash-set implicit-made-explicit-properties original-property-sym #t))
 (define expand.1
   (|#%name|
    expand
@@ -50963,7 +50964,10 @@
               disarmed-s_0
               sym_0
               s_0
-              (syntax-property-copy s_0 original-property-sym)
+              (if (begin-unsafe
+                   (hash-ref (syntax-props s_0) original-property-sym #f))
+                original-implicit-made-explicit-properties
+                implicit-made-explicit-properties)
               insp_0)))
         (let ((new-s_0
                (syntax-rearm$1

racket/src/expander/expand/implicit-property.rkt

@@ -0,0 +1,12 @@
+#lang racket/base
+(require "../syntax/original.rkt")
+
+(provide implicit-made-explicit-properties
+         original-implicit-made-explicit-properties)
+
+(define implicit-made-explicit-properties
+  (hasheq 'implicit-made-explicit #t))
+
+(define original-implicit-made-explicit-properties
+  (hash-set implicit-made-explicit-properties
+            original-property-sym #t))

racket/src/expander/expand/main.rkt

@@ -39,7 +39,8 @@
          "../common/performance.rkt"
          "rebuild.rkt"
          "parsed.rkt"
-         "expanded+parsed.rkt")
+         "expanded+parsed.rkt"
+         "implicit-property.rkt")
 
 (provide expand
          lookup
@@ -243,7 +244,9 @@
 (define (make-explicit ctx sym s disarmed-s)
   (define insp (current-module-code-inspector))
   (define sym-s (immediate-datum->syntax disarmed-s sym s
-                                         (syntax-property-copy s original-property-sym)
+                                         (if (syntax-has-property? s original-property-sym)
+                                             original-implicit-made-explicit-properties
+                                             implicit-made-explicit-properties)
                                          insp))
   (define new-s (syntax-rearm (immediate-datum->syntax disarmed-s (cons sym-s disarmed-s) s
                                                        (syntax-props s)

racket/src/expander/syntax/original.rkt

@@ -4,4 +4,3 @@
 
 (define original-property-sym
   (gensym 'original))
-

racket/src/expander/syntax/property.rkt

@@ -7,7 +7,7 @@
          syntax-property-preserved?
          syntax-property-symbol-keys
          syntax-property-remove
-         syntax-property-copy)
+         syntax-has-property?)
 
 ;; ----------------------------------------
 
@@ -59,8 +59,5 @@
       s))
 
 ;; internal use by expander:
-(define (syntax-property-copy from-s key)
+(define (syntax-has-property? from-s key)
-  (define v (hash-ref (syntax-props from-s) key #f))
+  (hash-ref (syntax-props from-s) key #f))
-  (if v
-      (hash-set empty-props key v)
-      empty-props))