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

Add instanceof.

Browse Source 
The instanceof contract combinator takes a class contract.  The resulting
contract protects objects using the external field and method contracts
in the class contract.
This commit is contained in:
Stevie Strickland 2011-01-07 18:22:24 -05:00
parent d6fc7da750
commit 92775c5e4e
3 changed files with 112 additions and 14 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

45
collects/racket/private/class-internal.rkt
View File

@ -58,7 +58,7 @@
method-in-interface? interface->method-names class->interface class-info
(struct-out exn:fail:object)
make-primitive-class
class/c ->m ->*m ->dm case->m object/c
class/c ->m ->*m ->dm case->m object/c instanceof
;; "keywords":
private public override augment
@ -3099,11 +3099,15 @@
(λ (blame)
(λ (obj)
(make-wrapper-object ctc obj blame
(object/c-methods ctc) (object/c-method-contracts ctc)
(object/c-fields ctc) (object/c-field-contracts ctc)))))
(base-object/c-methods ctc) (base-object/c-method-contracts ctc)
(base-object/c-fields ctc) (base-object/c-field-contracts ctc)))))
(define-struct object/c (methods method-contracts fields field-contracts)
#:omit-define-syntaxes
(define (object/c-first-order ctc)
(λ (obj)
(let/ec ret
(check-object-contract obj (base-object/c-methods ctc) (base-object/c-fields ctc) (λ args (ret #f))))))
(define-struct base-object/c (methods method-contracts fields field-contracts)
#:property prop:contract
(build-contract-property
#:projection object/c-proj
@ -3122,13 +3126,9 @@
(apply build-compound-type-name
'object/c
(append
(pair-ids-ctcs (object/c-methods ctc) (object/c-method-contracts ctc))
(handle-optional 'field (object/c-fields ctc) (object/c-field-contracts ctc))))))
#:first-order
(λ (ctc)
(λ (obj)
(let/ec ret
(check-object-contract obj (object/c-methods ctc) (object/c-fields ctc) (λ args (ret #f))))))))
(pair-ids-ctcs (base-object/c-methods ctc) (base-object/c-method-contracts ctc))
(handle-optional 'field (base-object/c-fields ctc) (base-object/c-field-contracts ctc))))))
#:first-order object/c-first-order))
(define-syntax (object/c stx)
(syntax-case stx ()
@ -3139,7 +3139,24 @@
[fields #`(list #,@(reverse (hash-ref parsed-forms 'fields null)))]
[field-ctcs #`(list #,@(reverse (hash-ref parsed-forms 'field-contracts null)))])
(syntax/loc stx
(make-object/c methods method-ctcs fields field-ctcs))))]))
(make-base-object/c methods method-ctcs fields field-ctcs))))]))
(define-struct (base-instanceof base-object/c) (class-ctc)
#:property prop:contract
(build-contract-property
#:projection object/c-proj
#:name
(λ (ctc)
(build-compound-type-name 'instanceof (base-instanceof-class-ctc ctc)))
#:first-order object/c-first-order))
(define (instanceof cctc)
(let ([ctc (coerce-contract 'instanceof cctc)])
(unless (class/c? ctc)
(error "expected class contract, got ~v" ctc))
(make-base-instanceof (class/c-methods ctc) (class/c-method-contracts ctc)
(class/c-fields ctc) (class/c-field-contracts ctc)
ctc)))
;;--------------------------------------------------------------------
;; interfaces
@ -4670,5 +4687,5 @@
method-in-interface? interface->method-names class->interface class-info
(struct-out exn:fail:object)
make-primitive-class
class/c ->m ->*m ->dm case->m object/c)
class/c ->m ->*m ->dm case->m object/c instanceof)

8
collects/scribblings/reference/class.scrbl
View File

@ -1626,6 +1626,14 @@ behaves as if its class had been wrapped with the equivalent
@scheme[class/c] contract.
}
@defproc[(instanceof [class-contract contract?]) contract?]{
Produces a contract for an instance of a class that conforms
to @scheme[class-contract].
The resulting contract checks only the external field and method
contracts listed in @scheme[class-contract].
}
@defform/subs[
#:literals (field -> ->* ->d)

73
collects/tests/racket/contract-test.rktl
View File

@ -7486,6 +7486,79 @@
'neg)])
(set-field! n pre-o #t)
(get-field n o)))
;
;
;
; ; ;;;
; ; ;
; ; ;
; ; ;
; ; ;; ;;; ;;;; ;;;;; ;;;; ;; ;;; ;;; ;;; ;;; ;;;;
; ;; ;; ; ; ; ; ; ;; ; ; ; ; ; ; ; ;
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
; ; ; ; ;; ; ;;;;; ; ; ; ;;;;;;; ; ; ;
; ; ; ; ;; ; ; ; ; ; ; ; ; ; ;
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
; ; ; ; ; ; ; ; ;; ; ; ; ; ; ; ; ; ;
; ;;; ;;; ;;; ;;;; ;;; ;;; ;; ;;; ;;; ;;; ;;;; ;;; ;;;
;
;
;
;
(test/spec-passed
'instanceof-first-order-1
'(let* ([c% object%]
[c%/c (class/c)])
(contract (instanceof c%/c) (new c%) 'pos 'neg)))
(test/pos-blame
'instanceof-first-order-2
'(let* ([c% object%]
[c%/c (class/c (field [f number?]))])
(contract (instanceof c%/c) (new c%) 'pos 'neg)))
(test/pos-blame
'instanceof-first-order-3
'(let* ([c% object%]
[c%/c (class/c [m (->m number? number?)])])
(contract (instanceof c%/c) (new c%) 'pos 'neg)))
(test/spec-passed
'instanceof-first-order-4
'(let* ([c% (class object% (super-new) (field [f 3]))]
[c%/c (class/c (field [f number?]))])
(contract (instanceof c%/c) (new c%) 'pos 'neg)))
(test/spec-passed
'instanceof-first-order-5
'(let* ([c% (class object% (super-new) (define/public (m x) x))]
[c%/c (class/c [m (->m number? number?)])])
(contract (instanceof c%/c) (new c%) 'pos 'neg)))
(test/spec-passed/result
'instanceof-higher-order-1
'(let* ([c% (class object% (super-new) (field [f 3]))]
[c%/c (class/c (field [f number?]))]
[o (contract (instanceof c%/c) (new c%) 'pos 'neg)])
(get-field f o))
3)
(test/neg-blame
'instanceof-higher-order-2
'(let* ([c% (class object% (super-new) (field [f 3]))]
[c%/c (class/c (field [f number?]))]
[o (contract (instanceof c%/c) (new c%) 'pos 'neg)])
(set-field! f o #t)))
(test/pos-blame
'instanceof-higher-order-3
'(let* ([c% (class object% (super-new) (define/public (m x) (zero? x)))]
[c%/c (class/c [m (->m number? number?)])]
[o (contract (instanceof c%/c) (new c%) 'pos 'neg)])
(send o m 3)))
;
;