Generalized types for ((call)|(let))/[ec]c to allow n-ary continuations.

original commit: 878d4cfb4db64a69195dac6e3402e566d62946e1

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)

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?

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

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