From a447b5bf6b105e5dbbec1fb78cc8f10d4a898099 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 27 Jul 2018 12:24:39 -0600 Subject: [PATCH] expander: improve some errors at phase >= 1 At phase 1 and higher, the expander tentatively allows an unbound identifier so that, for example, `define-for-syntax` can define a helper function syntactically after a compile-time expression that uses the helper. While unbound references eventually trigger an error, the reordering can be consuing, as in the example #lang racket (define-syntax (f stx) (syntax-parse stx [(_ oops) #'ok])) which complains about `_` when the real problem is that `syntax-parse` isn't imported. To provide better errors, `raise-syntax-error` now implicitly extends an error message to include a list of previously encountered unbound identifiersin the current compilation unit. That list will be non-empty only at phase >= 1. With that change, the error message for the above example is bad.rkt:5:5: _: wildcard not allowed as an expression after encountering unbound identifier (which is possibly the real problem): syntax-parse in: (_ oops) .... Closes #2167 --- racket/src/expander/expand/context.rkt | 11 +++ racket/src/expander/syntax/error.rkt | 22 ++++- racket/src/racket/src/startup.inc | 127 ++++++++++++++++++------- 3 files changed, 127 insertions(+), 33 deletions(-) diff --git a/racket/src/expander/expand/context.rkt b/racket/src/expander/expand/context.rkt index 33a0eb0b12..a84be364e9 100644 --- a/racket/src/expander/expand/context.rkt +++ b/racket/src/expander/expand/context.rkt @@ -4,6 +4,7 @@ "../syntax/syntax.rkt" "../syntax/scope.rkt" "../syntax/binding.rkt" + "../syntax/error.rkt" "env.rkt" "free-id-set.rkt" "../namespace/namespace.rkt" @@ -202,3 +203,13 @@ [to-parsed? #t] [observer #f] [should-not-encounter-macros? #t])) + +;; ---------------------------------------- + +;; Register a callback for `raise-syntax-error` +(set-current-previously-unbound! + (lambda () + (define ctx (current-expand-context)) + (define phase-to-ids (and ctx (expand-context-need-eventually-defined ctx))) + (and phase-to-ids + (hash-ref phase-to-ids (expand-context-phase ctx) null)))) diff --git a/racket/src/expander/syntax/error.rkt b/racket/src/expander/syntax/error.rkt index b623b04ec9..bef996b400 100644 --- a/racket/src/expander/syntax/error.rkt +++ b/racket/src/expander/syntax/error.rkt @@ -10,7 +10,9 @@ make-exn:fail:syntax:unbound raise-syntax-error - raise-unbound-syntax-error) + raise-unbound-syntax-error + + set-current-previously-unbound!) (struct exn:fail:syntax exn:fail (exprs) #:extra-constructor-name make-exn:fail:syntax @@ -57,6 +59,19 @@ (format "~a" (or given-name (extract-form-name expr) '?))) + (define unbound-message + ;; If we have unbound identifiers to check, then it's possible that the + ;; true error is that the identifier should have been bound to a syntactic + ;; form. So, list those identifiers. The list will be non-empty only for + ;; phase >= 1. + (let ([ids (current-previously-unbound)]) + (or (and (pair? ids) + (format "\n after encountering unbound identifier~a (which is possibly the real problem):~a" + (if (null? (cdr ids)) "" "s") + (apply string-append + (for/list ([id (in-list ids)]) + (format "\n ~s" (syntax-e id)))))) + ""))) (define at-message (or (and sub-expr (error-print-source-location) @@ -76,6 +91,7 @@ (string-append src-loc-str name ": " message + unbound-message at-message in-message message-suffix) @@ -105,3 +121,7 @@ (and str (string-append str ": "))))) +;; Hook for the expander: +(define current-previously-unbound (lambda () #f)) +(define (set-current-previously-unbound! proc) + (set! current-previously-unbound proc)) diff --git a/racket/src/racket/src/startup.inc b/racket/src/racket/src/startup.inc index 764864fb36..b47a8e5ec7 100644 --- a/racket/src/racket/src/startup.inc +++ b/racket/src/racket/src/startup.inc @@ -682,6 +682,7 @@ static const char *startup_source = "(if a_1669(procedure-keywords(a_1669 p_0))(values null null)))))" "(values null null)))" " (let-values () (raise-argument-error 'procedure-keywords \"procedure?\" p_0)))))))" +"(define-values(print-values)(lambda vs_0(begin(begin(for-each(current-print) vs_0)(apply values vs_0)))))" "(define-values" "(reverse$1)" "(lambda(l_0)" @@ -12825,7 +12826,7 @@ static const char *startup_source = "(let-values((()" "(begin" "(if((lambda(x_0)" -"(let-values(((or-part_124)(not x_0)))(if or-part_124 or-part_124(symbol? x_0))))" +"(let-values(((or-part_125)(not x_0)))(if or-part_125 or-part_125(symbol? x_0))))" " given-name_0)" "(void)" " (let-values () (raise-argument-error who_0 \"(or/c symbol? #f)\" given-name_0)))" @@ -12849,65 +12850,117 @@ static const char *startup_source = "(let-values(((name_119)" "(format" " \"~a\"" -"(let-values(((or-part_125) given-name_0))" -"(if or-part_125" -" or-part_125" -"(let-values(((or-part_126)(extract-form-name expr_0)))" -"(if or-part_126 or-part_126 '?)))))))" -"(let-values(((at-message_120)" -"(let-values(((or-part_127)" +"(let-values(((or-part_126) given-name_0))" +"(if or-part_126" +" or-part_126" +"(let-values(((or-part_127)(extract-form-name expr_0)))" +"(if or-part_127 or-part_127 '?)))))))" +"(let-values(((unbound-message_120)" +"(let-values(((ids_128)(current-previously-unbound)))" +"(let-values(((or-part_129)" +"(if(pair? ids_128)" +"(format" +" \"\\n after encountering unbound identifier~a (which is possibly the real problem):~a\"" +" (if (null? (cdr ids_128)) \"\" \"s\")" +"(apply" +" string-append" +"(reverse$1" +"(let-values(((lst_130) ids_128))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_130)))" +"((letrec-values(((for-loop_131)" +"(lambda(fold-var_0 lst_0)" +"(begin" +" 'for-loop" +"(if(pair? lst_0)" +"(let-values(((id_134)" +"(unsafe-car lst_0))" +"((rest_135)" +"(unsafe-cdr lst_0)))" +"(let-values(((fold-var_136)" +"(let-values(((fold-var_137)" +" fold-var_0))" +"(let-values(((fold-var_138)" +"(let-values()" +"(cons" +"(let-values()" +"(format" +" \"\\n ~s\"" +"(syntax-e$1" +" id_134)))" +" fold-var_137))))" +"(values" +" fold-var_138)))))" +"(if(not #f)" +"(for-loop_131" +" fold-var_136" +" rest_135)" +" fold-var_136)))" +" fold-var_0)))))" +" for-loop_131)" +" null" +" lst_130))))))" +" #f)))" +" (if or-part_129 or-part_129 \"\")))))" +"(let-values(((at-message_121)" +"(let-values(((or-part_139)" "(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\"" +"(syntax->datum$1(datum->syntax$1 #f sub-expr_0)))" " #f)" " #f)))" -" (if or-part_127 or-part_127 \"\"))))" -"(let-values(((in-message_121)" -"(let-values(((or-part_128)" +" (if or-part_139 or-part_139 \"\"))))" +"(let-values(((in-message_122)" +"(let-values(((or-part_140)" "(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\" (syntax->datum$1 (datum->syntax$1 #f expr_0)))" " #f)" " #f)))" -" (if or-part_128 or-part_128 \"\"))))" -"(let-values(((src-loc-str_122)" -"(let-values(((or-part_129)" +" (if or-part_140 or-part_140 \"\"))))" +"(let-values(((src-loc-str_123)" +"(let-values(((or-part_141)" "(if(error-print-source-location)" -"(let-values(((or-part_130)(extract-source-location sub-expr_0)))" -"(if or-part_130 or-part_130(extract-source-location expr_0)))" +"(let-values(((or-part_142)(extract-source-location sub-expr_0)))" +"(if or-part_142 or-part_142(extract-source-location expr_0)))" " #f)))" -" (if or-part_129 or-part_129 \"\"))))" +" (if or-part_141 or-part_141 \"\"))))" "(raise" "(exn:fail:syntax_0" "(string-append" -" src-loc-str_122" +" src-loc-str_123" " name_119" -" \": \"" +" \": \"" " message_0" -" at-message_120" -" in-message_121" +" unbound-message_120" +" at-message_121" +" in-message_122" " message-suffix_0)" "(current-continuation-marks)" "(map2" " syntax-taint$1" -"(if(let-values(((or-part_131) sub-expr_0))(if or-part_131 or-part_131 expr_0))" +"(if(let-values(((or-part_143) sub-expr_0))(if or-part_143 or-part_143 expr_0))" "(cons" "(datum->syntax$1" " #f" -"(let-values(((or-part_132) sub-expr_0))(if or-part_132 or-part_132 expr_0)))" +"(let-values(((or-part_144) sub-expr_0))(if or-part_144 or-part_144 expr_0)))" " extra-sources_0)" -" extra-sources_0)))))))))))))))" +" extra-sources_0))))))))))))))))" "(define-values" "(extract-form-name)" "(lambda(s_0)" "(begin" "(if(syntax?$1 s_0)" "(let-values()" -"(let-values(((e_134)(syntax-e$1 s_0)))" -"(if(symbol? e_134)" -"(let-values() e_134)" -"(if(if(pair? e_134)(identifier?(car e_134)) #f)" -"(let-values()(syntax-e$1(car e_134)))" +"(let-values(((e_146)(syntax-e$1 s_0)))" +"(if(symbol? e_146)" +"(let-values() e_146)" +"(if(if(pair? e_146)(identifier?(car e_146)) #f)" +"(let-values()(syntax-e$1(car e_146)))" "(let-values() #f)))))" "(let-values() #f)))))" "(define-values" @@ -12916,9 +12969,11 @@ static const char *startup_source = "(begin" "(if(syntax?$1 s_0)" "(if(syntax-srcloc s_0)" -" (let-values (((str_136) (srcloc->string (syntax-srcloc s_0)))) (if str_136 (string-append str_136 \": \") #f))" +" (let-values (((str_148) (srcloc->string (syntax-srcloc s_0)))) (if str_148 (string-append str_148 \": \") #f))" " #f)" " #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" "(struct:module-use module-use1.1 module-use? module-use-module module-use-phase)" "(let-values(((struct:_1 make-_2 ?_3 -ref_4 -set!_5)" @@ -15929,6 +15984,14 @@ static const char *startup_source = "(expand-context/outer-current-use-scopes the-struct_374)" "(expand-context/outer-name the-struct_374)))" " (raise-argument-error 'struct-copy \"expand-context/outer?\" the-struct_374)))))))" +"(call-with-values" +"(lambda()" +"(set-current-previously-unbound!" +"(lambda()" +"(let-values(((ctx_380)(current-expand-context)))" +"(let-values(((phase-to-ids_381)(if ctx_380(expand-context-need-eventually-defined ctx_380) #f)))" +"(if phase-to-ids_381(hash-ref phase-to-ids_381(expand-context-phase ctx_380) null) #f))))))" +" print-values)" "(define-values" "(taint-dispatch)" "(lambda(s_0 proc_0 phase_0)"