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

Change box-immutable/c to use box/c with #:immutable #t.

Browse Source
This commit is contained in:
Stevie Strickland 2010-05-14 15:38:19 -04:00
parent 99e5d6fd6c
commit e3678a937e
2 changed files with 5 additions and 81 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -6,87 +6,8 @@
(provide box-immutable/c
(rename-out [wrap-box/c box/c]))
(define-syntax (*-immutable/c stx)
(syntax-case stx ()
[(_ predicate? constructor (arb? selectors ...) type-name name)
#'(*-immutable/c predicate? constructor (arb? selectors ...) type-name name #t)]
[(_ predicate? constructor (arb? selectors ...) type-name name test-immutable?)
(and (eq? #f (syntax->datum (syntax arb?)))
(boolean? (syntax->datum #'test-immutable?)))
(let ([test-immutable? (syntax->datum #'test-immutable?)])
(with-syntax ([(params ...) (generate-temporaries (syntax (selectors ...)))]
[(p-apps ...) (generate-temporaries (syntax (selectors ...)))]
[(ctc-x ...) (generate-temporaries (syntax (selectors ...)))]
[(procs ...) (generate-temporaries (syntax (selectors ...)))]
[(selector-names ...) (generate-temporaries (syntax (selectors ...)))])
#`(let ([predicate?-name predicate?]
[constructor-name constructor]
[selector-names selectors] ...)
(λ (params ...)
(let ([ctc-x (coerce-contract 'name params)] ...)
(if (and (flat-contract? ctc-x) ...)
(let ([p-apps (flat-contract-predicate ctc-x)] ...)
(build-flat-contract
`(name ,(contract-name ctc-x) ...)
(lambda (x)
(and (predicate?-name x)
(p-apps (selector-names x))
...))))
(let ([procs (contract-projection ctc-x)] ...)
(make-contract
#:name (build-compound-type-name 'name ctc-x ...)
#:projection
(λ (blame)
(let ([p-apps (procs blame)] ...)
(λ (v)
(if #,(if test-immutable?
#'(and (predicate?-name v)
(immutable? v))
#'(predicate?-name v))
(constructor-name (p-apps (selector-names v)) ...)
(raise-blame-error
blame
v
#,(if test-immutable?
"expected immutable <~a>, given: ~e"
"expected <~a>, given: ~e")
'type-name
v)))))))))))))]
[(_ predicate? constructor (arb? selector) correct-size type-name name)
(eq? #t (syntax->datum (syntax arb?)))
(syntax
(let ([predicate?-name predicate?]
[constructor-name constructor]
[selector-name selector])
(λ params
(let ([ctcs (map (λ (param) (coerce-contract 'name param)) params)])
(let ([procs (map contract-projection ctcs)])
(make-contract
#:name (apply build-compound-type-name 'name ctcs)
#:projection
(λ (blame)
(let ([p-apps (map (λ (proc) (proc blame)) procs)]
[count (length params)])
(λ (v)
(if (and (immutable? v)
(predicate?-name v)
(correct-size count v))
(apply constructor-name
(let loop ([p-apps p-apps]
[i 0])
(cond
[(null? p-apps) null]
[else (let ([p-app (car p-apps)])
(cons (p-app (selector-name v i))
(loop (cdr p-apps) (+ i 1))))])))
(raise-blame-error
blame
v
"expected <~a>, given: ~e"
'type-name
v)))))))))))]))
(define box-immutable/c (*-immutable/c box? box-immutable (#f unbox) immutable-box box-immutable/c))
(define/subexpression-pos-prop (box-immutable/c elem)
(build-box/c elem #:immutable #t))
(define-struct box/c (content immutable))

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

@ -10022,6 +10022,9 @@ so that propagation occurs.
(test-obligations '(box/c a)
'((racket/contract:contract (box/c) ())
(racket/contract:positive-position a)))
(test-obligations '(box-immutable/c a)
'((racket/contract:contract (box-immutable/c) ())
(racket/contract:positive-position a)))
;