diff --git a/collects/tests/typed-racket/unit-tests/contract-tests.rkt b/collects/tests/typed-racket/unit-tests/contract-tests.rkt index bcf33465..72ab0898 100644 --- a/collects/tests/typed-racket/unit-tests/contract-tests.rkt +++ b/collects/tests/typed-racket/unit-tests/contract-tests.rkt @@ -20,7 +20,7 @@ (test-suite "Contract Tests" (t (-Number . -> . -Number)) (t (-Promise -Number)) - (t/fail (-set Univ)) + (t (-set Univ)) )) (define-go contract-tests) diff --git a/collects/typed-racket/private/type-contract.rkt b/collects/typed-racket/private/type-contract.rkt index c32db15a..c417b3aa 100644 --- a/collects/typed-racket/private/type-contract.rkt +++ b/collects/typed-racket/private/type-contract.rkt @@ -182,11 +182,10 @@ [(or (App: _ _ _) (Name: _)) (t->c (resolve-once ty))] ;; any/c doesn't provide protection in positive position [(Univ:) - (if from-typed? - (begin - (set-impersonator!) - #'any-wrap/c) - #'any/c)] + (cond [from-typed? + (set-chaperone!) + #'any-wrap/c] + [else #'any/c])] ;; we special-case lists: [(Mu: var (Union: (list (Value: '()) (Pair: elem-ty (F: var))))) (if (and (not from-typed?) (type-equal? elem-ty t:Univ)) @@ -293,7 +292,7 @@ (match-let ([(Mu-name: n-nm _) ty]) (with-syntax ([(n*) (generate-temporaries (list n-nm))]) (parameterize ([vars (cons (list n #'n*) (vars))] - [current-contract-kind flat-sym]) + [current-contract-kind (contract-kind-min kind chaperone-sym)]) (define ctc (t->c b)) #`(letrec ([n* (recursive-contract #,ctc @@ -329,7 +328,8 @@ (with-syntax* ([rec (generate-temporary 'rec)]) (define required-recursive-kind (contract-kind-min kind (if mut? impersonator-sym chaperone-sym))) - (parameterize ((current-contract-kind flat-sym)) + ;(printf "kind: ~a mut-k: ~a req-rec-kind: ~a\n" kind (if mut? impersonator-sym chaperone-sym) required-recursive-kind) + (parameterize ((current-contract-kind (contract-kind-min kind chaperone-sym))) (let ((fld-ctc (t->c fty #:seen (cons (cons ty #'rec) structs-seen) #:kind required-recursive-kind))) #`(let ((rec (recursive-contract struct-ctc #,(contract-kind->keyword (current-contract-kind))))) diff --git a/collects/typed-racket/types/printer.rkt b/collects/typed-racket/types/printer.rkt index fdcc44d4..20df7bda 100644 --- a/collects/typed-racket/types/printer.rkt +++ b/collects/typed-racket/types/printer.rkt @@ -213,6 +213,7 @@ [(Name: stx) (fp "~a" (syntax-e stx))] [(app has-name? (? values name)) (fp "~a" name)] + [(StructType: (Struct: nm _ _ _ _ _)) (fp "(StructType ~a)" (syntax-e nm))] [(StructTop: (Struct: nm _ _ _ _ _)) (fp "(Struct ~a)" (syntax-e nm))] [(BoxTop:) (fp "Box")] [(ChannelTop:) (fp "Channel")] diff --git a/collects/typed-racket/types/subtype.rkt b/collects/typed-racket/types/subtype.rkt index 281e6123..5abe3216 100644 --- a/collects/typed-racket/types/subtype.rkt +++ b/collects/typed-racket/types/subtype.rkt @@ -52,7 +52,7 @@ (define k (cons (unsafe-struct-ref s 0) (unsafe-struct-ref t 0))) (define (new-val) (define result (handle-failure (and (subtype* (current-seen) s t) #t))) - (printf "subtype cache miss ~a ~a\n" s t) + ;(printf "subtype cache miss ~a ~a\n" s t) result) (hash-ref! subtype-cache k new-val)) diff --git a/collects/typed-racket/utils/any-wrap.rkt b/collects/typed-racket/utils/any-wrap.rkt index 53921050..31ac9ffa 100644 --- a/collects/typed-racket/utils/any-wrap.rkt +++ b/collects/typed-racket/utils/any-wrap.rkt @@ -2,44 +2,72 @@ (require racket/match racket/contract/base racket/contract/combinator) -(define-struct any-wrap (val) - #:property prop:custom-write - (lambda (v p write?) - (fprintf p "#" (any-wrap-val v)))) - (define undef (letrec ([x x]) x)) -(define (traverse wrap?) +(define (traverse b) + (define (fail v) + (raise-blame-error (blame-swap b) v "Attempted to use a higher-order value passed as `Any`")) + (define (t v) + (define (wrap-struct s) + (define (extract-functions struct-type) + (define-values (sym init auto ref set! imms par skip?) + (struct-type-info type)) + (when skip? (fail s)) ;; "Opaque struct type!") + (define-values (fun/chap-list _) + (for/fold ([res null] + [imms imms]) + ([n (in-range (+ init auto))]) + (if (and (pair? imms) (= (car imms) n)) + ;; field is immutable + (values + (list* (make-struct-field-accessor ref n) + (lambda (s v) (t v)) + res) + (cdr imms)) + ;; field is mutable + (values + (list* (make-struct-field-accessor ref n) + (lambda (s v) (t v)) + (make-struct-field-mutator set! n) + (lambda (s v) (fail s)) + res) + imms)))) + (cond + [par (cons fun/chap-list (extract-functions par))] + [else fun/chap-list])) + (define-values (type skipped?) (struct-info s)) + (when skipped? (fail s)); "Opaque struct type!" + (apply chaperone-struct s (extract-functions type))) + (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) (null? e) (regexp? e) (eq? undef e) (keyword? e) (bytes? e) (boolean? e) (void? e)))) v] [(cons x y) (cons (t x) (t y))] - [(and (? immutable?) (? vector?)) - (for/vector #:length (vector-length v) - ([i (in-vector v)]) (t i))] - [(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)])) + [(? vector?) (chaperone-vector v + (lambda (v i e) (t e)) + (lambda (v i e) (fail v)))] + [(? box?) (chaperone-box v + (lambda (v e) (t e)) + (lambda (v e) (fail v)))] + [(? hash?) (chaperone-hash v + (lambda (h k) (values k (lambda (h k v) (t v)))) ;; ref + (lambda (h k n) (if (immutable? v) (values k n) (fail v))) ;; set + (lambda (h v) v) ;; remove + (lambda (h k) (t k)))] ;; key + [(? evt?) (chaperone-evt v (lambda (e) (values e t)))] + [(? struct?) (wrap-struct v)] + [(? procedure?) (chaperone-procedure v (lambda _ (fail v)))] + [_ (fail v)])) t) (define any-wrap/c - (make-contract + (make-chaperone-contract #:name 'Any - #:projection (compose traverse blame-original?))) + #:first-order (lambda (x) #t) + #:projection traverse)) (provide any-wrap/c)