raise-syntax-error: accomodate cyclic S-expressions

Closes #1016

pkgs/racket-doc/scribblings/reference/exns.scrbl

@@ -383,6 +383,10 @@ record, else the @racket[expr] is used if provided and not
 @racket[extra-sources] to produce the @racket[exprs] field, or
 @racket[extra-sources] is used directly for @racket[exprs] if neither
 @racket[expr] nor @racket[sub-expr] is provided and not @racket[#f].
+The @racket[extra-sources] argument is also used directly for
+@racket[exprs] in the unusual case that the @racket[sub-expr] or
+@racket[expr] that would be included in @racket[exprs] cannot be
+converted to a syntax object (because it contains a cycle).
 
 The form name used in the generated error message is determined
 through a combination of the @racket[name], @racket[expr], and

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

@@ -2481,6 +2481,20 @@
   (check stx #f)
   (check #f a-stx))
 
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Check that `raise-syntax-error` forges ahead even if
+;; it's given a cyclic S-expression
+
+(let ()
+  (define v (vector #f))
+  (vector-set! v 0 v)
+  (define (check-err v v-detail)
+    (err/rt-test (raise-syntax-error 'something "" v v-detail)
+                 exn:fail:syntax?
+                 #rx"^something: .*#0=#[(]#0#[)]"))
+  (check-err v #f)
+  (check-err 'bad v))
+
 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Test prop:rename-transformer with procedure content
 

racket/src/bc/src/startup.inc

@@ -13803,9 +13803,7 @@ static const char *startup_source =
 "(let-values(((or-part_0)"
 "(if sub-expr_0"
 "(if(error-print-source-location)"
-"(format"
+"                                                  (format \"\\n  at: ~.s\" (->datum sub-expr_0))"
-"                                                   \"\\n  at: ~.s\""
-"(syntax->datum$1(datum->syntax$1 #f sub-expr_0)))"
 " #f)"
 " #f)))"
 "                                  (if or-part_0 or-part_0 \"\"))))"
@@ -13813,7 +13811,7 @@ static const char *startup_source =
 "(let-values(((or-part_0)"
 "(if expr_0"
 "(if(error-print-source-location)"
-"                                                    (format \"\\n  in: ~.s\" (syntax->datum$1 (datum->syntax$1 #f expr_0)))"
+"                                                    (format \"\\n  in: ~.s\" (->datum expr_0))"
 " #f)"
 " #f)))"
 "                                    (if or-part_0 or-part_0 \"\"))))"
@@ -13839,11 +13837,23 @@ static const char *startup_source =
 "(map2"
 " syntax-taint$1"
 "(if(let-values(((or-part_0) sub-expr_0))(if or-part_0 or-part_0 expr_0))"
+"(let-values(((with-handlers-predicate17_0) exn:fail:contract?)"
+"((with-handlers-handler18_0)"
+"(lambda(exn_0)(begin 'with-handlers-handler18 extra-sources_0))))"
+"(let-values(((bpz_0)(continuation-mark-set-first #f break-enabled-key)))"
+"(call-handled-body"
+" bpz_0"
+"(lambda(e_0)"
+"(select-handler/no-breaks"
+" e_0"
+" bpz_0"
+"(list(cons with-handlers-predicate17_0 with-handlers-handler18_0))))"
+"(lambda()"
 "(cons"
 "(datum->syntax$1"
 " #f"
 "(let-values(((or-part_0) sub-expr_0))(if or-part_0 or-part_0 expr_0)))"
-" extra-sources_0)"
+" extra-sources_0)))))"
 " extra-sources_0))))))))))))))))"
 "(define-values"
 "(extract-form-name)"
@@ -13867,6 +13877,18 @@ static const char *startup_source =
 "          (let-values (((str_0) (srcloc->string (syntax-srcloc s_0)))) (if str_0 (string-append str_0 \": \") #f))"
 " #f)"
 " #f))))"
+"(define-values"
+"(->datum)"
+"(lambda(expr_0)"
+"(begin"
+"(let-values(((with-handlers-predicate19_0) exn:fail:contract?)"
+"((with-handlers-handler20_0)(lambda(exn_0)(begin 'with-handlers-handler20 expr_0))))"
+"(let-values(((bpz_0)(continuation-mark-set-first #f break-enabled-key)))"
+"(call-handled-body"
+" bpz_0"
+"(lambda(e_0)"
+"(select-handler/no-breaks e_0 bpz_0(list(cons with-handlers-predicate19_0 with-handlers-handler20_0))))"
+"(lambda()(syntax->datum$1(datum->syntax$1 #f expr_0)))))))))"
 "(define-values(current-previously-unbound)(lambda()(begin #f)))"
 "(define-values(set-current-previously-unbound!)(lambda(proc_0)(begin(set! current-previously-unbound proc_0))))"
 "(define-values"

racket/src/cs/schemified/expander.scm

@@ -16588,10 +16588,7 @@
                        (let ((or-part_0
                               (if sub-expr_0
                                 (if (error-print-source-location)
-                                  (format
+                                  (format "\n  at: ~.s" (->datum sub-expr_0))
-                                   "\n  at: ~.s"
-                                   (syntax->datum$1
-                                    (datum->syntax$1 #f sub-expr_0)))
                                   #f)
                                 #f)))
                          (if or-part_0 or-part_0 ""))))
@@ -16599,10 +16596,7 @@
                          (let ((or-part_0
                                 (if expr_0
                                   (if (error-print-source-location)
-                                    (format
+                                    (format "\n  in: ~.s" (->datum expr_0))
-                                     "\n  in: ~.s"
-                                     (syntax->datum$1
-                                      (datum->syntax$1 #f expr_0)))
                                     #f)
                                   #f)))
                            (if or-part_0 or-part_0 ""))))
@@ -16636,11 +16630,31 @@
                             (map_1346
                              syntax-taint$1
                              (if (if sub-expr_0 sub-expr_0 expr_0)
-                               (cons
+                               (let ((with-handlers-handler18_0
-                                (datum->syntax$1
+                                      (|#%name|
-                                 #f
+                                       with-handlers-handler18
-                                 (if sub-expr_0 sub-expr_0 expr_0))
+                                       (lambda (exn_0)
-                                extra-sources_0)
+                                         (begin extra-sources_0)))))
+                                 (let ((bpz_0
+                                        (continuation-mark-set-first
+                                         #f
+                                         break-enabled-key)))
+                                   (call-handled-body
+                                    bpz_0
+                                    (lambda (e_0)
+                                      (select-handler/no-breaks
+                                       e_0
+                                       bpz_0
+                                       (list
+                                        (cons
+                                         exn:fail:contract?
+                                         with-handlers-handler18_0))))
+                                    (lambda ()
+                                      (cons
+                                       (datum->syntax$1
+                                        #f
+                                        (if sub-expr_0 sub-expr_0 expr_0))
+                                       extra-sources_0)))))
                                extra-sources_0)))))))))))))))))
 (define extract-form-name
   (lambda (s_0)
@@ -16660,6 +16674,19 @@
           (if str_0 (string-append str_0 ": ") #f))
         #f)
       #f)))
+(define ->datum
+  (lambda (expr_0)
+    (let ((with-handlers-handler20_0
+           (|#%name| with-handlers-handler20 (lambda (exn_0) (begin expr_0)))))
+      (let ((bpz_0 (continuation-mark-set-first #f break-enabled-key)))
+        (call-handled-body
+         bpz_0
+         (lambda (e_0)
+           (select-handler/no-breaks
+            e_0
+            bpz_0
+            (list (cons exn:fail:contract? with-handlers-handler20_0))))
+         (lambda () (syntax->datum$1 (datum->syntax$1 #f expr_0))))))))
 (define current-previously-unbound (lambda () #f))
 (define set-current-previously-unbound!
   (lambda (proc_0) (set! current-previously-unbound proc_0)))

racket/src/expander/syntax/error.rkt

@@ -75,12 +75,12 @@
   (define at-message
     (or (and sub-expr
              (error-print-source-location)
-             (format "\n  at: ~.s" (syntax->datum (datum->syntax #f sub-expr))))
+             (format "\n  at: ~.s" (->datum sub-expr)))
         ""))
   (define in-message
     (or (and expr
              (error-print-source-location)
-             (format "\n  in: ~.s" (syntax->datum (datum->syntax #f expr))))
+             (format "\n  in: ~.s" (->datum expr)))
         ""))
   (define src-loc-str
     (or (and (error-print-source-location)
@@ -98,8 +98,10 @@
           (current-continuation-marks)
           (map syntax-taint
                (if (or sub-expr expr)
-                   (cons (datum->syntax #f (or sub-expr expr))
+                   ;; accomodate `datum->syntax` failure similar to `->datum`:
-                         extra-sources)
+                   (with-handlers ([exn:fail:contract? (lambda (exn) extra-sources)])
+                     (cons (datum->syntax #f (or sub-expr expr))
+                           extra-sources))
                    extra-sources)))))
 
 (define (extract-form-name s)
@@ -121,6 +123,16 @@
          (and str
               (string-append str ": ")))))
 
+;; `raise-syntax-error` is meant to accept either syntax objects or
+;; S-expressions, and it has traditionally supported hybird values by
+;; coercing to a syntax object and them back; in case the expression
+;; cannot be represented as a syntax object due to cycles, though,
+;; fall back to showing the value in raw form (instead of constraining
+;; `raise-syntax-error`)
+(define (->datum expr)
+  (with-handlers ([exn:fail:contract? (lambda (exn) expr)])
+    (syntax->datum (datum->syntax #f expr))))
+
 ;; Hook for the expander:
 (define current-previously-unbound (lambda () #f))
 (define (set-current-previously-unbound! proc)