suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Add a :-less do for TR

Browse Source
This commit is contained in:
Asumu Takikawa 2014-02-12 11:56:28 -05:00
parent e6e3ab4e74
commit a941f95c2e
5 changed files with 21 additions and 13 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
pkgs/typed-racket-pkgs/typed-racket-compatibility/typed/scheme/base.rkt
View File

@ -4,7 +4,7 @@
with-handlers default-continuation-prompt-tag with-handlers default-continuation-prompt-tag
define λ lambda define-struct for for* define λ lambda define-struct for for*
let let* let-values letrec letrec-values let let* let-values letrec letrec-values
let/cc let/ec)) let/cc let/ec do))
(basics #%module-begin #%top-interaction)) (basics #%module-begin #%top-interaction))
(require typed-racket/base-env/extra-procs (require typed-racket/base-env/extra-procs

19
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/prims.rkt
View File

@ -48,6 +48,8 @@ This file defines two sorts of primitives. All of them are provided into any mod
[-letrec-values letrec-values:] [-letrec-values letrec-values:]
[-let/cc let/cc:] [-let/cc let/cc:]
[-let/ec let/ec:] [-let/ec let/ec:]
[-do do]
[-do do:]
[with-handlers: with-handlers] [with-handlers: with-handlers]
[define-typed-struct/exec define-struct/exec:] [define-typed-struct/exec define-struct/exec:]
[for/annotation for] [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)))) (values (rts #t) (rts #f))))
(define-syntax (do: stx) (define-syntax (-do stx)
(syntax-parse stx #:literals (:) (syntax-parse stx #:literals (:)
[(_ : ty [(_ (~optional (~seq : ty) #:defaults ([ty #f]))
((var:optionally-annotated-name rest ...) ...) ((var:optionally-annotated-name rest ...) ...)
(stop?:expr ret ...) (stop?:expr ret ...)
c:expr ...) c:expr ...)
(quasisyntax/loc (define do-stx
stx (syntax/loc stx
(ann #,(syntax/loc
stx
(do ((var.ann-name rest ...) ...) (do ((var.ann-name rest ...) ...)
(stop? ret ...) (stop? ret ...)
c ...)) c ...)))
ty))])) (if (attribute ty)
(quasisyntax/loc stx
(ann #,do-stx #,(attribute ty)))
do-stx)]))
;; wrap the original for with a type annotation ;; wrap the original for with a type annotation
(define-syntax (for/annotation stx) (define-syntax (for/annotation stx)

2
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/private/with-types.rkt
View File

@ -4,7 +4,7 @@
(for-template (for-template
(except-in racket/base for for* with-handlers lambda λ define (except-in racket/base for for* with-handlers lambda λ define
let let* letrec letrec-values let-values let let* letrec letrec-values let-values
let/cc let/ec let/cc let/ec do
default-continuation-prompt-tag) default-continuation-prompt-tag)
"../base-env/prims.rkt" "../base-env/prims.rkt"
(prefix-in c: (combine-in racket/contract/region racket/contract/base))) (prefix-in c: (combine-in racket/contract/region racket/contract/base)))

2
pkgs/typed-racket-pkgs/typed-racket-lib/typed/racket/base.rkt
View File

@ -4,7 +4,7 @@
with-handlers default-continuation-prompt-tag with-handlers default-continuation-prompt-tag
define λ lambda define-struct for for* define λ lambda define-struct for for*
let let* let-values letrec letrec-values let let* let-values letrec letrec-values
let/cc let/ec)) let/cc let/ec do))
(basics #%module-begin #%top-interaction)) (basics #%module-begin #%top-interaction))
(require typed-racket/base-env/extra-procs (require typed-racket/base-env/extra-procs

5
pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/typecheck-tests.rkt
View File

@ -2191,6 +2191,11 @@
[tc-e (let/ec k "foo") -String] [tc-e (let/ec k "foo") -String]
[tc-e (let/cc k : String (k "foo")) -String] [tc-e (let/cc k : String (k "foo")) -String]
[tc-e (let/ec 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 (test-suite
"tc-literal tests" "tc-literal tests"