From 625f0ad83a38d5dc2c3a5fd69f2f4d0ed9283dc2 Mon Sep 17 00:00:00 2001
From: simonpj <unknown>
Date: Tue, 5 Jan 1999 12:22:12 +0000
Subject: [PATCH] [project @ 1999-01-05 12:22:08 by simonpj] Fix renamer crash
on bootstrap build
---
ghc/compiler/rename/RnEnv.lhs | 10 +++++-----
ghc/compiler/rename/RnNames.lhs | 16 +++++++++++-----
ghc/compiler/rename/RnSource.lhs | 2 +-
ghc/compiler/typecheck/TcExpr.lhs | 7 ++++---
4 files changed, 21 insertions(+), 14 deletions(-)
diff --git a/ghc/compiler/rename/RnEnv.lhs b/ghc/compiler/rename/RnEnv.lhs
index 2fdf11e5d524..205c2c77d134 100644
--- a/ghc/compiler/rename/RnEnv.lhs
+++ b/ghc/compiler/rename/RnEnv.lhs
@@ -586,7 +586,7 @@ availNames (AvailTC n ns) = ns
filterAvail :: RdrNameIE -- Wanted
-> AvailInfo -- Available
-> AvailInfo -- Resulting available;
- -- NotAvailable if wanted stuff isn't there
+ -- NotAvailable if (any of the) wanted stuff isn't there
filterAvail ie@(IEThingWith want wants) avail@(AvailTC n ns)
| sub_names_ok = AvailTC n (filter is_wanted ns)
@@ -603,8 +603,7 @@ filterAvail ie@(IEThingWith want wants) avail@(AvailTC n ns)
filterAvail (IEThingAbs _) (AvailTC n ns) = ASSERT( n `elem` ns )
AvailTC n [n]
-
-filterAvail (IEThingAbs _) avail@(Avail n) = avail -- Type synonyms
+filterAvail (IEThingAll _) avail@(AvailTC _ _) = avail
filterAvail (IEVar _) avail@(Avail n) = avail
filterAvail (IEVar v) avail@(AvailTC n ns) = AvailTC n (filter wanted ns)
@@ -615,9 +614,10 @@ filterAvail (IEVar v) avail@(AvailTC n ns) = AvailTC n (filter wanted ns)
-- import A( op )
-- where op is a class operation
-filterAvail (IEThingAll _) avail@(AvailTC _ _) = avail
-filterAvail ie avail = NotAvailable
+#ifdef DEBUG
+filterAvail ie avail = pprPanic "filterAvail" (ppr ie $$ pprAvail avail)
+#endif
-- In interfaces, pprAvail gets given the OccName of the "host" thing
diff --git a/ghc/compiler/rename/RnNames.lhs b/ghc/compiler/rename/RnNames.lhs
index 3be854e591f6..9471b3c00821 100644
--- a/ghc/compiler/rename/RnNames.lhs
+++ b/ghc/compiler/rename/RnNames.lhs
@@ -192,9 +192,7 @@ importsFromImportDecl rec_unqual_fn (ImportDecl mod qual_only as_source as_mod i
if null avails then
-- If there's an error in getInterfaceExports, (e.g. interface
- -- file not found) then avail might be NotAvailable, so availName
- -- in home_modules fails. Hence the guard here. Also we get lots
- -- of spurious errors from 'filterImports' if we don't find the interface file
+ -- file not found) we get lots of spurious errors from 'filterImports'
returnRn (emptyRdrEnv, mkEmptyExportAvails mod)
else
@@ -207,12 +205,20 @@ importsFromImportDecl rec_unqual_fn (ImportDecl mod qual_only as_source as_mod i
home_modules = [name | avail <- filtered_avails,
-- Doesn't take account of hiding, but that doesn't matter
+ -- Drop NotAvailables.
+ -- Happens if filterAvail finds something missing
+ case avail of
+ NotAvailable -> False
+ other -> True,
+
let name = availName avail,
- nameModule name /= mod]
- -- This predicate is a bit of a hack.
+ nameModule (availName avail) /= mod
+ -- This nameModule predicate is a bit of a hack.
-- PrelBase imports error from PrelErr.hi-boot; but error is
-- wired in, so its provenance doesn't say it's from an hi-boot
-- file. Result: disaster when PrelErr.hi doesn't exist.
+ -- [Jan 99: I now can't see how the predicate achieves the goal!]
+ ]
same_module n1 n2 = nameModule n1 == nameModule n2
load n = loadHomeInterface (doc_str n) n
diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs
index 0c673e613272..b6c6c627d41b 100644
--- a/ghc/compiler/rename/RnSource.lhs
+++ b/ghc/compiler/rename/RnSource.lhs
@@ -153,7 +153,7 @@ rnDecl (TyClD (TyData new_or_data context tycon tyvars condecls derivings pragma
returnRn (TyClD (TyData new_or_data context' tycon' tyvars' condecls' derivings' noDataPragmas src_loc),
cxt_fvs `plusFV` plusFVs con_fvs_s `plusFV` deriv_fvs)
where
- data_doc = text "the data typecodeGen/ declaration for" <+> ppr tycon
+ data_doc = text "the data type declaration for" <+> ppr tycon
con_names = map conDeclName condecls
rnDecl (TyClD (TySynonym name tyvars ty src_loc))
diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs
index a1be69a71cb6..84fc1d92c994 100644
--- a/ghc/compiler/typecheck/TcExpr.lhs
+++ b/ghc/compiler/typecheck/TcExpr.lhs
@@ -464,11 +464,12 @@ tcMonoExpr (RecordCon con_name rbinds) res_ty
let
bad_fields = badFields rbinds data_con
in
- mapNF_Tc (addErrTc . badFieldCon con_name) bad_fields `thenNF_Tc_`
+ if not (null bad_fields) then
+ mapNF_Tc (addErrTc . badFieldCon con_name) bad_fields `thenNF_Tc_`
+ failTc -- Fail now, because tcRecordBinds will crash on a bad field
+ else
-- Typecheck the record bindings
- -- (Do this after checkRecordFields in case there's a field that
- -- doesn't match the constructor.)
tcRecordBinds record_ty rbinds `thenTc` \ (rbinds', rbinds_lie) ->
returnTc (RecordConOut data_con con_expr rbinds', con_lie `plusLIE` rbinds_lie)
--
GitLab