c2hs 0.21.1 → 0.22.1
raw patch · 15 files changed
+295/−76 lines, 15 files
Files
- ChangeLog +6/−0
- c2hs.cabal +5/−1
- src/C2HS/CHS.hs +66/−26
- src/C2HS/CHS/Lexer.hs +6/−0
- src/C2HS/Gen/Bind.hs +119/−43
- src/C2HS/Version.hs +1/−1
- tests/bugs/issue-102/Issue102.chs +15/−0
- tests/bugs/issue-82/Issue82.chs +6/−0
- tests/bugs/issue-9/Issue9.chs +11/−0
- tests/bugs/issue-9/issue9.c +0/−0
- tests/bugs/issue-9/issue9.h +19/−0
- tests/bugs/issue-98/Issue98.chs +13/−0
- tests/bugs/issue-98/issue98.c +4/−0
- tests/bugs/issue-98/issue98.h +3/−0
- tests/test-bugs.hs +21/−5
ChangeLog view
@@ -1,3 +1,9 @@+0.22.1+ - First (not very good) implementation of support for variadic+ functions [#102]+ - Default marshallers for Char types [#98]+ - Improve sizeof computations [#9, #10]+ 0.21.1 - Parametrized pointer types in pointer hooks [#36] - Special "+" parameters for efficient foreign pointer marshalling [#46]
c2hs.cabal view
@@ -1,5 +1,5 @@ Name: c2hs-Version: 0.21.1+Version: 0.22.1 License: GPL-2 License-File: COPYING Copyright: Copyright (c) 1999-2007 Manuel M T Chakravarty@@ -41,6 +41,7 @@ tests/bugs/call_capital/*.h tests/bugs/call_capital/*.c tests/bugs/issue-7/*.chs tests/bugs/issue-7/*.h+ tests/bugs/issue-9/*.chs tests/bugs/issue-9/*.h tests/bugs/issue-9/*.c tests/bugs/issue-10/*.chs tests/bugs/issue-10/*.h tests/bugs/issue-10/*.c tests/bugs/issue-16/*.chs tests/bugs/issue-16/*.h tests/bugs/issue-16/*.c tests/bugs/issue-19/*.chs tests/bugs/issue-19/*.h tests/bugs/issue-19/*.c@@ -69,11 +70,14 @@ tests/bugs/issue-75/*.chs tests/bugs/issue-75/*.h tests/bugs/issue-75/*.c tests/bugs/issue-79/*.chs tests/bugs/issue-79/*.h tests/bugs/issue-79/*.c tests/bugs/issue-80/*.chs tests/bugs/issue-80/*.h tests/bugs/issue-80/*.c+ tests/bugs/issue-82/*.chs tests/bugs/issue-83/*.chs tests/bugs/issue-93/*.chs tests/bugs/issue-93/*.h tests/bugs/issue-93/*.c tests/bugs/issue-95/*.chs tests/bugs/issue-95/*.h tests/bugs/issue-95/*.c tests/bugs/issue-96/*.chs tests/bugs/issue-96/*.h tests/bugs/issue-96/*.c tests/bugs/issue-97/*.chs tests/bugs/issue-97/*.h tests/bugs/issue-97/*.c+ tests/bugs/issue-98/*.chs tests/bugs/issue-98/*.h tests/bugs/issue-98/*.c+ tests/bugs/issue-102/*.chs tests/bugs/issue-103/*.chs tests/bugs/issue-103/*.h tests/bugs/issue-103/*.c tests/bugs/issue-107/*.chs tests/bugs/issue-113/*.chs tests/bugs/issue-113/*.h tests/bugs/issue-113/*.c
src/C2HS/CHS.hs view
@@ -222,6 +222,8 @@ Position | CHSFun Bool -- is a pure function? Bool -- is unsafe?+ Bool -- is variadic?+ [[String]] -- variadic C parameter types CHSAPath -- C function (Maybe Ident) -- Haskell name (Maybe String) -- type context@@ -250,20 +252,20 @@ 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 (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 -- | two hooks are equal if they have the same Haskell name and reference the -- same C object@@ -285,8 +287,8 @@ ide1 == ide2 (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 _) =@@ -563,11 +565,12 @@ . (if isPure then showString "pure " else id) . (if isUns then showString "unsafe " else id) . showApAlias ide oalias-showCHSHook (CHSFun isPure isUns ide oalias octxt parms parm _) =+showCHSHook (CHSFun isPure isUns isVar varTypes ide oalias octxt parms parm _) = showString "fun " . (if isPure then showString "pure " else id) . (if isUns then showString "unsafe " else id)- . showApAlias ide oalias+ . (if isVar then showString "variadic " else id)+ . showFunAlias ide varTypes oalias . (case octxt of Nothing -> showChar ' ' Just ctxtStr -> showString ctxtStr . showString " => ")@@ -643,6 +646,21 @@ Nothing -> id Just ide -> showString " as " . showCHSIdent ide) +showFunAlias :: CHSAPath -> [[String]] -> Maybe Ident -> ShowS+showFunAlias apath vas oalias =+ showCHSAPath apath+ . (if null vas+ then showString ""+ else showString "("+ . foldr (.) id (intersperse (showString ", ") (map showDecl vas))+ . showString ")")+ . (case oalias of+ Nothing -> id+ Just ide -> showString " as " . showCHSIdent ide)++showDecl :: [String] -> ShowS+showDecl is = foldr (.) id (intersperse (showString " ") (map showString is))+ showCHSParm :: CHSParm -> ShowS showCHSParm CHSPlusParm = showChar '+' showCHSParm (CHSParm oimMarsh hsTyStr twoCVals oomMarsh _ comment) =@@ -1073,16 +1091,19 @@ do (isPure , toks' ) <- parseIsPure toks (isUnsafe, toks'2) <- parseIsUnsafe toks'- (apath , toks'3) <- parsePath toks'2- (oalias , toks'4) <- parseOptAs (apathToIdent apath) False toks'3- (octxt , toks'5) <- parseOptContext toks'4- (parms , toks'6) <- parseParms toks'5- (parm , toks'7) <- parseParm toks'6- toks'8 <- parseEndHook toks'7- frags <- parseFrags toks'8+ (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+ toks'10 <- parseEndHook toks'9+ frags <- parseFrags toks'10 return $ CHSHook- (CHSFun isPure isUnsafe apath oalias octxt parms parm pos) hkpos :+ (CHSFun isPure isUnsafe isVar varTypes+ apath oalias octxt parms parm pos) hkpos : frags where toks = removeIllPositionedComment inputToks@@ -1091,6 +1112,21 @@ parseOptContext toks' = return (Nothing , toks') --+ parseVarTypes (CHSTokLParen _:CHSTokIdent _ i:toks') = do+ (is, toks'2) <- parseVarTypes'' toks'+ (ts, toks'3) <- parseVarTypes' toks'2+ return ((identToString i:is):ts, toks'3)+ parseVarTypes toks' = return ([], toks')+ parseVarTypes' (CHSTokRParen _:toks') = return ([], toks')+ parseVarTypes' (CHSTokComma _:CHSTokIdent _ i:toks') = do+ (is, toks'2) <- parseVarTypes'' toks'+ (ts, toks'3) <- parseVarTypes' toks'2+ return ((identToString i:is):ts, toks'3)+ parseVarTypes'' (CHSTokIdent _ i:toks') = do+ (is, toks'2) <- parseVarTypes'' toks'+ return (identToString i:is, toks'2)+ parseVarTypes'' toks' = return ([], toks')+ -- parseParms (CHSTokLBrace _:CHSTokRBrace _:CHSTokArrow _:toks') = return ([], toks') parseParms (CHSTokLBrace _ :toks') =@@ -1138,6 +1174,10 @@ parseIsUnsafe :: [CHSToken] -> CST s (Bool, [CHSToken]) parseIsUnsafe (CHSTokUnsafe _:toks) = return (True , toks) parseIsUnsafe toks = return (False, toks)++parseIsVariadic :: [CHSToken] -> CST s (Bool, [CHSToken])+parseIsVariadic (CHSTokVariadic _:toks) = return (True , toks)+parseIsVariadic toks = return (False, toks) apathToIdent :: CHSAPath -> Ident apathToIdent (CHSRoot _ ide) =
src/C2HS/CHS/Lexer.hs view
@@ -241,6 +241,7 @@ | CHSTok_2Case Position -- `underscoreToCase' | CHSTokUnsafe Position -- `unsafe' | CHSTokUpper Position -- `upcaseFirstLetter'+ | CHSTokVariadic Position -- `variadic' | CHSTokWith Position Ident -- `with' | CHSTokString Position String -- string | CHSTokHSVerb Position String -- verbatim Haskell (`...')@@ -303,6 +304,7 @@ posOf (CHSTok_2Case pos ) = pos posOf (CHSTokUnsafe pos ) = pos posOf (CHSTokUpper pos ) = pos+ posOf (CHSTokVariadic pos ) = pos posOf (CHSTokWith pos _) = pos posOf (CHSTokString pos _) = pos posOf (CHSTokHSVerb pos _) = pos@@ -365,6 +367,7 @@ (CHSTok_2Case _ ) == (CHSTok_2Case _ ) = True (CHSTokUnsafe _ ) == (CHSTokUnsafe _ ) = True (CHSTokUpper _ ) == (CHSTokUpper _ ) = True+ (CHSTokVariadic _ ) == (CHSTokVariadic _ ) = True (CHSTokWith _ _) == (CHSTokWith _ _) = True (CHSTokString _ _) == (CHSTokString _ _) = True (CHSTokHSVerb _ _) == (CHSTokHSVerb _ _) = True@@ -429,6 +432,7 @@ showsPrec _ (CHSTok_2Case _ ) = showString "underscoreToCase" showsPrec _ (CHSTokUnsafe _ ) = showString "unsafe" showsPrec _ (CHSTokUpper _ ) = showString "upcaseFirstLetter"+ showsPrec _ (CHSTokVariadic _ ) = showString "variadic" showsPrec _ (CHSTokWith _ _) = showString "with" showsPrec _ (CHSTokString _ s) = showString ("\"" ++ s ++ "\"") showsPrec _ (CHSTokHSVerb _ s) = showString ("`" ++ s ++ "'")@@ -779,6 +783,7 @@ idkwtok pos "underscoreToCase" _ = CHSTok_2Case pos idkwtok pos "unsafe" _ = CHSTokUnsafe pos idkwtok pos "upcaseFirstLetter"_ = CHSTokUpper pos+ idkwtok pos "variadic" _ = CHSTokVariadic pos idkwtok pos "with" name = mkwith pos name idkwtok pos cs name = mkid pos cs name --@@ -821,6 +826,7 @@ CHSTok_2Case pos -> mkid pos "underscoreToCase" CHSTokUnsafe pos -> mkid pos "unsafe" CHSTokUpper pos -> mkid pos "upcaseFirstLetter"+ CHSTokVariadic pos -> mkid pos "variadic" CHSTokWith pos ide -> CHSTokIdent pos ide _ -> tok where mkid pos str = CHSTokIdent pos (internalIdent str)
src/C2HS/Gen/Bind.hs view
@@ -111,7 +111,7 @@ import Data.Char (toLower) import Data.Function (on) import Data.List (deleteBy, groupBy, sortBy, intersperse, find, nubBy, intercalate)-import Data.Map (lookup)+import Data.Map (Map, lookup, fromList) import Data.Maybe (isNothing, isJust, fromJust, fromMaybe) import Data.Bits ((.|.), (.&.)) import Control.Arrow (second)@@ -169,6 +169,12 @@ lookupDftMarshIn hsTy [PrimET pt] | isFloatHsType hsTy &&isFloatCPrimType pt = return $ Just (Left cFloatConvIde, CHSValArg)+lookupDftMarshIn "Char" [PrimET CCharPT] =+ return $ Just (Left castCharToCCharIde, CHSValArg)+lookupDftMarshIn "Char" [PrimET CUCharPT] =+ return $ Just (Left castCharToCUCharIde, CHSValArg)+lookupDftMarshIn "Char" [PrimET CSCharPT] =+ return $ Just (Left castCharToCSCharIde, CHSValArg) lookupDftMarshIn "String" [PtrET (PrimET CCharPT)] = return $ Just (Left withCStringIde, CHSIOArg) lookupDftMarshIn "CString" [PtrET (PrimET CCharPT)] =@@ -219,6 +225,12 @@ lookupDftMarshOut hsTy [PrimET pt] | isFloatHsType hsTy &&isFloatCPrimType pt = return $ Just (Left cFloatConvIde, CHSValArg)+lookupDftMarshOut "Char" [PrimET CCharPT] =+ return $ Just (Left castCCharToCharIde, CHSValArg)+lookupDftMarshOut "Char" [PrimET CUCharPT] =+ return $ Just (Left castCUCharToCharIde, CHSValArg)+lookupDftMarshOut "Char" [PrimET CSCharPT] =+ return $ Just (Left castCSCharToCharIde, CHSValArg) lookupDftMarshOut "String" [PtrET (PrimET CCharPT)] = return $ Just (Left peekCStringIde, CHSIOArg) lookupDftMarshOut "CString" [PtrET (PrimET CCharPT)] =@@ -320,19 +332,27 @@ -- voidIde, cFromBoolIde, cToBoolIde, cIntConvIde, cFloatConvIde, withCStringIde, peekIde, peekCStringIde, idIde,- newForeignPtr_Ide, withForeignPtrIde, returnIde :: Ident-voidIde = internalIdent "void" -- never appears in the output-cFromBoolIde = internalIdent "fromBool"-cToBoolIde = internalIdent "toBool"-cIntConvIde = internalIdent "fromIntegral"-cFloatConvIde = internalIdent "realToFrac"-withCStringIde = internalIdent "withCString"-peekIde = internalIdent "peek"-peekCStringIde = internalIdent "peekCString"-idIde = internalIdent "id"-newForeignPtr_Ide = internalIdent "newForeignPtr_"-withForeignPtrIde = internalIdent "withForeignPtr"-returnIde = internalIdent "return"+ newForeignPtr_Ide, withForeignPtrIde, returnIde,+ castCharToCCharIde, castCharToCUCharIde, castCharToCSCharIde,+ castCCharToCharIde, castCUCharToCharIde, castCSCharToCharIde :: Ident+voidIde = internalIdent "void" -- never appears in the output+cFromBoolIde = internalIdent "fromBool"+cToBoolIde = internalIdent "toBool"+cIntConvIde = internalIdent "fromIntegral"+cFloatConvIde = internalIdent "realToFrac"+withCStringIde = internalIdent "withCString"+peekIde = internalIdent "peek"+peekCStringIde = internalIdent "peekCString"+idIde = internalIdent "id"+newForeignPtr_Ide = internalIdent "newForeignPtr_"+withForeignPtrIde = internalIdent "withForeignPtr"+returnIde = internalIdent "return"+castCharToCCharIde = internalIdent "castCharToCChar"+castCharToCUCharIde = internalIdent "castCharToCUChar"+castCharToCSCharIde = internalIdent "castCharToCSChar"+castCCharToCharIde = internalIdent "castCCharToChar"+castCUCharToCharIde = internalIdent "castCUCharToChar"+castCSCharToCharIde = internalIdent "castCSCharToChar" -- expansion of binding hooks@@ -513,7 +533,7 @@ let ideLexeme = identToString ide' -- orignl name might have been a shadow hsLexeme = ideLexeme `maybe` identToString $ oalias cdecl' = ide' `simplifyDecl` cdecl- callImport hook isPure isUns ideLexeme hsLexeme cdecl' pos+ callImport hook isPure isUns [] ideLexeme hsLexeme cdecl' pos return hsLexeme where traceEnter = traceGenBind $@@ -549,7 +569,7 @@ "** Indirect call hook for `" ++ identToString (apathToIdent apath) ++ "':\n" traceValueType et = traceGenBind $ "Type of accessed value: " ++ showExtType et ++ "\n"-expandHook (CHSFun isPure isUns (CHSRoot _ ide)+expandHook (CHSFun isPure isUns isVar inVarTypes (CHSRoot _ ide) oalias ctxt parms parm pos) hkpos = do traceEnter@@ -565,14 +585,18 @@ fiIde = internalIdent fiLexeme cdecl' = cide `simplifyDecl` cdecl callHook = CHSCall isPure isUns (CHSRoot False cide) (Just fiIde) pos- callImport callHook isPure isUns (identToString cide) fiLexeme cdecl' pos+ varTypes <- mapM (convertVarType pos) inVarTypes+ callImport callHook isPure isUns varTypes (identToString cide)+ fiLexeme cdecl' pos extTy <- extractFunType pos cdecl' True- funDef isPure hsLexeme fiLexeme extTy ctxt parms parm Nothing pos hkpos+ funDef isPure 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 isUns isVar varTypes+ apath oalias ctxt parms parm pos) hkpos = do traceEnter @@ -599,7 +623,7 @@ callImportDyn callHook isPure isUns ideLexeme fiLexeme decl ty pos set_get <- setGet pos CHSGet offsets False ptrTy Nothing- funDef isPure hsLexeme fiLexeme (FunET ptrTy $ purify ty)+ funDef isPure 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@@ -923,18 +947,17 @@ -- * the C declaration is a simplified declaration of the function that we -- want to import into Haskell land ---callImport :: CHSHook -> Bool -> Bool -> String -> String -> CDecl -> Position- -> GB ()-callImport hook isPure isUns ideLexeme hsLexeme cdecl pos =+callImport :: CHSHook -> Bool -> Bool -> [ExtType] -> String ->+ String -> CDecl -> Position -> GB ()+callImport hook isPure isUns varTypes ideLexeme hsLexeme cdecl pos = do -- compute the external type from the declaration, and delay the foreign -- export declaration -- extType <- extractFunType pos cdecl isPure header <- getSwitch headerSB- when (isVariadic extType) (variadicErr pos (posOf cdecl)) delayCode hook (foreignImport (extractCallingConvention cdecl)- header ideLexeme hsLexeme isUns extType)+ header ideLexeme hsLexeme isUns extType varTypes) traceFunType extType where traceFunType et = traceGenBind $@@ -957,11 +980,12 @@ -- | Haskell code for the foreign import declaration needed by a call hook ---foreignImport :: CallingConvention -> String -> String -> String -> Bool -> ExtType -> String-foreignImport cconv header ident hsIdent isUnsafe ty =+foreignImport :: CallingConvention -> String -> String -> String -> Bool ->+ ExtType -> [ExtType] -> String+foreignImport cconv header ident hsIdent isUnsafe ty vas = "foreign import " ++ showCallingConvention cconv ++ " " ++ safety ++ " " ++ show entity ++- "\n " ++ hsIdent ++ " :: " ++ showExtType ty ++ "\n"+ "\n " ++ hsIdent ++ " :: " ++ showExtFunType ty vas ++ "\n" where safety = if isUnsafe then "unsafe" else "safe" entity | null header = ident@@ -991,6 +1015,7 @@ -> String -- name of the new Haskell function -> String -- Haskell name of the foreign imported C function -> ExtType -- simplified declaration of the C function+ -> [ExtType] -- simplified declaration of the C function -> Maybe String -- type context of the new Haskell function -> [CHSParm] -- parameter marshalling description -> CHSParm -- result marshalling description@@ -998,11 +1023,11 @@ -> 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 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- (parms', parm', isImpure) <- addDftMarshaller pos parms parm extTy+ (parms', parm', isImpure) <- addDftMarshaller pos parms parm extTy varExtTys traceMarsh parms' parm' isImpure marshs <- zipWithM marshArg [1..] parms'@@ -1171,10 +1196,10 @@ -- | add default marshallers for "in" and "out" marshalling ---addDftMarshaller :: Position -> [CHSParm] -> CHSParm -> ExtType+addDftMarshaller :: Position -> [CHSParm] -> CHSParm -> ExtType -> [ExtType] -> GB ([CHSParm], CHSParm, Bool)-addDftMarshaller pos parms parm extTy = do- let (resTy, argTys) = splitFunTy extTy+addDftMarshaller pos parms parm extTy varExTys = do+ let (resTy, argTys) = splitFunTy extTy varExTys (parm' , isImpure1) <- checkResMarsh parm resTy (parms', isImpure2) <- addDft parms argTys return (parms', parm', isImpure1 || isImpure2)@@ -1193,12 +1218,12 @@ (omMarsh', isImpure) <- addDftOut pos' omMarsh ty [cTy] return (CHSParm imMarsh' ty False omMarsh' pos' c, isImpure) --- splitFunTy (FunET UnitET ty ) = splitFunTy ty- splitFunTy (FunET ty1 ty2) = let- (resTy, argTys) = splitFunTy ty2- in- (resTy, ty1:argTys)- splitFunTy resTy = (resTy, [])+ splitFunTy (FunET UnitET ty) vts = splitFunTy ty vts+ splitFunTy (FunET ty1 ty2) vts = let (resTy, argTys) = splitFunTy ty2 vts+ in (resTy, ty1:argTys)+ splitFunTy (VarFunET ty2) vts = let (resTy, argTys) = splitFunTy ty2 []+ in (resTy, argTys ++ vts)+ splitFunTy resTy _ = (resTy, []) -- -- match Haskell with C arguments (and results) --@@ -1673,6 +1698,16 @@ showExtType (PrimET (CUFieldPT bs)) = "CUInt{-:" ++ show bs ++ "-}" showExtType UnitET = "()" +showExtFunType :: ExtType -> [ExtType] -> String+showExtFunType (FunET UnitET res) _ = showExtType res+showExtFunType (FunET arg res) vas =+ "(" ++ showExtType arg ++ " -> " ++ showExtFunType res vas ++ ")"+showExtFunType (VarFunET res) [] = showExtFunType res []+showExtFunType t@(VarFunET res) (va:vas) =+ "(" ++ showExtType va ++ " -> " ++ showExtFunType t vas ++ ")"+showExtFunType (IOET t) vas = "(IO " ++ showExtFunType t vas ++ ")"+showExtFunType t _ = showExtType t+ -- | compute the type of the C function declared by the given C object -- -- * the identifier specifies in which of the declarators we are interested@@ -1889,6 +1924,29 @@ unsigned = CUnsigType undefined enum = CEnumType undefined undefined +typeNameMap :: Map String CTypeSpec+typeNameMap = fromList [ ("void", CVoidType undefined)+ , ("char", CCharType undefined)+ , ("short", CShortType undefined)+ , ("int", CIntType undefined)+ , ("long", CLongType undefined)+ , ("float", CFloatType undefined)+ , ("double", CDoubleType undefined)+ , ("signed", CSignedType undefined)+ , ("unsigned", CUnsigType undefined)+ , ("enum", CEnumType undefined undefined) ]++convertVarType :: Position -> [String] -> GB ExtType+convertVarType pos ts = do+ let mtns = map (flip lookup typeNameMap) ts+ case any isNothing mtns of+ True -> variadicTypeErr pos+ False -> do+ st <- specType pos (map (CTypeSpec . fromJust) mtns) Nothing+ case st of+ ExtType et -> return et+ _ -> variadicTypeErr pos+ -- | compute the complex (external) type determined by a list of type specifiers -- -- * may not be called for a specifier that defines a typedef alias@@ -2093,9 +2151,9 @@ sizeAlignOfStructPad :: [CDecl] -> CStructTag -> GB (BitSize, Int) sizeAlignOfStructPad decls tag = do- PlatformSpec {bitfieldAlignmentPS = bitfieldAlignment} <- getPlatform (size, align) <- sizeAlignOfStruct decls tag- return (alignOffset size align bitfieldAlignment, align)+ let b = CInfo.size CIntPT+ return (alignOffset size b b, align) -- | compute the size and alignment constraint of a given C declaration --@@ -2121,8 +2179,20 @@ return (fromIntegral len `scaleBitSize` bitsize, align) sizeAlignOf (CDecl _ [(Just (CDeclr _ (CArrDeclr _ (CNoArrSize _) _ : _) _ _ _), _init, _expr)] _) = interr "GenBind.sizeAlignOf: array of undeclared size."-sizeAlignOf cdecl =- sizeAlignOfSingle cdecl+sizeAlignOf cdecl = do+ traceAliasCheck+ case checkForOneAliasName cdecl of+ Nothing -> sizeAlignOfSingle cdecl+ Just ide -> do -- this is a typedef alias+ traceAlias ide+ cdecl' <- getDeclOf ide+ let CDecl specs [(declr, init', _)] at = ide `simplifyDecl` cdecl'+ sdecl = CDecl specs [(declr, init', Nothing)] at+ sizeAlignOf sdecl+ where+ traceAliasCheck = traceGenBind $ "extractCompType: checking for alias\n"+ traceAlias ide = traceGenBind $+ "extractCompType: found an alias called `" ++ identToString ide ++ "'\n" sizeAlignOfSingle cdecl =@@ -2445,6 +2515,12 @@ ["Variadic function!", "Calling variadic functions is not supported by the FFI; the function", "is defined at " ++ show cpos ++ "."]++variadicTypeErr :: Position -> GB a+variadicTypeErr pos =+ raiseErrorCTExc pos+ ["Variadic function argument type!",+ "Calling variadic functions is only supported for simple C types"] illegalPlusErr :: Position -> GB a illegalPlusErr pos =
src/C2HS/Version.hs view
@@ -9,7 +9,7 @@ name = "C->Haskell Compiler" versnum = Paths_c2hs.version-versnick = "Snowbound"+versnick = "Snowbounder" date = "31 Oct 2014" version = name ++ ", version " ++ showVersion versnum ++ " " ++ versnick ++ ", " ++ date copyright = "Copyright (c) 1999-2007 Manuel M T Chakravarty\n"
+ tests/bugs/issue-102/Issue102.chs view
@@ -0,0 +1,15 @@+module Main where++import Foreign.Ptr+import Foreign.C.Types+import Foreign.C.String++#include <stdio.h>++{#fun variadic printf(int) as printi {`String', `Int'} -> `()'#}+{#fun variadic printf(int, int) as printi2 {`String', `Int', `Int'} -> `()'#}++main :: IO ()+main = do+ printi "TST 1: %d\n" 1234+ printi2 "TST 2: %d %d\n" 13 47
+ tests/bugs/issue-82/Issue82.chs view
@@ -0,0 +1,6 @@+module Main where++#include "string.h"++main :: IO ()+main = putStrLn "OK"
+ tests/bugs/issue-9/Issue9.chs view
@@ -0,0 +1,11 @@+module Main where++#include "issue9.h"++main :: IO ()+main = do+ putStrLn $ "PTA:" ++ show ({# sizeof pointer_to_array #} :: Int)+ putStrLn $ "AOP:" ++ show ({# sizeof array_of_pointers #} :: Int)+ print (({# sizeof inner_t #}, {# sizeof outer_t #}) :: (Int, Int))+ print ({# sizeof ok_outer_t #} :: Int)+ putStrLn "OK"
+ tests/bugs/issue-9/issue9.c view
+ tests/bugs/issue-9/issue9.h view
@@ -0,0 +1,19 @@+struct pointer_to_array {+ int (*y)[4];+} PTA;++struct array_of_pointers {+ int *y[4];+} AOP;++typedef char inner_t[32];++typedef struct {+ inner_t first;+ inner_t second;+} outer_t;++typedef struct {+ char first[32];+ char second[32];+} ok_outer_t;
+ tests/bugs/issue-98/Issue98.chs view
@@ -0,0 +1,13 @@+module Main where++import Foreign.C.Types+import Foreign.C.String++#include "issue98.h"++{#fun pure identichar as ^ { `Char' } -> `Char' #}+{#fun pure identiuchar as ^ { `Char' } -> `Char' #}+{#fun pure identischar as ^ { `Char' } -> `Char' #}++main :: IO ()+main = print $ map ($ 'A') [identichar, identiuchar, identischar]
+ tests/bugs/issue-98/issue98.c view
@@ -0,0 +1,4 @@+#include "issue98.h"+char identichar(char c) { return c; }+unsigned char identiuchar(unsigned char c) { return c; }+signed char identischar(signed char c) { return c; }
+ tests/bugs/issue-98/issue98.h view
@@ -0,0 +1,3 @@+char identichar(char c);+unsigned char identiuchar(unsigned char c);+signed char identischar(signed char c);
tests/test-bugs.hs view
@@ -29,8 +29,9 @@ tests = [ testGroup "Bugs" [ testCase "call_capital (issue #??)" call_capital- , testCase "Issue #7" issue7--- , testCase "Issue #10" issue10+ , testCase "Issue #7" issue07+ , testCase "Issue #9" issue09+ , testCase "Issue #10" issue10 , testCase "Issue #16" issue16 , testCase "Issue #19" issue19 , testCase "Issue #22" issue22@@ -57,11 +58,14 @@ , testCase "Issue #75" issue75 , testCase "Issue #79" issue79 , testCase "Issue #80" issue80+ , testCase "Issue #82" issue82 , testCase "Issue #83" issue83 , testCase "Issue #93" issue93 , testCase "Issue #95" issue95 , testCase "Issue #96" issue96 , testCase "Issue #97" issue97+ , testCase "Issue #98" issue98+ , testCase "Issue #102" issue102 , testCase "Issue #103" issue103 , testCase "Issue #107" issue107 , testCase "Issue #113" issue113@@ -106,6 +110,12 @@ let expected = ["1", "2", "3"] liftIO $ assertBool "" (T.lines res == expected) +issue102 :: Assertion+issue102 = hs_only_expect_issue 102 ["TST 1: 1234", "TST 2: 13 47"]++issue98 :: Assertion+issue98 = build_issue 98+ issue97 :: Assertion issue97 = c2hsShelly $ chdir "tests/bugs/issue-97" $ do mapM_ rm_f ["Issue97.hs", "Issue97.chs.h", "Issue97.chi",@@ -128,6 +138,9 @@ issue93 :: Assertion issue93 = build_issue 93 +issue82 :: Assertion+issue82 = hs_only_build_issue 82+ issue83 :: Assertion issue83 = hs_only_expect_issue 83 ["(-3,0)", "TEST_VAL", "8415", "8415"] @@ -256,10 +269,13 @@ issue16 = build_issue 16 issue10 :: Assertion-issue10 = expect_issue 10 ["SAME", "SAME", "SAME"]+issue10 = expect_issue 10 ["SAME", "SAME", "SAME", "SAME"] -issue7 :: Assertion-issue7 = c2hsShelly $ do+issue09 :: Assertion+issue09 = expect_issue 9 ["PTA:8", "AOP:32", "(32,64)", "64", "OK"]++issue07 :: Assertion+issue07 = c2hsShelly $ do errExit False $ do cd "tests/bugs/issue-7" mapM_ rm_f ["Issue7.hs", "Issue7.chs.h", "Issue7.chi"]