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

.

Browse Source 
original commit: 28e8d7d337f009adcb92d142d6f92140379d506d
This commit is contained in:
Robby Findler 2005-01-20 05:05:05 +00:00
parent 6ebc7b5f67
commit b33493ea8e
2 changed files with 156 additions and 6 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

80
collects/mzlib/contract.ss
View File

@ -1231,10 +1231,14 @@ add struct contracts for immutable structs?
[(field-var ...) (generate-temporaries flds)]
[(field/app-var ...) (generate-temporaries flds)])
(syntax
(let ([method-ctc-var method-ctc-stx] ...
[field-ctc-var (coerce-contract object-contract field-ctc-stx)] ...)
(let ([method-var (contract-proc method-ctc-var)] ...
[field-var (contract-proc field-ctc-var)] ...)
(let ([method-ctc-var method-ctc-stx]
...
[field-ctc-var (coerce-contract object-contract field-ctc-stx)]
...)
(let ([method-var (contract-proc method-ctc-var)]
...
[field-var (contract-proc field-ctc-var)]
...)
(make-contract
`(object-contract
,(build-compound-type-name 'method-name method-ctc-var) ...
@ -2432,6 +2436,8 @@ add struct contracts for immutable structs?
vectorof vector-immutableof vector/c vector-immutable/c
cons-immutable/c cons/c list-immutable/c list/c
box-immutable/c box/c
promise/c
struct/c
mixin-contract make-mixin-contract
syntax/c)
@ -2964,6 +2970,72 @@ add struct contracts for immutable structs?
(and (syntax? val)
(pred (syntax-e val)))))))
(define promise/c
(lambda (ctc-in)
(let* ([ctc (coerce-contract promise/c ctc-in)]
[ctc-proc (contract-proc ctc)])
(make-contract
(build-compound-type-name 'promise/c ctc)
(lambda (pos neg src-info orig-str)
(let ([p-app (ctc-proc pos neg src-info orig-str)])
(lambda (val)
(unless (promise? val)
(raise-contract-error
src-info
pos
neg
orig-str
"expected <promise>, given: ~e"
val))
(delay (p-app (force val))))))))))
(define-syntax (struct/c stx)
(syntax-case stx ()
[(_ struct-name args ...)
(and (identifier? (syntax struct-name))
(syntax-local-value (syntax struct-name) (lambda () #f)))
(with-syntax ([(ctc-x ...) (generate-temporaries (syntax (args ...)))]
[(ctc-proc-x ...) (generate-temporaries (syntax (args ...)))]
[(ctc-app-x ...) (generate-temporaries (syntax (args ...)))]
[(type-desc-id
constructor-id
predicate-id
(selector-id ...)
(mutator-id ...)
super-id)
(syntax-local-value (syntax struct-name))])
(syntax
(let ([ctc-x (coerce-contract struct/c args)] ...)
(unless predicate-id
(error 'struct/c "could not determine predicate for ~s" 'struct-name))
(unless (and selector-id ...)
(error 'struct/c "could not determine selectors for ~s" 'struct-name))
(unless (flat-contract? ctc-x)
(error 'struct/c "expected flat contracts as arguments, got ~e" ctc-x))
...
(let ([ctc-proc-x (contract-proc ctc-x)] ...)
(make-contract
(build-compound-type-name 'struct/c 'struct-name ctc-x ...)
(lambda (pos neg src-info orig-str)
(let ([ctc-app-x (ctc-proc-x pos neg src-info orig-str)] ...)
(lambda (val)
(unless (predicate-id val)
(raise-contract-error
src-info
pos
neg
orig-str
"expected <~a>, given: ~e"
'struct-name
val))
(ctc-app-x (selector-id val)) ...
val))))))))]
[(_ struct-name anything ...)
(raise-syntax-error 'struct/c "expected a struct identifier" stx (syntax struct-name))]))
(define (flat-contract/predicate? pred)
(or (flat-contract? pred)
(and (procedure? pred)

82
collects/tests/mzscheme/contract-test.ss
View File

@ -2395,6 +2395,79 @@
'neg)
1))
(test/pos-blame
'promise/c1
'(force (contract (promise/c boolean?)
(delay 1)
'pos
'neg)))
(test/spec-passed
'promise/c2
'(force (contract (promise/c boolean?)
(delay #t)
'pos
'neg)))
(test/spec-passed/result
'promise/c3
'(let ([x 0])
(contract (promise/c any/c)
(delay (set! x (+ x 1)))
'pos
'neg)
x)
0)
(test/spec-passed/result
'promise/c4
'(let ([x 0])
(force (contract (promise/c any/c)
(delay (set! x (+ x 1)))
'pos
'neg))
x)
1)
(test/spec-passed/result
'promise/c5
'(let ([x 0])
(let ([p (contract (promise/c any/c)
(delay (set! x (+ x 1)))
'pos
'neg)])
(force p)
(force p))
x)
1)
(test/spec-passed
'struct/c1
'(let ()
(define-struct s (a))
(contract (struct/c s integer?)
(make-s 1)
'pos
'neg)))
(test/pos-blame
'struct/c2
'(let ()
(define-struct s (a))
(contract (struct/c s integer?)
(make-s #f)
'pos
'neg)))
(test/pos-blame
'struct/c3
'(let ()
(define-struct s (a))
(contract (struct/c s integer?)
1
'pos
'neg)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; ;;
;; Flat Contract Tests ;;
@ -2640,7 +2713,8 @@
(object-contract (m (-> integer? any))))
(test-name '(object-contract (m (-> integer? (values integer? integer?))))
(object-contract (m (-> integer? (values integer? integer?)))))
(test-name '(object-contract (m (case-> (-> integer? integer? integer?) (-> integer? (values integer? integer?)))))
(test-name '(object-contract (m (case-> (-> integer? integer? integer?)
(-> integer? (values integer? integer?)))))
(object-contract (m (case->
(-> integer? integer? integer?)
(-> integer? (values integer? integer?))))))
@ -2669,6 +2743,10 @@
(object-contract (m (->r ((x number?) (y boolean?) (z pair?)) number?))))
(test-name '(object-contract (m (->r ((x ...) (y ...) (z ...)) rest-x ... ...)))
(object-contract (m (->r ((x number?) (y boolean?) (z pair?)) rest-x any/c number?))))
(test-name '(promise/c any/c) (promise/c any/c))
(test-name '(struct/c st integer?)
(let ()
(define-struct st (a))
(struct/c st integer?)))
))
(report-errs)