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

Improve the type of andmap.

Browse Source 
Steps toward reducing the number of initializations.

svn: r9612
This commit is contained in:
Sam Tobin-Hochstadt 2008-05-02 23:35:37 +00:00
parent 921ef6cfcb
commit fd44d9b01f
4 changed files with 16 additions and 6 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -118,7 +118,10 @@
[(-Port) -Sexp] [(-Port) -Sexp]
[() -Sexp])] [() -Sexp])]
[ormap (-poly (a b) ((-> a b) (-lst a) . -> . b))] [ormap (-poly (a b) ((-> a b) (-lst a) . -> . b))]
[andmap (-poly (a b) ((-> a b) (-lst a) . -> . b))] [andmap (-poly (a b c d e)
(cl->*
((-> a b) (-lst a) . -> . b)
((-> c d e) (-lst c) (-lst d) . -> . e)))]
[newline (cl-> [() -Void] [newline (cl-> [() -Void]
[(-Port) -Void])] [(-Port) -Void])]
[not (-> Univ B)] [not (-> Univ B)]

12
collects/typed-scheme/private/base-types.ss
View File

@ -13,6 +13,7 @@
(require (require
"extra-procs.ss" "extra-procs.ss"
"init-envs.ss"
scheme/promise scheme/promise
(except-in "type-rep.ss" make-arr) (except-in "type-rep.ss" make-arr)
(only-in scheme/list cons?) (only-in scheme/list cons?)
@ -38,15 +39,18 @@
;; the initial type name environment - just the base types ;; the initial type name environment - just the base types
(define-syntax (define-tname-env stx) (define-syntax (define-tname-env stx)
(syntax-case stx () (syntax-case stx ()
[(_ var provider [nm ty] ...) [(_ var provider initer [nm ty] ...)
#`(begin #`(begin
(define-syntax nm (lambda (stx) (raise-syntax-error 'type-check "type name used out of context" stx))) ... (define-syntax nm (lambda (stx) (raise-syntax-error 'type-check "type name used out of context" stx))) ...
(provide nm) ... (provide nm) ...
(define-syntax provider (lambda (stx) #'(begin (provide nm) ...))) (define-syntax provider (lambda (stx) #'(begin (provide nm) ...)))
(provide provider) (provide provider)
(begin-for-syntax (define-for-syntax (initer)
(initialize-type-name-env (initialize-type-name-env
(list (list #'nm ty) ...))))])) (list (list #'nm ty) ...)))
(begin-for-syntax
;(printf "phase is ~a~n" (syntax-local-phase-level))
(initer)))]))
(define-syntax (define-other-types stx) (define-syntax (define-other-types stx)
(syntax-case stx () (syntax-case stx ()
@ -70,7 +74,7 @@
(provide provider requirer))))])) (provide provider requirer))))]))
;; the initial set of available type names ;; the initial set of available type names
(define-tname-env initial-type-names provide-tnames (define-tname-env initial-type-names provide-tnames init-tnames
[Number N] [Number N]
[Integer -Integer] [Integer -Integer]
[Void -Void] [Void -Void]

3
collects/typed-scheme/typed-scheme.ss
View File

@ -22,6 +22,7 @@
"private/effect-rep.ss" "private/effect-rep.ss"
"private/rep-utils.ss" "private/rep-utils.ss"
"private/type-contract.ss" "private/type-contract.ss"
;(only-in "private/base-types.ss" init-tnames)
scheme/nest scheme/nest
syntax/kerncase syntax/kerncase
scheme/match)) scheme/match))
@ -46,6 +47,8 @@
(define-for-syntax catch-errors? #f) (define-for-syntax catch-errors? #f)
;(begin (init-tnames))
(define-syntax (module-begin stx) (define-syntax (module-begin stx)
(define module-name (syntax-property stx 'enclosing-module-name)) (define module-name (syntax-property stx 'enclosing-module-name))