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

expander: improve some errors at phase >= 1

Browse Source 
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
This commit is contained in:
Matthew Flatt 2018-07-27 12:24:39 -06:00
parent 031564b28c
commit a447b5bf6b
3 changed files with 127 additions and 33 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
racket/src/expander/expand/context.rkt
View File

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

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

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

123
racket/src/racket/src/startup.inc
View File

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