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