From bf4fb553b3daa41da8ec102ab6ea2a4b7c652950 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 27 Apr 2021 17:04:52 -0600 Subject: [PATCH] raise-syntax-error: accomodate cyclic S-expressions Closes #1016 --- .../scribblings/reference/exns.scrbl | 4 ++ pkgs/racket-test-core/tests/racket/stx.rktl | 14 +++++ racket/src/bc/src/startup.inc | 32 +++++++++-- racket/src/cs/schemified/expander.scm | 53 ++++++++++++++----- racket/src/expander/syntax/error.rkt | 20 +++++-- 5 files changed, 101 insertions(+), 22 deletions(-) diff --git a/pkgs/racket-doc/scribblings/reference/exns.scrbl b/pkgs/racket-doc/scribblings/reference/exns.scrbl index 27f4c157a8..e7f822ac73 100644 --- a/pkgs/racket-doc/scribblings/reference/exns.scrbl +++ b/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 diff --git a/pkgs/racket-test-core/tests/racket/stx.rktl b/pkgs/racket-test-core/tests/racket/stx.rktl index f8c811c078..1fb34358a3 100644 --- a/pkgs/racket-test-core/tests/racket/stx.rktl +++ b/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 diff --git a/racket/src/bc/src/startup.inc b/racket/src/bc/src/startup.inc index 1f42bfc5a8..bf36456a4f 100644 --- a/racket/src/bc/src/startup.inc +++ b/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" -" \"\\n at: ~.s\"" -"(syntax->datum$1(datum->syntax$1 #f sub-expr_0)))" +" (format \"\\n at: ~.s\" (->datum 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" diff --git a/racket/src/cs/schemified/expander.scm b/racket/src/cs/schemified/expander.scm index d09fcf6b69..c078e38528 100644 --- a/racket/src/cs/schemified/expander.scm +++ b/racket/src/cs/schemified/expander.scm @@ -16588,10 +16588,7 @@ (let ((or-part_0 (if sub-expr_0 (if (error-print-source-location) - (format - "\n at: ~.s" - (syntax->datum$1 - (datum->syntax$1 #f sub-expr_0))) + (format "\n at: ~.s" (->datum 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 - "\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 "")))) @@ -16636,11 +16630,31 @@ (map_1346 syntax-taint$1 (if (if sub-expr_0 sub-expr_0 expr_0) - (cons - (datum->syntax$1 - #f - (if sub-expr_0 sub-expr_0 expr_0)) - extra-sources_0) + (let ((with-handlers-handler18_0 + (|#%name| + with-handlers-handler18 + (lambda (exn_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))) diff --git a/racket/src/expander/syntax/error.rkt b/racket/src/expander/syntax/error.rkt index bef996b400..db50844b39 100644 --- a/racket/src/expander/syntax/error.rkt +++ b/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)) - extra-sources) + ;; accomodate `datum->syntax` failure similar to `->datum`: + (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)