c2hs 0.22.1 → 0.23.1
raw patch · 21 files changed
+638/−191 lines, 21 files
Files
- ChangeLog +6/−0
- c2hs.cabal +5/−1
- src/C2HS/C/Info.hs +5/−71
- src/C2HS/CHS.hs +104/−23
- src/C2HS/CHS/Lexer.hs +56/−1
- src/C2HS/Gen/Bind.hs +217/−77
- src/C2HS/Gen/Header.hs +19/−2
- src/C2HS/Gen/Monad.hs +44/−5
- tests/bugs/issue-102/Issue102.chs +46/−4
- tests/bugs/issue-15/Issue15.chs +16/−0
- tests/bugs/issue-15/issue15.c +4/−0
- tests/bugs/issue-15/issue15.h +9/−0
- tests/bugs/issue-20/Issue20.chs +14/−0
- tests/bugs/issue-20/issue20.c +6/−0
- tests/bugs/issue-20/issue20.h +3/−0
- tests/bugs/issue-25/Issue25.chs +17/−0
- tests/bugs/issue-48/Issue48.chs +16/−0
- tests/bugs/issue-48/issue48.c +6/−0
- tests/bugs/issue-48/issue48.h +3/−0
- tests/bugs/issue-83/Issue83.chs +12/−1
- tests/test-bugs.hs +30/−6
ChangeLog view
@@ -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]
c2hs.cabal view
@@ -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
src/C2HS/C/Info.hs view
@@ -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
src/C2HS/CHS.hs view
@@ -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 _ :
src/C2HS/CHS/Lexer.hs view
@@ -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)
src/C2HS/Gen/Bind.hs view
@@ -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
src/C2HS/Gen/Header.hs view
@@ -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)
src/C2HS/Gen/Monad.hs view
@@ -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
tests/bugs/issue-102/Issue102.chs view
@@ -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 <stdio.h>+#include <fcntl.h> -{#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
+ tests/bugs/issue-15/Issue15.chs view
@@ -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
+ tests/bugs/issue-15/issue15.c view
@@ -0,0 +1,4 @@+const int tst_val(void)+{+ return 'drag';+}
+ tests/bugs/issue-15/issue15.h view
@@ -0,0 +1,9 @@+const int tst_val(void);++enum Tst {+ kClippingCreator = 'drag',+ kClippingPictureType = 'clpp',+ kClippingTextType = 'clpt',+ kClippingSoundType = 'clps',+ kClippingUnknownType = 'clpu'+};
+ tests/bugs/issue-20/Issue20.chs view
@@ -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
+ tests/bugs/issue-20/issue20.c view
@@ -0,0 +1,6 @@+#include <stdlib.h>++size_t foo(int n)+{+ return n * sizeof(int);+}
+ tests/bugs/issue-20/issue20.h view
@@ -0,0 +1,3 @@+#include <stdlib.h>++size_t foo(int n);
+ tests/bugs/issue-25/Issue25.chs view
@@ -0,0 +1,17 @@+module Main where++import Foreign+import Foreign.C++#include <wchar.h>++{#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
+ tests/bugs/issue-48/Issue48.chs view
@@ -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
+ tests/bugs/issue-48/issue48.c view
@@ -0,0 +1,6 @@+#include "issue48.h"++int64_t foo(int64_t n)+{+ return n + 1;+}
+ tests/bugs/issue-48/issue48.h view
@@ -0,0 +1,3 @@+#include <sys/types.h>++int64_t foo(int64_t n);
tests/bugs/issue-83/Issue83.chs view
@@ -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
tests/test-bugs.hs view
@@ -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