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