Add smart constructors for Result and tc-result.
This commit is contained in:
Eric Dobson
parent
418ee07f4e
commit
4a7dd75ffd
|
|
@ -77,16 +77,16 @@
|
|||
[(tc-results: ts fs os dty dbound)
|
||||
(make-ValuesDots
|
||||
(for/list ([t (in-list ts)] [f (in-list fs)] [o (in-list os)])
|
||||
(make-Result (abstract-type arg-names keys t)
|
||||
(abstract-filter arg-names keys f)
|
||||
(abstract-object arg-names keys o)))
|
||||
(-result (abstract-type arg-names keys t)
|
||||
(abstract-filter arg-names keys f)
|
||||
(abstract-object arg-names keys o)))
|
||||
dty dbound)]
|
||||
[(tc-results: ts fs os)
|
||||
(make-Values
|
||||
(for/list ([t (in-list ts)] [f (in-list fs)] [o (in-list os)])
|
||||
(make-Result (abstract-type arg-names keys t)
|
||||
(abstract-filter arg-names keys f)
|
||||
(abstract-object arg-names keys o))))]))
|
||||
(-result (abstract-type arg-names keys t)
|
||||
(abstract-filter arg-names keys f)
|
||||
(abstract-object arg-names keys o))))]))
|
||||
|
||||
;; Abstract all given id objects into index objects (keys) in
|
||||
;; the given type
|
||||
|
|
|
|||
|
|
@ -103,7 +103,11 @@
|
|||
;; Results
|
||||
(define/cond-contract (-result t [f -top-filter] [o -empty-obj])
|
||||
(c:->* (Type/c) (FilterSet? Object?) Result?)
|
||||
(make-Result t f o))
|
||||
(cond
|
||||
[(or (equal? t -Bottom) (equal? f -bot-filter))
|
||||
(make-Result -Bottom -bot-filter o)]
|
||||
[else
|
||||
(make-Result t f o)]))
|
||||
|
||||
;; Filters
|
||||
(define/decl -top (make-Top))
|
||||
|
|
|
|||
|
|
@ -66,36 +66,46 @@
|
|||
[(_ tp fp op) (Values: (list (Result: tp fp op) (... ...)))]
|
||||
[(_ tp fp op dty dbound) (ValuesDots: (list (Result: tp fp op) (... ...)) dty dbound)]))
|
||||
|
||||
;; make-tc-result*: Type/c FilterSet/c Object? -> tc-result?
|
||||
;; Smart constructor for a tc-result.
|
||||
(define (-tc-result type filter object)
|
||||
(cond
|
||||
[(or (equal? type -Bottom) (equal? filter -bot-filter))
|
||||
(make-tc-result -Bottom -bot-filter object)]
|
||||
[else
|
||||
(make-tc-result type filter object)]))
|
||||
|
||||
|
||||
;; convenience function for returning the result of typechecking an expression
|
||||
(define ret
|
||||
(case-lambda [(t)
|
||||
(make-tc-results
|
||||
(cond [(Type/c? t)
|
||||
(list (make-tc-result t -top-filter -empty-obj))]
|
||||
(list (-tc-result t -top-filter -empty-obj))]
|
||||
[else
|
||||
(for/list ([i (in-list t)])
|
||||
(make-tc-result i -top-filter -empty-obj))])
|
||||
(-tc-result i -top-filter -empty-obj))])
|
||||
#f)]
|
||||
[(t f)
|
||||
(make-tc-results
|
||||
(if (Type/c? t)
|
||||
(list (make-tc-result t f -empty-obj))
|
||||
(list (-tc-result t f -empty-obj))
|
||||
(for/list ([i (in-list t)] [f (in-list f)])
|
||||
(make-tc-result i f -empty-obj)))
|
||||
(-tc-result i f -empty-obj)))
|
||||
#f)]
|
||||
[(t f o)
|
||||
(make-tc-results
|
||||
(if (and (list? t) (list? f) (list? o))
|
||||
(map make-tc-result t f o)
|
||||
(list (make-tc-result t f o)))
|
||||
(map -tc-result t f o)
|
||||
(list (-tc-result t f o)))
|
||||
#f)]
|
||||
[(t f o dty)
|
||||
(int-err "ret used with dty without dbound")]
|
||||
[(t f o dty dbound)
|
||||
(make-tc-results
|
||||
(if (and (list? t) (list? f) (list? o))
|
||||
(map make-tc-result t f o)
|
||||
(list (make-tc-result t f o)))
|
||||
(map -tc-result t f o)
|
||||
(list (-tc-result t f o)))
|
||||
(cons dty dbound))]))
|
||||
|
||||
;(trace ret)
|
||||
|
|
|
|||
|
|
@ -807,7 +807,7 @@
|
|||
[tc-e/t (let* ([z 1]
|
||||
[p? (lambda: ([x : Any]) z)])
|
||||
(lambda: ([x : Any]) (if (p? x) x 12)))
|
||||
(t:-> Univ Univ)]
|
||||
(t:-> Univ Univ : (-FS (-not-filter (-val #f) 0) (-filter (-val #f) 0)))]
|
||||
|
||||
[tc-e (not 1)
|
||||
#:ret (ret -Boolean -false-filter)]
|
||||
|
|
@ -1025,14 +1025,14 @@
|
|||
(if (list? x)
|
||||
(add1 x)
|
||||
12)))
|
||||
#:ret (ret -PosByte)]
|
||||
#:ret (ret -PosByte -true-filter)]
|
||||
|
||||
[tc-err (let*: ([x : Any 1]
|
||||
[f : (-> Void) (lambda () (set! x 'foo))])
|
||||
(if (number? x)
|
||||
(begin (f) (add1 x))
|
||||
12))
|
||||
#:ret (ret -PosByte)]
|
||||
#:ret (ret -PosByte -true-filter)]
|
||||
|
||||
[tc-err (ann 3 (Rec a a))]
|
||||
[tc-err (ann 3 (Rec a (U a 3)))]
|
||||
|
|
@ -1168,7 +1168,7 @@
|
|||
(tc-e (or (string->number "7") 7)
|
||||
#:ret (ret -Number -true-filter))
|
||||
[tc-e (let ([x 1]) (if x x (add1 x)))
|
||||
#:ret (ret -One -top-filter)]
|
||||
#:ret (ret -One -true-filter)]
|
||||
[tc-e (let: ([x : (U (Vectorof Integer) String) (vector 1 2 3)])
|
||||
(if (vector? x) (vector-ref x 0) (string-length x)))
|
||||
-Integer]
|
||||
|
|
@ -2102,9 +2102,9 @@
|
|||
(struct-type-info struct:arity-at-least)])
|
||||
(getter (arity-at-least 3) 0))
|
||||
Univ]
|
||||
[tc-e (assert (let-values ([(type _) (struct-info (arity-at-least 3))])
|
||||
[tc-e/t (assert (let-values ([(type _) (struct-info (arity-at-least 3))])
|
||||
type))
|
||||
(make-StructTypeTop)]
|
||||
(make-StructTypeTop)]
|
||||
[tc-err (let-values ([(name _1 _2 getter setter _3 _4 _5)
|
||||
(struct-type-info struct:arity-at-least)])
|
||||
(getter 'bad 0))
|
||||
|
|
@ -2123,7 +2123,7 @@
|
|||
[tc-e (touch (future (λ () "foo"))) -String]
|
||||
[tc-e (current-future) (-opt (-future Univ))]
|
||||
[tc-e (add1 (processor-count)) -PosInt]
|
||||
[tc-e (assert (current-future) future?) (-future Univ)]
|
||||
[tc-e/t (assert (current-future) future?) (-future Univ)]
|
||||
[tc-e (futures-enabled?) -Boolean]
|
||||
[tc-e (place-enabled?) -Boolean]
|
||||
[tc-e (dynamic-place "a.rkt" 'a #:at #f) -Place]
|
||||
|
|
@ -2698,6 +2698,16 @@
|
|||
#:ret (ret -String)
|
||||
#:expected (ret -String -no-filter -no-obj)]
|
||||
|
||||
[tc-e/t
|
||||
(lambda (x)
|
||||
(unless (number? x)
|
||||
(error 'foo)))
|
||||
(t:-> Univ -Void : (-FS (-filter -Number 0) (-filter -Number 0)))]
|
||||
|
||||
[tc-e
|
||||
(let ([x : (U) (error 'fail)])
|
||||
(if (number? x) (add1 x) 0))
|
||||
-Bottom]
|
||||
|
||||
)
|
||||
(test-suite
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user