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

Minor cleanup in prims.

Browse Source 
original commit: ee47fe5f259d254fbd47d2a11f6a972342de3f5b
This commit is contained in:
Eric Dobson 2013-11-14 22:02:54 -08:00
parent 593fc00875
commit 3def8438c1
1 changed files with 8 additions and 5 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -89,6 +89,10 @@ This file defines two sorts of primitives. All of them are provided into any mod
[typed-racket/private/type-contract (type->contract type->contract-fail)]
[typed-racket/env/type-name-env (register-type-name)]))
(define-for-syntax (with-type* expr ty)
(with-type #`(ann #,expr #,ty)))
(begin-for-syntax
(define-syntax-class opt-parent
#:attributes (nm parent)
@ -278,7 +282,7 @@ This file defines two sorts of primitives. All of them are provided into any mod
#`(#%expression
(ann
#,(ignore-some
#`(let-values (((val) #,(with-type #'(ann v Any))))
#`(let-values (((val) #,(with-type* #'v #'Any)))
(contract
#,ctc-expr
val
@ -503,10 +507,9 @@ This file defines two sorts of primitives. All of them are provided into any mod
[(_ ([pred? action] ...) . body)
(with-syntax ([(pred?* ...)
(for/list ([s (in-syntax #'(pred? ...))])
(with-type #`(ann #,s : (Any -> Any))))]
(with-type* s #'(Any -> Any)))]
[(action* ...)
(for/list ([s (in-syntax #'(action ...))])
(exn-handler s))]
(stx-map exn-handler #'(action ...))]
[body* (exn-body #'(let-values () . body))])
(exn-handlers #'(with-handlers ([pred?* action*] ...) body*)))]))
@ -524,7 +527,7 @@ This file defines two sorts of primitives. All of them are provided into any mod
(syntax-parse stx #:literals (:)
[(_ nm ((~describe "field specification" [fld:optionally-annotated-name]) ...) [proc : proc-ty])
(with-syntax*
([proc* (with-type #'(ann proc : proc-ty))]
([proc* (with-type* #'proc #'proc-ty)]
[d-s (ignore-some (syntax/loc stx (define-struct nm (fld.name ...)
#:property prop:procedure proc*)))]
[dtsi (quasisyntax/loc stx (dtsi/exec* () nm (fld ...) proc-ty))])