From 73e59ddec735a938f48cb77d6c898f3fdf86226b Mon Sep 17 00:00:00 2001 From: Stephen Chang Date: Wed, 6 Apr 2016 17:15:20 -0400 Subject: [PATCH] workaround syntax-parse error msg regressions - just throw explicit type-error exn instead of relying on #:fail-when etc - run-all-tests passing --- tapl/ext-stlc.rkt | 17 +++++++++-------- tapl/infer.rkt | 15 +++++++++------ tapl/stlc+lit.rkt | 2 +- tapl/stlc.rkt | 14 ++++++++------ 4 files changed, 27 insertions(+), 21 deletions(-) diff --git a/tapl/ext-stlc.rkt b/tapl/ext-stlc.rkt index 600c765..e8bcbff 100644 --- a/tapl/ext-stlc.rkt +++ b/tapl/ext-stlc.rkt @@ -23,11 +23,11 @@ (define-base-type Char) (define-typed-syntax #%datum - [(_ . b:boolean) (⊢ (#%datum . b) : Bool)] - [(_ . s:str) (⊢ (#%datum . s) : String)] - [(_ . f) #:when (flonum? (syntax-e #'f)) (⊢ (#%datum . f) : Float)] - [(_ . c:char) (⊢ (#%datum . c) : Char)] - [(_ . x) #'(stlc+lit:#%datum . x)]) + [(_ . b:boolean) (⊢ #,(syntax/loc stx (#%datum . b)) : Bool)] + [(_ . s:str) (⊢ #,(syntax/loc stx (#%datum . s)) : String)] + [(_ . f) #:when (flonum? (syntax-e #'f)) (⊢ #,(syntax/loc stx (#%datum . f)) : Float)] + [(_ . c:char) (⊢ #,(syntax/loc stx (#%datum . c)) : Char)] + [(_ . x) (syntax/loc stx (stlc+lit:#%datum . x))]) (define-primop zero? : (→ Int Bool)) (define-primop = : (→ Int Int Bool)) @@ -114,8 +114,9 @@ #:with ((x- ...) (e- ... e_body-) (τ ... τ_body)) (infers/ctx+erase #'(b ...) #'(e ... e_body)) #:fail-unless (typechecks? #'(b.type ...) #'(τ ...)) - (string-append - "type check fail, args have wrong type:\n" + (type-error #:src stx + #:msg (string-append + "letrec: type check fail, args have wrong type:\n" (string-join (stx-map (λ (e τ τ-expect) @@ -123,7 +124,7 @@ "~a has type ~a, expected ~a" (syntax->datum e) (type->str τ) (type->str τ-expect))) #'(e ...) #'(τ ...) #'(b.type ...)) - "\n")) + "\n"))) (⊢ (letrec ([x- e-] ...) e_body-) : τ_body)]) diff --git a/tapl/infer.rkt b/tapl/infer.rkt index e53d9fd..54b0240 100644 --- a/tapl/infer.rkt +++ b/tapl/infer.rkt @@ -117,7 +117,8 @@ ; #:with [e_fn- (τ_in ... τ_out)] (⇑ e_fn_anno as →) #:with [e_fn- ((X ...) ((~ext-stlc:→ τ_inX ... τ_outX)))] (⇑ e_fn_anno as ∀) #:fail-unless (stx-length=? #'(τ_inX ...) #'(e_arg ...)) ; check arity - (string-append + (type-error #:src stx + #:msg (string-append (format "~a (~a:~a) Wrong number of arguments given to function ~a.\n" (syntax-source stx) (syntax-line stx) (syntax-column stx) (syntax->datum #'e_fn)) @@ -129,13 +130,14 @@ (map (λ (e t) (format " ~a : ~a" e t)) ; indent each line (syntax->datum #'(e_arg ...)) (stx-map type->str #'(τ_arg ...))) - "\n")) + "\n"))) #:with cs (compute-constraints #'((τ_inX τ_arg) ...)) #:with (τ_solved ...) (stx-map (λ (y) (lookup y #'cs)) #'(X ...)) #:with (τ_in ... τ_out) (stx-map (λ (t) (substs #'(τ_solved ...) #'(X ...) t)) #'(τ_inX ... τ_outX)) ; some code duplication #:fail-unless (typechecks? #'(τ_arg ...) #'(τ_in ...)) - (string-append + (type-error #:src stx + #:msg (string-append (format "~a (~a:~a) Arguments to function ~a have wrong type(s).\n" (syntax-source stx) (syntax-line stx) (syntax-column stx) (syntax->datum #'e_fn)) @@ -147,7 +149,7 @@ "\n" #:after-last "\n") (format "Expected: ~a arguments with type(s): " (stx-length #'(τ_in ...))) - (string-join (stx-map type->str #'(τ_in ...)) ", ")) + (string-join (stx-map type->str #'(τ_in ...)) ", "))) ; propagate inferred types for variables up #:with env (stx-flatten (filter (λ (x) x) (stx-map get-env #'(e_arg- ...)))) #:with result-app (add-env #'(#%app e_fn- e_arg- ...) #'env) @@ -157,7 +159,8 @@ ; #:when (printf "fn first ~a\n" (syntax->datum stx)) #:with [e_fn- ((X ...) ((~ext-stlc:→ τ_inX ... τ_outX)))] (⇑ e_fn as ∀) #:fail-unless (stx-length=? #'(τ_inX ...) #'(e_arg ...)) ; check arity - (string-append + (type-error #:src stx + #:msg (string-append (format "~a (~a:~a) Wrong number of arguments given to function ~a.\n" (syntax-source stx) (syntax-line stx) (syntax-column stx) (syntax->datum #'e_fn)) @@ -165,7 +168,7 @@ (stx-length #'(τ_inX ...))) (string-join (stx-map type->str #'(τ_inX ...)) ", " #:after-last "\n") "Given args: " - (string-join (map ~a (syntax->datum #'(e_arg ...))) ", ")) + (string-join (map ~a (syntax->datum #'(e_arg ...))) ", "))) ; #:with ([e_arg- τ_arg] ...) #'(infers+erase #'(e_arg ...)) #:with (cs ([e_arg- τ_arg] ...)) (let-values ([(cs e+τs) diff --git a/tapl/stlc+lit.rkt b/tapl/stlc+lit.rkt index b4a16fb..141d792 100644 --- a/tapl/stlc+lit.rkt +++ b/tapl/stlc+lit.rkt @@ -33,7 +33,7 @@ (define-primop + : (→ Int Int Int)) (define-typed-syntax #%datum - [(_ . n:integer) (⊢ (#%datum . n) : Int)] + [(_ . n:integer) (⊢ #,(syntax/loc stx (#%datum . n)) : Int)] [(_ . x) #:when (type-error #:src #'x #:msg "Unsupported literal: ~v" #'x) #'(#%datum . x)]) diff --git a/tapl/stlc.rkt b/tapl/stlc.rkt index 9ffafbd..e5c104d 100644 --- a/tapl/stlc.rkt +++ b/tapl/stlc.rkt @@ -78,7 +78,7 @@ #:note [note ""] #:name [name #f]) (syntax-parse stx - [(app . rst) + #;[(app . rst) #:when (not (equal? '#%app (syntax->datum #'app))) (mk-app-err-msg (syntax/loc stx (#%app app . rst)) #:expected expected-τs @@ -111,10 +111,12 @@ #:with [e_fn- (τ_in ... τ_out)] (⇑ e_fn as →) #:with ([e_arg- τ_arg] ...) (infers+erase #'(e_arg ...)) #:fail-unless (stx-length=? #'(τ_arg ...) #'(τ_in ...)) - (mk-app-err-msg stx #:expected #'(τ_in ...) - #:given #'(τ_arg ...) - #:note "Wrong number of arguments.") + (type-error #:src stx + #:msg (mk-app-err-msg stx #:expected #'(τ_in ...) + #:given #'(τ_arg ...) + #:note "Wrong number of arguments.")) #:fail-unless (typechecks? #'(τ_arg ...) #'(τ_in ...)) - (mk-app-err-msg stx #:expected #'(τ_in ...) - #:given #'(τ_arg ...)) + (type-error #:src stx + #:msg (mk-app-err-msg stx #:expected #'(τ_in ...) + #:given #'(τ_arg ...))) (⊢ (#%app e_fn- e_arg- ...) : τ_out)])