expander: fix origin tracking with a set! transformer

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

@@ -400,6 +400,25 @@
         (syntax-case stx ()
           [(_ () (_ () e)) (car (syntax-property #'e 'origin))])))
 
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Check 'origin tracing for a set!-transformer
+
+(test #t
+      'has-do-not-forget-me-origin?
+      (let ([stx (expand #'(let-syntax ([do-not-forget-me (make-set!-transformer
+                                                           (lambda (stx)
+                                                             #'10))])
+                             (set! do-not-forget-me 5)))])
+        (let loop ([v stx])
+          (cond
+            [(syntax? v)
+             (or (loop (syntax-property v 'origin))
+                 (loop (syntax-e v)))]
+            [(pair? v) (or (loop (car v))
+                           (loop (cdr v)))]
+            [(eq? v 'do-not-forget-me) #t]
+            [else #f]))))
+
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Make sure a language name via `#lang` is original
 

racket/src/expander/expand/expr.rkt

@@ -631,8 +631,8 @@
    (log-expand ctx 'prim-set!)
    (define disarmed-s (syntax-disarm s))
    (define-match m disarmed-s '(set! id rhs))
-   (define id (m 'id))
-   (let rename-loop ([id id] [from-rename? #f])
+   (define orig-id (m 'id))
+   (let rename-loop ([id orig-id] [from-rename? #f])
      (define binding (resolve+shift id (expand-context-phase ctx)
                                     #:ambiguous-value 'ambiguous
                                     #:immediate? #t))
@@ -672,7 +672,7 @@
                  ctx)]
         [else
          (define-values (exp-s re-ctx)
-           (apply-transformer t insp s id ctx binding))
+           (apply-transformer t insp s orig-id ctx binding #:origin-id orig-id))
          (cond
           [(expand-context-just-once? ctx) exp-s]
           [else (expand exp-s re-ctx)])])]
@@ -681,7 +681,7 @@
         [(not-in-this-expand-context? t ctx)
          (expand (avoid-current-expand-context (substitute-set!-rename s disarmed-s (m 'set!) (m 'rhs) id from-rename? ctx t) t ctx)
                  ctx)]
-        [else (rename-loop (rename-transformer-target-in-context t ctx) #t)])]
+        [else (rename-loop (syntax-track-origin (rename-transformer-target-in-context t ctx) id id) #t)])]
       [else
        (raise-syntax-error #f "cannot mutate syntax identifier" s id)]))))
 

racket/src/expander/expand/main.rkt

@@ -337,7 +337,8 @@
 ;; scopes to represent the expansion step; the `insp-of-t` inspector
 ;; is the inspector of the module that defines `t`, which gives it
 ;; priviledge for `syntax-arm` and similar
-(define (apply-transformer t insp-of-t s id ctx binding)
+(define (apply-transformer t insp-of-t s id ctx binding
+                           #:origin-id [origin-id #f])
   (performance-region
    ['expand '_ 'macro]
 
@@ -366,7 +367,7 @@
    ;; any expansion result
    (define post-s (maybe-add-post-expansion-scope result-s ctx))
    ;; Track expansion:
-   (define tracked-s (syntax-track-origin post-s cleaned-s (if (identifier? s) s (car (syntax-e s)))))
+   (define tracked-s (syntax-track-origin post-s cleaned-s (or origin-id (if (identifier? s) s (car (syntax-e s))))))
    (define rearmed-s (taint-dispatch tracked-s (lambda (t-s) (syntax-rearm t-s s)) (expand-context-phase ctx)))
    (log-expand ctx 'exit-macro rearmed-s)
    (values rearmed-s