X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Frename%2FRnSource.lhs;h=f2683e8058cbdf20af3184c79269fe1792f284e2;hb=4d4c860c6e82118f760d0debdece55114543158f;hp=9842d4533e3a6f0c7e3f40efc885b9b2387a5666;hpb=df8b00e014ad8280354dd3fab6e6df0a52377627;p=ghc-hetmet.git

diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs
index 9842d45..f2683e8 100644
--- a/compiler/rename/RnSource.lhs
+++ b/compiler/rename/RnSource.lhs
@@ -5,12 +5,15 @@
 
 \begin{code}
 module RnSource ( 
-	rnSrcDecls, addTcgDUs, rnTyClDecls 
+	rnSrcDecls, addTcgDUs, rnTyClDecls, findSplice
     ) where
 
 #include "HsVersions.h"
 
 import {-# SOURCE #-} RnExpr( rnLExpr )
+#ifdef GHCI
+import {-# SOURCE #-} TcSplice ( runQuasiQuoteDecl )
+#endif 	/* GHCI */
 
 import HsSyn
 import RdrName		( RdrName, isRdrDataCon, elemLocalRdrEnv, rdrNameOcc )
@@ -31,6 +34,8 @@ import HscTypes      	( GenAvailInfo(..), availsToNameSet )
 import RnHsDoc          ( rnHsDoc, rnMbLHsDoc )
 import TcRnMonad
 
+import ForeignCall	( CCallTarget(..) )
+import Module
 import HscTypes		( Warnings(..), plusWarns )
 import Class		( FunDep )
 import Name		( Name, nameOccName )
@@ -41,10 +46,12 @@ import Bag
 import FastString
 import Util		( filterOut )
 import SrcLoc
-import DynFlags	        ( DynFlag(..) )
+import DynFlags	        ( DynFlag(..), DynFlags, thisPackage )
+import HscTypes		( HscEnv, hsc_dflags )
 import BasicTypes       ( Boxity(..) )
 import ListSetOps       ( findDupsEq )
 
+
 import Control.Monad
 import Data.Maybe
 \end{code}
@@ -118,7 +125,7 @@ rnSrcDecls group@(HsGroup {hs_valds  = val_decls,
    --     It uses the fixity env from (A) to bind fixities for view patterns.
    new_lhs <- rnTopBindsLHS local_fix_env val_decls ;
    -- bind the LHSes (and their fixities) in the global rdr environment
-   let { val_binders = map unLoc $ collectHsValBinders new_lhs ;
+   let { val_binders = collectHsValBinders new_lhs ;
 	 val_bndr_set = mkNameSet val_binders ;
 	 all_bndr_set = val_bndr_set `unionNameSets` availsToNameSet tc_avails ;
          val_avails = map Avail val_binders 
@@ -368,9 +375,15 @@ rnDefaultDecl (DefaultDecl tys)
 \begin{code}
 rnHsForeignDecl :: ForeignDecl RdrName -> RnM (ForeignDecl Name, FreeVars)
 rnHsForeignDecl (ForeignImport name ty spec)
-  = lookupLocatedTopBndrRn name	        `thenM` \ name' ->
+  = getTopEnv                           `thenM` \ (topEnv :: HscEnv) ->
+    lookupLocatedTopBndrRn name	        `thenM` \ name' ->
     rnHsTypeFVs (fo_decl_msg name) ty	`thenM` \ (ty', fvs) ->
-    return (ForeignImport name' ty' spec, fvs)
+
+    -- Mark any PackageTarget style imports as coming from the current package
+    let packageId	= thisPackage $ hsc_dflags topEnv
+	spec'		= patchForeignImport packageId spec
+
+    in	return (ForeignImport name' ty' spec', fvs)
 
 rnHsForeignDecl (ForeignExport name ty spec)
   = lookupLocatedOccRn name	        `thenM` \ name' ->
@@ -382,6 +395,32 @@ rnHsForeignDecl (ForeignExport name ty spec)
 
 fo_decl_msg :: Located RdrName -> SDoc
 fo_decl_msg name = ptext (sLit "In the foreign declaration for") <+> ppr name
+
+
+-- | For Windows DLLs we need to know what packages imported symbols are from
+--	to generate correct calls. Imported symbols are tagged with the current
+--	package, so if they get inlined across a package boundry we'll still
+--	know where they're from.
+--
+patchForeignImport :: PackageId -> ForeignImport -> ForeignImport
+patchForeignImport packageId (CImport cconv safety fs spec)
+	= CImport cconv safety fs (patchCImportSpec packageId spec) 
+
+patchCImportSpec :: PackageId -> CImportSpec -> CImportSpec
+patchCImportSpec packageId spec
+ = case spec of
+	CFunction callTarget	-> CFunction $ patchCCallTarget packageId callTarget
+	_			-> spec
+
+patchCCallTarget :: PackageId -> CCallTarget -> CCallTarget
+patchCCallTarget packageId callTarget
+ = case callTarget of
+ 	StaticTarget label Nothing
+	 -> StaticTarget label (Just packageId)
+
+	_			-> callTarget	
+
+
 \end{code}
 
 
@@ -401,7 +440,7 @@ rnSrcInstDecl (InstDecl inst_ty mbinds uprags ats)
 	-- The typechecker (not the renamer) checks that all 
 	-- the bindings are for the right class
     let
-	meth_names  = collectHsBindLocatedBinders mbinds
+	meth_names  = collectMethodBinders mbinds
 	(inst_tyvars, _, cls,_) = splitHsInstDeclTy (unLoc inst_ty')
     in
     checkDupRdrNames meth_names 	`thenM_`
@@ -439,7 +478,7 @@ rnSrcInstDecl (InstDecl inst_ty mbinds uprags ats)
 	--
 	-- But the (unqualified) method names are in scope
     let 
-	binders = collectHsBindBinders mbinds'
+	binders = collectHsBindsBinders mbinds'
 	bndr_set = mkNameSet binders
     in
     bindLocalNames binders 
@@ -690,9 +729,10 @@ rnTyClDecl tydecl@TyData {tcdND = new_or_data, tcdCtxt = context,
 		   else emptyFVs))
         }
   where
-    h98_style = case condecls of
-		     L _ (ConDecl { con_res = ResTyH98 }) : _  -> True
-		     _    		                       -> False
+    h98_style = case condecls of	 -- Note [Stupid theta]
+		     L _ (ConDecl { con_res = ResTyGADT {} }) : _  -> False
+		     _    		                           -> True
+               		     						  
     data_doc = text "In the data type declaration for" <+> quotes (ppr tycon)
 
     rn_derivs Nothing   = return (Nothing, emptyFVs)
@@ -788,6 +828,15 @@ badGadtStupidTheta _
 	  ptext (sLit "(You can put a context on each contructor, though.)")]
 \end{code}
 
+Note [Stupid theta]
+~~~~~~~~~~~~~~~~~~~
+Trac #3850 complains about a regression wrt 6.10 for 
+     data Show a => T a
+There is no reason not to allow the stupid theta if there are no data
+constructors.  It's still stupid, but does no harm, and I don't want
+to cause programs to break unnecessarily (notably HList).  So if there
+are no data constructors we allow h98_style = True
+
 
 %*********************************************************
 %*							*
@@ -1050,3 +1099,83 @@ rnHsTyVar _doc tyvar = lookupOccRn tyvar
 \end{code}
 
 
+%*********************************************************
+%*							*
+	findSplice
+%*							*
+%*********************************************************
+
+This code marches down the declarations, looking for the first
+Template Haskell splice.  As it does so it
+	a) groups the declarations into a HsGroup
+	b) runs any top-level quasi-quotes
+
+\begin{code}
+findSplice :: [LHsDecl RdrName] -> RnM (HsGroup RdrName, Maybe (SpliceDecl RdrName, [LHsDecl RdrName]))
+findSplice ds = addl emptyRdrGroup ds
+
+addl :: HsGroup RdrName -> [LHsDecl RdrName]
+     -> RnM (HsGroup RdrName, Maybe (SpliceDecl RdrName, [LHsDecl RdrName]))
+-- This stuff reverses the declarations (again) but it doesn't matter
+addl gp []	     = return (gp, Nothing)
+addl gp (L l d : ds) = add gp l d ds
+
+
+add :: HsGroup RdrName -> SrcSpan -> HsDecl RdrName -> [LHsDecl RdrName]
+    -> RnM (HsGroup RdrName, Maybe (SpliceDecl RdrName, [LHsDecl RdrName]))
+
+add gp _ (SpliceD e) ds = return (gp, Just (e, ds))
+
+#ifndef GHCI
+add _ _ (QuasiQuoteD qq) _
+  = pprPanic "Can't do QuasiQuote declarations without GHCi" (ppr qq)
+#else
+add gp _ (QuasiQuoteD qq) ds		-- Expand quasiquotes
+  = do { ds' <- runQuasiQuoteDecl qq
+       ; addl gp (ds' ++ ds) }
+#endif
+
+-- Class declarations: pull out the fixity signatures to the top
+add gp@(HsGroup {hs_tyclds = ts, hs_fixds = fs}) l (TyClD d) ds
+  | isClassDecl d
+  = let fsigs = [ L l f | L l (FixSig f) <- tcdSigs d ] in
+    addl (gp { hs_tyclds = L l d : ts, hs_fixds = fsigs ++ fs}) ds
+  | otherwise
+  = addl (gp { hs_tyclds = L l d : ts }) ds
+
+-- Signatures: fixity sigs go a different place than all others
+add gp@(HsGroup {hs_fixds = ts}) l (SigD (FixSig f)) ds
+  = addl (gp {hs_fixds = L l f : ts}) ds
+add gp@(HsGroup {hs_valds = ts}) l (SigD d) ds
+  = addl (gp {hs_valds = add_sig (L l d) ts}) ds
+
+-- Value declarations: use add_bind
+add gp@(HsGroup {hs_valds  = ts}) l (ValD d) ds
+  = addl (gp { hs_valds = add_bind (L l d) ts }) ds
+
+-- The rest are routine
+add gp@(HsGroup {hs_instds = ts})  l (InstD d) ds
+  = addl (gp { hs_instds = L l d : ts }) ds
+add gp@(HsGroup {hs_derivds = ts})  l (DerivD d) ds
+  = addl (gp { hs_derivds = L l d : ts }) ds
+add gp@(HsGroup {hs_defds  = ts})  l (DefD d) ds
+  = addl (gp { hs_defds = L l d : ts }) ds
+add gp@(HsGroup {hs_fords  = ts}) l (ForD d) ds
+  = addl (gp { hs_fords = L l d : ts }) ds
+add gp@(HsGroup {hs_warnds  = ts})  l (WarningD d) ds
+  = addl (gp { hs_warnds = L l d : ts }) ds
+add gp@(HsGroup {hs_annds  = ts}) l (AnnD d) ds
+  = addl (gp { hs_annds = L l d : ts }) ds
+add gp@(HsGroup {hs_ruleds  = ts}) l (RuleD d) ds
+  = addl (gp { hs_ruleds = L l d : ts }) ds
+add gp l (DocD d) ds
+  = addl (gp { hs_docs = (L l d) : (hs_docs gp) })  ds
+
+add_bind :: LHsBind a -> HsValBinds a -> HsValBinds a
+add_bind b (ValBindsIn bs sigs) = ValBindsIn (bs `snocBag` b) sigs
+add_bind _ (ValBindsOut {})     = panic "RdrHsSyn:add_bind"
+
+add_sig :: LSig a -> HsValBinds a -> HsValBinds a
+add_sig s (ValBindsIn bs sigs) = ValBindsIn bs (s:sigs) 
+add_sig _ (ValBindsOut {})     = panic "RdrHsSyn:add_sig"
+\end{code}
\ No newline at end of file