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

Parsing and first order checks for internal field access contracts.

Browse Source 
svn: r18203
This commit is contained in:
Stevie Strickland 2010-02-20 04:02:59 +00:00
parent d87794a8d2
commit fcee6788d7
2 changed files with 35 additions and 4 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

25
collects/scheme/private/class-internal.ss
View File

@ -2492,9 +2492,12 @@
(when (eq? flag 'final) (when (eq? flag 'final)
(failed "method ~a is final" i))))) (failed "method ~a is final" i)))))
(let ([field-ht (class-field-ht cls)]) (let ([field-ht (class-field-ht cls)])
(for ([m (class/c-fields ctc)]) (for ([f (class/c-fields ctc)])
(unless (hash-ref field-ht m #f) (unless (hash-ref field-ht f #f)
(failed "no public field ~a" m))))) (failed "no public field ~a" f)))
(for ([f (class/c-inherits ctc)])
(unless (hash-ref field-ht f #f)
(failed "no public field ~a" f)))))
#t)) #t))
(define (class/c-proj ctc) (define (class/c-proj ctc)
@ -2648,6 +2651,7 @@
(define-struct class/c (define-struct class/c
(methods method-contracts fields field-contracts (methods method-contracts fields field-contracts
inherits inherit-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)
#:omit-define-syntaxes #:omit-define-syntaxes
@ -2679,6 +2683,7 @@
(append (append
handled-methods handled-methods
(handle-optional 'field (class/c-fields ctc) (class/c-field-contracts ctc)) (handle-optional 'field (class/c-fields ctc) (class/c-field-contracts ctc))
(handle-optional 'inherit-field (class/c-inherits ctc) (class/c-inherit-contracts ctc))
(handle-optional 'super (class/c-supers ctc) (class/c-super-contracts ctc)) (handle-optional 'super (class/c-supers ctc) (class/c-super-contracts ctc))
(handle-optional 'inner (class/c-inners ctc) (class/c-inner-contracts ctc)) (handle-optional 'inner (class/c-inners ctc) (class/c-inner-contracts ctc))
(handle-optional 'override (class/c-overrides ctc) (class/c-override-contracts ctc)) (handle-optional 'override (class/c-overrides ctc) (class/c-override-contracts ctc))
@ -2709,13 +2714,22 @@
(let-values ([(name ctc) (parse-name-ctc stx)]) (let-values ([(name ctc) (parse-name-ctc stx)])
(values (cons name names) (cons ctc ctcs))))) (values (cons name names) (cons ctc ctcs)))))
(define (parse-spec stx) (define (parse-spec stx)
(syntax-case stx (field init super inner override augment) (syntax-case stx (field inherit-field init super inner override augment)
[(field f-spec ...) [(field f-spec ...)
(let-values ([(names ctcs) (parse-names-ctcs #'(f-spec ...))]) (let-values ([(names ctcs) (parse-names-ctcs #'(f-spec ...))])
(hash-set! parsed-forms 'fields (hash-set! parsed-forms 'fields
(append names (hash-ref parsed-forms 'fields null))) (append names (hash-ref parsed-forms 'fields null)))
(hash-set! parsed-forms 'field-contracts (hash-set! parsed-forms 'field-contracts
(append ctcs (hash-ref parsed-forms 'field-contracts null))))] (append ctcs (hash-ref parsed-forms 'field-contracts null))))]
[(inherit-field f-spec ...)
(begin
(when object/c?
(raise-syntax-error 'object/c "inherit-field contract not allowed in object/c" stx))
(let-values ([(names ctcs) (parse-names-ctcs #'(f-spec ...))])
(hash-set! parsed-forms 'inherits
(append names (hash-ref parsed-forms 'inherits null)))
(hash-set! parsed-forms 'inherit-contracts
(append ctcs (hash-ref parsed-forms 'inherit-contracts null)))))]
[(super s-spec ...) [(super s-spec ...)
(begin (begin
(when object/c? (when object/c?
@ -2772,6 +2786,8 @@
[method-ctcs #`(list #,@(reverse (hash-ref parsed-forms 'method-contracts null)))] [method-ctcs #`(list #,@(reverse (hash-ref parsed-forms 'method-contracts null)))]
[fields #`(list #,@(reverse (hash-ref parsed-forms 'fields null)))] [fields #`(list #,@(reverse (hash-ref parsed-forms 'fields null)))]
[field-ctcs #`(list #,@(reverse (hash-ref parsed-forms 'field-contracts null)))] [field-ctcs #`(list #,@(reverse (hash-ref parsed-forms 'field-contracts null)))]
[inherits #`(list #,@(reverse (hash-ref parsed-forms 'inherits null)))]
[inherit-ctcs #`(list #,@(reverse (hash-ref parsed-forms 'inherit-contracts null)))]
[supers #`(list #,@(reverse (hash-ref parsed-forms 'supers null)))] [supers #`(list #,@(reverse (hash-ref parsed-forms 'supers null)))]
[super-ctcs #`(list #,@(reverse (hash-ref parsed-forms 'super-contracts null)))] [super-ctcs #`(list #,@(reverse (hash-ref parsed-forms 'super-contracts null)))]
[inners #`(list #,@(reverse (hash-ref parsed-forms 'inners null)))] [inners #`(list #,@(reverse (hash-ref parsed-forms 'inners null)))]
@ -2783,6 +2799,7 @@
(syntax/loc stx (syntax/loc stx
(make-class/c methods method-ctcs (make-class/c methods method-ctcs
fields field-ctcs fields field-ctcs
inherits inherit-ctcs
supers super-ctcs supers super-ctcs
inners inner-ctcs inners inner-ctcs
overrides override-ctcs overrides override-ctcs

14
collects/tests/mzscheme/contract-test.ss
View File

@ -4115,6 +4115,20 @@
(class object% (super-new) (field [n 3])) (class object% (super-new) (field [n 3]))
'pos 'pos
'neg)) 'neg))
(test/pos-blame
'class/c-first-order-inherit-field-1
'(contract (class/c (inherit-field [n number?]))
object%
'pos
'neg))
(test/spec-passed
'class/c-first-order-inherit-field-2
'(contract (class/c (inherit-field [n number?]))
(class object% (super-new) (field [n 3]))
'pos
'neg))
(test/pos-blame (test/pos-blame
'class/c-first-order-super-1 'class/c-first-order-super-1