diff --git a/pkgs/racket-doc/scribblings/reference/contracts.scrbl b/pkgs/racket-doc/scribblings/reference/contracts.scrbl index 199bb43e62..b9496d6813 100644 --- a/pkgs/racket-doc/scribblings/reference/contracts.scrbl +++ b/pkgs/racket-doc/scribblings/reference/contracts.scrbl @@ -420,7 +420,8 @@ passes its arguments to @racket[or/c]. @defproc[(vectorof [c contract?] [#:immutable immutable (or/c #t #f 'dont-care) 'dont-care] - [#:flat? flat? boolean? #f]) + [#:flat? flat? boolean? #f] + [#:eager eager (or/c #t #f exact-nonnegative-integer?) #t]) contract?]{ Returns a @tech{contract} that recognizes vectors. The elements of the vector must match @racket[c]. @@ -431,9 +432,16 @@ a @tech{flat contract}, and the @racket[c] argument must also be a @tech{flat co check future operations on the vector. If the @racket[immutable] argument is @racket[#t] and the @racket[c] argument is -a @tech{flat contract}, the result will be a @tech{flat contract}. If the @racket[c] argument +a @tech{flat contract} and the @racket[eager] argument is @racket[#t], +the result will be a @tech{flat contract}. If the @racket[c] argument is a @tech{chaperone contract}, then the result will be a @tech{chaperone contract}. +If the @racket[eager] argument is @racket[#t], then immutable vectors are +checked eagerly when @racket[c] is a @tech{flat contract}. If the +@racket[eager] argument is a number @racket[n], then immutable vectors are checked +eagerly when @racket[c] is a @tech{flat contract} and the length of the vector +is less than or equal to @racket[n].}. + When a higher-order @racket[vectorof] contract is applied to a vector, the result is not @racket[eq?] to the input. The result will be a copy for immutable vectors and a @tech{chaperone} or @tech{impersonator} of the input for mutable vectors, @@ -441,7 +449,8 @@ unless the @racket[c] argument is a @tech{flat contract} and the vector is immut in which case the result is the original vector. @history[#:changed "6.3.0.5" @list{Changed flat vector contracts to not copy - immutable vectors.}]} + immutable vectors.} + #:changed "6.7.0.3" @list{Added the @racket[#:eager] option.}]} @defproc[(vector-immutableof [c contract?]) contract?]{ diff --git a/pkgs/racket-test/tests/racket/contract/vector.rkt b/pkgs/racket-test/tests/racket/contract/vector.rkt index e060273d86..6b29c564fc 100644 --- a/pkgs/racket-test/tests/racket/contract/vector.rkt +++ b/pkgs/racket-test/tests/racket/contract/vector.rkt @@ -148,5 +148,24 @@ 0) 1 2) - + + (test/spec-passed/result + 'vectorof-eager + '(vector-ref (contract (vectorof integer? #:eager #f) (vector-immutable 0 "") 'pos 'neg) 0) + 0) + + (test/spec-passed/result + 'vectorof-eager-1 + '(vector-ref (contract (vectorof integer? #:eager 1) (vector-immutable 0 "") 'pos 'neg) 0) + 0) + + + (test/pos-blame + 'vectorof-eager-1-fail + '(vector-ref (contract (vectorof integer? #:eager 2) (vector-immutable 0 "") 'pos 'neg) 1)) + + (test/pos-blame + 'vectorof-eager-fail + '(contract (vectorof integer? #:eager 5) (vector-immutable 0 "") 'pos 'neg)) + ) diff --git a/racket/collects/racket/contract/private/vector.rkt b/racket/collects/racket/contract/private/vector.rkt index f1dfb0c962..11d0dee160 100644 --- a/racket/collects/racket/contract/private/vector.rkt +++ b/racket/collects/racket/contract/private/vector.rkt @@ -10,7 +10,11 @@ [wrap-vector/c vector/c]) vector-immutable/c vector-immutableof) -(define-struct base-vectorof (elem immutable)) +;; eager is one of: +;; - #t: always perform an eager check of the elements of an immutable vector +;; - #f: never perform an eager check of the elements of an immutable vector +;; - N (for N>=0): perform an eager check of immutable vectors size <= N +(define-struct base-vectorof (elem immutable eager)) (define-for-syntax (convert-args args this-one) (let loop ([args args] @@ -148,6 +152,7 @@ (λ (ctc) (define elem-ctc (base-vectorof-elem ctc)) (define immutable (base-vectorof-immutable ctc)) + (define eager (base-vectorof-eager ctc)) (define check (check-vectorof ctc)) (λ (blame) (define pos-blame (blame-add-element-of-context blame)) @@ -174,7 +179,12 @@ (define (raise-blame val . args) (apply raise-blame-error blame #:missing-party neg-party val args)) (check val raise-blame #f) - (if (and (immutable? val) (not (chaperone? val))) + ;; avoid traversing large vectors + ;; unless `eager` is specified + (if (and (or (equal? eager #t) + (and eager (<= (vector-length val) eager))) + (immutable? val) + (not (chaperone? val))) (begin (for ([e (in-vector val)]) (unless (p? e) (elem-pos-proj e neg-party))) @@ -240,20 +250,30 @@ 'racket/contract:contract (vector this-one (list #'vecof) null))))])) -(define/subexpression-pos-prop (vectorof c #:immutable [immutable 'dont-care] #:flat? [flat? #f]) +(define/subexpression-pos-prop (vectorof c #:immutable [immutable 'dont-care] #:flat? [flat? #f] #:eager [eager #t]) (define ctc (if flat? (coerce-flat-contract 'vectorof c) (coerce-contract 'vectorof c))) + (unless (or (boolean? eager) + (exact-nonnegative-integer? eager)) + (raise-argument-error 'vectorof + "(or/c #t #f exact-nonnegative-integer?)" + eager)) (cond - [(or flat? + [(and flat? (not (equal? eager #t))) + (raise-arguments-error 'vectorof "flat? cannot be true unless eager is true" + "flat?" flat? + "eager" eager)] + [(or (and flat? (equal? eager #t)) (and (equal? immutable #t) + (equal? eager #t) (flat-contract? ctc))) - (make-flat-vectorof ctc immutable)] + (make-flat-vectorof ctc immutable eager)] [(chaperone-contract? ctc) - (make-chaperone-vectorof ctc immutable)] + (make-chaperone-vectorof ctc immutable eager)] [else - (make-impersonator-vectorof ctc immutable)])) + (make-impersonator-vectorof ctc immutable eager)])) (define/subexpression-pos-prop (vector-immutableof c) (vectorof c #:immutable #t))