From b272c02548968bd1ea682748cae63e7de3b43820 Mon Sep 17 00:00:00 2001
From: Stevie Strickland <sstrickl@racket-lang.org>
Date: Thu, 21 Oct 2010 15:20:04 -0700
Subject: [PATCH] Have unconstrained-domain-> do tail checks as well.

---
 collects/racket/contract/private/arrow.rkt | 42 +++++++++++++---------
 collects/tests/racket/contract-test.rktl   | 11 ++++++
 2 files changed, 37 insertions(+), 16 deletions(-)

diff --git a/collects/racket/contract/private/arrow.rkt b/collects/racket/contract/private/arrow.rkt
index dfdc10528c..b544f45844 100644
--- a/collects/racket/contract/private/arrow.rkt
+++ b/collects/racket/contract/private/arrow.rkt
@@ -51,6 +51,19 @@ v4 todo:
   #:property prop:procedure 0
   #:property prop:contracted 1)
 
+(define contract-key (gensym 'contract-key))
+
+(define-for-syntax (check-tail-contract num-rng-ctcs rng-ctcs rng-checkers call-gen)
+  #`(call-with-immediate-continuation-mark
+     contract-key
+     (λ (m)
+       (cond
+         [(and m
+               (= (length m) #,num-rng-ctcs)
+               (andmap procedure-closure-contents-eq? m (list . #,rng-ctcs)))
+          #,(call-gen #'())]
+         [else #,(call-gen rng-checkers)]))))
+
 (define-syntax (unconstrained-domain-> stx)
   (syntax-case stx ()
     [(_ rngs ...)
@@ -58,7 +71,7 @@ v4 todo:
                    [(proj-x ...) (generate-temporaries #'(rngs ...))]
                    [(p-app-x ...) (generate-temporaries #'(rngs ...))]
                    [(res-x ...) (generate-temporaries #'(rngs ...))])
-       #'(let ([rngs-x (coerce-contract 'unconstrained-domain-> rngs)] ...)
+       #`(let ([rngs-x (coerce-contract 'unconstrained-domain-> rngs)] ...)
            (let ([proj-x (contract-projection rngs-x)] ...)
              (define name
                (build-compound-type-name 'unconstrained-domain-> (contract-name rngs-x) ...))
@@ -73,10 +86,19 @@ v4 todo:
                       val
                       (make-keyword-procedure
                        (λ (kwds kwd-vals . args)
-                         (apply values res-checker kwd-vals args))
+                         #,(check-tail-contract 
+                            (length (syntax->list #'(rngs ...)))
+                            #'(p-app-x ...)
+                            (list #'res-checker)
+                            (λ (s) #`(apply values #,@s kwd-vals args))))
                        (λ args
-                         (apply values res-checker args)))
-                      proxy-prop:contracted ctc)))))
+                         #,(check-tail-contract 
+                            (length (syntax->list #'(rngs ...)))
+                            #'(p-app-x ...)
+                            (list #'res-checker)
+                            (λ (s) #`(apply values #,@s args)))))
+                      proxy-prop:contracted ctc
+                      proxy-prop:application-mark (cons contract-key (list p-app-x ...)))))))
              (define ctc
                (if (and (chaperone-contract? rngs-x) ...)
                    (make-chaperone-contract
@@ -110,19 +132,7 @@ v4 todo:
        (let-values ([(vr va) (procedure-keywords val)])
          (and va (equal? vr contract-req-kwds) (equal? va contract-opt-kwds)))))
 
-(define contract-key (gensym 'contract-key))
-
 (define-for-syntax (create-chaperone blame val pre post this-args doms opt-doms dom-rest req-kwds opt-kwds rngs)
-  (define (check-tail-contract num-rng-ctcs rng-ctcs rng-checkers call-gen)
-    #`(call-with-immediate-continuation-mark
-       contract-key
-       (λ (m)
-         (cond
-           [(and m
-                 (= (length m) #,num-rng-ctcs)
-                 (andmap procedure-closure-contents-eq? m (list . #,rng-ctcs)))
-            #,(call-gen #'())]
-           [else #,(call-gen rng-checkers)]))))
   (with-syntax ([blame blame]
                 [val val])
     (with-syntax ([(pre ...) 
diff --git a/collects/tests/racket/contract-test.rktl b/collects/tests/racket/contract-test.rktl
index ce16ccb2f2..0c9fc2ad95 100644
--- a/collects/tests/racket/contract-test.rktl
+++ b/collects/tests/racket/contract-test.rktl
@@ -9794,6 +9794,17 @@ so that propagation occurs.
              (f 3))
            (c)))
   
+  (ctest 1
+         'tail-unconstrained-domain-arrow
+         (let ([c (counter)])
+           (letrec ([f 
+                     (contract (unconstrained-domain-> c)
+                               (λ (x) (if (zero? x) x (f (- x 1))))
+                               'pos
+                               'neg)])
+             (f 3))
+           (c)))
+  
   (ctest 2
          'tail-multiple-value-arrow
          (let ([c (counter)])