Adding `absent' to class contracts.

The `absent' clause lists public methods which must _not_ exist in the
contracted class.

collects/racket/private/class-internal.rkt

@@ -68,7 +68,7 @@
            rename-super rename-inner inherit inherit/super inherit/inner inherit-field
            this this% super inner
            super-make-object super-instantiate super-new
-           inspect))
+           inspect absent))
 
 
 ;;--------------------------------------------------------------------
@@ -102,6 +102,24 @@
                        inspect
                        init-rest)
 
+;; Going ahead and doing this in a generic fashion, in case we later realize that
+;; we need more class contract-specific keywords.
+(define-for-syntax (do-class-contract-keyword stx)
+  (raise-syntax-error
+   #f
+   "use of a class contract keyword is not in a class contract"
+   stx))
+
+(define-syntax provide-class-contract-keyword
+  (syntax-rules ()
+    [(_ id ...)
+     (begin
+       (define-syntax (id stx) (do-class-contract-keyword stx))
+       ...
+       (provide id ...))]))
+
+(provide-class-contract-keyword absent)
+
 (define-for-syntax (do-define-like-internal stx)
   (syntax-case stx ()
     [(_ orig . __)
@@ -2500,6 +2518,9 @@
     (for ([m (class/c-methods ctc)])
       (unless (hash-ref method-ht m #f)
         (fail "no public method ~a" m)))
+    (for ([m (class/c-absents ctc)])
+      (when (hash-ref method-ht m #f)
+        (fail "class already contains public method ~a")))
     (for ([m (class/c-inherits ctc)])
       (unless (hash-ref method-ht m #f)
         (fail "no public method ~a" m)))
@@ -2878,7 +2899,7 @@
    inherits inherit-contracts inherit-fields inherit-field-contracts
    supers super-contracts inners inner-contracts
    overrides override-contracts augments augment-contracts
-   augrides augride-contracts)
+   augrides augride-contracts absents)
   #:omit-define-syntaxes
   #:property prop:contract
   (build-contract-property
@@ -2915,7 +2936,9 @@
                (handle-optional 'inner (class/c-inners ctc) (class/c-inner-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 '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)])
+                 (if (null? absents) null (list (cons 'absent absents))))))))
    #:first-order
    (λ (ctc)
      (λ (cls)
@@ -2943,7 +2966,7 @@
       (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 init-field super inner override augment augride)
+    (syntax-case stx (field inherit inherit-field init init-field super inner override augment augride absent)
       [(field f-spec ...)
        (let-values ([(names ctcs) (parse-names-ctcs #'(f-spec ...))])
          (hash-set! parsed-forms 'fields
@@ -3029,6 +3052,16 @@
                       (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 ...)
+       (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)))))]
       [m-spec
        (let-values ([(name ctc1) (parse-name-ctc #'m-spec)])
          (hash-set! parsed-forms 'methods
@@ -3064,7 +3097,8 @@
                      [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)))])
+                     [augride-ctcs #`(list #,@(reverse (hash-ref parsed-forms 'augride-contracts null)))]
+                     [absents #`(list #,@(reverse (hash-ref parsed-forms 'absents null)))])
          (syntax/loc stx
            (let* ([inits+contracts (sort (list (cons i i-c) ...)
                                          (lambda (s1 s2) 
@@ -3079,7 +3113,8 @@
                            inners inner-ctcs
                            overrides override-ctcs
                            augments augment-ctcs
-                           augrides augride-ctcs)))))]))
+                           augrides augride-ctcs
+                           absents)))))]))
 
 (define (check-object-contract obj methods fields fail)
   (unless (object? obj)

collects/scribblings/reference/class.scrbl

@@ -1477,7 +1477,7 @@ resulting trait are the same as for @scheme[trait-sum], otherwise the
 @section{Object and Class Contracts}
 
 @defform/subs[
-#:literals (field init init-field inherit inherit-field super inner override augment augride)
+#:literals (field init init-field inherit inherit-field super inner override augment augride absent)
 
 (class/c member-spec ...)
 
@@ -1492,7 +1492,8 @@ resulting trait are the same as for @scheme[trait-sum], otherwise the
   (inner method-spec ...)
   (override method-spec ...)
   (augment method-spec ...)
-  (augride method-spec ...)]
+  (augride method-spec ...)
+  (absent method-id ...)]
  
  [method-spec
   method-id
@@ -1517,6 +1518,8 @@ 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.
+
 The external contracts are as follows:
 
 @itemize[
@@ -1572,6 +1575,10 @@ The internal contracts are as follows:
    @scheme[augride] is used when subclasses can override the current augmentation.}
 ]}
 
+@defform[(absent method-id ...)]{
+See @scheme[class/c]; use outside of a @scheme[class/c] form is a syntax error.
+}
+
 @defform[(->m dom ... range)]{
 Similar to @scheme[->], except that the domain of the resulting contract contains one more element
 than the stated domain, where the first (implicit) argument is contracted with @scheme[any/c].

collects/tests/racket/contract-test.rktl

@@ -6727,6 +6727,17 @@
            [d% (class c% (super-new) (inherit m) (define/public (f) (m 5)))])
       (send (new d%) f)))
   
+  (test/spec-passed
+   'class/c-first-order-absent-1
+   '(contract (class/c (absent m)) object% 'pos 'neg))
+  
+  (test/pos-blame
+   'class/c-first-order-absent-2
+   '(contract (class/c (absent m))
+              (class object% (super-new) (define/public (m) 3))
+              'pos
+              'neg))
+  
   (test/spec-passed
    'class/c-higher-order-init-1
    '(let ([c% (contract (class/c (init [a number?]))