diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/annotate-classes.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/annotate-classes.rkt index 21d21358..539330f6 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/annotate-classes.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/annotate-classes.rkt @@ -4,7 +4,11 @@ syntax/parse/experimental/template "../private/parse-classes.rkt" "../private/syntax-properties.rkt" - (for-label "colon.rkt")) + "../utils/literal-syntax-class.rkt" + (for-meta -1 (only-in "base-types-extra.rkt" U ->)) + (for-label "colon.rkt" + (only-in "base-types-extra.rkt" Values) + (only-in racket/base values))) (provide (all-defined-out)) ;; Data definitions @@ -48,12 +52,24 @@ #:attr ty #f #:with ann-name #'n)) -(define-splicing-syntax-class (param-annotated-name trans) +(define-literal-syntax-class #:for-label Values) +(define-literal-syntax-class #:for-label values) + +(define-splicing-syntax-class cont-annotated-name #:attributes (name ty ann-name) - #:description "type-annotated identifier" + #:description "type-annotated continuation identifier" #:literal-sets (colon) (pattern [~seq name:id : ty] - #:with ann-name (type-label-property #'name (trans #'ty)))) + #:with ann-name (type-label-property + #'name + (syntax-parse #'ty + [((~or :Values^ :values^) tys ... dty :ddd/bound) + #'(tys ... dty -> (U))] + [((~or :Values^ :values^) tys ... dty _:ddd) + #'(tys ... dty -> (U))] + [((~or :Values^ :values^) tys ...) + #'(tys ... -> (U))] + [t #'(t -> (U))])))) (define-syntax-class annotated-binding #:attributes (name ty ann-name binding rhs) 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 fcf2459e..6e095e16 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 @@ -1196,8 +1196,17 @@ (-poly (a b) (->opt [Sym] (make-Prompt-Tagof a b)))] ;; default-continuation-prompt-tag is defined in "base-contracted.rkt" [call-with-current-continuation - (-poly (a b) (((a . -> . (Un)) . -> . b) . -> . (Un a b)))] -[call/cc (-poly (a b) (((a . -> . (Un)) . -> . b) . -> . (Un a b)))] + (-polydots (a b c) + (cl->* (-> (-> (-> (Un)) (-values null)) (-values null)) + (-> (-> (->... (list a) (c c) (Un)) + (make-ValuesDots (list (-result b)) c 'c)) + (make-ValuesDots (list (-result (Un a b))) c 'c))))] +[call/cc + (-polydots (a b c) + (cl->* (-> (-> (-> (Un)) (-values null)) (-values null)) + (-> (-> (->... (list a) (c c) (Un)) + (make-ValuesDots (list (-result b)) c 'c)) + (make-ValuesDots (list (-result (Un a b))) c 'c))))] [call-with-composable-continuation (-polydots (b c a) (-> ;; takes a continuation and should return the same @@ -1208,8 +1217,17 @@ ;; return type here (make-ValuesDots '() a 'a)))] [call-with-escape-continuation - (-poly (a b) (((a . -> . (Un)) . -> . b) . -> . (Un a b)))] -[call/ec (-poly (a b) (((a . -> . (Un)) . -> . b) . -> . (Un a b)))] + (-polydots (a b c) + (cl->* (-> (-> (-> (Un)) (-values null)) (-values null)) + (-> (-> (->... (list a) (c c) (Un)) + (make-ValuesDots (list (-result b)) c 'c)) + (make-ValuesDots (list (-result (Un a b))) c 'c))))] +[call/ec + (-polydots (a b c) + (cl->* (-> (-> (-> (Un)) (-values null)) (-values null)) + (-> (-> (->... (list a) (c c) (Un)) + (make-ValuesDots (list (-result b)) c 'c)) + (make-ValuesDots (list (-result (Un a b))) c 'c))))] [call-with-continuation-barrier (-poly (a) (-> (-> a) a))] [continuation-prompt-available? (-> (make-Prompt-TagTop) B)] [continuation? diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/prims.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/prims.rkt index d4885c4c..cf4acc65 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/prims.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/prims.rkt @@ -1185,7 +1185,7 @@ This file defines two sorts of primitives. All of them are provided into any mod (let () (define ((mk l/c) stx) (syntax-parse stx - [(_ (~or (~var k (param-annotated-name (lambda (s) #`(#,s -> (U))))) + [(_ (~or k:cont-annotated-name (~and k:id (~bind [k.ann-name #'k]))) . body) (quasisyntax/loc stx (#,l/c k.ann-name . body))])) (values (mk #'let/cc) (mk #'let/ec)))) diff --git a/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/succeed/call-comp.rkt b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/succeed/call-comp.rkt index 0befd402..40f95af1 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/succeed/call-comp.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/succeed/call-comp.rkt @@ -15,3 +15,6 @@ tag (λ: ([x : Integer]) (+ 1 x))) +((inst call/ec Integer Integer Integer) (lambda ([f : (Integer Integer -> Nothing)]) (f 0 1))) +(let/cc k : (values String Symbol Boolean) + (+ 5 (k "result arity doesn't matter" 'hahaha #t)))