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

* Fix inits so that we either call the previous class/c wrapper's init

Browse Source 
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
This commit is contained in:
Stevie Strickland 2010-03-15 08:29:22 +00:00
parent 7ec061cdbf
commit 924842d9e9
2 changed files with 137 additions and 102 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -2581,11 +2581,13 @@
(λ (cls) (λ (cls)
(class/c-check-first-order ctc cls blame) (class/c-check-first-order ctc cls blame)
(let* ([name (class-name cls)] (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. ;; Only add a new slot if we're not projecting an already contracted class.
[supers (if (eq? (class-orig-cls cls) cls) [supers (if never-wrapped?
(list->vector (append (vector->list (class-supers cls)) (list #f))) (list->vector (append (vector->list (class-supers cls))
(list #f)))
(list->vector (vector->list (class-supers cls))))] (list->vector (vector->list (class-supers cls))))]
[pos (if (eq? (class-orig-cls cls) cls) [pos (if never-wrapped?
(add1 (class-pos cls)) (add1 (class-pos cls))
(class-pos cls))] (class-pos cls))]
[method-width (class-method-width cls)] [method-width (class-method-width cls)]
@ -2671,9 +2673,10 @@
'struct:object 'object? 'make-object 'struct:object 'object? 'make-object
'field-ref 'field-set! 'field-ref 'field-set!
(class-init-args cls) ;; class/c introduced subclasses do not consume init args
(class-init-mode cls) null
init 'normal
#f
(class-orig-cls cls) (class-orig-cls cls)
#f #f ; serializer is never set #f #f ; serializer is never set
@ -2859,54 +2862,65 @@
[int-vec (vector-ref int-methods i)]) [int-vec (vector-ref int-methods i)])
(vector-set! int-vec new-idx (vector-set! int-vec new-idx
(make-method (p (vector-ref int-vec new-idx)) m))))))) (make-method (p (vector-ref int-vec new-idx)) m)))))))
(unless (null? (class/c-inits ctc)) ;; Unlike the others, we always want to do this, even if there are no init contracts,
(let () ;; since we still need to handle either calling the previous class/c's init or
(define inits+contracts (map cons (class/c-inits ctc) (class/c-init-contracts ctc))) ;; calling continue-make-super appropriately.
(define (grab-same-inits lst) (let ()
(if (null? lst) ;; zip the inits and contracts together for ordered selection
(values null null) (define inits+contracts (map cons (class/c-inits ctc) (class/c-init-contracts ctc)))
(let loop ([inits/c (cdr lst)] ;; grab all the inits+contracts that involve the same init arg
[prefix (list (car lst))]) ;; (assumes that inits and contracts were sorted in class/c creation)
(cond (define (grab-same-inits lst)
[(null? inits/c) (if (null? lst)
(values (reverse prefix) inits/c)] (values null null)
[(eq? (car (car inits/c)) (car (car prefix))) (let loop ([inits/c (cdr lst)]
(loop (cdr inits/c) [prefix (list (car lst))])
(cons (car inits/c) prefix))] (cond
[else (values (reverse prefix) inits/c)])))) [(null? inits/c)
(define (apply-contracts inits/c init-args) (values (reverse prefix) inits/c)]
(let loop ([init-args init-args] [(eq? (car (car inits/c)) (car (car prefix)))
[inits/c inits/c] (loop (cdr inits/c)
[handled-args null]) (cons (car inits/c) prefix))]
(cond [else (values (reverse prefix) inits/c)]))))
[(null? init-args) ;; run through the list of init-args and apply contracts for same-named
(reverse handled-args)] ;; init args
[(null? inits/c) (define (apply-contracts inits/c init-args)
(append (reverse handled-args) init-args)] (let loop ([init-args init-args]
[(eq? (car (car inits/c)) (car (car init-args))) [inits/c inits/c]
(let ([init-arg (car init-args)] [handled-args null])
[p ((contract-projection (cdr (car inits/c))) (cond
(blame-swap blame))]) [(null? init-args)
(loop (cdr init-args) (reverse handled-args)]
(cdr inits/c) [(null? inits/c)
(cons (cons (car init-arg) (p (cdr init-arg))) (append (reverse handled-args) init-args)]
handled-args)))] [(eq? (car (car inits/c)) (car (car init-args)))
[else (loop (cdr init-args) (let ([init-arg (car init-args)]
inits/c [p ((contract-projection (cdr (car inits/c)))
(cons (car init-args) handled-args))]))) (blame-swap blame))])
(set-class-init! (loop (cdr init-args)
c (cdr inits/c)
(lambda (the-obj super-go si_c si_inited? si_leftovers init-args) (cons (cons (car init-arg) (p (cdr init-arg)))
(let ([init-args handled-args)))]
(let loop ([inits/c inits+contracts] [else (loop (cdr init-args)
[handled-args init-args]) inits/c
(if (null? inits/c) (cons (car init-args) handled-args))])))
handled-args (set-class-init!
(let-values ([(prefix suffix) (grab-same-inits inits/c)]) c
(loop suffix (lambda (the-obj super-go si_c si_inited? si_leftovers init-args)
(apply-contracts prefix init-args)))))]) (let ([init-args
(init the-obj super-go si_c si_inited? si_leftovers 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)))) c))))
@ -3081,37 +3095,34 @@
(syntax-case stx () (syntax-case stx ()
[(_ form ...) [(_ form ...)
(let ([parsed-forms (parse-class/c-specs (syntax->list #'(form ...)) #f)]) (let ([parsed-forms (parse-class/c-specs (syntax->list #'(form ...)) #f)])
(let* ([inits (reverse (hash-ref parsed-forms 'inits null))] (with-syntax ([methods #`(list #,@(reverse (hash-ref parsed-forms 'methods null)))]
[init-contracts (reverse (hash-ref parsed-forms 'init-contracts null))] [method-ctcs #`(list #,@(reverse (hash-ref parsed-forms 'method-contracts null)))]
[paired (map cons inits init-contracts)] [fields #`(list #,@(reverse (hash-ref parsed-forms 'fields null)))]
[sorted-inits (sort paired [field-ctcs #`(list #,@(reverse (hash-ref parsed-forms 'field-contracts null)))]
(lambda (s1 s2) [(i ...) (reverse (hash-ref parsed-forms 'inits null))]
(string<? (symbol->string s1) (symbol->string s2))) [(i-c ...) (reverse (hash-ref parsed-forms 'init-contracts null))]
#:key car)]) [inherits #`(list #,@(reverse (hash-ref parsed-forms 'inherits null)))]
(with-syntax ([methods #`(list #,@(reverse (hash-ref parsed-forms 'methods null)))] [inherit-ctcs #`(list #,@(reverse (hash-ref parsed-forms 'inherit-contracts null)))]
[method-ctcs #`(list #,@(reverse (hash-ref parsed-forms 'method-contracts null)))] [inherit-fields #`(list #,@(reverse (hash-ref parsed-forms 'inherit-fields null)))]
[fields #`(list #,@(reverse (hash-ref parsed-forms 'fields null)))] [inherit-field-ctcs #`(list #,@(reverse (hash-ref parsed-forms 'inherit-field-contracts null)))]
[field-ctcs #`(list #,@(reverse (hash-ref parsed-forms 'field-contracts null)))] [supers #`(list #,@(reverse (hash-ref parsed-forms 'supers null)))]
[inits #`(list #,@(map car sorted-inits))] [super-ctcs #`(list #,@(reverse (hash-ref parsed-forms 'super-contracts null)))]
[init-ctcs #`(list #,@(map cdr sorted-inits))] [inners #`(list #,@(reverse (hash-ref parsed-forms 'inners null)))]
[inherits #`(list #,@(reverse (hash-ref parsed-forms 'inherits null)))] [inner-ctcs #`(list #,@(reverse (hash-ref parsed-forms 'inner-contracts null)))]
[inherit-ctcs #`(list #,@(reverse (hash-ref parsed-forms 'inherit-contracts null)))] [overrides #`(list #,@(reverse (hash-ref parsed-forms 'overrides null)))]
[inherit-fields #`(list #,@(reverse (hash-ref parsed-forms 'inherit-fields null)))] [override-ctcs #`(list #,@(reverse (hash-ref parsed-forms 'override-contracts null)))]
[inherit-field-ctcs #`(list #,@(reverse (hash-ref parsed-forms 'inherit-field-contracts null)))] [augments #`(list #,@(reverse (hash-ref parsed-forms 'augments null)))]
[supers #`(list #,@(reverse (hash-ref parsed-forms 'supers null)))] [augment-ctcs #`(list #,@(reverse (hash-ref parsed-forms 'augment-contracts null)))]
[super-ctcs #`(list #,@(reverse (hash-ref parsed-forms 'super-contracts null)))] [augrides #`(list #,@(reverse (hash-ref parsed-forms 'augrides null)))]
[inners #`(list #,@(reverse (hash-ref parsed-forms 'inners null)))] [augride-ctcs #`(list #,@(reverse (hash-ref parsed-forms 'augride-contracts null)))])
[inner-ctcs #`(list #,@(reverse (hash-ref parsed-forms 'inner-contracts null)))] (syntax/loc stx
[overrides #`(list #,@(reverse (hash-ref parsed-forms 'overrides null)))] (let* ([inits+contracts (sort (list (cons i i-c) ...)
[override-ctcs #`(list #,@(reverse (hash-ref parsed-forms 'override-contracts null)))] (lambda (s1 s2)
[augments #`(list #,@(reverse (hash-ref parsed-forms 'augments null)))] (string<? (symbol->string s1) (symbol->string s2)))
[augment-ctcs #`(list #,@(reverse (hash-ref parsed-forms 'augment-contracts null)))] #:key car)])
[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 (make-class/c methods method-ctcs
fields field-ctcs fields field-ctcs
inits init-ctcs (map car inits+contracts) (map cdr inits+contracts)
inherits inherit-ctcs inherits inherit-ctcs
inherit-fields inherit-field-ctcs inherit-fields inherit-field-ctcs
supers super-ctcs supers super-ctcs

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

@ -4669,30 +4669,54 @@
(test/spec-passed (test/spec-passed
'class/c-higher-order-init-3 'class/c-higher-order-init-3
'(let ([c% (class object% (super-new) (init a))] '(let* ([c% (class object% (super-new) (init a))]
[d% (contract (class/c (init [a number?] [a string?])) [d% (contract (class/c (init [a number?] [a string?]))
(class a% (super-new) (init a)) (class c% (super-new) (init a))
'pos 'pos
'neg)]) 'neg)])
(new c% [a 3] [a "foo"]))) (new d% [a 3] [a "foo"])))
(test/neg-blame (test/neg-blame
'class/c-higher-order-init-4 'class/c-higher-order-init-4
'(let ([c% (class object% (super-new) (init a))] '(let* ([c% (class object% (super-new) (init a))]
[d% (contract (class/c (init [a number?] [a string?])) [d% (contract (class/c (init [a number?] [a string?]))
(class a% (super-new) (init a)) (class c% (super-new) (init a))
'pos 'pos
'neg)]) 'neg)])
(new c% [a 3] [a 4]))) (new d% [a 3] [a 4])))
(test/spec-blame (test/neg-blame
'class/c-higher-order-init-5 'class/c-higher-order-init-5
'(let ([c% (class object% (super-new) (init a))] '(let* ([c% (class object% (super-new) (init a))]
[d% (contract (class/c (init [a number?] [a string?])) [d% (contract (class/c (init [a number?] [a string?]))
(class a% (super-new) (init a)) (class c% (super-new) (init a))
'pos 'pos
'neg)]) 'neg)])
(new c% [a "bar"] [a "foo"]))) (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 (test/spec-passed
'class/c-higher-order-method-1 'class/c-higher-order-method-1