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 rnrs/lists-6 fold-left)
'#%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])]
[copy-file (-> -Pathlike -Pathlike -Void)]
[bytes->string/utf-8 (-> -Bytes -String)]
;; language
[(expand '(this-language))
Sym
string-constants/string-constant]
;; make-promise
;; make-promise
[(cadr (syntax->list (expand '(delay 3))))
(-poly (a) (-> (-> a) (-Promise a)))
scheme/promise]
;; qq-append
;; qq-append
[(cadr (syntax->list (expand '`(,@'() 1))))
(-poly (a b)
(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))]
;; call-with-values
[(#%plain-app call-with-values prod con)
(match-let* ([(tc-result: prod-t) (tc-expr #'prod)]
[(tc-result: con-t) (tc-expr #'con)])
(match (list prod-t con-t)
[(list (Function: (list (arr: (list) vals #f #f _ _))) (Function: (list (arr: dom rng #f #f _ _))))
(=> unmatch)
(match (list vals dom)
[(list (Values: v) (list t ...))
(if (subtypes v t)
(ret rng)
(unmatch))]
[(list t1 (list t2))
(if (subtype t1 t2) (ret rng) (unmatch))]
[_ (unmatch)])]
[_ (tc-error "Incorrect arguments to call with values: ~a ~a" prod-t con-t)]))]
;; special cases for `values'
(match-let* ([(tc-result: prod-t) (tc-expr #'prod)])
(define (values-ty->list t)
(match t
[(Values: ts) ts]
[_ (list t)]))
(match prod-t
[(Function: (list (arr: (list) vals _ #f _ _)))
(tc/funapp #'con #'prod (tc-expr #'con) (map ret (values-ty->list vals)) expected)]
[_ (tc-error/expr #:return (ret (Un))
"First argument to call with values must be a function that can accept no arguments, got: ~a"
prod-t)]))]
;; special cases for `values'
;; special case the single-argument version to preserve the effects
[(#%plain-app values arg) (tc-expr #'arg)]
[(#%plain-app values . 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)
#`(list #'nm ty)]
[(e ty extra-mods ...)
#'(list (let ([new-ns
(let* ([ns (make-empty-namespace)])
(namespace-attach-module (current-namespace)
'scheme/base
ns)
ns)])
(parameterize ([current-namespace new-ns])
(namespace-require 'scheme/base)
(namespace-require 'extra-mods) ...
e))
ty)]))
#'(let ([x (list (let ([new-ns
(let* ([ns (make-empty-namespace)])
(namespace-attach-module (current-namespace)
'scheme/base
ns)
ns)])
(parameterize ([current-namespace new-ns])
(namespace-require 'scheme/base)
(namespace-require 'extra-mods) ...
e))
ty)])
;(display x) (newline)
x)]))
(syntax->list #'(e ...))))]))
;; if t is of the form (Pair t* (Pair t* ... (Listof t*)))