raise-syntax-error: accomodate cyclic S-expressions

Closes #1016
This commit is contained in:
Matthew Flatt 2021-04-27 17:04:52 -06:00
parent 09b61f06c1
commit bf4fb553b3
5 changed files with 101 additions and 22 deletions

View File

@ -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] to produce the @racket[exprs] field, or
@racket[extra-sources] is used directly for @racket[exprs] if neither @racket[extra-sources] is used directly for @racket[exprs] if neither
@racket[expr] nor @racket[sub-expr] is provided and not @racket[#f]. @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 The form name used in the generated error message is determined
through a combination of the @racket[name], @racket[expr], and through a combination of the @racket[name], @racket[expr], and

View File

@ -2481,6 +2481,20 @@
(check stx #f) (check stx #f)
(check #f a-stx)) (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 ;; Test prop:rename-transformer with procedure content

View File

@ -13803,9 +13803,7 @@ static const char *startup_source =
"(let-values(((or-part_0)" "(let-values(((or-part_0)"
"(if sub-expr_0" "(if sub-expr_0"
"(if(error-print-source-location)" "(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)"
" #f)))" " #f)))"
" (if or-part_0 or-part_0 \"\"))))" " (if or-part_0 or-part_0 \"\"))))"
@ -13813,7 +13811,7 @@ static const char *startup_source =
"(let-values(((or-part_0)" "(let-values(((or-part_0)"
"(if expr_0" "(if expr_0"
"(if(error-print-source-location)" "(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)"
" #f)))" " #f)))"
" (if or-part_0 or-part_0 \"\"))))" " (if or-part_0 or-part_0 \"\"))))"
@ -13839,11 +13837,23 @@ static const char *startup_source =
"(map2" "(map2"
" syntax-taint$1" " syntax-taint$1"
"(if(let-values(((or-part_0) sub-expr_0))(if or-part_0 or-part_0 expr_0))" "(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" "(cons"
"(datum->syntax$1" "(datum->syntax$1"
" #f" " #f"
"(let-values(((or-part_0) sub-expr_0))(if or-part_0 or-part_0 expr_0)))" "(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))))))))))))))))" " extra-sources_0))))))))))))))))"
"(define-values" "(define-values"
"(extract-form-name)" "(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))" " (let-values (((str_0) (srcloc->string (syntax-srcloc s_0)))) (if str_0 (string-append str_0 \": \") #f))"
" #f)" " #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(current-previously-unbound)(lambda()(begin #f)))"
"(define-values(set-current-previously-unbound!)(lambda(proc_0)(begin(set! current-previously-unbound proc_0))))" "(define-values(set-current-previously-unbound!)(lambda(proc_0)(begin(set! current-previously-unbound proc_0))))"
"(define-values" "(define-values"

View File

@ -16588,10 +16588,7 @@
(let ((or-part_0 (let ((or-part_0
(if sub-expr_0 (if sub-expr_0
(if (error-print-source-location) (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)
#f))) #f)))
(if or-part_0 or-part_0 "")))) (if or-part_0 or-part_0 ""))))
@ -16599,10 +16596,7 @@
(let ((or-part_0 (let ((or-part_0
(if expr_0 (if expr_0
(if (error-print-source-location) (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)
#f))) #f)))
(if or-part_0 or-part_0 "")))) (if or-part_0 or-part_0 ""))))
@ -16636,11 +16630,31 @@
(map_1346 (map_1346
syntax-taint$1 syntax-taint$1
(if (if sub-expr_0 sub-expr_0 expr_0) (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))))))))))))))))) extra-sources_0)))))))))))))))))
(define extract-form-name (define extract-form-name
(lambda (s_0) (lambda (s_0)
@ -16660,6 +16674,19 @@
(if str_0 (string-append str_0 ": ") #f)) (if str_0 (string-append str_0 ": ") #f))
#f) #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 current-previously-unbound (lambda () #f))
(define set-current-previously-unbound! (define set-current-previously-unbound!
(lambda (proc_0) (set! current-previously-unbound proc_0))) (lambda (proc_0) (set! current-previously-unbound proc_0)))

View File

@ -75,12 +75,12 @@
(define at-message (define at-message
(or (and sub-expr (or (and sub-expr
(error-print-source-location) (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 (define in-message
(or (and expr (or (and expr
(error-print-source-location) (error-print-source-location)
(format "\n in: ~.s" (syntax->datum (datum->syntax #f expr)))) (format "\n in: ~.s" (->datum expr)))
"")) ""))
(define src-loc-str (define src-loc-str
(or (and (error-print-source-location) (or (and (error-print-source-location)
@ -98,8 +98,10 @@
(current-continuation-marks) (current-continuation-marks)
(map syntax-taint (map syntax-taint
(if (or sub-expr expr) (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))))) extra-sources)))))
(define (extract-form-name s) (define (extract-form-name s)
@ -121,6 +123,16 @@
(and str (and str
(string-append 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: ;; Hook for the expander:
(define current-previously-unbound (lambda () #f)) (define current-previously-unbound (lambda () #f))
(define (set-current-previously-unbound! proc) (define (set-current-previously-unbound! proc)