* 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
This commit is contained in:
Stevie Strickland
parent
7ec061cdbf
commit
924842d9e9
|
|
@ -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)
|
||||
(string<? (symbol->string 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)
|
||||
(string<? (symbol->string 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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user