diff --git a/collects/tests/typed-scheme/fail/bad-any.ss b/collects/tests/typed-scheme/fail/bad-any.ss new file mode 100644 index 00000000..846e541a --- /dev/null +++ b/collects/tests/typed-scheme/fail/bad-any.ss @@ -0,0 +1,14 @@ +#; +(exn-pred exn:fail:contract?) +#lang scheme/load + +(module m typed-scheme + (: f Any) + (define f (lambda: ([x : Number]) (add1 x))) + (provide f)) + +(module n scheme + (require 'm) + (f "foo")) + +(require 'n) diff --git a/collects/typed-scheme/private/type-contract.ss b/collects/typed-scheme/private/type-contract.ss index 5ac589a9..89c690ad 100644 --- a/collects/typed-scheme/private/type-contract.ss +++ b/collects/typed-scheme/private/type-contract.ss @@ -13,7 +13,7 @@ (private parse-type) scheme/match syntax/struct syntax/stx mzlib/trace unstable/syntax scheme/list (only-in scheme/contract -> ->* case-> cons/c flat-rec-contract provide/contract any/c) - (for-template scheme/base scheme/contract unstable/poly-c (only-in scheme/class object% is-a?/c subclass?/c))) + (for-template scheme/base scheme/contract unstable/poly-c (utils any-wrap) (only-in scheme/class object% is-a?/c subclass?/c))) (define (define/fixup-contract? stx) (or (syntax-property stx 'typechecker:contract-def) @@ -29,7 +29,11 @@ (let ([typ (if maker? ((Struct-flds (lookup-type-name (Name-id typ))) #f . t:->* . typ) typ)]) - (with-syntax ([cnt (type->contract typ (lambda () (tc-error/stx prop "Type ~a could not be converted to a contract." typ)))]) + (with-syntax ([cnt (type->contract + typ + ;; this is for a `require/typed', so the value is not from the typed side + #:typed-side #f + (lambda () (tc-error/stx prop "Type ~a could not be converted to a contract." typ)))]) (syntax/loc stx (define-values (n) cnt))))] [_ (int-err "should never happen - not a define-values: ~a" (syntax->datum stx))])) @@ -44,15 +48,18 @@ (= (length l) (length (remove-duplicates l)))) -(define (type->contract ty fail #:out [out? #f]) +(define (type->contract ty fail #:out [out? #f] #:typed-side [from-typed? #t]) (define vars (make-parameter '())) (let/ec exit - (let loop ([ty ty] [pos? #t]) - (define (t->c t) (loop t pos?)) - (define (t->c/neg t) (loop t (not pos?))) + (let loop ([ty ty] [pos? #t] [from-typed? from-typed?]) + (define (t->c t) (loop t pos? from-typed?)) + (define (t->c/neg t) (loop t (not pos?) (not from-typed?))) (match ty [(or (App: _ _ _) (Name: _)) (t->c (resolve-once ty))] - [(Univ:) #'any/c] + ;; any/c doesn't provide protection in positive position + [(Univ:) (if from-typed? + #'any-wrap/c + #'any/c)] ;; we special-case lists: [(Mu: var (Union: (list (Value: '()) (Pair: elem-ty (F: var))))) #`(listof #,(t->c elem-ty))] @@ -143,3 +150,4 @@ [else (exit (fail))])))) + diff --git a/collects/typed-scheme/typecheck/provide-handling.ss b/collects/typed-scheme/typecheck/provide-handling.ss index 8943cc59..74b65801 100644 --- a/collects/typed-scheme/typecheck/provide-handling.ss +++ b/collects/typed-scheme/typecheck/provide-handling.ss @@ -5,7 +5,8 @@ syntax/kerncase syntax/boundmap (env type-name-env type-alias-env) mzlib/trace - (private type-contract typed-renaming) + (only-in (private type-contract) type->contract) + (private typed-renaming) (rep type-rep) (utils tc-utils) scheme/contract/private/provide diff --git a/collects/typed-scheme/utils/any-wrap.ss b/collects/typed-scheme/utils/any-wrap.ss new file mode 100644 index 00000000..76bfc4f1 --- /dev/null +++ b/collects/typed-scheme/utils/any-wrap.ss @@ -0,0 +1,38 @@ +#lang scheme/base + +(require scheme/match scheme/vector scheme/contract) + +(define-struct any-wrap (val) + #:property prop:custom-write + (lambda (v p write?) + (fprintf p "#"))) + +(define (traverse wrap?) + (define (t v) + (match v + [(? (lambda (e) (and (any-wrap? e) (not wrap?)))) (any-wrap-val v)] + [(? (lambda (e) + (or (number? e) (string? e) (char? e) (symbol? e) (keyword? e) (bytes? e) (void? e)))) v] + [(cons x y) (cons (t x) (t y))] + [(and (? immutable?) (? vector?)) (vector-map t v)] + [(and (? immutable?) (box v)) (box (t v))] + [(and (? immutable?) (? hash? v)) + ((cond [(hash-eq? v) make-immutable-hasheq] + [(hash-eqv? v) make-immutable-hasheqv] + [else make-immutable-hash]) + (for/list ([(k v) (in-hash v)]) + (cons (t k) (t v))))] + #; ;; need to check immutablity + [(? prefab-struct-key) + (let* ([k (prefab-struct-key v)] + [vals (struct->vector v)]) + (apply make-prefab-struct k (for/list ([i (in-vector vals 1)]) i)))] + [_ (if wrap? (make-any-wrap v) v)])) + t) + +(define any-wrap/c + (simple-contract + #:name 'Any + #:projection (compose traverse blame-original?))) + +(provide any-wrap/c) \ No newline at end of file diff --git a/collects/typed-scheme/utils/tc-utils.ss b/collects/typed-scheme/utils/tc-utils.ss index 69c990e8..687f1156 100644 --- a/collects/typed-scheme/utils/tc-utils.ss +++ b/collects/typed-scheme/utils/tc-utils.ss @@ -8,7 +8,7 @@ don't depend on any other portion of the system (provide (all-defined-out)) (require "syntax-traversal.ss" "utils.ss" - syntax/parse (for-syntax scheme/base syntax/parse) scheme/match + syntax/parse (for-syntax scheme/base syntax/parse) scheme/match unstable/debug (for-syntax unstable/syntax)) ;; a parameter representing the original location of the syntax being currently checked @@ -42,11 +42,13 @@ don't depend on any other portion of the system (define warn-unreachable? (make-parameter #t)) (define (warn-unreachable e) - (let ([l (current-logger)]) + (let ([l (current-logger)] + [stx (locate-stx e)]) (when (and (warn-unreachable?) (log-level? l 'warning) - (and (orig-module-stx) (eq? (syntax-source-module e) (syntax-source-module (orig-module-stx)))) - (syntax-source-module e)) + (syntax-original? (syntax-local-introduce e)) + #;(and (orig-module-stx) (eq? (debug syntax-source-module e) (debug syntax-source-module (orig-module-stx)))) + #;(syntax-source-module stx)) (log-message l 'warning (format "Typed Scheme has detected unreachable code: ~e" (syntax->datum (locate-stx e))) e))))