diff --git a/C2HS.hs b/C2HS.hs --- a/C2HS.hs +++ b/C2HS.hs @@ -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 diff --git a/c2hs.cabal b/c2hs.cabal --- a/c2hs.cabal +++ b/c2hs.cabal @@ -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 diff --git a/src/C2HS/CHS.hs b/src/C2HS/CHS.hs --- a/src/C2HS/CHS.hs +++ b/src/C2HS/CHS.hs @@ -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 = 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 @@ -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 -- 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,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 diff --git a/tests/system/Sizeof.chs b/tests/system/Sizeof.chs --- a/tests/system/Sizeof.chs +++ b/tests/system/Sizeof.chs @@ -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 diff --git a/tests/system/sizeof.c b/tests/system/sizeof.c --- a/tests/system/sizeof.c +++ b/tests/system/sizeof.c @@ -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); +} diff --git a/tests/system/sizeof.h b/tests/system/sizeof.h --- a/tests/system/sizeof.h +++ b/tests/system/sizeof.h @@ -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;