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)] [field-ctc-var (coerce-contract 'object-contract field-ctc-stx)]
...) ...)
(make-contract (define ctc
#:name (make-contract
`(object-contract #:name
,(build-compound-type-name 'method-name method-ctc-var) ... `(object-contract
,(build-compound-type-name 'field 'field-name field-ctc-var) ...) ,(build-compound-type-name 'method-name method-ctc-var) ...
#:projection ,(build-compound-type-name 'field 'field-name field-ctc-var) ...)
(lambda (blame) #: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) (lambda (val)
(make-wrapper-object val blame (check-object-contract val #f (list 'method-name ...) (list 'field-name ...))))
(list 'method-name ...) (list method-ctc-var ...) ctc)))))]))))
(list 'field-name ...) (list field-ctc-var ...))))
#:first-order
(lambda (val)
(check-object-contract val #f (list 'method-name ...) (list 'field-name ...))))))))]))))
(define (check-object val blame) (define (check-object val blame)