diff --git a/collects/typed-scheme/private/base-env.ss b/collects/typed-scheme/private/base-env.ss index 514259e871..5891dd3eab 100644 --- a/collects/typed-scheme/private/base-env.ss +++ b/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))] diff --git a/collects/typed-scheme/private/syntax-traversal.ss b/collects/typed-scheme/private/syntax-traversal.ss index e2cfe31685..dcdb5b9da7 100644 --- a/collects/typed-scheme/private/syntax-traversal.ss +++ b/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)]) diff --git a/collects/typed-scheme/private/tc-app-unit.ss b/collects/typed-scheme/private/tc-app-unit.ss index 21c33a2b9b..bd73e3dd54 100644 --- a/collects/typed-scheme/private/tc-app-unit.ss +++ b/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))))) diff --git a/collects/typed-scheme/private/tool.ss b/collects/typed-scheme/private/tool.ss deleted file mode 100644 index dc2e24020a..0000000000 --- a/collects/typed-scheme/private/tool.ss +++ /dev/null @@ -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%))))))) - )