made mutual recursion work for ->d

svn: r12366

collects/scheme/private/contract-arrow.ss

@@ -833,12 +833,14 @@ v4 todo:
                                     (syntax-local-infer-name stx)
                                     #`(λ args (apply f args))))))))))))]))
 
+(define ->d-tail-key (gensym '->d-tail-key))
+
 (define (->d-proj ->d-stct)
   (let ([non-kwd-ctc-count (+ (length (->d-mandatory-dom-ctcs ->d-stct))
                               (length (->d-optional-dom-ctcs ->d-stct))
                               (if (->d-mtd? ->d-stct) 1 0))])
     (λ (pos-blame neg-blame src-info orig-str)
-      (let ([tail-key (gensym '->d-tail-key)])
+      (let ([this->d-id (gensym '->d-tail-key)])
         (λ (val)
           (check-procedure val
                            (->d-mtd? ->d-stct)
@@ -856,16 +858,8 @@ v4 todo:
                           [dep-pre-args
                            (build-dep-ctc-args non-kwd-ctc-count raw-orig-args (->d-rest-ctc ->d-stct)
                                                (->d-keywords ->d-stct) kwd-args kwd-arg-vals)]
-                          [thnk
+                          [thunk
                            (λ ()
-                             (when (->d-pre-cond ->d-stct)
-                               (unless (apply (->d-pre-cond ->d-stct) dep-pre-args)
-                                 (raise-contract-error val
-                                                       src-info
-                                                       neg-blame
-                                                       orig-str
-                                                       "#:pre-cond violation")))
-                             (with-continuation-mark tail-key #t
                              (keyword-apply
                               val
                               kwd-args
@@ -908,7 +902,20 @@ v4 todo:
                                         (error 'shouldnt\ happen))]
                                    [else (cons (invoke-dep-ctc (car non-kwd-ctcs) dep-pre-args (car args) neg-blame pos-blame src-info orig-str)
                                                (loop (cdr args)
-                                                       (cdr non-kwd-ctcs)))]))))))]
+                                                     (cdr non-kwd-ctcs)))])))))]
+                          [check-and-mark
+                           (λ (marks)
+                             (when (->d-pre-cond ->d-stct)
+                               (unless (apply (->d-pre-cond ->d-stct) dep-pre-args)
+                                 (raise-contract-error val
+                                                       src-info
+                                                       neg-blame
+                                                       orig-str
+                                                       "#:pre-cond violation")))
+                             (if marks
+                                 (with-continuation-mark ->d-tail-key (cons this->d-id marks)
+                                   (thunk))
+                                 (thunk)))]
                           [rng (let ([rng (->d-range ->d-stct)])
                                  (cond
                                    [(not rng) #f]
@@ -918,12 +925,13 @@ v4 todo:
                                    [else rng]))]
                           [rng-underscore? (box? (->d-range ->d-stct))])
                      (call-with-immediate-continuation-mark
-                      tail-key
+                      ->d-tail-key
                       (λ (first-mark)
                         (if (and rng
-                                 (not first-mark))
+                                 (not (and first-mark
+                                           (member this->d-id first-mark))))
                             (call-with-values
-                             thnk
+                             (λ () (check-and-mark (or first-mark '())))
                              (λ orig-results
                                (let* ([range-count (length rng)]
                                       [post-args (append orig-results raw-orig-args)]
@@ -959,7 +967,7 @@ v4 todo:
                                                         (if rng-underscore? #f dep-post-args)
                                                         (car results) pos-blame neg-blame src-info orig-str)
                                         (loop (cdr results) (cdr result-contracts)))]))))))
-                            (thnk))))))])
+                            (check-and-mark #f))))))])
             (make-keyword-procedure kwd-proc
                                     ((->d-name-wrapper ->d-stct)
                                      (λ args

collects/tests/mzscheme/contract-test.ss

@@ -5265,6 +5265,31 @@ so that propagation occurs.
              (f 3))
            (c)))
   
+  (ctest '(1 1)
+         'tail->d-mut-rec
+         (letrec ([odd-count 0]
+                  [pos-count 0]
+                  [count-odd?
+                   (λ (x)
+                     (set! odd-count (+ odd-count 1))
+                     (odd? x))]
+                  [count-positive? 
+                   (λ (x)
+                     (set! pos-count (+ pos-count 1))
+                     (positive? x))]
+                  [returns-odd
+                   (contract (->d ([x any/c]) () [_ count-odd?])
+                             (λ (x) (returns-pos x))
+                             'pos
+                             'neg)]
+                  [returns-pos
+                   (contract (->d ([x any/c]) () [_ count-positive?])
+                             (λ (x) (if (zero? x) 1 (returns-odd (- x 1))))
+                             'pos
+                             'neg)])
+           (returns-odd 3)
+           (list odd-count pos-count)))
+  
   (ctest 2
          'case->-regular
          (let ([c (counter)])