diff --git a/pkgs/typed-racket-pkgs/typed-racket-compatibility/typed/scheme/base.rkt b/pkgs/typed-racket-pkgs/typed-racket-compatibility/typed/scheme/base.rkt index 4530118e7c..82e2d06658 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-compatibility/typed/scheme/base.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-compatibility/typed/scheme/base.rkt @@ -4,7 +4,7 @@ with-handlers default-continuation-prompt-tag define λ lambda define-struct for for* let let* let-values letrec letrec-values - let/cc let/ec)) + let/cc let/ec do)) (basics #%module-begin #%top-interaction)) (require typed-racket/base-env/extra-procs 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 c7f6f48571..7a5fa17887 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 @@ -48,6 +48,8 @@ This file defines two sorts of primitives. All of them are provided into any mod [-letrec-values letrec-values:] [-let/cc let/cc:] [-let/ec let/ec:] + [-do do] + [-do do:] [with-handlers: with-handlers] [define-typed-struct/exec define-struct/exec:] [for/annotation for] @@ -780,20 +782,21 @@ This file defines two sorts of primitives. All of them are provided into any mod (values (rts #t) (rts #f)))) -(define-syntax (do: stx) +(define-syntax (-do stx) (syntax-parse stx #:literals (:) - [(_ : ty + [(_ (~optional (~seq : ty) #:defaults ([ty #f])) ((var:optionally-annotated-name rest ...) ...) (stop?:expr ret ...) c:expr ...) - (quasisyntax/loc - stx - (ann #,(syntax/loc - stx - (do ((var.ann-name rest ...) ...) - (stop? ret ...) - c ...)) - ty))])) + (define do-stx + (syntax/loc stx + (do ((var.ann-name rest ...) ...) + (stop? ret ...) + c ...))) + (if (attribute ty) + (quasisyntax/loc stx + (ann #,do-stx #,(attribute ty))) + do-stx)])) ;; wrap the original for with a type annotation (define-syntax (for/annotation stx) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/private/with-types.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/private/with-types.rkt index 7907626e81..b76c18f00f 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/private/with-types.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/private/with-types.rkt @@ -4,7 +4,7 @@ (for-template (except-in racket/base for for* with-handlers lambda λ define let let* letrec letrec-values let-values - let/cc let/ec + let/cc let/ec do default-continuation-prompt-tag) "../base-env/prims.rkt" (prefix-in c: (combine-in racket/contract/region racket/contract/base))) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed/racket/base.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed/racket/base.rkt index 2abe00fbcd..465953bd98 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed/racket/base.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed/racket/base.rkt @@ -4,7 +4,7 @@ with-handlers default-continuation-prompt-tag define λ lambda define-struct for for* let let* let-values letrec letrec-values - let/cc let/ec)) + let/cc let/ec do)) (basics #%module-begin #%top-interaction)) (require typed-racket/base-env/extra-procs 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 96775c0314..0398f5ceda 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 @@ -2191,6 +2191,11 @@ [tc-e (let/ec k "foo") -String] [tc-e (let/cc k : String (k "foo")) -String] [tc-e (let/ec k : String (k "foo")) -String] + [tc-e (ann (do ([x : Integer 0 (add1 x)]) ((> x 10) x) (displayln x)) + Integer) + #:ret (ret -Integer (make-NoFilter) (make-NoObject))] + [tc-e (do : Integer ([x : Integer 0 (add1 x)]) ((> x 10) x) (displayln x)) + #:ret (ret -Integer (make-NoFilter) (make-NoObject))] ) (test-suite "tc-literal tests"