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

Conversion of object/c and object-contract to use impersonators.

Browse Source 
original commit: 2bd7760412ec9c8e4af8936193cb3a6cb95518b0
This commit is contained in:
Stevie Strickland 2010-11-15 16:06:43 -05:00
parent 866da10d6e
commit d0a35ce51a
1 changed files with 15 additions and 13 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

28
collects/mzlib/private/contract-object.rkt
View File

@ -281,20 +281,22 @@
...
[field-ctc-var (coerce-contract 'object-contract field-ctc-stx)]
...)
(make-contract
#:name
`(object-contract
,(build-compound-type-name 'method-name method-ctc-var) ...
,(build-compound-type-name 'field 'field-name field-ctc-var) ...)
#:projection
(lambda (blame)
(define ctc
(make-contract
#:name
`(object-contract
,(build-compound-type-name 'method-name method-ctc-var) ...
,(build-compound-type-name 'field 'field-name field-ctc-var) ...)
#:projection
(lambda (blame)
(lambda (val)
(make-wrapper-object ctc val blame
(list 'method-name ...) (list method-ctc-var ...)
(list 'field-name ...) (list field-ctc-var ...))))
#:first-order
(lambda (val)
(make-wrapper-object val blame
(list 'method-name ...) (list method-ctc-var ...)
(list 'field-name ...) (list field-ctc-var ...))))
#:first-order
(lambda (val)
(check-object-contract val #f (list 'method-name ...) (list 'field-name ...))))))))]))))
(check-object-contract val #f (list 'method-name ...) (list 'field-name ...))))
ctc)))))]))))
(define (check-object val blame)