diff --git a/pkgs/racket-test/tests/racket/contract/flat-contracts.rkt b/pkgs/racket-test/tests/racket/contract/flat-contracts.rkt index a0bba7ed00..06c62c4e08 100644 --- a/pkgs/racket-test/tests/racket/contract/flat-contracts.rkt +++ b/pkgs/racket-test/tests/racket/contract/flat-contracts.rkt @@ -17,6 +17,7 @@ (define (test-flat-contract/proc contract pass fail line #:skip-predicate-checks? [skip-predicate-checks? #f]) (contract-eval `(,test #t flat-contract? ,contract)) + (contract-eval `(,test #t flat-contract? (opt/c ,contract))) (define (run-two-tests maybe-rewrite) (define name (if (pair? contract) (car contract) contract)) (let/ec k diff --git a/racket/collects/racket/contract/combinator.rkt b/racket/collects/racket/contract/combinator.rkt index de43909add..b7115e7a88 100644 --- a/racket/collects/racket/contract/combinator.rkt +++ b/racket/collects/racket/contract/combinator.rkt @@ -27,10 +27,6 @@ make-contract - prop:opt-chaperone-contract - prop:opt-chaperone-contract? - prop:opt-chaperone-contract-get-test - prop:orc-contract prop:orc-contract? prop:orc-contract-get-subcontracts diff --git a/racket/collects/racket/contract/private/guts.rkt b/racket/collects/racket/contract/private/guts.rkt index 6ea0cf3871..98d6a471d7 100644 --- a/racket/collects/racket/contract/private/guts.rkt +++ b/racket/collects/racket/contract/private/guts.rkt @@ -123,9 +123,7 @@ (or (simple-flat-contract? x) (let ([c (coerce-contract/f x)]) (and c - (or (chaperone-contract-struct? c) - (and (prop:opt-chaperone-contract? c) - ((prop:opt-chaperone-contract-get-test c) c))))))) + (chaperone-contract-struct? c))))) (define (simple-flat-contract? x) (or (and (procedure? x) (procedure-arity-includes? x 1)) diff --git a/racket/collects/racket/contract/private/opt.rkt b/racket/collects/racket/contract/private/opt.rkt index f3f44d5e98..a6059041aa 100644 --- a/racket/collects/racket/contract/private/opt.rkt +++ b/racket/collects/racket/contract/private/opt.rkt @@ -236,7 +236,7 @@ (optres-superlifts an-optres) (bind-lifts (optres-lifts an-optres) - #`(make-opt-contract + #`(make-an-opt-contract (λ (ctc) (λ (blame) #,(bind-superlifts @@ -246,7 +246,11 @@ (λ (this that) #f) (vector) (begin-lifted (box #f)) - #,(optres-chaperone an-optres)))) + #,(optres-chaperone an-optres) + #,(let ([f (optres-flat an-optres)]) + (if f + #`(λ (val) #,f) + #'#f))))) #`(coerce-contract '#,error-name-sym #,exp)))) ;; this macro optimizes 'e' as a contract, @@ -324,7 +328,7 @@ (optres-superlifts an-optres) (bind-lifts (optres-lifts an-optres) - #`(make-opt-contract + #`(make-an-opt-contract (λ (ctc) (λ (blame) (λ (val) @@ -333,7 +337,11 @@ (λ (this that) #f) (vector) (begin-lifted (box #f)) - #,(optres-chaperone an-optres))))) + #,(optres-chaperone an-optres) + #,(let ([f (optres-flat an-optres)]) + (if f + #`(λ (val) #,f) + #'#f)))))) (values f1 f2)))])) ;; optimized contracts @@ -346,18 +354,48 @@ (define-values (orig-ctc-prop orig-ctc-pred? orig-ctc-get) (make-struct-type-property 'original-contract)) +(define (make-an-opt-contract proj name stronger stronger-vars stamp + chaperone? flat) + (cond + [flat + (make-flat-opt-contract proj name stronger stronger-vars stamp flat)] + [chaperone? + (make-chaperone-opt-contract proj name stronger stronger-vars stamp)] + [else + (make-impersonator-opt-contract proj name stronger stronger-vars stamp)])) + ;; the stronger-vars don't seem to be used anymore for stronger; probably ;; they should be folded into the lifts and then there should be a separate ;; setup for consolidating stronger checks -(define-struct opt-contract (proj name stronger stronger-vars stamp chaperone?) - #:property prop:opt-chaperone-contract (λ (ctc) (opt-contract-chaperone? ctc)) - #:property prop:custom-write (λ (val port mode) (fprintf port "#" (opt-contract-name val))) +(define-struct opt-contract (proj name stronger stronger-vars stamp)) + +(define (opt-contract-stronger-proc this that) + (and (opt-contract? that) + (eq? (opt-contract-stamp this) (opt-contract-stamp that)) + ((opt-contract-stronger this) this that))) + +(define-struct (flat-opt-contract opt-contract) (predicate) + #:property prop:custom-write + (λ (val port mode) (fprintf port "#" (opt-contract-name val))) + #:property prop:flat-contract + (build-flat-contract-property + #:projection (λ (ctc) ((opt-contract-proj ctc) ctc)) + #:first-order (λ (ctc) (flat-opt-contract-predicate ctc)) + #:name (λ (ctc) (opt-contract-name ctc)) + #:stronger opt-contract-stronger-proc)) +(define-struct (chaperone-opt-contract opt-contract) () + #:property prop:custom-write + (λ (val port mode) (fprintf port "#" (opt-contract-name val))) + #:property prop:chaperone-contract + (build-chaperone-contract-property + #:projection (λ (ctc) ((opt-contract-proj ctc) ctc)) + #:name (λ (ctc) (opt-contract-name ctc)) + #:stronger opt-contract-stronger-proc)) +(define-struct (impersonator-opt-contract opt-contract) () + #:property prop:custom-write + (λ (val port mode) (fprintf port "#" (opt-contract-name val))) #:property prop:contract (build-contract-property #:projection (λ (ctc) ((opt-contract-proj ctc) ctc)) #:name (λ (ctc) (opt-contract-name ctc)) - #:stronger - (λ (this that) - (and (opt-contract? that) - (eq? (opt-contract-stamp this) (opt-contract-stamp that)) - ((opt-contract-stronger this) this that))))) + #:stronger opt-contract-stronger-proc)) diff --git a/racket/collects/racket/contract/private/prop.rkt b/racket/collects/racket/contract/private/prop.rkt index b2c522a4eb..39c72716e6 100644 --- a/racket/collects/racket/contract/private/prop.rkt +++ b/racket/collects/racket/contract/private/prop.rkt @@ -34,11 +34,7 @@ make-contract make-chaperone-contract make-flat-contract - - prop:opt-chaperone-contract - prop:opt-chaperone-contract? - prop:opt-chaperone-contract-get-test - + prop:orc-contract prop:orc-contract? prop:orc-contract-get-subcontracts @@ -221,15 +217,6 @@ chaperone-contract-property-guard (list (cons prop:contract chaperone-contract-property->contract-property)))) -;; this property is so the opt'd contracts can -;; declare that they are chaperone'd; the property -;; is a function that extracts a boolean from the -;; original struct -(define-values (prop:opt-chaperone-contract - prop:opt-chaperone-contract? - prop:opt-chaperone-contract-get-test) - (make-struct-type-property 'prop:opt-chaperone-contract)) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; Flat Contract Property