Improve the type of andmap.

Steps toward reducing the number of initializations.

svn: r9612

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)]

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]

collects/typed-scheme/private/type-alias-env.ss

@@ -31,7 +31,7 @@
 
 (define (register-resolved-type-alias id ty)
   #;(when (eq? 'Number (syntax-e id))
-      (printf "registering type ~a ~a~n~a~n" id (syntax-e id) ty))
+    (printf "registering type ~a ~a~n~a~n" id (syntax-e id) ty))
   (mapping-put! id (make-resolved ty)))
 
 (define (lookup-type-alias id parse-type [k (lambda () (tc-error "Unknown type alias: ~a" (syntax-e id)))])

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))