From 1bd29dd7e9aa261f7bf2231a101a6992ab956c6a Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Mon, 15 Mar 2010 06:49:49 +0000 Subject: [PATCH 01/10] 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 From 9640ea4e2ce9e57bbde4b7723f2d17edb0ef75c4 Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Mon, 15 Mar 2010 07:03:54 +0000 Subject: [PATCH 02/10] Sort the init contract forms. svn: r18535 --- collects/scheme/private/class-internal.ss | 72 +++++++++++++---------- 1 file changed, 40 insertions(+), 32 deletions(-) diff --git a/collects/scheme/private/class-internal.ss b/collects/scheme/private/class-internal.ss index 88d999ebcb..4fe4b9145b 100644 --- a/collects/scheme/private/class-internal.ss +++ b/collects/scheme/private/class-internal.ss @@ -2632,6 +2632,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 @@ -2672,7 +2673,7 @@ (class-init-args cls) (class-init-mode cls) - (class-init cls) + init (class-orig-cls cls) #f #f ; serializer is never set @@ -3032,37 +3033,44 @@ (syntax-case stx () [(_ form ...) (let ([parsed-forms (parse-class/c-specs (syntax->list #'(form ...)) #f)]) - (with-syntax ([methods #`(list #,@(reverse (hash-ref parsed-forms 'methods null)))] - [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)))] - [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)))] - [inner-ctcs #`(list #,@(reverse (hash-ref parsed-forms 'inner-contracts null)))] - [overrides #`(list #,@(reverse (hash-ref parsed-forms 'overrides null)))] - [override-ctcs #`(list #,@(reverse (hash-ref parsed-forms 'override-contracts null)))] - [augments #`(list #,@(reverse (hash-ref parsed-forms 'augments null)))] - [augment-ctcs #`(list #,@(reverse (hash-ref parsed-forms 'augment-contracts null)))] - [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 - inits init-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 (reverse (hash-ref parsed-forms 'inits null))] + [init-contracts (reverse (hash-ref parsed-forms 'init-contracts null))] + [paired (map cons inits init-contracts)] + [sorted-inits (sort paired + (lambda (s1 s2) + (stringstring s1) (symbol->string s2))) + #:key car)]) + (with-syntax ([methods #`(list #,@(reverse (hash-ref parsed-forms 'methods null)))] + [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 #,@(map car sorted-inits))] + [init-ctcs #`(list #,@(map cdr sorted-inits))] + [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)))] + [inner-ctcs #`(list #,@(reverse (hash-ref parsed-forms 'inner-contracts null)))] + [overrides #`(list #,@(reverse (hash-ref parsed-forms 'overrides null)))] + [override-ctcs #`(list #,@(reverse (hash-ref parsed-forms 'override-contracts null)))] + [augments #`(list #,@(reverse (hash-ref parsed-forms 'augments null)))] + [augment-ctcs #`(list #,@(reverse (hash-ref parsed-forms 'augment-contracts null)))] + [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 + inits init-ctcs + 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 From 2f9717ca72a1801918199ff52749db2b92484d44 Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Mon, 15 Mar 2010 07:05:31 +0000 Subject: [PATCH 03/10] Start on the init function. First step -- just replace it if we have init contracts, but don't add any checking (yet). svn: r18536 --- collects/scheme/private/class-internal.ss | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/collects/scheme/private/class-internal.ss b/collects/scheme/private/class-internal.ss index 4fe4b9145b..f287d4426b 100644 --- a/collects/scheme/private/class-internal.ss +++ b/collects/scheme/private/class-internal.ss @@ -2860,6 +2860,12 @@ (vector-set! int-vec new-idx (make-method (p (vector-ref int-vec new-idx)) m))))))) + (unless (null? (class/c-inits ctc)) + (set-class-init! + c + (lambda (the-obj super-go si_c si_inited? si_leftovers init-args) + (init the-obj super-go si_c si_inited? si_leftovers init-args)))) + c)))) (define-struct class/c From f9e404afbc532987328e799f175562c559d94468 Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Mon, 15 Mar 2010 07:25:54 +0000 Subject: [PATCH 04/10] * Fix bug in #:name for init contracts * Apply appropriate projections to init arguments. svn: r18537 --- collects/scheme/private/class-internal.ss | 52 ++++++++++++++++++++--- 1 file changed, 47 insertions(+), 5 deletions(-) diff --git a/collects/scheme/private/class-internal.ss b/collects/scheme/private/class-internal.ss index f287d4426b..638d34418a 100644 --- a/collects/scheme/private/class-internal.ss +++ b/collects/scheme/private/class-internal.ss @@ -2861,10 +2861,52 @@ (make-method (p (vector-ref int-vec new-idx)) m))))))) (unless (null? (class/c-inits ctc)) - (set-class-init! - c - (lambda (the-obj super-go si_c si_inited? si_leftovers init-args) - (init the-obj super-go si_c si_inited? si_leftovers init-args)))) + (let () + (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)])))) + (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 (map cons (class/c-inits ctc) (class/c-init-contracts ctc))] + [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)))))]) + (init the-obj super-go si_c si_inited? si_leftovers init-args)))))) c)))) @@ -2902,7 +2944,7 @@ 'class/c (append handled-methods - (handle-optional 'init (class/c-inits ctc) (class/c-field-contracts ctc)) + (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)) From 7ec061cdbf0327a857cb52b24745c7a5977b2cc9 Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Mon, 15 Mar 2010 07:37:25 +0000 Subject: [PATCH 05/10] * Factor out zipping of inits/contracts of the init closure * Add tests for higher-order behavior svn: r18538 --- collects/scheme/private/class-internal.ss | 6 ++-- collects/tests/mzscheme/contract-test.ss | 43 +++++++++++++++++++++++ 2 files changed, 46 insertions(+), 3 deletions(-) diff --git a/collects/scheme/private/class-internal.ss b/collects/scheme/private/class-internal.ss index 638d34418a..6fd91108d9 100644 --- a/collects/scheme/private/class-internal.ss +++ b/collects/scheme/private/class-internal.ss @@ -2862,6 +2862,7 @@ (unless (null? (class/c-inits ctc)) (let () + (define inits+contracts (map cons (class/c-inits ctc) (class/c-init-contracts ctc))) (define (grab-same-inits lst) (if (null? lst) (values null null) @@ -2889,8 +2890,7 @@ (blame-swap blame))]) (loop (cdr init-args) (cdr inits/c) - (cons (cons (car init-arg) - (p (cdr init-arg))) + (cons (cons (car init-arg) (p (cdr init-arg))) handled-args)))] [else (loop (cdr init-args) inits/c @@ -2899,7 +2899,7 @@ c (lambda (the-obj super-go si_c si_inited? si_leftovers init-args) (let ([init-args - (let loop ([inits/c (map cons (class/c-inits ctc) (class/c-init-contracts ctc))] + (let loop ([inits/c inits+contracts] [handled-args init-args]) (if (null? inits/c) handled-args diff --git a/collects/tests/mzscheme/contract-test.ss b/collects/tests/mzscheme/contract-test.ss index e39ee9aab6..401b4b43e0 100644 --- a/collects/tests/mzscheme/contract-test.ss +++ b/collects/tests/mzscheme/contract-test.ss @@ -4650,6 +4650,49 @@ '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 a% (super-new) (init a)) + 'pos + 'neg)]) + (new c% [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 a% (super-new) (init a)) + 'pos + 'neg)]) + (new c% [a 3] [a 4]))) + + (test/spec-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 a% (super-new) (init a)) + 'pos + 'neg)]) + (new c% [a "bar"] [a "foo"]))) (test/spec-passed 'class/c-higher-order-method-1 From 924842d9e9ee96ec33cfbfb674fe7aeea8be06bd Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Mon, 15 Mar 2010 08:29:22 +0000 Subject: [PATCH 06/10] * Fix inits so that we either call the previous class/c wrapper's init or let continue-make-super take control if we were the first wrapper * Fix up handling of init/contract sorting so that things are performed at the right phase (at least if we're going to treat names as symbols). * Fix up new tests so that all contract layers are tested. svn: r18540 --- collects/scheme/private/class-internal.ss | 177 ++++++++++++---------- collects/tests/mzscheme/contract-test.ss | 62 +++++--- 2 files changed, 137 insertions(+), 102 deletions(-) diff --git a/collects/scheme/private/class-internal.ss b/collects/scheme/private/class-internal.ss index 6fd91108d9..59c3f988d2 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)] @@ -2671,9 +2673,10 @@ 'struct:object 'object? 'make-object 'field-ref 'field-set! - (class-init-args cls) - (class-init-mode cls) - init + ;; class/c introduced subclasses do not consume init args + null + 'normal + #f (class-orig-cls cls) #f #f ; serializer is never set @@ -2859,54 +2862,65 @@ [int-vec (vector-ref int-methods i)]) (vector-set! int-vec new-idx (make-method (p (vector-ref int-vec new-idx)) m))))))) - - (unless (null? (class/c-inits ctc)) - (let () - (define inits+contracts (map cons (class/c-inits ctc) (class/c-init-contracts ctc))) - (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)])))) - (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)))))]) - (init the-obj super-go si_c si_inited? si_leftovers init-args)))))) + + ;; 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)))) @@ -3081,37 +3095,34 @@ (syntax-case stx () [(_ form ...) (let ([parsed-forms (parse-class/c-specs (syntax->list #'(form ...)) #f)]) - (let* ([inits (reverse (hash-ref parsed-forms 'inits null))] - [init-contracts (reverse (hash-ref parsed-forms 'init-contracts null))] - [paired (map cons inits init-contracts)] - [sorted-inits (sort paired - (lambda (s1 s2) - (stringstring s1) (symbol->string s2))) - #:key car)]) - (with-syntax ([methods #`(list #,@(reverse (hash-ref parsed-forms 'methods null)))] - [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 #,@(map car sorted-inits))] - [init-ctcs #`(list #,@(map cdr sorted-inits))] - [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)))] - [inner-ctcs #`(list #,@(reverse (hash-ref parsed-forms 'inner-contracts null)))] - [overrides #`(list #,@(reverse (hash-ref parsed-forms 'overrides null)))] - [override-ctcs #`(list #,@(reverse (hash-ref parsed-forms 'override-contracts null)))] - [augments #`(list #,@(reverse (hash-ref parsed-forms 'augments null)))] - [augment-ctcs #`(list #,@(reverse (hash-ref parsed-forms 'augment-contracts null)))] - [augrides #`(list #,@(reverse (hash-ref parsed-forms 'augrides null)))] - [augride-ctcs #`(list #,@(reverse (hash-ref parsed-forms 'augride-contracts null)))]) - (syntax/loc stx + (with-syntax ([methods #`(list #,@(reverse (hash-ref parsed-forms 'methods null)))] + [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)))] + [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)))] + [inner-ctcs #`(list #,@(reverse (hash-ref parsed-forms 'inner-contracts null)))] + [overrides #`(list #,@(reverse (hash-ref parsed-forms 'overrides null)))] + [override-ctcs #`(list #,@(reverse (hash-ref parsed-forms 'override-contracts null)))] + [augments #`(list #,@(reverse (hash-ref parsed-forms 'augments null)))] + [augment-ctcs #`(list #,@(reverse (hash-ref parsed-forms 'augment-contracts null)))] + [augrides #`(list #,@(reverse (hash-ref parsed-forms 'augrides null)))] + [augride-ctcs #`(list #,@(reverse (hash-ref parsed-forms 'augride-contracts null)))]) + (syntax/loc stx + (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 - inits init-ctcs + (map car inits+contracts) (map cdr inits+contracts) 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 401b4b43e0..2ee7630835 100644 --- a/collects/tests/mzscheme/contract-test.ss +++ b/collects/tests/mzscheme/contract-test.ss @@ -4669,30 +4669,54 @@ (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 a% (super-new) (init a)) - 'pos - 'neg)]) - (new c% [a 3] [a "foo"]))) + '(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 a% (super-new) (init a)) - 'pos - 'neg)]) - (new c% [a 3] [a 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/spec-blame + (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 a% (super-new) (init a)) - 'pos - 'neg)]) - (new c% [a "bar"] [a "foo"]))) + '(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-method-1 From c7c8f7061ed6fe18001a3cdb8b091f0e017a639d Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Mon, 15 Mar 2010 08:47:09 +0000 Subject: [PATCH 07/10] Add documentation, and also add tests for appropriate init-field behavior. svn: r18541 --- collects/scribblings/reference/class.scrbl | 11 ++++++- collects/tests/mzscheme/contract-test.ss | 36 ++++++++++++++++++++++ 2 files changed, 46 insertions(+), 1 deletion(-) diff --git a/collects/scribblings/reference/class.scrbl b/collects/scribblings/reference/class.scrbl index 93215880ee..36f85ee5dc 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 ...) @@ -1525,6 +1527,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 2ee7630835..6f81cc76de 100644 --- a/collects/tests/mzscheme/contract-test.ss +++ b/collects/tests/mzscheme/contract-test.ss @@ -4717,6 +4717,42 @@ [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 From 5a488ae7cbf9f973cf89169f5557c12e355a3f39 Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Mon, 15 Mar 2010 08:57:41 +0000 Subject: [PATCH 08/10] Add handling of by-name inits to commented-out class/c use in typed-scheme. Also, fix class/c section of reference slightly by mentioning the role of external contracts in class instantiation. svn: r18542 --- collects/scribblings/reference/class.scrbl | 9 +++++---- collects/typed-scheme/private/type-contract.ss | 10 ++++++---- 2 files changed, 11 insertions(+), 8 deletions(-) diff --git a/collects/scribblings/reference/class.scrbl b/collects/scribblings/reference/class.scrbl index 36f85ee5dc..42a494c3a0 100644 --- a/collects/scribblings/reference/class.scrbl +++ b/collects/scribblings/reference/class.scrbl @@ -1503,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 diff --git a/collects/typed-scheme/private/type-contract.ss b/collects/typed-scheme/private/type-contract.ss index 081fbd5fec..f7566cb4f3 100644 --- a/collects/typed-scheme/private/type-contract.ss +++ b/collects/typed-scheme/private/type-contract.ss @@ -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 From bf56a108fe3c3f05976223dd81dbbf5b80baed33 Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Mon, 15 Mar 2010 09:04:10 +0000 Subject: [PATCH 09/10] Need scheme/class's init for use in class/c form. svn: r18543 --- collects/typed-scheme/private/type-contract.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/typed-scheme/private/type-contract.ss b/collects/typed-scheme/private/type-contract.ss index f7566cb4f3..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) From 5145638ac5c7ca3dae1daf4b630b1e44d2a903b2 Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Mon, 15 Mar 2010 09:19:50 +0000 Subject: [PATCH 10/10] Since we're handling initialization and the result of this wrapper is a real (sub)class, we need this to be #f. svn: r18544 --- collects/scheme/private/class-internal.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/scheme/private/class-internal.ss b/collects/scheme/private/class-internal.ss index 59c3f988d2..ce2618a2ab 100644 --- a/collects/scheme/private/class-internal.ss +++ b/collects/scheme/private/class-internal.ss @@ -2680,7 +2680,7 @@ (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)])