suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

raise-syntax-error: accomodate cyclic S-expressions

Browse Source 
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
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
pkgs/racket-doc/scribblings/reference/exns.scrbl
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] 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

14
pkgs/racket-test-core/tests/racket/stx.rktl
View File

@ -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

32
racket/src/bc/src/startup.inc
View File

@ -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"

53
racket/src/cs/schemified/expander.scm
View File

@ -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)))

20
racket/src/expander/syntax/error.rkt
View File

@ -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)