[project @ 1998-08-14 11:48:39 by sof]

Reading in foreign decls

ghc/compiler/reader/Lex.lhs

@@ -38,14 +38,14 @@ import List             ( isSuffixOf )
 
 import {-# SOURCE #-} CostCentre
 
-import CmdLineOpts	( opt_IgnoreIfacePragmas, opt_NoHiCheck )
+import CmdLineOpts	( opt_IgnoreIfacePragmas, opt_HiVersion, opt_NoHiCheck )
 import Demand		( Demand(..) {- instance Read -} )
 import UniqFM           ( UniqFM, listToUFM, lookupUFM)
 import BasicTypes	( NewOrData(..), IfaceFlavour(..) )
 import SrcLoc		( SrcLoc, incSrcLine, srcLocFile )
 
 import Maybes		( MaybeErr(..) )
-import ErrUtils		( ErrMsg(..) )
+import ErrUtils		( ErrMsg )
 import Outputable
 import Util		( nOfThem, panic )
 
@@ -865,7 +865,7 @@ happyError s l = Failed (ifaceParseErr l ([]::[IfaceToken]){-Todo-})
 -}
 checkVersion :: Maybe Integer -> IfM ()
 checkVersion mb@(Just v) s l
- | (v==0) || (v == PROJECTVERSION) || opt_NoHiCheck = Succeeded ()
+ | (v==0) || (v == fromInt opt_HiVersion) || opt_NoHiCheck = Succeeded ()
  | otherwise = Failed (ifaceVersionErr mb l ([]::[IfaceToken]){-Todo-})
 checkVersion mb@Nothing  s l 
  | "hi-boot" `isSuffixOf` (_UNPK_ (srcLocFile l)) = Succeeded ()
@@ -879,7 +879,7 @@ ifaceParseErr l toks
 
 ifaceVersionErr hi_vers l toks
   = hsep [ppr l, ptext SLIT("Interface file version error;"),
-          ptext SLIT("Expected"), int PROJECTVERSION, 
+          ptext SLIT("Expected"), int opt_HiVersion, 
 	  ptext SLIT(" found "), pp_version]
     where
      pp_version =

ghc/compiler/reader/PrefixSyn.lhs

@@ -10,7 +10,6 @@ order that follows the \tr{Prefix_Form} document.
 \begin{code}
 module PrefixSyn (
 	RdrBinding(..),
-	RdrId,
 	RdrMatch(..),
 	SigConverter,
 	SrcFile,
@@ -29,7 +28,8 @@ import Util		( panic )
 import SrcLoc           ( SrcLoc )
 import Char		( isDigit, ord )
 
-type RdrId   = RdrName
+
+--UNUSED: type RdrId   = RdrName
 type SrcLine = Int
 type SrcFile = FAST_STRING
 type SrcFun  = RdrName
@@ -46,6 +46,7 @@ data RdrBinding
   | RdrClassDecl 	RdrNameClassDecl
   | RdrInstDecl 	RdrNameInstDecl
   | RdrDefaultDecl	RdrNameDefaultDecl
+  | RdrForeignDecl      RdrNameForeignDecl
 
 			-- signatures are mysterious; we can't
 			-- tell if its a Sig or a ClassOpSig,

ghc/compiler/reader/PrefixToHs.lhs

@@ -14,7 +14,9 @@ module PrefixToHs (
 	cvBinds,
 	cvMonoBindsAndSigs,
 	cvMatches,
-	cvOtherDecls
+	cvOtherDecls,
+	cvForeignDecls -- HACK
+
     ) where
 
 #include "HsVersions.h"
@@ -195,6 +197,15 @@ 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
+
+cvForeignDecls :: RdrBinding -> [RdrNameHsDecl]
+cvForeignDecls b = go [] b
+ where
+    go acc (RdrAndBindings b1 b2) = go (go acc b1) b2
+    go acc (RdrForeignDecl d)     = ForD d  : acc
+    go acc other		  = acc
+ 
 \end{code}

ghc/compiler/reader/RdrHsSyn.lhs

@@ -16,6 +16,7 @@ module RdrHsSyn (
 	RdrNameContext,
 	RdrNameSpecDataSig,
 	RdrNameDefaultDecl,
+	RdrNameForeignDecl,
 	RdrNameFixityDecl,
 	RdrNameGRHS,
 	RdrNameGRHSsAndBinds,
@@ -76,6 +77,7 @@ type RdrNameContext		= Context 		RdrName
 type RdrNameHsDecl		= HsDecl		Unused RdrName RdrNamePat
 type RdrNameSpecDataSig		= SpecDataSig		RdrName
 type RdrNameDefaultDecl		= DefaultDecl		RdrName
+type RdrNameForeignDecl		= ForeignDecl		RdrName
 type RdrNameFixityDecl		= FixityDecl		RdrName
 type RdrNameGRHS		= GRHS			Unused RdrName RdrNamePat
 type RdrNameGRHSsAndBinds	= GRHSsAndBinds		Unused RdrName RdrNamePat

ghc/compiler/reader/ReadPrefix.lhs

@@ -16,6 +16,7 @@ import HsPragmas	( noDataPragmas, noClassPragmas, noInstancePragmas, noGenPragma
 import RdrHsSyn         
 import BasicTypes	( Fixity(..), FixityDirection(..), NewOrData(..), IfaceFlavour(..) )
 import PrefixToHs
+import CallConv
 
 import CmdLineOpts      ( opt_NoImplicitPrelude )
 import FiniteMap	( elemFM, FiniteMap )
@@ -126,6 +127,7 @@ rdModule
 
     let
 	val_decl    = ValD (cvBinds srcfile cvValSig binding)
+	for_decls   = cvForeignDecls binding
 	other_decls = cvOtherDecls binding
     in
     returnUgn (modname,
@@ -134,7 +136,7 @@ rdModule
 	      		  exports
 	      		  imports
 	      		  fixities
-			  (val_decl: other_decls)
+			  (for_decls ++ val_decl: other_decls)
 	      		  src_loc
        		)
 \end{code}
@@ -599,6 +601,16 @@ wlkBinding binding
 	wlkList rdMonoType dbindts  `thenUgn` \ tys ->
 	returnUgn (RdrDefaultDecl (DefaultDecl tys src_loc))
 
+        -- "foreign" declaration
+      U_fobind id ty ext_name unsafe_flag cconv imp_exp srcline ->
+	  mkSrcLocUgn        srcline		   $ \ src_loc ->
+	  wlkVarId id				   `thenUgn` \ h_id ->
+	  wlkHsType ty				   `thenUgn` \ h_ty ->
+	  wlkExtName ext_name			   `thenUgn` \ h_ext_name ->
+	  rdCallConv cconv		           `thenUgn` \ h_cconv ->
+	  rdImpExp imp_exp (cvFlag unsafe_flag)    `thenUgn` \ h_imp_exp ->
+ 	  returnUgn (RdrForeignDecl (ForeignDecl h_id h_imp_exp h_ty h_ext_name h_cconv src_loc))
+
       a_sig_we_hope ->
 	-- signature(-like) things, including user pragmas
 	wlk_sig_thing a_sig_we_hope
@@ -932,3 +944,29 @@ rdEntity pt
 	returnUgn (IEModuleContents mod)
 \end{code}
 
+
+%************************************************************************
+%*									*
+\subsection[rdExtName]{Read an external name}
+%*									*
+%************************************************************************
+
+\begin{code}
+wlkExtName :: U_maybe -> UgnM ExtName
+wlkExtName (U_nothing) = returnUgn Dynamic
+wlkExtName (U_just pt)
+  = rdU_list pt		    `thenUgn` \ ds ->
+    wlkList rdU_hstring ds  `thenUgn` \ ss ->
+    case ss of
+      [nm]     -> returnUgn (ExtName nm Nothing)
+      [mod,nm] -> returnUgn (ExtName nm (Just mod))
+
+rdCallConv :: Int -> UgnM CallConv
+rdCallConv x = returnUgn x
+
+rdImpExp :: Int -> Bool -> UgnM (Maybe Bool)
+rdImpExp 0 isUnsafe = -- foreign import
+  returnUgn (Just isUnsafe)
+rdImpExp 1 _ = -- foreign export
+  returnUgn Nothing
+\end{code}