diff --git a/ChangeLog b/ChangeLog --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,9 @@ +0.23.1 + - Typedef and default marshalling hooks [#20, #25, #48] + - Test fixes for 32-bit platforms (Jürgen Keck: @j-keck) + - Multi-character constants for OS X [#15] + - Better support for binding to variadic functions [#102] + 0.22.1 - First (not very good) implementation of support for variadic functions [#102] diff --git a/c2hs.cabal b/c2hs.cabal --- a/c2hs.cabal +++ b/c2hs.cabal @@ -1,5 +1,5 @@ Name: c2hs -Version: 0.22.1 +Version: 0.23.1 License: GPL-2 License-File: COPYING Copyright: Copyright (c) 1999-2007 Manuel M T Chakravarty @@ -43,10 +43,13 @@ 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-15/*.chs tests/bugs/issue-15/*.h tests/bugs/issue-15/*.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 + tests/bugs/issue-20/*.chs tests/bugs/issue-20/*.h tests/bugs/issue-20/*.c tests/bugs/issue-22/*.chs tests/bugs/issue-22/*.h tests/bugs/issue-22/*.c tests/bugs/issue-23/*.chs tests/bugs/issue-23/*.h tests/bugs/issue-23/*.c + tests/bugs/issue-25/*.chs tests/bugs/issue-29/*.chs tests/bugs/issue-29/*.h tests/bugs/issue-30/*.chs tests/bugs/issue-30/*.h tests/bugs/issue-30/*.c tests/bugs/issue-31/*.chs tests/bugs/issue-31/*.h tests/bugs/issue-31/*.c @@ -59,6 +62,7 @@ tests/bugs/issue-45/*.chs tests/bugs/issue-45/*.h tests/bugs/issue-45/*.c tests/bugs/issue-46/*.chs tests/bugs/issue-46/*.h tests/bugs/issue-46/*.c tests/bugs/issue-47/*.chs tests/bugs/issue-47/*.h tests/bugs/issue-47/*.c + tests/bugs/issue-48/*.chs tests/bugs/issue-48/*.h tests/bugs/issue-48/*.c tests/bugs/issue-51/*.chs tests/bugs/issue-51/*.h tests/bugs/issue-51/*.c tests/bugs/issue-54/*.chs tests/bugs/issue-54/*.h tests/bugs/issue-54/*.c tests/bugs/issue-60/*.chs tests/bugs/issue-60/*.h tests/bugs/issue-60/*.c diff --git a/src/C2HS/C/Info.hs b/src/C2HS/C/Info.hs --- a/src/C2HS/C/Info.hs +++ b/src/C2HS/C/Info.hs @@ -54,20 +54,14 @@ -- module C2HS.C.Info ( - CPrimType(..), size, alignment, getPlatform + CPrimType(..), size ) where import Foreign (Ptr, FunPtr) -import qualified Foreign.Storable as Storable (Storable(sizeOf, alignment)) +import qualified Foreign.Storable as Storable (Storable(sizeOf)) import Foreign.C -import C2HS.Config (PlatformSpec(..)) -import C2HS.State (getSwitch) -import C2HS.Switches (platformSB) -import C2HS.Gen.Monad (GB) -import Data.Errors - -- calibration of C's primitive types -- ---------------------------------- @@ -94,7 +88,8 @@ | CLDoublePT -- long double | CSFieldPT Int -- signed bit field | CUFieldPT Int -- unsigned bit field - deriving (Eq) + | CAliasedPT String String CPrimType + deriving (Eq, Show) -- | size of primitive type of C -- @@ -123,65 +118,4 @@ #endif size (CSFieldPT bs) = -bs size (CUFieldPT bs) = -bs - --- | alignment of C's primitive types --- --- * more precisely, the padding put before the type's member starts when the --- preceding component is a char --- -alignment :: CPrimType -> GB Int -alignment CPtrPT = return $ Storable.alignment (undefined :: Ptr ()) -alignment CFunPtrPT = return $ Storable.alignment (undefined :: FunPtr ()) -alignment CCharPT = return $ 1 -alignment CUCharPT = return $ 1 -alignment CSCharPT = return $ 1 -alignment CIntPT = return $ Storable.alignment (undefined :: CInt) -alignment CShortPT = return $ Storable.alignment (undefined :: CShort) -alignment CLongPT = return $ Storable.alignment (undefined :: CLong) -alignment CLLongPT = return $ Storable.alignment (undefined :: CLLong) -alignment CUIntPT = return $ Storable.alignment (undefined :: CUInt) -alignment CUShortPT = return $ Storable.alignment (undefined :: CUShort) -alignment CULongPT = return $ Storable.alignment (undefined :: CULong) -alignment CULLongPT = return $ Storable.alignment (undefined :: CULLong) -alignment CFloatPT = return $ Storable.alignment (undefined :: CFloat) -alignment CDoublePT = return $ Storable.alignment (undefined :: CDouble) -#if MIN_VERSION_base(4,2,0) -alignment CLDoublePT = interr "Info.alignment: CLDouble not supported" -#else -alignment CLDoublePT = return $ Storable.alignment (undefined :: CLDouble) -#endif -alignment (CSFieldPT bs) = fieldAlignment bs -alignment (CUFieldPT bs) = fieldAlignment bs - --- | alignment constraint for a C bitfield --- --- * gets the bitfield size (in bits) as an argument --- --- * alignments constraints smaller or equal to zero are reserved for bitfield --- alignments --- --- * bitfields of size 0 always trigger padding; thus, they get the maximal --- size --- --- * if bitfields whose size exceeds the space that is still available in a --- partially filled storage unit trigger padding, the size of a storage unit --- is provided as the alignment constraint; otherwise, it is 0 (meaning it --- definitely starts at the current position) --- --- * here, alignment constraint /= 0 are somewhat subtle; they mean that is --- the given number of bits doesn't fit in what's left in the current --- storage unit, alignment to the start of the next storage unit has to be --- triggered --- -fieldAlignment :: Int -> GB Int -fieldAlignment 0 = return $ - (size CIntPT - 1) -fieldAlignment bs = - do - PlatformSpec {bitfieldPaddingPS = bitfieldPadding} <- getPlatform - return $ if bitfieldPadding then - bs else 0 - --- | obtain platform from switchboard --- -getPlatform :: GB PlatformSpec -getPlatform = getSwitch platformSB - +size (CAliasedPT _ _ pt) = size pt diff --git a/src/C2HS/CHS.hs b/src/C2HS/CHS.hs --- a/src/C2HS/CHS.hs +++ b/src/C2HS/CHS.hs @@ -63,6 +63,7 @@ -- | `pointer' ['*'] idalias ptrkind ['nocode'] -- | `class' [ident `=>'] ident ident -- | `const' ident +-- | `default' ident ident [dft ...] -- ctxt -> [`lib' `=' string] [prefix] -- idalias -> ident -- | looseident [`as' (ident | `^' | `'' ident1 ident2 ... `'')] @@ -82,6 +83,8 @@ -- | `downcaseFirstLetter' -- | ident `as' ident -- ptrkind -> [`foreign' [`finalizer' idalias] | `stable'] ['newtype' | '->' ident] +-- dft -> dfttype `=` ident [`*'] +-- dfttype -> `in' | `out' | `ptr_in' | `ptr_out' -- -- If `underscoreToCase', `upcaseFirstLetter', or `downcaseFirstLetter' -- occurs in a translation table, it must be the first entry, or if two of @@ -97,7 +100,8 @@ module C2HS.CHS (CHSModule(..), CHSFrag(..), CHSHook(..), CHSTrans(..), CHSChangeCase(..), CHSParm(..), CHSMarsh, CHSArg(..), CHSAccess(..), - CHSAPath(..), CHSPtrType(..), + CHSAPath(..), CHSPtrType(..), CHSTypedefInfo, CHSDefaultMarsh, + Direction(..), loadCHS, dumpCHS, hssuffix, chssuffix, loadCHI, dumpCHI, chisuffix, showCHSParm, apathToIdent, apathRootIdent, hasNonGNU) where @@ -109,7 +113,6 @@ import System.FilePath ((<.>), ()) - -- Language.C import Language.C.Data.Ident import Language.C.Data.Position @@ -119,6 +122,7 @@ import C2HS.State (CST, getSwitch, chiPathSB, catchExc, throwExc, raiseError, fatal, errorsPresent, showErrors, Traces(..), putTraceStr) import qualified System.CIO as CIO +import C2HS.C.Info (CPrimType(..)) import C2HS.Version (version) -- friends @@ -223,7 +227,7 @@ | CHSFun Bool -- is a pure function? Bool -- is unsafe? Bool -- is variadic? - [[String]] -- variadic C parameter types + [String] -- variadic C parameter types CHSAPath -- C function (Maybe Ident) -- Haskell name (Maybe String) -- type context @@ -249,7 +253,17 @@ Position | CHSConst Ident -- C identifier Position + | CHSTypedef Ident -- C type name + Ident -- Haskell type name + Position + | CHSDefault Direction -- in or out marshaller? + String -- Haskell type name + String -- C type string + Bool -- is it a C pointer? + (Either Ident String, CHSArg) -- marshaller + Position +data Direction = In | Out deriving (Eq, Ord, Show) instance Pos CHSHook where posOf (CHSImport _ _ _ pos) = pos @@ -266,6 +280,8 @@ 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 @@ -300,6 +316,10 @@ ide1 == ide2 (CHSConst ide1 _) == (CHSConst ide2 _) = ide1 == ide2 + (CHSTypedef ide1 _ _) == (CHSTypedef ide2 _ _) = + ide1 == ide2 + (CHSDefault _ ide1 _ _ _ _) == (CHSDefault _ ide2 _ _ _ _) = + ide1 == ide2 _ == _ = False -- | translation table @@ -319,6 +339,12 @@ -- type CHSMarsh = Maybe (Either Ident String, CHSArg) +-- | Type default information +type CHSTypedefInfo = (Ident, CPrimType) + +-- | Type default information +type CHSDefaultMarsh = (Either Ident String, CHSArg) + -- | marshalling descriptor for function hooks -- data CHSParm = CHSPlusParm -- special "+" parameter @@ -616,6 +642,21 @@ showCHSHook (CHSConst constIde _) = showString "const " . showCHSIdent constIde +showCHSHook (CHSTypedef cIde hsIde _) = + showString "typedef " + . showCHSIdent cIde + . showCHSIdent hsIde +showCHSHook (CHSDefault dir hsTy cTy cPtr marsh _) = + showString "default " + . showString (if dir == In then "in" else "out") + . showChar '`' . showString hsTy . showChar '\'' + . showChar '[' . showString cTy + . showString (if cPtr then " *" else "") . showChar ']' + . showMarsh marsh + where showMarsh (Left ide, arg) = showCHSIdent ide . showArg arg + showMarsh (Right s, arg) = showString s . showArg arg + showArg CHSIOArg = showString "*" + showArg _ = showString "" showPrefix :: Maybe String -> Bool -> ShowS showPrefix Nothing _ = showString "" @@ -646,21 +687,18 @@ Nothing -> id Just ide -> showString " as " . showCHSIdent ide) -showFunAlias :: CHSAPath -> [[String]] -> Maybe Ident -> ShowS +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 ")") + else showString "[" + . foldr (.) id (intersperse (showString ", ") (map showString 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) = @@ -931,6 +969,12 @@ CHSTokConst pos :toks) = parseConst hkpos pos (removeCommentInHook toks) parseFrags0 (CHSTokHook hkpos: + CHSTokTypedef pos :toks) = parseTypedef hkpos pos + (removeCommentInHook toks) + parseFrags0 (CHSTokHook hkpos: + CHSTokDefault pos :toks) = parseDefault hkpos pos + (removeCommentInHook toks) + parseFrags0 (CHSTokHook hkpos: CHSTokPointer pos :toks) = parsePointer hkpos pos (removeCommentInHook toks) parseFrags0 (CHSTokHook _ :toks) = syntaxError toks @@ -1112,20 +1156,14 @@ 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 (CHSTokLBrack _:CHSTokCArg _ t:toks') = do + (ts, toks'2) <- parseVarTypes' toks' + return (t:ts, toks'2) 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') + parseVarTypes' (CHSTokRBrack _:toks') = return ([], toks') + parseVarTypes' (CHSTokComma _:CHSTokCArg _ t:toks') = do + (ts, toks'2) <- parseVarTypes' toks' + return (t:ts, toks'2) -- parseParms (CHSTokLBrace _:CHSTokRBrace _:CHSTokArrow _:toks') = return ([], toks') @@ -1340,6 +1378,49 @@ frags <- parseFrags toks' return $ CHSHook (CHSConst constIde pos) hkpos : frags parseConst _ _ toks = syntaxError toks + +parseTypedef :: Position -> Position -> [CHSToken] -> CST s [CHSFrag] +parseTypedef hkpos pos (CHSTokIdent _ cIde : CHSTokIdent _ hsIde : + CHSTokEndHook _ : toks) = + do + frags <- parseFrags toks + return $ CHSHook (CHSTypedef cIde hsIde pos) hkpos : frags +parseTypedef _ _ toks = syntaxError toks + +parseDefault :: Position -> Position -> [CHSToken] -> CST s [CHSFrag] +parseDefault hkpos pos + toks@(dirtok : + CHSTokHSVerb _ hsTy : + CHSTokLBrack _ : + CHSTokCArg _ cTyIn : + CHSTokRBrack _ : + toks1) = + do + dir <- case dirtok of + CHSTokIn _ -> return In + CHSTokOut _ -> return Out + _ -> syntaxError toks + (marsh, toks2) <- parseMarshaller toks1 + let trim = reverse . dropWhile isSpace . reverse . dropWhile isSpace + cTy' = trim cTyIn + (cTy, cPtr) = if last cTy' == '*' + then (trim $ init cTy', True) + else (cTy', False) + toks3 <- parseEndHook toks2 + frags <- parseFrags toks3 + return $ CHSHook (CHSDefault dir hsTy cTy cPtr marsh pos) hkpos : frags + where parseMarshaller :: [CHSToken] + -> CST s ((Either Ident String, CHSArg), [CHSToken]) + parseMarshaller (CHSTokIdent _ mide : toks') = do + (hasStar, toks'') <- parseOptStar toks' + let argtype = if hasStar then CHSIOArg else CHSValArg + return ((Left mide, argtype), toks'') + parseMarshaller toks' = syntaxError toks' +parseDefault _ _ toks = syntaxError toks + +parseOptStar :: [CHSToken] -> CST s (Bool, [CHSToken]) +parseOptStar (CHSTokStar _ : toks) = return (True, toks) +parseOptStar toks = return (False, toks) parseOptLib :: [CHSToken] -> CST s (Maybe String, [CHSToken]) parseOptLib (CHSTokLib _ : 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 @@ -173,7 +173,7 @@ where import Data.List ((\\)) -import Data.Char (isDigit) +import Data.Char (isDigit, isSpace) import Language.C.Data.Ident import Language.C.Data.Name @@ -206,6 +206,8 @@ | CHSTokRBrace Position -- `}' | CHSTokLParen Position -- `(' | CHSTokRParen Position -- `)' + | CHSTokLBrack Position -- `[' + | CHSTokRBrack Position -- `]' | CHSTokHook Position -- `{#' | CHSTokEndHook Position -- `#}' | CHSTokAdd Position -- `add' @@ -215,6 +217,8 @@ | CHSTokConst Position -- `const' | CHSTokContext Position -- `context' | CHSTokNonGNU Position -- `nonGNU' + | CHSTokTypedef Position -- `typedef' + | CHSTokDefault Position -- `default' | CHSTokDerive Position -- `deriving' | CHSTokDown Position -- `downcaseFirstLetter' | CHSTokEnum Position -- `enum' @@ -243,6 +247,8 @@ | CHSTokUpper Position -- `upcaseFirstLetter' | CHSTokVariadic Position -- `variadic' | CHSTokWith Position Ident -- `with' + | CHSTokIn Position -- `in' + | CHSTokOut Position -- `out' | CHSTokString Position String -- string | CHSTokHSVerb Position String -- verbatim Haskell (`...') | CHSTokHSQuot Position String -- quoted Haskell ('...') @@ -254,6 +260,7 @@ | CHSTokCtrl Position Char -- control code | CHSTokComment Position String -- comment | CHSTokCIdentTail Position Ident -- C identifier without prefix + | CHSTokCArg Position String -- C type argument instance Pos CHSToken where posOf (CHSTokArrow pos ) = pos @@ -269,6 +276,8 @@ posOf (CHSTokRBrace pos ) = pos posOf (CHSTokLParen pos ) = pos posOf (CHSTokRParen pos ) = pos + posOf (CHSTokLBrack pos ) = pos + posOf (CHSTokRBrack pos ) = pos posOf (CHSTokHook pos ) = pos posOf (CHSTokEndHook pos ) = pos posOf (CHSTokAdd pos ) = pos @@ -279,6 +288,8 @@ posOf (CHSTokContext pos ) = pos posOf (CHSTokNonGNU pos ) = pos posOf (CHSTokDerive pos ) = pos + posOf (CHSTokTypedef pos ) = pos + posOf (CHSTokDefault pos ) = pos posOf (CHSTokDown pos ) = pos posOf (CHSTokEnum pos ) = pos posOf (CHSTokFinal pos ) = pos @@ -306,6 +317,8 @@ posOf (CHSTokUpper pos ) = pos posOf (CHSTokVariadic pos ) = pos posOf (CHSTokWith pos _) = pos + posOf (CHSTokIn pos ) = pos + posOf (CHSTokOut pos ) = pos posOf (CHSTokString pos _) = pos posOf (CHSTokHSVerb pos _) = pos posOf (CHSTokHSQuot pos _) = pos @@ -317,6 +330,7 @@ posOf (CHSTokCtrl pos _) = pos posOf (CHSTokComment pos _) = pos posOf (CHSTokCIdentTail pos _) = pos + posOf (CHSTokCArg pos _) = pos instance Eq CHSToken where (CHSTokArrow _ ) == (CHSTokArrow _ ) = True @@ -332,6 +346,8 @@ (CHSTokRBrace _ ) == (CHSTokRBrace _ ) = True (CHSTokLParen _ ) == (CHSTokLParen _ ) = True (CHSTokRParen _ ) == (CHSTokRParen _ ) = True + (CHSTokLBrack _ ) == (CHSTokLBrack _ ) = True + (CHSTokRBrack _ ) == (CHSTokRBrack _ ) = True (CHSTokHook _ ) == (CHSTokHook _ ) = True (CHSTokEndHook _ ) == (CHSTokEndHook _ ) = True (CHSTokAdd _ ) == (CHSTokAdd _ ) = True @@ -341,6 +357,8 @@ (CHSTokConst _ ) == (CHSTokConst _ ) = True (CHSTokContext _ ) == (CHSTokContext _ ) = True (CHSTokNonGNU _ ) == (CHSTokNonGNU _ ) = True + (CHSTokTypedef _ ) == (CHSTokTypedef _ ) = True + (CHSTokDefault _ ) == (CHSTokDefault _ ) = True (CHSTokDerive _ ) == (CHSTokDerive _ ) = True (CHSTokDown _ ) == (CHSTokDown _ ) = True (CHSTokEnum _ ) == (CHSTokEnum _ ) = True @@ -369,6 +387,8 @@ (CHSTokUpper _ ) == (CHSTokUpper _ ) = True (CHSTokVariadic _ ) == (CHSTokVariadic _ ) = True (CHSTokWith _ _) == (CHSTokWith _ _) = True + (CHSTokIn _ ) == (CHSTokIn _ ) = True + (CHSTokOut _ ) == (CHSTokOut _ ) = True (CHSTokString _ _) == (CHSTokString _ _) = True (CHSTokHSVerb _ _) == (CHSTokHSVerb _ _) = True (CHSTokHSQuot _ _) == (CHSTokHSQuot _ _) = True @@ -380,6 +400,7 @@ (CHSTokCtrl _ _) == (CHSTokCtrl _ _) = True (CHSTokComment _ _) == (CHSTokComment _ _) = True (CHSTokCIdentTail _ _) == (CHSTokCIdentTail _ _) = True + (CHSTokCArg _ _) == (CHSTokCArg _ _) = True _ == _ = False instance Show CHSToken where @@ -397,6 +418,8 @@ showsPrec _ (CHSTokRBrace _ ) = showString "}" showsPrec _ (CHSTokLParen _ ) = showString "(" showsPrec _ (CHSTokRParen _ ) = showString ")" + showsPrec _ (CHSTokLBrack _ ) = showString "[" + showsPrec _ (CHSTokRBrack _ ) = showString "]" showsPrec _ (CHSTokHook _ ) = showString "{#" showsPrec _ (CHSTokEndHook _ ) = showString "#}" showsPrec _ (CHSTokAdd _ ) = showString "add" @@ -406,6 +429,8 @@ showsPrec _ (CHSTokConst _ ) = showString "const" showsPrec _ (CHSTokContext _ ) = showString "context" showsPrec _ (CHSTokNonGNU _ ) = showString "nonGNU" + showsPrec _ (CHSTokTypedef _ ) = showString "typedef" + showsPrec _ (CHSTokDefault _ ) = showString "default" showsPrec _ (CHSTokDerive _ ) = showString "deriving" showsPrec _ (CHSTokDown _ ) = showString "downcaseFirstLetter" showsPrec _ (CHSTokEnum _ ) = showString "enum" @@ -434,6 +459,8 @@ showsPrec _ (CHSTokUpper _ ) = showString "upcaseFirstLetter" showsPrec _ (CHSTokVariadic _ ) = showString "variadic" showsPrec _ (CHSTokWith _ _) = showString "with" + showsPrec _ (CHSTokIn _ ) = showString "in" + showsPrec _ (CHSTokOut _ ) = showString "out" showsPrec _ (CHSTokString _ s) = showString ("\"" ++ s ++ "\"") showsPrec _ (CHSTokHSVerb _ s) = showString ("`" ++ s ++ "'") showsPrec _ (CHSTokHSQuot _ s) = showString ("'" ++ s ++ "'") @@ -447,6 +474,7 @@ then "" else " --" ++ s ++ "\n") showsPrec _ (CHSTokCIdentTail _ i) = (showString . identToString) i + showsPrec _ (CHSTokCArg _ s) = showString s -- lexer state -- ----------- @@ -701,6 +729,7 @@ >||< hsverb >||< hsquot >||< whitespace + >||< arglist >||< endOfHook >||< string "--" +> anyButNL`star` epsilon -- comment `lexaction` \cs pos -> Just (CHSTokComment pos (drop 2 cs)) @@ -710,7 +739,25 @@ `lexmeta` \_ pos s -> (Just $ Right (CHSTokEndHook pos), incPos pos 2, s, Just chslexer) + arglist = string "[" + `lexmeta` \_ pos s -> (Just $ Right (CHSTokLBrack pos), + incPos pos 1, s, Just alLexer) +-- | lexer for C function types for variadic functions +-- +alLexer :: CHSLexer +alLexer = sym "," CHSTokComma + >||< endOfArgList + >||< cArg + where sym cs con = string cs `lexaction` \_ pos -> Just (con pos) + endOfArgList = string "]" + `lexmeta` + \_ pos s -> (Just $ Right (CHSTokRBrack pos), + incPos pos 1, s, Just bhLexer) + cArg = ((alt (anySet \\ ",]")) `star` epsilon) `lexaction` + \cs pos -> Just (CHSTokCArg pos $ trim cs) + trim = reverse . dropWhile isSpace . reverse . dropWhile isSpace + -- | the inline-C lexer -- cLexer :: CHSLexer @@ -757,6 +804,8 @@ idkwtok pos "const" _ = CHSTokConst pos idkwtok pos "context" _ = CHSTokContext pos idkwtok pos "nonGNU" _ = CHSTokNonGNU pos + idkwtok pos "typedef" _ = CHSTokTypedef pos + idkwtok pos "default" _ = CHSTokDefault pos idkwtok pos "deriving" _ = CHSTokDerive pos idkwtok pos "downcaseFirstLetter" _ = CHSTokDown pos idkwtok pos "enum" _ = CHSTokEnum pos @@ -785,6 +834,8 @@ idkwtok pos "upcaseFirstLetter"_ = CHSTokUpper pos idkwtok pos "variadic" _ = CHSTokVariadic pos idkwtok pos "with" name = mkwith pos name + idkwtok pos "in" _ = CHSTokIn pos + idkwtok pos "out" _ = CHSTokOut pos idkwtok pos cs name = mkid pos cs name -- mkid pos cs name = CHSTokIdent pos (mkIdent pos cs name) @@ -800,6 +851,8 @@ CHSTokConst pos -> mkid pos "const" CHSTokContext pos -> mkid pos "context" CHSTokNonGNU pos -> mkid pos "nonGNU" + CHSTokTypedef pos -> mkid pos "typedef" + CHSTokDefault pos -> mkid pos "default" CHSTokDerive pos -> mkid pos "deriving" CHSTokDown pos -> mkid pos "downcaseFirstLetter" CHSTokEnum pos -> mkid pos "enum" @@ -828,6 +881,8 @@ CHSTokUpper pos -> mkid pos "upcaseFirstLetter" CHSTokVariadic pos -> mkid pos "variadic" CHSTokWith pos ide -> CHSTokIdent pos ide + CHSTokIn pos -> mkid pos "in" + CHSTokOut pos -> mkid pos "out" _ -> 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 @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- C->Haskell Compiler: binding generator -- @@ -110,13 +111,17 @@ -- standard libraries import Data.Char (toLower) import Data.Function (on) -import Data.List (deleteBy, groupBy, sortBy, intersperse, find, nubBy, intercalate) -import Data.Map (Map, lookup, fromList) +import Data.List (deleteBy, groupBy, sortBy, intersperse, find, nubBy, + intercalate, isPrefixOf, foldl') +import Data.Map (lookup) import Data.Maybe (isNothing, isJust, fromJust, fromMaybe) import Data.Bits ((.|.), (.&.)) import Control.Arrow (second) -import Control.Monad (when, unless, liftM, mapAndUnzipM, zipWithM) +import Control.Monad (when, unless, liftM, mapAndUnzipM, zipWithM, forM) import Data.Ord (comparing) +import qualified Foreign.Storable as Storable (Storable(alignment)) +import Foreign (Ptr, FunPtr) +import Foreign.C -- Language.C / compiler toolkit import Language.C.Data.Position @@ -124,25 +129,31 @@ import Language.C.Pretty import Text.PrettyPrint.HughesPJ (render) import Data.Errors +import C2HS.Config (PlatformSpec(..)) +import C2HS.State (getSwitch) +import C2HS.Switches (platformSB) + -- C->Haskell -import C2HS.Config (PlatformSpec(..)) import C2HS.State (CST, errorsPresent, showErrors, fatal, - SwitchBoard(..), Traces(..), putTraceStr, getSwitch) + SwitchBoard(..), Traces(..), putTraceStr) import C2HS.C -- friends -import C2HS.CHS (CHSModule(..), CHSFrag(..), CHSHook(..), - CHSParm(..), CHSMarsh, CHSArg(..), CHSAccess(..), CHSAPath(..), +import C2HS.CHS (CHSModule(..), CHSFrag(..), CHSHook(..), CHSParm(..), + CHSMarsh, CHSArg(..), CHSAccess(..), CHSAPath(..), + CHSTypedefInfo, Direction(..), CHSPtrType(..), showCHSParm, apathToIdent, apathRootIdent) -import C2HS.C.Info (CPrimType(..), alignment, getPlatform) +import C2HS.C.Info (CPrimType(..)) import qualified C2HS.C.Info as CInfo import C2HS.Gen.Monad (TransFun, transTabToTransFun, HsObject(..), GB, GBState(..), initialGBState, setContext, getPrefix, getReplacementPrefix, delayCode, getDelayedCode, ptrMapsTo, queryPtr, objIs, sizeIs, querySize, queryClass, queryPointer, - mergeMaps, dumpMaps, queryEnum, isEnum) + mergeMaps, dumpMaps, queryEnum, isEnum, + queryTypedef, isC2HSTypedef, + queryDefaultMarsh, isDefaultMarsh) -- default marshallers @@ -182,8 +193,6 @@ lookupDftMarshIn "String" [PtrET (PrimET CCharPT), PrimET pt] | isIntegralCPrimType pt = return $ Just (Right stringIn , CHSIOArg) -lookupDftMarshIn hsTy [PtrET ty] | showExtType ty == hsTy = - return $ Just (Right stringIn, CHSIOArg) lookupDftMarshIn hsTy [PtrET (PrimET pt)] | isIntegralHsType hsTy && isIntegralCPrimType pt = return $ Just (Right "with . fromIntegral", CHSIOArg) @@ -193,6 +202,22 @@ lookupDftMarshIn "Bool" [PtrET (PrimET pt)] | isIntegralCPrimType pt = return $ Just (Right "with . fromBool", CHSIOArg) +lookupDftMarshIn hsTy [PtrET UnitET] | "Ptr " `isPrefixOf` hsTy = + return $ Just (Left idIde, CHSValArg) +lookupDftMarshIn hsTy [PrimET (CAliasedPT tds hsAlias _)] = do + mm <- queryDefaultMarsh $ (In, tds, False) + case mm of + Nothing -> if hsTy == hsAlias + then return $ Just (Left idIde, CHSValArg) + else return Nothing + Just m -> return $ Just m +lookupDftMarshIn hsTy [PtrET (PrimET (CAliasedPT tds hsAlias _pt))] = do + mm <- queryDefaultMarsh $ (In, tds, True) + case mm of + Nothing -> if hsTy == hsAlias + then return $ Just (Left idIde, CHSValArg) + else return Nothing + Just m -> return $ Just m -- Default case deals with: lookupDftMarshIn hsty _ = do om <- readCT objmap @@ -220,10 +245,10 @@ lookupDftMarshOut "Bool" [PrimET pt] | isIntegralCPrimType pt = return $ Just (Left cToBoolIde, CHSValArg) lookupDftMarshOut hsTy [PrimET pt] | isIntegralHsType hsTy - &&isIntegralCPrimType pt = + && isIntegralCPrimType pt = return $ Just (Left cIntConvIde, CHSValArg) lookupDftMarshOut hsTy [PrimET pt] | isFloatHsType hsTy - &&isFloatCPrimType pt = + && isFloatCPrimType pt = return $ Just (Left cFloatConvIde, CHSValArg) lookupDftMarshOut "Char" [PrimET CCharPT] = return $ Just (Left castCCharToCharIde, CHSValArg) @@ -239,9 +264,22 @@ | isIntegralCPrimType pt = return $ Just (Right "\\(s, n) -> peekCStringLen (s, fromIntegral n)", CHSIOArg) -lookupDftMarshOut hsTy [PtrET ty] | showExtType ty == hsTy = - return $ Just (Left peekIde, CHSIOArg) --- Default case deals with: +lookupDftMarshOut hsTy [PtrET UnitET] | "Ptr " `isPrefixOf` hsTy = + return $ Just (Left idIde, CHSValArg) +lookupDftMarshOut hsTy [PrimET (CAliasedPT tds hsAlias _)] = do + mm <- queryDefaultMarsh $ (Out, tds, False) + case mm of + Nothing -> if hsTy == hsAlias + then return $ Just (Left idIde, CHSValArg) + else return Nothing + Just m -> return $ Just m +lookupDftMarshOut hsTy [PtrET (PrimET (CAliasedPT tds hsAlias _pt))] = do + mm <- queryDefaultMarsh $ (Out, tds, True) + case mm of + Nothing -> if hsTy == hsAlias + then return $ Just (Left idIde, CHSValArg) + else return Nothing + Just m -> return $ Just m lookupDftMarshOut hsty _ = do om <- readCT objmap isenum <- queryEnum hsty @@ -331,7 +369,7 @@ -- | standard conversions -- voidIde, cFromBoolIde, cToBoolIde, cIntConvIde, cFloatConvIde, - withCStringIde, peekIde, peekCStringIde, idIde, + withCStringIde, peekCStringIde, idIde, newForeignPtr_Ide, withForeignPtrIde, returnIde, castCharToCCharIde, castCharToCUCharIde, castCharToCSCharIde, castCCharToCharIde, castCUCharToCharIde, castCSCharToCharIde :: Ident @@ -341,7 +379,6 @@ cIntConvIde = internalIdent "fromIntegral" cFloatConvIde = internalIdent "realToFrac" withCStringIde = internalIdent "withCString" -peekIde = internalIdent "peek" peekCStringIde = internalIdent "peekCString" idIde = internalIdent "id" newForeignPtr_Ide = internalIdent "newForeignPtr_" @@ -569,11 +606,12 @@ "** Indirect call hook for `" ++ identToString (apathToIdent apath) ++ "':\n" traceValueType et = traceGenBind $ "Type of accessed value: " ++ showExtType et ++ "\n" -expandHook (CHSFun isPure isUns isVar inVarTypes (CHSRoot _ ide) +expandHook (CHSFun isPure isUns _ inVarTypes (CHSRoot _ ide) oalias ctxt parms parm pos) hkpos = do traceEnter traceGenBind $ "ide = '" ++ show ide ++ "'\n" + traceGenBind $ "inVarTypes = " ++ show inVarTypes ++ "\n" -- get the corresponding C declaration; raises error if not found or not a -- function; we use shadow identifiers, so the returned identifier is used -- afterwards instead of the original one @@ -585,7 +623,7 @@ fiIde = internalIdent fiLexeme cdecl' = cide `simplifyDecl` cdecl callHook = CHSCall isPure isUns (CHSRoot False cide) (Just fiIde) pos - varTypes <- mapM (convertVarType pos) inVarTypes + varTypes <- convertVarTypes hsLexeme pos inVarTypes callImport callHook isPure isUns varTypes (identToString cide) fiLexeme cdecl' pos @@ -595,8 +633,7 @@ where traceEnter = traceGenBind $ "** Fun hook for `" ++ identToString ide ++ "':\n" -expandHook (CHSFun isPure isUns isVar varTypes - apath oalias ctxt parms parm pos) hkpos = +expandHook (CHSFun isPure isUns _ _ apath oalias ctxt parms parm pos) hkpos = do traceEnter @@ -783,6 +820,35 @@ Just (ObjCO cdecl) <- findObj cIde let (Just ini) = initDeclr cdecl return . show . pretty $ ini +expandHook (CHSTypedef cIde hsIde pos) _ = + do + traceGenBind $ "** Typedef hook: " ++ identToString cIde ++ + " -> " ++ identToString hsIde ++ "\n" + let def = "__c2hs_typedef__" ++ + identToString cIde ++ "__" ++ identToString hsIde + Just (ObjCO cdecl) <- findObj $ internalIdent def + st <- extractCompType True True cdecl + et <- case st of + ExtType (PrimET e) -> return e + _ -> typeDefaultErr pos + cIde `isC2HSTypedef` (hsIde, et) + return "" +expandHook (CHSDefault dir hsTy cTy cPtr marsh pos) _ = + do + traceGenBind $ "** Default hook: " ++ hsTy ++ " [" ++ cTy ++ + (if cPtr then " *" else "") ++ "]\n" + mtypedef <- queryTypedef $ internalIdent cTy + case mtypedef of + Nothing -> typeDefaultErr pos + Just (tdide, _) -> do + let def = "__c2hs_typedef__" ++ cTy ++ "__" ++ identToString tdide + Just (ObjCO cdecl) <- findObj $ internalIdent def + st <- extractCompType True True cdecl + case st of + ExtType (PrimET _) -> do + (dir, cTy, cPtr) `isDefaultMarsh` marsh + return "" + _ -> typeDefaultErr pos apathNewtypeName :: CHSAPath -> GB (Maybe Ident) apathNewtypeName path = do @@ -1129,8 +1195,8 @@ in ctxt ++ concat (intersperse " -> " (argTys ++ [resTup])) where - notVoid Nothing = interr "GenBind.funDef: \ - \No default marshaller?" + notVoid Nothing + = interr "GenBind.funDef: No default marshaller?" notVoid (Just (_, kind)) = kind /= CHSVoidArg && kind /= CHSIOVoidArg -- -- for an argument marshaller, generate all "in" and "out" marshalling @@ -1557,14 +1623,13 @@ classDef pos className typeName ptrType isNewtype superClasses = do let - toMethodName = case typeName of - "" -> interr "GenBind.classDef: \ - \Illegal identifier!" - c:cs -> toLower c : cs + toMethodName = case typeName of + "" -> interr "GenBind.classDef: Illegal identifier!" + c:cs -> toLower c : cs fromMethodName = "from" ++ typeName classDefContext = case superClasses of - [] -> "" - (superName, _, _):_ -> superName ++ " p => " + [] -> "" + (superName, _, _):_ -> superName ++ " p => " classDefStr = "class " ++ classDefContext ++ className ++ " p where\n" ++ " " ++ toMethodName ++ " :: p -> " ++ typeName ++ "\n" @@ -1582,9 +1647,8 @@ unless (ptrType == ptrType') $ pointerTypeMismatchErr pos className superName let toMethodName = case ptrName of - "" -> interr "GenBind.classDef: \ - \Illegal identifier - 2!" - c:cs -> toLower c : cs + "" -> interr "GenBind.classDef: Illegal identifier - 2!" + c:cs -> toLower c : cs fromMethodName = "from" ++ ptrName castFun = "cast" ++ show ptrType typeConstr = if isNewtype then typeName ++ " " else "" @@ -1633,6 +1697,7 @@ | PrimET CPrimType -- basic C type | UnitET -- void | VarFunET ExtType -- variadic function + deriving Show instance Eq ExtType where (FunET t1 t2) == (FunET t1' t2') = t1 == t1' && t2 == t2' @@ -1696,6 +1761,7 @@ showExtType (PrimET CLDoublePT) = "CLDouble" showExtType (PrimET (CSFieldPT bs)) = "CInt{-:" ++ show bs ++ "-}" showExtType (PrimET (CUFieldPT bs)) = "CUInt{-:" ++ show bs ++ "-}" +showExtType (PrimET (CAliasedPT _ hs _)) = hs showExtType UnitET = "()" showExtFunType :: ExtType -> [ExtType] -> String @@ -1703,7 +1769,7 @@ showExtFunType (FunET arg res) vas = "(" ++ showExtType arg ++ " -> " ++ showExtFunType res vas ++ ")" showExtFunType (VarFunET res) [] = showExtFunType res [] -showExtFunType t@(VarFunET res) (va:vas) = +showExtFunType t@(VarFunET _) (va:vas) = "(" ++ showExtType va ++ " -> " ++ showExtFunType t vas ++ ")" showExtFunType (IOET t) vas = "(IO " ++ showExtFunType t vas ++ ")" showExtFunType t _ = showExtType t @@ -1838,6 +1904,12 @@ traceFunType et <- extractFunType (posOf cdecl) cdecl False returnX et + + makeAliasedCompType :: Ident -> CHSTypedefInfo -> GB CompType + makeAliasedCompType cIde (hsIde, et) = do + return $ ExtType $ PrimET $ + CAliasedPT (identToString cIde) (identToString hsIde) et + -- -- handle all types, which are not obviously pointers or functions -- @@ -1847,18 +1919,22 @@ case checkForOneAliasName cdecl of Nothing -> specType (posOf cdecl) specs' size Just ide -> do -- this is a typedef alias - traceAlias ide - oHsRepr <- queryPtr (False, ide) -- check for pointer hook alias - case oHsRepr of - Just repr | usePtrAliases - -> ptrAlias repr -- found a pointer hook alias - _ -> do -- skip current alias (only one) - cdecl' <- getDeclOf ide - let CDecl specs [(declr, init', _)] at = - ide `simplifyDecl` cdecl' - sdecl = CDecl specs [(declr, init', size)] at - -- propagate `size' down (slightly kludgy) - extractCompType isResult usePtrAliases sdecl + oDefault <- queryTypedef ide + case oDefault of + Just tdefault -> makeAliasedCompType ide tdefault + Nothing -> do + traceAlias ide + oHsRepr <- queryPtr (False, ide) -- check for pointer hook alias + case oHsRepr of + Just repr | usePtrAliases + -> ptrAlias repr -- found a pointer hook alias + _ -> do -- skip current alias (only one) + cdecl' <- getDeclOf ide + let CDecl specs [(declr, init', _)] at = + ide `simplifyDecl` cdecl' + sdecl = CDecl specs [(declr, init', size)] at + -- propagate `size' down (slightly kludgy) + extractCompType isResult usePtrAliases sdecl -- -- compute the result for a pointer alias -- @@ -1924,28 +2000,19 @@ 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 +convertVarTypes :: String -> Position -> [String] -> GB [ExtType] +convertVarTypes base pos ts = do + let vaIdent i = internalIdent $ "__c2hs__vararg__" ++ base ++ "_" ++ show i + ides = map vaIdent [0..length ts - 1] + doone ide = do + Just (ObjCO cdecl) <- findObj ide + return cdecl + cdecls <- mapM doone ides + forM cdecls $ \cdecl -> do + st <- extractCompType True True cdecl + case st of + ExtType et -> return et + _ -> variadicTypeErr pos -- | compute the complex (external) type determined by a list of type specifiers -- @@ -2371,7 +2438,10 @@ evalCConst :: CConst -> GB ConstResult evalCConst (CIntConst i _ ) = return $ IntResult (getCInteger i) -evalCConst (CCharConst c _ ) = return $ IntResult (getCCharAsInt c) +evalCConst (CCharConst c@(C2HS.C.CChar _ _) _ ) = + return $ IntResult (getCCharAsInt c) +evalCConst (CCharConst (CChars cs _) _ ) = return $ IntResult (foldl' add 0 cs) + where add tot ch = tot * 0x100 + fromIntegral (fromEnum ch) evalCConst (CFloatConst _ _ ) = todo "GenBind.evalCConst: Float conversion from literal misses." evalCConst (CStrConst _ at) = @@ -2497,16 +2567,16 @@ illegalTypeSpecErr cpos = raiseErrorCTExc cpos ["Illegal type!", - "The type specifiers of this declaration do not form a legal ANSI C(89) \ - \type." + "The type specifiers of this declaration do not form a " ++ + "legal ANSI C(89) type." ] unsupportedTypeSpecErr :: Position -> GB a unsupportedTypeSpecErr cpos = raiseErrorCTExc cpos ["Unsupported type!", - "The type specifier of this declaration is not supported by your \ - \combination of C compiler and Haskell compiler." + "The type specifier of this declaration is not supported by your " ++ + "combination of C compiler and Haskell compiler." ] variadicErr :: Position -> Position -> GB a @@ -2522,6 +2592,12 @@ ["Variadic function argument type!", "Calling variadic functions is only supported for simple C types"] +typeDefaultErr :: Position -> GB a +typeDefaultErr pos = + raiseErrorCTExc pos + ["Internal type default error!", + "Something went wrong."] + illegalPlusErr :: Position -> GB a illegalPlusErr pos = raiseErrorCTExc pos @@ -2551,8 +2627,8 @@ ptrExpectedErr pos = raiseErrorCTExc pos ["Expected a pointer object!", - "Attempt to dereference a non-pointer object or to use it in a `pointer' \ - \hook."] + "Attempt to dereference a non-pointer object or to use it in a " ++ + "`pointer' hook."] funPtrExpectedErr :: Position -> GB a funPtrExpectedErr pos = @@ -2624,10 +2700,74 @@ noDftMarshErr pos inOut hsTy cTys = raiseErrorCTExc pos ["Missing " ++ inOut ++ " marshaller!", - "There is no default marshaller for this combination of Haskell and \ - \C type:", + "There is no default marshaller for this combination of Haskell and " ++ + "C type:", "Haskell type: " ++ hsTy, "C type : " ++ concat (intersperse " " (map showExtType cTys))] undefEnumErr :: Position -> GB a undefEnumErr pos = raiseErrorCTExc pos ["Incomplete enum type!"] + + +-- | alignment of C's primitive types +-- +-- * more precisely, the padding put before the type's member starts when the +-- preceding component is a char +-- +alignment :: CPrimType -> GB Int +alignment CPtrPT = return $ Storable.alignment (undefined :: Ptr ()) +alignment CFunPtrPT = return $ Storable.alignment (undefined :: FunPtr ()) +alignment CCharPT = return $ 1 +alignment CUCharPT = return $ 1 +alignment CSCharPT = return $ 1 +alignment CIntPT = return $ Storable.alignment (undefined :: CInt) +alignment CShortPT = return $ Storable.alignment (undefined :: CShort) +alignment CLongPT = return $ Storable.alignment (undefined :: CLong) +alignment CLLongPT = return $ Storable.alignment (undefined :: CLLong) +alignment CUIntPT = return $ Storable.alignment (undefined :: CUInt) +alignment CUShortPT = return $ Storable.alignment (undefined :: CUShort) +alignment CULongPT = return $ Storable.alignment (undefined :: CULong) +alignment CULLongPT = return $ Storable.alignment (undefined :: CULLong) +alignment CFloatPT = + return $ Storable.alignment (undefined :: Foreign.C.CFloat) +alignment CDoublePT = return $ Storable.alignment (undefined :: CDouble) +#if MIN_VERSION_base(4,2,0) +alignment CLDoublePT = interr "Info.alignment: CLDouble not supported" +#else +alignment CLDoublePT = return $ Storable.alignment (undefined :: CLDouble) +#endif +alignment (CSFieldPT bs) = fieldAlignment bs +alignment (CUFieldPT bs) = fieldAlignment bs +alignment (CAliasedPT _ _ pt) = alignment pt + +-- | alignment constraint for a C bitfield +-- +-- * gets the bitfield size (in bits) as an argument +-- +-- * alignments constraints smaller or equal to zero are reserved for bitfield +-- alignments +-- +-- * bitfields of size 0 always trigger padding; thus, they get the maximal +-- size +-- +-- * if bitfields whose size exceeds the space that is still available in a +-- partially filled storage unit trigger padding, the size of a storage unit +-- is provided as the alignment constraint; otherwise, it is 0 (meaning it +-- definitely starts at the current position) +-- +-- * here, alignment constraint /= 0 are somewhat subtle; they mean that is +-- the given number of bits doesn't fit in what's left in the current +-- storage unit, alignment to the start of the next storage unit has to be +-- triggered +-- +fieldAlignment :: Int -> GB Int +fieldAlignment 0 = return $ - (CInfo.size CIntPT - 1) +fieldAlignment bs = + do + PlatformSpec {bitfieldPaddingPS = bitfieldPadding} <- getPlatform + return $ if bitfieldPadding then - bs else 0 + +-- | obtain platform from switchboard +-- +getPlatform :: GB PlatformSpec +getPlatform = getSwitch platformSB diff --git a/src/C2HS/Gen/Header.hs b/src/C2HS/Gen/Header.hs --- a/src/C2HS/Gen/Header.hs +++ b/src/C2HS/Gen/Header.hs @@ -61,7 +61,8 @@ throwExc, errorsPresent, showErrors, fatal) -- friends -import C2HS.CHS (CHSModule(..), CHSFrag(..), CHSHook(..), CHSChangeCase(..), CHSTrans(..)) +import C2HS.CHS (CHSModule(..), CHSFrag(..), CHSHook(..), CHSChangeCase(..), + CHSTrans(..), CHSAPath(..)) -- | The header generation monad @@ -207,7 +208,7 @@ where newConstIdent = liftM internalIdent $ transCST $ - \supply -> (tail supply, "c2hs__const__" ++ show (nameId $ head supply)) + \supply -> (tail supply, "__c2hs__const__" ++ show (nameId $ head supply)) constDef ide = -- This is a little nasty. We write a definition of an *integer* -- C value into the header, regardless of what type it really @@ -217,6 +218,22 @@ Just (CInitExpr (CVar cident undefNode) undefNode), Nothing)] undefNode + +ghFrag (frag@(CHSHook (CHSFun _ _ True varTypes + (CHSRoot _ ide) oalias _ _ _ _) _) : frags) = do + let ideLexeme = identToString ide + hsLexeme = ideLexeme `maybe` identToString $ oalias + vaIdent base idx = "__c2hs__vararg__" ++ base ++ "_" ++ show idx + ides = map (vaIdent hsLexeme) [0..length varTypes - 1] + defs = zipWith (\t i -> t ++ " " ++ i ++ ";\n") varTypes ides + return (DL.fromList defs, Frag frag, frags) + +ghFrag (frag@(CHSHook (CHSTypedef cIde hsIde _) _) : frags) = do + let cTypLexeme = identToString cIde + hsTypLexeme = identToString hsIde + defs = [cTypLexeme ++ " __c2hs_typedef__" ++ + cTypLexeme ++ "__" ++ hsTypLexeme ++ ";\n"] + return (DL.fromList defs, Frag frag, frags) ghFrag (frag@(CHSHook _ _) : frags) = return (DL.empty, Frag frag, frags) ghFrag (frag@(CHSLine _ ) : frags) = return (DL.empty, Frag frag, frags) diff --git a/src/C2HS/Gen/Monad.hs b/src/C2HS/Gen/Monad.hs --- a/src/C2HS/Gen/Monad.hs +++ b/src/C2HS/Gen/Monad.hs @@ -71,10 +71,12 @@ module C2HS.Gen.Monad ( TransFun, transTabToTransFun, - HsObject(..), GB, GBState(..), initialGBState, setContext, getLibrary, getPrefix, + HsObject(..), GB, GBState(..), + initialGBState, setContext, getLibrary, getPrefix, getReplacementPrefix, delayCode, getDelayedCode, ptrMapsTo, queryPtr, objIs, queryObj, sizeIs, querySize, queryClass, queryPointer, - mergeMaps, dumpMaps, queryEnum, isEnum + mergeMaps, dumpMaps, queryEnum, isEnum, + queryTypedef, isC2HSTypedef, queryDefaultMarsh, isDefaultMarsh ) where -- standard libraries @@ -96,7 +98,8 @@ -- friends import C2HS.CHS (CHSFrag(..), CHSHook(..), CHSTrans(..), - CHSChangeCase(..), CHSPtrType(..)) + CHSChangeCase(..), CHSPtrType(..), + CHSTypedefInfo, CHSDefaultMarsh, Direction(..)) -- translation tables @@ -221,6 +224,12 @@ -- | set of Haskell type names corresponding to C enums. type EnumSet = Set String +-- Map from C type names to type default definitions. +type TypedefMap = Map Ident CHSTypedefInfo + +-- Map from C type names to type default definitions. +type DefaultMarshMap = Map (Direction, String, Bool) CHSDefaultMarsh + {- FIXME: What a mess... instance Show HsObject where show (Pointer ptrType isNewtype) = @@ -279,7 +288,9 @@ ptrmap :: PointerMap, -- pointer representation objmap :: HsObjectMap, -- generated Haskell objects szmap :: SizeMap, -- object sizes - enums :: EnumSet -- enumeration hooks + enums :: EnumSet, -- enumeration hooks + tdmap :: TypedefMap, -- typedefs + dmmap :: DefaultMarshMap -- user-defined default marshallers } type GB a = CT GBState a @@ -293,7 +304,9 @@ ptrmap = Map.empty, objmap = Map.empty, szmap = Map.empty, - enums = Set.empty + enums = Set.empty, + tdmap = Map.empty, + dmmap = Map.empty } -- | set the dynamic library and library prefix @@ -488,6 +501,32 @@ isEnum :: String -> GB () isEnum hsName = transCT (\state -> (state { enums = Set.insert hsName (enums state) }, ())) + +-- | query the type default map +-- +queryTypedef :: Ident -> GB (Maybe CHSTypedefInfo) +queryTypedef cIde = do + tds <- readCT tdmap + return $ cIde `Map.lookup` tds + +-- | add an entry to the type default map +-- +isC2HSTypedef :: Ident -> CHSTypedefInfo -> GB () +isC2HSTypedef cIde td = + transCT (\state -> (state { tdmap = Map.insert cIde td (tdmap state) }, ())) + +-- | query the default marshaller map +-- +queryDefaultMarsh :: (Direction, String, Bool) -> GB (Maybe CHSDefaultMarsh) +queryDefaultMarsh k = do + dms <- readCT dmmap + return $ k `Map.lookup` dms + +-- | add an entry to the type default map +-- +isDefaultMarsh :: (Direction, String, Bool) -> CHSDefaultMarsh -> GB () +isDefaultMarsh k dm = + transCT (\state -> (state { dmmap = Map.insert k dm (dmmap state) }, ())) -- error messages diff --git a/tests/bugs/issue-102/Issue102.chs b/tests/bugs/issue-102/Issue102.chs --- a/tests/bugs/issue-102/Issue102.chs +++ b/tests/bugs/issue-102/Issue102.chs @@ -1,15 +1,57 @@ module Main where -import Foreign.Ptr -import Foreign.C.Types +import Control.Monad +import Foreign import Foreign.C.String +import Foreign.C.Types #include +#include -{#fun variadic printf(int) as printi {`String', `Int'} -> `()'#} -{#fun variadic printf(int, int) as printi2 {`String', `Int', `Int'} -> `()'#} +{#pointer *FILE as File foreign finalizer fclose newtype#} +{#fun fopen as ^ {`String', `String'} -> `File'#} +{#fun fileno as ^ {`File'} -> `Int'#} + +{#fun variadic fprintf[int] as fprinti + {`File', `String', `Int'} -> `()'#} +{#fun variadic fprintf[int, int] as fprinti2 + {`File', `String', `Int', `Int'} -> `()'#} +{#fun variadic fprintf[const char *] as fprints + {`File', `String', `String'} -> `()'#} + +{#fun variadic printf[int] as printi {`String', `Int'} -> `()'#} +{#fun variadic printf[int, int] as printi2 {`String', `Int', `Int'} -> `()'#} +{#fun variadic printf[const char *] as prints {`String', `String'} -> `()'#} + +{#enum define FCntlAction {F_GETLK as GetLock, F_SETLK as SetLock} + deriving (Eq, Ord, Show)#} +{#enum define FCntlLockState + {F_RDLCK as ReadLock, F_WRLCK as WriteLock, F_UNLCK as Unlocked} + deriving (Eq, Ord, Show)#} +{#pointer *flock as FLock foreign newtype#} +{#fun variadic fcntl[struct flock *] as + f_get_lock {`Int', `Int', +} -> `FLock'#} +{#fun variadic fcntl[struct flock *] as + f_set_lock {`Int', `Int', `FLock'} -> `Int'#} + main :: IO () main = do + f <- fopen "issue-102.txt" "w" + fd <- fileno f printi "TST 1: %d\n" 1234 printi2 "TST 2: %d %d\n" 13 47 + prints "TST 3: %s\n" "testing" + fprinti f "TST 1: %d\n" 1234 + fprinti2 f "TST 2: %d %d\n" 13 47 + fprints f "TST 3: %s\n" "testing" + flck <- get_lock fd + withFLock flck $ \lck -> do + typ <- {#get flock.l_type#} lck + print (toEnum $ fromIntegral typ :: FCntlLockState) + +get_lock :: Int -> IO FLock +get_lock fd = f_get_lock fd (fromEnum GetLock) + +set_lock :: Int -> FLock -> IO Int +set_lock fd lck = f_set_lock fd (fromEnum SetLock) lck diff --git a/tests/bugs/issue-15/Issue15.chs b/tests/bugs/issue-15/Issue15.chs new file mode 100644 --- /dev/null +++ b/tests/bugs/issue-15/Issue15.chs @@ -0,0 +1,16 @@ +module Main where + +import Foreign.C.Types +import Numeric +import Data.Char + +#include "issue15.h" + +{#enum Tst as ^ {underscoreToCase} deriving (Eq, Show)#} + +main :: IO () +main = do + tst <- {#call tst_val#} + let chk1 = showIntAtBase 16 intToDigit tst "" + chk2 = showIntAtBase 16 intToDigit (fromEnum Kclippingcreator) "" + print $ chk1 == chk2 diff --git a/tests/bugs/issue-15/issue15.c b/tests/bugs/issue-15/issue15.c new file mode 100644 --- /dev/null +++ b/tests/bugs/issue-15/issue15.c @@ -0,0 +1,4 @@ +const int tst_val(void) +{ + return 'drag'; +} diff --git a/tests/bugs/issue-15/issue15.h b/tests/bugs/issue-15/issue15.h new file mode 100644 --- /dev/null +++ b/tests/bugs/issue-15/issue15.h @@ -0,0 +1,9 @@ +const int tst_val(void); + +enum Tst { + kClippingCreator = 'drag', + kClippingPictureType = 'clpp', + kClippingTextType = 'clpt', + kClippingSoundType = 'clps', + kClippingUnknownType = 'clpu' +}; diff --git a/tests/bugs/issue-20/Issue20.chs b/tests/bugs/issue-20/Issue20.chs new file mode 100644 --- /dev/null +++ b/tests/bugs/issue-20/Issue20.chs @@ -0,0 +1,14 @@ +module Main where + +import Foreign.C + +#include "issue20.h" + +{#typedef size_t CSize#} +{#fun foo {`Int'} -> `CSize'#} + +main :: IO () +main = do + s1 <- foo 1 + s4 <- foo 4 + print $ s4 `div` s1 diff --git a/tests/bugs/issue-20/issue20.c b/tests/bugs/issue-20/issue20.c new file mode 100644 --- /dev/null +++ b/tests/bugs/issue-20/issue20.c @@ -0,0 +1,6 @@ +#include + +size_t foo(int n) +{ + return n * sizeof(int); +} diff --git a/tests/bugs/issue-20/issue20.h b/tests/bugs/issue-20/issue20.h new file mode 100644 --- /dev/null +++ b/tests/bugs/issue-20/issue20.h @@ -0,0 +1,3 @@ +#include + +size_t foo(int n); diff --git a/tests/bugs/issue-25/Issue25.chs b/tests/bugs/issue-25/Issue25.chs new file mode 100644 --- /dev/null +++ b/tests/bugs/issue-25/Issue25.chs @@ -0,0 +1,17 @@ +module Main where + +import Foreign +import Foreign.C + +#include + +{#typedef wchar_t CWchar#} +{#default in `String' [wchar_t *] withCWString* #} +{#default out `String' [wchar_t *] peekCWString* #} +{#fun wcscmp {`String', `String'} -> `Int'#} +{#fun wcscat {`String', `String'} -> `String'#} + +main :: IO () +main = do + wcscmp "abc" "def" >>= print + wcscat "abc" "def" >>= putStrLn diff --git a/tests/bugs/issue-48/Issue48.chs b/tests/bugs/issue-48/Issue48.chs new file mode 100644 --- /dev/null +++ b/tests/bugs/issue-48/Issue48.chs @@ -0,0 +1,16 @@ +module Main where + +import Foreign.C +import Foreign.C.Types + +#include "issue48.h" + +{#typedef int64_t CLong#} +{#default out `Int' [int64_t] fromIntegral#} +{#default in `Int' [int64_t] fromIntegral#} +{#fun foo {`Int'} -> `Int'#} + +main :: IO () +main = do + foo 1 >>= print + foo 4 >>= print diff --git a/tests/bugs/issue-48/issue48.c b/tests/bugs/issue-48/issue48.c new file mode 100644 --- /dev/null +++ b/tests/bugs/issue-48/issue48.c @@ -0,0 +1,6 @@ +#include "issue48.h" + +int64_t foo(int64_t n) +{ + return n + 1; +} diff --git a/tests/bugs/issue-48/issue48.h b/tests/bugs/issue-48/issue48.h new file mode 100644 --- /dev/null +++ b/tests/bugs/issue-48/issue48.h @@ -0,0 +1,3 @@ +#include + +int64_t foo(int64_t n); diff --git a/tests/bugs/issue-83/Issue83.chs b/tests/bugs/issue-83/Issue83.chs --- a/tests/bugs/issue-83/Issue83.chs +++ b/tests/bugs/issue-83/Issue83.chs @@ -15,6 +15,9 @@ {#fun getenv as ^ {`String'} -> `CString'#} {#fun sin as hsin {`Double'} -> `Double'#} {#fun sin as csin {`CDouble'} -> `CDouble'#} +{#fun malloc as ^ {`CULong'} -> `Ptr ()'#} +{#fun free as ^ {`Ptr ()'} -> `()'#} +{#fun strcpy as ^ {`CString', `CString'} -> `()'#} main :: IO () main = do @@ -23,7 +26,7 @@ withCString s2 $ \cs2 -> strcmp cs1 cs2 res2 <- withCString s2 $ \cs2 -> withCString s3 $ \cs3 -> strcmp cs2 cs3 - print (res1, res2) + print (res1 < 0, res2 == 0) void $ setenv "TEST_VAR" "TEST_VAL" 1 h <- getenv "TEST_VAR" peekCString h >>= putStrLn @@ -31,3 +34,11 @@ print (round (10000 * cx) :: Integer) hx <- hsin 1.0 print (round (10000 * hx) :: Integer) + let s = "TESTING" + p <- malloc $ fromIntegral $ length s + 1 + let ps = castPtr p :: CString + cs <- newCString s + strcpy ps cs + res <- peekCString ps + putStrLn res + free p diff --git a/tests/test-bugs.hs b/tests/test-bugs.hs --- a/tests/test-bugs.hs +++ b/tests/test-bugs.hs @@ -32,10 +32,13 @@ , testCase "Issue #7" issue07 , testCase "Issue #9" issue09 , testCase "Issue #10" issue10 + , testCase "Issue #15" issue15 , testCase "Issue #16" issue16 , testCase "Issue #19" issue19 + , testCase "Issue #20" issue20 , testCase "Issue #22" issue22 , testCase "Issue #23" issue23 + , testCase "Issue #25" issue25 , testCase "Issue #29" issue29 , testCase "Issue #30" issue30 , testCase "Issue #31" issue31 @@ -47,6 +50,7 @@ , testCase "Issue #45" issue45 , testCase "Issue #46" issue46 , testCase "Issue #47" issue47 + , testCase "Issue #48" issue48 , testCase "Issue #51" issue51 , testCase "Issue #54" issue54 , testCase "Issue #60" issue60 @@ -95,7 +99,7 @@ issue113 = build_issue 113 issue107 :: Assertion -issue107 = hs_only_expect_issue 107 ["True"] +issue107 = hs_only_expect_issue 107 True ["True"] issue103 :: Assertion issue103 = c2hsShelly $ chdir "tests/bugs/issue-103" $ do @@ -111,7 +115,10 @@ liftIO $ assertBool "" (T.lines res == expected) issue102 :: Assertion -issue102 = hs_only_expect_issue 102 ["TST 1: 1234", "TST 2: 13 47"] +issue102 = hs_only_expect_issue 102 False ["TST 1: 1234", + "TST 2: 13 47", + "TST 3: testing", + "Unlocked"] issue98 :: Assertion issue98 = build_issue 98 @@ -142,7 +149,8 @@ issue82 = hs_only_build_issue 82 issue83 :: Assertion -issue83 = hs_only_expect_issue 83 ["(-3,0)", "TEST_VAL", "8415", "8415"] +issue83 = hs_only_expect_issue 83 True ["(True,True)", "TEST_VAL", + "8415", "8415", "TESTING"] issue80 :: Assertion issue80 = build_issue 80 @@ -190,6 +198,9 @@ expect_issue_with True True 51 "nonGNU" [] ["0"] expect_issue_with True True 51 "GNU" [] ["1"] +issue48 :: Assertion +issue48 = expect_issue 48 ["2", "5"] + issue47 :: Assertion issue47 = build_issue 47 @@ -256,23 +267,35 @@ code <- lastExitCode liftIO $ assertBool "" (code == 0) +issue25 :: Assertion +issue25 = hs_only_expect_issue 25 True ["-1", "abcdef"] + issue23 :: Assertion issue23 = expect_issue 23 ["H1"] issue22 :: Assertion issue22 = expect_issue 22 ["abcdef", "2", "20"] +issue20 :: Assertion +issue20 = expect_issue 20 ["4"] + issue19 :: Assertion issue19 = expect_issue 19 ["Did it!"] issue16 :: Assertion issue16 = build_issue 16 +issue15 :: Assertion +issue15 = expect_issue 15 ["True"] + issue10 :: Assertion issue10 = expect_issue 10 ["SAME", "SAME", "SAME", "SAME"] issue09 :: Assertion -issue09 = expect_issue 9 ["PTA:8", "AOP:32", "(32,64)", "64", "OK"] +issue09 = expect_issue 9 $ archdep ++ ["(32,64)", "64", "OK"] + where archdep + | (maxBound::Int) == 2147483647 = ["PTA:4", "AOP:16"] -- 32 bit + | otherwise = ["PTA:8", "AOP:32"] -- 64 bit issue07 :: Assertion issue07 = c2hsShelly $ do @@ -307,8 +330,9 @@ unordered_expect_issue n expected = expect_issue_with False True n "" [] expected -hs_only_expect_issue :: Int -> [Text] -> Assertion -hs_only_expect_issue n expected = expect_issue_with True False n "" [] expected +hs_only_expect_issue :: Int -> Bool -> [Text] -> Assertion +hs_only_expect_issue n ordered expected = + expect_issue_with ordered False n "" [] expected expect_issue_with :: Bool -> Bool -> Int -> String -> [Text] -> [Text] -> Assertion