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

Reading in foreign decls

diff --git a/ghc/compiler/reader/Lex.lhs b/ghc/compiler/reader/Lex.lhs
index 3eee37d..32efe30 100644 (file)
--- a/ghc/compiler/reader/Lex.lhs
+++ b/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 =

diff --git a/ghc/compiler/reader/PrefixSyn.lhs b/ghc/compiler/reader/PrefixSyn.lhs
index 9d1d8d0..6b15a0d 100644 (file)
--- a/ghc/compiler/reader/PrefixSyn.lhs
+++ b/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,

diff --git a/ghc/compiler/reader/PrefixToHs.lhs b/ghc/compiler/reader/PrefixToHs.lhs
index b91f75b..ce3e2fd 100644 (file)
--- a/ghc/compiler/reader/PrefixToHs.lhs
+++ b/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}

diff --git a/ghc/compiler/reader/RdrHsSyn.lhs b/ghc/compiler/reader/RdrHsSyn.lhs
index 338e025..02a0c53 100644 (file)
--- a/ghc/compiler/reader/RdrHsSyn.lhs
+++ b/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

diff --git a/ghc/compiler/reader/ReadPrefix.lhs b/ghc/compiler/reader/ReadPrefix.lhs
index 1dc750e..16946c2 100644 (file)
--- a/ghc/compiler/reader/ReadPrefix.lhs
+++ b/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}