Now change box/c to use proxies or chaperones appropriately.
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:
parent
b8fb6dae9a
commit
994ad6d10f
|
@ -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
24
collects/mzlib/private/contract-mutable.rkt
Normal 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))))))
|
|
@ -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].}
|
||||
|
|
|
@ -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)])))
|
||||
|
||||
|
|
|
@ -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))]
|
||||
|
|
|
@ -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))]))))
|
||||
|
||||
|
|
Loading…
Reference in New Issue
Block a user