c2hs 0.24.1 → 0.25.1
raw patch · 11 files changed
+357/−120 lines, 11 files
Files
- ChangeLog +3/−0
- c2hs.cabal +2/−1
- src/C2HS/C/Info.hs +2/−34
- src/C2HS/Gen/Bind.hs +190/−63
- src/C2HS/Gen/Monad.hs +17/−7
- src/C2HS/Gen/Wrapper.hs +31/−15
- tests/bugs/issue-128/Issue128.chs +42/−0
- tests/bugs/issue-128/issue128.c +37/−0
- tests/bugs/issue-128/issue128.h +13/−0
- tests/bugs/issue-128/tst.c +2/−0
- tests/test-bugs.hs +18/−0
ChangeLog view
@@ -1,3 +1,6 @@+0.25.1+ - Marshalling for C bool values [#128]+ 0.24.1 - Revert bad fix for bool handling [#127] - Wrapper generation for bare structure arguments [#117] plus custom
c2hs.cabal view
@@ -1,5 +1,5 @@ Name: c2hs-Version: 0.24.1+Version: 0.25.1 License: GPL-2 License-File: COPYING Copyright: Copyright (c) 1999-2007 Manuel M T Chakravarty@@ -89,6 +89,7 @@ tests/bugs/issue-117/*.chs tests/bugs/issue-117/*.h tests/bugs/issue-117/*.c tests/bugs/issue-123/*.chs tests/bugs/issue-123/*.h tests/bugs/issue-123/*.c tests/bugs/issue-127/*.chs tests/bugs/issue-127/*.h tests/bugs/issue-127/*.c+ tests/bugs/issue-128/*.chs tests/bugs/issue-128/*.h tests/bugs/issue-128/*.c source-repository head type: git
src/C2HS/C/Info.hs view
@@ -54,14 +54,10 @@ -- module C2HS.C.Info (- CPrimType(..), size+ CPrimType(..) ) where -import Foreign (Ptr, FunPtr)-import qualified Foreign.Storable as Storable (Storable(sizeOf))-import Foreign.C - -- calibration of C's primitive types -- ---------------------------------- @@ -86,36 +82,8 @@ | CFloatPT -- float | CDoublePT -- double | CLDoublePT -- long double+ | CBoolPT -- bool (C99 _Bool) | CSFieldPT Int -- signed bit field | CUFieldPT Int -- unsigned bit field | CAliasedPT String String CPrimType deriving (Eq, Show)---- | size of primitive type of C------ * negative size implies that it is a bit, not an octet size----size :: CPrimType -> Int-size CPtrPT = Storable.sizeOf (undefined :: Ptr ())-size CFunPtrPT = Storable.sizeOf (undefined :: FunPtr ())-size CCharPT = 1-size CUCharPT = 1-size CSCharPT = 1-size CIntPT = Storable.sizeOf (undefined :: CInt)-size CShortPT = Storable.sizeOf (undefined :: CShort)-size CLongPT = Storable.sizeOf (undefined :: CLong)-size CLLongPT = Storable.sizeOf (undefined :: CLLong)-size CUIntPT = Storable.sizeOf (undefined :: CUInt)-size CUShortPT = Storable.sizeOf (undefined :: CUShort)-size CULongPT = Storable.sizeOf (undefined :: CULong)-size CULLongPT = Storable.sizeOf (undefined :: CLLong)-size CFloatPT = Storable.sizeOf (undefined :: CFloat)-size CDoublePT = Storable.sizeOf (undefined :: CDouble)-#if MIN_VERSION_base(4,2,0)-size CLDoublePT = 0 --marks it as an unsupported type, see 'specType'-#else-size CLDoublePT = Storable.sizeOf (undefined :: CLDouble)-#endif-size (CSFieldPT bs) = -bs-size (CUFieldPT bs) = -bs-size (CAliasedPT _ _ pt) = size pt
src/C2HS/Gen/Bind.hs view
@@ -51,6 +51,7 @@ -- float -> CFloat -- double -> CDouble -- long double -> CLDouble+-- bool -> CBool -- enum ... -> CInt -- struct ... -> ** error ** -- union ... -> ** error **@@ -107,10 +108,17 @@ where import Prelude hiding (exp, lookup)+import qualified Prelude -- standard libraries import Data.Char (toLower) import Data.Function (on)+import Data.IORef (IORef, newIORef, readIORef, writeIORef)+import System.IO.Unsafe (unsafePerformIO)+import System.IO (withFile, hPutStrLn, IOMode(..))+import System.Exit (ExitCode(..))+import System.Directory (removeFile)+import System.Process (readProcessWithExitCode, system) import Data.List (deleteBy, groupBy, sortBy, intersperse, find, nubBy, intercalate, isPrefixOf, foldl') import Data.Map (lookup)@@ -119,7 +127,8 @@ import Control.Arrow (second) import Control.Monad (when, unless, liftM, mapAndUnzipM, zipWithM, forM) import Data.Ord (comparing)-import qualified Foreign.Storable as Storable (Storable(alignment))+import qualified Foreign.Storable as Storable (Storable(alignment),+ Storable(sizeOf)) import Foreign (Ptr, FunPtr) import Foreign.C @@ -145,7 +154,6 @@ CHSTypedefInfo, Direction(..), CHSPtrType(..), showCHSParm, apathToIdent, apathRootIdent) import C2HS.C.Info (CPrimType(..))-import qualified C2HS.C.Info as CInfo import C2HS.Gen.Monad (TransFun, transTabToTransFun, HsObject(..), GB, GBState(..), Wrapper(..), initialGBState, setContext, getPrefix, getReplacementPrefix,@@ -360,7 +368,7 @@ isIntegralCPrimType :: CPrimType -> Bool isIntegralCPrimType = (`elem` [CCharPT, CSCharPT, CIntPT, CShortPT, CLongPT, CLLongPT, CUIntPT, CUCharPT, CUShortPT,- CULongPT, CULLongPT])+ CULongPT, CULLongPT, CBoolPT]) -- | check for floating C types --@@ -532,14 +540,14 @@ do traceInfoSizeof decl <- findAndChaseDeclOrTag ide False True -- no indirection, but shadows- (size, _) <- sizeAlignOf decl- traceInfoDump (render $ pretty decl) size- return $ show (padBits size)+ (sz, _) <- sizeAlignOf decl+ traceInfoDump (render $ pretty decl) sz+ return $ show (padBits sz) where traceInfoSizeof = traceGenBind "** Sizeof hook:\n"- traceInfoDump decl size = traceGenBind $+ traceInfoDump decl sz = traceGenBind $ "Size of declaration\n" ++ show decl ++ "\nis "- ++ show (padBits size) ++ "\n"+ ++ show (padBits sz) ++ "\n" expandHook (CHSEnumDefine _ _ _ _) _ = interr $ "Binding generation error : enum define hooks " ++ "should be eliminated via preprocessing "@@ -732,8 +740,8 @@ hsIde `objIs` Pointer ptrKind isNewtype -- register Haskell object decl <- findAndChaseDeclOrTag cName False True- (size, _) <- sizeAlignOf decl- hsIde `sizeIs` (padBits size)+ (sz, _) <- sizeAlignOf decl+ hsIde `sizeIs` (padBits sz) -- -- we check for a typedef declaration or tag (struct, union, or enum) --@@ -1030,14 +1038,20 @@ -- extType <- extractFunType pos cdecl isPure owrapped header <- getSwitch headerSB- let (needwrapper, wraps, ide) = case owrapped of- Nothing -> (False, [], ideLexeme)+ let bools@(boolres, boolargs) = boolArgs extType+ needwrapper1 = boolres || or boolargs+ (needwrapper2, wraps) = case owrapped of+ Nothing -> (False, replicate (numArgs extType) False) Just ws -> if or ws- then (True, ws, "__c2hs_wrapped__" ++ ideLexeme)- else (False, [], ideLexeme)+ then (True, ws)+ else (False, replicate (numArgs extType) False)+ ide = if needwrapper1 || needwrapper2+ then "__c2hs_wrapped__" ++ ideLexeme+ else ideLexeme delayCode hook (foreignImport (extractCallingConvention cdecl) header ide hsLexeme isUns extType varTypes)- when needwrapper $ addWrapper ide ideLexeme cdecl wraps pos+ when (needwrapper1 || needwrapper2) $+ addWrapper ide ideLexeme cdecl wraps bools pos traceFunType extType where traceFunType et = traceGenBind $@@ -1254,11 +1268,11 @@ msize <- querySize $ internalIdent hsParmTy case msize of Nothing -> interr "Missing size for \"+\" parameter allocation!"- Just size -> do+ Just sz -> do let a = "a" ++ show (i :: Int) bdr1 = a ++ "'" bdr2 = a ++ "''"- marshIn = "mallocForeignPtrBytes " ++ show size +++ marshIn = "mallocForeignPtrBytes " ++ show sz ++ " >>= \\" ++ bdr2 ++ " -> withForeignPtr " ++ bdr2 ++ " $ \\" ++ bdr1 ++ " -> "@@ -1425,13 +1439,13 @@ -- * declaration must have exactly one declarator -- replaceByAlias :: CDecl -> GB CDecl-replaceByAlias cdecl@(CDecl _ [(_, _, size)] _at) =+replaceByAlias cdecl@(CDecl _ [(_, _, sz)] _at) = do ocdecl <- checkForAlias cdecl case ocdecl of Nothing -> return cdecl Just (CDecl specs [(declr, init', _)] at) -> -- form of an alias- return $ CDecl specs [(declr, init', size)] at+ return $ CDecl specs [(declr, init', sz)] at -- | given a structure declaration and member name, compute the offset of the -- member in the structure and the declaration of the referenced member@@ -1484,19 +1498,18 @@ where setGetBody [BitSize offset bitOffset] = do- let tyTag = showExtType ty bf <- checkType ty case bf of Nothing -> return $ case access of -- not a bitfield- CHSGet -> peekOp offset tyTag arrSize- CHSSet -> pokeOp offset tyTag "val" arrSize+ CHSGet -> peekOp offset ty arrSize+ CHSSet -> pokeOp offset ty "val" arrSize --FIXME: must take `bitfieldDirection' into account Just (_, bs) -> return $ case access of -- a bitfield- CHSGet -> "val <- " ++ peekOp offset tyTag arrSize+ CHSGet -> "val <- " ++ peekOp offset ty arrSize ++ extractBitfield- CHSSet -> "org <- " ++ peekOp offset tyTag arrSize+ CHSSet -> "org <- " ++ peekOp offset ty arrSize ++ insertBitfield- ++ pokeOp offset tyTag "val'" arrSize+ ++ pokeOp offset ty "val'" arrSize where -- we have to be careful here to ensure proper sign extension; -- in particular, shifting right followed by anding a mask is@@ -1508,7 +1521,7 @@ ++ show (bs + bitOffset) ++ ")) `shiftR` (" ++ bitsPerField ++ " - " ++ show bs ++ ")"- bitsPerField = show $ CInfo.size CIntPT * 8+ bitsPerField = show $ size CIntPT * 8 -- insertBitfield = "; let {val' = (org .&. " ++ middleMask ++ ") .|. (val `shiftL` "@@ -1535,15 +1548,20 @@ checkType (PrimET (CSFieldPT bs)) = return $ Just (True , bs) checkType _ = return Nothing --- peekOp off tyTag Nothing =- "peekByteOff ptr " ++ show off ++ " ::IO " ++ tyTag- peekOp off tyTag (Just _) =- "return $ ptr `plusPtr` " ++ show off ++ " ::IO " ++ tyTag- pokeOp off tyTag var Nothing =- "pokeByteOff ptr " ++ show off ++ " (" ++ var ++ "::" ++ tyTag ++ ")"- pokeOp off tyTag var (Just sz) =+ peekOp off (PrimET CBoolPT) Nothing =+ "toBool `fmap` (peekByteOff ptr " ++ show off ++ " :: IO CInt)"+ peekOp off t Nothing =+ "peekByteOff ptr " ++ show off ++ " :: IO " ++ showExtType t+ peekOp off t (Just _) =+ "return $ ptr `plusPtr` " ++ show off ++ " :: IO " ++ showExtType t+ pokeOp off (PrimET CBoolPT) var Nothing =+ "pokeByteOff ptr " ++ show off ++ " (fromBool " ++ var ++ " :: CInt)"+ pokeOp off t var Nothing =+ "pokeByteOff ptr " ++ show off ++ " (" ++ var ++ " :: " +++ showExtType t ++ ")"+ pokeOp off t var (Just sz) = "copyArray (ptr `plusPtr` " ++ show off ++ ") (" ++- var ++ "::" ++ tyTag ++ ") " ++ show sz+ var ++ " :: " ++ showExtType t ++ ") " ++ show sz -- | generate the type definition for a pointer hook and enter the required type -- mapping into the 'ptrmap'@@ -1739,6 +1757,19 @@ numArgs (FunET _ f) = 1 + numArgs f numArgs _ = 0 +boolArgs :: ExtType -> (Bool, [Bool])+boolArgs (FunET a rest@(FunET _ _)) =+ let (res, as) = boolArgs rest in (res, boolArg a : as)+boolArgs (FunET a (IOET res) ) = boolArgs (FunET a res)+boolArgs (FunET a (PrimET CBoolPT)) = (True, [boolArg a])+boolArgs (FunET a _ ) = (False, [boolArg a])+boolArgs _ = (False, [])++boolArg :: ExtType -> Bool+boolArg (PrimET CBoolPT) = True+boolArg _ = False++ -- | pretty print an external type -- -- * a previous version of this function attempted to not print unnecessary@@ -1773,6 +1804,7 @@ showExtType (PrimET CFloatPT) = "CFloat" showExtType (PrimET CDoublePT) = "CDouble" showExtType (PrimET CLDoublePT) = "CLDouble"+showExtType (PrimET CBoolPT) = "CInt{-bool-}" showExtType (PrimET (CSFieldPT bs)) = "CInt{-:" ++ show bs ++ "-}" showExtType (PrimET (CUFieldPT bs)) = "CUInt{-:" ++ show bs ++ "-}" showExtType (PrimET (CAliasedPT _ hs _)) = hs@@ -1879,10 +1911,10 @@ if length declrs > 1 then interr "GenBind.extractCompType: Too many declarators!" else case declrs of- [(Just declr, _, size)] | isPtr || isPtrDeclr declr -> ptrType declr- | isFunDeclr declr -> funType- | otherwise -> aliasOrSpecType size- _ -> aliasOrSpecType Nothing+ [(Just declr, _, sz)] | isPtr || isPtrDeclr declr -> ptrType declr+ | isFunDeclr declr -> funType+ | otherwise -> aliasOrSpecType sz+ _ -> aliasOrSpecType Nothing where -- handle explicit pointer types --@@ -1925,10 +1957,10 @@ -- handle all types, which are not obviously pointers or functions -- aliasOrSpecType :: Maybe CExpr -> GB ExtType- aliasOrSpecType size = do- traceAliasOrSpecType size+ aliasOrSpecType sz = do+ traceAliasOrSpecType sz case checkForOneAliasName cdecl of- Nothing -> specType (posOf cdecl) specs' size+ Nothing -> specType (posOf cdecl) specs' sz Just ide -> do -- this is a typedef alias oDefault <- queryTypedef ide case oDefault of@@ -1943,8 +1975,8 @@ cdecl' <- getDeclOf ide let CDecl specs [(declr, init', _)] at = ide `simplifyDecl` cdecl'- sdecl = CDecl specs [(declr, init', size)] at- -- propagate `size' down (slightly kludgy)+ sdecl = CDecl specs [(declr, init', sz)] at+ -- propagate `sz' down (slightly kludgy) extractCompType isResult usePtrAliases False sdecl -- -- compute the result for a pointer alias@@ -1993,6 +2025,7 @@ ([unsigned, long, long, int] , PrimET CULLongPT ), ([float] , PrimET CFloatPT ), ([double] , PrimET CDoublePT ),+ ([bool] , PrimET CBoolPT ), ([long, double] , PrimET CLDoublePT), ([enum] , PrimET CIntPT )] where@@ -2003,6 +2036,7 @@ long = CLongType undefined float = CFloatType undefined double = CDoubleType undefined+ bool = CBoolType undefined signed = CSignedType undefined unsigned = CUnsigType undefined enum = CEnumType undefined undefined@@ -2042,7 +2076,7 @@ lookupTSpec = lookupBy matches -- -- can't be a bitfield (yet)- isUnsupportedType (PrimET et) = CInfo.size et == 0+ isUnsupportedType (PrimET et) = et /= CBoolPT && size et == 0 isUnsupportedType _ = False -- -- check whether two type specifier lists denote the same type; handles@@ -2063,6 +2097,7 @@ eqSpec (CLongType _) (CLongType _) = True eqSpec (CFloatType _) (CFloatType _) = True eqSpec (CDoubleType _) (CDoubleType _) = True+ eqSpec (CBoolType _) (CBoolType _) = True eqSpec (CSignedType _) (CSignedType _) = True eqSpec (CUnsigType _) (CUnsigType _) = True eqSpec (CSUType _ _) (CSUType _ _) = True@@ -2079,15 +2114,15 @@ case sizeResult of FloatResult _ -> illegalConstExprErr pos "a float result" IntResult size' -> do- let size = fromInteger size'+ let sz = fromInteger size' case et of- PrimET CUIntPT -> returnCT $ CUFieldPT size+ PrimET CUIntPT -> returnCT $ CUFieldPT sz PrimET CIntPT | [signed] `matches` tspecs- || [signed, int] `matches` tspecs -> returnCT $ CSFieldPT size+ || [signed, int] `matches` tspecs -> returnCT $ CSFieldPT sz | [int] `matches` tspecs ->- returnCT $ if bitfieldIntSigned then CSFieldPT size- else CUFieldPT size+ returnCT $ if bitfieldIntSigned then CSFieldPT sz+ else CUFieldPT sz _ -> illegalFieldSizeErr pos where returnCT = return . PrimET@@ -2165,9 +2200,9 @@ -- addBitSize :: BitSize -> BitSize -> BitSize addBitSize (BitSize o1 b1) (BitSize o2 b2) =- BitSize (o1 + o2 + overflow * CInfo.size CIntPT) rest+ BitSize (o1 + o2 + overflow * size CIntPT) rest where- bitsPerBitfield = CInfo.size CIntPT * 8+ bitsPerBitfield = size CIntPT * 8 (overflow, rest) = (b1 + b2) `divMod` bitsPerBitfield -- | multiply a bit size by a constant (gives size of an array)@@ -2177,14 +2212,14 @@ scaleBitSize :: Int -> BitSize -> BitSize scaleBitSize n (BitSize o1 b1) = BitSize (n * o1 + overflow) rest where- bitsPerBitfield = CInfo.size CIntPT * 8+ bitsPerBitfield = size CIntPT * 8 (overflow, rest) = (n * b1) `divMod` bitsPerBitfield -- | pad any storage unit that is partially used by a bitfield -- padBits :: BitSize -> Int padBits (BitSize o 0) = o-padBits (BitSize o _) = o + CInfo.size CIntPT+padBits (BitSize o _) = o + size CIntPT -- | compute the offset of the declarator in the second argument when it is -- preceded by the declarators in the first argument@@ -2207,9 +2242,9 @@ do PlatformSpec {bitfieldAlignmentPS = bitfieldAlignment} <- getPlatform (offset, preAlign) <- sizeAlignOfStruct (init decls) CStructTag- (size, align) <- sizeAlignOf (last decls)+ (sz, align) <- sizeAlignOf (last decls) let sizeOfStruct = alignOffset offset align bitfieldAlignment- `addBitSize` size+ `addBitSize` sz align' = if align > 0 then align else bitfieldAlignment alignOfStruct = preAlign `max` align' return (sizeOfStruct, alignOfStruct)@@ -2229,9 +2264,9 @@ sizeAlignOfStructPad :: [CDecl] -> CStructTag -> GB (BitSize, Int) sizeAlignOfStructPad decls tag = do- (size, align) <- sizeAlignOfStruct decls tag- let b = CInfo.size CIntPT- return (alignOffset size b b, align)+ (sz, align) <- sizeAlignOfStruct decls tag+ let b = size CIntPT+ return (alignOffset sz b b, align) -- | compute the size and alignment constraint of a given C declaration --@@ -2315,7 +2350,7 @@ bitSize et | sz < 0 = BitSize 0 (-sz) -- size is in bits | otherwise = BitSize sz 0 where- sz = CInfo.size et+ sz = size et -- | apply the given alignment constraint at the given offset --@@ -2337,7 +2372,7 @@ | otherwise = -- stays in current bitfield offset where- bitsPerBitfield = CInfo.size CIntPT * 8+ bitsPerBitfield = size CIntPT * 8 overflowingBitfield = bitOffset - align > bitsPerBitfield -- note, `align' is negative @@ -2378,8 +2413,8 @@ todo "GenBind.evalConstCExpr: sizeof not implemented yet." evalConstCExpr (CSizeofType decl _) = do- (size, _) <- sizeAlignOf decl- return $ IntResult (fromIntegral . padBits $ size)+ (sz, _) <- sizeAlignOf decl+ return $ IntResult (fromIntegral . padBits $ sz) evalConstCExpr (CAlignofExpr _ _) = todo "GenBind.evalConstCExpr: alignof (GNU C extension) not implemented yet." evalConstCExpr (CAlignofType decl _) =@@ -2708,6 +2743,37 @@ undefEnumErr pos = raiseErrorCTExc pos ["Incomplete enum type!"] +-- | size of primitive type of C+--+-- * negative size implies that it is a bit, not an octet size+--+size :: CPrimType -> Int+size CPtrPT = Storable.sizeOf (undefined :: Ptr ())+size CFunPtrPT = Storable.sizeOf (undefined :: FunPtr ())+size CCharPT = 1+size CUCharPT = 1+size CSCharPT = 1+size CIntPT = Storable.sizeOf (undefined :: CInt)+size CShortPT = Storable.sizeOf (undefined :: CShort)+size CLongPT = Storable.sizeOf (undefined :: CLong)+size CLLongPT = Storable.sizeOf (undefined :: CLLong)+size CUIntPT = Storable.sizeOf (undefined :: CUInt)+size CUShortPT = Storable.sizeOf (undefined :: CUShort)+size CULongPT = Storable.sizeOf (undefined :: CULong)+size CULLongPT = Storable.sizeOf (undefined :: CLLong)+size CFloatPT = Storable.sizeOf (undefined :: Foreign.C.CFloat)+size CDoublePT = Storable.sizeOf (undefined :: CDouble)+#if MIN_VERSION_base(4,2,0)+size CLDoublePT = 0 --marks it as an unsupported type, see 'specType'+#else+size CLDoublePT = Storable.sizeOf (undefined :: CLDouble)+#endif+size CBoolPT = cBoolSize+size (CSFieldPT bs) = -bs+size (CUFieldPT bs) = -bs+size (CAliasedPT _ _ pt) = size pt++ -- | alignment of C's primitive types -- -- * more precisely, the padding put before the type's member starts when the@@ -2735,6 +2801,7 @@ #else alignment CLDoublePT = return $ Storable.alignment (undefined :: CLDouble) #endif+alignment CBoolPT = return cBoolSize alignment (CSFieldPT bs) = fieldAlignment bs alignment (CUFieldPT bs) = fieldAlignment bs alignment (CAliasedPT _ _ pt) = alignment pt@@ -2760,7 +2827,7 @@ -- triggered -- fieldAlignment :: Int -> GB Int-fieldAlignment 0 = return $ - (CInfo.size CIntPT - 1)+fieldAlignment 0 = return $ - (size CIntPT - 1) fieldAlignment bs = do PlatformSpec {bitfieldPaddingPS = bitfieldPadding} <- getPlatform@@ -2770,3 +2837,63 @@ -- getPlatform :: GB PlatformSpec getPlatform = getSwitch platformSB+++-- All this is slightly horrible, but it's the only way to find the+-- size of the C99 _Bool type which is needed for marshalling+-- structures containing C 'bool' values. (Marshalling of 'bool'+-- function arguments and return values can be done by passing them+-- through the FFI as C 'int', but calculating offsets into structures+-- requires knowledge of the size of the type, which isn't provided by+-- the Haskell FFI.)++{-# NOINLINE cBoolSizeRef #-}+cBoolSizeRef :: IORef (Maybe Int)+cBoolSizeRef = unsafePerformIO $ newIORef Nothing++findBoolSize :: IO Int+findBoolSize = do+ withFile "c2hs__bool_size.c" WriteMode $ \h -> do+ hPutStrLn h "#include <stdio.h>"+ hPutStrLn h $ "int main(int argc, char *argv[]) " +++ "{ printf(\"%u\\n\", sizeof(_Bool)); return 0; }"+ gcccode <- system $ cCompiler ++ " -o c2hs__bool_size c2hs__bool_size.c"+ when (gcccode /= ExitSuccess) $+ error "Failed to compile 'bool' size test program!"+ (code, stdout, _) <- readProcessWithExitCode "./c2hs__bool_size" [] ""+ when (code /= ExitSuccess) $+ error "Failed to run 'bool' size test program!"+ let sz = read stdout :: Int+ removeFile "c2hs__bool_size.c"+ removeFile "c2hs__bool_size"+ return sz++cBoolSize :: Int+cBoolSize = unsafePerformIO $ do+ msz <- readIORef cBoolSizeRef+ case msz of+ Just sz -> return sz+ Nothing -> do+ sz <- findBoolSize+ writeIORef cBoolSizeRef $ Just sz+ return sz++{-# NOINLINE cCompilerRef #-}+cCompilerRef :: IORef (Maybe String)+cCompilerRef = unsafePerformIO $ newIORef Nothing++cCompiler :: String+cCompiler = unsafePerformIO $ do+ mcc <- readIORef cCompilerRef+ case mcc of+ Just cc -> return cc+ Nothing -> do+ (code, stdout, _) <- readProcessWithExitCode "ghc" ["--info"] ""+ when (code /= ExitSuccess) $+ error "Failed to determine C compiler from 'ghc --info'!"+ let vals = read stdout :: [(String, String)]+ case Prelude.lookup "C compiler command" vals of+ Nothing -> error "Failed to determine C compiler from 'ghc --info'!"+ Just cc -> do+ writeIORef cCompilerRef $ Just cc+ return cc
src/C2HS/Gen/Monad.hs view
@@ -237,9 +237,18 @@ , wrapOrigFn ::String , wrapDecl :: CDecl , wrapArgs :: [Bool]+ , wrapBools :: (Bool, [Bool]) , wrapPos :: Position } deriving Show +instance Eq Wrapper where+ w1 == w2 = wrapFn w1 == wrapFn w2++instance Ord Wrapper where+ compare w1 w2 = compare (wrapFn w1) (wrapFn w2)++type WrapperSet = Set Wrapper+ {- FIXME: What a mess... instance Show HsObject where show (Pointer ptrType isNewtype) =@@ -301,7 +310,7 @@ enums :: EnumSet, -- enumeration hooks tdmap :: TypedefMap, -- typedefs dmmap :: DefaultMarshMap, -- user-defined default marshallers- wrappers :: [Wrapper]+ wrappers :: WrapperSet } type GB a = CT GBState a@@ -318,7 +327,7 @@ enums = Set.empty, tdmap = Map.empty, dmmap = Map.empty,- wrappers = []+ wrappers = Set.empty } -- | set the dynamic library and library prefix@@ -541,13 +550,14 @@ transCT (\state -> (state { dmmap = Map.insert k dm (dmmap state) }, ())) -- | add a wrapper definition-addWrapper :: String -> String -> CDecl -> [Bool] -> Position -> GB ()-addWrapper wfn ofn cdecl args pos =- let w = Wrapper wfn ofn cdecl args pos- in transCT (\st -> (st { wrappers = w : (wrappers st) }, ()))+addWrapper :: String -> String -> CDecl ->+ [Bool] -> (Bool, [Bool]) -> Position -> GB ()+addWrapper wfn ofn cdecl args bools pos =+ let w = Wrapper wfn ofn cdecl args bools pos+ in transCT (\st -> (st { wrappers = Set.insert w (wrappers st) }, ())) getWrappers :: GB [Wrapper]-getWrappers = readCT wrappers+getWrappers = Set.toList `fmap` readCT wrappers -- error messages
src/C2HS/Gen/Wrapper.hs view
@@ -64,46 +64,62 @@ -- | Process a single fragment. -- genWrapper :: Wrapper -> CST s (DList String)-genWrapper (Wrapper wfn ofn (CDecl specs [(Just decl, _, _)] _) args pos) = do+genWrapper (Wrapper wfn ofn (CDecl specs [(Just decl, _, _)] _)+ args (boolres, boolargs) pos) = do let renamed = rename (internalIdent wfn) decl- wrapdecl <- fixArgs ofn pos args renamed- let wrapfn = CFunDef specs wrapdecl [] body undefNode+ wrapdecl <- fixArgs ofn pos args boolargs renamed+ let fspecs = if boolres+ then map replaceBoolSpec specs+ else specs+ wrapfn = CFunDef fspecs wrapdecl [] body undefNode body = CCompound [] [CBlockStmt (CReturn expr undefNode)] undefNode expr = Just $ callBody ofn args decl return $ DL.fromList [render (pretty wrapfn) ++ "\n"]-genWrapper (Wrapper _ ofn _ _ pos) =+genWrapper (Wrapper _ ofn _ _ _ pos) = internalWrapperErr pos ["genWrapper:" ++ ofn] rename :: Ident -> CDeclr -> CDeclr rename ide (CDeclr _ dds str attrs n) = CDeclr (Just ide) dds str attrs n -fixArgs :: String -> Position -> [Bool] -> CDeclr -> CST s CDeclr-fixArgs ofn pos args (CDeclr ide fd str attrs n) = do+fixArgs :: String -> Position -> [Bool] -> [Bool] -> CDeclr+ -> CST s CDeclr+fixArgs ofn pos args bools (CDeclr ide fd str attrs n) = do fd' <- case fd of [] -> return [] f:fs -> do- f' <- fixFunArgs ofn pos args f+ f' <- fixFunArgs ofn pos args bools f return $ f' : fs return $ CDeclr ide fd' str attrs n -fixFunArgs :: String -> Position -> [Bool] -> CDerivedDeclr+fixFunArgs :: String -> Position -> [Bool] -> [Bool] -> CDerivedDeclr -> CST s CDerivedDeclr-fixFunArgs ofn pos args (CFunDeclr (Right (adecls, flg)) attrs n) = do- adecls' <- zipWithM (fixDecl ofn pos) args adecls+fixFunArgs ofn pos args bools+ (CFunDeclr (Right (adecls, flg)) attrs n) = do+ adecls' <- zipWithM (fixDecl ofn pos) (zip args bools) adecls return $ CFunDeclr (Right (adecls', flg)) attrs n-fixFunArgs ofn pos args cdecl =+fixFunArgs ofn pos args bools cdecl = internalWrapperErr pos ["fixFunArgs:" ++ ofn, "args=" ++ show args,+ "bools=" ++ show bools, "cdecl=" ++ show cdecl] -fixDecl :: String -> Position -> Bool -> CDecl -> CST s CDecl-fixDecl _ _ False d = return d-fixDecl _ pos True (CDecl specs [(Just decl, Nothing, Nothing)] n) = do+replaceBool :: CDecl -> CDecl+replaceBool (CDecl spec ds n) = CDecl (map replaceBoolSpec spec) ds n++replaceBoolSpec :: CDeclSpec -> CDeclSpec+replaceBoolSpec (CTypeSpec (CBoolType tn)) = CTypeSpec (CIntType tn)+replaceBoolSpec t = t++fixDecl :: String -> Position -> (Bool, Bool) -> CDecl -> CST s CDecl+fixDecl _ _ (False, True) d = return $ replaceBool d+fixDecl _ _ (False, False) d = return d+fixDecl _ pos (True, _) (CDecl specs [(Just decl, Nothing, Nothing)] n) = do decl' <- addPtr pos decl return $ CDecl specs [(Just decl', Nothing, Nothing)] n-fixDecl ofn pos arg cdecl =+fixDecl ofn pos (arg, bool) cdecl = internalWrapperErr pos ["fixDecl:ofn=" ++ ofn, "arg=" ++ show arg,+ "bool=" ++ show bool, "cdecl=" ++ show cdecl] addPtr :: Position -> CDeclr -> CST s CDeclr
+ tests/bugs/issue-128/Issue128.chs view
@@ -0,0 +1,42 @@+module Main where++import Control.Monad+import Foreign.Ptr+import Foreign.ForeignPtr+import Foreign.C.Types+import Foreign.Storable+import Foreign.Marshal.Utils++#include "issue128.h"++{#fun f1 as ^ {`Int', `Bool'} -> `Int'#}+{#fun f2 as ^ {`Int'} -> `Bool'#}++{#pointer *tststruct as TstStruct foreign finalizer free_tststruct newtype#}+{#fun make_tststruct as makeTstStruct {`Int'} -> `TstStruct'#}+{#fun mod_tststruct as modTstStruct {`TstStruct', `Int', `Bool'} -> `()'#}++main :: IO ()+main = do+ f1 4 True >>= print+ f1 4 False >>= print+ f2 4 >>= print+ f2 0 >>= print+ s <- makeTstStruct 10+ withTstStruct s $ \sp -> do+ {#get tststruct->a#} sp >>= print+ {#get tststruct->b#} sp >>= print+ modTstStruct s 2 True+ withTstStruct s $ \sp -> do+ {#get tststruct->a#} sp >>= print+ {#get tststruct->b#} sp >>= print+ modTstStruct s 5 False+ withTstStruct s $ \sp -> do+ {#get tststruct->a#} sp >>= print+ {#get tststruct->b#} sp >>= print+ withTstStruct s $ \sp -> do+ {#set tststruct->a#} sp 8+ {#set tststruct->b#} sp True+ withTstStruct s $ \sp -> do+ {#get tststruct->a#} sp >>= print+ {#get tststruct->b#} sp >>= print
+ tests/bugs/issue-128/issue128.c view
@@ -0,0 +1,37 @@+#include <stdlib.h>+#include "issue128.h"++int f1(int n, bool incr)+{+ if (incr)+ return n + 1;+ else+ return n - 1;+}++bool f2(int n)+{+ return n > 0;+}+++tststruct *make_tststruct(int ain)+{+ tststruct *p = (tststruct *)malloc(sizeof(tststruct));+ p->a = ain;+ p->b = false;+}++void free_tststruct(tststruct *s)+{+ free(s);+}++void mod_tststruct(tststruct *s, int da, bool incr)+{+ if (incr)+ s->a += da;+ else+ s->a -= da;+ s->b = incr;+}
+ tests/bugs/issue-128/issue128.h view
@@ -0,0 +1,13 @@+#include <stdbool.h>++int f1(int n, bool incr);+bool f2(int n);++typedef struct {+ int a;+ bool b;+} tststruct;++tststruct *make_tststruct(int ain);+void free_tststruct(tststruct *s);+void mod_tststruct(tststruct *s, int da, bool incr);
+ tests/bugs/issue-128/tst.c view
@@ -0,0 +1,2 @@+#include <stdio.h>+int main(int argc, char *argv[]) { printf("%u\n", sizeof(_Bool)); }
tests/test-bugs.hs view
@@ -79,6 +79,7 @@ , testCase "Issue #117" issue117 , testCase "Issue #123" issue123 , testCase "Issue #127" issue127+ , testCase "Issue #128" issue128 ] ++ -- Some tests that won't work on Windows. if os /= "cygwin32" && os /= "mingw32"@@ -97,6 +98,23 @@ cmd "ghc" "--make" "-cpp" "Capital_c.o" "Capital.hs" res <- absPath "./Capital" >>= cmd let expected = ["upper C();", "lower c();", "upper C();"]+ liftIO $ assertBool "" (T.lines res == expected)++issue128 :: Assertion+issue128 = c2hsShelly $ chdir "tests/bugs/issue-128" $ do+ mapM_ rm_f ["Issue128.hs", "Issue128.chs.h", "Issue128.chs.c", "Issue128.chi",+ "issue128_c.o", "Issue128.chs.o", "Issue128"]+ cmd "c2hs" "Issue128.chs"+ cmd cc "-c" "-o" "issue128_c.o" "issue128.c"+ cmd cc "-c" "Issue128.chs.c"+ cmd "ghc" "--make" "issue128_c.o" "Issue128.chs.o" "Issue128.hs"+ res <- absPath "./Issue128" >>= cmd+ let expected = ["5", "3",+ "True", "False",+ "10", "False",+ "12", "True",+ "7", "False",+ "8", "True"] liftIO $ assertBool "" (T.lines res == expected) issue127 :: Assertion