From 87c9aba9e011d07fe4ebba214790c2e235a7a38d Mon Sep 17 00:00:00 2001
From: Robby Findler <robby@racket-lang.org>
Date: Wed, 29 Apr 2009 03:48:45 +0000
Subject: [PATCH] added a little optimization to provide/contract

svn: r14646
---
 collects/scheme/private/contract.ss      | 11 +++++++++--
 collects/tests/mzscheme/contract-test.ss | 12 ++++++++++++
 2 files changed, 21 insertions(+), 2 deletions(-)

diff --git a/collects/scheme/private/contract.ss b/collects/scheme/private/contract.ss
index 5920e8a6e0..a9ea375649 100644
--- a/collects/scheme/private/contract.ss
+++ b/collects/scheme/private/contract.ss
@@ -1217,6 +1217,12 @@ improve method arity mismatch contract violation error messages?
                             [ctrct (syntax-property ctrct 'inferred-name id)]
                             [external-name (or user-rename-id id)]
                             [where-stx stx])
+                (with-syntax ([extra-test 
+                               (syntax-case #'ctrct (->)
+                                 [(-> dom ... arg)
+                                  #`(and (procedure? id)
+                                         (procedure-arity-includes? id #,(length (syntax->list #'(dom ...)))))]
+                                 [_ #f])])
                 (with-syntax ([code
                                (quasisyntax/loc stx
                                  (begin
@@ -1234,10 +1240,11 @@ improve method arity mismatch contract violation error messages?
                   
                   (syntax-local-lift-module-end-declaration
                    #`(begin 
-                       (-contract contract-id id pos-module-source 'ignored #,(id->contract-src-info #'id))
+                       (unless extra-test
+                         (-contract contract-id id pos-module-source 'ignored #,(id->contract-src-info #'id)))
                        (void)))
                   
-                  (syntax (code id-rename)))))]))
+                  (syntax (code id-rename))))))]))
        
        (with-syntax ([(bodies ...) (code-for-each-clause (syntax->list (syntax (p/c-ele ...))))])
          (signal-dup-syntax-error)
diff --git a/collects/tests/mzscheme/contract-test.ss b/collects/tests/mzscheme/contract-test.ss
index 917e07c2ae..3b299b5f8d 100644
--- a/collects/tests/mzscheme/contract-test.ss
+++ b/collects/tests/mzscheme/contract-test.ss
@@ -6560,6 +6560,18 @@ so that propagation occurs.
      (and (exn? x)
           (regexp-match #rx"cannot set!" (exn-message x)))))
   
+  (contract-error-test
+   #'(begin
+       (eval '(module pce8-bug1 scheme/base
+                (require scheme/contract)
+                (define (f x) x)
+                (provide/contract [f (-> integer? integer? integer?)])))
+       (eval '(require 'pce8-bug1)))
+   (λ (x)
+     (printf ">> ~s\n" (exn-message x))
+     (and (exn? x)
+          (regexp-match #rx"pce8-bug" (exn-message x)))))
+  
   (contract-eval `(,test 'pos guilty-party (with-handlers ((void values)) (contract not #t 'pos 'neg))))
   
   (report-errs)