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

Omit a redundant pass.

Browse Source
This commit is contained in:
Vincent St-Amour 2011-07-22 16:40:11 -04:00
parent 84931448b5
commit 02b76d7741
1 changed files with 26 additions and 41 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

67
collects/typed-scheme/typecheck/tc-app-helper.rkt
View File

@ -232,48 +232,33 @@
(loop (cdr cases) (cdr parts) (loop (cdr cases) (cdr parts)
candidates parts-acc)) ; we discard this one candidates parts-acc)) ; we discard this one
;; discard subsumed cases (supertype modulo filters) ;; among the domains that fit with the expected type, we only
(let loop ([cases candidates] ;; need to keep the most liberal
[parts parts-acc] ;; since we only care about permissiveness of domains, we
;; accumulators ;; reconstruct function types with a return type of any then test
[candidates '()] ;; for subtyping
[parts-acc '()]) (let ([fun-tys-ret-any
(if (not (null? cases)) (map (match-lambda
(let ([head (car cases)] [tail (cdr cases)]) [(Function: (list (arr: dom _ rest drest _)))
(if (is-subsumed-in? head tail) (make-Function (list (make-arr dom (-values (list Univ))
(loop tail (cdr parts) rest drest null)))])
candidates parts-acc) ; we discard this one candidates)])
(loop tail (cdr parts) (let loop ([cases fun-tys-ret-any]
(cons head candidates) ; we keep this one [parts parts-acc]
(cons (car parts) parts-acc)))) ;; accumulators
;; final pass, we only need the parts to print the
;; error message
[parts-acc '()])
(if (not (null? cases))
;; if a case is a supertype of another, we discard it
(let ([head (car cases)])
(if (is-subsumed-in? head (remove head fun-tys-ret-any))
(loop (cdr cases) (cdr parts)
parts-acc) ; we discard this one
(loop (cdr cases) (cdr parts)
(cons (car parts) parts-acc)))) ; we keep this one
;; among the domains that fit with the expected type, we only (unzip4 (reverse parts-acc))))))))
;; need to keep the most liberal
;; since we only care about permissiveness of domains, we
;; reconstruct function types with a return type of any then test
;; for subtyping
(let ([fun-tys-ret-any
(map (match-lambda
[(Function: (list (arr: dom _ rest drest _)))
(make-Function (list (make-arr dom (-values (list Univ))
rest drest null)))])
candidates)])
(let loop ([cases fun-tys-ret-any]
[parts parts-acc]
;; accumulators
;; final pass, we only need the parts to print the
;; error message
[parts-acc '()])
(if (not (null? cases))
;; if a case is a supertype of another, we discard it
(let ([head (car cases)])
(if (is-subsumed-in? head (remove head fun-tys-ret-any))
(loop (cdr cases) (cdr parts)
parts-acc) ; we discard this one
(loop (cdr cases) (cdr parts)
(cons (car parts) parts-acc)))) ; we keep this one
(unzip4 (reverse parts-acc))))))))))
;; Wrapper over possible-domains that works on types. ;; Wrapper over possible-domains that works on types.
(define (cleanup-type t [expected #f]) (define (cleanup-type t [expected #f])