[project @ 1999-01-07 12:48:13 by simonpj]

Small changes to make the compiler boot itself

ghc/compiler/Makefile

 # -----------------------------------------------------------------------------
-# $Id: Makefile,v 1.47 1998/12/10 08:54:18 simonpj Exp $
+# $Id: Makefile,v 1.48 1999/01/07 12:48:13 simonpj Exp $
 
 TOP = ..
 include $(TOP)/mk/boilerplate.mk
@@ -178,7 +178,7 @@ reader/Lex_HC_OPTS		= -K2m -H16m -fvia-C
 # Heap was 6m with 2.10
 reader/ReadPrefix_HC_OPTS 	= -fvia-C '-\#include"hspincl.h"' -H10m
 
-rename/ParseIface_HC_OPTS 	+= -Onot -H30m -fno-warn-incomplete-patterns
+rename/ParseIface_HC_OPTS 	+= -Onot -H45m -fno-warn-incomplete-patterns
 rename/ParseIface_HAPPY_OPTS    += -g
 
 ifeq "$(TARGETPLATFORM)" "hppa1.1-hp-hpux9"

ghc/compiler/hsSyn/HsExpr.hi-boot-5

 __interface HsExpr 1 0 where
 __export HsExpr HsExpr pprExpr;
-1 data HsExpr f i p ;
-1 pprExpr :: __forall [_i _p _f] {Name.NamedThing _i, Outputable.Outputable _i, Outputable.Outputable _p} => HsExpr.HsExpr _f _i _p -> Outputable.SDoc ;
+1 data HsExpr i p ;
+1 pprExpr :: __forall [_i _p] {Name.NamedThing _i, Outputable.Outputable _i, Outputable.Outputable _p} => HsExpr.HsExpr _i _p -> Outputable.SDoc ;

ghc/compiler/hsSyn/HsMatches.hi-boot-5

 __interface HsMatches 1 0 where
-__export HsMatches Match GRHSsAndBinds pprMatch pprMatches pprGRHSsAndBinds ;
-1 data Match a b c ;
-1 data GRHSsAndBinds a b c ;
-1 pprGRHSsAndBinds :: __forall [_i _p _f] {Name.NamedThing _i, Outputable.Outputable _i, Outputable.Outputable _p} => PrelBase.Bool -> HsMatches.GRHSsAndBinds _f _i _p -> Outputable.SDoc ;
-1 pprMatch :: __forall [_i _p _f] {Name.NamedThing _i, Outputable.Outputable _i, Outputable.Outputable _p} => PrelBase.Bool -> HsMatches.Match _f _i _p -> Outputable.SDoc ;
-1 pprMatches :: __forall [_i _p _f] {Name.NamedThing _i, Outputable.Outputable _i, Outputable.Outputable _p} => (PrelBase.Bool, Outputable.SDoc) -> [HsMatches.Match _f _i _p] -> Outputable.SDoc ;
+__export HsMatches Match GRHSs pprMatch pprMatches pprGRHSs ;
+1 data Match a b ;
+1 data GRHSs a b ;
+1 pprGRHSs :: __forall [i p] {Name.NamedThing i, Outputable.Outputable i, Outputable.Outputable p} => PrelBase.Bool -> HsMatches.GRHSs i p -> Outputable.SDoc ;
+1 pprMatch :: __forall [_i _p] {Name.NamedThing _i, Outputable.Outputable _i, Outputable.Outputable _p} => (PrelBase.Bool, Outputable.SDoc) -> HsMatches.Match _i _p -> Outputable.SDoc ;
+1 pprMatches :: __forall [_i _p] {Name.NamedThing _i, Outputable.Outputable _i, Outputable.Outputable _p} => (PrelBase.Bool, Outputable.SDoc) -> [HsMatches.Match _i _p] -> Outputable.SDoc ;

ghc/compiler/rename/RnBinds.hi-boot-5

 __interface RnBinds 1 0 where
 __export RnBinds rnBinds;
-1 rnBinds :: __forall [_a _b] => RdrHsSyn.RdrNameHsBinds -> (RnHsSyn.RenamedHsBinds -> RnMonad.RnMS _a (_b, RnMonad.FreeVars)) -> RnMonad.RnMS _a (_b, RnMonad.FreeVars) ;
+1 rnBinds :: __forall [_a _b] => RdrHsSyn.RdrNameHsBinds -> (RnHsSyn.RenamedHsBinds -> RnMonad.RnMS _a (_b, RnEnv.FreeVars)) -> RnMonad.RnMS _a (_b, RnEnv.FreeVars) ;

ghc/compiler/rename/RnEnv.lhs

@@ -499,13 +499,16 @@ combine_globals ns_old ns_new	-- ns_new is often short
 	       choose n' | n==n' && better_provenance n n' = n
 			 | otherwise			   = n'
 
--- Choose a user-imported thing over a non-user-imported thing
--- and an explicitly-imported thing over an implicitly imported thing
+-- Choose 
+--	a local thing		      over an	imported thing
+--	a user-imported thing	      over a	non-user-imported thing
+-- 	an explicitly-imported thing  over an	implicitly imported thing
 better_provenance n1 n2
   = case (getNameProvenance n1, getNameProvenance n2) of
+	(LocalDef _ _,				_			      ) -> True
 	(NonLocalDef (UserImport _ _ True) _ _, _			      ) -> True
 	(NonLocalDef (UserImport _ _ _   ) _ _, NonLocalDef ImplicitImport _ _) -> True
-	other -> False
+	other									-> False
 
 no_conflict :: Name -> Name -> Bool
 no_conflict n1 n2 | isLocallyDefined n1 && isLocallyDefined n2 = False

ghc/compiler/rename/RnIfaces.lhs

@@ -270,7 +270,7 @@ loadDecl mod as_source decls_map (version, decl)
 				       [ (name, (version,avail,decl',name==main_name)) 
 				       | name <- sys_bndrs ++ availNames avail]
 	add_decl decls_map (name, stuff)
-	  = ASSERT2( not (name `elemNameEnv` decls_map), ppr name )
+	  = WARN( name `elemNameEnv` decls_map, ppr name )
 	    addToNameEnv decls_map name stuff
     in
     returnRn new_decls_map

ghc/compiler/rename/RnNames.lhs

@@ -78,7 +78,7 @@ getGlobalNames (HsModule this_mod _ exports imports decls mod_loc)
 	importsFromLocalDecls this_mod rec_exp_fn decls	`thenRn` \ (local_gbl_env, local_mod_avails) ->
 
 		-- PROCESS IMPORT DECLS
-	mapAndUnzipRn (importsFromImportDecl rec_unqual_fn)
+	mapAndUnzipRn (importsFromImportDecl this_mod rec_unqual_fn)
 		      all_imports			`thenRn` \ (imp_gbl_envs, imp_avails_s) ->
 
 		-- COMBINE RESULTS
@@ -181,22 +181,23 @@ checkEarlyExit mod
 \end{code}
 	
 \begin{code}
-importsFromImportDecl :: (Name -> Bool)		-- True => print unqualified
+importsFromImportDecl :: Module			-- The module being compiled
+		      -> (Name -> Bool)		-- True => print unqualified
 		      -> RdrNameImportDecl
 		      -> RnMG (GlobalRdrEnv, 
 			       ExportAvails) 
 
-importsFromImportDecl rec_unqual_fn (ImportDecl mod qual_only as_source as_mod import_spec iloc)
+importsFromImportDecl this_mod rec_unqual_fn (ImportDecl imp_mod qual_only as_source as_mod import_spec iloc)
   = pushSrcLocRn iloc $
-    getInterfaceExports mod as_source		`thenRn` \ avails ->
+    getInterfaceExports imp_mod as_source		`thenRn` \ avails ->
 
     if null avails then
 	-- If there's an error in getInterfaceExports, (e.g. interface
 	-- file not found) we get lots of spurious errors from 'filterImports'
-	returnRn (emptyRdrEnv, mkEmptyExportAvails mod)
+	returnRn (emptyRdrEnv, mkEmptyExportAvails imp_mod)
     else
 
-    filterImports mod import_spec avails	`thenRn` \ (filtered_avails, hides, explicits) ->
+    filterImports imp_mod import_spec avails	`thenRn` \ (filtered_avails, hides, explicits) ->
 
 	-- Load all the home modules for the things being
 	-- bought into scope.  This makes sure their fixities
@@ -212,12 +213,10 @@ importsFromImportDecl rec_unqual_fn (ImportDecl mod qual_only as_source as_mod i
 				  other        -> True,
 			
 			       let name = availName avail,
-			       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!]
+			       not (isLocallyDefined name || nameModule name == imp_mod)
+				-- Don't try to load the module being compiled
+				--	(this can happen in mutual-recursion situations)
+				-- or from the module being imported (it's already loaded)
 			]
 				
 	same_module n1 n2 = nameModule n1 == nameModule n2
@@ -236,11 +235,11 @@ importsFromImportDecl rec_unqual_fn (ImportDecl mod qual_only as_source as_mod i
 			  | otherwise	       = setNameProvenance name (mk_new_prov name)
 
 	is_explicit name = name `elemNameSet` explicits
-	mk_new_prov name = NonLocalDef (UserImport mod iloc (is_explicit name))
+	mk_new_prov name = NonLocalDef (UserImport imp_mod iloc (is_explicit name))
 				       as_source
 				       (rec_unqual_fn name)
     in
-    qualifyImports mod 
+    qualifyImports imp_mod 
 		   (not qual_only)	-- Maybe want unqualified names
 		   as_mod hides
 		   filtered_avails improve_prov		`thenRn` \ (rdr_name_env, mod_avails) ->
@@ -354,7 +353,7 @@ fixitiesFromLocalDecls gbl_env decls
 available, and filters it through the import spec (if any).
 
 \begin{code}
-filterImports :: Module
+filterImports :: Module				-- The module being imported
 	      -> Maybe (Bool, [RdrNameIE])	-- Import spec; True => hiding
 	      -> [AvailInfo]			-- What's available
 	      -> RnMG ([AvailInfo],		-- What's actually imported

ghc/compiler/rename/RnSource.hi-boot-5

 __interface RnSource 1 0 where
-__export RnSource rnHsSigType;
-1 rnHsSigType :: __forall [_a] => (Outputable.SDoc)
+__export RnSource rnHsSigType rnHsType;
+1 rnHsSigType :: __forall [_a] => Outputable.SDoc
 			       -> RdrHsSyn.RdrNameHsType
-			       -> RnMonad.RnMS _a RnHsSyn.RenamedHsType ;
+			       -> RnMonad.RnMS _a (RnHsSyn.RenamedHsType, RnEnv.FreeVars) ;
+1 rnHsType :: __forall [_a] => Outputable.SDoc
+			       -> RdrHsSyn.RdrNameHsType
+			       -> RnMonad.RnMS _a (RnHsSyn.RenamedHsType, RnEnv.FreeVars) ;

ghc/compiler/typecheck/TcEnv.hi-boot-5

 __interface TcEnv 1 0 where
 __export TcEnv TcEnv;
-1 data TcEnv a;
+1 data TcEnv ;

ghc/compiler/typecheck/TcExpr.hi-boot-5

@@ -2,5 +2,5 @@ __interface TcExpr 1 0 where
 __export TcExpr tcExpr ;
 1 tcExpr :: __forall [_s] => 
 	  RnHsSyn.RenamedHsExpr
-       -> TcMonad.TcType _s 
-       -> TcMonad.TcM _s (TcHsSyn.TcExpr _s, Inst.LIE _s) ;
+       -> TcMonad.TcType
+       -> TcMonad.TcM _s (TcHsSyn.TcExpr, Inst.LIE) ;

ghc/compiler/typecheck/TcExpr.lhs

@@ -504,18 +504,29 @@ tcMonoExpr (RecordCon con_name rbinds) res_ty
 tcMonoExpr (RecordUpd record_expr rbinds) res_ty
   = tcAddErrCtxt recordUpdCtxt			$
 
-	-- STEP 1
-	-- Figure out the tycon and data cons from the first field name
+	-- STEP 0
+	-- Check that the field names are really field names
     ASSERT( not (null rbinds) )
     let 
-	((first_field_name, _, _) : rest) = rbinds
+	field_names = [field_name | (field_name, _, _) <- rbinds]
+    in
+    mapNF_Tc tcLookupValueMaybe field_names		`thenNF_Tc` \ maybe_sel_ids ->
+    let
+	bad_guys = [field_name | (field_name, maybe_sel_id) <- field_names `zip` maybe_sel_ids,
+				 case maybe_sel_id of
+					Nothing -> True
+					Just sel_id -> not (isRecordSelector sel_id)
+		   ]
     in
-    tcLookupValueMaybe first_field_name		`thenNF_Tc` \ maybe_sel_id ->
-    (case maybe_sel_id of
-	Just sel_id | isRecordSelector sel_id -> returnTc sel_id
-	other				      -> failWithTc (notSelector first_field_name)
-    )						`thenTc` \ sel_id ->
+    mapNF_Tc (addErrTc . notSelector) bad_guys	`thenTc_`
+    if not (null bad_guys) then
+	failTc
+    else
+    
+	-- STEP 1
+	-- Figure out the tycon and data cons from the first field name
     let
+	(Just sel_id : _)	  = maybe_sel_ids
 	(_, tau)	      	  = splitForAllTys (idType sel_id)
 	Just (data_ty, _)     	  = splitFunTy_maybe tau	-- Must succeed since sel_id is a selector
 	(tycon, _, data_cons) 	  = splitAlgTyConApp data_ty
@@ -524,9 +535,11 @@ tcMonoExpr (RecordUpd record_expr rbinds) res_ty
     tcInstTyVars con_tyvars			`thenNF_Tc` \ (_, result_inst_tys, _) ->
 
 	-- STEP 2
-	-- Check for bad fields
+	-- Check that at least one constructor has all the named fields
+	-- i.e. has an empty set of bad fields returned by badFields
     checkTc (any (null . badFields rbinds) data_cons)
 	    (badFieldsUpd rbinds)		`thenTc_`
+
 	-- STEP 3
 	-- Typecheck the update bindings.
 	-- (Do this after checking for bad fields in case there's a field that

ghc/compiler/typecheck/TcMatches.hi-boot-5

+__interface TcMatches 1 0 where
+__export TcMatches tcGRHSs tcMatchesFun;
+1 tcGRHSs :: __forall [s] => 
+	      RnHsSyn.RenamedGRHSs
+	      -> TcMonad.TcType
+	      -> HsExpr.StmtCtxt
+	      -> TcMonad.TcM s (TcHsSyn.TcGRHSs, Inst.LIE) ;
+1 tcMatchesFun :: __forall [s] => 
+		[(Name.Name,Var.Id)]
+	     ->	Name.Name
+	     -> TcMonad.TcType
+	     -> [RnHsSyn.RenamedMatch]
+	     -> TcMonad.TcM s ([TcHsSyn.TcMatch], Inst.LIE) ;
+

ghc/compiler/types/Type.hi-boot-5

@@ -4,3 +4,4 @@ __export Type Type Kind SuperKind ;
 1 type Kind = Type ;
 1 type SuperKind = Type ;
 
+