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

Add require of scheme/promise for force.

Browse Source 
Handle call-with-values more appropriately.
This commit is contained in:
Sam Tobin-Hochstadt 2008-07-07 16:43:12 -04:00
parent 4758c0b14d
commit 589ba9d77a
3 changed files with 31 additions and 31 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -7,7 +7,8 @@
(only-in scheme/list cons? take drop add-between last) (only-in scheme/list cons? take drop add-between last)
(only-in rnrs/lists-6 fold-left) (only-in rnrs/lists-6 fold-left)
'#%paramz '#%paramz
(only-in scheme/match/runtime match:error)) (only-in scheme/match/runtime match:error)
scheme/promise)
@ -415,17 +416,16 @@
[(-Input-Port Sym) -String])] [(-Input-Port Sym) -String])]
[copy-file (-> -Pathlike -Pathlike -Void)] [copy-file (-> -Pathlike -Pathlike -Void)]
[bytes->string/utf-8 (-> -Bytes -String)] [bytes->string/utf-8 (-> -Bytes -String)]
;; language ;; language
[(expand '(this-language)) [(expand '(this-language))
Sym Sym
string-constants/string-constant] string-constants/string-constant]
;; make-promise ;; make-promise
[(cadr (syntax->list (expand '(delay 3)))) [(cadr (syntax->list (expand '(delay 3))))
(-poly (a) (-> (-> a) (-Promise a))) (-poly (a) (-> (-> a) (-Promise a)))
scheme/promise] scheme/promise]
;; qq-append ;; qq-append
[(cadr (syntax->list (expand '`(,@'() 1)))) [(cadr (syntax->list (expand '`(,@'() 1))))
(-poly (a b) (-poly (a b)
(cl->* (cl->*

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

@ -522,21 +522,19 @@
(int-err "bad do-make-object : ~a" (syntax->datum #'args))] (int-err "bad do-make-object : ~a" (syntax->datum #'args))]
;; call-with-values ;; call-with-values
[(#%plain-app call-with-values prod con) [(#%plain-app call-with-values prod con)
(match-let* ([(tc-result: prod-t) (tc-expr #'prod)] (match-let* ([(tc-result: prod-t) (tc-expr #'prod)])
[(tc-result: con-t) (tc-expr #'con)]) (define (values-ty->list t)
(match (list prod-t con-t) (match t
[(list (Function: (list (arr: (list) vals #f #f _ _))) (Function: (list (arr: dom rng #f #f _ _)))) [(Values: ts) ts]
(=> unmatch) [_ (list t)]))
(match (list vals dom) (match prod-t
[(list (Values: v) (list t ...)) [(Function: (list (arr: (list) vals _ #f _ _)))
(if (subtypes v t) (tc/funapp #'con #'prod (tc-expr #'con) (map ret (values-ty->list vals)) expected)]
(ret rng) [_ (tc-error/expr #:return (ret (Un))
(unmatch))] "First argument to call with values must be a function that can accept no arguments, got: ~a"
[(list t1 (list t2)) prod-t)]))]
(if (subtype t1 t2) (ret rng) (unmatch))] ;; special cases for `values'
[_ (unmatch)])] ;; special case the single-argument version to preserve the effects
[_ (tc-error "Incorrect arguments to call with values: ~a ~a" prod-t con-t)]))]
;; special cases for `values'
[(#%plain-app values arg) (tc-expr #'arg)] [(#%plain-app values arg) (tc-expr #'arg)]
[(#%plain-app values . args) [(#%plain-app values . args)
(let ([tys (map tc-expr/t (syntax->list #'args))]) (let ([tys (map tc-expr/t (syntax->list #'args))])

24
collects/typed-scheme/private/type-effect-convenience.ss
View File

@ -213,17 +213,19 @@
(identifier? #'nm) (identifier? #'nm)
#`(list #'nm ty)] #`(list #'nm ty)]
[(e ty extra-mods ...) [(e ty extra-mods ...)
#'(list (let ([new-ns #'(let ([x (list (let ([new-ns
(let* ([ns (make-empty-namespace)]) (let* ([ns (make-empty-namespace)])
(namespace-attach-module (current-namespace) (namespace-attach-module (current-namespace)
'scheme/base 'scheme/base
ns) ns)
ns)]) ns)])
(parameterize ([current-namespace new-ns]) (parameterize ([current-namespace new-ns])
(namespace-require 'scheme/base) (namespace-require 'scheme/base)
(namespace-require 'extra-mods) ... (namespace-require 'extra-mods) ...
e)) e))
ty)])) ty)])
;(display x) (newline)
x)]))
(syntax->list #'(e ...))))])) (syntax->list #'(e ...))))]))
;; if t is of the form (Pair t* (Pair t* ... (Listof t*))) ;; if t is of the form (Pair t* (Pair t* ... (Listof t*)))