Commit c3c47d97 authored by sof's avatar sof
Browse files

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

Reading in foreign decls
parent ffe3daa2
......@@ -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 =
......
......@@ -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,
......
......@@ -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}
......@@ -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
......
......@@ -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}
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment