Remove tool.

Improve error message source.
Add `build-list'
Don't give internal error when inference returns a bad result.

svn: r8885

collects/typed-scheme/private/base-env.ss

@@ -189,6 +189,7 @@
      [vector-ref 
       (make-Poly (list 'a) ((make-Vector (-v a)) N . -> . (-v a)))]
      [build-vector (-poly (a) (N (N . -> . a) . -> . (make-Vector a)))]
+     [build-list (-poly (a) (N (N . -> . a) . -> . (-lst a)))]
      [reverse (make-Poly '(a) (-> (make-lst (-v a)) (make-lst (-v a))))]
      [append (-poly (a) (->* (list) (-lst a) (-lst a)))]
      [length (make-Poly '(a) (-> (make-lst (-v a)) N))]

collects/typed-scheme/private/syntax-traversal.ss

@@ -41,7 +41,7 @@
 (define (look-for-in-orig orig expanded lookfor)
   (define src (syntax-source orig))
   ;; we just might get a lookfor that is already in the original
-  (if (eq? src (syntax-source lookfor))
+  (if (syntax-original? lookfor)
     lookfor
     (let ([enclosing (enclosing-syntaxes-with-source expanded lookfor src)]
           [syntax-locs (make-hash-table 'equal)])

collects/typed-scheme/private/tc-app-unit.ss

@@ -234,10 +234,20 @@
                   => (lambda (substitution)
                        (let* ([s (lambda (t) (subst-all substitution t))]
                               [new-doms* (map s (car doms*))])
-                         (unless (andmap subtype argtypes new-doms*)
+                         (if (andmap subtype argtypes new-doms*)
+                             (ret (subst-all substitution (car rngs*)))
+                             ;; FIXME
+                             ;; should be an error here, something went horribly wrong!!!
+                             (loop (cdr doms*) (cdr rngs*)))))]
+                             #|
+                           (printf "subst is:~a~nret is: ~a~nvars is: ~a~nresult is:~a~n" substitution (car rngs*) vars 
+                                   (subst-all substitution (car rngs*)))
+                           (printf "new-doms*: ~a~n" new-doms*)
+                           (printf "orig doms* is: ~a~n" (car doms*))
+                           (printf "argtypes: ~a~n" argtypes)
                            (int-err "Inconsistent substitution - arguments not subtypes")))
                        #;(printf "subst is:~a~nret is: ~a~nvars is: ~a~n" substitution (car rngs*) vars)
-                       (ret (subst-all substitution (car rngs*))))]
+                       )]|#
                  [else (loop (cdr doms*) (cdr rngs*))]))]
         ;; polymorphic varargs
         [(tc-result: (Poly: vars (Function: (list (arr: dom rng rest thn-eff els-eff)))))

collects/typed-scheme/private/tool.ss

@@ -1,49 +0,0 @@
-(module tool mzscheme
-  (require (lib "unit.ss")
-	   (lib "class.ss")
-	   (lib "tool.ss" "drscheme")
-           (lib "string-constant.ss" "string-constants")
-           (prefix r: "../typed-reader.ss"))
-  
-
-  (provide tool@)
-  
-  (define tool@
-    (unit
-      (import drscheme:tool^)
-      (export drscheme:tool-exports^)
-      
-      (define mbl% (drscheme:language:module-based-language->language-mixin
-		    (drscheme:language:simple-module-based-language->module-based-language-mixin 
-		     drscheme:language:simple-module-based-language%)))
-      
-      (define planet-module '(planet "typed-scheme.ss" ("plt" "typed-scheme.plt" 3)))
-
-      (define (typed-scheme-language% cl%)
-	(class* cl% (drscheme:language:simple-module-based-language<%>)
-	  (define/override (get-language-numbers)
-	    '(1000 -401))
-	  (define/override (get-language-name) "Typed Scheme")
-	  (define/override (get-language-position)
-	    (list (string-constant experimental-languages) "Typed Scheme"))
-	  (define/override (get-module) planet-module)
-          (define/override (get-reader) 
-	    (lambda (src port)
-       	      (let ([v (r:read-syntax src port)])
-                (if (eof-object? v)
-                  v
-                  (namespace-syntax-introduce v)))))
- 	  (define/override (get-one-line-summary)
-	    "Scheme with types!")
-          (define/override (get-language-url) "http://www.ccs.neu.edu/~samth/typed-scheme.html")
-	  (define/override (enable-macro-stepper?) #t)
-          (define/override (use-namespace-require/copy?) #f)
-	  (super-new [module (get-module)] [language-position (get-language-position)])))
-      
-      (define (phase1) (void))
-      (define (phase2)
-        (drscheme:language-configuration:add-language 
-	 (make-object (typed-scheme-language%
-		       ((drscheme:language:get-default-mixin) 
-			mbl%)))))))
-  )