From 1bd29dd7e9aa261f7bf2231a101a6992ab956c6a Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Mon, 15 Mar 2010 06:49:49 +0000 Subject: [PATCH] Okay, we're going to add back init contracts, which I'd somewhat done before. 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 --- collects/scheme/private/class-internal.ss | 24 ++++++++++++++++++++-- collects/tests/mzscheme/contract-test.ss | 25 +++++++++++++++++++++++ 2 files changed, 47 insertions(+), 2 deletions(-) diff --git a/collects/scheme/private/class-internal.ss b/collects/scheme/private/class-internal.ss index e35ac9b5ce..88d999ebcb 100644 --- a/collects/scheme/private/class-internal.ss +++ b/collects/scheme/private/class-internal.ss @@ -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 diff --git a/collects/tests/mzscheme/contract-test.ss b/collects/tests/mzscheme/contract-test.ss index 384b1e8bac..e39ee9aab6 100644 --- a/collects/tests/mzscheme/contract-test.ss +++ b/collects/tests/mzscheme/contract-test.ss @@ -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