..

original commit: 2a6090270b1766d7b4798afd8171a5c5f953ca60

collects/mzlib/contracts.ss

@@ -822,13 +822,6 @@
          (and 
           (andmap method-specifier? (syntax->list (syntax (method-specifier ...))))
           (andmap identifier? (syntax->list (syntax (meth-name ...)))))
-         (match-let ([(`(,make-outer-checks ,xxx ,build-pieces) ...)
-                      (map (lambda (meth-contract-stx)
-                             (let ([/h (select/h meth-contract-stx 'class-contract stx)])
-                               (let-values ([(make-outer-check xxx build-pieces impl-wrap impl-builder impl-info)
-                                             (/h meth-contract-stx)])
-                                 (list make-outer-check xxx build-pieces))))
-                           (syntax->list (syntax (meth-contract ...))))])
          (let* ([outer-args (syntax (val pos-blame neg-blame src-info))]
                 [val-meth-names (syntax->list (syntax (meth-name ...)))]
                 [val-publics? (map (lambda (x) (eq? 'public (syntax-e x)))
@@ -836,6 +829,15 @@
                 [super-meth-names (map prefix-super val-meth-names)]
                 [val-meth-contracts (syntax->list (syntax (meth-contract ...)))]
                 [val-meth-contract-vars (generate-temporaries val-meth-contracts)])
+
+           (let ([ht (make-hash-table)])
+             (for-each (lambda (name)
+                         (let ([key (syntax-e name)])
+                           (when (hash-table-get ht key (lambda () #f))
+                             (raise-syntax-error 'class/contract "duplicate method name in contract" stx name))
+                           (hash-table-put! ht key #t)))
+                       val-meth-names))
+           
            (with-syntax ([outer-args outer-args]
                          [(super-meth-name ...) super-meth-names]
                          [(get-meth-contract ...) (map method-name->contract-method-name val-meth-names)]
@@ -855,8 +857,6 @@
                                                                   val-meth-names
                                                                   val-meth-contract-vars
                                                                   val-publics?)])
-               (foldr
-                (lambda (f stx) (f stx))
              (syntax/loc stx
                (let ([meth-contract-var meth-contract] ...)
                  (make-contract
@@ -889,8 +889,7 @@
                       (rename [super-meth-name meth-name] ...)
                       method ...
                       (super-instantiate ())))
-                     (lambda x (error 'impl-contract "unimplemented")))))
+                  (lambda x (error 'impl-contract "unimplemented")))))))]
-                make-outer-checks))))]
         [(_ (meth-specifier meth-name meth-contract) ...)
          (for-each (lambda (specifier name)
                      (unless (method-specifier? name)
@@ -1570,8 +1569,10 @@
                ((contract-wrap (car contracts)) val pos neg src-info)]))
           (lambda x (error 'impl-contract "unimplemented")))])))
 
-  (provide and/f or/f 
+  (provide and/f or/f not/f
            >=/c <=/c </c >/c 
+           integer-in real-in
+           string/len
 	   natural-number?
            false? any? 
 	   printable?
@@ -1608,6 +1609,15 @@
                                      (cons (car strs)
                                            (loop (cdr strs))))]))))))
   
+  (define (string/len n)
+    (unless (number? n)
+      (error 'string/len "expected a number as argument, got ~e" n))
+    (make-flat-named-contract 
+     (format "string (up to ~a characters)" n)
+     (lambda (x)
+       (and (string? x)
+            ((string-length x) . < . n)))))
+  
   (define (symbols . ss)
     (unless ((length ss) . >= . 1)
       (error 'symbols "expected at least one argument"))
@@ -1668,6 +1678,16 @@
        (ormap (lambda (f) (test-flat-contract f x))
               fs))))
 
+  (define (not/f f)
+    (unless (or (flat-named-contract? f)
+                (and (procedure? f)
+                     (procedure-arity-includes? f 1)))
+      (error 'not/f "expected a procedure of arity 1 or <flat-named-contract>, given: ~e" f))
+    (make-flat-named-contract
+     (build-compound-type-name "not/f" f)
+     (lambda (x)
+       (not (f x)))))
+  
   (define (>=/c x)
     (make-flat-named-contract
      (format "number >= ~a" x)
@@ -1773,6 +1793,26 @@
                     args
                     (vector->list v))))))
   
+  (define (integer-in start end)
+    (unless (and (integer? start)
+                 (integer? end))
+      (error 'integer-in "expected two integers as arguments, got ~e and ~e" start end))
+    (make-flat-named-contract 
+     (format "integer between ~a and ~a, inclusive" start end)
+     (lambda (x)
+       (and (integer? x)
+            (<= start x end)))))
+  
+  (define (real-in start end)
+    (unless (and (real? start)
+                 (real? end))
+      (error 'real-in "expected two real numbers as arguments, got ~e and ~e" start end))
+    (make-flat-named-contract 
+     (format "real between ~a and ~a, inclusive" start end)
+     (lambda (x)
+       (and (real? x)
+            (<= start x end)))))
+  
   (define (box/p pred)
     (unless (flat-contract? pred)
       (error 'box/p "expected a flat contract, got: ~e" pred))

collects/tests/mzscheme/contracts.ss

@@ -881,6 +881,22 @@
       (send (make-object d%) m 100))
    "pos-d")
   
+  (test/spec-failed
+   'not/f1
+   '(contract (not/f integer?)
+              1
+              'pos
+              'neg)
+   "pos-d")
+  
+  (test/spec-passed/result
+   'not/f2
+   '(contract (not/f integer?)
+              'not-integer
+              'pos
+              'neg)
+   'not-integer)
+  
   ))
 
 (report-errs)