diff -Nru c2hs-0.28.6/c2hs.cabal c2hs-0.28.8/c2hs.cabal --- c2hs-0.28.6/c2hs.cabal 2018-09-26 01:37:37.000000000 +0000 +++ c2hs-0.28.8/c2hs.cabal 2001-09-09 01:46:40.000000000 +0000 @@ -1,5 +1,5 @@ Name: c2hs -Version: 0.28.6 +Version: 0.28.8 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 @@ -113,7 +115,7 @@ Executable c2hs Build-Depends: base >= 2 && < 5, bytestring, - language-c >= 0.7.1 && < 0.9, + language-c >= 0.7.1 && < 0.10, filepath, dlist @@ -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 -Nru c2hs-0.28.6/ChangeLog c2hs-0.28.8/ChangeLog --- c2hs-0.28.6/ChangeLog 2018-09-26 01:39:27.000000000 +0000 +++ c2hs-0.28.8/ChangeLog 2001-09-09 01:46:40.000000000 +0000 @@ -1,3 +1,16 @@ +0.28.8.* + - Bump upper bounds of language-c to 0.10 [#261] +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 -Nru c2hs-0.28.6/debian/changelog c2hs-0.28.8/debian/changelog --- c2hs-0.28.6/debian/changelog 2021-09-11 05:00:47.000000000 +0000 +++ c2hs-0.28.8/debian/changelog 2022-02-01 17:53:38.000000000 +0000 @@ -1,32 +1,16 @@ -c2hs (0.28.6-1build4.1) impish; urgency=medium +c2hs (0.28.8-1) unstable; urgency=medium - * No-change rebuild for libffi soname change. + [ Apollon Oikonomopoulos ] + * Team upload + * New upstream release + + B-D on libghc-language-c-dev >= 0.9 to ensure GCC-11 compatibility + (closes: #984167) + * Fix paragraph continuation in d/copyright - -- Matthias Klose Sat, 11 Sep 2021 07:00:47 +0200 + [ Debian Janitor ] + * Remove MIA uploaders -c2hs (0.28.6-1build4) groovy; urgency=medium - - * No-change rebuild against libffi8ubuntu1 - - -- Steve Langasek Thu, 27 Aug 2020 00:02:50 +0000 - -c2hs (0.28.6-1build3) focal; urgency=medium - - * No-change rebuild with fixed binutils on arm64. - - -- Matthias Klose Sat, 08 Feb 2020 10:56:30 +0000 - -c2hs (0.28.6-1build2) focal; urgency=medium - - * No-change rebuild for libffi soname change. - - -- Matthias Klose Sun, 12 Jan 2020 09:06:36 +0000 - -c2hs (0.28.6-1build1) eoan; urgency=medium - - * Rebuild against new GHC abi. - - -- Gianfranco Costamagna Sat, 07 Sep 2019 17:40:48 +0200 + -- Apollon Oikonomopoulos Tue, 01 Feb 2022 19:53:38 +0200 c2hs (0.28.6-1) unstable; urgency=medium diff -Nru c2hs-0.28.6/debian/control c2hs-0.28.8/debian/control --- c2hs-0.28.6/debian/control 2020-08-27 00:02:49.000000000 +0000 +++ c2hs-0.28.8/debian/control 2022-02-01 17:53:38.000000000 +0000 @@ -1,8 +1,6 @@ Source: c2hs -Maintainer: Ubuntu Developers -XSBC-Original-Maintainer: Debian Haskell Group +Maintainer: Debian Haskell Group Uploaders: - Arjan Oosting , Erik de Castro Lopo , Priority: optional Section: haskell @@ -18,8 +16,8 @@ happy, haskell-devscripts (>= 0.13), libghc-dlist-dev, - libghc-language-c-dev (>= 0.7.1), - libghc-language-c-dev (<< 0.9), + libghc-language-c-dev (>= 0.9), + libghc-language-c-dev (<< 0.10), libghc-language-c-prof, libxml2-utils, xsltproc, diff -Nru c2hs-0.28.6/debian/copyright c2hs-0.28.8/debian/copyright --- c2hs-0.28.6/debian/copyright 2019-07-29 00:13:16.000000000 +0000 +++ c2hs-0.28.8/debian/copyright 2022-02-01 17:53:38.000000000 +0000 @@ -21,7 +21,7 @@ documentation and/or other materials provided with the distribution. 3. The name of the author may not be used to endorse or promote products derived from this software without specific prior written permission. - + . THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE diff -Nru c2hs-0.28.6/doc/c2hs.xml c2hs-0.28.8/doc/c2hs.xml --- c2hs-0.28.6/doc/c2hs.xml 2018-09-26 01:06:29.000000000 +0000 +++ c2hs-0.28.8/doc/c2hs.xml 2001-09-09 01:46:40.000000000 +0000 @@ -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 -Nru c2hs-0.28.6/src/C2HS/C/Names.hs c2hs-0.28.8/src/C2HS/C/Names.hs --- c2hs-0.28.6/src/C2HS/C/Names.hs 2018-09-26 01:06:29.000000000 +0000 +++ c2hs-0.28.8/src/C2HS/C/Names.hs 2001-09-09 01:46:40.000000000 +0000 @@ -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 -Nru c2hs-0.28.6/src/C2HS/C/Trav.hs c2hs-0.28.8/src/C2HS/C/Trav.hs --- c2hs-0.28.6/src/C2HS/C/Trav.hs 2018-09-26 01:06:29.000000000 +0000 +++ c2hs-0.28.8/src/C2HS/C/Trav.hs 2001-09-09 01:46:40.000000000 +0000 @@ -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 -Nru c2hs-0.28.6/src/C2HS/CHS/Lexer.hs c2hs-0.28.8/src/C2HS/CHS/Lexer.hs --- c2hs-0.28.6/src/C2HS/CHS/Lexer.hs 2018-09-26 01:06:29.000000000 +0000 +++ c2hs-0.28.8/src/C2HS/CHS/Lexer.hs 2001-09-09 01:46:40.000000000 +0000 @@ -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 -Nru c2hs-0.28.6/src/C2HS/CHS.hs c2hs-0.28.8/src/C2HS/CHS.hs --- c2hs-0.28.6/src/C2HS/CHS.hs 2018-09-26 01:06:29.000000000 +0000 +++ c2hs-0.28.8/src/C2HS/CHS.hs 2001-09-09 01:46:40.000000000 +0000 @@ -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 @@ -1225,6 +1234,10 @@ 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) parseIsUnsafe toks = return (False, toks) diff -Nru c2hs-0.28.6/src/C2HS/Gen/Bind.hs c2hs-0.28.8/src/C2HS/Gen/Bind.hs --- c2hs-0.28.6/src/C2HS/Gen/Bind.hs 2018-09-26 01:06:29.000000000 +0000 +++ c2hs-0.28.8/src/C2HS/Gen/Bind.hs 2001-09-09 01:46:40.000000000 +0000 @@ -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 -Nru c2hs-0.28.6/src/C2HS/Gen/Header.hs c2hs-0.28.8/src/C2HS/Gen/Header.hs --- c2hs-0.28.6/src/C2HS/Gen/Header.hs 2018-09-26 01:06:29.000000000 +0000 +++ c2hs-0.28.8/src/C2HS/Gen/Header.hs 2001-09-09 01:46:40.000000000 +0000 @@ -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 -Nru c2hs-0.28.6/src/C2HS/Gen/Monad.hs c2hs-0.28.8/src/C2HS/Gen/Monad.hs --- c2hs-0.28.6/src/C2HS/Gen/Monad.hs 2018-09-26 01:06:29.000000000 +0000 +++ c2hs-0.28.8/src/C2HS/Gen/Monad.hs 2001-09-09 01:46:40.000000000 +0000 @@ -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 -Nru c2hs-0.28.6/src/C2HS/Gen/Wrapper.hs c2hs-0.28.8/src/C2HS/Gen/Wrapper.hs --- c2hs-0.28.6/src/C2HS/Gen/Wrapper.hs 2018-09-26 01:06:29.000000000 +0000 +++ c2hs-0.28.8/src/C2HS/Gen/Wrapper.hs 2001-09-09 01:46:40.000000000 +0000 @@ -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 -Nru c2hs-0.28.6/src/Main.hs c2hs-0.28.8/src/Main.hs --- c2hs-0.28.6/src/Main.hs 2018-09-26 01:06:29.000000000 +0000 +++ c2hs-0.28.8/src/Main.hs 2001-09-09 01:46:40.000000000 +0000 @@ -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 -Nru c2hs-0.28.6/tests/bugs/issue-230/issue230.c c2hs-0.28.8/tests/bugs/issue-230/issue230.c --- c2hs-0.28.6/tests/bugs/issue-230/issue230.c 1970-01-01 00:00:00.000000000 +0000 +++ c2hs-0.28.8/tests/bugs/issue-230/issue230.c 2001-09-09 01:46:40.000000000 +0000 @@ -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 -Nru c2hs-0.28.6/tests/bugs/issue-230/Issue230.chs c2hs-0.28.8/tests/bugs/issue-230/Issue230.chs --- c2hs-0.28.6/tests/bugs/issue-230/Issue230.chs 1970-01-01 00:00:00.000000000 +0000 +++ c2hs-0.28.8/tests/bugs/issue-230/Issue230.chs 2001-09-09 01:46:40.000000000 +0000 @@ -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 -Nru c2hs-0.28.6/tests/bugs/issue-230/issue230.h c2hs-0.28.8/tests/bugs/issue-230/issue230.h --- c2hs-0.28.6/tests/bugs/issue-230/issue230.h 1970-01-01 00:00:00.000000000 +0000 +++ c2hs-0.28.8/tests/bugs/issue-230/issue230.h 2001-09-09 01:46:40.000000000 +0000 @@ -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 -Nru c2hs-0.28.6/tests/bugs/issue-257/issue257.c c2hs-0.28.8/tests/bugs/issue-257/issue257.c --- c2hs-0.28.6/tests/bugs/issue-257/issue257.c 1970-01-01 00:00:00.000000000 +0000 +++ c2hs-0.28.8/tests/bugs/issue-257/issue257.c 2001-09-09 01:46:40.000000000 +0000 @@ -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 -Nru c2hs-0.28.6/tests/bugs/issue-257/Issue257.chs c2hs-0.28.8/tests/bugs/issue-257/Issue257.chs --- c2hs-0.28.6/tests/bugs/issue-257/Issue257.chs 1970-01-01 00:00:00.000000000 +0000 +++ c2hs-0.28.8/tests/bugs/issue-257/Issue257.chs 2001-09-09 01:46:40.000000000 +0000 @@ -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 -Nru c2hs-0.28.6/tests/bugs/issue-257/issue257.h c2hs-0.28.8/tests/bugs/issue-257/issue257.h --- c2hs-0.28.6/tests/bugs/issue-257/issue257.h 1970-01-01 00:00:00.000000000 +0000 +++ c2hs-0.28.8/tests/bugs/issue-257/issue257.h 2001-09-09 01:46:40.000000000 +0000 @@ -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 -Nru c2hs-0.28.6/tests/test-bugs.hs c2hs-0.28.8/tests/test-bugs.hs --- c2hs-0.28.6/tests/test-bugs.hs 2018-09-26 01:06:29.000000000 +0000 +++ c2hs-0.28.8/tests/test-bugs.hs 2001-09-09 01:46:40.000000000 +0000 @@ -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 -Nru c2hs-0.28.6/tests/test-system.hs c2hs-0.28.8/tests/test-system.hs --- c2hs-0.28.6/tests/test-system.hs 2018-09-26 01:06:29.000000000 +0000 +++ c2hs-0.28.8/tests/test-system.hs 2001-09-09 01:46:40.000000000 +0000 @@ -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!"]