From 9e1c812b06a8d334ab4a3bc076e828b09d63cfe5 Mon Sep 17 00:00:00 2001
From: Sam Tobin-Hochstadt <samth@racket-lang.org>
Date: Fri, 2 May 2008 23:35:37 +0000
Subject: [PATCH] Improve the type of andmap. Steps toward reducing the number
 of initializations.

svn: r9612

original commit: fd44d9b01ff4d50042e757d9e2f76dae046237bd
---
 collects/typed-scheme/private/base-env.ss   |  5 ++++-
 collects/typed-scheme/private/base-types.ss | 12 ++++++++----
 collects/typed-scheme/typed-scheme.ss       |  3 +++
 3 files changed, 15 insertions(+), 5 deletions(-)

diff --git a/collects/typed-scheme/private/base-env.ss b/collects/typed-scheme/private/base-env.ss
index c5742d5e..61ded9a4 100644
--- a/collects/typed-scheme/private/base-env.ss
+++ b/collects/typed-scheme/private/base-env.ss
@@ -118,7 +118,10 @@
             [(-Port) -Sexp]
             [() -Sexp])]
      [ormap (-poly (a b) ((-> a b) (-lst a) . -> . b))]
-     [andmap (-poly (a b) ((-> a b) (-lst a) . -> . b))]
+     [andmap (-poly (a b c d e) 
+                    (cl->*
+                     ((-> a b) (-lst a) . -> . b)
+                     ((-> c d e) (-lst c) (-lst d) . -> . e)))]
      [newline (cl-> [() -Void]
                     [(-Port) -Void])]
      [not (-> Univ B)]
diff --git a/collects/typed-scheme/private/base-types.ss b/collects/typed-scheme/private/base-types.ss
index 736ad62d..8ee28858 100644
--- a/collects/typed-scheme/private/base-types.ss
+++ b/collects/typed-scheme/private/base-types.ss
@@ -13,6 +13,7 @@
 
 (require
  "extra-procs.ss"
+ "init-envs.ss"
  scheme/promise
  (except-in "type-rep.ss" make-arr)
  (only-in scheme/list cons?)
@@ -38,15 +39,18 @@
 ;; the initial type name environment - just the base types
 (define-syntax (define-tname-env stx)
   (syntax-case stx ()
-    [(_ var provider [nm ty] ...)
+    [(_ var provider initer [nm ty] ...)
      #`(begin
          (define-syntax nm (lambda (stx) (raise-syntax-error 'type-check "type name used out of context" stx))) ...
          (provide nm) ...
          (define-syntax provider (lambda (stx) #'(begin (provide nm) ...)))
          (provide provider)
-         (begin-for-syntax
+         (define-for-syntax (initer)
            (initialize-type-name-env
-            (list (list #'nm ty) ...))))]))
+            (list (list #'nm ty) ...)))
+         (begin-for-syntax 
+           ;(printf "phase is ~a~n" (syntax-local-phase-level))
+           (initer)))]))
 
 (define-syntax (define-other-types stx)
   (syntax-case stx ()
@@ -70,7 +74,7 @@
                   (provide provider requirer))))]))
 
 ;; the initial set of available type names
-(define-tname-env initial-type-names provide-tnames
+(define-tname-env initial-type-names provide-tnames init-tnames
   [Number N]
   [Integer -Integer]
   [Void -Void]
diff --git a/collects/typed-scheme/typed-scheme.ss b/collects/typed-scheme/typed-scheme.ss
index cb4f38d0..5ae7954d 100644
--- a/collects/typed-scheme/typed-scheme.ss
+++ b/collects/typed-scheme/typed-scheme.ss
@@ -22,6 +22,7 @@
           "private/effect-rep.ss"
           "private/rep-utils.ss"
           "private/type-contract.ss"
+          ;(only-in "private/base-types.ss" init-tnames)
           scheme/nest
           syntax/kerncase
           scheme/match))
@@ -46,6 +47,8 @@
 
 (define-for-syntax catch-errors? #f)
 
+;(begin (init-tnames))
+
 
 (define-syntax (module-begin stx)
   (define module-name (syntax-property stx 'enclosing-module-name))