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

Start inherit contracts (which are useful for mixins). Tests, plus parsing.

Browse Source 
svn: r18232
This commit is contained in:
Stevie Strickland 2010-02-20 21:28:20 +00:00
parent 6ae1a713df
commit a4d6252d16
2 changed files with 95 additions and 17 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -2560,7 +2560,7 @@
(for ([f (class/c-fields ctc)])
(unless (hash-ref field-ht f #f)
(failed "no public field ~a" f)))
(for ([f (class/c-inherits ctc)])
(for ([f (class/c-inherit-fields ctc)])
(unless (hash-ref field-ht f #f)
(failed "no public field ~a" f)))))
#t))
@ -2719,12 +2719,12 @@
(old-set o ((pre-p bset) v)))))))))
;; Handle internal field contracts
(unless (null? (class/c-inherits ctc))
(unless (null? (class/c-inherit-fields ctc))
(vector-copy! int-field-refs 0 (class-int-field-refs cls))
(vector-copy! int-field-sets 0 (class-int-field-sets cls))
(let ([bset (blame-swap blame)])
(for ([f (in-list (class/c-inherits ctc))]
[c (in-list (class/c-inherit-contracts ctc))])
(for ([f (in-list (class/c-inherit-fields ctc))]
[c (in-list (class/c-inherit-field-contracts ctc))])
(when c
(let* ([i (hash-ref field-ht f)]
[pre-p (contract-projection c)]
@ -2776,7 +2776,7 @@
(define-struct class/c
(methods method-contracts fields field-contracts
inherits inherit-contracts
inherits inherit-contracts inherit-fields inherit-field-contracts
supers super-contracts inners inner-contracts
overrides override-contracts augments augment-contracts)
#:omit-define-syntaxes
@ -2808,7 +2808,8 @@
(append
handled-methods
(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 'inherit (class/c-inherits ctc) (class/c-inherit-contracts ctc))
(handle-optional 'inherit-field (class/c-inherit-fields ctc) (class/c-inherit-field-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 'override (class/c-overrides ctc) (class/c-override-contracts ctc))
@ -2839,22 +2840,31 @@
(let-values ([(name ctc) (parse-name-ctc stx)])
(values (cons name names) (cons ctc ctcs)))))
(define (parse-spec stx)
(syntax-case stx (field inherit-field init super inner override augment)
(syntax-case stx (field inherit inherit-field init super inner override augment)
[(field f-spec ...)
(let-values ([(names ctcs) (parse-names-ctcs #'(f-spec ...))])
(hash-set! parsed-forms 'fields
(append names (hash-ref parsed-forms 'fields null)))
(hash-set! parsed-forms 'field-contracts
(append ctcs (hash-ref parsed-forms 'field-contracts null))))]
[(inherit m-spec ...)
(begin
(when object/c?
(raise-syntax-error 'object/c "inherit contract not allowed in object/c" stx))
(let-values ([(names ctcs) (parse-names-ctcs #'(m-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)))))]
[(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)))))]
(hash-set! parsed-forms 'inherit-fields
(append names (hash-ref parsed-forms 'inherit-fields null)))
(hash-set! parsed-forms 'inherit-field-contracts
(append ctcs (hash-ref parsed-forms 'inherit-field-contracts null)))))]
[(super s-spec ...)
(begin
(when object/c?
@ -2913,6 +2923,8 @@
[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)))]
[inherit-fields #`(list #,@(reverse (hash-ref parsed-forms 'inherit-fields null)))]
[inherit-field-ctcs #`(list #,@(reverse (hash-ref parsed-forms 'inherit-field-contracts null)))]
[supers #`(list #,@(reverse (hash-ref parsed-forms 'supers null)))]
[super-ctcs #`(list #,@(reverse (hash-ref parsed-forms 'super-contracts null)))]
[inners #`(list #,@(reverse (hash-ref parsed-forms 'inners null)))]
@ -2925,6 +2937,7 @@
(make-class/c methods method-ctcs
fields field-ctcs
inherits inherit-ctcs
inherit-fields inherit-field-ctcs
supers super-ctcs
inners inner-ctcs
overrides override-ctcs

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

@ -4457,6 +4457,33 @@
'pos
'neg)])
(class c% (super-new) (inherit m))))
(test/pos-blame
'class/c-first-order-inherit-1
'(let* ([c% (contract (class/c (inherit [m (-> any/c number? number?)]))
object%
'pos
'neg)]
[d% (class c% (super-new) (inherit m) (define/public (f) (m 5)))])
(send (new d%) f)))
(test/spec-passed
'class/c-first-order-inherit-2
'(let* ([c% (contract (class/c (inherit [m (-> any/c number? number?)]))
(class object% (super-new) (define/public (m x) x))
'pos
'neg)]
[d% (class c% (super-new) (inherit m) (define/public (f) (m 5)))])
(send (new d%) f)))
(test/pos-blame
'class/c-first-order-inherit-3
'(let* ([c% (contract (class/c (inherit [m (-> any/c number? number?)]))
(class object% (super-new) (define/public (m) 3))
'pos
'neg)]
[d% (class c% (super-new) (inherit m) (define/public (f) (m 5)))])
(send (new d%) f)))
(test/spec-passed
'class/c-higher-order-method-1
@ -4486,7 +4513,7 @@
;; Public method contracts do not check behavioral subtyping.
;; Once interfaces have contracts, those will.
(test/spec-passed
'class/c-higher-order-method-3
'class/c-higher-order-method-4
'(let* ([c% (contract (class/c [m (-> any/c number? number?)])
(class object% (super-new) (define/public (m x) (zero? x)))
'pos
@ -4701,7 +4728,7 @@
(get-field f (new c%))))
(test/spec-passed/result
'class/c-higher-order-inherit-1
'class/c-higher-order-inherit-field-1
'(let* ([c% (contract (class/c (inherit-field [f number?]))
(class object% (super-new) (field [f 10]))
'pos
@ -4713,7 +4740,7 @@
10)
(test/spec-passed/result
'class/c-higher-order-inherit-2
'class/c-higher-order-inherit-field-2
'(let* ([c% (contract (class/c (inherit-field [f number?]))
(class object% (super-new) (field [f 10]))
'pos
@ -4727,7 +4754,7 @@
12)
(test/pos-blame
'class/c-higher-order-inherit-3
'class/c-higher-order-inherit-field-3
'(let* ([c% (contract (class/c (inherit-field [f number?]))
(class object% (super-new) (field [f #f]))
'pos
@ -4738,7 +4765,7 @@
(send (new d%) m)))
(test/neg-blame
'class/c-higher-order-inherit-4
'class/c-higher-order-inherit-field-4
'(let* ([c% (contract (class/c (inherit-field [f number?]))
(class object% (super-new) (field [f 10]))
'pos
@ -4749,7 +4776,7 @@
(send (new d%) m)))
(test/spec-passed
'class/c-higher-order-inherit-5
'class/c-higher-order-inherit-field-5
'(let* ([c% (contract (class/c (inherit-field f))
(class object% (super-new) (field [f 10]))
'pos
@ -4918,6 +4945,44 @@
[e% (class d% (super-new) (inherit m) (define/public (g x) (m x)))])
(send (new e%) f 3.5)))
(test/spec-passed
'class/c-higher-order-inherit-1
'(let* ([c% (contract (class/c (inherit [m (-> any/c number? number?)]))
(class object% (super-new) (define/public (m x) x))
'pos
'neg)]
[d% (class c% (super-new) (inherit m) (define/public (f) (m 5)))])
(send (new d%) f)))
(test/neg-blame
'class/c-higher-order-inherit-2
'(let* ([c% (contract (class/c (inherit [m (-> any/c number? number?)]))
(class object% (super-new) (define/public (m x) x))
'pos
'neg)]
[d% (class c% (super-new) (inherit m) (define/public (f) (m #f)))])
(send (new d%) f)))
(test/pos-blame
'class/c-higher-order-inherit-3
'(let* ([c% (contract (class/c (inherit [m (-> any/c number? number?)]))
(class object% (super-new) (define/public (m x) (zero? x)))
'pos
'neg)]
[d% (class c% (super-new) (inherit m) (define/public (f) (m 5)))])
(send (new d%) f)))
;; Should not be checked if overridden (i.e. target of dyn disp changes).
(test/spec-passed
'class/c-higher-order-inherit-4
'(let* ([c% (contract (class/c (inherit [m (-> any/c number? number?)]))
(class object% (super-new) (define/public (m x) (zero? x)))
'pos
'neg)]
[d% (class c% (super-new) (inherit m) (define/public (f) (m 5)))]
[e% (class d% (super-new) (define/override (m x) x))])
(send (new d%) f)))
;
;
; ;; ;; ; ;;