[project @ 1998-11-08 17:10:35 by sof]

First take at 'foreign label's

8 files changed, 94 insertions, 28 deletions

diff --git a/ghc/compiler/deSugar/DsForeign.lhs b/ghc/compiler/deSugar/DsForeign.lhs
index f495cd2c23..be886a4705 100644
--- a/ghc/compiler/deSugar/DsForeign.lhs
+++ b/ghc/compiler/deSugar/DsForeign.lhs
@@ -19,7 +19,7 @@ import DsCCall		( getIoOkDataCon, boxResult, unboxArg,
 import DsMonad
 import DsUtils
 
-import HsSyn		( ExtName(..), ForeignDecl(..), isDynamic )
+import HsSyn		( ExtName(..), ForeignDecl(..), isDynamic, ForKind(..) )
 import CallConv
 import TcHsSyn		( maybeBoxedPrimType, TypecheckedForeignDecl )
 import CoreUtils	( coreExprType )
@@ -51,7 +51,8 @@ import TysWiredIn	( getStatePairingConInfo,
 			  realWorldStateTy, stateDataCon,
 			  isFFIArgumentTy, unitTy,
 			  addrTy, stablePtrTyCon,
-			  stateAndPtrPrimDataCon
+			  stateAndPtrPrimDataCon,
+			  addrDataCon
 			)
 import Outputable
 \end{code}
@@ -83,6 +84,9 @@ dsForeigns fos = foldlDs combine ([],[],empty,empty,empty) fos
     | isForeignImport = 
         dsFImport i (idType i) uns ext_nm cconv  `thenDs` \ b -> 
 	returnDs (b:acc_fi, acc_fe, acc_hc, acc_h, acc_c)
+    | isForeignLabel = 
+        dsFLabel i ext_nm `thenDs` \ b -> 
+	returnDs (b:acc_fi, acc_fe, acc_hc, acc_h, acc_c)
     | isDynamic ext_nm =
         dsFExportDynamic i (idType i) ext_nm cconv  `thenDs` \ (fi,fe,hc,h,c) -> 
 	returnDs (fi:acc_fi, fe:acc_fe, hc $$ acc_hc, h $$ acc_h, c $$ acc_c)
@@ -91,8 +95,17 @@ dsForeigns fos = foldlDs combine ([],[],empty,empty,empty) fos
 	returnDs (acc_fi, fe:acc_fe, hc $$ acc_hc, h $$ acc_h, c $$ acc_c)
 
    where
-    isForeignImport = maybeToBool imp_exp
-    (Just uns)      = imp_exp
+    isForeignImport = 
+	case imp_exp of
+	  FoImport _ -> True
+	  _          -> False
+
+    isForeignLabel = 
+	case imp_exp of
+	  FoLabel -> True
+	  _       -> False
+
+    (FoImport uns)   = imp_exp
 
 \end{code}
 
@@ -149,6 +162,21 @@ mkArgs ty =
         
 \end{code}
 
+
+\begin{code}
+dsFLabel :: Id -> ExtName -> DsM CoreBinding
+dsFLabel nm ext_name =
+    returnDs (NonRec nm fo_rhs)
+  where
+   fo_rhs = mkCon addrDataCon [] [LitArg (MachLitLit enm AddrRep)]
+   enm    =
+    case ext_name of
+      ExtName f _ -> f
+
+\end{code}
+
+
+
 \begin{code}
 dsFExport :: Id
 	  -> Type		-- Type of foreign export.
diff --git a/ghc/compiler/hsSyn/HsDecls.lhs b/ghc/compiler/hsSyn/HsDecls.lhs
index 944c2743c6..9de522df97 100644
--- a/ghc/compiler/hsSyn/HsDecls.lhs
+++ b/ghc/compiler/hsSyn/HsDecls.lhs
@@ -354,7 +354,7 @@ instance (NamedThing name, Outputable name)
 data ForeignDecl name = 
    ForeignDecl 
         name 
-	(Maybe Bool)   -- Nothing => foreign export; Just unsafe => foreign import unsafe
+	ForKind   
 	(HsType name)
 	ExtName
 	CallConv
@@ -369,8 +369,16 @@ instance (NamedThing name, Outputable name)
         where
          (ppr_imp_exp, ppr_unsafe) =
 	   case imp_exp of
-	     Nothing -> (ptext SLIT("export"), empty)
-	     Just us -> (ptext SLIT("import"), ptext SLIT("unsafe"))
+	     FoLabel     -> (ptext SLIT("label"), empty)
+	     FoExport    -> (ptext SLIT("export"), empty)
+	     FoImport us 
+		| us        -> (ptext SLIT("import"), ptext SLIT("unsafe"))
+		| otherwise -> (ptext SLIT("import"), empty)
+
+data ForKind
+ = FoLabel
+ | FoExport
+ | FoImport Bool -- True  => unsafe call.
 
 data ExtName
  = Dynamic 
diff --git a/ghc/compiler/hsSyn/HsSyn.lhs b/ghc/compiler/hsSyn/HsSyn.lhs
index 22dcc544fd..ea103620c7 100644
--- a/ghc/compiler/hsSyn/HsSyn.lhs
+++ b/ghc/compiler/hsSyn/HsSyn.lhs
@@ -32,8 +32,8 @@ module HsSyn (
 -- friends:
 import HsBinds
 import HsDecls		( HsDecl(..), TyDecl(..), InstDecl(..), ClassDecl(..), 
-			  DefaultDecl(..), ForeignDecl(..), ExtName(..), isDynamic,
-			  FixityDecl(..), 
+			  DefaultDecl(..), ForeignDecl(..), ForKind(..),
+			  ExtName(..), isDynamic,  FixityDecl(..), 
 			  ConDecl(..), ConDetails(..), BangType(..),
 			  IfaceSig(..), HsIdInfo,  SpecDataSig(..), 
 			  hsDeclName
diff --git a/ghc/compiler/reader/PrefixToHs.lhs b/ghc/compiler/reader/PrefixToHs.lhs
index ce3e2fdde1..1d5b008548 100644
--- a/ghc/compiler/reader/PrefixToHs.lhs
+++ b/ghc/compiler/reader/PrefixToHs.lhs
@@ -197,7 +197,6 @@ cvOtherDecls b
     go acc (RdrClassDecl d)	  = ClD d   : acc
     go acc (RdrInstDecl d)	  = InstD d : acc 
     go acc (RdrDefaultDecl d)     = DefD d  : acc
---    go acc (RdrForeignDecl d)     = ForD d  : acc
     go acc other		  = acc
 	-- Ignore value bindings
 
diff --git a/ghc/compiler/reader/ReadPrefix.lhs b/ghc/compiler/reader/ReadPrefix.lhs
index 16946c2e6f..33ef93b7c0 100644
--- a/ghc/compiler/reader/ReadPrefix.lhs
+++ b/ghc/compiler/reader/ReadPrefix.lhs
@@ -964,9 +964,11 @@ wlkExtName (U_just pt)
 rdCallConv :: Int -> UgnM CallConv
 rdCallConv x = returnUgn x
 
-rdImpExp :: Int -> Bool -> UgnM (Maybe Bool)
-rdImpExp 0 isUnsafe = -- foreign import
-  returnUgn (Just isUnsafe)
+rdForKind :: Int -> Bool -> UgnM ForKind
+rdForKind 0 isUnsafe = -- foreign import
+  returnUgn (FoImport isUnsafe)
 rdImpExp 1 _ = -- foreign export
-  returnUgn Nothing
+  returnUgn FoExport
+rdImpExp 2 _ = -- foreign label
+  returnUgn FoLabel
 \end{code}
diff --git a/ghc/compiler/rename/RnNames.lhs b/ghc/compiler/rename/RnNames.lhs
index 3c1b0e8972..7fad74c375 100644
--- a/ghc/compiler/rename/RnNames.lhs
+++ b/ghc/compiler/rename/RnNames.lhs
@@ -16,7 +16,7 @@ import CmdLineOpts    ( opt_NoImplicitPrelude, opt_WarnDuplicateExports,
 
 import HsSyn	( HsModule(..), ImportDecl(..), HsDecl(..), 
 		  IE(..), ieName, 
-		  ForeignDecl(..), ExtName(..),
+		  ForeignDecl(..), ExtName(..), ForKind(..),
 		  FixityDecl(..),
 		  collectTopBinders
 		)
@@ -226,12 +226,17 @@ importsFromLocalDecls rec_exp_fn (HsModule mod _ _ _ fix_decls decls _)
 	returnRn (val_avails ++ avails)
 
     -- foreign import declaration
-    getLocalDeclBinders avails (ForD (ForeignDecl nm (Just _) _ _ _ loc))
+    getLocalDeclBinders avails (ForD (ForeignDecl nm (FoImport _) _ _ _ loc))
+      = do_one (nm,loc)			    `thenRn` \ for_avail ->
+	returnRn (for_avail : avails)
+
+    -- foreign import declaration
+    getLocalDeclBinders avails (ForD (ForeignDecl nm FoLabel _ _ _ loc))
       = do_one (nm,loc)			    `thenRn` \ for_avail ->
 	returnRn (for_avail : avails)
 
     -- foreign export dynamic declaration
-    getLocalDeclBinders avails (ForD (ForeignDecl nm Nothing _ Dynamic _ loc))
+    getLocalDeclBinders avails (ForD (ForeignDecl nm FoExport _ Dynamic _ loc))
       = do_one (nm,loc)			    `thenRn` \ for_avail ->
 	returnRn (for_avail : avails)
 
diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs
index 89e484d98e..10a7fd8986 100644
--- a/ghc/compiler/rename/RnSource.lhs
+++ b/ghc/compiler/rename/RnSource.lhs
@@ -35,7 +35,9 @@ import FiniteMap	( lookupFM )
 import Id		( GenId{-instance NamedThing-} )
 import IdInfo		( FBTypeInfo, ArgUsageInfo )
 import Lex		( isLexCon )
-import PrelInfo		( derivingOccurrences, evalClass_RDR, numClass_RDR, allClass_NAME )
+import PrelInfo		( derivingOccurrences, evalClass_RDR, numClass_RDR, allClass_NAME,
+			  ioOkDataCon_NAME
+			)
 import Maybes		( maybeToBool )
 import Bag		( bagToList )
 import Outputable
@@ -309,15 +311,22 @@ rnDecl (DefD (DefaultDecl tys src_loc))
 rnDecl (ForD (ForeignDecl name imp_exp ty ext_nm cconv src_loc))
   = pushSrcLocRn src_loc $
     lookupBndrRn name		        `thenRn` \ name' ->
-    (if is_export then
+    (if is_import then
         addImplicitOccRn name'
      else
 	returnRn name')			`thenRn_`
     rnHsSigType fo_decl_msg ty		`thenRn` \ ty' ->
+     -- hack: force the constructors of IO to be slurped in,
+     -- since we need 'em when desugaring a foreign decl.
+    addImplicitOccRn ioOkDataCon_NAME   `thenRn_`
     returnRn (ForD (ForeignDecl name' imp_exp ty' ext_nm cconv src_loc))
  where
   fo_decl_msg = ptext SLIT("a foreign declaration")
-  is_export   = not (maybeToBool imp_exp) && not (isDynamic ext_nm)
+  is_import   = 
+     not (isDynamic ext_nm) &&
+     case imp_exp of
+       FoImport _ -> True
+       _          -> False
 
 \end{code}
 
diff --git a/ghc/compiler/typecheck/TcForeign.lhs b/ghc/compiler/typecheck/TcForeign.lhs
index 4a2e4a21ad..6382472003 100644
--- a/ghc/compiler/typecheck/TcForeign.lhs
+++ b/ghc/compiler/typecheck/TcForeign.lhs
@@ -21,7 +21,7 @@ module TcForeign
 
 import HsSyn		( HsDecl(..), ForeignDecl(..), HsExpr(..),
 			  ExtName(..), isDynamic, MonoBinds(..),
-			  OutPat(..)
+			  OutPat(..), ForKind(..)
 			)
 import RnHsSyn		( RenamedHsDecl, RenamedForeignDecl )
 
@@ -79,20 +79,22 @@ tcForeignExports decls =
 
 -- defines a binding
 isForeignImport :: ForeignDecl name -> Bool
-isForeignImport (ForeignDecl _ (Just _) _ _ _ _)      = True
-isForeignImport (ForeignDecl _ Nothing _ Dynamic _ _) = True
-isForeignImport _				      = False
+isForeignImport (ForeignDecl _ k _ dyn _ _) =
+  case k of
+    FoImport _ -> True
+    FoExport   -> case dyn of { Dynamic -> True ; _ -> False }
+    FoLabel    -> True
 
 -- exports a binding
 isForeignExport :: ForeignDecl name -> Bool
-isForeignExport (ForeignDecl _ Nothing _ ext_nm _ _) = not (isDynamic ext_nm)
-isForeignExport _				     = False
+isForeignExport (ForeignDecl _ FoExport _ ext_nm _ _) = not (isDynamic ext_nm)
+isForeignExport _				      = False
 
 \end{code}
 
 \begin{code}
 tcFImport :: RenamedForeignDecl -> TcM s (Id, TypecheckedForeignDecl)
-tcFImport fo@(ForeignDecl nm Nothing hs_ty Dynamic cconv src_loc) =
+tcFImport fo@(ForeignDecl nm FoExport hs_ty Dynamic cconv src_loc) =
    tcAddSrcLoc src_loc		     $
    tcAddErrCtxt (foreignDeclCtxt fo) $
    tcHsType hs_ty		    `thenTc`	\ sig_ty ->
@@ -105,7 +107,20 @@ tcFImport fo@(ForeignDecl nm Nothing hs_ty Dynamic cconv src_loc) =
      (arg_tys, res_ty) -> 
 	checkForeignExport True t_ty arg_tys res_ty `thenTc_`
 	let i = (mkUserId nm sig_ty) in
-	returnTc (i, (ForeignDecl i Nothing undefined Dynamic cconv src_loc))
+	returnTc (i, (ForeignDecl i FoExport undefined Dynamic cconv src_loc))
+
+tcFImport fo@(ForeignDecl nm FoLabel hs_ty ext_nm cconv src_loc) =
+   tcAddSrcLoc src_loc		     $
+   tcAddErrCtxt (foreignDeclCtxt fo) $
+   tcHsType hs_ty		    `thenTc`	\ sig_ty ->
+   let
+      -- drop the foralls before inspecting the structure
+      -- of the foreign type.
+    (_, t_ty) = splitForAllTys sig_ty
+   in
+   check (isAddrTy t_ty) (illegalForeignTyErr False{-result-} sig_ty) `thenTc_`
+   let i = (mkUserId nm sig_ty) in
+   returnTc (i, (ForeignDecl i FoLabel undefined ext_nm cconv src_loc))
 
 tcFImport fo@(ForeignDecl nm imp_exp hs_ty ext_nm cconv src_loc) =
    tcAddSrcLoc src_loc		     $