suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Remove tool.

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

svn: r8885
This commit is contained in:
Sam Tobin-Hochstadt 2008-03-04 23:09:45 +00:00
parent 8b0a675b9a
commit f7d6b01d26
4 changed files with 14 additions and 52 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
collects/typed-scheme/private/base-env.ss
View File

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

2
collects/typed-scheme/private/syntax-traversal.ss
View File

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

14
collects/typed-scheme/private/tc-app-unit.ss
View File

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

49
collects/typed-scheme/private/tool.ss
View File

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