[project @ 2001-03-05 12:18:05 by simonpj]

[ghc-hetmet.git] / ghc / compiler / stgSyn / StgLint.lhs

diff --git a/ghc/compiler/stgSyn/StgLint.lhs b/ghc/compiler/stgSyn/StgLint.lhs
index 433ab2a..bfae295 100644 (file)
--- a/ghc/compiler/stgSyn/StgLint.lhs
+++ b/ghc/compiler/stgSyn/StgLint.lhs
@@ -11,15 +11,15 @@ module StgLint ( lintStgBindings ) where
 import StgSyn
 
 import Bag             ( Bag, emptyBag, isEmptyBag, snocBag )
-import Id              ( Id, idType )
+import Id              ( Id, idType, isLocalId )
 import VarSet
 import DataCon         ( DataCon, dataConArgTys, dataConRepType )
 import PrimOp          ( primOpType )
 import Literal         ( literalType, Literal )
 import Maybes          ( catMaybes )
-import Name            ( isLocallyDefined, getSrcLoc )
+import Name            ( getSrcLoc )
 import ErrUtils                ( ErrMsg, Message, addErrLocHdrLine, pprBagOfErrors, dontAddErrLoc )
-import Type            ( mkFunTys, splitFunTys, splitAlgTyConApp_maybe, 
+import Type            ( mkFunTys, splitFunTys, splitAlgTyConApp_maybe, splitTyConApp_maybe,
                          isUnLiftedType, isTyVarTy, splitForAllTys, Type
                        )
 import TyCon           ( TyCon )
@@ -196,8 +196,13 @@ lintStgExpr (StgSCC _ expr)        = lintStgExpr expr
 
 lintStgExpr e@(StgCase scrut _ _ bndr _ alts)
   = lintStgExpr scrut          `thenMaybeL` \ _ ->
-    checkTys (idType bndr) scrut_ty (mkDefltMsg bndr) `thenL_`
 
+    (case alts of
+       StgPrimAlts tc _ _       -> check_bndr tc
+       StgAlgAlts (Just tc) _ _ -> check_bndr tc
+       StgAlgAlts Nothing   _ _ -> returnL ()
+    )                                                  `thenL_`
+       
     (trace (showSDoc (ppr e)) $ 
        -- we only allow case of tail-call or primop.
     (case scrut of
@@ -206,12 +211,13 @@ lintStgExpr e@(StgCase scrut _ _ bndr _ alts)
        other -> addErrL (mkCaseOfCaseMsg e))   `thenL_`
 
     addInScopeVars [bndr] (lintStgAlts alts scrut_ty)
-  )
+    )
   where
-    scrut_ty = get_ty alts
-
-    get_ty (StgAlgAlts  ty _ _) = ty
-    get_ty (StgPrimAlts ty _ _) = ty
+    scrut_ty     = idType bndr
+    bad_bndr      = mkDefltMsg bndr
+    check_bndr tc = case splitTyConApp_maybe scrut_ty of
+                       Just (bndr_tc, _) -> checkL (tc == bndr_tc) bad_bndr
+                       Nothing           -> addErrL bad_bndr
 \end{code}
 
 \begin{code}
@@ -375,7 +381,7 @@ addErr errs_so_far msg locs
   = errs_so_far `snocBag` mk_msg locs
   where
     mk_msg (loc:_) = let (l,hdr) = dumpLoc loc in addErrLocHdrLine l hdr msg
-    mk_msg []      = dontAddErrLoc "" msg
+    mk_msg []      = dontAddErrLoc msg
 
 addLoc :: LintLocInfo -> LintM a -> LintM a
 addLoc extra_loc m loc scope errs
@@ -437,7 +443,7 @@ checkFunApp fun_ty arg_tys msg loc scope errs
 \begin{code}
 checkInScope :: Id -> LintM ()
 checkInScope id loc scope errs
-  = if isLocallyDefined id && not (id `elemVarSet` scope) then
+  = if isLocalId id && not (id `elemVarSet` scope) then
        ((), addErr errs (hsep [ppr id, ptext SLIT("is out of scope")]) loc)
     else
        ((), errs)