From 6ac7fe78e6927319681092fc6ed3eef54ee2996d Mon Sep 17 00:00:00 2001 From: Carl Eastlund Date: Mon, 18 Jan 2010 18:32:26 +0000 Subject: [PATCH] Ported object contracts to new properties. svn: r17719 --- collects/scheme/contract/private/object.ss | 114 ++++++++++----------- 1 file changed, 55 insertions(+), 59 deletions(-) diff --git a/collects/scheme/contract/private/object.ss b/collects/scheme/contract/private/object.ss index a306e854f0..5bf3e0b149 100644 --- a/collects/scheme/contract/private/object.ss +++ b/collects/scheme/contract/private/object.ss @@ -17,8 +17,10 @@ #; (let* ([cm (syntax-parameterize ((making-a-method #t)) (-> any/c integer? integer?))] [cf (-> integer? integer?)] - [m-proj (((proj-get cm) cm) 'pos 'neg #'here "whatever" some-boolean)] - [f-proj (((proj-get cf) cf) 'pos 'neg #'here "whatever" some-boolean)] + [m-proj ((contract-projection cm) + (make-blame #'here #f "whatever" 'pos 'neg #f))] + [f-proj ((contract-projection cf) + (make-blame #'here #f "whatever" 'pos 'neg #f))] [cls (make-wrapper-class 'wrapper-class '(m) (list @@ -52,63 +54,57 @@ (define-struct object-contract (methods method-ctcs method-wrappers fields field-ctcs) #:omit-define-syntaxes - #:property proj-prop - (λ (ctc) - (let ([meth-names (object-contract-methods ctc)] - [meth-param-projs (map (λ (x) ((proj-get x) x)) (object-contract-method-ctcs ctc))] - [ctc-field-names (object-contract-fields ctc)] - [field-param-projs (map (λ (x) ((proj-get x) x)) (object-contract-field-ctcs ctc))]) - (λ (pos-blame neg-blame src-info orig-str positive-position?) - (let* ([meth-projs (map (λ (x) (x pos-blame neg-blame src-info orig-str positive-position?)) - meth-param-projs)] - [meths (map (λ (p x) (p x)) meth-projs (object-contract-method-wrappers ctc))] - [cls (make-wrapper-class 'wrapper-class meth-names meths ctc-field-names #f)] - [field-projs (map (λ (x) (x pos-blame neg-blame src-info orig-str positive-position?)) field-param-projs)]) - (λ (val) - - (unless (object? val) - (raise-contract-error val src-info pos-blame orig-str - "expected an object, got ~e" - val)) - - (let ([objs-mtds (interface->method-names (object-interface val))] - [vtable (extract-vtable val)] - [method-ht (extract-method-ht val)]) - (for-each (λ (m proj) - (let ([index (hash-ref method-ht m #f)]) - (unless index - (raise-contract-error val src-info pos-blame orig-str - "expected an object with method ~s" - m)) - ;; verify the first-order properties by apply the projection and - ;; throwing the result away. Without this, the contract wrappers - ;; just check the first-order properties of the wrappers, which is - ;; the wrong thing. - (proj (vector-ref vtable index)))) - meth-names - meth-projs)) - - (let ([fields (field-names val)]) - (for-each (λ (f) - (unless (memq f fields) - (raise-contract-error val src-info pos-blame orig-str - "expected an object with field ~s" - f))) - ctc-field-names)) - - (apply make-object cls val - (map (λ (field proj) (proj (get-field/proc field val))) - ctc-field-names field-projs))))))) - #:property name-prop - (λ (ctc) `(object-contract ,@(map (λ (fld ctc) (build-compound-type-name 'field fld ctc)) - (object-contract-fields ctc) - (object-contract-field-ctcs ctc)) - ,@(map (λ (mtd ctc) (build-compound-type-name mtd ctc)) - (object-contract-methods ctc) - (object-contract-method-ctcs ctc)))) - - #:property first-order-prop (λ (ctc) (λ (val) #f)) - #:property stronger-prop (λ (this that) #f)) + #:property prop:contract + (build-contract-property + #:projection + (λ (ctc) + (let ([meth-names (object-contract-methods ctc)] + [meth-param-projs (map contract-projection (object-contract-method-ctcs ctc))] + [ctc-field-names (object-contract-fields ctc)] + [field-param-projs (map contract-projection (object-contract-field-ctcs ctc))]) + (λ (blame) + (let* ([meth-projs (map (λ (x) (x blame)) meth-param-projs)] + [meths (map (λ (p x) (p x)) meth-projs (object-contract-method-wrappers ctc))] + [cls (make-wrapper-class 'wrapper-class meth-names meths ctc-field-names #f)] + [field-projs (map (λ (x) (x blame)) field-param-projs)]) + (λ (val) + + (unless (object? val) + (raise-blame-error blame val "expected an object, got ~e" val)) + + (let ([objs-mtds (interface->method-names (object-interface val))] + [vtable (extract-vtable val)] + [method-ht (extract-method-ht val)]) + (for-each (λ (m proj) + (let ([index (hash-ref method-ht m #f)]) + (unless index + (raise-blame-error blame val "expected an object with method ~s" m)) + ;; verify the first-order properties by apply the projection and + ;; throwing the result away. Without this, the contract wrappers + ;; just check the first-order properties of the wrappers, which is + ;; the wrong thing. + (proj (vector-ref vtable index)))) + meth-names + meth-projs)) + + (let ([fields (field-names val)]) + (for-each (λ (f) + (unless (memq f fields) + (raise-blame-error blame val "expected an object with field ~s" f))) + ctc-field-names)) + + (apply make-object cls val + (map (λ (field proj) (proj (get-field/proc field val))) + ctc-field-names field-projs))))))) + #:name + (λ (ctc) `(object-contract ,@(map (λ (fld ctc) (build-compound-type-name 'field fld ctc)) + (object-contract-fields ctc) + (object-contract-field-ctcs ctc)) + ,@(map (λ (mtd ctc) (build-compound-type-name mtd ctc)) + (object-contract-methods ctc) + (object-contract-method-ctcs ctc)))) + + #:first-order (λ (ctc) (λ (val) #f)))) (define-syntax (object-contract stx) (syntax-case stx ()