From 5a2d6f9c6b8d9f30fcab4ba8fde77342e6422660 Mon Sep 17 00:00:00 2001 From: Eric Dobson Date: Sun, 6 Oct 2013 10:21:22 -0700 Subject: [PATCH] Make version of TR that builds new contracts. original commit: eb03d5c298ef77bc9e382f8a6d1bfc891ad5c076 --- .../typed-racket/private/type-contract.rkt | 9 +++++++-- .../typed-racket-lib/typed-racket/typed-racket.rkt | 1 + .../typed-racket-lib/typed-racket/utils/utils.rkt | 1 + 3 files changed, 9 insertions(+), 2 deletions(-) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/private/type-contract.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/private/type-contract.rkt index 75dfeb17..984b2004 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/private/type-contract.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/private/type-contract.rkt @@ -18,6 +18,7 @@ racket/format unstable/list unstable/sequence + (static-contracts types instantiate) (contract-req) (for-syntax racket/base syntax/parse racket/syntax) (for-template racket/base racket/contract racket/set (utils any-wrap) @@ -144,9 +145,13 @@ [(untyped) 'typed] [(both) 'both])) - (define (type->contract ty fail #:typed-side [typed-side #t] #:kind [kind 'impersonator]) - (define vars (make-parameter '())) + (let/ec escape + (define (fail/t->sc) (escape (fail))) + (instantiate (type->static-contract ty #:typed-side typed-side fail/t->sc) fail kind))) + +(define (type->contract-old ty fail #:typed-side [typed-side #t] #:kind [kind 'impersonator]) + (define vars (make-parameter '())) (define current-contract-kind (make-parameter flat-sym)) (define (increase-current-contract-kind! kind) (current-contract-kind (contract-kind-max (current-contract-kind) kind))) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typed-racket.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typed-racket.rkt index 36a95547..e22a9c4b 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typed-racket.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typed-racket.rkt @@ -7,6 +7,7 @@ ;; the below requires are needed since they provide identifiers ;; that may appear in the residual program ;; TODO: figure out why this are needed here and not somewhere else + (submod "static-contracts/types.rkt" predicates) "utils/utils.rkt" (for-syntax "utils/utils.rkt") "utils/any-wrap.rkt" unstable/contract racket/contract/parametric) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/utils/utils.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/utils/utils.rkt index e59ae4d2..77af3cf0 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/utils/utils.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/utils/utils.rkt @@ -87,6 +87,7 @@ at least theoretically. (define-requirer types types-out) (define-requirer optimizer optimizer-out) (define-requirer base-env base-env-out) +(define-requirer static-contracts static-contracts-out) ;; turn contracts on and off - off by default for performance. (provide (for-syntax enable-contracts?)