From 9f184c01be2fa5fa13bfcb70a8fe32beb7bb11fc Mon Sep 17 00:00:00 2001 From: simonpj Date: Mon, 12 Jan 1998 09:29:32 +0000 Subject: [PATCH] [project @ 1998-01-12 09:29:22 by simonpj] Fix renamer global/local env bug --- ghc/compiler/reader/Lex.lhs | 13 +++++++++++++ ghc/compiler/rename/RnBinds.lhs | 2 +- ghc/compiler/rename/RnEnv.lhs | 10 +++++----- ghc/compiler/rename/RnMonad.lhs | 8 +++++--- ghc/compiler/rename/RnNames.lhs | 7 ++++--- 5 files changed, 28 insertions(+), 12 deletions(-) diff --git a/ghc/compiler/reader/Lex.lhs b/ghc/compiler/reader/Lex.lhs index f04e4ce..b312655 100644 --- a/ghc/compiler/reader/Lex.lhs +++ b/ghc/compiler/reader/Lex.lhs @@ -1,3 +1,16 @@ +-------------------------------------------------------- +[Jan 98] +There's a known bug in here: + + If an interface file ends prematurely, Lex tries to + do headFS of an empty FastString. + +An example that provokes the error is + + f _:_ _forall_ [a] <<>> +-------------------------------------------------------- + + % % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996 % diff --git a/ghc/compiler/rename/RnBinds.lhs b/ghc/compiler/rename/RnBinds.lhs index 18d47c0..046cd68 100644 --- a/ghc/compiler/rename/RnBinds.lhs +++ b/ghc/compiler/rename/RnBinds.lhs @@ -567,7 +567,7 @@ sig_doc (InlineSig _ loc) = (SLIT("INLINE pragma"),loc) sig_doc (MagicUnfoldingSig _ _ loc) = (SLIT("MAGIC_UNFOLDING pragma"),loc) missingSigErr var - = sep [ptext SLIT("a definition but no type signature for"), quotes (ppr var)] + = sep [ptext SLIT("Definition but no type signature for"), quotes (ppr var)] methodBindErr mbind = hang (ptext SLIT("Can't handle multiple methods defined by one pattern binding")) diff --git a/ghc/compiler/rename/RnEnv.lhs b/ghc/compiler/rename/RnEnv.lhs index 89ecdf9..f975e91 100644 --- a/ghc/compiler/rename/RnEnv.lhs +++ b/ghc/compiler/rename/RnEnv.lhs @@ -19,7 +19,7 @@ import RnMonad import Name ( Name, OccName(..), Provenance(..), ExportFlag(..), NamedThing(..), occNameString, occNameFlavour, getSrcLoc, NameSet, emptyNameSet, addListToNameSet, nameSetToList, - mkLocalName, mkGlobalName, modAndOcc, isLocallyDefinedName, + mkLocalName, mkGlobalName, modAndOcc, nameOccName, setNameProvenance, isVarOcc, getNameProvenance, pprProvenance, pprOccName, pprModule, pprNameProvenance, isLocalName @@ -447,16 +447,16 @@ addOneToGlobalNameEnv env rdr_name name delOneFromGlobalNameEnv :: GlobalNameEnv -> RdrName -> GlobalNameEnv delOneFromGlobalNameEnv env rdr_name = delFromFM env rdr_name -conflicting_name (n1,h1) (n2,h2) - = (n1 /= n2) || - (isLocallyDefinedName n1 && isLocallyDefinedName n2) +conflicting_name :: (Name, HowInScope) -> (Name, HowInScope) -> Bool +conflicting_name (n1, FromLocalDefn _) (n2, FromLocalDefn _) = True +conflicting_name (n1,h1) (n2,h2) = n1 /= n2 -- We complain of a conflict if one RdrName maps to two different Names, -- OR if one RdrName maps to the same *locally-defined* Name. The latter -- case is to catch two separate, local definitions of the same thing. -- -- If a module imports itself then there might be a local defn and an imported -- defn of the same name; in this case the names will compare as equal, but - -- will still have different provenances. + -- will still have different HowInScope fields lookupNameEnv :: NameEnv -> RdrName -> Maybe Name lookupNameEnv = lookupFM diff --git a/ghc/compiler/rename/RnMonad.lhs b/ghc/compiler/rename/RnMonad.lhs index 09cecfa..f20b714 100644 --- a/ghc/compiler/rename/RnMonad.lhs +++ b/ghc/compiler/rename/RnMonad.lhs @@ -619,9 +619,11 @@ lookupGlobalNameRn rdr_name rn_down (SDown (RnEnv global_env fixity_env) local_e -- Look in both local and global env lookupNameRn :: RdrName -> RnMS s (Maybe Name) lookupNameRn rdr_name rn_down (SDown (RnEnv global_env fixity_env) local_env mod_name mode) - = case lookupFM global_env rdr_name of - Just (name, _) -> returnSST (Just name) - Nothing -> returnSST (lookupFM local_env rdr_name) + = case lookupFM local_env rdr_name of + Just name -> returnSST (Just name) + Nothing -> case lookupFM global_env rdr_name of + Just (name, _) -> returnSST (Just name) + Nothing -> returnSST Nothing getNameEnvs :: RnMS s (GlobalNameEnv, NameEnv) getNameEnvs rn_down (SDown (RnEnv global_env fixity_env) local_env mod_name mode) diff --git a/ghc/compiler/rename/RnNames.lhs b/ghc/compiler/rename/RnNames.lhs index 0574301..a3ff994 100644 --- a/ghc/compiler/rename/RnNames.lhs +++ b/ghc/compiler/rename/RnNames.lhs @@ -323,6 +323,7 @@ qualifyImports this_mod qual_imp unqual_imp as_mod hides add_avail :: GlobalNameEnv -> AvailInfo -> RnMG GlobalNameEnv add_avail env avail = foldlRn add_name env (availNames avail) + add_name env name = add qual_imp env (Qual qual_mod occ err_hif) `thenRn` \ env1 -> add unqual_imp env1 (Unqual occ) where @@ -398,8 +399,8 @@ addAvailEnv warn_dups ie env NotAvailable = returnRn env addAvailEnv warn_dups ie env (AvailTC _ []) = returnRn env addAvailEnv warn_dups ie env avail | warn_dups = mapMaybeRn (addErrRn . availClashErr) () conflict `thenRn_` - returnRn (addToFM_C add_avail env key elt) - | otherwise = returnRn (addToFM_C add_avail env key elt) + returnRn (addToFM_C addAvail env key elt) + | otherwise = returnRn (addToFM_C addAvail env key elt) where key = nameOccName (availName avail) elt = (ie,avail,reports_on) @@ -421,7 +422,7 @@ bad_avail (ie1,avail1,r1) (ie2,avail2,r2) dup_avail (ie1,avail1,r1) (ie2,avail2,r2) = availName avail1 == availName avail2 -- Same OccName & avail. -add_avail (ie1,a1,r1) (ie2,a2,r2) = (ie1, a1 `plusAvail` a2, r1 + r2) +addAvail (ie1,a1,r1) (ie2,a2,r2) = (ie1, a1 `plusAvail` a2, r1 + r2) \end{code} Processing the export list. -- 1.7.10.4