From f3998ec18fd0f3d56b377d41e2a2958aaf9460ec Mon Sep 17 00:00:00 2001
From: partain <unknown>
Date: Thu, 16 May 1996 09:48:49 +0000
Subject: [PATCH] [project @ 1996-05-16 09:48:23 by partain] Sansom changes
through 960515
---
ghc/compiler/Jmakefile | 2 +-
ghc/compiler/hsSyn/HsExpr.lhs | 2 +-
ghc/compiler/parser/hsparser.y | 21 ++++++++---------
ghc/compiler/reader/ReadPrefix.lhs | 2 +-
ghc/compiler/rename/Rename.lhs | 3 +--
ghc/compiler/rename/RnExpr.lhs | 4 ++--
ghc/compiler/rename/RnIfaces.lhs | 2 +-
ghc/compiler/rename/RnMonad.lhs | 6 ++---
ghc/compiler/rename/RnNames.lhs | 37 +++++++++++++++++++++++++-----
ghc/compiler/rename/RnUtils.lhs | 7 +-----
ghc/compiler/typecheck/TcExpr.lhs | 2 +-
11 files changed, 52 insertions(+), 36 deletions(-)
diff --git a/ghc/compiler/Jmakefile b/ghc/compiler/Jmakefile
index 373757ff2562..58072a107563 100644
--- a/ghc/compiler/Jmakefile
+++ b/ghc/compiler/Jmakefile
@@ -820,7 +820,7 @@ MakeDirectories(install, $(INSTLIBDIR_GHC))
InstallBinaryTarget(hsp,$(INSTLIBDIR_GHC))
#endif /* DoInstall... */
-YaccRunWithExpectMsg(parser/hsparser,14,0)
+YaccRunWithExpectMsg(parser/hsparser,12,0)
UgenTarget(parser/constr)
UgenTarget(parser/binding)
diff --git a/ghc/compiler/hsSyn/HsExpr.lhs b/ghc/compiler/hsSyn/HsExpr.lhs
index 65fd71e34d59..55709cabdd1d 100644
--- a/ghc/compiler/hsSyn/HsExpr.lhs
+++ b/ghc/compiler/hsSyn/HsExpr.lhs
@@ -60,7 +60,7 @@ data HsExpr tyvar uvar id pat
-- They are eventually removed by the type checker.
| NegApp (HsExpr tyvar uvar id pat) -- negated expr
- id -- the negate id
+ (HsExpr tyvar uvar id pat) -- the negate id (in a HsVar)
| HsPar (HsExpr tyvar uvar id pat) -- parenthesised expr
diff --git a/ghc/compiler/parser/hsparser.y b/ghc/compiler/parser/hsparser.y
index e2e99154dc11..50ba88fd23e3 100644
--- a/ghc/compiler/parser/hsparser.y
+++ b/ghc/compiler/parser/hsparser.y
@@ -124,9 +124,9 @@ BOOLEAN inpat;
* *
**********************************************************************/
-%token OCURLY CCURLY VCCURLY SEMI
-%token OBRACK CBRACK OPAREN CPAREN
-%token COMMA BQUOTE
+%token OCURLY CCURLY VCCURLY
+%token COMMA SEMI OBRACK CBRACK
+%token WILDCARD BQUOTE OPAREN CPAREN
/**********************************************************************
@@ -137,9 +137,9 @@ BOOLEAN inpat;
* *
**********************************************************************/
-%token DOTDOT DCOLON EQUAL
-%token LAMBDA VBAR RARROW
-%token LARROW MINUS
+%token DOTDOT DCOLON EQUAL LAMBDA
+%token VBAR RARROW LARROW
+%token AT LAZY DARROW
/**********************************************************************
@@ -165,12 +165,12 @@ BOOLEAN inpat;
/**********************************************************************
* *
* *
-* Valid symbols/identifiers which need to be recognised *
+* Special symbols/identifiers which need to be recognised *
* *
* *
**********************************************************************/
-%token WILDCARD AT LAZY BANG
+%token MINUS BANG
%token AS HIDING QUALIFIED
@@ -909,7 +909,7 @@ exp : oexp DCOLON ctype { $$ = mkrestr($1,$3); }
Operators must be left-associative at the same precedence for
precedence parsing to work.
*/
- /* 9 S/R conflicts on qop -> shift */
+ /* 8 S/R conflicts on qop -> shift */
oexp : oexp qop oexp %prec MINUS { $$ = mkinfixap($2,$1,$3); }
| dexp
;
@@ -1430,9 +1430,8 @@ varid : VARID
| QUALIFIED { $$ = install_literal("qualified"); }
;
-/* DARROW BANG are valid varsyms */
+/* BANG are valid varsyms */
varsym_nominus : VARSYM
- | DARROW { $$ = install_literal("=>"); }
| BANG { $$ = install_literal("!"); }
;
diff --git a/ghc/compiler/reader/ReadPrefix.lhs b/ghc/compiler/reader/ReadPrefix.lhs
index 0aa0e50f522c..b35b926185bf 100644
--- a/ghc/compiler/reader/ReadPrefix.lhs
+++ b/ghc/compiler/reader/ReadPrefix.lhs
@@ -307,7 +307,7 @@ wlkExpr expr
U_negate nexp -> -- prefix negation
wlkExpr nexp `thenUgn` \ expr ->
- returnUgn (NegApp expr (Unqual SLIT("negate")) )
+ returnUgn (NegApp expr (HsVar (Qual SLIT("Prelude") SLIT("negate"))))
U_llist llist -> -- explicit list
wlkList rdExpr llist `thenUgn` \ exprs ->
diff --git a/ghc/compiler/rename/Rename.lhs b/ghc/compiler/rename/Rename.lhs
index 1a969990e33a..743c83d1253e 100644
--- a/ghc/compiler/rename/Rename.lhs
+++ b/ghc/compiler/rename/Rename.lhs
@@ -65,7 +65,6 @@ renameModule :: UniqSupply
\end{code}
ToDo: May want to arrange to return old interface for this module!
-ToDo: Builtin names which must be read.
ToDo: Deal with instances (instance version, this module on instance list ???)
\begin{code}
@@ -218,7 +217,7 @@ makeHiMap (Just f)
\begin{code}
{- TESTING:
-pprPIface (ParsedIface m ?? v mv usgs lcm exm ims lfx ltdm lvdm lids ldp)
+pprPIface (ParsedIface m ms v mv usgs lcm exm ims lfx ltdm lvdm lids ldp)
= ppAboves [
ppCat [ppPStr SLIT("interface"), ppPStr m, ppInt v,
case mv of { Nothing -> ppNil; Just n -> ppInt n }],
diff --git a/ghc/compiler/rename/RnExpr.lhs b/ghc/compiler/rename/RnExpr.lhs
index d00312c42bfb..9b4a61ba9805 100644
--- a/ghc/compiler/rename/RnExpr.lhs
+++ b/ghc/compiler/rename/RnExpr.lhs
@@ -228,8 +228,8 @@ rnExpr (OpApp e1 op e2)
rnExpr (NegApp e n)
= rnExpr e `thenRn` \ (e', fvs_e) ->
- lookupValue n `thenRn` \ nname ->
- returnRn (NegApp e' nname, fvs_e `unionUniqSets` fv_set nname)
+ rnExpr n `thenRn` \ (n', fvs_n) ->
+ returnRn (NegApp e' n', fvs_e `unionUniqSets` fvs_n)
rnExpr (HsPar e)
= rnExpr e `thenRn` \ (e', fvs_e) ->
diff --git a/ghc/compiler/rename/RnIfaces.lhs b/ghc/compiler/rename/RnIfaces.lhs
index 299a1f34fdf9..76fe13cdbd89 100644
--- a/ghc/compiler/rename/RnIfaces.lhs
+++ b/ghc/compiler/rename/RnIfaces.lhs
@@ -211,7 +211,7 @@ mergeIfaces (ParsedIface mod1 (_, files1) _ _ _ _ _ _ fixes1 tdefs1 vdefs1 idefs
ppStr "merged with", ppPStr mod1]) $
ASSERT(mod1 == mod2)
ParsedIface mod1
- (True, unionBags files1 files2)
+ (True, unionBags files2 files1)
(panic "mergeIface: module version numbers")
(panic "mergeIface: source version numbers") -- Version numbers etc must be extracted from
(panic "mergeIface: usage version numbers") -- the merged file interfaces named above
diff --git a/ghc/compiler/rename/RnMonad.lhs b/ghc/compiler/rename/RnMonad.lhs
index cde9eef625b5..9b7bf0fac676 100644
--- a/ghc/compiler/rename/RnMonad.lhs
+++ b/ghc/compiler/rename/RnMonad.lhs
@@ -43,7 +43,7 @@ import RnHsSyn ( RnName, mkRnName, mkRnUnbound, mkRnImplicit,
import RnUtils ( RnEnv(..), extendLocalRnEnv,
lookupRnEnv, lookupGlobalRnEnv, lookupTcRnEnv,
unknownNameErr, badClassOpErr, qualNameErr,
- dupNamesErr, shadowedNameWarn, negateNameWarn
+ dupNamesErr, shadowedNameWarn
)
import Bag ( Bag, emptyBag, isEmptyBag, snocBag )
@@ -292,12 +292,10 @@ newLocalNames :: String -- Documentation string
-> RnMonad x s [RnName]
newLocalNames str names_w_loc
- = mapRn (addWarnRn . negateNameWarn) negs `thenRn_`
- mapRn (addErrRn . qualNameErr str) quals `thenRn_`
+ = mapRn (addErrRn . qualNameErr str) quals `thenRn_`
mapRn (addErrRn . dupNamesErr str) dups `thenRn_`
mkLocalNames these
where
- negs = filter ((== Unqual SLIT("negate")).fst) names_w_loc
quals = filter (isQual.fst) names_w_loc
(these, dups) = removeDups cmp_fst names_w_loc
cmp_fst (a,_) (b,_) = cmp a b
diff --git a/ghc/compiler/rename/RnNames.lhs b/ghc/compiler/rename/RnNames.lhs
index 0f7037269dd1..10ea30ac3065 100644
--- a/ghc/compiler/rename/RnNames.lhs
+++ b/ghc/compiler/rename/RnNames.lhs
@@ -348,7 +348,8 @@ doImportDecls iface_cache g_info us src_imps
) >>= \ (vals, tcs, unquals, fixes, errs, warns, _) ->
return (vals, tcs, imp_mods, unquals, fixes,
- errs, imp_warns `unionBags` warns)
+ imp_errs `unionBags` errs,
+ imp_warns `unionBags` warns)
where
the_imps = implicit_prel ++ src_imps
all_imps = implicit_qprel ++ the_imps
@@ -364,21 +365,35 @@ doImportDecls iface_cache g_info us src_imps
then [{- no "import Prelude" -}]
else [ImportDecl pRELUDE False Nothing Nothing prel_loc]
- prel_imps -- WDP: Just guessing on this defn... ToDo
- = [ imp | imp@(ImportDecl mod _ _ _ _) <- the_imps, fromPrelude mod ]
-
prel_loc = mkBuiltinSrcLoc
(uniq_imps, imp_dups) = removeDups cmp_mod the_imps
cmp_mod (ImportDecl m1 _ _ _ _) (ImportDecl m2 _ _ _ _) = cmpPString m1 m2
- qprel_imps = [ imp | imp@(ImportDecl mod True Nothing _ _) <- prel_imps ]
+ qprel_imps = [ imp | imp@(ImportDecl mod True Nothing _ _) <- src_imps,
+ fromPrelude mod ]
+
+ qual_mods = [ (qual_name mod as_mod, imp) | imp@(ImportDecl mod True as_mod _ _) <- src_imps ]
+ qual_name mod (Just as_mod) = as_mod
+ qual_name mod Nothing = mod
+
+ (_, qual_dups) = removeDups cmp_qual qual_mods
+ bad_qual_dups = filter (not . all_same_mod) qual_dups
+
+ cmp_qual (q1,_) (q2,_) = cmpPString q1 q2
+ all_same_mod ((q,ImportDecl mod _ _ _ _):rest)
+ = all has_same_mod rest
+ where
+ has_same_mod (q,ImportDecl mod2 _ _ _ _) = mod == mod2
+
imp_mods = [ mod | ImportDecl mod _ _ _ _ <- uniq_imps ]
+
imp_warns = listToBag (map dupImportWarn imp_dups)
`unionBags`
listToBag (map qualPreludeImportWarn qprel_imps)
+ imp_errs = listToBag (map dupQualImportErr bad_qual_dups)
doImports iface_cache i_info us []
= return (emptyBag, emptyBag, emptyBag, emptyBag, emptyBag, emptyBag, emptyBag)
@@ -516,7 +531,7 @@ getBuiltins (((b_val_names,b_tc_names),_,_,_),_,_,_) mod maybe_spec
(vals, tcs, ies_left) = do_builtin ies
-getOrigIEs (ParsedIface _ _ _ _ _ _ exps _ _ _ _ _ _) Nothing -- import all
+getOrigIEs (ParsedIface _ _ _ _ _ _ exps _ _ _ _ _ _) Nothing -- import all
= (map mkAllIE (eltsFM exps), [], emptyBag)
getOrigIEs (ParsedIface _ _ _ _ _ _ exps _ _ _ _ _ _) (Just (True, ies)) -- import hiding
@@ -807,6 +822,16 @@ qualPreludeImportWarn (ImportDecl m _ _ _ locn)
= addShortWarnLocLine locn (\ sty ->
ppCat [ppStr "qualified import of prelude module", ppPStr m])
+dupQualImportErr ((q1,ImportDecl _ _ _ _ locn1):dup_quals) sty
+ = ppAboves (item1 : map dup_item dup_quals)
+ where
+ item1 = addShortErrLocLine locn1 (\ sty ->
+ ppCat [ppStr "multiple imports (from different modules) with same qualified name", ppPStr q1]) sty
+
+ dup_item (q,ImportDecl _ _ _ _ locn)
+ = addShortErrLocLine locn (\ sty ->
+ ppCat [ppStr "here was another import with qualified name", ppPStr q]) sty
+
unknownImpSpecErr ie imp_mod locn
= addShortErrLocLine locn (\ sty ->
ppBesides [ppStr "module ", ppPStr imp_mod, ppStr " does not export `", ppr sty (ie_name ie), ppStr "'"])
diff --git a/ghc/compiler/rename/RnUtils.lhs b/ghc/compiler/rename/RnUtils.lhs
index ba38151367ce..1825928e20b6 100644
--- a/ghc/compiler/rename/RnUtils.lhs
+++ b/ghc/compiler/rename/RnUtils.lhs
@@ -19,8 +19,7 @@ module RnUtils (
qualNameErr,
dupNamesErr,
shadowedNameWarn,
- multipleOccWarn,
- negateNameWarn
+ multipleOccWarn
) where
import Ubiq
@@ -203,9 +202,5 @@ shadowedNameWarn locn shadow
multipleOccWarn (name, occs) sty
= ppBesides [ppStr "warning:multiple names used to refer to `", ppr sty name, ppStr "': ",
ppInterleave ppComma (map (ppr sty) occs)]
-
-negateNameWarn (name,locn)
- = addShortWarnLocLine locn ( \ sty ->
- ppBesides [ppStr "local binding of `negate' will be used for prefix `-'"])
\end{code}
diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs
index 594653b355cc..fa2ff93539c1 100644
--- a/ghc/compiler/typecheck/TcExpr.lhs
+++ b/ghc/compiler/typecheck/TcExpr.lhs
@@ -169,7 +169,7 @@ tcExpr (HsLit lit@(HsString str))
tcExpr (HsPar expr) -- preserve parens so printing needn't guess where they go
= tcExpr expr
-tcExpr (NegApp expr n) = tcExpr (HsApp (HsVar n) expr)
+tcExpr (NegApp expr neg) = tcExpr (HsApp neg expr)
tcExpr (HsLam match)
= tcMatch match `thenTc` \ (match',lie,ty) ->
--
GitLab