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

more stuff compiles

Browse Source 
svn: r13952
This commit is contained in:
Sam Tobin-Hochstadt 2009-03-04 18:53:37 +00:00
parent 78fe918457
commit 37aa9746ea
4 changed files with 19 additions and 10 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -46,7 +46,7 @@
[null (-val null)] [null (-val null)]
[number? (make-pred-ty N)] [number? (make-pred-ty N)]
[char? (make-pred-ty -Char)] [char? (make-pred-ty -Char)]
[integer? (Univ . -> . B : (list (make-Latent-Restrict-Effect N)) (list (make-Latent-Remove-Effect -Integer)))] [integer? (Univ . -> . B : (-LFS (list (-filter N)) (list (-not-filter -Integer))))]
[exact-integer? (make-pred-ty -Integer)] [exact-integer? (make-pred-ty -Integer)]
[boolean? (make-pred-ty B)] [boolean? (make-pred-ty B)]
[add1 (cl->* (-> -Integer -Integer) [add1 (cl->* (-> -Integer -Integer)
@ -106,10 +106,7 @@
[((a b c . -> . c) c (-lst a) (-lst b)) c]))] [((a b c . -> . c) c (-lst a) (-lst b)) c]))]
[foldr (-poly (a b c) ((a b . -> . b) b (-lst a) . -> . b))] [foldr (-poly (a b c) ((a b . -> . b) b (-lst a) . -> . b))]
[filter (-poly (a b) (cl->* [filter (-poly (a b) (cl->*
((a . -> . B ((make-pred-ty a B b)
:
(list (make-Latent-Restrict-Effect b))
(list (make-Latent-Remove-Effect b)))
(-lst a) (-lst a)
. -> . . -> .
(-lst b)) (-lst b))

2
collects/typed-scheme/private/env-lang.ss
View File

@ -32,5 +32,5 @@
require require
(all-from-out scheme/base) (all-from-out scheme/base)
(for-syntax (for-syntax
(types convenience union) (types-out convenience union)
(all-from-out scheme/base))) (all-from-out scheme/base)))

13
collects/typed-scheme/types/abbrev.ss
View File

@ -198,6 +198,11 @@
[(Function: as) as])) [(Function: as) as]))
(make-Function (apply append (map funty-arities args)))) (make-Function (apply append (map funty-arities args))))
(define-syntax cl->
(syntax-parser
[(_ [(dom ...) rng] ...)
#'(cl->* (dom ... . -> . rng) ...)]))
(define-syntax (->key stx) (define-syntax (->key stx)
(syntax-parse stx (syntax-parse stx
[(_ ty:expr ... (~or (k:keyword kty:expr opt:boolean)) ... rng) [(_ ty:expr ... (~or (k:keyword kty:expr opt:boolean)) ... rng)
@ -213,11 +218,17 @@
(define (-struct name parent flds [proc #f] [poly #f] [pred #'dummy] [cert values]) (define (-struct name parent flds [proc #f] [poly #f] [pred #'dummy] [cert values])
(make-Struct name parent flds proc poly pred cert)) (make-Struct name parent flds proc poly pred cert))
(define (-filter t [p null] [i 0])
(make-LTypeFilter t p i))
(define (-not-filter t [p null] [i 0])
(make-LNotTypeFilter t p i))
(define make-pred-ty (define make-pred-ty
(case-lambda (case-lambda
[(in out t) [(in out t)
(->* in out : (-LFS (list (make-LTypeFilter t null 0)) (list (make-LNotTypeFilter t null 0))))] (->* in out : (-LFS (list (-filter t)) (list (-not-filter t))))]
[(t) (make-pred-ty (list Univ) B t)])) [(t) (make-pred-ty (list Univ) B t)]))

5
collects/typed-scheme/types/convenience.ss
View File

@ -1,7 +1,7 @@
#lang scheme/base #lang scheme/base
(require "../utils/utils.ss") (require "../utils/utils.ss")
(require (rep type-rep) (require (rep type-rep filter-rep object-rep)
(utils tc-utils) (utils tc-utils)
"abbrev.ss" "abbrev.ss"
(types comparison printer union subtype utils) (types comparison printer union subtype utils)
@ -15,7 +15,8 @@
(provide (all-defined-out) (provide (all-defined-out)
(all-from-out "abbrev.ss") (all-from-out "abbrev.ss")
;; these should all eventually go away ;; these should all eventually go away
make-Name make-ValuesDots make-Function) make-Name make-ValuesDots make-Function
(rep-out filter-rep object-rep))
(define (one-of/c . args) (define (one-of/c . args)
(apply Un (map -val args))) (apply Un (map -val args)))