[project @ 2001-05-24 13:59:09 by simonpj]

------------------------------------------------------
	More stuff towards generalising 'foreign' declarations
	------------------------------------------------------

This is the second step towards generalising 'foreign' declarations to
handle langauges other than C.  Now I can handle

  foreign import dotnet type T
  foreign import dotnet "void Foo.Baz.f( T )" f :: T -> IO ()



			** WARNING **
	I believe that all the foreign stuff for C should
	work exactly as before, but I have not tested it
	thoroughly.  Sven, Manuel, Marcin: please give it a
	whirl and compare old with new output.


Lots of fiddling around with data types.  The main changes are

* HsDecls.lhs
	The ForeignDecl type and its friends
	Note also the ForeignType constructor to TyClDecl

* ForeignCall.lhs
	Here's where the stuff that survives right through
	compilation lives

* TcForeign.lhs DsForeign.lhs
	Substantial changes driven by the new data types

* Parser.y ParseIface.y RnSource
	Just what you'd expect

5 files changed, 46 insertions, 41 deletions

diff --git a/ghc/compiler/rename/ParseIface.y b/ghc/compiler/rename/ParseIface.y
index 78aa4773da..47fda3acf6 100644
--- a/ghc/compiler/rename/ParseIface.y
+++ b/ghc/compiler/rename/ParseIface.y
@@ -351,6 +351,8 @@ decl    : src_loc qvar_name '::' type maybe_idinfo
   		 	{ IfaceSig $2 $4 ($5 $2) $1 }
 	| src_loc 'type' qtc_name tv_bndrs '=' type 		       
 			{ TySynonym $3 $4 $6 $1 }
+	| src_loc 'foreign' 'type' qtc_name  		       
+			{ ForeignType $4 DNType $1 }
 	| src_loc 'data' opt_decl_context qtc_name tv_bndrs constrs 	       
 	       		{ mkTyData DataType $3 $4 $5 $6 (length $6) Nothing $1 }
 	| src_loc 'newtype' opt_decl_context qtc_name tv_bndrs newtype_constr
@@ -808,9 +810,10 @@ core_aexpr      : qvar_name				        { UfVar $1 }
                                  (is_dyn, is_casm, may_gc) = $2
 
 			         target | is_dyn    = DynamicTarget
+					| is_casm   = CasmTarget $3
 					| otherwise = StaticTarget $3
 
-	                         ccall = CCallSpec target CCallConv may_gc is_casm
+	                         ccall = CCallSpec target CCallConv may_gc
  	                     in
 			     UfFCall (CCall ccall) $4
 			   }
diff --git a/ghc/compiler/rename/RnHsSyn.lhs b/ghc/compiler/rename/RnHsSyn.lhs
index 13c14bca8d..a1fbfeb0c8 100644
--- a/ghc/compiler/rename/RnHsSyn.lhs
+++ b/ghc/compiler/rename/RnHsSyn.lhs
@@ -119,6 +119,9 @@ In all cases this is set up for interface-file declarations:
 
 \begin{code}
 tyClDeclFVs :: RenamedTyClDecl -> NameSet
+tyClDeclFVs (ForeignType {})
+  = emptyFVs
+
 tyClDeclFVs (IfaceSig {tcdType = ty, tcdIdInfo = id_infos})
   = extractHsTyNames ty			`plusFV` 
     plusFVs (map hsIdInfoFVs id_infos)
diff --git a/ghc/compiler/rename/RnIfaces.lhs b/ghc/compiler/rename/RnIfaces.lhs
index 7cab59c01d..f60ae46059 100644
--- a/ghc/compiler/rename/RnIfaces.lhs
+++ b/ghc/compiler/rename/RnIfaces.lhs
@@ -489,7 +489,8 @@ getGates :: FreeVars		-- Things mentioned in the source program
 getGates source_fvs decl 
   = get_gates (\n -> n `elemNameSet` source_fvs) decl
 
-get_gates is_used (IfaceSig {tcdType = ty}) = extractHsTyNames ty
+get_gates is_used (ForeignType {tcdName = tycon}) = unitNameSet tycon
+get_gates is_used (IfaceSig    {tcdType = ty})    = extractHsTyNames ty
 
 get_gates is_used (ClassDecl { tcdCtxt = ctxt, tcdName = cls, tcdTyVars = tvs, tcdSigs = sigs})
   = (super_cls_and_sigs `addOneToNameSet` cls) `unionNameSets` 
diff --git a/ghc/compiler/rename/RnNames.lhs b/ghc/compiler/rename/RnNames.lhs
index a54dbd857c..2bfe8a5c46 100644
--- a/ghc/compiler/rename/RnNames.lhs
+++ b/ghc/compiler/rename/RnNames.lhs
@@ -13,7 +13,7 @@ module RnNames (
 import CmdLineOpts	( DynFlag(..) )
 
 import HsSyn		( HsModule(..), HsDecl(..), IE(..), ieName, ImportDecl(..),
-			  ForeignDecl(..), ForKind(..), isDynamicExtName,
+			  ForeignDecl(..), 
 			  collectLocatedHsBinders
 			)
 import RdrHsSyn		( RdrNameIE, RdrNameImportDecl,
@@ -244,17 +244,11 @@ getLocalDeclBinders mod (ValD binds)
     new (rdr_name, loc) = newTopBinder mod rdr_name loc 	`thenRn` \ name ->
 			  returnRn (Avail name)
 
-getLocalDeclBinders mod (ForD (ForeignDecl nm kind _ ext_nm _ loc))
-  | binds_haskell_name kind
+getLocalDeclBinders mod (ForD (ForeignImport nm _ _ loc))
   = newTopBinder mod nm loc	    `thenRn` \ name ->
     returnRn [Avail name]
-
-  | otherwise 		-- a foreign export
+getLocalDeclBinders mod (ForD _)
   = returnRn []
-  where
-    binds_haskell_name (FoImport _) = True
-    binds_haskell_name FoLabel      = True
-    binds_haskell_name FoExport     = isDynamicExtName ext_nm
 
 getLocalDeclBinders mod (FixD _)    = returnRn []
 getLocalDeclBinders mod (DeprecD _) = returnRn []
diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs
index 781e67ca41..71fe8ffc44 100644
--- a/ghc/compiler/rename/RnSource.lhs
+++ b/ghc/compiler/rename/RnSource.lhs
@@ -49,8 +49,6 @@ import CmdLineOpts	( DynFlag(..) )
 				-- Warn of unused for-all'd tyvars
 import Unique		( Uniquable(..) )
 import Maybes		( maybeToBool )
-import ErrUtils		( Message )
-import CStrings		( isCLabelString )
 import ListSetOps	( removeDupsEq )
 \end{code}
 
@@ -112,39 +110,44 @@ rnSourceDecl (RuleD rule)
   = rnHsRuleDecl rule		`thenRn` \ (new_rule, fvs) ->
     returnRn (RuleD new_rule, fvs)
 
+rnSourceDecl (ForD ford)
+  = rnHsForeignDecl ford		`thenRn` \ (new_ford, fvs) ->
+    returnRn (ForD new_ford, fvs)
+
 rnSourceDecl (DefD (DefaultDecl tys src_loc))
   = pushSrcLocRn src_loc $
     mapFvRn (rnHsTypeFVs doc_str) tys		`thenRn` \ (tys', fvs) ->
     returnRn (DefD (DefaultDecl tys' src_loc), fvs)
   where
     doc_str = text "a `default' declaration"
+\end{code}
 
-rnSourceDecl (ForD (ForeignDecl name imp_exp ty ext_nm cconv src_loc))
-  = pushSrcLocRn src_loc $
-    lookupOccRn name		        `thenRn` \ name' ->
-    let 
-	extra_fvs FoExport 
-	  | isDyn = lookupOrigNames [newStablePtr_RDR, deRefStablePtr_RDR,
-				     bindIO_RDR, returnIO_RDR]
-	  | otherwise =
-		lookupOrigNames [bindIO_RDR, returnIO_RDR] `thenRn` \ fvs ->
-		returnRn (addOneFV fvs name')
-	extra_fvs other = returnRn emptyFVs
-    in
-    checkRn (ok_ext_nm ext_nm) (badExtName ext_nm)	`thenRn_`
 
-    extra_fvs imp_exp					`thenRn` \ fvs1 -> 
+%*********************************************************
+%*							*
+\subsection{Foreign declarations}
+%*							*
+%*********************************************************
+
+\begin{code}
+rnHsForeignDecl (ForeignImport name ty spec src_loc)
+  = pushSrcLocRn src_loc 		$
+    lookupOccRn name		        `thenRn` \ name' ->
+    rnHsTypeFVs (fo_decl_msg name) ty	`thenRn` \ (ty', fvs1) ->
+    lookupOrigNames (extras spec)	`thenRn` \ fvs2 ->
+    returnRn (ForeignImport name' ty' spec src_loc, fvs1 `plusFV` fvs2)
+  where
+    extras (CDynImport _) = [newStablePtr_RDR, deRefStablePtr_RDR, bindIO_RDR, returnIO_RDR]
+    extras other	  = []
 
-    rnHsTypeFVs fo_decl_msg ty	       		`thenRn` \ (ty', fvs2) ->
-    returnRn (ForD (ForeignDecl name' imp_exp ty' ext_nm cconv src_loc), 
-	      fvs1 `plusFV` fvs2)
- where
-  fo_decl_msg = ptext SLIT("The foreign declaration for") <+> ppr name
-  isDyn	      = isDynamicExtName ext_nm
+rnHsForeignDecl (ForeignExport name ty spec src_loc)
+  = pushSrcLocRn src_loc 			$
+    lookupOccRn name		        	`thenRn` \ name' ->
+    rnHsTypeFVs (fo_decl_msg name) ty  		`thenRn` \ (ty', fvs1) ->
+    lookupOrigNames [bindIO_RDR, returnIO_RDR]	`thenRn` \ fvs2 ->
+    returnRn (ForeignExport name' ty' spec src_loc, fvs1 `plusFV` fvs2)
 
-  ok_ext_nm Dynamic 		   = True
-  ok_ext_nm (ExtName nm (Just mb)) = isCLabelString nm && isCLabelString mb
-  ok_ext_nm (ExtName nm Nothing)   = isCLabelString nm
+fo_decl_msg name = ptext SLIT("The foreign declaration for") <+> ppr name
 \end{code}
 
 
@@ -284,6 +287,11 @@ rnTyClDecl (IfaceSig {tcdName = name, tcdType = ty, tcdIdInfo = id_infos, tcdLoc
   where
     doc_str = text "the interface signature for" <+> quotes (ppr name)
 
+rnTyClDecl (ForeignType {tcdName = name, tcdFoType = spec, tcdLoc = loc})
+  = pushSrcLocRn loc 			$
+    lookupTopBndrRn name		`thenRn` \ name' ->
+    returnRn (ForeignType {tcdName = name', tcdFoType = spec, tcdLoc = loc})
+
 rnTyClDecl (TyData {tcdND = new_or_data, tcdCtxt = context, tcdName = tycon,
 		    tcdTyVars = tyvars, tcdCons = condecls, tcdNCons = nconstrs,
 		    tcdLoc = src_loc, tcdSysNames = sys_names})
@@ -428,7 +436,7 @@ finishSourceTyClDecl (ClassDecl {tcdMeths = Just mbinds, tcdLoc = src_loc})	-- G
     meth_doc = text "the default-methods for class"	<+> ppr (tcdName rn_cls_decl)
 
 finishSourceTyClDecl _ tycl_decl = returnRn (tycl_decl, emptyFVs)
-	-- Not a class declaration
+	-- Not a class or data type declaration
 \end{code}
 
 
@@ -879,10 +887,6 @@ badRuleVar name var
 	 ptext SLIT("Forall'd variable") <+> quotes (ppr var) <+> 
 		ptext SLIT("does not appear on left hand side")]
 
-badExtName :: ExtName -> Message
-badExtName ext_nm
-  = sep [quotes (ppr ext_nm) <+> ptext SLIT("is not a valid C identifier")]
-
 dupClassAssertWarn ctxt (assertion : dups)
   = sep [hsep [ptext SLIT("Duplicate class assertion"), 
 	       quotes (ppr assertion),