Changing absent so that fields may be specified as well as methods.
This commit is contained in:
parent
b35b7d98f8
commit
6494bf863e
|
@ -2575,6 +2575,9 @@
|
||||||
(for ([f (class/c-fields ctc)])
|
(for ([f (class/c-fields ctc)])
|
||||||
(unless (hash-ref field-ht f #f)
|
(unless (hash-ref field-ht f #f)
|
||||||
(fail "no public field ~a" f)))
|
(fail "no public field ~a" f)))
|
||||||
|
(for ([f (class/c-absent-fields ctc)])
|
||||||
|
(when (hash-ref field-ht f #f)
|
||||||
|
(fail "class already contains public field ~a" f)))
|
||||||
(for ([f (class/c-inherit-fields ctc)])
|
(for ([f (class/c-inherit-fields ctc)])
|
||||||
(unless (hash-ref field-ht f #f)
|
(unless (hash-ref field-ht f #f)
|
||||||
(fail "no public field ~a" f)))))
|
(fail "no public field ~a" f)))))
|
||||||
|
@ -2899,7 +2902,7 @@
|
||||||
inherits inherit-contracts inherit-fields inherit-field-contracts
|
inherits inherit-contracts inherit-fields inherit-field-contracts
|
||||||
supers super-contracts inners inner-contracts
|
supers super-contracts inners inner-contracts
|
||||||
overrides override-contracts augments augment-contracts
|
overrides override-contracts augments augment-contracts
|
||||||
augrides augride-contracts absents)
|
augrides augride-contracts absents absent-fields)
|
||||||
#:omit-define-syntaxes
|
#:omit-define-syntaxes
|
||||||
#:property prop:contract
|
#:property prop:contract
|
||||||
(build-contract-property
|
(build-contract-property
|
||||||
|
@ -2918,6 +2921,15 @@
|
||||||
(if (null? is)
|
(if (null? is)
|
||||||
null
|
null
|
||||||
(list (cons name (pair-ids-ctcs is ctcs)))))]
|
(list (cons name (pair-ids-ctcs is ctcs)))))]
|
||||||
|
[handle-absents
|
||||||
|
(λ (meths fields)
|
||||||
|
(cond
|
||||||
|
[(and (null? meths) (null? fields))
|
||||||
|
null]
|
||||||
|
[(null? fields)
|
||||||
|
(list (cons 'absent meths))]
|
||||||
|
[else
|
||||||
|
(list (list* 'absent (cons 'field fields) meths))]))]
|
||||||
[handled-methods
|
[handled-methods
|
||||||
(for/list ([i (in-list (class/c-methods ctc))]
|
(for/list ([i (in-list (class/c-methods ctc))]
|
||||||
[ctc (in-list (class/c-method-contracts ctc))])
|
[ctc (in-list (class/c-method-contracts ctc))])
|
||||||
|
@ -2937,8 +2949,7 @@
|
||||||
(handle-optional 'override (class/c-overrides ctc) (class/c-override-contracts ctc))
|
(handle-optional 'override (class/c-overrides ctc) (class/c-override-contracts ctc))
|
||||||
(handle-optional 'augment (class/c-augments ctc) (class/c-augment-contracts ctc))
|
(handle-optional 'augment (class/c-augments ctc) (class/c-augment-contracts ctc))
|
||||||
(handle-optional 'augride (class/c-augrides ctc) (class/c-augride-contracts ctc))
|
(handle-optional 'augride (class/c-augrides ctc) (class/c-augride-contracts ctc))
|
||||||
(let ([absents (class/c-absents ctc)])
|
(handle-absents (class/c-absents ctc) (class/c-absent-fields ctc))))))
|
||||||
(if (null? absents) null (list (cons 'absent absents))))))))
|
|
||||||
#:first-order
|
#:first-order
|
||||||
(λ (ctc)
|
(λ (ctc)
|
||||||
(λ (cls)
|
(λ (cls)
|
||||||
|
@ -2958,13 +2969,29 @@
|
||||||
(values #'(quote x)
|
(values #'(quote x)
|
||||||
#`(coerce-contract '#,form-name (let ([x ctc]) x)))]
|
#`(coerce-contract '#,form-name (let ([x ctc]) x)))]
|
||||||
[_
|
[_
|
||||||
(raise-syntax-error 'class/c "expected identifier or (id contract)" stx)]))
|
(raise-syntax-error form-name "expected identifier or (id contract)" stx)]))
|
||||||
(define (parse-names-ctcs stx)
|
(define (parse-names-ctcs stx)
|
||||||
(for/fold ([names null]
|
(for/fold ([names null]
|
||||||
[ctcs null])
|
[ctcs null])
|
||||||
([stx (in-list (syntax->list stx))])
|
([stx (in-list (syntax->list stx))])
|
||||||
(let-values ([(name ctc) (parse-name-ctc stx)])
|
(let-values ([(name ctc) (parse-name-ctc stx)])
|
||||||
(values (cons name names) (cons ctc ctcs)))))
|
(values (cons name names) (cons ctc ctcs)))))
|
||||||
|
(define (parse-absents stx)
|
||||||
|
(for/fold ([meths null]
|
||||||
|
[fields null])
|
||||||
|
([stx (in-list (syntax->list stx))])
|
||||||
|
(syntax-case stx (field)
|
||||||
|
[(field f-id ...)
|
||||||
|
(let ([symbols (for/list ([id (in-list (syntax->list #'(f-id ...)))])
|
||||||
|
(unless (identifier? id)
|
||||||
|
(raise-syntax-error 'class/c "expected identifier" stx))
|
||||||
|
#`(quote #,id))])
|
||||||
|
(values meths (append (reverse symbols) fields)))]
|
||||||
|
[id
|
||||||
|
(identifier? #'id)
|
||||||
|
(values (cons #'(quote id) meths) fields)]
|
||||||
|
[_
|
||||||
|
(raise-syntax-error 'class/c "expected identifier or (field id ...)" stx)])))
|
||||||
(define (parse-spec stx)
|
(define (parse-spec stx)
|
||||||
(syntax-case stx (field inherit inherit-field init init-field super inner override augment augride absent)
|
(syntax-case stx (field inherit inherit-field init init-field super inner override augment augride absent)
|
||||||
[(field f-spec ...)
|
[(field f-spec ...)
|
||||||
|
@ -3052,16 +3079,15 @@
|
||||||
(append names (hash-ref parsed-forms 'augrides null)))
|
(append names (hash-ref parsed-forms 'augrides null)))
|
||||||
(hash-set! parsed-forms 'augride-contracts
|
(hash-set! parsed-forms 'augride-contracts
|
||||||
(append ctcs (hash-ref parsed-forms 'augride-contracts null)))))]
|
(append ctcs (hash-ref parsed-forms 'augride-contracts null)))))]
|
||||||
[(absent m-id ...)
|
[(absent a-spec ...)
|
||||||
(begin
|
(begin
|
||||||
(when object/c?
|
(when object/c?
|
||||||
(raise-syntax-error 'object/c "absent specification not allowed in object/c" stx))
|
(raise-syntax-error 'object/c "absent specification not allowed in object/c" stx))
|
||||||
(let ([ids (syntax->list #'(m-id ...))])
|
(let-values ([(meths fields) (parse-absents #'(a-spec ...))])
|
||||||
(for ([id (in-list ids)])
|
|
||||||
(unless (identifier? id)
|
|
||||||
(raise-syntax-error form-name "non-identifier in absent specification" id)))
|
|
||||||
(hash-set! parsed-forms 'absents
|
(hash-set! parsed-forms 'absents
|
||||||
(append (map (λ (x) #`(quote #,x)) ids) (hash-ref parsed-forms 'absents null)))))]
|
(append meths (hash-ref parsed-forms 'absents null)))
|
||||||
|
(hash-set! parsed-forms 'absent-fields
|
||||||
|
(append fields (hash-ref parsed-forms 'absent-fields null)))))]
|
||||||
[m-spec
|
[m-spec
|
||||||
(let-values ([(name ctc1) (parse-name-ctc #'m-spec)])
|
(let-values ([(name ctc1) (parse-name-ctc #'m-spec)])
|
||||||
(hash-set! parsed-forms 'methods
|
(hash-set! parsed-forms 'methods
|
||||||
|
@ -3098,7 +3124,8 @@
|
||||||
[augment-ctcs #`(list #,@(reverse (hash-ref parsed-forms 'augment-contracts null)))]
|
[augment-ctcs #`(list #,@(reverse (hash-ref parsed-forms 'augment-contracts null)))]
|
||||||
[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)))]
|
||||||
[absents #`(list #,@(reverse (hash-ref parsed-forms 'absents null)))])
|
[absents #`(list #,@(reverse (hash-ref parsed-forms 'absents null)))]
|
||||||
|
[absent-fields #`(list #,@(reverse (hash-ref parsed-forms 'absent-fields null)))])
|
||||||
(syntax/loc stx
|
(syntax/loc stx
|
||||||
(let* ([inits+contracts (sort (list (cons i i-c) ...)
|
(let* ([inits+contracts (sort (list (cons i i-c) ...)
|
||||||
(lambda (s1 s2)
|
(lambda (s1 s2)
|
||||||
|
@ -3114,7 +3141,7 @@
|
||||||
overrides override-ctcs
|
overrides override-ctcs
|
||||||
augments augment-ctcs
|
augments augment-ctcs
|
||||||
augrides augride-ctcs
|
augrides augride-ctcs
|
||||||
absents)))))]))
|
absents absent-fields)))))]))
|
||||||
|
|
||||||
(define (check-object-contract obj methods fields fail)
|
(define (check-object-contract obj methods fields fail)
|
||||||
(unless (object? obj)
|
(unless (object? obj)
|
||||||
|
|
|
@ -1493,14 +1493,17 @@ resulting trait are the same as for @scheme[trait-sum], otherwise the
|
||||||
(override method-spec ...)
|
(override method-spec ...)
|
||||||
(augment method-spec ...)
|
(augment method-spec ...)
|
||||||
(augride method-spec ...)
|
(augride method-spec ...)
|
||||||
(absent method-id ...)]
|
(absent absent-spec ...)]
|
||||||
|
|
||||||
[method-spec
|
[method-spec
|
||||||
method-id
|
method-id
|
||||||
(method-id method-contract)]
|
(method-id method-contract)]
|
||||||
[field-spec
|
[field-spec
|
||||||
field-id
|
field-id
|
||||||
(field-id contract-expr)])]{
|
(field-id contract-expr)]
|
||||||
|
[absent-spec
|
||||||
|
method-id
|
||||||
|
(field field-id ...)])]{
|
||||||
Produces a contract for a class.
|
Produces a contract for a class.
|
||||||
|
|
||||||
There are two major categories of contracts listed in a @scheme[class/c]
|
There are two major categories of contracts listed in a @scheme[class/c]
|
||||||
|
@ -1518,7 +1521,7 @@ contracts which discuss the state of the object when the method is called
|
||||||
contract forms, such as @scheme[->m], are provided as a shorthand
|
contract forms, such as @scheme[->m], are provided as a shorthand
|
||||||
for writing method contracts.
|
for writing method contracts.
|
||||||
|
|
||||||
Methods listed in an @scheme[absent] clause must @emph{not} be present in the class.
|
Methods and fields listed in an @scheme[absent] clause must @emph{not} be present in the class.
|
||||||
|
|
||||||
The external contracts are as follows:
|
The external contracts are as follows:
|
||||||
|
|
||||||
|
|
|
@ -6738,6 +6738,17 @@
|
||||||
'pos
|
'pos
|
||||||
'neg))
|
'neg))
|
||||||
|
|
||||||
|
(test/spec-passed
|
||||||
|
'class/c-first-order-absent-3
|
||||||
|
'(contract (class/c (absent (field f))) object% 'pos 'neg))
|
||||||
|
|
||||||
|
(test/pos-blame
|
||||||
|
'class/c-first-order-absent-4
|
||||||
|
'(contract (class/c (absent (field f)))
|
||||||
|
(class object% (super-new) (field [f 3]))
|
||||||
|
'pos
|
||||||
|
'neg))
|
||||||
|
|
||||||
(test/spec-passed
|
(test/spec-passed
|
||||||
'class/c-higher-order-init-1
|
'class/c-higher-order-init-1
|
||||||
'(let ([c% (contract (class/c (init [a number?]))
|
'(let ([c% (contract (class/c (init [a number?]))
|
||||||
|
|
Loading…
Reference in New Issue
Block a user