From 6494bf863efc5ac4bf59729ee4e4aed718f6d3fe Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Tue, 5 Apr 2011 15:03:46 -0400 Subject: [PATCH] Changing absent so that fields may be specified as well as methods. --- collects/racket/private/class-internal.rkt | 53 ++++++++++++++++------ collects/scribblings/reference/class.scrbl | 9 ++-- collects/tests/racket/contract-test.rktl | 11 +++++ 3 files changed, 57 insertions(+), 16 deletions(-) diff --git a/collects/racket/private/class-internal.rkt b/collects/racket/private/class-internal.rkt index ff4900bc08..33aa9af404 100644 --- a/collects/racket/private/class-internal.rkt +++ b/collects/racket/private/class-internal.rkt @@ -2575,6 +2575,9 @@ (for ([f (class/c-fields ctc)]) (unless (hash-ref field-ht f #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)]) (unless (hash-ref field-ht f #f) (fail "no public field ~a" f))))) @@ -2899,7 +2902,7 @@ inherits inherit-contracts inherit-fields inherit-field-contracts supers super-contracts inners inner-contracts overrides override-contracts augments augment-contracts - augrides augride-contracts absents) + augrides augride-contracts absents absent-fields) #:omit-define-syntaxes #:property prop:contract (build-contract-property @@ -2918,6 +2921,15 @@ (if (null? is) null (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 (for/list ([i (in-list (class/c-methods 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 'augment (class/c-augments ctc) (class/c-augment-contracts ctc)) (handle-optional 'augride (class/c-augrides ctc) (class/c-augride-contracts ctc)) - (let ([absents (class/c-absents ctc)]) - (if (null? absents) null (list (cons 'absent absents)))))))) + (handle-absents (class/c-absents ctc) (class/c-absent-fields ctc)))))) #:first-order (λ (ctc) (λ (cls) @@ -2958,13 +2969,29 @@ (values #'(quote 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) (for/fold ([names null] [ctcs null]) ([stx (in-list (syntax->list stx))]) (let-values ([(name ctc) (parse-name-ctc stx)]) (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) (syntax-case stx (field inherit inherit-field init init-field super inner override augment augride absent) [(field f-spec ...) @@ -3052,16 +3079,15 @@ (append names (hash-ref parsed-forms 'augrides null))) (hash-set! parsed-forms 'augride-contracts (append ctcs (hash-ref parsed-forms 'augride-contracts null)))))] - [(absent m-id ...) + [(absent a-spec ...) (begin (when object/c? (raise-syntax-error 'object/c "absent specification not allowed in object/c" stx)) - (let ([ids (syntax->list #'(m-id ...))]) - (for ([id (in-list ids)]) - (unless (identifier? id) - (raise-syntax-error form-name "non-identifier in absent specification" id))) - (hash-set! parsed-forms 'absents - (append (map (λ (x) #`(quote #,x)) ids) (hash-ref parsed-forms 'absents null)))))] + (let-values ([(meths fields) (parse-absents #'(a-spec ...))]) + (hash-set! parsed-forms 'absents + (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 (let-values ([(name ctc1) (parse-name-ctc #'m-spec)]) (hash-set! parsed-forms 'methods @@ -3098,7 +3124,8 @@ [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)))] - [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 (let* ([inits+contracts (sort (list (cons i i-c) ...) (lambda (s1 s2) @@ -3114,7 +3141,7 @@ overrides override-ctcs augments augment-ctcs augrides augride-ctcs - absents)))))])) + absents absent-fields)))))])) (define (check-object-contract obj methods fields fail) (unless (object? obj) diff --git a/collects/scribblings/reference/class.scrbl b/collects/scribblings/reference/class.scrbl index 9ded4928f5..d7e04ac10d 100644 --- a/collects/scribblings/reference/class.scrbl +++ b/collects/scribblings/reference/class.scrbl @@ -1493,14 +1493,17 @@ resulting trait are the same as for @scheme[trait-sum], otherwise the (override method-spec ...) (augment method-spec ...) (augride method-spec ...) - (absent method-id ...)] + (absent absent-spec ...)] [method-spec method-id (method-id method-contract)] [field-spec field-id - (field-id contract-expr)])]{ + (field-id contract-expr)] + [absent-spec + method-id + (field field-id ...)])]{ Produces a contract for a class. 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 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: diff --git a/collects/tests/racket/contract-test.rktl b/collects/tests/racket/contract-test.rktl index 8894c2f1ed..438e909e7d 100644 --- a/collects/tests/racket/contract-test.rktl +++ b/collects/tests/racket/contract-test.rktl @@ -6738,6 +6738,17 @@ 'pos '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 'class/c-higher-order-init-1 '(let ([c% (contract (class/c (init [a number?]))