Ported object contracts to new properties.
svn: r17719
This commit is contained in:
Carl Eastlund
parent
7763a4079a
commit
6ac7fe78e6
|
|
@ -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 ()
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user