Changing absent so that fields may be specified as well as methods.

This commit is contained in:
Stevie Strickland 2011-04-05 15:03:46 -04:00
parent b35b7d98f8
commit 6494bf863e
3 changed files with 57 additions and 16 deletions

View File

@ -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)

View File

@ -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:

View File

@ -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?]))