Add some handling of by-name inits to class/c, though we can't do any useful
first-order checks without more invasive changes. svn: r18546
This commit is contained in:
Stevie Strickland
commit
b12faf3d15
|
|
@ -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)]
|
||||
|
|
@ -2632,6 +2634,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
|
||||
|
|
@ -2670,13 +2673,14 @@
|
|||
'struct:object 'object? 'make-object
|
||||
'field-ref 'field-set!
|
||||
|
||||
(class-init-args cls)
|
||||
(class-init-mode cls)
|
||||
(class-init cls)
|
||||
;; class/c introduced subclasses do not consume init args
|
||||
null
|
||||
'normal
|
||||
#f
|
||||
|
||||
(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)])
|
||||
|
|
@ -2859,10 +2863,69 @@
|
|||
(vector-set! int-vec new-idx
|
||||
(make-method (p (vector-ref int-vec new-idx)) m)))))))
|
||||
|
||||
;; 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))))
|
||||
|
||||
(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 +2958,7 @@
|
|||
'class/c
|
||||
(append
|
||||
handled-methods
|
||||
(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))
|
||||
|
|
@ -2929,13 +2993,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 +3099,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)))]
|
||||
[(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)))]
|
||||
|
|
@ -3034,15 +3116,20 @@
|
|||
[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
|
||||
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+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
|
||||
(map car inits+contracts) (map cdr inits+contracts)
|
||||
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
|
||||
|
|
|
|||
|
|
@ -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 ...)
|
||||
|
|
@ -1501,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
|
||||
|
|
@ -1525,6 +1528,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:
|
||||
|
|
|
|||
|
|
@ -4228,6 +4228,31 @@
|
|||
'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
|
||||
'(contract (class/c (inherit-field [n number?]))
|
||||
|
|
@ -4626,6 +4651,109 @@
|
|||
[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 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 c% (super-new) (init a))
|
||||
'pos
|
||||
'neg)])
|
||||
(new d% [a 3] [a 4])))
|
||||
|
||||
(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 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-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
|
||||
'(let ([c% (contract (class/c [m (-> any/c number? number?)])
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user