diff --git a/collects/scheme/private/class-internal.ss b/collects/scheme/private/class-internal.ss index e35ac9b5ce..ce2618a2ab 100644 --- a/collects/scheme/private/class-internal.ss +++ b/collects/scheme/private/class-internal.ss @@ -2581,11 +2581,13 @@ (λ (cls) (class/c-check-first-order ctc cls blame) (let* ([name (class-name cls)] + [never-wrapped? (eq? (class-orig-cls cls) cls)] ;; Only add a new slot if we're not projecting an already contracted class. - [supers (if (eq? (class-orig-cls cls) cls) - (list->vector (append (vector->list (class-supers cls)) (list #f))) + [supers (if never-wrapped? + (list->vector (append (vector->list (class-supers cls)) + (list #f))) (list->vector (vector->list (class-supers cls))))] - [pos (if (eq? (class-orig-cls cls) cls) + [pos (if never-wrapped? (add1 (class-pos cls)) (class-pos cls))] [method-width (class-method-width cls)] @@ -2632,6 +2634,7 @@ [ext-field-sets (if (null? (class/c-fields ctc)) (class-ext-field-sets cls) (make-vector field-pub-width))] + [init (class-init cls)] [class-make (if name (make-naming-constructor struct:class @@ -2670,13 +2673,14 @@ 'struct:object 'object? 'make-object 'field-ref 'field-set! - (class-init-args cls) - (class-init-mode cls) - (class-init cls) + ;; class/c introduced subclasses do not consume init args + null + 'normal + #f (class-orig-cls cls) #f #f ; serializer is never set - (class-no-super-init? cls))] + #f)] [obj-name (if name (string->symbol (format "object:~a" name)) 'object)]) @@ -2858,11 +2862,70 @@ [int-vec (vector-ref int-methods i)]) (vector-set! int-vec new-idx (make-method (p (vector-ref int-vec new-idx)) m))))))) + + ;; Unlike the others, we always want to do this, even if there are no init contracts, + ;; since we still need to handle either calling the previous class/c's init or + ;; calling continue-make-super appropriately. + (let () + ;; zip the inits and contracts together for ordered selection + (define inits+contracts (map cons (class/c-inits ctc) (class/c-init-contracts ctc))) + ;; grab all the inits+contracts that involve the same init arg + ;; (assumes that inits and contracts were sorted in class/c creation) + (define (grab-same-inits lst) + (if (null? lst) + (values null null) + (let loop ([inits/c (cdr lst)] + [prefix (list (car lst))]) + (cond + [(null? inits/c) + (values (reverse prefix) inits/c)] + [(eq? (car (car inits/c)) (car (car prefix))) + (loop (cdr inits/c) + (cons (car inits/c) prefix))] + [else (values (reverse prefix) inits/c)])))) + ;; run through the list of init-args and apply contracts for same-named + ;; init args + (define (apply-contracts inits/c init-args) + (let loop ([init-args init-args] + [inits/c inits/c] + [handled-args null]) + (cond + [(null? init-args) + (reverse handled-args)] + [(null? inits/c) + (append (reverse handled-args) init-args)] + [(eq? (car (car inits/c)) (car (car init-args))) + (let ([init-arg (car init-args)] + [p ((contract-projection (cdr (car inits/c))) + (blame-swap blame))]) + (loop (cdr init-args) + (cdr inits/c) + (cons (cons (car init-arg) (p (cdr init-arg))) + handled-args)))] + [else (loop (cdr init-args) + inits/c + (cons (car init-args) handled-args))]))) + (set-class-init! + c + (lambda (the-obj super-go si_c si_inited? si_leftovers init-args) + (let ([init-args + (let loop ([inits/c inits+contracts] + [handled-args init-args]) + (if (null? inits/c) + handled-args + (let-values ([(prefix suffix) (grab-same-inits inits/c)]) + (loop suffix + (apply-contracts prefix init-args)))))]) + ;; Since we never consume init args, we can ignore si_leftovers + ;; since init-args is the same. + (if never-wrapped? + (super-go the-obj si_c si_inited? init-args null null) + (init the-obj super-go si_c si_inited? init-args init-args)))))) 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 +2958,7 @@ 'class/c (append handled-methods + (handle-optional 'init (class/c-inits ctc) (class/c-init-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 +2993,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 +3099,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)))] + [(i ...) (reverse (hash-ref parsed-forms 'inits null))] + [(i-c ...) (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)))] @@ -3034,15 +3116,20 @@ [augrides #`(list #,@(reverse (hash-ref parsed-forms 'augrides null)))] [augride-ctcs #`(list #,@(reverse (hash-ref parsed-forms 'augride-contracts null)))]) (syntax/loc stx - (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 - augments augment-ctcs - augrides augride-ctcs))))])) + (let* ([inits+contracts (sort (list (cons i i-c) ...) + (lambda (s1 s2) + (stringstring s1) (symbol->string s2))) + #:key car)]) + (make-class/c methods method-ctcs + fields field-ctcs + (map car inits+contracts) (map cdr inits+contracts) + inherits inherit-ctcs + inherit-fields inherit-field-ctcs + supers super-ctcs + inners inner-ctcs + overrides override-ctcs + augments augment-ctcs + augrides augride-ctcs)))))])) (define (check-object-contract obj blame methods fields) (let/ec return diff --git a/collects/scribblings/reference/class.scrbl b/collects/scribblings/reference/class.scrbl index 93215880ee..42a494c3a0 100644 --- a/collects/scribblings/reference/class.scrbl +++ b/collects/scribblings/reference/class.scrbl @@ -1476,13 +1476,15 @@ resulting trait is the same as for @scheme[trait-sum], otherwise the @section{Object and Class Contracts} @defform/subs[ -#:literals (field inherit inherit-field super inner override augment augride) +#:literals (field init init-field inherit inherit-field super inner override augment augride) (class/c member-spec ...) ([member-spec method-spec (field field-spec ...) + (init field-spec ...) + (init-field field-spec ...) (inherit method-spec ...) (inherit-field field-spec ...) (super method-spec ...) @@ -1501,10 +1503,11 @@ Produces a contract for a class. There are two major categories of contracts listed in a @scheme[class/c] form: external and internal contracts. External contracts govern behavior -when methods or fields are accessed via an object of that class. Internal -contracts govern behavior when method or fields are accessed within the -class hierarchy. This separation allows for stronger contracts for class -clients and weaker contracts for subclasses. +when an object is instantiated from a class or when methods or fields are +accessed via an object of that class. Internal contracts govern behavior +when method or fields are accessed within the class hierarchy. This +separation allows for stronger contracts for class clients and weaker +contracts for subclasses. Method contracts must contain an additional initial argument which corresponds to the implicit @scheme[this] parameter of the method. This allows for @@ -1525,6 +1528,13 @@ The external contracts are as follows: value contained in that field when accessed via an object of that class. Since fields may be mutated, these contracts are checked on any external access and/or mutation of the field.} + @item{An initialization argument contract, tagged with @scheme[init], describes the + expected behavior of the value paired with that name during class instantiation. + The same name can be provided more than once, in which case the first such contract + in the @scheme[class/c] form is applied to the first value tagged with that name in + the list of initialization arguments, and so on.} + @item{The contracts listed in an @scheme[init-field] section are treated as if each + contract appeared in an @scheme[init] section and a @scheme[field] section.} ] The internal contracts are as follows: diff --git a/collects/tests/mzscheme/contract-test.ss b/collects/tests/mzscheme/contract-test.ss index 384b1e8bac..6f81cc76de 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 @@ -4625,6 +4650,109 @@ 'neg)] [d% (class c% (super-new) (inherit m) (define/public (f) (m 5)))]) (send (new d%) f))) + + (test/spec-passed + 'class/c-higher-order-init-1 + '(let ([c% (contract (class/c (init [a number?])) + (class object% (super-new) (init a)) + 'pos + 'neg)]) + (new c% [a 3]))) + + (test/neg-blame + 'class/c-higher-order-init-2 + '(let ([c% (contract (class/c (init [a number?])) + (class object% (super-new) (init a)) + 'pos + 'neg)]) + (new c% [a #t]))) + + (test/spec-passed + 'class/c-higher-order-init-3 + '(let* ([c% (class object% (super-new) (init a))] + [d% (contract (class/c (init [a number?] [a string?])) + (class c% (super-new) (init a)) + 'pos + 'neg)]) + (new d% [a 3] [a "foo"]))) + + (test/neg-blame + 'class/c-higher-order-init-4 + '(let* ([c% (class object% (super-new) (init a))] + [d% (contract (class/c (init [a number?] [a string?])) + (class c% (super-new) (init a)) + 'pos + 'neg)]) + (new d% [a 3] [a 4]))) + + (test/neg-blame + 'class/c-higher-order-init-5 + '(let* ([c% (class object% (super-new) (init a))] + [d% (contract (class/c (init [a number?] [a string?])) + (class c% (super-new) (init a)) + 'pos + 'neg)]) + (new d% [a "bar"] [a "foo"]))) + + (test/spec-passed + 'class/c-higher-order-init-6 + '(let* ([c% (class object% (super-new) (init a))] + [d% (class c% (super-new) (init a))] + [d%/c (contract (class/c (init [a integer?] [a string?])) d% 'pos 'neg1)] + [d%/c/c (contract (class/c (init [a number?])) d%/c 'pos1 'neg)]) + (new d%/c/c [a 3] [a "foo"]))) + + (test/neg-blame + 'class/c-higher-order-init-7 + '(let* ([c% (class object% (super-new) (init a))] + [d% (class c% (super-new) (init a))] + [d%/c (contract (class/c (init [a integer?] [a string?])) d% 'pos1 'neg)] + [d%/c/c (contract (class/c (init [a number?])) d%/c 'pos 'neg1)]) + (new d%/c/c [a 3.5] [a "foo"]))) + + (test/neg-blame + 'class/c-higher-order-init-8 + '(let* ([c% (class object% (super-new) (init a))] + [d% (class c% (super-new) (init a))] + [d%/c (contract (class/c (init [a integer?] [a string?])) d% 'pos 'neg)] + [d%/c/c (contract (class/c (init [a number?])) d%/c 'pos 'neg)]) + (new d%/c/c [a #t] [a "foo"]))) + + (test/spec-passed + 'class/c-higher-order-init-field-1 + '(let ([c% (contract (class/c (init-field [f (-> number? number?)])) + (class object% (super-new) (init-field f) (f 3)) + 'pos + 'neg)]) + (new c% [f (lambda (x) x)]))) + + (test/pos-blame + 'class/c-higher-order-init-field-2 + '(let ([c% (contract (class/c (init-field [f (-> number? number?)])) + (class object% (super-new) (init-field f) (f #t)) + 'pos + 'neg)]) + (new c% [f (lambda (x) x)]))) + + (test/neg-blame + 'class/c-higher-order-init-field-3 + '(let ([c% (contract (class/c (init-field [f (-> number? number?)])) + (class object% (super-new) (init-field f) (f 3)) + 'pos + 'neg)]) + (new c% [f (lambda (x) (zero? x))]))) + + ;; Make sure that the original provider of the value is blamed if an + ;; init arg is given an invalid value, and then that is retrieved by + ;; an external client. + (test/neg-blame + 'class/c-higher-order-init-field-4 + '(let* ([c% (contract (class/c (init-field [f (-> number? number?)])) + (class object% (super-new) (init-field f)) + 'pos + 'neg)] + [o (new c% [f (lambda (x) (zero? x))])]) + ((get-field f o) 3))) (test/spec-passed 'class/c-higher-order-method-1 diff --git a/collects/typed-scheme/private/type-contract.ss b/collects/typed-scheme/private/type-contract.ss index 081fbd5fec..7cf4c8104c 100644 --- a/collects/typed-scheme/private/type-contract.ss +++ b/collects/typed-scheme/private/type-contract.ss @@ -15,7 +15,7 @@ scheme/match syntax/struct syntax/stx mzlib/trace unstable/syntax scheme/list (only-in scheme/contract -> ->* case-> cons/c flat-rec-contract provide/contract any/c) (for-template scheme/base scheme/contract unstable/poly-c (utils any-wrap) - (only-in scheme/class object% is-a?/c subclass?/c object-contract class/c object/c class?))) + (only-in scheme/class object% is-a?/c subclass?/c object-contract class/c init object/c class?))) (define (define/fixup-contract? stx) (or (syntax-property stx 'typechecker:contract-def) @@ -151,13 +151,15 @@ [(names ...) name]) #'(object/c (names fcn-cnts) ...))] ;; init args not currently handled by class/c - [(Class: _ _ (list (list name fcn) ...)) + [(Class: _ (list (list by-name-init by-name-init-ty _) ...) (list (list name fcn) ...)) (when flat? (exit (fail))) - (with-syntax ([(fcn-cnts ...) (for/list ([f fcn]) (t->c/fun f #:method #t))] - [(names ...) name]) + (with-syntax ([(fcn-cnt ...) (for/list ([f fcn]) (t->c/fun f #:method #t))] + [(name ...) name] + [(by-name-cnt ...) (for/list ([t by-name-init-ty]) (t->c/neg t))] + [(by-name-init ...) by-name-init]) #'class? #; - #'(class/c (names fcn-cnts) ...))] + #'(class/c (name fcn-cnt) ... (init [by-name-init by-name-cnt] ...)))] [(Value: '()) #'null?] [(Struct: nm par flds proc poly? pred? cert acc-ids) (cond