Skip to content

GitLab

Commit 98200644 authored by simonpj's avatar simonpj
Browse files

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

Small changes to make the compiler boot itself
parent 6c43076c
Hide whitespace changes
Inline Side-by-side
ghc/compiler/Makefile
View file @ 98200644
# -----------------------------------------------------------------------------
# $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
View file @ 98200644
__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
View file @ 98200644
__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
View file @ 98200644
__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
View file @ 98200644
......@@ -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
View file @ 98200644
......@@ -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
View file @ 98200644
......@@ -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
View file @ 98200644
__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
View file @ 98200644
__interface TcEnv 1 0 where
__export TcEnv TcEnv;
1 data TcEnv a;
1 data TcEnv ;
ghc/compiler/typecheck/TcExpr.hi-boot-5
View file @ 98200644
......@@ -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
View file @ 98200644
......@@ -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 0 → 100644
View file @ 98200644
__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
View file @ 98200644
......@@ -4,3 +4,4 @@ __export Type Type Kind SuperKind ;
1 type Kind = Type ;
1 type SuperKind = Type ;
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment