5b0298a4bd
* A degenerate type synonym like type T a = a in some circumstances incorrectly caused an occurence check error. * Several new features in gcc-3.3 cause breakage in the nhc98 build. This patch fixes many [but ot all] of those problems. PKGREVISION++.
133 lines
4.6 KiB
Text
133 lines
4.6 KiB
Text
$NetBSD: patch-ag,v 1.1 2004/01/16 00:59:18 kristerw Exp $
|
|
|
|
--- src/compiler98/TypeUnify.hs.orig 20 Feb 2003 18:23:29
|
|
+++ src/compiler98/TypeUnify.hs 1 Apr 2003 13:54:36
|
|
@@ -3,7 +3,7 @@
|
|
-}
|
|
module TypeUnify(unify,unifyr) where
|
|
|
|
-import NT(NT(..),NewType(..),freeNT,strNT)
|
|
+import NT(NT(..),NewType(..),freeNT,strNT,anyVarNT)
|
|
import IdKind
|
|
import TypeSubst
|
|
import TypeUtil
|
|
@@ -20,12 +20,12 @@
|
|
|
|
unify state phi (t1@(NTany tvn1),t2) =
|
|
case applySubst phi tvn1 of
|
|
- Nothing -> extend phi tvn1 (subst phi t2)
|
|
+ Nothing -> extendV state phi tvn1 (subst phi t2)
|
|
Just phitvn -> unify state phi (phitvn,subst phi t2)
|
|
|
|
unify state phi (t1@(NTvar tvn1),(NTany tvn2)) =
|
|
case applySubst phi tvn2 of
|
|
- Nothing -> extend phi tvn2 (subst phi t1)
|
|
+ Nothing -> extendV state phi tvn2 (subst phi t1)
|
|
Just phitvn -> unify state phi (phitvn,subst phi t1)
|
|
|
|
unify state phi (t1@(NTvar tvn1),t2) =
|
|
@@ -35,7 +35,7 @@
|
|
|
|
unify state phi (t1@(NTcons _ _),t2@(NTany tvn2)) =
|
|
case applySubst phi tvn2 of
|
|
- Nothing -> extend phi tvn2 (subst phi t1)
|
|
+ Nothing -> extendV state phi tvn2 (subst phi t1)
|
|
Just phitvn -> unify state phi (phitvn,subst phi t1)
|
|
|
|
unify state phi (t1@(NTcons _ _),t2@(NTvar tvn2)) =
|
|
@@ -81,13 +81,13 @@
|
|
unify state phi (t1@(NTapp ta1 tb1),t2@(NTany tvn2)) =
|
|
-- strace ("unify(2) " ++ show t1 ++ " " ++ show t2) $
|
|
case applySubst phi tvn2 of
|
|
- Nothing -> extend phi tvn2 (subst phi t1)
|
|
+ Nothing -> extendV state phi tvn2 (subst phi t1)
|
|
Just phitvn -> unify state phi (phitvn,subst phi t1)
|
|
|
|
unify state phi (t1@(NTapp ta1 tb1),t2@(NTvar tvn2)) =
|
|
-- strace ("unify(3) " ++ show t1 ++ " " ++ show t2) $
|
|
case applySubst phi tvn2 of
|
|
- Nothing -> extend phi tvn2 (subst phi t1)
|
|
+ Nothing -> extendV state phi tvn2 (subst phi t1)
|
|
Just phitvn -> unify state phi (phitvn,subst phi t1)
|
|
|
|
unify state phi (t1@(NTapp ta1 tb1),t2@(NTcons c2 ts2)) =
|
|
@@ -130,7 +130,7 @@
|
|
unify state phi (t1@(NTexist e),t2@(NTany tvn2)) =
|
|
-- strace ("unify exist " ++ show e ++ " any " ++ show tvn2) $
|
|
case applySubst phi tvn2 of
|
|
- Nothing -> extend phi tvn2 (subst phi t1)
|
|
+ Nothing -> extendV state phi tvn2 (subst phi t1)
|
|
Just phitvn -> unify state phi (phitvn,subst phi t1)
|
|
|
|
unify state phi (t1@(NTexist e),t2@(NTvar tvn2)) =
|
|
@@ -166,6 +166,8 @@
|
|
|
|
------
|
|
|
|
+-- expand any type synonym at top, so that none is at top in result
|
|
+expandAll :: IntState -> NT -> NT
|
|
expandAll state t@(NTcons tcon ts) =
|
|
case unifyExpand state tcon of
|
|
Left _ -> t
|
|
@@ -178,6 +180,15 @@
|
|
Right _ -> False
|
|
Left _ -> True
|
|
|
|
+-- expand all type synonyms, so that none is left in result
|
|
+fullyExpand :: IntState -> NT -> NT
|
|
+fullyExpand state t =
|
|
+ case expandAll state t of
|
|
+ NTstrict t -> NTstrict (fullyExpand state t)
|
|
+ NTapp t1 t2 -> NTapp (fullyExpand state t1) (fullyExpand state t2)
|
|
+ NTcons id ts -> NTcons id (map (fullyExpand state) ts)
|
|
+ t -> t
|
|
+
|
|
{-
|
|
If tcon is a type synoym, then unifyExpand returns the depth and the
|
|
definition body of the type synoym.
|
|
@@ -205,27 +216,26 @@
|
|
|
|
expand (NewType free [] ctxs [nt]) ts = subst (list2Subst (zip free ts)) nt
|
|
|
|
-
|
|
+{-
|
|
+Extends substitution by subtitution of `t' for `tvn'.
|
|
+Performs occurrence check and assures that replacement of `tvn' is a type
|
|
+variable, if `t' expands to a type variable.
|
|
+-}
|
|
extendV :: IntState -> AssocTree Id NT -> Id -> NT
|
|
-> Either (AssocTree Id NT, String) (AssocTree Id NT)
|
|
|
|
-extendV state phi tvn t@(NTcons c _) =
|
|
- if unboxedIS state c then
|
|
- Left (phi,"polymorphic type variable bound to unboxed data " ++ strIS state c)
|
|
- else
|
|
- extend phi tvn t
|
|
extendV state phi tvn t =
|
|
- extend phi tvn t
|
|
+ let t' = expandAll state t
|
|
+ in case anyVarNT t' of
|
|
+ Just tvn' -> if tvn' == tvn
|
|
+ then Right phi
|
|
+ else Right (addSubst phi tvn t')
|
|
+ Nothing ->
|
|
+ if tvn `elem` freeNT t'
|
|
+ then let t'' = fullyExpand state t'
|
|
+ -- expansion may have less free variables
|
|
+ in if tvn `elem` freeNT t''
|
|
+ then Left (phi,"(type-variable occurrence check fails)")
|
|
+ else Right (addSubst phi tvn t'')
|
|
+ else Right (addSubst phi tvn t) -- do not expand unnecessarily
|
|
|
|
-extend phi tvn t@(NTany tvn') =
|
|
- if tvn' == tvn
|
|
- then Right phi
|
|
- else Right (addSubst phi tvn t)
|
|
-extend phi tvn t@(NTvar tvn') =
|
|
- if tvn' == tvn
|
|
- then Right phi
|
|
- else Right (addSubst phi tvn t)
|
|
-extend phi tvn t | tvn `elem` freeNT t =
|
|
- Left (phi,"(type-variable occurrence check fails)")
|
|
-extend phi tvn t@(NTcons c _) = Right (addSubst phi tvn t)
|
|
-extend phi tvn t = Right (addSubst phi tvn t)
|