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

strnum? works

Browse Source 
original commit: 83c16719725e6aa423e9f2ef4adab8483def4436
This commit is contained in:
Sam Tobin-Hochstadt 2010-04-27 10:16:21 -04:00
parent 1505c7c3de
commit f792d08edb
5 changed files with 34 additions and 22 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
collects/tests/typed-scheme/succeed/simple-or.ss
View File

@ -1,11 +1,14 @@
#lang typed/scheme
(define: x : Any 7)
(define: (f [x : (U String Number)]) : Number 0)
;(let ([tmp (number? x)]) (if tmp tmp (string? x)))
(let ([tmp (number? x)]) (if tmp tmp (string? x)))
(if (let ([tmp (number? x)])
(if tmp tmp (string? x)))
(f x)
0)
0)
(: strnum? (Any -> Boolean : (U String Number)))
(define (strnum? x)
(or (string? x) (number? x)))

2
collects/typed-scheme/typecheck/tc-expr-unit.ss
View File

@ -176,7 +176,7 @@
(ret (subber subst-type ts) (subber subst-filter-set fs) (subber subst-object os) dt db)]
[t (sub-one subst-type t)])
r))
(let ([tr1 (debug maybe-abstract tr1)])
(let ([tr1 (maybe-abstract tr1)])
(match* (tr1 expected)
;; these two have to be first so that errors can be allowed in cases where multiple values are expected
[((tc-result1: (? (lambda (t) (type-equal? t (Un))))) (tc-results: ts2 (NoFilter:) (NoObject:)))

14
collects/typed-scheme/typecheck/tc-if.ss
View File

@ -50,10 +50,10 @@
(env-props env-els))]
[(tc-results: ts fs2 os2) (with-lexical-env env-thn (tc thn (unbox flag+)))]
[(tc-results: us fs3 os3) (with-lexical-env env-els (tc els (unbox flag-)))])
;(printf "old thn-props: ~a\n" (env-props (lexical-env)))
;(printf "fs+: ~a~n" fs+)
;(printf "thn-props: ~a~n" (env-props env-thn))
;(printf "new-thn-props: ~a~n" new-thn-props)
(printf "old els-props: ~a\n" (env-props (lexical-env)))
(printf "fs-: ~a~n" fs-)
(printf "els-props: ~a~n" (env-props env-els))
(printf "new-els-props: ~a~n" new-els-props)
;; if we have the same number of values in both cases
(cond [(= (length ts) (length us))
(let ([r (combine-results
@ -65,11 +65,11 @@
[(_ (NoFilter:))
(-FS -top -top)]
[((FilterSet: f2+ f2-) (FilterSet: f3+ f3-))
(-FS (-or (apply -and fs+ f2+ new-thn-props) (-and fs- f3+))
(-or (apply -and fs+ f2- new-thn-props) (-and fs- f3-)))])]
(-FS (-or (apply -and fs+ f2+ new-thn-props) (apply -and fs- f3+ new-els-props))
(-or (apply -and fs+ f2- new-thn-props) (apply -and fs- f3- new-els-props)))])]
[type (Un t2 t3)]
[object (if (object-equal? o2 o3) o2 (make-Empty))])
;(printf "result filter is: ~a\n" filter)
(printf "result filter is: ~a\n" filter)
(ret type filter object))))])
(if expected (check-below r expected) r))]
;; special case if one of the branches is unreachable

4
collects/typed-scheme/typecheck/tc-let-unit.ss
View File

@ -34,7 +34,9 @@
([r (in-list results)]
[names (in-list namess)])
(match r
[(tc-results: ts (FilterSet: fs+ fs-) os)
[(tc-results: ts (FilterSet: fs+ fs-) os)
(printf "f+: ~a~n" fs+)
(printf "f-: ~a~n" fs-)
(values ts
(apply append
(for/list ([n names]

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

@ -101,7 +101,9 @@
(subtype t1 t2))]
[(_ _) #f])))
(define (compact props)
;; props : propositions to compress
;; or? : is this or OrFilter (alternative is AndFilter)
(define (compact props or?)
(define tf-map (make-hash))
(define ntf-map (make-hash))
(let loop ([props props] [others null])
@ -110,18 +112,17 @@
(for/list ([v (in-dict-values tf-map)]) v)
(for/list ([v (in-dict-values ntf-map)]) v))
(match (car props)
[(and p (TypeFilter: t1 f1 x))
[(and p (TypeFilter: t1 f1 x) (? (lambda _ or?)))
(hash-update! tf-map
(list f1 (hash-id x))
(match-lambda [(TypeFilter: t2 _ _) (make-TypeFilter (Un t1 t2) f1 x)]
[p (int-err "got something that isn't a typefilter ~a" p)])
p)
(loop (cdr props) others)]
#;
[(and p (NotTypeFilter: t1 f1 x))
[(and p (NotTypeFilter: t1 f1 x) (? (lambda _ (not or?))))
(hash-update! ntf-map
(list f1 (hash-id x))
(match-lambda [(NotTypeFilter: t2 _ _) (make-NotTypeFilter (restrict t1 t2) f1 x)]
(match-lambda [(NotTypeFilter: t2 _ _) (make-NotTypeFilter (Un t1 t2) f1 x)]
[p (int-err "got something that isn't a nottypefilter ~a" p)])
p)
(loop (cdr props) others)]
@ -144,7 +145,7 @@
(match result
[(list) -bot]
[(list f) f]
[_ (distribute (compact result))])
[_ (distribute (compact result #t))])
(match (car fs)
[(and t (Top:)) t]
[(OrFilter: fs*) (loop (append fs* (cdr fs)) result)]
@ -153,7 +154,7 @@
(cond [(for/or ([f (in-list (append (cdr fs) result))])
(opposite? f t))
-top]
[(for/or ([f (in-list result)]) (or (filter-equal? f t) (implied-atomic? t f)))
[(for/or ([f (in-list result)]) (or (filter-equal? f t) (implied-atomic? f t)))
(loop (cdr fs) result)]
[else
(loop (cdr fs) (cons t result))])]))))
@ -169,10 +170,16 @@
-bot
(if (filter-equal? f1 f2)
f1
(make-AndFilter (list f1 f2))))]
[_ (make-AndFilter result)])
(make-AndFilter (compact (list f1 f2) #f))))]
[_ (make-AndFilter (compact result #f))])
(match (car fs)
[(and t (Bot:)) t]
[(AndFilter: fs*) (loop (cdr fs) (append fs* result))]
[(Top:) (loop (cdr fs) result)]
[t (loop (cdr fs) (cons t result))]))))
[t (cond [(for/or ([f (in-list (append (cdr fs) result))])
(opposite? f t))
-bot]
[(for/or ([f (in-list result)]) (or (filter-equal? f t) (implied-atomic? t f)))
(loop (cdr fs) result)]
[else
(loop (cdr fs) (cons t result))])]))))