From a4a2ccacc3f896ebaf325e76952cc5df6d415228 Mon Sep 17 00:00:00 2001 From: Asumu Takikawa Date: Tue, 4 Nov 2014 15:24:33 -0500 Subject: [PATCH] Eliminate special cases for top-level contract gen Use the same mechanism as require/typed for doing all contract gen for make-predicate, cast, etc. Also don't special-case contract generation for top-level require/typed. original commit: 1c5202ade74c922e7f3870c7bc3e505357a3ed85 --- .../typed-racket/base-env/prims.rkt | 104 +++++------------- .../typed-racket-lib/typed-racket/core.rkt | 8 +- .../typed-racket/private/type-contract.rkt | 4 +- .../typed-racket/fail/cast-top-level2.rkt | 2 +- .../typed-racket/fail/make-predicate-mod1.rkt | 2 +- .../fail/make-predicate-top-level2.rkt | 2 +- 6 files changed, 39 insertions(+), 83 deletions(-) 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 11bd9c77..bcd18892 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 @@ -141,7 +141,6 @@ This file defines two sorts of primitives. All of them are provided into any mod ["../types/utils.rkt" (fv)] [syntax/define (normalize-definition)] [typed-racket/private/parse-type (parse-type)] - [typed-racket/private/type-contract (type->contract type->contract-fail)] [typed-racket/env/type-alias-env (register-resolved-type-alias)])) (define-for-syntax (with-type* expr ty) @@ -209,22 +208,6 @@ This file defines two sorts of primitives. All of them are provided into any mod (raise-syntax-error #f "at least one specification is required" stx)) #`(begin c.spec ...)] [(_ #:internal nm:opt-rename ty lib (~optional [~seq #:struct-maker parent]) ...) - (define/with-syntax cnt* - (if (eq? (syntax-local-context) 'top-level) - ;; if we're at the top-level, we can generate the contract - ;; immediately, but otherwise the contract will be fixed up - ;; by the module type-checking pass later - (let ([typ (parse-type #'ty)]) - (ignore - (type->contract - typ - ;; this is for a `require/typed', so the value is not - ;; from the typed side - #:typed-side #f - (type->contract-fail typ #'ty)))) - ;; in the fix-up case, the contract is just an identifier - ;; that is defined below - (generate-temporary #'nm.nm))) (define/with-syntax hidden (generate-temporary #'nm.nm)) (define/with-syntax sm (if (attribute parent) #'(#:struct-maker parent) @@ -233,16 +216,13 @@ This file defines two sorts of primitives. All of them are provided into any mod (if (attribute parent) contract-def/maker-property contract-def-property)) + ;; define `cnt*` to be fixed up later by the module type-checking + (define cnt* + (syntax-local-lift-expression (property #'#f #'ty))) (quasisyntax/loc stx (begin - ;; define `cnt*` to be fixed up later by the module - ;; type-checking (not defined at top-level since it - ;; doesn't work with local expansion) - #,@(ignore (if (eq? (syntax-local-context) 'top-level) - #'() - #`(#,(property #'(define cnt* #f) #'ty)))) #,(internal #'(require/typed-internal hidden ty . sm)) - #,(ignore #'(require/contract nm.spec hidden cnt* lib))))])) + #,(ignore #`(require/contract nm.spec hidden #,cnt* lib))))])) (values (r/t-maker #t) (r/t-maker #f)))) (define-syntax (require/typed/provide stx) @@ -304,35 +284,18 @@ This file defines two sorts of primitives. All of them are provided into any mod (define-syntax (make-predicate stx) (syntax-parse stx [(_ ty:expr) - (if (syntax-transforming-module-expression?) - (let ((name (syntax-local-lift-expression - (flat-contract-def-property #'#f #'ty)))) - (define (check-valid-type _) - (define type (parse-type #'ty)) - (define vars (fv type)) - ;; If there was an error don't create another one - (unless (or (Error? type) (null? vars)) - (tc-error/delayed - "Type ~a could not be converted to a predicate because it contains free variables." - type))) - - #`(#,(external-check-property #'#%expression check-valid-type) - #,(ignore-some/expr #`(flat-contract-predicate #,name) #'(Any -> Boolean : ty)))) - (let ([typ (parse-type #'ty)]) - (if (Error? typ) - ;; This code should never get run, typechecking will have an error earlier - #`(error 'make-predicate "Couldn't parse type") - #`(#%expression - #,(ignore-some/expr - #`(flat-contract-predicate - #,(type->contract - typ - ;; must be a flat contract - #:kind 'flat - ;; the value is not from the typed side - #:typed-side #f - (type->contract-fail typ #'ty #:ctc-str "predicate"))) - #'(Any -> Boolean : ty))))))])) + (define name (syntax-local-lift-expression + (flat-contract-def-property #'#f #'ty))) + (define (check-valid-type _) + (define type (parse-type #'ty)) + (define vars (fv type)) + ;; If there was an error don't create another one + (unless (or (Error? type) (null? vars)) + (tc-error/delayed + "Type ~a could not be converted to a predicate because it contains free variables." + type))) + #`(#,(external-check-property #'#%expression check-valid-type) + #,(ignore-some/expr #`(flat-contract-predicate #,name) #'(Any -> Boolean : ty)))])) (define-syntax (cast stx) (syntax-parse stx @@ -355,30 +318,19 @@ This file defines two sorts of primitives. All of them are provided into any mod (cond [(not (unbox typed-context?)) ; no-check, don't check #'v] - [(syntax-transforming-module-expression?) - (let ((ctc (syntax-local-lift-expression - (contract-def-property #'#f #'ty)))) - (define (check-valid-type _) - (define type (parse-type #'ty)) - (define vars (fv type)) - ;; If there was an error don't create another one - (unless (or (Error? type) (null? vars)) - (tc-error/delayed - "Type ~a could not be converted to a contract because it contains free variables." - type))) - #`(#,(external-check-property #'#%expression check-valid-type) - #,(apply-contract ctc)))] [else - (let ([typ (parse-type #'ty)]) - (if (Error? typ) - ;; This code should never get run, typechecking will have an error earlier - #`(error 'cast "Couldn't parse type") - (apply-contract - (type->contract - typ - ;; the value is not from the typed side - #:typed-side #f - (type->contract-fail typ #'ty)))))])])) + (define ctc (syntax-local-lift-expression + (contract-def-property #'#f #'ty))) + (define (check-valid-type _) + (define type (parse-type #'ty)) + (define vars (fv type)) + ;; If there was an error don't create another one + (unless (or (Error? type) (null? vars)) + (tc-error/delayed + "Type ~a could not be converted to a contract because it contains free variables." + type))) + #`(#,(external-check-property #'#%expression check-valid-type) + #,(apply-contract ctc))])])) (define-syntax (require/opaque-type stx) (define-syntax-class name-exists-kw diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/core.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/core.rkt index 38ec1649..51f7cd23 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/core.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/core.rkt @@ -71,7 +71,9 @@ (tc-toplevel/full stx #'form (λ (body2 type) (with-syntax* - ([(optimized-body . _) (maybe-optimize #`(#,body2))]) + ([(transformed-body ...) + (change-contract-fixups (flatten-all-begins body2))] + [(optimized-body ...) (maybe-optimize #'(transformed-body ...))]) (syntax-parse body2 [_ (let ([ty-str (match type ;; 'no-type means the form is not an expression and @@ -122,5 +124,5 @@ #,(if (unbox include-extra-requires?) extra-requires #'(begin)) - #,(arm #'optimized-body)) - (arm #'optimized-body)))]))))])) + #,(arm #'(begin optimized-body ...))) + (arm #'(begin optimized-body ...))))]))))])) 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 e80c75e5..91e67721 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 @@ -95,7 +95,9 @@ ;; this is for a `require/typed', so the value is not from the typed side #:typed-side #f #:kind kind - (type->contract-fail typ prop))]) + (type->contract-fail + typ prop + #:ctc-str (if flat? "predicate" "contract")))]) (ignore ; should be ignored by the optimizer (quasisyntax/loc stx (define-values (n) cnt)))))] [_ (int-err "should never happen - not a define-values: ~a" diff --git a/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/fail/cast-top-level2.rkt b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/fail/cast-top-level2.rkt index 944e1d6f..c987633d 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/fail/cast-top-level2.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/fail/cast-top-level2.rkt @@ -1,5 +1,5 @@ #; -(exn-pred exn:fail:syntax? #rx".*is unbound.*") +(exn-pred exn:fail:syntax? #rx"free variables") #lang racket/load diff --git a/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/fail/make-predicate-mod1.rkt b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/fail/make-predicate-mod1.rkt index 0eea5b32..16d1664d 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/fail/make-predicate-mod1.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/fail/make-predicate-mod1.rkt @@ -1,5 +1,5 @@ #; -(exn-pred exn:fail:syntax? #rx".*could not be converted to a contract.*") +(exn-pred exn:fail:syntax? #rx".*could not be converted to a predicate.*") #lang typed/racket/base diff --git a/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/fail/make-predicate-top-level2.rkt b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/fail/make-predicate-top-level2.rkt index 474b0a85..32a02e07 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/fail/make-predicate-top-level2.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/fail/make-predicate-top-level2.rkt @@ -1,5 +1,5 @@ #; -(exn-pred exn:fail:syntax? #rx".*is unbound.*") +(exn-pred exn:fail:syntax? #rx"free variables") #lang racket/load (require typed/racket/base)