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). original commit: 994ad6d10fc817a5ceca2f9f4874dac5c14c0aab
This commit is contained in:
parent
71d6d2f101
commit
7271481c49
|
@ -23,6 +23,13 @@
|
||||||
(require "private/contract-define.rkt")
|
(require "private/contract-define.rkt")
|
||||||
(provide (all-from-out "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
|
;; provide everything from the racket/ implementation
|
||||||
|
@ -30,8 +37,6 @@
|
||||||
;;
|
;;
|
||||||
|
|
||||||
(require racket/contract/private/base
|
(require racket/contract/private/base
|
||||||
racket/contract/private/box
|
|
||||||
racket/contract/private/hash
|
|
||||||
racket/contract/private/misc
|
racket/contract/private/misc
|
||||||
racket/contract/private/provide
|
racket/contract/private/provide
|
||||||
racket/contract/private/guts
|
racket/contract/private/guts
|
||||||
|
@ -46,8 +51,6 @@
|
||||||
contract-struct)
|
contract-struct)
|
||||||
|
|
||||||
(all-from-out racket/contract/private/base)
|
(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)
|
(all-from-out racket/contract/private/provide)
|
||||||
(except-out (all-from-out racket/contract/private/misc)
|
(except-out (all-from-out racket/contract/private/misc)
|
||||||
check-between/c
|
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))))))
|
Loading…
Reference in New Issue
Block a user