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

Now change box/c to use proxies or chaperones appropriately.

Browse Source 
Create a mzlib/contract compatible version of the old box/c and use that
for mzlib/contract.  Change the docs so that the docs for mzlib/contract
contain the right information.

Fix the typed-scheme implementation to only force flat box (or hash)
contracts when it already is required to be flat.  Otherwise, allow
non-flat contracts for the element contract (or domain/range contracts).
This commit is contained in:
Stevie Strickland 2010-05-13 15:43:52 -04:00
parent b8fb6dae9a
commit 994ad6d10f
6 changed files with 174 additions and 19 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
collects/mzlib/contract.rkt
View File

@ -23,6 +23,13 @@
(require "private/contract-define.rkt")
(provide (all-from-out "private/contract-define.rkt"))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; old-style flat mutable contracts
;;
(require "private/contract-mutable.rkt")
(provide (all-from-out "private/contract-mutable.rkt"))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; provide everything from the racket/ implementation
@ -30,8 +37,6 @@
;;
(require racket/contract/private/base
racket/contract/private/box
racket/contract/private/hash
racket/contract/private/misc
racket/contract/private/provide
racket/contract/private/guts
@ -46,8 +51,6 @@
contract-struct)
(all-from-out racket/contract/private/base)
(all-from-out racket/contract/private/box)
(all-from-out racket/contract/private/hash)
(all-from-out racket/contract/private/provide)
(except-out (all-from-out racket/contract/private/misc)
check-between/c

24
collects/mzlib/private/contract-mutable.rkt Normal file
View File

@ -0,0 +1,24 @@
#lang racket/base
(require (only-in racket/contract/private/box box-immutable/c)
racket/contract/private/blame
racket/contract/private/guts)
(provide box/c box-immutable/c)
(define/subexpression-pos-prop (box/c ctc)
(let ([ctc (coerce-flat-contract 'box/c ctc)])
(make-flat-contract
#:name (build-compound-type-name 'box/c ctc)
#:first-order
(λ (val)
(and (box? val)
(contract-first-order-passes? ctc (unbox val))))
#:projection
(λ (blame)
(λ (val)
(let ([proj ((contract-projection ctc) blame)])
(unless (box? val)
(raise-blame-error blame val "not a box"))
(proj (unbox val))
val))))))

8
collects/mzlib/scribblings/contract.scrbl
View File

@ -47,7 +47,6 @@ from @schememodname[scheme/contract]:
any/c
between/c
box-immutable/c
box/c
build-compound-type-name
coerce-contract
cons/c
@ -90,7 +89,7 @@ from @schememodname[scheme/contract]:
vector/c
vectorof]
It also provides the old version of @scheme[define/contract]:
It also provides the old version of the following forms:
@defform[(define/contract id contract-expr init-value-expr)]{
@ -109,3 +108,8 @@ provided by @scheme[provide/contract], because
where the reference to the defined variable occurs. Instead, it uses
the source location of the reference to the variable as the name of
that definition.}
@defproc[(box/c [c flat-contract?]) flat-contract?]{
Returns a flat contract that recognizes boxes. The content of the box
must match @racket[c].}

111
collects/racket/contract/private/box.rkt
View File

@ -3,7 +3,8 @@
(require (for-syntax racket/base)
"guts.rkt")
(provide box-immutable/c box/c)
(provide box-immutable/c
(rename-out [build-box/c box/c]))
(define-syntax (*-immutable/c stx)
(syntax-case stx ()
@ -87,12 +88,104 @@
(define box-immutable/c (*-immutable/c box? box-immutable (#f unbox) immutable-box box-immutable/c))
(define/final-prop (box/c pred)
(let* ([ctc (coerce-flat-contract 'box/c pred)]
[p? (flat-contract-predicate ctc)])
(build-flat-contract
(build-compound-type-name 'box/c ctc)
(λ (x)
(and (box? x)
(p? (unbox x)))))))
(define-struct box/c (content immutable))
(define (box/c-first-order ctc)
(let ([elem-ctc (box/c-content ctc)]
[immutable (box/c-immutable ctc)]
[flat? (flat-box/c? ctc)])
(λ (val #:blame [blame #f])
(let/ec return
(define (fail . args)
(if blame
(apply raise-blame-error blame val args)
(return #f)))
(unless (box? val)
(fail "expected a box, got ~a" val))
(case immutable
[(#t)
(unless (immutable? val)
(fail "expected an immutable box, got ~a" val))]
[(#f)
(when (immutable? val)
(fail "expected a mutable box, got ~a" val))]
[(dont-care) (void)])
(when (or flat? (and (immutable? val) (not blame)))
(if blame
(begin (((contract-projection elem-ctc) blame) (unbox val))
(void))
(unless (contract-first-order-passes? elem-ctc (unbox val))
(fail))))))))
(define (box/c-name ctc)
(let ([elem-name (contract-name (box/c-content ctc))]
[immutable (box/c-immutable ctc)]
[flat? (flat-box/c? ctc)])
(apply build-compound-type-name
'box/c
elem-name
(if (and flat? (eq? immutable #t))
(list '#:immutable #t)
(append
(if (not (eq? immutable 'dont-care))
(list '#:immutable immutable)
null)
(if flat?
(list '#:flat? #t)
null))))))
(define-struct (flat-box/c box/c) ()
#:property prop:flat-contract
(build-flat-contract-property
#:name box/c-name
#:first-order box/c-first-order
#:projection
(λ (ctc)
(λ (blame)
(λ (val)
((box/c-first-order ctc) val #:blame blame)
val)))))
(define (ho-projection box-wrapper)
(λ (ctc)
(let ([elem-ctc (box/c-content ctc)]
[immutable (box/c-immutable ctc)])
(λ (blame)
(let ([pos-elem-proj ((contract-projection elem-ctc) blame)]
[neg-elem-proj ((contract-projection elem-ctc) (blame-swap blame))])
(λ (val)
((box/c-first-order ctc) val #:blame blame)
(if (immutable? val)
(box-immutable (pos-elem-proj (unbox val)))
(box-wrapper val
(λ (b v) (pos-elem-proj v))
(λ (b v) (neg-elem-proj v))))))))))
(define-struct (chaperone-box/c box/c) ()
#:property prop:chaperone-contract
(build-chaperone-contract-property
#:name box/c-name
#:first-order box/c-first-order
#:projection (ho-projection chaperone-box)))
(define-struct (proxy-box/c box/c) ()
#:property prop:contract
(build-contract-property
#:name box/c-name
#:first-order box/c-first-order
#:projection (ho-projection proxy-box)))
(define (build-box/c elem #:immutable [immutable 'dont-care] #:flat? [flat? #f])
(let ([ctc (if flat?
(coerce-flat-contract 'box/c elem)
(coerce-contract 'box/c elem))])
(cond
[(or flat?
(and (eq? immutable #t)
(flat-contract? ctc)))
(make-flat-box/c ctc immutable)]
[(chaperone-contract? ctc)
(make-chaperone-box/c ctc immutable)]
[else
(make-proxy-box/c ctc immutable)])))

30
collects/tests/racket/contract-test.rktl
View File

@ -8885,6 +8885,30 @@ so that propagation occurs.
#:higher-order (λ (b) values))])
(hash/c proxy-ctc proxy-ctc))
exn:fail?)
(ctest #t contract? (box/c number? #:flat? #t))
(ctest #t chaperone-contract? (box/c number? #:flat? #t))
(ctest #t flat-contract? (box/c number? #:flat? #t))
(ctest #t contract? (box/c number? #:immutable #t))
(ctest #t chaperone-contract? (box/c number? #:immutable #t))
(ctest #t flat-contract? (box/c number? #:immutable #t))
(ctest #t contract? (box/c number?))
(ctest #t chaperone-contract? (box/c number?))
(ctest #f flat-contract? (box/c number?))
(ctest #t contract? (box/c (box/c number?) #:immutable #t))
(ctest #t chaperone-contract? (box/c (box/c number?) #:immutable #t))
(ctest #f flat-contract? (box/c (box/c number?) #:immutable #t))
(ctest #t contract? (box/c (-> number? number?)))
(ctest #f chaperone-contract? (box/c (-> number? number?)))
(ctest #f flat-contract? (box/c (-> number? number?)))
(ctest #t contract? (box/c (-> number? number?) #:immutable #t))
(ctest #f chaperone-contract? (box/c (-> number? number?) #:immutable #t))
(ctest #f flat-contract? (box/c (-> number? number?) #:immutable #t))
(ctest #t contract? 1)
(ctest #t contract? (-> 1 1))
@ -8978,8 +9002,10 @@ so that propagation occurs.
(test-flat-contract '(list/c a-predicate-that-wont-be-optimized (flat-contract integer?)) (list #t 1) (list 1 #f))
(test-flat-contract '(list/c a-predicate-that-wont-be-optimized (flat-contract integer?)) (list #t 1) #f)
(test-flat-contract '(box/c boolean?) (box #f) (box 1))
(test-flat-contract '(box/c (flat-contract boolean?)) (box #t) #f)
(test-flat-contract '(box/c boolean? #:flat? #t) (box #f) (box 1))
(test-flat-contract '(box/c (flat-contract boolean?) #:flat? #t) (box #t) #f)
(test-flat-contract '(box-immutable/c boolean?) (box-immutable #f) (box-immutable 1))
(test-flat-contract '(box-immutable/c (flat-contract boolean?)) (box-immutable #t) #f)
(test-flat-contract '(flat-rec-contract sexp (cons/c sexp sexp) number?) '(1 2 . 3) '(1 . #f))
(test-flat-contract '(flat-murec-contract ([even1 (or/c null? (cons/c number? even2))]

9
collects/typed-scheme/private/type-contract.rkt
View File

@ -134,7 +134,9 @@
[(Vector: t)
#`(vectorof #,(t->c t #:flat #t))]
[(Box: t)
#`(box/c #,(t->c t #:flat #t))]
(if flat?
#`(box/c #,(t->c t #:flat #t) #:flat? #t)
#`(box/c #,(t->c t)))]
[(Pair: t1 t2)
#`(cons/c #,(t->c t1) #,(t->c t2))]
[(Opaque: p? cert)
@ -206,7 +208,10 @@
[(Syntax: t) #`(syntax/c #,(t->c t))]
[(Value: v) #`(flat-named-contract #,(format "~a" v) (lambda (x) (equal? x '#,v)))]
[(Param: in out) #`(parameter/c #,(t->c out))]
[(Hashtable: k v) #`(hash/c #,(t->c k #:flat #t) #,(t->c v #:flat #t) #:immutable 'dont-care)]
[(Hashtable: k v)
(if flat?
#`(hash/c #,(t->c k #:flat #t) #,(t->c v #:flat #t) #:flat? #t #:immutable 'dont-care)
#`(hash/c #,(t->c k) #,(t->c v) #:immutable 'dont-care))]
[else
(exit (fail))]))))