added recursive contracts and fixed a bug or two

svn: r81

collects/mzlib/contract.ss

@@ -11,6 +11,7 @@ add struct contracts for immutable structs?
   
   (provide (rename -contract contract)
            any
+           recursive-contract
            ->
            ->d
            ->*
@@ -506,7 +507,7 @@ add struct contracts for immutable structs?
   ;                                                      
   ;                                                      
   
-  ;; contract = (make-contract ((union #f (listof number)) -> string)
+  ;; contract = (make-contract sexp
   ;;                           (sym
   ;;                            sym
   ;;                            (union syntax #f)
@@ -560,7 +561,7 @@ add struct contracts for immutable structs?
     
   
   
-  ;; build-compound-type-name : (union contract symbol) ... -> (union path #f) -> sexp
+  ;; build-compound-type-name : (union contract symbol) ... -> (-> sexp)
   (define (build-compound-type-name . fs)
     (let loop ([subs fs]
                [i 0])
@@ -594,7 +595,7 @@ add struct contracts for immutable structs?
     (build-flat-contract name predicate))
   
   (define (build-flat-contract name predicate)
-    (make-flat-contract 
+    (make-flat-contract
      name
      (lambda (pos neg src-info orig-str) 
        (lambda (val)
@@ -728,6 +729,23 @@ add struct contracts for immutable structs?
               ""))
         ""))
     
+  (define-syntax (recursive-contract stx)
+    (syntax-case stx ()
+      [(_ arg)
+       (syntax (recursive-contract/proc '(recursive-contract arg) (delay (check-contract arg))))]))
+  
+  (define (recursive-contract/proc name delayed-contract)
+    (make-contract name
+                   (λ (pos neg src str)
+                     (let ([proc (contract-proc (force delayed-contract))])
+                       (λ (val)
+                         ((proc pos neg src str) val))))))
+  
+  (define (check-contract ctc)
+    (unless (contract? ctc)
+      (error 'recursive-contract "expected a contract, got ~e" ctc))
+    ctc)
+                   
 ;                                                                                   
 ;                                                                                   
 ;                                                                                   
@@ -3094,14 +3112,14 @@ add struct contracts for immutable structs?
 	[(null? args) (flat-contract null?)]
 	[else (cons-immutable/c (car args) (loop (cdr args)))])))
 
-  (define (syntax/c c)
+  (define (syntax/c ctc-in)
-    (unless (flat-contract/predicate? c)
+    (let ([ctc (coerce-contract syntax/c ctc-in)])
-      (error 'syntax/c "expected argument of type <flat-contract> or procedure of arity 1, got ~e" c))
+      (build-flat-contract
-    (build-flat-contract
+       (build-compound-type-name 'syntax/c ctc)
-     (let ([pred (flat-contract-predicate c)])
+       (let ([pred (flat-contract-predicate ctc)])
-       (lambda (val)
+         (lambda (val)
-         (and (syntax? val)
+           (and (syntax? val)
-              (pred (syntax-e val)))))))
+                (pred (syntax-e val))))))))
   
   (define promise/c
     (lambda (ctc-in)

collects/tests/mzscheme/contract-test.ss

@@ -2781,6 +2781,20 @@
       x)
    1)
   
+  (test/pos-blame 
+   'syntax/c1
+   '(contract (syntax/c boolean?)
+              #'x
+              'pos
+              'neg))
+  
+  (test/spec-passed
+   'syntax/c2
+   '(contract (syntax/c symbol?)
+              #'x
+              'pos
+              'neg))
+  
   (test/spec-passed
    'struct/c1
    '(let ()
@@ -2807,6 +2821,35 @@
                 1
                 'pos
                 'neg)))
+
+  (test/spec-passed
+   'recursive-contract1
+   (letrec ([ctc (-> integer? (recursive-contract ctc))])
+     (letrec ([f (λ (x) f)])
+       ((((contract ctc f 'pos 'neg) 1) 2) 3))))
+  
+  (test/neg-blame
+   'recursive-contract2
+   '(letrec ([ctc (-> integer? (recursive-contract ctc))])
+      (letrec ([f (λ (x) f)])
+        ((contract ctc f 'pos 'neg) #f))))
+  
+  (test/neg-blame
+   'recursive-contract3
+   '(letrec ([ctc (-> integer? (recursive-contract ctc))])
+      (letrec ([f (λ (x) f)])
+        ((((contract ctc f 'pos 'neg) 1) 2) #f))))
+  
+  (test/pos-blame
+   'recursive-contract4
+   '(letrec ([ctc (-> integer? (recursive-contract ctc))])
+      (letrec ([c 0]
+               [f (λ (x) 
+                    (set! c (+ c 1))
+                    (if (= c 2)
+                        'nope
+                        f))])
+        ((((contract ctc f 'pos 'neg) 1) 2) 3))))
   
   ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   ;;                                                        ;;
@@ -3107,9 +3150,13 @@
   (test-name '(object-contract (m (->r ((x ...) (y ...) (z ...)) rest-x ... ...))) 
              (object-contract (m (->r ((x number?) (y boolean?) (z pair?)) rest-x any/c number?))))
   (test-name '(promise/c any/c) (promise/c any/c))
+  (test-name '(syntax/c any/c) (syntax/c any/c))
   (test-name '(struct/c st integer?) 
              (let ()
                (define-struct st (a))
                (struct/c st integer?)))
+  
+  (test-name '(recursive-contract (box/c boolean?)) (recursive-contract (box/c boolean?)))
+  (test-name '(recursive-contract x) (let ([x (box/c boolean?)]) (recursive-contract x)))
   ))
 (report-errs)