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

Further fixes in overlap checking.

Browse Source 
Rhss of code dispatching on overlapping structs are no longer
considered dead, and as such, are now typechecked.

Had to fix a test that passed only because some not-really-dead code
was not being typechecked.
(cherry picked from commit 4d5b50dee9e04aee167a7e04fbbe23526131fcad)

original commit: e0614cfed24dfc9e7f89b9a8c77e7930695b0269
This commit is contained in:
Vincent St-Amour 2010-07-16 18:16:51 -04:00 committed by Eli Barzilay
parent 0161cda2d4
commit b71fbae36a
5 changed files with 147 additions and 12 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

16
collects/tests/typed-scheme/fail/dead-substruct.rkt Normal file
View File

@ -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))

17
collects/tests/typed-scheme/optimizer/generic/dead-substructs.rkt Normal file
View File

@ -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))

18
collects/tests/typed-scheme/succeed/priority-queue.scm
View File

@ -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

101
collects/tests/typed-scheme/xfail/priority-queue.scm Normal file
View File

@ -0,0 +1,101 @@
#lang typed-scheme
;;; priority-queue.scm -- Jens Axel Søgaard
;;; PURPOSE
; This file implements priority queues on top of
; a heap library.
(define-type-alias number Number)
(define-type-alias boolean Boolean)
(define-type-alias symbol Symbol)
(define-type-alias top Any)
(define-type-alias list-of Listof)
(require (prefix-in heap: "leftist-heap.ss")
(except-in (lib "67.ss" "srfi") number-compare current-compare =? <?)
(only-in "leftist-heap.ss" comparator))
(require/typed number-compare (number number -> number) (lib "67.ss" "srfi"))
(require/typed current-compare (-> (top top -> number)) (lib "67.ss" "srfi"))
(require/typed =? ((top top -> number) top top -> boolean) (lib "67.ss" "srfi"))
(require/typed <? ((top top -> number) top top -> boolean) (lib "67.ss" "srfi"))
; a priority-queue is a heap of (cons <priority> <element>)
(define-type-alias (elem a) (cons number a))
(define-typed-struct (a) priority-queue ([heap : (heap:Heap (elem a))]))
(define-type-alias (pqh a) (heap:Heap (elem a)))
; conveniences
(pdefine: (a) (heap [pq : (priority-queue a)]) : (pqh a) (priority-queue-heap pq))
(pdefine: (a) (pri [p : (elem a)]) : number (car p))
(pdefine: (a) (elm [p : (elem a)]) : a (cdr p))
(pdefine: (a) (make [h : (pqh a)]) : (priority-queue a) (make-priority-queue h))
; sort after priority
; TODO: and then element?
(pdefine: (a) (compare [p1 : (elem a)] [p2 : (elem a)]) : number
(number-compare (pri p1) (pri p2)))
;;; OPERATIONS
(define: (num-elems [h : (heap:Heap (cons number number))]) : (list-of (cons number number))
(heap:elements h))
(pdefine: (a) (elements [pq : (priority-queue a)]) : (list-of a)
(map #{elm :: ((elem a) -> a)} (heap:elements (heap pq))))
(pdefine: (a) (elements+priorities [pq : (priority-queue a)]) : (values (list-of a) (list-of number))
(let: ([eps : (list-of (elem a)) (heap:elements (heap pq))])
(values (map #{elm :: ((elem a) -> a)} eps)
(map #{pri :: ((elem a) -> number)} eps))))
(pdefine: (a) (empty? [pq : (priority-queue a)]) : boolean
(heap:empty? (heap pq)))
(define: empty : (All (a) (case-lambda (-> (priority-queue a)) (comparator -> (priority-queue a))))
(pcase-lambda: (a)
[() (#{empty @ a} (current-compare))]
[([cmp : comparator]) (make (#{heap:empty :: (case-lambda (-> (pqh a))
(comparator -> (pqh a)))} cmp))]))
(pdefine: (e r) (fold [f : ((cons number e) r -> r)] [b : r] [a : (priority-queue e)]) : r
(heap:fold f b (#{heap :: ((priority-queue e) -> (pqh e))} a)))
;; "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"))))
(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"))))
(pdefine: (a) (insert [x : a] [p : number] [pq : (priority-queue a)]) : (priority-queue a)
(make (heap:insert (cons p x) (heap pq))))
;; FIXME -- too many annotations needed on cons
(pdefine: (a) (insert* [xs : (list-of a)] [ps : (list-of number)] [pq : (priority-queue a)]) : (priority-queue a)
(make (heap:insert* (map #{cons @ number a} ps xs) (heap pq))))
(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"))))
(pdefine: (a) (size [pq : (priority-queue a)]) : number
(heap:size (heap pq)))
(pdefine: (a) (union [pq1 : (priority-queue a)] [pq2 : (priority-queue a)]) : (priority-queue a)
(make (heap:union (heap pq1) (heap pq2))))
#;(require "signatures/priority-queue-signature.scm")
#;(provide-priority-queue)

7
collects/typed-scheme/types/remove-intersect.rkt
View File

@ -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*)