From 9eaae1f93e312009d59ff7bf7535c3a2bbfe7be2 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Tue, 29 Jul 2014 23:56:03 -0700 Subject: [PATCH] Close holes in what values can be thrown. - Don't allow 3d-syntax in the exprs field of `exn:fail:syntax` - Don't allow throwing arbitrary higher-order values --- .../typed-racket-lib/typed-racket/base-env/base-env.rkt | 6 +++--- .../typed-racket/base-env/base-structs.rkt | 4 ++-- .../typed-racket-lib/typed-racket/types/abbrev.rkt | 4 ++++ .../tests/typed-racket/unit-tests/typecheck-tests.rkt | 8 ++++++++ 4 files changed, 17 insertions(+), 5 deletions(-) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/base-env.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/base-env.rkt index 7f0f6810f0..1f601b115a 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/base-env.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/base-env.rkt @@ -20,7 +20,7 @@ "base-structs.rkt" racket/file (only-in racket/private/pre-base new-apply-proc) - (only-in (types abbrev) [-Boolean B] [-Symbol Sym]) + (only-in (types abbrev) [-Boolean B] [-Symbol Sym] -Flat) (only-in (types numeric-tower) [-Number N]) (only-in (rep type-rep) make-ClassTop @@ -1146,8 +1146,8 @@ ((-> ManyUniv) ((list) Univ . ->* . b) . -> . b)))] ;; Section 10.2 -[raise (cl->* (Univ . -> . (Un)) - (Univ Univ . -> . (Un)))] +[raise (cl->* ((Un -Flat -Exn) . -> . (Un)) + ((Un -Flat -Exn) Univ . -> . (Un)))] [error (cl->* (-> Sym (Un)) (->* (list -String) Univ (Un)) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/base-structs.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/base-structs.rkt index d6bb8e1f8d..10879a648a 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/base-structs.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/base-structs.rkt @@ -10,7 +10,7 @@ (require (for-template racket/base (prefix-in k: '#%kernel))) -(provide initialize-structs -Date -Srcloc -Date -Arity-At-Least) +(provide initialize-structs -Date -Srcloc -Date -Arity-At-Least -Exn) (define-syntax define-hierarchy (syntax-rules (define-hierarchy) @@ -82,7 +82,7 @@ (define-hierarchy exn:fail:contract:continuation (#:kernel-maker k:exn:fail:contract:continuation) ()) (define-hierarchy exn:fail:contract:variable (#:kernel-maker k:exn:fail:contract:variable) ())) - (define-hierarchy exn:fail:syntax (#:kernel-maker k:exn:fail:syntax) ([exprs : (-lst (-Syntax Univ))])) + (define-hierarchy exn:fail:syntax (#:kernel-maker k:exn:fail:syntax) ([exprs : (-lst Any-Syntax)])) (define-hierarchy exn:fail:read (#:kernel-maker k:exn:fail:read) ([srclocs : (-lst Univ)]) ;; cce: Univ here should be srcloc diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/abbrev.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/abbrev.rkt index 18aa0f7a41..6bd29c8f9a 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/abbrev.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/abbrev.rkt @@ -164,6 +164,10 @@ (make-Vector sexp) (make-Box sexp) t))) +(define/decl -Flat + (-mu flat + (Un -Null -Number -Boolean -Symbol -String -Keyword -Char + (-pair flat flat)))) (define/decl -Sexp (-Sexpof (Un))) (define Syntax-Sexp (-Sexpof Any-Syntax)) (define Ident (-Syntax -Symbol)) diff --git a/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/typecheck-tests.rkt b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/typecheck-tests.rkt index 4f702f9a81..3534600545 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/typecheck-tests.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/typecheck-tests.rkt @@ -3175,6 +3175,14 @@ (raise 'foo)) #:ret (ret -String) #:msg #rx"expected: Symbol.*given: Any"] + + [tc-err + (raise (λ ([x : Number]) (add1 x))) + #:ret (ret (Un))] + + [tc-err + (exn:fail:syntax "" (current-continuation-marks) (list (datum->syntax #f add1))) + #:ret (ret -Exn)] ;; PR 14218 [tc-e (ann (values "foo" "bar") (Values String String))