From d0a35ce51a981bae2eac0caeceb2a06768c921f5 Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Mon, 15 Nov 2010 16:06:43 -0500 Subject: [PATCH] Conversion of object/c and object-contract to use impersonators. original commit: 2bd7760412ec9c8e4af8936193cb3a6cb95518b0 --- collects/mzlib/private/contract-object.rkt | 28 ++++++++++++---------- 1 file changed, 15 insertions(+), 13 deletions(-) diff --git a/collects/mzlib/private/contract-object.rkt b/collects/mzlib/private/contract-object.rkt index d877bac..8daded9 100644 --- a/collects/mzlib/private/contract-object.rkt +++ b/collects/mzlib/private/contract-object.rkt @@ -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)