c2hs 0.16.2 → 0.16.3
raw patch · 8 files changed
+320/−133 lines, 8 filesdep ~containersdep ~filepath
Dependency ranges changed: containers, filepath
Files
- C2HS.hs +50/−32
- c2hs.cabal +2/−2
- src/C2HS/CHS.hs +57/−26
- src/C2HS/CHS/Lexer.hs +28/−13
- src/C2HS/Gen/Bind.hs +106/−48
- tests/system/Sizeof.chs +50/−11
- tests/system/sizeof.c +16/−0
- tests/system/sizeof.h +11/−1
C2HS.hs view
@@ -40,7 +40,7 @@ module Foreign, -- * Re-export the C language component of the FFI- module CForeign,+ module Foreign.C, -- * Composite marshalling functions withCStringLenIntConv, peekCStringLenIntConv, withIntConv, withFloatConv,@@ -58,12 +58,9 @@ import Foreign- hiding (Word)- -- Should also hide the Foreign.Marshal.Pool exports in- -- compilers that export them-import CForeign+import Foreign.C -import Monad (when, liftM)+import Monad (liftM) -- Composite marshalling functions@@ -71,28 +68,52 @@ -- Strings with explicit length ---withCStringLenIntConv s f = withCStringLen s $ \(p, n) -> f (p, cIntConv n)-peekCStringLenIntConv (s, n) = peekCStringLen (s, cIntConv n)+withCStringLenIntConv :: Num n => String -> ((CString, n) -> IO a) -> IO a+withCStringLenIntConv s f = withCStringLen s $ \(p, n) -> f (p, fromIntegral n) +peekCStringLenIntConv :: Integral n => (CString, n) -> IO String+peekCStringLenIntConv (s, n) = peekCStringLen (s, fromIntegral n)+ -- Marshalling of numerals -- withIntConv :: (Storable b, Integral a, Integral b) - => a -> (Ptr b -> IO c) -> IO c-withIntConv = with . cIntConv+ => a -> (Ptr b -> IO c) -> IO c+withIntConv = with . fromIntegral withFloatConv :: (Storable b, RealFloat a, RealFloat b) - => a -> (Ptr b -> IO c) -> IO c-withFloatConv = with . cFloatConv+ => a -> (Ptr b -> IO c) -> IO c+withFloatConv = with . realToFrac peekIntConv :: (Storable a, Integral a, Integral b) - => Ptr a -> IO b-peekIntConv = liftM cIntConv . peek+ => Ptr a -> IO b+peekIntConv = liftM fromIntegral . peek peekFloatConv :: (Storable a, RealFloat a, RealFloat b) - => Ptr a -> IO b-peekFloatConv = liftM cFloatConv . peek+ => Ptr a -> IO b+peekFloatConv = liftM realToFrac . peek ++-- Everything else below is deprecated.+-- These functions are not used by code generated by c2hs.++{-# DEPRECATED withBool "The C2HS module will soon stop providing unnecessary\nutility functions. Please use standard FFI library functions instead." #-}+{-# DEPRECATED peekBool "The C2HS module will soon stop providing unnecessary\nutility functions. Please use standard FFI library functions instead." #-}+{-# DEPRECATED withEnum "The C2HS module will soon stop providing unnecessary\nutility functions. Please use standard FFI library functions instead." #-}+{-# DEPRECATED peekEnum "The C2HS module will soon stop providing unnecessary\nutility functions. Please use standard FFI library functions instead." #-}+{-# DEPRECATED nothingIf "The C2HS module will soon stop providing unnecessary\nutility functions. Please use standard FFI library functions instead." #-}+{-# DEPRECATED nothingIfNull "The C2HS module will soon stop providing unnecessary\nutility functions. Please use standard FFI library functions instead." #-}+{-# DEPRECATED combineBitMasks "The C2HS module will soon stop providing unnecessary\nutility functions. Please use standard FFI library functions instead." #-}+{-# DEPRECATED containsBitMask "The C2HS module will soon stop providing unnecessary\nutility functions. Please use standard FFI library functions instead." #-}+{-# DEPRECATED extractBitMasks "The C2HS module will soon stop providing unnecessary\nutility functions. Please use standard FFI library functions instead." #-}+{-# DEPRECATED cIntConv "The C2HS module will soon stop providing unnecessary\nutility functions. Please use standard FFI library functions instead." #-}+{-# DEPRECATED cFloatConv "The C2HS module will soon stop providing unnecessary\nutility functions. Please use standard FFI library functions instead." #-}+{-# DEPRECATED cFromBool "The C2HS module will soon stop providing unnecessary\nutility functions. Please use standard FFI library functions instead." #-}+{-# DEPRECATED cToBool "The C2HS module will soon stop providing unnecessary\nutility functions. Please use standard FFI library functions instead." #-}+{-# DEPRECATED cToEnum "The C2HS module will soon stop providing unnecessary\nutility functions. Please use standard FFI library functions instead." #-}+{-# DEPRECATED cFromEnum "The C2HS module will soon stop providing unnecessary\nutility functions. Please use standard FFI library functions instead." #-}++ -- Passing Booleans by reference -- @@ -116,20 +137,22 @@ -- Storing of 'Maybe' values -- ------------------------- +--TODO: kill off this orphan instance!+ instance Storable a => Storable (Maybe a) where sizeOf _ = sizeOf (undefined :: Ptr ()) alignment _ = alignment (undefined :: Ptr ()) peek p = do- ptr <- peek (castPtr p)- if ptr == nullPtr- then return Nothing- else liftM Just $ peek ptr+ ptr <- peek (castPtr p)+ if ptr == nullPtr+ then return Nothing+ else liftM Just $ peek ptr poke p v = do- ptr <- case v of- Nothing -> return nullPtr- Just v' -> new v'+ ptr <- case v of+ Nothing -> return nullPtr+ Just v' -> new v' poke (castPtr p) ptr @@ -167,8 +190,8 @@ -- containsBitMask :: (Bits a, Enum b) => a -> b -> Bool bits `containsBitMask` bm = let bm' = fromIntegral . fromEnum $ bm- in- bm' .&. bits == bm'+ in+ bm' .&. bits == bm' -- |Given a bit pattern, yield all bit masks that it contains. --@@ -193,11 +216,6 @@ -- cFloatConv :: (RealFloat a, RealFloat b) => a -> b cFloatConv = realToFrac--- As this conversion by default goes via `Rational', it can be very slow...-{-# RULES - "cFloatConv/Float->Float" forall (x::Float). cFloatConv x = x;- "cFloatConv/Double->Double" forall (x::Double). cFloatConv x = x- #-} -- |Obtain C value from Haskell 'Bool'. --@@ -212,9 +230,9 @@ -- |Convert a C enumeration to Haskell. -- cToEnum :: (Integral i, Enum e) => i -> e-cToEnum = toEnum . cIntConv+cToEnum = toEnum . fromIntegral -- |Convert a Haskell enumeration to C. -- cFromEnum :: (Enum e, Integral i) => e -> i-cFromEnum = cIntConv . fromEnum+cFromEnum = fromIntegral . fromEnum
c2hs.cabal view
@@ -1,5 +1,5 @@ Name: c2hs-Version: 0.16.2+Version: 0.16.3 License: GPL-2 License-File: COPYING Copyright: Copyright (c) 1999-2007 Manuel M T Chakravarty@@ -81,4 +81,4 @@ extensions: ForeignFunctionInterface c-sources: src/C2HS/config.c --TODO: eliminate the need to suppress these warnings:- ghc-options: -Wall -fno-warn-incomplete-patterns+ ghc-options: -Wall -fno-warn-incomplete-patterns -fwarn-tabs
src/C2HS/CHS.hs view
@@ -63,7 +63,8 @@ -- prefix -> `prefix' `=' string -- deriving -> `deriving' `(' ident_1 `,' ... `,' ident_n `)' -- parms -> [verbhs `=>'] `{' parm_1 `,' ... `,' parm_n `}' `->' parm--- parm -> [ident_1 [`*' | `-']] verbhs [`&'] [ident_2 [`*'] [`-']]+-- parm -> [ident_or_quot_1 [`*' | `-']] verbhs [`&'] [ident_or_quot_2 [`*'] [`-']]+-- ident_or_quot -> ident | quoths -- apath -> ident -- | `*' apath -- | apath `.' ident@@ -87,7 +88,7 @@ -- module C2HS.CHS (CHSModule(..), CHSFrag(..), CHSHook(..), CHSTrans(..),- CHSChangeCase(..), CHSParm(..), CHSArg(..), CHSAccess(..),+ CHSChangeCase(..), CHSParm(..), CHSMarsh, CHSArg(..), CHSAccess(..), CHSAPath(..), CHSPtrType(..), loadCHS, dumpCHS, hssuffix, chssuffix, loadCHI, dumpCHI, chisuffix, showCHSParm, apathToIdent)@@ -115,7 +116,6 @@ -- friends import C2HS.CHS.Lexer (CHSToken(..), lexCHS, keywordToIdent) - -- CHS abstract syntax -- ------------------- @@ -173,6 +173,8 @@ Position | CHSSizeof Ident -- C type Position+ | CHSAlignof Ident -- C type+ Position | CHSEnum Ident -- C enumeration type (Maybe Ident) -- Haskell name CHSTrans -- translation table@@ -217,6 +219,7 @@ posOf (CHSContext _ _ pos) = pos posOf (CHSType _ pos) = pos posOf (CHSSizeof _ pos) = pos+ posOf (CHSAlignof _ pos) = pos posOf (CHSEnum _ _ _ _ _ pos) = pos posOf (CHSEnumDefine _ _ _ pos) = pos posOf (CHSCall _ _ _ _ pos) = pos@@ -237,6 +240,8 @@ ide1 == ide2 (CHSSizeof ide1 _) == (CHSSizeof ide2 _) = ide1 == ide2+ (CHSAlignof ide1 _) == (CHSAlignof ide2 _) =+ ide1 == ide2 (CHSEnum ide1 oalias1 _ _ _ _) == (CHSEnum ide2 oalias2 _ _ _ _) = oalias1 == oalias2 && ide1 == ide2 (CHSEnumDefine ide1 _ _ _) == (CHSEnumDefine ide2 _ _ _) =@@ -266,15 +271,17 @@ | CHSDownCase deriving Eq --- | marshalling descriptor for function hooks+-- | marshaller consists of a function name or verbatim Haskell code+-- and flag indicating whether it has to be executed in the IO monad ----- * a marshaller consists of a function name and flag indicating whether it--- has to be executed in the IO monad+type CHSMarsh = Maybe (Either Ident String, CHSArg)++-- | marshalling descriptor for function hooks ---data CHSParm = CHSParm (Maybe (Ident, CHSArg)) -- "in" marshaller- String -- Haskell type- Bool -- C repr: two values?- (Maybe (Ident, CHSArg)) -- "out" marshaller+data CHSParm = CHSParm CHSMarsh -- "in" marshaller+ String -- Haskell type+ Bool -- C repr: two values?+ CHSMarsh -- "out" marshaller Position -- | kinds of arguments in function hooks@@ -478,6 +485,9 @@ showCHSHook (CHSSizeof ide _) = showString "sizeof " . showCHSIdent ide+showCHSHook (CHSAlignof ide _) =+ showString "alignof "+ . showCHSIdent ide showCHSHook (CHSEnum ide oalias trans oprefix derive _) = showString "enum " . showIdAlias ide oalias@@ -574,13 +584,16 @@ . showOMarsh oomMarsh where showOMarsh Nothing = id- showOMarsh (Just (ide, argKind)) = showCHSIdent ide- . (case argKind of- CHSValArg -> id- CHSIOArg -> showString "*"- CHSVoidArg -> showString "-"- CHSIOVoidArg -> showString "*-")+ showOMarsh (Just (body, argKind)) = showMarshBody body+ . (case argKind of+ CHSValArg -> id+ CHSIOArg -> showString "*"+ CHSVoidArg -> showString "-"+ CHSIOVoidArg -> showString "*-") --+ showMarshBody (Left ide) = showCHSIdent ide+ showMarshBody (Right str) = showChar '|' . showString str . showChar '|'+ -- showHsVerb str = showChar '`' . showString str . showChar '\'' showCHSTrans :: CHSTrans -> ShowS@@ -775,6 +788,7 @@ parseFrags0 (CHSTokContext pos :toks) = parseContext pos toks parseFrags0 (CHSTokType pos :toks) = parseType pos toks parseFrags0 (CHSTokSizeof pos :toks) = parseSizeof pos toks+ parseFrags0 (CHSTokAlignof pos :toks) = parseAlignof pos toks parseFrags0 (CHSTokEnum pos :toks) = parseEnum pos toks parseFrags0 (CHSTokCall pos :toks) = parseCall pos toks parseFrags0 (CHSTokFun pos :toks) = parseFun pos toks@@ -862,6 +876,14 @@ return $ CHSHook (CHSSizeof ide pos) : frags parseSizeof _ toks = syntaxError toks +parseAlignof :: Position -> [CHSToken] -> CST s [CHSFrag]+parseAlignof pos (CHSTokIdent _ ide:toks) =+ do+ toks' <- parseEndHook toks+ frags <- parseFrags toks'+ return $ CHSHook (CHSAlignof ide pos) : frags+parseAlignof _ toks = syntaxError toks+ parseEnum :: Position -> [CHSToken] -> CST s [CHSFrag] -- {#enum define hsid {alias_1,...,alias_n} [deriving (clid_1,...,clid_n)] #}@@ -977,17 +999,26 @@ (oomMarsh, toks'3) <- parseOptMarsh toks'2 return (CHSParm oimMarsh hsTyStr twoCVals oomMarsh pos, toks'3) where- parseOptMarsh :: [CHSToken] -> CST s (Maybe (Ident, CHSArg), [CHSToken])- parseOptMarsh (CHSTokIdent _ ide:CHSTokStar _ :CHSTokMinus _:toks') =- return (Just (ide, CHSIOVoidArg) , toks')- parseOptMarsh (CHSTokIdent _ ide:CHSTokStar _ :toks') =- return (Just (ide, CHSIOArg) , toks')- parseOptMarsh (CHSTokIdent _ ide:CHSTokMinus _:toks') =- return (Just (ide, CHSVoidArg), toks')- parseOptMarsh (CHSTokIdent _ ide :toks') =- return (Just (ide, CHSValArg) , toks')- parseOptMarsh toks' =+ parseOptMarsh :: [CHSToken] -> CST s (CHSMarsh, [CHSToken])+ parseOptMarsh (CHSTokIdent _ ide:toks') =+ do+ (marshType, toks'2) <- parseOptMarshType toks'+ return (Just (Left ide, marshType), toks'2)+ parseOptMarsh (CHSTokHSQuot _ str:toks') =+ do+ (marshType, toks'2) <- parseOptMarshType toks'+ return (Just (Right str, marshType), toks'2)+ parseOptMarsh toks' = return (Nothing, toks')++ parseOptMarshType (CHSTokStar _ :CHSTokMinus _:toks') =+ return (CHSIOVoidArg , toks')+ parseOptMarshType (CHSTokStar _ :toks') =+ return (CHSIOArg , toks')+ parseOptMarshType (CHSTokMinus _:toks') =+ return (CHSVoidArg, toks')+ parseOptMarshType toks' =+ return (CHSValArg, toks') parseField :: Position -> CHSAccess -> [CHSToken] -> CST s [CHSFrag] parseField pos access toks =
src/C2HS/CHS/Lexer.hs view
@@ -87,7 +87,6 @@ -- transfers control to the following binding-hook lexer: -- -- ident -> letter (letter | digit | `\'')*--- | `\'' letter (letter | digit)* `\'' -- reservedid -> `as' | `call' | `class' | `context' | `deriving' -- | `enum' | `foreign' | `fun' | `get' | `lib' -- | `downcaseFirstLetter'@@ -98,14 +97,18 @@ -- reservedsym -> `{#' | `#}' | `{' | `}' | `,' | `.' | `->' | `=' -- | `=>' | '-' | `*' | `&' | `^' -- string -> `"' instr* `"'--- verbhs -> `\`' instr* `\''+-- verbhs -> `\`' inhsverb* `\''+-- quoths -> `\'' inhsverb* `\'' -- instr -> ` '..`\127' \\ `"'+-- inhsverb -> ` '..`\127' \\ `\'' -- comment -> `--' (any \\ `\n')* `\n' -- -- Control characters, white space, and comments are discarded in the -- binding-hook lexer. Nested comments are not allowed in a binding hook. -- Identifiers can be enclosed in single quotes to avoid collision with--- C->Haskell keywords.+-- C->Haskell keywords, and in this case quoted part could also be followed by+-- what is assumed to be a valid Haskell code, which would be transferred in the+-- output file verbatim. -- -- * In the binding-hook lexer, the lexeme `#}' transfers control back to the -- base lexer. An occurence of the lexeme `{#' inside the binding-hook@@ -128,8 +131,7 @@ -- is accepted by the C lexer. In the case of Haskell identifiers, a -- confusion between variable and constructor identifiers will be noted by -- the Haskell compiler translating the code generated by c2hs. Moreover,--- identifiers can be enclosed in single quotes to avoid collision with--- C->Haskell keywords, but those may not contain apostrophes.+-- identifiers that are inside quoted parts (see above) may not contain apostrophes. -- -- * Any line starting with the character `#' is regarded to be a C -- preprocessor directive. With the exception of `#c' and `#endc', which@@ -223,6 +225,7 @@ | CHSTokQualif Position -- `qualified' | CHSTokSet Position -- `set' | CHSTokSizeof Position -- `sizeof'+ | CHSTokAlignof Position -- `alignof' | CHSTokStable Position -- `stable' | CHSTokType Position -- `type' | CHSTok_2Case Position -- `underscoreToCase'@@ -231,6 +234,7 @@ | CHSTokWith Position -- `with' | CHSTokString Position String -- string | CHSTokHSVerb Position String -- verbatim Haskell (`...')+ | CHSTokHSQuot Position String -- quoted Haskell ('...') | CHSTokIdent Position Ident -- identifier | CHSTokHaskell Position String -- verbatim Haskell code | CHSTokCPP Position String -- pre-processor directive@@ -273,6 +277,7 @@ posOf (CHSTokQualif pos ) = pos posOf (CHSTokSet pos ) = pos posOf (CHSTokSizeof pos ) = pos+ posOf (CHSTokAlignof pos ) = pos posOf (CHSTokStable pos ) = pos posOf (CHSTokType pos ) = pos posOf (CHSTok_2Case pos ) = pos@@ -281,6 +286,7 @@ posOf (CHSTokWith pos ) = pos posOf (CHSTokString pos _) = pos posOf (CHSTokHSVerb pos _) = pos+ posOf (CHSTokHSQuot pos _) = pos posOf (CHSTokIdent pos _) = pos posOf (CHSTokHaskell pos _) = pos posOf (CHSTokCPP pos _) = pos@@ -323,6 +329,7 @@ (CHSTokQualif _ ) == (CHSTokQualif _ ) = True (CHSTokSet _ ) == (CHSTokSet _ ) = True (CHSTokSizeof _ ) == (CHSTokSizeof _ ) = True+ (CHSTokAlignof _ ) == (CHSTokAlignof _ ) = True (CHSTokStable _ ) == (CHSTokStable _ ) = True (CHSTokType _ ) == (CHSTokType _ ) = True (CHSTok_2Case _ ) == (CHSTok_2Case _ ) = True@@ -331,6 +338,7 @@ (CHSTokWith _ ) == (CHSTokWith _ ) = True (CHSTokString _ _) == (CHSTokString _ _) = True (CHSTokHSVerb _ _) == (CHSTokHSVerb _ _) = True+ (CHSTokHSQuot _ _) == (CHSTokHSQuot _ _) = True (CHSTokIdent _ _) == (CHSTokIdent _ _) = True (CHSTokHaskell _ _) == (CHSTokHaskell _ _) = True (CHSTokCPP _ _) == (CHSTokCPP _ _) = True@@ -374,6 +382,7 @@ showsPrec _ (CHSTokQualif _ ) = showString "qualified" showsPrec _ (CHSTokSet _ ) = showString "set" showsPrec _ (CHSTokSizeof _ ) = showString "sizeof"+ showsPrec _ (CHSTokAlignof _ ) = showString "alignof" showsPrec _ (CHSTokStable _ ) = showString "stable" showsPrec _ (CHSTokType _ ) = showString "type" showsPrec _ (CHSTok_2Case _ ) = showString "underscoreToCase"@@ -382,6 +391,7 @@ showsPrec _ (CHSTokWith _ ) = showString "with" showsPrec _ (CHSTokString _ s) = showString ("\"" ++ s ++ "\"") showsPrec _ (CHSTokHSVerb _ s) = showString ("`" ++ s ++ "'")+ showsPrec _ (CHSTokHSQuot _ s) = showString ("'" ++ s ++ "'") showsPrec _ (CHSTokIdent _ i) = (showString . identToString) i showsPrec _ (CHSTokHaskell _ s) = showString s showsPrec _ (CHSTokCPP _ s) = showString s@@ -627,6 +637,7 @@ >||< symbol >||< strlit >||< hsverb+ >||< hsquot >||< whitespace >||< endOfHook >||< string "--" +> anyButNL`star` char '\n' -- comment@@ -672,10 +683,6 @@ -- identifier or keyword (letter +> (letter >|< digit >|< char '\'')`star` epsilon `lexactionName` \cs pos name -> (idkwtok $!pos) cs name)- >||< -- identifier in single quotes- (char '\'' +> letter +> (letter >|< digit)`star` char '\''- `lexactionName` \cs pos name -> (mkid $!pos) cs name)- -- NB: quotes are removed by lexemeToIdent where idkwtok pos "as" _ = CHSTokAs pos idkwtok pos "call" _ = CHSTokCall pos@@ -697,6 +704,7 @@ idkwtok pos "qualified" _ = CHSTokQualif pos idkwtok pos "set" _ = CHSTokSet pos idkwtok pos "sizeof" _ = CHSTokSizeof pos+ idkwtok pos "alignof" _ = CHSTokAlignof pos idkwtok pos "stable" _ = CHSTokStable pos idkwtok pos "type" _ = CHSTokType pos idkwtok pos "underscoreToCase" _ = CHSTok_2Case pos@@ -730,6 +738,7 @@ CHSTokQualif pos -> mkid pos "qualified" CHSTokSet pos -> mkid pos "set" CHSTokSizeof pos -> mkid pos "sizeof"+ CHSTokAlignof pos -> mkid pos "alignof" CHSTokStable pos -> mkid pos "stable" CHSTokType pos -> mkid pos "type" CHSTok_2Case pos -> mkid pos "underscoreToCase"@@ -770,14 +779,20 @@ hsverb = char '`' +> inhsverb`star` char '\'' `lexaction` \cs pos -> Just (CHSTokHSVerb pos (init . tail $ cs)) +-- | quoted code+--+hsquot :: CHSLexer+hsquot = char '\'' +> inhsverb`star` char '\''+ `lexaction` \cs pos -> Just (CHSTokHSQuot pos (init . tail $ cs)) + -- | regular expressions -- letter, digit, instr, inhsverb :: Regexp s t-letter = alt ['a'..'z'] >|< alt ['A'..'Z'] >|< char '_'-digit = alt ['0'..'9']-instr = alt ([' '..'\255'] \\ "\"\\")-inhsverb = alt ([' '..'\127'] \\ "\'")+letter = alt ['a'..'z'] >|< alt ['A'..'Z'] >|< char '_'+digit = alt ['0'..'9']+instr = alt ([' '..'\255'] \\ "\"\\")+inhsverb = alt ([' '..'\127'] \\ "'") -- | character sets --
src/C2HS/Gen/Bind.hs view
@@ -1,5 +1,4 @@ -- C->Haskell Compiler: binding generator--- vim:ts=8:noexpandtab -- -- Copyright (c) [1999..2003] Manuel M T Chakravarty --@@ -128,7 +127,7 @@ SwitchBoard(..), Traces(..), putTraceStr, getSwitch) import C2HS.C (AttrC, CObj(..), CTag(..), CDecl(..), CDeclSpec(..), CTypeSpec(..),- CStructUnion(..), CStructTag(..), CEnum(..), CDeclr(..),+ CStructUnion(..), CStructTag(..), CEnum(..), CDeclr(..), CAttr(..), CDerivedDeclr(..),CArrSize(..), CExpr(..), CBinaryOp(..), CUnaryOp(..), CConst (..), CInteger(..),cInteger,getCInteger,getCCharAsInt,@@ -141,11 +140,11 @@ checkForAlias, checkForOneAliasName, checkForOneCUName, lookupEnum, lookupStructUnion, lookupDeclOrTag, isPtrDeclr, dropPtrDeclr, isPtrDecl, getDeclOf, isFunDeclr,- refersToNewDef, CDef(..))+ refersToNewDef, partitionDeclSpecs, CDef(..)) -- friends import C2HS.CHS (CHSModule(..), CHSFrag(..), CHSHook(..),- CHSParm(..), CHSArg(..), CHSAccess(..), CHSAPath(..),+ CHSParm(..), CHSMarsh, CHSArg(..), CHSAccess(..), CHSAPath(..), CHSPtrType(..), showCHSParm, apathToIdent) import C2HS.C.Info (CPrimType(..), alignment, getPlatform) import qualified C2HS.C.Info as CInfo@@ -154,7 +153,6 @@ delayCode, getDelayedCode, ptrMapsTo, queryPtr, objIs, queryClass, queryPointer, mergeMaps, dumpMaps) - -- default marshallers -- ------------------- @@ -166,55 +164,55 @@ -- | determine the default "in" marshaller for the given Haskell and C types ---lookupDftMarshIn :: String -> [ExtType] -> GB (Maybe (Ident, CHSArg))+lookupDftMarshIn :: String -> [ExtType] -> GB CHSMarsh lookupDftMarshIn "Bool" [PrimET pt] | isIntegralCPrimType pt =- return $ Just (cFromBoolIde, CHSValArg)+ return $ Just (Left cFromBoolIde, CHSValArg) lookupDftMarshIn hsTy [PrimET pt] | isIntegralHsType hsTy &&isIntegralCPrimType pt =- return $ Just (cIntConvIde, CHSValArg)+ return $ Just (Left cIntConvIde, CHSValArg) lookupDftMarshIn hsTy [PrimET pt] | isFloatHsType hsTy &&isFloatCPrimType pt =- return $ Just (cFloatConvIde, CHSValArg)+ return $ Just (Left cFloatConvIde, CHSValArg) lookupDftMarshIn "String" [PtrET (PrimET CCharPT)] =- return $ Just (withCStringIde, CHSIOArg)+ return $ Just (Left withCStringIde, CHSIOArg) lookupDftMarshIn "String" [PtrET (PrimET CCharPT), PrimET pt] | isIntegralCPrimType pt =- return $ Just (withCStringLenIde, CHSIOArg)+ return $ Just (Left withCStringLenIde, CHSIOArg) lookupDftMarshIn hsTy [PtrET ty] | showExtType ty == hsTy =- return $ Just (withIde, CHSIOArg)+ return $ Just (Left withIde, CHSIOArg) lookupDftMarshIn hsTy [PtrET (PrimET pt)] | isIntegralHsType hsTy && isIntegralCPrimType pt =- return $ Just (withIntConvIde, CHSIOArg)+ return $ Just (Left withIntConvIde, CHSIOArg) lookupDftMarshIn hsTy [PtrET (PrimET pt)] | isFloatHsType hsTy && isFloatCPrimType pt =- return $ Just (withFloatConvIde, CHSIOArg)+ return $ Just (Left withFloatConvIde, CHSIOArg) lookupDftMarshIn "Bool" [PtrET (PrimET pt)] | isIntegralCPrimType pt =- return $ Just (withFromBoolIde, CHSIOArg)+ return $ Just (Left withFromBoolIde, CHSIOArg) -- FIXME: handle array-list conversion lookupDftMarshIn _ _ = return Nothing -- | determine the default "out" marshaller for the given Haskell and C types ---lookupDftMarshOut :: String -> [ExtType] -> GB (Maybe (Ident, CHSArg))+lookupDftMarshOut :: String -> [ExtType] -> GB CHSMarsh lookupDftMarshOut "()" _ =- return $ Just (voidIde, CHSVoidArg)+ return $ Just (Left voidIde, CHSVoidArg) lookupDftMarshOut "Bool" [PrimET pt] | isIntegralCPrimType pt =- return $ Just (cToBoolIde, CHSValArg)+ return $ Just (Left cToBoolIde, CHSValArg) lookupDftMarshOut hsTy [PrimET pt] | isIntegralHsType hsTy &&isIntegralCPrimType pt =- return $ Just (cIntConvIde, CHSValArg)+ return $ Just (Left cIntConvIde, CHSValArg) lookupDftMarshOut hsTy [PrimET pt] | isFloatHsType hsTy &&isFloatCPrimType pt =- return $ Just (cFloatConvIde, CHSValArg)+ return $ Just (Left cFloatConvIde, CHSValArg) lookupDftMarshOut "String" [PtrET (PrimET CCharPT)] =- return $ Just (peekCStringIde, CHSIOArg)+ return $ Just (Left peekCStringIde, CHSIOArg) lookupDftMarshOut "String" [PtrET (PrimET CCharPT), PrimET pt] | isIntegralCPrimType pt =- return $ Just (peekCStringLenIde, CHSIOArg)+ return $ Just (Left peekCStringLenIde, CHSIOArg) lookupDftMarshOut hsTy [PtrET ty] | showExtType ty == hsTy =- return $ Just (peekIde, CHSIOArg)+ return $ Just (Left peekIde, CHSIOArg) -- FIXME: add combination, such as "peek" plus "cIntConv" etc -- FIXME: handle array-list conversion lookupDftMarshOut _ _ =@@ -272,20 +270,24 @@ withFloatConvIde, withFromBoolIde, peekIde, peekCStringIde, peekCStringLenIde :: Ident voidIde = internalIdent "void" -- never appears in the output-cFromBoolIde = internalIdent "cFromBool"-cToBoolIde = internalIdent "cToBool"-cIntConvIde = internalIdent "cIntConv"-cFloatConvIde = internalIdent "cFloatConv"+cFromBoolIde = internalIdent "fromBool"+cToBoolIde = internalIdent "toBool"+cIntConvIde = internalIdent "fromIntegral"+cFloatConvIde = internalIdent "realToFrac" withIde = internalIdent "with" withCStringIde = internalIdent "withCString"-withCStringLenIde = internalIdent "withCStringLenIntConv"-withIntConvIde = internalIdent "withIntConv"-withFloatConvIde = internalIdent "withFloatConv"-withFromBoolIde = internalIdent "withFromBoolConv"+withCStringLenIde = internalIdent "withCStringLenIntConv" --TODO: kill off+withIntConvIde = internalIdent "withIntConv" --TODO: kill off+withFloatConvIde = internalIdent "withFloatConv" --TODO: kill off+withFromBoolIde = internalIdent "withFromBoolConv" --TODO: kill off peekIde = internalIdent "peek" peekCStringIde = internalIdent "peekCString"-peekCStringLenIde = internalIdent "peekCStringLenIntConv"+peekCStringLenIde = internalIdent "peekCStringLenIntConv" --TODO: kill off +--TODO: c2hs should not generate these references to externally defined+-- non-standard utility functions. It's annoying and they are all trivial.+-- The solutionis to generate expressions inline, rather than requiring all+-- marshalers be single identifiers. -- expansion of binding hooks -- --------------------------@@ -404,6 +406,19 @@ traceInfoDump decl ty = traceGenBind $ "Declaration\n" ++ show decl ++ "\ntranslates to\n" ++ showExtType ty ++ "\n"+expandHook (CHSAlignof ide _) =+ do+ traceInfoAlignof+ decl <- findAndChaseDecl ide False True -- no indirection, but shadows+ (_, align) <- sizeAlignOf decl+ traceInfoDump (render $ pretty decl) align+ return $ show align+ where+ traceInfoAlignof = traceGenBind "** alignment hook:\n"+ traceInfoDump decl align = traceGenBind $+ "Alignment of declaration\n" ++ show decl ++ "\nis "+ ++ show align ++ "\n"+ expandHook (CHSSizeof ide _) = do traceInfoSizeof@@ -769,7 +784,8 @@ extType <- extractFunType pos cdecl isPure header <- getSwitch headerSB when (isVariadic extType) (variadicErr pos (posOf cdecl))- delayCode hook (foreignImport header ideLexeme hsLexeme isUns extType)+ delayCode hook (foreignImport (extractCallingConvention cdecl)+ header ideLexeme hsLexeme isUns extType) traceFunType extType where traceFunType et = traceGenBind $@@ -791,9 +807,10 @@ -- | Haskell code for the foreign import declaration needed by a call hook ---foreignImport :: String -> String -> String -> Bool -> ExtType -> String-foreignImport header ident hsIdent isUnsafe ty =- "foreign import ccall " ++ safety ++ " " ++ show entity +++foreignImport :: CallingConvention -> String -> String -> String -> Bool -> ExtType -> String+foreignImport cconv header ident hsIdent isUnsafe ty =+ "foreign import " ++ showCallingConvention cconv ++ " " ++ safety+ ++ " " ++ show entity ++ "\n " ++ hsIdent ++ " :: " ++ showExtType ty ++ "\n" where safety = if isUnsafe then "unsafe" else "safe"@@ -856,15 +873,19 @@ join (take 1 callArgs) ++ " >>= \\b1' ->\n" marshRes = case parm' of- CHSParm _ _ _twoCVal (Just (_ , CHSVoidArg)) _ -> ""- CHSParm _ _ _twoCVal (Just (omIde, CHSIOVoidArg)) _ ->- " " ++ identToString omIde ++ " res >> \n"- CHSParm _ _ _twoCVal (Just (omIde, CHSIOArg )) _ ->- " " ++ identToString omIde ++ " res >>= \\res' ->\n"- CHSParm _ _ _twoCVal (Just (omIde, CHSValArg )) _ ->- " let {res' = " ++ identToString omIde ++ " res} in\n"+ CHSParm _ _ _twoCVal (Just (_ , CHSVoidArg )) _ -> ""+ CHSParm _ _ _twoCVal (Just (omBody, CHSIOVoidArg)) _ ->+ " " ++ marshBody omBody ++ " res >> \n"+ CHSParm _ _ _twoCVal (Just (omBody, CHSIOArg )) _ ->+ " " ++ marshBody omBody ++ " res >>= \\res' ->\n"+ CHSParm _ _ _twoCVal (Just (omBody, CHSValArg )) _ ->+ " let {res' = " ++ marshBody omBody ++ " res} in\n" CHSParm _ _ _ Nothing _ -> interr "GenBind.funDef: marshRes: no default?"++ marshBody (Left ide) = identToString ide+ marshBody (Right str) = str+ retArgs' = case parm' of CHSParm _ _ _ (Just (_, CHSVoidArg)) _ -> retArgs CHSParm _ _ _ (Just (_, CHSIOVoidArg)) _ -> retArgs@@ -912,11 +933,11 @@ -- for an argument marshaller, generate all "in" and "out" marshalling -- code fragments --- marshArg i (CHSParm (Just (imIde, imArgKind)) _ twoCVal- (Just (omIde, omArgKind)) _ ) =+ marshArg i (CHSParm (Just (imBody, imArgKind)) _ twoCVal+ (Just (omBody, omArgKind)) _ ) = let a = "a" ++ show (i :: Int)- imStr = identToString imIde+ imStr = marshBody imBody imApp = imStr ++ " " ++ a funArg = if imArgKind == CHSVoidArg then "" else a inBndr = if twoCVal@@ -930,7 +951,7 @@ callArgs = if twoCVal then [a ++ "'1 ", a ++ "'2"] else [a ++ "'"]- omApp = identToString omIde ++ join callArgs+ omApp = marshBody omBody ++ " " ++ join callArgs outBndr = a ++ "''" marshOut = case omArgKind of CHSVoidArg -> ""@@ -939,6 +960,9 @@ CHSValArg -> "let {" ++ outBndr ++ " = " ++ omApp ++ "} in " retArg = if omArgKind == CHSVoidArg || omArgKind == CHSIOVoidArg then "" else outBndr++ marshBody (Left ide) = identToString ide+ marshBody (Right str) = str in (funArg, marshIn, callArgs, marshOut, retArg) marshArg _ _ = interr "GenBind.funDef: Missing default?"@@ -1027,7 +1051,7 @@ -- addDftVoid marsh@(Just (_, kind)) = return (marsh, kind == CHSIOArg) addDftVoid Nothing = do- return (Just (internalIdent "void", CHSVoidArg), False)+ return (Just (Left (internalIdent "void"), CHSVoidArg), False) -- | compute from an access path, the declarator finally accessed and the index -- path required for the access@@ -1703,7 +1727,40 @@ int = CIntType undefined signed = CSignedType undefined +-- handle calling convention+-- ------------------------- +data CallingConvention = StdCallConv+ | CCallConv+ deriving (Eq)++-- | determine the calling convention for the provided decl+extractCallingConvention :: CDecl -> CallingConvention+extractCallingConvention cdecl+ | hasStdCallAttr cdecl = StdCallConv+ | otherwise = CCallConv+ where+ isStdCallAttr (CAttr x _ _) = identToString x == "stdcall"+ || identToString x == "__stdcall__"++ hasStdCallAttr = any isStdCallAttr . funAttrs++ funAttrs (CDecl specs declrs _) =+ let (_,attrs',_,_,_) = partitionDeclSpecs specs+ in attrs' ++ funEndAttrs declrs++ -- attrs after the function name, e.g. void foo() __attribute__((...));+ funEndAttrs [(Just ((CDeclr _ (CFunDeclr _ _ _ : _) _ attrs _)), _, _)] = attrs+ funEndAttrs _ = []+++-- | generate the necessary parameter for "foreign import" for the+-- provided calling convention+showCallingConvention :: CallingConvention -> String+showCallingConvention StdCallConv = "stdcall"+showCallingConvention CCallConv = "ccall"++ -- offset and size computations -- ---------------------------- @@ -1778,6 +1835,7 @@ align' = if align > 0 then align else bitfieldAlignment alignOfStruct = preAlign `max` align' return (sizeOfStruct, alignOfStruct)+ sizeAlignOfStruct decls CUnionTag = do PlatformSpec {bitfieldAlignmentPS = bitfieldAlignment} <- getPlatform
tests/system/Sizeof.chs view
@@ -1,15 +1,54 @@ module Main where+ import Monad (liftM, when)-import C2HS+import Foreign.C main = do- let sz1 = {# sizeof S1 #}- sz1expect <- liftM cIntConv $ {# call size_of_s1 #}- when (sz1 /= sz1expect) $ error "Fatal: sizeof s1 != size_of_s1()"- let sz2 = {# sizeof S2 #}- sz2expect <- liftM cIntConv $ {# call size_of_s2 #}- when (sz2 /= sz2expect) $ error "Fatal: sizeof s2 != size_of_s2()"- let sz3 = {# sizeof S3 #}- sz3expect <- liftM cIntConv $ {# call size_of_s3 #}- when (sz3 /= sz3expect) $ error $ "Fatal: sizeof s3 != size_of_s3(): " ++ show sz3 ++ " but expected " ++ show sz3expect- putStrLn (show sz1 ++ " & " ++ show sz2 ++ " & " ++ show sz3)+ size+ alignment++size = do+ let sz1 = {# sizeof S1 #}+ sz1expect <- liftM fromIntegral {# call size_of_s1 #}+ when (sz1 /= sz1expect) $ fail "Fatal: sizeof s1 != size_of_s1()"++ let sz2 = {# sizeof S2 #}+ sz2expect <- liftM fromIntegral {# call size_of_s2 #}+ when (sz2 /= sz2expect) $ fail "Fatal: sizeof s2 != size_of_s2()"++ -- small bitfield in struct gets wrong size, should be sizeof int, c2hs gets 1+ -- http://hackage.haskell.org/trac/c2hs/ticket/10+ let sz3 = {# sizeof S3 #}+ sz3expect <- liftM fromIntegral {# call size_of_s3 #}+ when (sz3 /= sz3expect) $ fail $ "Fatal: sizeof s3 != size_of_s3(): " ++ show sz3 ++ " but expected " ++ show sz3expect++ let sz4 = {# sizeof S4 #}+ sz4expect <- liftM fromIntegral {# call size_of_s4 #}+ when (sz4 /= sz4expect) $ fail $ "Fatal: sizeof s4 != size_of_s4(): " ++ show sz4 ++ " but expected " ++ show sz4expect++ putStrLn $ show sz1 ++ " & "+ ++ show sz2 ++ " & "+ ++ show sz3 ++ " & "+ ++ show sz4++alignment = do+ let al1 = {# alignof S1 #}+ al1expect <- liftM fromIntegral {# call align_of_s1 #}+ when (al1 /= al1expect) $ fail "Fatal: alignment s1 != align_of_s1()"++ let al2 = {# alignof S2 #}+ al2expect <- liftM fromIntegral {# call align_of_s2 #}+ when (al2 /= al2expect) $ fail "Fatal: alignment s2 != align_of_s2()"++ let al3 = {# alignof S3 #}+ al3expect <- liftM fromIntegral {# call align_of_s3 #}+ when (al3 /= al3expect) $ fail $ "Fatal: alignment s3 != align_of_s3(): " ++ show al3 ++ " but expected " ++ show al3expect++ let al4 = {# alignof S4 #}+ al4expect <- liftM fromIntegral {# call align_of_s4 #}+ when (al4 /= al4expect) $ fail $ "Fatal: alignment s4 != align_of_s4(): " ++ show al4 ++ " but expected " ++ show al4expect++ putStrLn $ show al1 ++ " & "+ ++ show al2 ++ " & "+ ++ show al3 ++ " & "+ ++ show al4
tests/system/sizeof.c view
@@ -8,3 +8,19 @@ size_t size_of_s3() { return sizeof(struct s3); }+size_t size_of_s4() {+ return sizeof(struct s4);+}++size_t align_of_s1() {+ return __alignof__(struct s1);+}+size_t align_of_s2() {+ return __alignof__(struct s2);+}+size_t align_of_s3() {+ return __alignof__(struct s3);+}+size_t align_of_s4() {+ return __alignof__(struct s4);+}
tests/system/sizeof.h view
@@ -3,7 +3,12 @@ size_t size_of_s1(); size_t size_of_s2(); size_t size_of_s3();+size_t size_of_s4(); +size_t align_of_s1();+size_t align_of_s2();+size_t align_of_s3();+ typedef struct s1 { int x; char y;@@ -15,7 +20,12 @@ int (*f1)(void); int (*f2)[11]; } S2;+ typedef struct s3 {+ int a:7;+} S3;++typedef struct s4 { struct { int a : BFSZ(int,13); int b : BFSZ(int,13);@@ -33,4 +43,4 @@ long long g; long long h:BFSZ(long long, 15); */-} S3;+} S4;