Commit 909691a9 authored by Simon Marlow's avatar Simon Marlow

Fix #3319, and do various tidyups at the same time

 - converting a THSyn FFI declaration to HsDecl was broken; fixed
 - pretty-printing of FFI declarations was variously bogus; fixed
 - there was an unused "library" field in CImport; removed
parent ce1430c0
......@@ -124,7 +124,7 @@ because it exposes the boxing to the call site.
dsFImport :: Id
-> ForeignImport
-> DsM ([Binding], SDoc, SDoc)
dsFImport id (CImport cconv safety _ _ spec) = do
dsFImport id (CImport cconv safety _ spec) = do
(ids, h, c) <- dsCImport id spec cconv safety
return (ids, h, c)
......
......@@ -333,7 +333,7 @@ repInstD' (L loc (InstDecl ty binds _ ats)) -- Ignore user pragmas for now
(tvs, cxt, cls, tys) = splitHsInstDeclTy (unLoc ty)
repForD :: Located (ForeignDecl Name) -> DsM (SrcSpan, Core TH.DecQ)
repForD (L loc (ForeignImport name typ (CImport cc s ch cn cis)))
repForD (L loc (ForeignImport name typ (CImport cc s ch cis)))
= do MkC name' <- lookupLOcc name
MkC typ' <- repLTy typ
MkC cc' <- repCCallConv cc
......@@ -341,7 +341,6 @@ repForD (L loc (ForeignImport name typ (CImport cc s ch cn cis)))
cis' <- conv_cimportspec cis
MkC str <- coreStringLit $ static
++ unpackFS ch ++ " "
++ unpackFS cn ++ " "
++ cis'
dec <- rep2 forImpDName [cc', s', str, name', typ']
return (loc, dec)
......
......@@ -319,7 +319,7 @@ cvtForD (ImportF callconv safety from nm ty)
| Just (c_header, cis) <- parse_ccall_impent (TH.nameBase nm) from
= do { nm' <- vNameL nm
; ty' <- cvtType ty
; let i = CImport (cvt_conv callconv) safety' c_header nilFS cis
; let i = CImport (cvt_conv callconv) safety' c_header cis
; return $ ForeignImport nm' ty' i }
| otherwise
......@@ -349,26 +349,41 @@ parse_ccall_impent nm s
Just ts -> parse_ccall_impent_static nm ts
Nothing -> Nothing
-- XXX we should be sharing code with RdrHsSyn.parseCImport
parse_ccall_impent_static :: String
-> [String]
-> Maybe (FastString, CImportSpec)
parse_ccall_impent_static nm ts
= let ts' = case ts of
[ "&", cid] -> [ cid]
[fname, "&" ] -> [fname ]
[fname, "&", cid] -> [fname, cid]
_ -> ts
in case ts' of
[ cid] | is_cid cid -> Just (nilFS, mk_cid cid)
[fname, cid] | is_cid cid -> Just (mkFastString fname, mk_cid cid)
[ ] -> Just (nilFS, mk_cid nm)
[fname ] -> Just (mkFastString fname, mk_cid nm)
_ -> Nothing
= case ts of
[ ] -> mkFun nilFS nm
[ "&", cid] -> mkLbl nilFS cid
[fname, "&" ] -> mkLbl (mkFastString fname) nm
[fname, "&", cid] -> mkLbl (mkFastString fname) cid
[ "&" ] -> mkLbl nilFS nm
[fname, cid] -> mkFun (mkFastString fname) cid
[ cid]
| is_cid cid -> mkFun nilFS cid
| otherwise -> mkFun (mkFastString cid) nm
-- tricky case when there's a single string: "foo.h" is a header,
-- but "foo" is a C identifier, and we tell the difference by
-- checking for a valid C identifier (see is_cid below).
_anything_else -> Nothing
where is_cid :: String -> Bool
is_cid x = all (/= '.') x && (isAlpha (head x) || head x == '_')
mk_cid :: String -> CImportSpec
mk_cid = CFunction . StaticTarget . mkFastString
mkLbl :: FastString -> String -> Maybe (FastString, CImportSpec)
mkLbl fname lbl = Just (fname, CLabel (mkFastString lbl))
mkFun :: FastString -> String -> Maybe (FastString, CImportSpec)
mkFun fname lbl = Just (fname, CFunction (StaticTarget (mkFastString lbl)))
-- This code is tokenising something like "foo.h &bar", eg.
-- "" -> Just []
-- "foo.h" -> Just ["foo.h"]
-- "foo.h &bar" -> Just ["foo.h","&","bar"]
-- "&" -> Just ["&"]
-- Nothing is returned for a parse error.
lex_ccall_impent :: String -> Maybe [String]
lex_ccall_impent "" = Just []
lex_ccall_impent ('&':xs) = fmap ("&":) $ lex_ccall_impent xs
......
......@@ -904,7 +904,6 @@ data ForeignImport = -- import of a C entity
CImport CCallConv -- ccall or stdcall
Safety -- safe or unsafe
FastString -- name of C header
FastString -- name of library object
CImportSpec -- details of the C entity
-- import of a .NET function
......@@ -944,22 +943,19 @@ instance OutputableBndr name => Outputable (ForeignDecl name) where
instance Outputable ForeignImport where
ppr (DNImport spec) =
ptext (sLit "dotnet") <+> ppr spec
ppr (CImport cconv safety header lib spec) =
ppr (CImport cconv safety header spec) =
ppr cconv <+> ppr safety <+>
char '"' <> pprCEntity header lib spec <> char '"'
char '"' <> pprCEntity spec <> char '"'
where
pprCEntity header lib (CLabel lbl) =
ptext (sLit "static") <+> ftext header <+> char '&' <>
pprLib lib <> ppr lbl
pprCEntity header lib (CFunction (StaticTarget lbl)) =
ptext (sLit "static") <+> ftext header <+> char '&' <>
pprLib lib <> ppr lbl
pprCEntity _ _ (CFunction (DynamicTarget)) =
pp_hdr = if nullFS header then empty else ftext header
pprCEntity (CLabel lbl) =
ptext (sLit "static") <+> pp_hdr <+> char '&' <> ppr lbl
pprCEntity (CFunction (StaticTarget lbl)) =
ptext (sLit "static") <+> pp_hdr <+> ppr lbl
pprCEntity (CFunction (DynamicTarget)) =
ptext (sLit "dynamic")
pprCEntity _ _ (CWrapper) = ptext (sLit "wrapper")
--
pprLib lib | nullFS lib = empty
| otherwise = char '[' <> ppr lib <> char ']'
pprCEntity (CWrapper) = ptext (sLit "wrapper")
instance Outputable ForeignExport where
ppr (CExport (CExportStatic lbl cconv)) =
......
......@@ -960,11 +960,11 @@ mkImport :: CallConv
mkImport (CCall cconv) safety (entity, v, ty)
| cconv == PrimCallConv = do
let funcTarget = CFunction (StaticTarget (unLoc entity))
importSpec = CImport PrimCallConv safety nilFS nilFS funcTarget
return (ForD (ForeignImport v ty importSpec))
mkImport (CCall cconv) safety (entity, v, ty) = do
importSpec <- parseCImport entity cconv safety v
importSpec = CImport PrimCallConv safety nilFS funcTarget
return (ForD (ForeignImport v ty importSpec))
| otherwise = do
importSpec <- parseCImport entity cconv safety v
return (ForD (ForeignImport v ty importSpec))
mkImport (DNCall ) _ (entity, v, ty) = do
spec <- parseDImport entity
return $ ForD (ForeignImport v ty (DNImport spec))
......@@ -980,9 +980,9 @@ parseCImport :: Located FastString
parseCImport (L loc entity) cconv safety v
-- FIXME: we should allow white space around `dynamic' and `wrapper' -=chak
| entity == fsLit "dynamic" =
return $ CImport cconv safety nilFS nilFS (CFunction DynamicTarget)
return $ CImport cconv safety nilFS (CFunction DynamicTarget)
| entity == fsLit "wrapper" =
return $ CImport cconv safety nilFS nilFS CWrapper
return $ CImport cconv safety nilFS CWrapper
| otherwise = parse0 (unpackFS entity)
where
-- using the static keyword?
......@@ -990,41 +990,35 @@ parseCImport (L loc entity) cconv safety v
parse0 ('s':'t':'a':'t':'i':'c':rest) = parse1 rest
parse0 rest = parse1 rest
-- check for header file name
parse1 "" = parse4 "" nilFS False nilFS
parse1 "" = parse4 "" nilFS False
parse1 (' ':rest) = parse1 rest
parse1 str@('&':_ ) = parse2 str nilFS
parse1 str@('[':_ ) = parse3 str nilFS False
parse1 str
| ".h" `isSuffixOf` first = parse2 rest (mkFastString first)
| otherwise = parse4 str nilFS False nilFS
| otherwise = parse4 str nilFS False
where
(first, rest) = break (\c -> c == ' ' || c == '&' || c == '[') str
(first, rest) = break (\c -> c == ' ' || c == '&') str
-- check for address operator (indicating a label import)
parse2 "" header = parse4 "" header False nilFS
parse2 "" header = parse4 "" header False
parse2 (' ':rest) header = parse2 rest header
parse2 ('&':rest) header = parse3 rest header True
parse2 str@('[':_ ) header = parse3 str header False
parse2 str header = parse4 str header False nilFS
-- check for library object name
parse3 (' ':rest) header isLbl = parse3 rest header isLbl
parse3 ('[':rest) header isLbl =
case break (== ']') rest of
(lib, ']':rest) -> parse4 rest header isLbl (mkFastString lib)
_ -> parseError loc "Missing ']' in entity"
parse3 str header isLbl = parse4 str header isLbl nilFS
parse2 ('&':rest) header = parse3 rest header
parse2 str header = parse4 str header False
-- eat spaces after '&'
parse3 (' ':rest) header = parse3 rest header
parse3 str header = parse4 str header True
-- check for name of C function
parse4 "" header isLbl lib = build (mkExtName (unLoc v)) header isLbl lib
parse4 (' ':rest) header isLbl lib = parse4 rest header isLbl lib
parse4 str header isLbl lib
| all (== ' ') rest = build (mkFastString first) header isLbl lib
| otherwise = parseError loc "Malformed entity string"
parse4 "" header isLbl = build (mkExtName (unLoc v)) header isLbl
parse4 (' ':rest) header isLbl = parse4 rest header isLbl
parse4 str header isLbl
| all (== ' ') rest = build (mkFastString first) header isLbl
| otherwise = parseError loc "Malformed entity string"
where
(first, rest) = break (== ' ') str
--
build cid header False lib = return $
CImport cconv safety header lib (CFunction (StaticTarget cid))
build cid header True lib = return $
CImport cconv safety header lib (CLabel cid )
build cid header False = return $
CImport cconv safety header (CFunction (StaticTarget cid))
build cid header True = return $
CImport cconv safety header (CLabel cid )
--
-- Unravel a dotnet spec string.
......
......@@ -108,7 +108,7 @@ tcCheckFIType _ arg_tys res_ty (DNImport spec) = do
_ -> return ()
return (DNImport (withDNTypes spec (map toDNType arg_tys) (toDNType res_ty)))
tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport _ safety _ _ (CLabel _))
tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport _ safety _ (CLabel _))
= ASSERT( null arg_tys )
do { checkCg checkCOrAsm
; checkSafety safety
......@@ -116,7 +116,7 @@ tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport _ safety _ _ (CLabel _))
; return idecl } -- NB check res_ty not sig_ty!
-- In case sig_ty is (forall a. ForeignPtr a)
tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv safety _ _ CWrapper) = do
tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv safety _ CWrapper) = do
-- Foreign wrapper (former f.e.d.)
-- The type must be of the form ft -> IO (FunPtr ft), where ft is a
-- valid foreign type. For legacy reasons ft -> IO (Ptr ft) as well
......@@ -135,7 +135,7 @@ tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv safety _ _ CWrapper) =
_ -> addErrTc (illegalForeignTyErr empty sig_ty)
return idecl
tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv safety _ _ (CFunction target))
tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv safety _ (CFunction target))
| isDynamicTarget target = do -- Foreign import dynamic
checkCg checkCOrAsmOrInterp
checkCConv cconv
......
Markdown is supported
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