suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

fix opt/c for flat-contract?

Browse Source 
Thanks to Philip McGrath for spotting the problem

Also, along the way, discover the setup for chaperoneness for opt
contracts was bogus, so fix that up too
This commit is contained in:
Robby Findler 2018-02-17 18:17:36 -06:00
parent 95dab07e47
commit 8393f0b2f6
5 changed files with 53 additions and 33 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
pkgs/racket-test/tests/racket/contract/flat-contracts.rkt
View File

@ -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

4
racket/collects/racket/contract/combinator.rkt
View File

@ -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

4
racket/collects/racket/contract/private/guts.rkt
View File

@ -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))

62
racket/collects/racket/contract/private/opt.rkt
View File

@ -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: ~.s>" (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-flat-contract: ~.s>" (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-chaperone-contract: ~.s>" (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: ~.s>" (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))

15
racket/collects/racket/contract/private/prop.rkt
View File

@ -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