diff --git a/collects/tests/typed-scheme/fail/dead-substruct.rkt b/collects/tests/typed-scheme/fail/dead-substruct.rkt new file mode 100644 index 00000000..eed75288 --- /dev/null +++ b/collects/tests/typed-scheme/fail/dead-substruct.rkt @@ -0,0 +1,16 @@ +#; +(exn-pred 1) +#lang typed/scheme + +(define-struct: parent ((x : Integer))) +(define-struct: (child1 parent) ((y : Integer))) +(define-struct: (child2 parent) ((y : Float))) + +(: f (parent -> Integer)) +(define (f x) + (cond [(child1? x) (+ "a" "b")] ; rhs was considered dead code + [(child2? x) 2] + [else (error "eh?")])) + +(f (make-child1 1 2)) +(f (make-child2 1 2.0)) diff --git a/collects/tests/typed-scheme/optimizer/generic/dead-substructs.rkt b/collects/tests/typed-scheme/optimizer/generic/dead-substructs.rkt new file mode 100644 index 00000000..a01a5e5b --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/generic/dead-substructs.rkt @@ -0,0 +1,17 @@ +#lang typed/scheme #:optimize + +;; originally from nucleic3 +;; cond on substructs, branches were considered dead + +(define-struct: parent ((x : Integer))) +(define-struct: (child1 parent) ((y : Integer))) +(define-struct: (child2 parent) ((y : Float))) + +(: f (parent -> Integer)) +(define (f x) + (cond [(child1? x) 1] + [(child2? x) 2] + [else (error "eh?")])) + +(f (make-child1 1 2)) +(f (make-child2 1 2.0)) diff --git a/collects/tests/typed-scheme/succeed/priority-queue.scm b/collects/tests/typed-scheme/succeed/priority-queue.scm index 091a284d..9454a314 100644 --- a/collects/tests/typed-scheme/succeed/priority-queue.scm +++ b/collects/tests/typed-scheme/succeed/priority-queue.scm @@ -65,15 +65,15 @@ ;; "bug" found - handling of empty heaps (pdefine: (a) (find-min [pq : (priority-queue a)]) : a (let ([h (heap pq)]) - (if (heap:heap-node? h) - (elm (heap:find-min h)) - (error "priority queue empty")))) + (if (heap:empty? h) + (error "priority queue empty") + (elm (heap:find-min h))))) (pdefine: (a) (find-min-priority [pq : (priority-queue a)]) : number (let ([h (heap pq)]) - (if (heap:heap-node? h) - (pri (heap:find-min h)) - (error "priority queue empty")))) + (if (heap:empty? h) + (error "priority queue empty") + (pri (heap:find-min h))))) (pdefine: (a) (insert [x : a] [p : number] [pq : (priority-queue a)]) : (priority-queue a) (make (heap:insert (cons p x) (heap pq)))) @@ -84,9 +84,9 @@ (pdefine: (a) (delete-min [pq : (priority-queue a)]) : (priority-queue a) (let ([h (heap pq)]) - (if (heap:heap-node? h) - (make (heap:delete-min h)) - (error "priority queue empty")))) + (if (heap:empty? h) + (error "priority queue empty") + (make (heap:delete-min h))))) (pdefine: (a) (size [pq : (priority-queue a)]) : number diff --git a/collects/typed-scheme/types/remove-intersect.rkt b/collects/typed-scheme/types/remove-intersect.rkt index 074af5da..64d55e8f 100644 --- a/collects/typed-scheme/types/remove-intersect.rkt +++ b/collects/typed-scheme/types/remove-intersect.rkt @@ -24,7 +24,8 @@ [(list (F: _) _) #t] [(list _ (F: _)) #t] [(list (Name: n) (Name: n*)) - (overlap (resolve-once t1) (resolve-once t2))] + (or (free-identifier=? n n*) + (overlap (resolve-once t1) (resolve-once t2)))] [(list (? Mu?) _) (overlap (unfold t1) t2)] [(list _ (? Mu?)) (overlap t1 (unfold t2))] [(list (Union: e) t) @@ -73,8 +74,8 @@ (and t2 (Struct: n* p* flds* _ _ _ _ _))) (let ([p1 (if (Name? p) (resolve-name p) p)] [p2 (if (Name? p*) (resolve-name p*) p*)]) - (or (overlap t1 p2) - (overlap t2 p1) + (or (and p2 (overlap t1 p2)) + (and p1 (overlap t2 p1)) (and (= (length flds) (length flds*)) (for/and ([f flds] [f* flds*]) (match* (f f*)