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

Add #:opaque keyword to class/c.

Browse Source 
The #:opaque keyword specifies that a class/c should be opaque.
An opaque class contract raises an error if the contracted class
contains any methods not mentioned in the contract.
This commit is contained in:
Asumu Takikawa 2012-01-12 01:20:16 -05:00
parent 09200fc7aa
commit 3eb963f62d
1 changed files with 20 additions and 3 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -16,6 +16,7 @@
syntax/define syntax/define
syntax/flatten-begin syntax/flatten-begin
syntax/private/boundmap syntax/private/boundmap
syntax/parse
"classidmap.rkt")) "classidmap.rkt"))
(define insp (current-inspector)) ; for all opaque structures (define insp (current-inspector)) ; for all opaque structures
@ -2576,6 +2577,10 @@
(for ([m (class/c-absents ctc)]) (for ([m (class/c-absents ctc)])
(when (hash-ref method-ht m #f) (when (hash-ref method-ht m #f)
(fail "class already contains public method ~a" m))) (fail "class already contains public method ~a" m)))
(when (class/c-opaque? ctc)
(for ([m (in-hash-keys method-ht)])
(unless (memq m (class/c-methods ctc))
(fail "method ~a not specified in contract" m))))
(for ([m (class/c-inherits ctc)]) (for ([m (class/c-inherits ctc)])
(unless (hash-ref method-ht m #f) (unless (hash-ref method-ht m #f)
(fail "no public method ~a" m))) (fail "no public method ~a" m)))
@ -2957,7 +2962,7 @@
inherits inherit-contracts inherit-fields inherit-field-contracts inherits inherit-contracts inherit-fields inherit-field-contracts
supers super-contracts inners inner-contracts supers super-contracts inners inner-contracts
overrides override-contracts augments augment-contracts overrides override-contracts augments augment-contracts
augrides augride-contracts absents absent-fields) augrides augride-contracts absents absent-fields opaque?)
#:omit-define-syntaxes #:omit-define-syntaxes
#:property prop:contract #:property prop:contract
(build-contract-property (build-contract-property
@ -3155,9 +3160,20 @@
(parse-spec form)) (parse-spec form))
parsed-forms) parsed-forms)
;; check keyword and pass off to -class/c
(define-syntax (class/c stx) (define-syntax (class/c stx)
(define-splicing-syntax-class opaque-keyword
(pattern (~seq #:opaque) #:with opaque? #'#t)
(pattern (~seq) #:with opaque? #'#f))
(syntax-parse stx
[(_ kwd:opaque-keyword form ...)
(syntax/loc stx (-class/c kwd.opaque? form ...))]))
(define-syntax (-class/c stx)
(syntax-case stx () (syntax-case stx ()
[(_ form ...) [(_ opaque? form ...)
(let ([parsed-forms (parse-class/c-specs (syntax->list #'(form ...)) #f)]) (let ([parsed-forms (parse-class/c-specs (syntax->list #'(form ...)) #f)])
(with-syntax ([methods #`(list #,@(reverse (hash-ref parsed-forms 'methods null)))] (with-syntax ([methods #`(list #,@(reverse (hash-ref parsed-forms 'methods null)))]
[method-ctcs #`(list #,@(reverse (hash-ref parsed-forms 'method-contracts null)))] [method-ctcs #`(list #,@(reverse (hash-ref parsed-forms 'method-contracts null)))]
@ -3196,7 +3212,8 @@
overrides override-ctcs overrides override-ctcs
augments augment-ctcs augments augment-ctcs
augrides augride-ctcs augrides augride-ctcs
absents absent-fields)))))])) absents absent-fields
opaque?)))))]))
(define (check-object-contract obj methods fields fail) (define (check-object-contract obj methods fields fail)
(unless (object? obj) (unless (object? obj)