packages feed

c2hs 0.28.6 → 0.28.7

raw patch · 20 files changed

+373/−128 lines, 20 filesdep ~shelly

Dependency ranges changed: shelly

Files

ChangeLog view
@@ -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
c2hs.cabal view
@@ -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
doc/c2hs.xml view
@@ -447,17 +447,18 @@     <title>Call Hooks</title>     <para> <programlisting>-{#call [pure] [unsafe] <replaceable>cid</replaceable> [as (<replaceable>hsid</replaceable> | ^)]#}+{#call [pure] [unsafe] [interruptible] <replaceable>cid</replaceable> [as (<replaceable>hsid</replaceable> | ^)]#} </programlisting>      A call hook rewrites to a call to the C function     <replaceable>cid</replaceable> and also ensures that the appropriate foreign     import declaration is generated.  The tags <literal>pure</literal> and     <literal>unsafe</literal> specify that the external function is purely-    functional and cannot re-enter the Haskell runtime, respectively.  If-    <replaceable>hsid</replaceable> is present, it is used as the identifier for-    the foreign declaration, which otherwise defaults to the-    <replaceable>cid</replaceable>.  When instead of+    functional and cannot re-enter the Haskell runtime, respectively.  The+    <literal>interruptible</literal> flag is intended to be used in conjunction+    with the InterruptibleFFI extension. If <replaceable>hsid</replaceable> is+    present, it is used as the identifier for the foreign declaration, which+    otherwise defaults to the <replaceable>cid</replaceable>.  When instead of     <replaceable>hsid</replaceable>, the symbol <literal>^</literal> is given,     the <replaceable>cid</replaceable> after conversion from C's underscore     notation to a capitalised identifier is used.@@ -477,7 +478,7 @@     <title>Function Hooks</title>     <para> <programlisting>-{#fun  [pure] [unsafe] <replaceable>cid</replaceable> [as (<replaceable>hsid</replaceable> | ^)]+{#fun  [pure] [unsafe] [interruptible] <replaceable>cid</replaceable> [as (<replaceable>hsid</replaceable> | ^)] [<replaceable>ctxt</replaceable> =>] { <replaceable>parm1</replaceable> , ... , <replaceable>parmn</replaceable> } -> <replaceable>parm</replaceable> </programlisting> @@ -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
src/C2HS/C/Names.hs view
@@ -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 --
src/C2HS/C/Trav.hs view
@@ -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
src/C2HS/CHS.hs view
@@ -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)
src/C2HS/CHS/Lexer.hs view
@@ -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"
src/C2HS/Gen/Bind.hs view
@@ -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
src/C2HS/Gen/Header.hs view
@@ -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
src/C2HS/Gen/Monad.hs view
@@ -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' =
src/C2HS/Gen/Wrapper.hs view
@@ -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
src/Main.hs view
@@ -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
+ tests/bugs/issue-230/Issue230.chs view
@@ -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 ()+
+ tests/bugs/issue-230/issue230.c view
@@ -0,0 +1,23 @@+#include <stdlib.h>++#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;+}
+ tests/bugs/issue-230/issue230.h view
@@ -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);
+ tests/bugs/issue-257/Issue257.chs view
@@ -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)
+ tests/bugs/issue-257/issue257.c view
@@ -0,0 +1,11 @@+#include <stdlib.h>+#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;+}
+ tests/bugs/issue-257/issue257.h view
@@ -0,0 +1,14 @@+#ifndef _BOOLS_H+#define _BOOLS_H+#include <stdbool.h>++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 */
tests/test-bugs.hs view
@@ -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
tests/test-system.hs view
@@ -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!"]