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

Okay, we're going to add back init contracts, which I'd somewhat done before.

Browse Source 
In this version, we're not going to have any reasonable first-order checks as
to whether or not the class actually accepts the initialization arguments that
are being contracted.  I'm also just going to handle by-name at first, since
that's all I originally discussed in the paper.

svn: r18534
This commit is contained in:
Stevie Strickland 2010-03-15 06:49:49 +00:00
parent e0c0645479
commit 1bd29dd7e9
2 changed files with 47 additions and 2 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -2862,7 +2862,7 @@
c))))
(define-struct class/c
(methods method-contracts fields field-contracts
(methods method-contracts fields field-contracts inits init-contracts
inherits inherit-contracts inherit-fields inherit-field-contracts
supers super-contracts inners inner-contracts
overrides override-contracts augments augment-contracts
@ -2895,6 +2895,7 @@
'class/c
(append
handled-methods
(handle-optional 'init (class/c-inits ctc) (class/c-field-contracts ctc))
(handle-optional 'field (class/c-fields ctc) (class/c-field-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))
@ -2929,13 +2930,29 @@
(let-values ([(name ctc) (parse-name-ctc stx)])
(values (cons name names) (cons ctc ctcs)))))
(define (parse-spec stx)
(syntax-case stx (field inherit inherit-field init super inner override augment augride)
(syntax-case stx (field inherit inherit-field init init-field super inner override augment augride)
[(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))))]
[(init i-spec ...)
(let-values ([(names ctcs) (parse-names-ctcs #'(i-spec ...))])
(hash-set! parsed-forms 'inits
(append names (hash-ref parsed-forms 'inits null)))
(hash-set! parsed-forms 'init-contracts
(append ctcs (hash-ref parsed-forms 'init-contracts null))))]
[(init-field i-spec ...)
(let-values ([(names ctcs) (parse-names-ctcs #'(i-spec ...))])
(hash-set! parsed-forms 'inits
(append names (hash-ref parsed-forms 'inits null)))
(hash-set! parsed-forms 'init-contracts
(append ctcs (hash-ref parsed-forms 'init-contracts null)))
(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?
@ -3019,6 +3036,8 @@
[method-ctcs #`(list #,@(reverse (hash-ref parsed-forms 'method-contracts null)))]
[fields #`(list #,@(reverse (hash-ref parsed-forms 'fields null)))]
[field-ctcs #`(list #,@(reverse (hash-ref parsed-forms 'field-contracts null)))]
[inits #`(list #,@(reverse (hash-ref parsed-forms 'inits null)))]
[init-ctcs #`(list #,@(reverse (hash-ref parsed-forms 'init-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)))]
@ -3036,6 +3055,7 @@
(syntax/loc stx
(make-class/c methods method-ctcs
fields field-ctcs
inits init-ctcs
inherits inherit-ctcs
inherit-fields inherit-field-ctcs
supers super-ctcs

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

@ -4227,6 +4227,31 @@
(class object% (super-new) (field [n 3]))
'pos
'neg))
;; No true first-order tests here, other than just to make
;; sure they're accepted. For init-field, we can at least
;; make sure the given field is public (which happens
;; naturally by splitting an init-field into init and field).
(test/spec-passed
'class/c-first-order-init-1
'(contract (class/c (init [a number?]))
(class object% (super-new) (init a))
'pos
'neg))
(test/spec-passed
'class/c-first-order-init-field-1
'(contract (class/c (init-field [a number?]))
(class object% (super-new) (init-field a))
'pos
'neg))
(test/pos-blame
'class/c-first-order-init-field-2
'(contract (class/c (init-field [a number?]))
object%
'pos
'neg))
(test/pos-blame
'class/c-first-order-inherit-field-1