diff --git a/ChangeLog b/ChangeLog --- a/ChangeLog +++ b/ChangeLog @@ -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] diff --git a/c2hs.cabal b/c2hs.cabal --- a/c2hs.cabal +++ b/c2hs.cabal @@ -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 diff --git a/src/C2HS/CHS.hs b/src/C2HS/CHS.hs --- a/src/C2HS/CHS.hs +++ b/src/C2HS/CHS.hs @@ -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) = diff --git a/src/C2HS/CHS/Lexer.hs b/src/C2HS/CHS/Lexer.hs --- a/src/C2HS/CHS/Lexer.hs +++ b/src/C2HS/CHS/Lexer.hs @@ -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) diff --git a/src/C2HS/Gen/Bind.hs b/src/C2HS/Gen/Bind.hs --- a/src/C2HS/Gen/Bind.hs +++ b/src/C2HS/Gen/Bind.hs @@ -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 = diff --git a/src/C2HS/Version.hs b/src/C2HS/Version.hs --- a/src/C2HS/Version.hs +++ b/src/C2HS/Version.hs @@ -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" diff --git a/tests/bugs/issue-102/Issue102.chs b/tests/bugs/issue-102/Issue102.chs new file mode 100644 --- /dev/null +++ b/tests/bugs/issue-102/Issue102.chs @@ -0,0 +1,15 @@ +module Main where + +import Foreign.Ptr +import Foreign.C.Types +import Foreign.C.String + +#include + +{#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 diff --git a/tests/bugs/issue-82/Issue82.chs b/tests/bugs/issue-82/Issue82.chs new file mode 100644 --- /dev/null +++ b/tests/bugs/issue-82/Issue82.chs @@ -0,0 +1,6 @@ +module Main where + +#include "string.h" + +main :: IO () +main = putStrLn "OK" diff --git a/tests/bugs/issue-9/Issue9.chs b/tests/bugs/issue-9/Issue9.chs new file mode 100644 --- /dev/null +++ b/tests/bugs/issue-9/Issue9.chs @@ -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" diff --git a/tests/bugs/issue-9/issue9.c b/tests/bugs/issue-9/issue9.c new file mode 100644 --- /dev/null +++ b/tests/bugs/issue-9/issue9.c diff --git a/tests/bugs/issue-9/issue9.h b/tests/bugs/issue-9/issue9.h new file mode 100644 --- /dev/null +++ b/tests/bugs/issue-9/issue9.h @@ -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; diff --git a/tests/bugs/issue-98/Issue98.chs b/tests/bugs/issue-98/Issue98.chs new file mode 100644 --- /dev/null +++ b/tests/bugs/issue-98/Issue98.chs @@ -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] diff --git a/tests/bugs/issue-98/issue98.c b/tests/bugs/issue-98/issue98.c new file mode 100644 --- /dev/null +++ b/tests/bugs/issue-98/issue98.c @@ -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; } diff --git a/tests/bugs/issue-98/issue98.h b/tests/bugs/issue-98/issue98.h new file mode 100644 --- /dev/null +++ b/tests/bugs/issue-98/issue98.h @@ -0,0 +1,3 @@ +char identichar(char c); +unsigned char identiuchar(unsigned char c); +signed char identischar(signed char c); diff --git a/tests/test-bugs.hs b/tests/test-bugs.hs --- a/tests/test-bugs.hs +++ b/tests/test-bugs.hs @@ -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"]