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

47
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
@ -2860,9 +2863,14 @@
(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,
;; since we still need to handle either calling the previous class/c's init or
;; calling continue-make-super appropriately.
(let () (let ()
;; zip the inits and contracts together for ordered selection
(define inits+contracts (map cons (class/c-inits ctc) (class/c-init-contracts ctc))) (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) (define (grab-same-inits lst)
(if (null? lst) (if (null? lst)
(values null null) (values null null)
@ -2875,6 +2883,8 @@
(loop (cdr inits/c) (loop (cdr inits/c)
(cons (car inits/c) prefix))] (cons (car inits/c) prefix))]
[else (values (reverse prefix) inits/c)])))) [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) (define (apply-contracts inits/c init-args)
(let loop ([init-args init-args] (let loop ([init-args init-args]
[inits/c inits/c] [inits/c inits/c]
@ -2906,7 +2916,11 @@
(let-values ([(prefix suffix) (grab-same-inits inits/c)]) (let-values ([(prefix suffix) (grab-same-inits inits/c)])
(loop suffix (loop suffix
(apply-contracts prefix init-args)))))]) (apply-contracts prefix init-args)))))])
(init the-obj super-go si_c si_inited? si_leftovers 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,19 +3095,12 @@
(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))]
[init-contracts (reverse (hash-ref parsed-forms 'init-contracts null))]
[paired (map cons inits init-contracts)]
[sorted-inits (sort paired
(lambda (s1 s2)
(string<? (symbol->string s1) (symbol->string s2)))
#:key car)])
(with-syntax ([methods #`(list #,@(reverse (hash-ref parsed-forms 'methods null)))] (with-syntax ([methods #`(list #,@(reverse (hash-ref parsed-forms 'methods null)))]
[method-ctcs #`(list #,@(reverse (hash-ref parsed-forms 'method-contracts null)))] [method-ctcs #`(list #,@(reverse (hash-ref parsed-forms 'method-contracts null)))]
[fields #`(list #,@(reverse (hash-ref parsed-forms 'fields null)))] [fields #`(list #,@(reverse (hash-ref parsed-forms 'fields null)))]
[field-ctcs #`(list #,@(reverse (hash-ref parsed-forms 'field-contracts null)))] [field-ctcs #`(list #,@(reverse (hash-ref parsed-forms 'field-contracts null)))]
[inits #`(list #,@(map car sorted-inits))] [(i ...) (reverse (hash-ref parsed-forms 'inits null))]
[init-ctcs #`(list #,@(map cdr sorted-inits))] [(i-c ...) (reverse (hash-ref parsed-forms 'init-contracts null))]
[inherits #`(list #,@(reverse (hash-ref parsed-forms 'inherits null)))] [inherits #`(list #,@(reverse (hash-ref parsed-forms 'inherits null)))]
[inherit-ctcs #`(list #,@(reverse (hash-ref parsed-forms 'inherit-contracts null)))] [inherit-ctcs #`(list #,@(reverse (hash-ref parsed-forms 'inherit-contracts null)))]
[inherit-fields #`(list #,@(reverse (hash-ref parsed-forms 'inherit-fields null)))] [inherit-fields #`(list #,@(reverse (hash-ref parsed-forms 'inherit-fields null)))]
@ -3109,9 +3116,13 @@
[augrides #`(list #,@(reverse (hash-ref parsed-forms 'augrides null)))] [augrides #`(list #,@(reverse (hash-ref parsed-forms 'augrides null)))]
[augride-ctcs #`(list #,@(reverse (hash-ref parsed-forms 'augride-contracts null)))]) [augride-ctcs #`(list #,@(reverse (hash-ref parsed-forms 'augride-contracts null)))])
(syntax/loc stx (syntax/loc stx
(let* ([inits+contracts (sort (list (cons i i-c) ...)
(lambda (s1 s2)
(string<? (symbol->string s1) (symbol->string s2)))
#:key car)])
(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

44
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