diff --git a/ChangeLog b/ChangeLog
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,14 @@
+0.28.7.*
+ - Support for InterruptibleFFI (Alex Wied)
+ - Support for equality in C macros (Vanessa McHale)
+ - Make c2hs source comments more Haddock friendly (George Thomas)
+ - (Un)Marshal a C bool into a CUChar instead of CInt
+ - The lowest GHC version supported is now 8.0.1, this is due to
+ upgrading Shelly to 1.9.0 for tests but generally the
+ medium-to-long term plan is to update app code to use 8.0.1
+ features as well.
+0.28.6
+ - Support for binding to anonymous nested structs and unions.
0.28.6
- Update for GHC 8.6.*
0.28.3
diff --git a/c2hs.cabal b/c2hs.cabal
--- a/c2hs.cabal
+++ b/c2hs.cabal
@@ -1,5 +1,5 @@
Name: c2hs
-Version: 0.28.6
+Version: 0.28.7
License: GPL-2
License-File: COPYING
Copyright: Copyright (c) 1999-2007 Manuel M T Chakravarty
@@ -18,7 +18,7 @@
hsc2hs), this ensures that C functions are imported with the
correct Haskell types.
Category: Development
-Tested-With: GHC==6.12.3, GHC==7.0.4, GHC==7.6.1, GHC==7.6.3, GHC==7.8.3, GHC==7.10.1
+Tested-With: GHC==8.0.1, GHC==8.10.1
Cabal-Version: >= 1.10
Build-Type: Simple
@@ -103,6 +103,8 @@
tests/bugs/issue-155/*.chs tests/bugs/issue-155/*.h
tests/bugs/issue-180/*.chs tests/bugs/issue-180/*.h
tests/bugs/issue-192/*.chs tests/bugs/issue-192/*.h
+ tests/bugs/issue-230/*.chs tests/bugs/issue-230/*.h tests/bugs/issue-230/*.c
+ tests/bugs/issue-257/*.chs tests/bugs/issue-257/*.h tests/bugs/issue-257/*.c
source-repository head
type: git
@@ -151,6 +153,7 @@
Data.Attributes
Data.Errors
Data.NameSpaces
+ Paths_c2hs
System.CIO
Text.Lexers
@@ -170,7 +173,7 @@
test-framework,
test-framework-hunit,
HUnit,
- shelly >= 1.0,
+ shelly >= 1.9.0 && < 1.10.0,
text,
transformers
default-language: Haskell2010
@@ -184,7 +187,7 @@
test-framework,
test-framework-hunit,
HUnit,
- shelly >= 1.0,
+ shelly >= 1.9.0 && < 1.10.0,
text,
transformers
default-language: Haskell2010
@@ -199,7 +202,7 @@
if flag(regression)
build-depends: base,
filepath,
- shelly >= 1.0,
+ shelly >= 1.9.0 && < 1.10.0,
text,
yaml >= 0.8
else
diff --git a/doc/c2hs.xml b/doc/c2hs.xml
--- a/doc/c2hs.xml
+++ b/doc/c2hs.xml
@@ -447,17 +447,18 @@
Call Hooks
-{#call [pure] [unsafe] cid [as (hsid | ^)]#}
+{#call [pure] [unsafe] [interruptible] cid [as (hsid | ^)]#}
A call hook rewrites to a call to the C function
cid and also ensures that the appropriate foreign
import declaration is generated. The tags pure and
unsafe specify that the external function is purely
- functional and cannot re-enter the Haskell runtime, respectively. If
- hsid is present, it is used as the identifier for
- the foreign declaration, which otherwise defaults to the
- cid. When instead of
+ functional and cannot re-enter the Haskell runtime, respectively. The
+ interruptible flag is intended to be used in conjunction
+ with the InterruptibleFFI extension. If hsid is
+ present, it is used as the identifier for the foreign declaration, which
+ otherwise defaults to the cid. When instead of
hsid, the symbol ^ is given,
the cid after conversion from C's underscore
notation to a capitalised identifier is used.
@@ -477,7 +478,7 @@
Function Hooks
-{#fun [pure] [unsafe] cid [as (hsid | ^)]
+{#fun [pure] [unsafe] [interruptible] cid [as (hsid | ^)]
[ctxt =>] { parm1 , ... , parmn } -> parm
@@ -1004,8 +1005,8 @@
| `type' ident
| `sizeof' ident
| `enum' idalias trans [`with' prefix] [deriving]
- | `call' [`pure'] [`unsafe'] idalias
- | `fun' [`pure'] [`unsafe'] idalias parms
+ | `call' [`pure'] [`unsafe'] [`interruptible'] idalias
+ | `fun' [`pure'] [`unsafe'] [`interruptible'] idalias parms
| `get' apath
| `set' apath
| `pointer' ['*'] idalias ptrkind
diff --git a/src/C2HS/C/Names.hs b/src/C2HS/C/Names.hs
--- a/src/C2HS/C/Names.hs
+++ b/src/C2HS/C/Names.hs
@@ -28,7 +28,7 @@
--
--- TODO ----------------------------------------------------------------------
--
--- * `defObjOrErr': currently, repeated declarations are completely ignored;
+-- * `defObjOrErr': currently, repeated declarations are completely ignored;
-- eventually, the consistency of the declarations should be checked
--
diff --git a/src/C2HS/C/Trav.hs b/src/C2HS/C/Trav.hs
--- a/src/C2HS/C/Trav.hs
+++ b/src/C2HS/C/Trav.hs
@@ -54,7 +54,7 @@
--
--- TODO ----------------------------------------------------------------------
--
--- * `extractStruct' doesn't account for forward declarations that have no
+-- * `extractStruct' doesn't account for forward declarations that have no
-- full declaration yet; if `extractStruct' is called on such a declaration,
-- we have a user error, but currently an internal error is raised
--
@@ -509,8 +509,11 @@
-- | expand declarators declaring more than one identifier into multiple
-- declarators, eg, `int x, y;' becomes `int x; int y;'
+-- For case of a declarator that declares no identifier, preserve the no-identifier decl.
--
expandDecl :: CDecl -> [CDecl]
+expandDecl decl@(CDecl _ [] _) =
+ [decl] -- no name member stays as member without a name.
expandDecl (CDecl specs decls at) =
map (\decl -> CDecl specs [decl] at) decls
diff --git a/src/C2HS/CHS.hs b/src/C2HS/CHS.hs
--- a/src/C2HS/CHS.hs
+++ b/src/C2HS/CHS.hs
@@ -56,7 +56,7 @@
-- | `enum' idalias trans [`nocode'] [`with' prefix] [`add' prefix] [deriving]
-- | `enum` `define` idalias [deriving]
-- | `call' [`pure'] [`unsafe'] idalias
--- | `fun' [`pure'] [`unsafe'] idalias parms
+-- | `fun' [`interruptible'] [`pure'] [`unsafe'] idalias parms
-- | `get' [`struct'] apath
-- | `set' [`struct'] apath
-- | `offsetof` apath
@@ -222,11 +222,13 @@
[Ident] -- instance requests from user
Position
| CHSCall Bool -- is a pure function?
+ Bool -- is interruptible?
Bool -- is unsafe?
CHSAPath -- C function
(Maybe Ident) -- Haskell name
Position
| CHSFun Bool -- is a pure function?
+ Bool -- is interruptible?
Bool -- is unsafe?
Bool -- is variadic?
[String] -- variadic C parameter types
@@ -268,22 +270,22 @@
data Direction = In | Out deriving (Eq, Ord, Show)
instance Pos CHSHook where
- posOf (CHSImport _ _ _ pos) = pos
- posOf (CHSContext _ _ _ pos) = pos
- posOf (CHSType _ pos) = pos
- posOf (CHSSizeof _ pos) = pos
- posOf (CHSAlignof _ pos) = pos
- posOf (CHSEnum _ _ _ _ _ _ _ pos) = pos
- posOf (CHSEnumDefine _ _ _ pos) = pos
- posOf (CHSCall _ _ _ _ pos) = pos
- posOf (CHSFun _ _ _ _ _ _ _ _ _ pos) = pos
- posOf (CHSField _ _ pos) = pos
- posOf (CHSOffsetof _ pos) = pos
- posOf (CHSPointer _ _ _ _ _ _ _ pos) = pos
- posOf (CHSClass _ _ _ pos) = pos
- posOf (CHSConst _ pos) = pos
- posOf (CHSTypedef _ _ pos) = pos
- posOf (CHSDefault _ _ _ _ _ pos) = pos
+ posOf (CHSImport _ _ _ pos) = pos
+ posOf (CHSContext _ _ _ pos) = pos
+ posOf (CHSType _ pos) = pos
+ posOf (CHSSizeof _ pos) = pos
+ posOf (CHSAlignof _ pos) = pos
+ posOf (CHSEnum _ _ _ _ _ _ _ pos) = pos
+ posOf (CHSEnumDefine _ _ _ pos) = pos
+ posOf (CHSCall _ _ _ _ _ pos) = pos
+ posOf (CHSFun _ _ _ _ _ _ _ _ _ _ pos) = pos
+ posOf (CHSField _ _ pos) = pos
+ posOf (CHSOffsetof _ pos) = pos
+ posOf (CHSPointer _ _ _ _ _ _ _ pos) = pos
+ posOf (CHSClass _ _ _ pos) = pos
+ posOf (CHSConst _ pos) = pos
+ posOf (CHSTypedef _ _ pos) = pos
+ posOf (CHSDefault _ _ _ _ _ pos) = pos
-- | two hooks are equal if they have the same Haskell name and reference the
-- same C object
@@ -303,10 +305,10 @@
oalias1 == oalias2 && ide1 == ide2
(CHSEnumDefine ide1 _ _ _) == (CHSEnumDefine ide2 _ _ _) =
ide1 == ide2
- (CHSCall _ _ ide1 oalias1 _) == (CHSCall _ _ ide2 oalias2 _) =
+ (CHSCall _ _ _ ide1 oalias1 _) == (CHSCall _ _ _ ide2 oalias2 _) =
oalias1 == oalias2 && ide1 == ide2
- (CHSFun _ _ _ _ ide1 oalias1 _ _ _ _) ==
- (CHSFun _ _ _ _ ide2 oalias2 _ _ _ _) = oalias1 == oalias2 && ide1 == ide2
+ (CHSFun _ _ _ _ _ ide1 oalias1 _ _ _ _) ==
+ (CHSFun _ _ _ _ _ ide2 oalias2 _ _ _ _) = oalias1 == oalias2 && ide1 == ide2
(CHSField acc1 path1 _) == (CHSField acc2 path2 _) =
acc1 == acc2 && path1 == path2
(CHSOffsetof path1 _) == (CHSOffsetof path2 _) =
@@ -522,13 +524,15 @@
showFrags _ _ [] = id
showFrags pureHs state (CHSVerb s pos : frags) =
let
- (fname,line) = (posFile pos, posRow pos)
generated = isBuiltinPos pos
emitNow = state == Emit ||
(state == Wait && not (null s) && head s == '\n')
nextState = if generated then Wait else NoLine
in
- (if emitNow then
+ (if emitNow && isSourcePos pos
+ then
+ let (fname,line) = (posFile pos, posRow pos)
+ in
showString ("\n{-# LINE " ++ show (line `max` 0) ++ " " ++
show fname ++ " #-}\n")
else id)
@@ -598,14 +602,17 @@
" deriving ("
++ concat (intersperse ", " (map identToString derive))
++ ") "
-showCHSHook (CHSCall isPure isUns ide oalias _) =
+showCHSHook (CHSCall isPure isIntr isUns ide oalias _) =
showString "call "
. (if isPure then showString "pure " else id)
+ . (if isIntr then showString "interruptible " else id)
. (if isUns then showString "unsafe " else id)
. showApAlias ide oalias
-showCHSHook (CHSFun isPure isUns isVar varTypes ide oalias octxt parms parm _) =
+showCHSHook (CHSFun isPure isIntr isUns isVar varTypes ide oalias octxt
+ parms parm _) =
showString "fun "
. (if isPure then showString "pure " else id)
+ . (if isIntr then showString "interruptible " else id)
. (if isUns then showString "unsafe " else id)
. (if isVar then showString "variadic " else id)
. showFunAlias ide varTypes oalias
@@ -1136,33 +1143,35 @@
parseCall :: Position -> Position -> [CHSToken] -> CST s [CHSFrag]
parseCall hkpos pos toks =
do
- (isPure , toks' ) <- parseIsPure toks
- (isUnsafe, toks'' ) <- parseIsUnsafe toks'
- (apath , toks''' ) <- parsePath toks''
- (oalias , toks'''') <- parseOptAs (apathToIdent apath) False toks'''
- toks''''' <- parseEndHook toks''''
- frags <- parseFrags toks'''''
+ (isPure , toks' ) <- parseIsPure toks
+ (isIntr , toks'' ) <- parseIsIntr toks'
+ (isUnsafe, toks''' ) <- parseIsUnsafe toks''
+ (apath , toks'''') <- parsePath toks'''
+ (oalias , toks''''') <- parseOptAs (apathToIdent apath) False toks''''
+ toks'''''' <- parseEndHook toks'''''
+ frags <- parseFrags toks''''''
return $
- CHSHook (CHSCall isPure isUnsafe apath oalias pos) hkpos : frags
+ CHSHook (CHSCall isPure isIntr isUnsafe apath oalias pos) hkpos : frags
parseFun :: Position -> Position -> [CHSToken] -> CST s [CHSFrag]
parseFun hkpos pos inputToks =
do
- (isPure , toks' ) <- parseIsPure toks
- (isUnsafe, toks'2) <- parseIsUnsafe toks'
- (isVar, toks'3) <- parseIsVariadic toks'2
- (apath , toks'4) <- parsePath toks'3
- (varTypes, toks'5) <- parseVarTypes toks'4
- (oalias , toks'6) <- parseOptAs (apathToIdent apath) False toks'5
- (octxt , toks'7) <- parseOptContext toks'6
- (parms , toks'8) <- parseParms toks'7
- (parm , toks'9) <- parseParm toks'8
- when (isParmWrapped parm) $ errorOutWrap $ head toks'8
- toks'10 <- parseEndHook toks'9
- frags <- parseFrags toks'10
+ (isPure , toks' ) <- parseIsPure toks
+ (isIntr , toks'2) <- parseIsIntr toks'
+ (isUnsafe, toks'3) <- parseIsUnsafe toks'2
+ (isVar, toks'4) <- parseIsVariadic toks'3
+ (apath , toks'5) <- parsePath toks'4
+ (varTypes, toks'6) <- parseVarTypes toks'5
+ (oalias , toks'7) <- parseOptAs (apathToIdent apath) False toks'6
+ (octxt , toks'8) <- parseOptContext toks'7
+ (parms , toks'9) <- parseParms toks'8
+ (parm , toks'10) <- parseParm toks'9
+ when (isParmWrapped parm) $ errorOutWrap $ head toks'9
+ toks'11 <- parseEndHook toks'10
+ frags <- parseFrags toks'11
return $
CHSHook
- (CHSFun isPure isUnsafe isVar varTypes
+ (CHSFun isPure isIntr isUnsafe isVar varTypes
apath oalias octxt parms parm pos) hkpos :
frags
where
@@ -1224,6 +1233,10 @@
parseIsPure (CHSTokFun _:toks) = return (True , toks) -- backwards compat.
parseIsPure toks = return (False, toks)
-- FIXME: eventually, remove `fun'; it's currently deprecated
+
+parseIsIntr :: [CHSToken] -> CST s (Bool, [CHSToken])
+parseIsIntr (CHSTokIntr _:toks) = return (True , toks)
+parseIsIntr toks = return (False, toks)
parseIsUnsafe :: [CHSToken] -> CST s (Bool, [CHSToken])
parseIsUnsafe (CHSTokUnsafe _:toks) = return (True , toks)
diff --git a/src/C2HS/CHS/Lexer.hs b/src/C2HS/CHS/Lexer.hs
--- a/src/C2HS/CHS/Lexer.hs
+++ b/src/C2HS/CHS/Lexer.hs
@@ -90,7 +90,7 @@
-- cidenttail -> digit (letter | digit)*
-- reservedid -> `add' | `as' | `call' | `class' | `context' | `deriving'
-- | `enum' | `foreign' | `fun' | `get' | `lib'
--- | `downcaseFirstLetter' | `finalizer'
+-- | `downcaseFirstLetter' | `finalizer' | `interruptible'
-- | `newtype' | `nocode' | `pointer' | `prefix' | `pure'
-- | `set' | `sizeof' | `stable' | `struct' | `type'
-- | `underscoreToCase' | `upcaseFirstLetter' | `unsafe' |
@@ -230,6 +230,7 @@
| CHSTokFun Position -- `fun'
| CHSTokGet Position -- `get'
| CHSTokImport Position -- `import'
+ | CHSTokIntr Position -- `interruptible'
| CHSTokLib Position -- `lib'
| CHSTokNewtype Position -- `newtype'
| CHSTokNocode Position -- `nocode'
@@ -446,6 +447,7 @@
showsPrec _ (CHSTokFun _ ) = showString "fun"
showsPrec _ (CHSTokGet _ ) = showString "get"
showsPrec _ (CHSTokImport _ ) = showString "import"
+ showsPrec _ (CHSTokIntr _ ) = showString "interruptible"
showsPrec _ (CHSTokLib _ ) = showString "lib"
showsPrec _ (CHSTokNewtype _ ) = showString "newtype"
showsPrec _ (CHSTokNocode _ ) = showString "nocode"
@@ -824,6 +826,7 @@
idkwtok pos "fun" _ = CHSTokFun pos
idkwtok pos "get" _ = CHSTokGet pos
idkwtok pos "import" _ = CHSTokImport pos
+ idkwtok pos "interruptible" _ = CHSTokIntr pos
idkwtok pos "lib" _ = CHSTokLib pos
idkwtok pos "newtype" _ = CHSTokNewtype pos
idkwtok pos "nocode" _ = CHSTokNocode pos
@@ -871,6 +874,7 @@
CHSTokFun pos -> mkid pos "fun"
CHSTokGet pos -> mkid pos "get"
CHSTokImport pos -> mkid pos "import"
+ CHSTokIntr pos -> mkid pos "interruptible"
CHSTokLib pos -> mkid pos "lib"
CHSTokNewtype pos -> mkid pos "newtype"
CHSTokNocode pos -> mkid pos "nocode"
diff --git a/src/C2HS/Gen/Bind.hs b/src/C2HS/Gen/Bind.hs
--- a/src/C2HS/Gen/Bind.hs
+++ b/src/C2HS/Gen/Bind.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE CPP #-}
+{-# LANGUAGE BangPatterns #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
-- C->Haskell Compiler: binding generator
--
@@ -374,6 +375,8 @@
isIntegralHsType "CUInt" = True
isIntegralHsType "CLong" = True
isIntegralHsType "CULong" = True
+isIntegralHsType "CLLong" = True
+isIntegralHsType "CULLong" = True
isIntegralHsType _ = False
-- | check for floating Haskell types
@@ -653,7 +656,7 @@
let trans = transTabToTransFun pfx reppfx chsTrans
hide = identToString . fromMaybe cide $ oalias
enumDef enum hide trans emit (map identToString derive) pos
-expandHook hook@(CHSCall isPure isUns (CHSRoot _ ide) oalias pos) _ =
+expandHook hook@(CHSCall isPure isIntr isUns (CHSRoot _ ide) oalias pos) _ =
do
traceEnter
-- get the corresponding C declaration; raises error if not found or not a
@@ -666,7 +669,7 @@
cdecl' = ide' `simplifyDecl` cdecl
ty <- extractFunType pos cdecl' Nothing
let args = concat [ " x" ++ show n | n <- [1..numArgs ty] ]
- callImport hook isUns [] ideLexeme hsLexeme cdecl' Nothing pos
+ callImport hook isIntr isUns [] ideLexeme hsLexeme cdecl' Nothing pos
when isPure $ addHsDependency "System.IO.Unsafe"
case (isPure, length args) of
(False, _) -> return hsLexeme
@@ -678,7 +681,7 @@
where
traceEnter = traceGenBind $
"** Call hook for `" ++ identToString ide ++ "':\n"
-expandHook hook@(CHSCall isPure isUns apath oalias pos) _ =
+expandHook hook@(CHSCall isPure isIntr isUns apath oalias pos) _ =
do
traceEnter
@@ -701,7 +704,7 @@
-- cdecl' = ide `simplifyDecl` cdecl
args = concat [ " x" ++ show n | n <- [1..numArgs ty] ]
- callImportDyn hook isUns ideLexeme hsLexeme decl ty pos
+ callImportDyn hook isIntr isUns ideLexeme hsLexeme decl ty pos
let res = "(\\o" ++ args ++ " -> " ++ set_get ++ " o >>= \\f -> "
++ hsLexeme ++ " f" ++ args ++ ")"
if isPure
@@ -715,7 +718,7 @@
identToString (apathToIdent apath) ++ "':\n"
traceValueType et = traceGenBind $
"Type of accessed value: " ++ showExtType et ++ "\n"
-expandHook (CHSFun isPure isUns _ inVarTypes (CHSRoot _ ide)
+expandHook (CHSFun isPure isIntr isUns _ inVarTypes (CHSRoot _ ide)
oalias ctxt parms parm pos) hkpos =
do
traceEnter
@@ -731,7 +734,8 @@
fiLexeme = hsLexeme ++ "'_" -- Urgh - probably unqiue...
fiIde = internalIdent fiLexeme
cdecl' = cide `simplifyDecl` cdecl
- callHook = CHSCall isPure isUns (CHSRoot False cide) (Just fiIde) pos
+ callHook = CHSCall isPure isIntr isUns (CHSRoot False cide) (Just fiIde)
+ pos
isWrapped (CHSParm _ _ twovals _ w _ _)
| twovals = [w, w]
| otherwise = [w]
@@ -739,16 +743,16 @@
wrapped = Just $ concatMap isWrapped parms
varTypes <- convertVarTypes hsLexeme pos inVarTypes
- callImport callHook isUns varTypes (identToString cide)
+ callImport callHook isIntr isUns varTypes (identToString cide)
fiLexeme cdecl' wrapped pos
extTy <- extractFunType pos cdecl' wrapped
- funDef isPure hsLexeme fiLexeme extTy varTypes
+ funDef isPure isIntr hsLexeme fiLexeme extTy varTypes
ctxt parms parm Nothing pos hkpos
where
traceEnter = traceGenBind $
"** Fun hook for `" ++ identToString ide ++ "':\n"
-expandHook (CHSFun isPure isUns _ _ apath oalias ctxt parms parm pos) hkpos =
+expandHook (CHSFun isPure isIntr isUns _ _ apath oalias ctxt parms parm pos) hkpos =
do
traceEnter
@@ -771,11 +775,11 @@
fiIde = internalIdent fiLexeme
-- cdecl' = cide `simplifyDecl` cdecl
-- args = concat [ " x" ++ show n | n <- [1..numArgs ty] ]
- callHook = CHSCall isPure isUns apath (Just fiIde) pos
- callImportDyn callHook isUns ideLexeme fiLexeme decl ty pos
+ callHook = CHSCall isPure isIntr isUns apath (Just fiIde) pos
+ callImportDyn callHook isIntr isUns ideLexeme fiLexeme decl ty pos
set_get <- setGet pos CHSGet offsets Nothing ptrTy Nothing
- funDef isPure hsLexeme fiLexeme (FunET ptrTy $ purify ty) []
+ funDef isPure isIntr hsLexeme fiLexeme (FunET ptrTy $ purify ty) []
ctxt parms parm (Just set_get) pos hkpos
where
-- remove IO from the result type of a function ExtType. necessary
@@ -1127,9 +1131,9 @@
-- * the C declaration is a simplified declaration of the function that we
-- want to import into Haskell land
--
-callImport :: CHSHook -> Bool -> [ExtType] -> String ->
+callImport :: CHSHook -> Bool -> Bool -> [ExtType] -> String ->
String -> CDecl -> Maybe [Bool] -> Position -> GB ()
-callImport hook isUns varTypes ideLexeme hsLexeme cdecl owrapped pos =
+callImport hook isIntr isUns varTypes ideLexeme hsLexeme cdecl owrapped pos =
do
-- compute the external type from the declaration, and delay the foreign
-- export declaration
@@ -1148,7 +1152,7 @@
else ideLexeme
addExtTypeDependency extType
delayCode hook (foreignImport (extractCallingConvention cdecl)
- header ide hsLexeme isUns extType varTypes)
+ header ide hsLexeme isIntr isUns extType varTypes)
when (needwrapper1 || needwrapper2) $
addWrapper ide ideLexeme cdecl wraps bools pos
traceFunType extType
@@ -1156,9 +1160,9 @@
traceFunType et = traceGenBind $
"Imported function type: " ++ showExtType et ++ "\n"
-callImportDyn :: CHSHook -> Bool -> String -> String -> CDecl -> ExtType
- -> Position -> GB ()
-callImportDyn hook isUns ideLexeme hsLexeme cdecl ty pos =
+callImportDyn :: CHSHook -> Bool -> Bool -> String -> String -> CDecl
+ -> ExtType -> Position -> GB ()
+callImportDyn hook isIntr isUns ideLexeme hsLexeme cdecl ty pos =
do
-- compute the external type from the declaration, and delay the foreign
-- export declaration
@@ -1166,7 +1170,7 @@
when (isVariadic ty) (variadicErr pos (posOf cdecl))
addExtTypeDependency ty
delayCode hook (foreignImportDyn (extractCallingConvention cdecl)
- ideLexeme hsLexeme isUns ty)
+ ideLexeme hsLexeme isIntr isUns ty)
traceFunType ty
where
traceFunType et = traceGenBind $
@@ -1175,13 +1179,16 @@
-- | Haskell code for the foreign import declaration needed by a call hook
--
foreignImport :: CallingConvention -> String -> String -> String -> Bool ->
- ExtType -> [ExtType] -> String
-foreignImport cconv header ident hsIdent isUnsafe ty vas =
+ Bool -> ExtType -> [ExtType] -> String
+foreignImport cconv header ident hsIdent isIntr isUnsafe ty vas =
"foreign import " ++ showCallingConvention cconv ++ " " ++ safety
++ " " ++ show entity ++
"\n " ++ hsIdent ++ " :: " ++ showExtFunType ty vas ++ "\n"
where
- safety = if isUnsafe then "unsafe" else "safe"
+ safety = case (isIntr, isUnsafe) of
+ (True, _) -> "interruptible"
+ (False, True) -> "unsafe"
+ (False, False) -> "safe"
entity | null header = ident
| otherwise = header ++ " " ++ ident
@@ -1189,14 +1196,17 @@
-- a call hook
--
foreignImportDyn :: CallingConvention -> String -> String -> Bool ->
- ExtType -> String
-foreignImportDyn cconv _ident hsIdent isUnsafe ty =
+ Bool -> ExtType -> String
+foreignImportDyn cconv _ident hsIdent isIntr isUnsafe ty =
"foreign import " ++ showCallingConvention cconv ++ " " ++ safety
++ " \"dynamic\"\n " ++
hsIdent ++ " :: " ++ impm "FunPtr" ++ "( " ++
showExtType ty ++ " ) -> " ++ showExtType ty ++ "\n"
where
- safety = if isUnsafe then "unsafe" else "safe"
+ safety = case (isIntr, isUnsafe) of
+ (True, _) -> "interruptible"
+ (False, True) -> "unsafe"
+ (False, False) -> "safe"
-- | produce a Haskell function definition for a fun hook
--
@@ -1208,6 +1218,7 @@
-- an io action (like 'peek' and unlike 'with'). -- US
funDef :: Bool -- pure function?
+ -> Bool -- interruptible?
-> String -- name of the new Haskell function
-> String -- Haskell name of the foreign imported C function
-> ExtType -- simplified declaration of the C function
@@ -1219,7 +1230,7 @@
-> Position -- source location of the hook
-> Position -- source location of the start of the hook
-> GB String -- Haskell code in text form
-funDef isPure hsLexeme fiLexeme extTy varExtTys octxt parms
+funDef isPure _ hsLexeme fiLexeme extTy varExtTys octxt parms
parm@(CHSParm _ hsParmTy _ _ _ _ _) marsh2 pos hkpos =
do
when (countPlus parms > 1 || isPlus parm) $ illegalPlusErr pos
@@ -1489,7 +1500,7 @@
do
decl <- findAndChaseDecl ide False True
return (ide `simplifyDecl` decl, [BitSize 0 0])
-accessPath (CHSDeref (CHSRoot _ ide) _) = -- *t
+accessPath (CHSDeref (CHSRoot _ ide) _) = -- *t
do
decl <- findAndChaseDecl ide True True
return (ide `simplifyDecl` decl, [BitSize 0 0])
@@ -1518,7 +1529,7 @@
case declr of
(Just (CDeclr _ [] _ _ _), _, _) -> return ()
_ -> structExpectedErr ide'
-accessPath (CHSDeref path _pos) = -- *a
+accessPath (CHSDeref path _pos) = -- *a
do
(decl, offsets) <- accessPath path
decl' <- derefOrErr decl
@@ -1554,33 +1565,67 @@
--
refStruct :: CStructUnion -> Ident -> GB (BitSize, CDecl)
refStruct su ide =
- do
+ case refStruct' su ide of
+ Nothing -> unknownFieldErr (posOf su) ide
+ Just ref -> ref
+
+refStruct' :: CStructUnion -> Ident -> Maybe (GB (BitSize, CDecl))
+refStruct' su ide =
-- get the list of fields and check for our selector
- --
let (fields, tag) = structMembers su
- (pre, post) = span (not . flip declNamed ide) fields
- when (null post) $
- unknownFieldErr (posOf su) ide
- --
- -- get sizes of preceding fields and the result type (`pre' are all
- -- declarators preceding `ide' and the first declarator in `post' defines
- -- `ide')
- --
- let decl = head post
+ (pre, post) = break (fieldDeclNamed ide) fields
+ in case post of
+ decl : _ -> Just (offsetInStructUnion tag pre decl)
+ -- if not declared on this level, search fields that are
+ -- anonymous struct/unions
+ [] -> case refStructDeep (probeStruct ide) fields of
+ (preNest, Just (container, containedRef))->
+ Just $ combineOffsets tag preNest container containedRef
+ (_, Nothing )-> Nothing
+
+-- determine if field is a struct/union that exposes matched identifier anonymously,
+-- by calling refStruct' recursively. If not, return Nothing, If so, return result of refstruct'
+probeStruct :: Ident -> CDecl -> Maybe (GB (BitSize, CDecl))
+probeStruct ide (CDecl specs [] _) =
+ case [ts | CTypeSpec ts <- specs] of
+ -- extract structure or union to search here
+ CSUType su _ : _-> refStruct' su ide -- not handling forward refs here yet
+ -- other prim types
+ _ -> Nothing -- anonymous field not a struct or union
+probeStruct _ _ = Nothing -- all cases but unnamed field
+
+refStructDeep :: (a -> Maybe b) -> [a] -> ([a], Maybe (a, b))
+refStructDeep f = go id where
+ go !acc [] = (acc [], Nothing)
+ go !acc (x:xs) = case f x of
+ Nothing -> go (acc . (x:)) xs
+ Just b -> (acc [], Just (x, b))
+
+offsetInStructUnion :: CStructTag -> [CDecl] -> CDecl -> GB (BitSize, CDecl)
+offsetInStructUnion tag pre decl =
+ do
+ offset <- case tag of
+ CStructTag -> offsetInStruct pre decl tag
+ CUnionTag -> return $ BitSize 0 0
+ return (offset, decl)
+
+combineOffsets :: CStructTag -> [CDecl] -> CDecl -> GB (BitSize, CDecl) -> GB (BitSize, CDecl)
+combineOffsets tag pre decl containedRef =
+ do
+ (containedOffset, containedDecl) <- containedRef
offset <- case tag of
CStructTag -> offsetInStruct pre decl tag
- CUnionTag -> return $ BitSize 0 0
- return (offset, decl)
+ CUnionTag -> return $ BitSize 0 0
+ return (offset `addBitSize` containedOffset, containedDecl)
--- | does the given declarator define the given name?
+-- | does the given declarator define the given name at top level?
--
-declNamed :: CDecl -> Ident -> Bool
-(CDecl _ [(Nothing , _, _)] _) `declNamed` _ = False
-(CDecl _ [(Just declr, _, _)] _) `declNamed` ide = declr `declrNamed` ide
-cdecl@(CDecl _ [] _) `declNamed` _ =
- errorAtPos (posOf cdecl) ["GenBind.declNamed: Abstract declarator in structure!"]
-cdecl `declNamed` _ =
- errorAtPos (posOf cdecl) ["GenBind.declNamed: More than one declarator!"]
+fieldDeclNamed :: Ident -> CDecl -> Bool
+ide `fieldDeclNamed` (CDecl _ [(Just declr, _, _)] _) = declr `declrNamed` ide
+_ `fieldDeclNamed` (CDecl _ [(Nothing , _, _)] _) = False
+_ `fieldDeclNamed` (CDecl _ [] _) = False
+_ `fieldDeclNamed` cdecl =
+ errorAtPos (posOf cdecl) ["GenBind.fieldDeclNamed: More than one declarator!"]
-- | Haskell code for writing to or reading from a struct
--
@@ -1667,7 +1712,7 @@
addHsDependency "Foreign.C.Types"
addHsDependency "Foreign.Storable"
return $ impm "toBool" ++ " `fmap` (" ++ impm "peekByteOff"
- ++ " ptr " ++ show off ++ " :: IO " ++ impm "CInt" ++ ")"
+ ++ " ptr " ++ show off ++ " :: IO " ++ impm "CUChar" ++ ")"
peekOp off t Nothing = do
addHsDependency "Foreign.Storable"
addExtTypeDependency t
@@ -1684,7 +1729,7 @@
addHsDependency "Foreign.Storable"
return $ impm "pokeByteOff" ++ " ptr " ++ show off
++ " (" ++ impm "fromBool" ++ " " ++
- var ++ " :: " ++ impm "CInt" ++ ")"
+ var ++ " :: " ++ impm "CUChar" ++ ")"
pokeOp off t var Nothing = do
addHsDependency "Foreign.Storable"
addExtTypeDependency t
@@ -1952,7 +1997,7 @@
showExtType (PrimET CFloatPT) = impm "CFloat"
showExtType (PrimET CDoublePT) = impm "CDouble"
showExtType (PrimET CLDoublePT) = impm "CLDouble"
-showExtType (PrimET CBoolPT) = impm "CInt{-bool-}"
+showExtType (PrimET CBoolPT) = impm "CUChar{-bool-}"
showExtType (PrimET (CSFieldPT bs)) = impm "CInt{-:" ++ show bs ++ "-}"
showExtType (PrimET (CUFieldPT bs)) = impm "CUInt{-:" ++ show bs ++ "-}"
showExtType (PrimET (CAliasedPT _ hs _)) = hs
@@ -2726,6 +2771,10 @@
(IntResult y) = return $ IntResult (x .|. y)
applyBin _ CAndOp (IntResult x)
(IntResult y) = return $ IntResult (x .&. y)
+applyBin _ CEqOp (IntResult x)
+ (IntResult y) = return $ IntResult (if x == y then 1 else 0)
+applyBin _ CNeqOp (IntResult x)
+ (IntResult y) = return $ IntResult (if x /= y then 1 else 0)
applyBin pos _ (IntResult _)
(IntResult _) =
todo $ "GenBind.applyBin: Not yet implemented operator in constant expression. " ++ show pos
@@ -3097,7 +3146,7 @@
let mungedCc = mungePath topDir cc
writeIORef cCompilerRef $ Just mungedCc
return mungedCc
- _ -> error "Failed to determine C compiler from 'ghc --info'!"
+ _ -> error "Failed to determine C compiler from 'ghc --info'!"
where
-- adapted from ghc/compiler/main/Packages.hs
diff --git a/src/C2HS/Gen/Header.hs b/src/C2HS/Gen/Header.hs
--- a/src/C2HS/Gen/Header.hs
+++ b/src/C2HS/Gen/Header.hs
@@ -39,7 +39,7 @@
--
--- TODO ----------------------------------------------------------------------
--
--- * Ideally, `ghFrag[s]' should be tail recursive
+-- * Ideally, `ghFrag[s]' should be tail recursive
module C2HS.Gen.Header (
genHeader
@@ -219,7 +219,7 @@
Nothing)]
undefNode
-ghFrag (frag@(CHSHook (CHSFun _ _ True varTypes
+ghFrag (frag@(CHSHook (CHSFun _ _ _ True varTypes
(CHSRoot _ ide) oalias _ _ _ _) _) : frags) = do
let ideLexeme = identToString ide
hsLexeme = ideLexeme `maybe` identToString $ oalias
diff --git a/src/C2HS/Gen/Monad.hs b/src/C2HS/Gen/Monad.hs
--- a/src/C2HS/Gen/Monad.hs
+++ b/src/C2HS/Gen/Monad.hs
@@ -376,12 +376,13 @@
where
newEntry = (hook, (CHSVerb ("\n" ++ str) (posOf hook)))
--
- delay hook'@(CHSCall isFun isUns ide _oalias _) frags' =
+ delay hook'@(CHSCall isFun isIntr isUns ide _oalias _) frags' =
case find (\(hook'', _) -> hook'' == hook') frags' of
- Just (CHSCall isFun' isUns' ide' _ _, _)
- | isFun == isFun'
- && isUns == isUns'
- && ide == ide' -> return frags'
+ Just (CHSCall isFun' isIntr' isUns' ide' _ _, _)
+ | isFun == isFun'
+ && isIntr == isIntr'
+ && isUns == isUns'
+ && ide == ide' -> return frags'
| otherwise -> err (posOf ide) (posOf ide')
Nothing -> return $ frags' ++ [newEntry]
delay hook'@(CHSPointer _ _ _ _ _ _ _ _) frags' =
diff --git a/src/C2HS/Gen/Wrapper.hs b/src/C2HS/Gen/Wrapper.hs
--- a/src/C2HS/Gen/Wrapper.hs
+++ b/src/C2HS/Gen/Wrapper.hs
@@ -107,7 +107,7 @@
replaceBool (CDecl spec ds n) = CDecl (map replaceBoolSpec spec) ds n
replaceBoolSpec :: CDeclSpec -> CDeclSpec
-replaceBoolSpec (CTypeSpec (CBoolType tn)) = CTypeSpec (CIntType tn)
+replaceBoolSpec (CTypeSpec (CBoolType tn)) = CTypeSpec (CCharType tn)
replaceBoolSpec t = t
fixDecl :: String -> Position -> (Bool, Bool, Int) -> CDecl -> CST s CDecl
diff --git a/src/Main.hs b/src/Main.hs
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -577,8 +577,13 @@
versionOpt = [ "-DC2HS_VERSION_MAJOR=" ++ versMajor
, "-DC2HS_VERSION_MINOR=" ++ versMinor
, "-DC2HS_VERSION_REV=" ++ versRev ]
- args = cppOpts ++ nonGNUOpts ++ ["-U__BLOCKS__"] ++
- versionOpt ++ [newHeaderFile]
+ args = filter (not . null) $
+ concat [ cppOpts
+ , nonGNUOpts
+ , ["-U__BLOCKS__"]
+ , versionOpt
+ , [newHeaderFile]
+ ]
tracePreproc (unwords (cpp:args))
exitCode <- CIO.liftIO $ do
preprocHnd <- openFile preprocFile WriteMode
diff --git a/tests/bugs/issue-230/Issue230.chs b/tests/bugs/issue-230/Issue230.chs
new file mode 100644
--- /dev/null
+++ b/tests/bugs/issue-230/Issue230.chs
@@ -0,0 +1,38 @@
+module Main where
+
+#include "issue230.h"
+
+import Control.Monad (liftM)
+import Foreign.C
+
+cIntConv :: CInt-> Int
+cIntConv = fromIntegral
+
+cDblConv :: CDouble -> Double
+cDblConv = realToFrac
+
+main :: IO ()
+main = do
+ test1 <- {#call make_test1#}
+ val1A <- liftM cIntConv $ {#get test1->a#} test1
+ val1B <- liftM cIntConv $ {#get test1->b#} test1
+ val1C <- liftM cIntConv $ {#get test1->c#} test1
+ val1D <- liftM cDblConv $ {#get test1->d#} test1
+
+ test2 <- {#call make_test2#}
+ val2A <- liftM cIntConv $ {#get test2->a#} test2
+ val2B <- liftM cIntConv $ {#get test2->b#} test2
+ val2C <- liftM cIntConv $ {#get test2->c#} test2
+ val2D <- liftM cDblConv $ {#get test2->d#} test2
+
+ putStrLn (show val1A)
+ putStrLn (show val1B)
+ putStrLn (show val1C)
+ putStrLn (show val1D)
+ putStrLn (show val2A)
+ putStrLn (show val2B)
+ putStrLn (show $ val2C /= 7)
+ putStrLn (show val2D)
+
+ return ()
+
diff --git a/tests/bugs/issue-230/issue230.c b/tests/bugs/issue-230/issue230.c
new file mode 100644
--- /dev/null
+++ b/tests/bugs/issue-230/issue230.c
@@ -0,0 +1,23 @@
+#include
+
+#include "issue230.h"
+
+struct test1 *make_test1(void)
+{
+ struct test1 *t = malloc(sizeof(struct test1));
+ t->a = 1;
+ t->b = 2;
+ t->c = 3;
+ t->d = 4.0;
+ return t;
+}
+
+struct test2 *make_test2(void)
+{
+ struct test2 *t = malloc(sizeof(struct test2));
+ t->a = 5;
+ t->b = 6;
+ t->c = 7;
+ t->d = 8.0;
+ return t;
+}
diff --git a/tests/bugs/issue-230/issue230.h b/tests/bugs/issue-230/issue230.h
new file mode 100644
--- /dev/null
+++ b/tests/bugs/issue-230/issue230.h
@@ -0,0 +1,20 @@
+struct test1 {
+ int a;
+ struct {
+ int c;
+ double d;
+ };
+ int b;
+};
+
+struct test2 {
+ int a;
+ union {
+ int c;
+ double d;
+ };
+ int b;
+};
+
+struct test1* make_test1(void);
+struct test2* make_test2(void);
diff --git a/tests/bugs/issue-257/Issue257.chs b/tests/bugs/issue-257/Issue257.chs
new file mode 100644
--- /dev/null
+++ b/tests/bugs/issue-257/Issue257.chs
@@ -0,0 +1,19 @@
+module Main where
+
+#include "issue257.h"
+
+import Foreign.Ptr
+
+{#fun make_bools as make_bools {`Bool',`Bool',`Bool',`Bool'} -> `Ptr ()' #}
+
+main :: IO ()
+main = do
+ bools <- make_bools True False True False
+ a <- {#get bools->a#} bools
+ b <- {#get bools->b#} bools
+ c <- {#get bools->c#} bools
+ d <- {#get bools->d#} bools
+ putStrLn (show a)
+ putStrLn (show b)
+ putStrLn (show c)
+ putStrLn (show d)
diff --git a/tests/bugs/issue-257/issue257.c b/tests/bugs/issue-257/issue257.c
new file mode 100644
--- /dev/null
+++ b/tests/bugs/issue-257/issue257.c
@@ -0,0 +1,11 @@
+#include
+#include "issue257.h"
+
+struct bools* make_bools(bool a, bool b, bool c, bool d) {
+ struct bools* bs = malloc(sizeof(struct bools));
+ bs->a = a;
+ bs->b = b;
+ bs->c = c;
+ bs->d = d;
+ return bs;
+}
diff --git a/tests/bugs/issue-257/issue257.h b/tests/bugs/issue-257/issue257.h
new file mode 100644
--- /dev/null
+++ b/tests/bugs/issue-257/issue257.h
@@ -0,0 +1,14 @@
+#ifndef _BOOLS_H
+#define _BOOLS_H
+#include
+
+struct bools {
+ bool a;
+ bool b;
+ bool c;
+ bool d;
+};
+
+struct bools* make_bools(bool a, bool b, bool c, bool d);
+
+#endif /* _BOOLS_H */
diff --git a/tests/test-bugs.hs b/tests/test-bugs.hs
--- a/tests/test-bugs.hs
+++ b/tests/test-bugs.hs
@@ -94,6 +94,9 @@
, testCase "Issue #155" issue155
, testCase "Issue #180" issue180
, testCase "Issue #192" issue192
+ , testCase "Issue #230" issue230
+ , testCase "Issue #242" issue242
+ , testCase "Issue #257" issue257
] ++
-- Some tests that won't work on Windows.
if os /= "cygwin32" && os /= "mingw32"
@@ -114,6 +117,24 @@
let expected = ["upper C();", "lower c();", "upper C();"]
liftIO $ assertBool "" (T.lines res == expected)
+issue257 :: Assertion
+issue257 = c2hsShelly $ chdir "tests/bugs/issue-257" $ do
+ mapM_ rm_f ["Issue257.hs", "Issue257.chs.h", "Issue257.chs.c", "Issue257.chi",
+ "issue257_c.o", "Issue257.chs.o", "Issue257"]
+ cmd "c2hs" "Issue257.chs"
+ cmd cc "-c" "-o" "issue257_c.o" "issue257.c"
+ cmd cc "-c" "Issue257.chs.c"
+ cmd "ghc" "--make" "issue257_c.o" "Issue257.chs.o" "Issue257.hs"
+ res <- absPath "./Issue257" >>= cmd
+ let expected = ["True","False","True","False"]
+ liftIO $ assertBool "" (T.lines res == expected)
+
+issue242 :: Assertion
+issue242 = expect_issue 242 ["1"]
+
+issue230 :: Assertion
+issue230 = expect_issue 230 ["1", "2", "3", "4.0", "5", "6", "True", "8.0"]
+
issue192 :: Assertion
issue192 = hs_only_build_issue 192
@@ -455,17 +476,17 @@
run "c2hs" $ c2hsargs ++ [toTextIgnore $ uc <.> "chs"]
code <- lastExitCode
when (code == 0) $ do
- when cbuild $ cmd cc "-c" "-o" (lcc <.> "o") (lc <.> "c")
+ when cbuild $ cmd cc "-c" "-o" (T.pack $ lcc <.> "o") (T.pack $ lc <.> "c")
code <- lastExitCode
when (code == 0) $ case (strict, cbuild) of
(True, True) ->
- cmd "ghc" "-Wall" "-Werror" "--make" (lcc <.> "o") (uc <.> "hs")
+ cmd "ghc" "-Wall" "-Werror" "--make" (T.pack $ lcc <.> "o") (T.pack $ uc <.> "hs")
(False, True) ->
- cmd "ghc" "--make" (lcc <.> "o") (uc <.> "hs")
+ cmd "ghc" "--make" (T.pack $ lcc <.> "o") (T.pack $ uc <.> "hs")
(True, False) ->
- cmd "ghc" "-Wall" "-Werror" "--make" (uc <.> "hs")
+ cmd "ghc" "-Wall" "-Werror" "--make" (T.pack $ uc <.> "hs")
(False, False) ->
- cmd "ghc" "--make" (uc <.> "hs")
+ cmd "ghc" "--make" (T.pack $ uc <.> "hs")
expect_issue :: Int -> [Text] -> Assertion
expect_issue n expected = expect_issue_with True True n "" [] expected
diff --git a/tests/test-system.hs b/tests/test-system.hs
--- a/tests/test-system.hs
+++ b/tests/test-system.hs
@@ -40,6 +40,7 @@
, testCase "Simple" test_simple
-- , testCase "Sizeof" test_sizeof -- KNOWN FAILURE: ISSUE #10
, testCase "Structs" test_structs
+ , testCase "Interruptible" test_interruptible
]
]
@@ -118,3 +119,11 @@
("ghc", ["-o", "structs", "structs_c.o", "Structs.o"])]
"./structs"
["42 & -1 & 2 & 200 & ' '"]
+
+test_interruptible :: Assertion
+test_interruptible = run_test_expect "tests/system/interruptible"
+ [("c2hs", ["interruptible.h", "Interruptible.chs"]),
+ (cc, ["-o", "interruptible_c.o", "-c", "interruptible.c"]),
+ ("ghc", ["-o", "interruptible", "interruptible_c.o", "Interruptible.hs"])]
+ "./interruptible"
+ ["interrupted!"]