c2hs 0.25.2 → 0.26.1
raw patch · 54 files changed
+786/−348 lines, 54 filesdep +bytestring
Dependencies added: bytestring
Files
- ChangeLog +13/−0
- c2hs.cabal +7/−1
- src/C2HS/C.hs +26/−1
- src/C2HS/C/Attrs.hs +4/−3
- src/C2HS/C/Builtin.hs +29/−3
- src/C2HS/C/Trav.hs +40/−32
- src/C2HS/CHS.hs +1/−1
- src/C2HS/Gen/Bind.hs +369/−214
- src/C2HS/Gen/Monad.hs +16/−3
- src/C2HS/Gen/Wrapper.hs +31/−18
- src/C2HS/Version.hs +2/−2
- tests/bugs/issue-10/Issue10.chs +0/−1
- tests/bugs/issue-102/Issue102.chs +0/−5
- tests/bugs/issue-115/Issue115.chs +1/−2
- tests/bugs/issue-123/Issue123.chs +0/−1
- tests/bugs/issue-127/Issue127.chs +0/−3
- tests/bugs/issue-128/tst.c +0/−2
- tests/bugs/issue-130/Issue130.chs +15/−0
- tests/bugs/issue-130/issue130.c +6/−0
- tests/bugs/issue-130/issue130.h +1/−0
- tests/bugs/issue-131/Issue131.chs +17/−0
- tests/bugs/issue-131/issue131.c +15/−0
- tests/bugs/issue-131/issue131.h +4/−0
- tests/bugs/issue-133/Issue133.chs +9/−0
- tests/bugs/issue-133/issue133.h +2/−0
- tests/bugs/issue-134/Issue134.chs +8/−0
- tests/bugs/issue-134/issue134.h +3/−0
- tests/bugs/issue-136/Issue136.chs +43/−0
- tests/bugs/issue-136/issue136.c +5/−0
- tests/bugs/issue-136/issue136.h +11/−0
- tests/bugs/issue-15/Issue15.chs +0/−1
- tests/bugs/issue-23/Issue23.chs +0/−2
- tests/bugs/issue-25/Issue25.chs +0/−1
- tests/bugs/issue-31/Issue31.chs +0/−4
- tests/bugs/issue-32/Issue32.chs +0/−5
- tests/bugs/issue-36/Issue36.chs +0/−2
- tests/bugs/issue-38/Issue38.chs +0/−2
- tests/bugs/issue-44/Issue44.chs +0/−2
- tests/bugs/issue-45/Issue45.chs +0/−2
- tests/bugs/issue-46/Issue46.chs +0/−3
- tests/bugs/issue-47/Issue47.chs +0/−2
- tests/bugs/issue-48/Issue48.chs +0/−1
- tests/bugs/issue-54/Issue54.chs +0/−3
- tests/bugs/issue-69/Issue69.chs +0/−2
- tests/bugs/issue-73/Issue73.chs +0/−4
- tests/bugs/issue-75/Issue75.chs +0/−4
- tests/bugs/issue-96/Issue96.chs +0/−2
- tests/bugs/issue-97/Issue97.chs +1/−0
- tests/bugs/issue-98/Issue98.chs +0/−3
- tests/regression-suite.hs +70/−7
- tests/system/cpp/Cpp.chs +1/−0
- tests/system/enums/Enums.chs +3/−2
- tests/system/structs/Structs.chs +3/−2
- tests/test-bugs.hs +30/−0
ChangeLog view
@@ -1,3 +1,16 @@+0.26.1+ - Better error messages [PR #139] (Noam Lewis)+ - Fix for OS X block syntax [#138] (Anthony Cowley)+ - Minimal support for va_list [PR #137] (Andy Adams-Moran)+ - Reorganise treatment of standard library imports used by C2HS+ [#136] (https://github.com/haskell/c2hs/blob/master/import-handling.md)+ - C structure tag/typedef confusion bug (caused problems for flock on+ OS X) [#134]+ - C typedefs to void pointers [#133]+ - Bool wrappers for unnamed parameters in C function definitions+ [#131]+ - Incorrect wrapping of some pure C functions [#130]+ 0.25.2 - Test fixes to work with GHC 7.10.1
c2hs.cabal view
@@ -1,5 +1,5 @@ Name: c2hs-Version: 0.25.2+Version: 0.26.1 License: GPL-2 License-File: COPYING Copyright: Copyright (c) 1999-2007 Manuel M T Chakravarty@@ -90,6 +90,11 @@ tests/bugs/issue-123/*.chs tests/bugs/issue-123/*.h tests/bugs/issue-123/*.c tests/bugs/issue-127/*.chs tests/bugs/issue-127/*.h tests/bugs/issue-127/*.c tests/bugs/issue-128/*.chs tests/bugs/issue-128/*.h tests/bugs/issue-128/*.c+ tests/bugs/issue-130/*.chs tests/bugs/issue-130/*.h tests/bugs/issue-130/*.c+ tests/bugs/issue-131/*.chs tests/bugs/issue-131/*.h tests/bugs/issue-131/*.c+ tests/bugs/issue-133/*.chs tests/bugs/issue-133/*.h+ tests/bugs/issue-134/*.chs tests/bugs/issue-134/*.h+ tests/bugs/issue-136/*.chs tests/bugs/issue-136/*.h tests/bugs/issue-136/*.c source-repository head type: git@@ -99,6 +104,7 @@ Executable c2hs Build-Depends: base >= 2 && < 5,+ bytestring, language-c >= 0.4.7 && < 0.5, filepath, dlist
src/C2HS/C.hs view
@@ -65,6 +65,7 @@ import Language.C.Parser import Data.Attributes (Attr(..))+import qualified Data.ByteString.Char8 as BS import C2HS.State (CST, fatal, errorsPresent, showErrors, raiseError,@@ -95,6 +96,18 @@ Left (ParseError (msgs,pos')) -> raiseError pos' msgs >> return (CTranslUnit [] undefNode) Right (ct,ns') -> setNameSupply ns' >> return ct++-- | @bsReplace old new haystack@ replaces occurences of @old@ with+-- @new@ in the @haystack@.+bsReplace :: BS.ByteString -> BS.ByteString -> BS.ByteString -> BS.ByteString+bsReplace old new = go id+ where go acc hay+ | BS.null hay = BS.concat (acc [])+ | otherwise = case BS.breakSubstring old hay of+ (h,t) | BS.null t -> BS.concat (acc [h])+ | otherwise -> go (acc . (h:) . (new:))+ (BS.drop n t)+ n = BS.length old -- | given a file name (with suffix), parse that file as a C header and do the -- static analysis (collect defined names)@@ -108,7 +121,19 @@ -- read file -- traceInfoRead fname- contents <- liftIO (readInputStream fname)++ -- very hacky dodge of Apple's block syntax in+ -- type definitions. This simply replaces a block+ -- type with a function pointer type. The issue+ -- is that language-c does not support this+ -- syntax, but frameworks such as OpenCL now use+ -- it in their headers.+ let fixBlockTypeDef x+ | BS.isPrefixOf (BS.pack "typedef ") x =+ bsReplace (BS.pack "(^") (BS.pack "(*") x+ | otherwise = x+ fixLines = BS.unlines . map fixBlockTypeDef . BS.lines+ contents <- fmap fixLines (liftIO $ readInputStream fname) -- parse --
src/C2HS/C/Attrs.hs view
@@ -269,12 +269,13 @@ data CObj = TypeCO CDecl -- typedef declaration | ObjCO CDecl -- object or function declaration | EnumCO Ident CEnum -- enumerator- | BuiltinCO -- builtin object+ | BuiltinCO (Maybe CDecl) -- builtin object, with equivalent+ -- C decl if one exists instance Show CObj where show (TypeCO decl) = "TypeCO { " ++ pshow decl ++ " }" show (ObjCO decl) = "ObjCO { "++ pshow decl ++ " }" show (EnumCO ide enum) = "EnumCO "++ show ide ++ " { " ++ pshow enum ++ " }"- show BuiltinCO = "BuiltinCO"+ show (BuiltinCO _) = "BuiltinCO" -- two C objects are equal iff they are defined by the same structure -- tree node (i.e., the two nodes referenced have the same attribute@@ -290,7 +291,7 @@ posOf (TypeCO def ) = posOf def posOf (ObjCO def ) = posOf def posOf (EnumCO ide _) = posOf ide- posOf (BuiltinCO ) = builtinPos+ posOf (BuiltinCO _ ) = builtinPos -- C tagged objects including operations
src/C2HS/C/Builtin.hs view
@@ -33,12 +33,38 @@ builtinTypeNames ) where -import Language.C.Data.Ident (Ident, builtinIdent)+-- Language.C / compiler toolkit+import Language.C.Data.Position+import Language.C.Data.Ident+import Language.C.Syntax+import Language.C.Data import C2HS.C.Attrs (CObj(BuiltinCO)) - -- | predefined type names -- builtinTypeNames :: [(Ident, CObj)]-builtinTypeNames = [(builtinIdent "__builtin_va_list", BuiltinCO)]+builtinTypeNames =+ [(va_list_ide, BuiltinCO $ Just ptrVoidDecl)]+ where+ va_list_ide :: Ident+ va_list_ide = builtinIdent "__builtin_va_list"++ ptrVoidDecl :: CDecl+ ptrVoidDecl =+ CDecl [ CStorageSpec (CTypedef builtin)+ , CTypeSpec (CVoidType builtin)+ ]+ [( Just $ CDeclr (Just va_list_ide)+ [CPtrDeclr [] builtin]+ Nothing+ []+ builtin+ , Nothing+ , Nothing+ )]+ builtin++ builtin :: NodeInfo+ builtin = mkNodeInfoOnlyPos builtinPos+
src/C2HS/C/Trav.hs view
@@ -340,48 +340,56 @@ DontCareCD -> interr "CTrav.getDeclOf: Don't care!" TagCD _ -> interr "CTrav.getDeclOf: Illegal tag!" ObjCD obj -> case obj of- TypeCO decl -> traceTypeCO decl >>- return decl- ObjCO decl -> traceObjCO decl >>- return decl- EnumCO _ _ -> illegalEnum- BuiltinCO -> illegalBuiltin+ TypeCO decl -> traceTypeCO decl >>+ return decl+ ObjCO decl -> traceObjCO decl >>+ return decl+ EnumCO _ _ -> illegalEnum+ BuiltinCO Nothing -> illegalBuiltin+ BuiltinCO (Just decl) -> traceBuiltinCO >>+ return decl where- illegalEnum = interr "CTrav.getDeclOf: Illegal enum!"- illegalBuiltin = interr "CTrav.getDeclOf: Attempted to get declarator of \- \builtin entity!"+ illegalEnum = interr "CTrav.getDeclOf: Illegal enum!"+ illegalBuiltin = interr "CTrav.getDeclOf: Attempted to get declarator of \+ \builtin entity!" -- if the latter ever becomes necessary, we have to -- change the representation of builtins and give them -- some dummy declarator- traceEnter = traceCTrav $- "Entering `getDeclOf' for `" ++ identToString ide+ traceEnter = traceCTrav+ $ "Entering `getDeclOf' for `" ++ identToString ide ++ "'...\n"- traceTypeCO decl = traceCTrav $- "...found a type object.\n" ++ show decl ++ "\n"- traceObjCO decl = traceCTrav $- "...found a vanilla object.\n" ++ show decl ++ "\n"-+ traceTypeCO decl = traceCTrav+ $ "...found a type object:\n" ++ show decl ++ "\n"+ traceObjCO decl = traceCTrav+ $ "...found a vanilla object:\n" ++ show decl ++ "\n"+ traceBuiltinCO = traceCTrav+ $ "...found a builtin object with a proxy decl.\n" -- convenience functions -- --- | find a type object in the object name space; returns 'Nothing' if the--- identifier is not defined------ * if the second argument is 'True', use 'findObjShadow'----findTypeObjMaybe :: Ident -> Bool -> CT s (Maybe (CObj, Ident))-findTypeObjMaybe ide useShadows =+findTypeObjMaybeWith :: Bool -> Ident -> Bool -> CT s (Maybe (CObj, Ident))+findTypeObjMaybeWith soft ide useShadows = do oobj <- if useShadows then findObjShadow ide else liftM (fmap (\obj -> (obj, ide))) $ findObj ide case oobj of- Just obj@(TypeCO _ , _) -> return $ Just obj- Just obj@(BuiltinCO, _) -> return $ Just obj- Just _ -> typedefExpectedErr ide- Nothing -> return $ Nothing+ Just obj@(TypeCO _ , _) -> return $ Just obj+ Just obj@(BuiltinCO _, _) -> return $ Just obj+ Just _ -> if soft+ then return Nothing+ else typedefExpectedErr ide+ Nothing -> return $ Nothing +-- | find a type object in the object name space; returns 'Nothing' if the+-- identifier is not defined+--+-- * if the second argument is 'True', use 'findObjShadow'+--+findTypeObjMaybe :: Ident -> Bool -> CT s (Maybe (CObj, Ident))+findTypeObjMaybe = findTypeObjMaybeWith False+ -- | find a type object in the object name space; raises an error and exception -- if the identifier is not defined --@@ -679,7 +687,7 @@ do traceCTrav $ "findAndChaseDeclOrTag: " ++ show ide ++ " (" ++ show useShadows ++ ")\n"- mobjide <- findTypeObjMaybe ide useShadows -- is there an object def?+ mobjide <- findTypeObjMaybeWith True ide useShadows -- is there an object def? case mobjide of Just (obj, ide') -> do ide `refersToNewDef` ObjCD obj@@ -774,9 +782,9 @@ then findObjShadow ide else liftM (fmap (\obj -> (obj, ide))) $ findObj ide let oobj = case mobj of- Just obj@(TypeCO _ , _) -> Just obj- Just obj@(BuiltinCO, _) -> Just obj- _ -> Nothing+ Just obj@(TypeCO{}, _) -> Just obj+ Just obj@(BuiltinCO{}, _) -> Just obj+ _ -> Nothing case preferTag of True -> case otag of Just tag -> extractStruct (posOf ide) tag@@ -807,7 +815,7 @@ -- lookupDeclOrTag :: Ident -> Bool -> CT s (Either CDecl CTag) lookupDeclOrTag ide useShadows = do- oobj <- findTypeObjMaybe ide useShadows+ oobj <- findTypeObjMaybeWith True ide useShadows case oobj of Just (_, ide') -> liftM Left $ findAndChaseDecl ide' False False -- already did check shadows
src/C2HS/CHS.hs view
@@ -904,7 +904,7 @@ parseCHSModule pos cs = do toks <- lexCHS cs pos frags <- parseFrags toks- return (CHSModule frags)+ return $ CHSModule frags -- | parsing of code fragments --
src/C2HS/Gen/Bind.hs view
@@ -111,7 +111,7 @@ import qualified Prelude -- standard libraries-import Data.Char (toLower)+import Data.Char (toLower, isSpace) import Data.Function (on) import Data.IORef (IORef, newIORef, readIORef, writeIORef) import System.IO.Unsafe (unsafePerformIO)@@ -120,7 +120,7 @@ import System.Directory (removeFile) import System.Process (readProcessWithExitCode, system) import Data.List (deleteBy, groupBy, sortBy, intersperse, find, nubBy,- intercalate, isPrefixOf, foldl')+ intercalate, isPrefixOf, isInfixOf, foldl') import Data.Map (lookup) import Data.Maybe (isNothing, isJust, fromJust, fromMaybe) import Data.Bits ((.|.), (.&.))@@ -161,10 +161,18 @@ sizeIs, querySize, queryClass, queryPointer, mergeMaps, dumpMaps, queryEnum, isEnum, queryTypedef, isC2HSTypedef,- queryDefaultMarsh, isDefaultMarsh, addWrapper, getWrappers)+ queryDefaultMarsh, isDefaultMarsh, addWrapper, getWrappers,+ addHsDependency, getHsDependencies) -import Debug.Trace +-- Module import alias.+imp :: String+imp = "C2HSImp"++impm :: String -> String+impm s = imp ++ "." ++ s++ -- default marshallers -- ------------------- @@ -175,13 +183,14 @@ -- - the checks for the Haskell types are quite kludgy stringIn :: String-stringIn = "\\s f -> withCStringLen s " +++stringIn = "\\s f -> " ++ impm "withCStringLen" ++ " s " ++ "(\\(p, n) -> f (p, fromIntegral n))" -- | determine the default "in" marshaller for the given Haskell and C types -- lookupDftMarshIn :: String -> [ExtType] -> GB CHSMarsh-lookupDftMarshIn "Bool" [PrimET pt] | isIntegralCPrimType pt =+lookupDftMarshIn "Bool" [PrimET pt] | isIntegralCPrimType pt = do+ addHsDependency "Foreign.Marshal.Utils" return $ Just (Left cFromBoolIde, CHSValArg) lookupDftMarshIn hsTy [PrimET pt] | isIntegralHsType hsTy &&isIntegralCPrimType pt =@@ -189,28 +198,36 @@ lookupDftMarshIn hsTy [PrimET pt] | isFloatHsType hsTy &&isFloatCPrimType pt = return $ Just (Left cFloatConvIde, CHSValArg)-lookupDftMarshIn "Char" [PrimET CCharPT] =+lookupDftMarshIn "Char" [PrimET CCharPT] = do+ addHsDependency "Foreign.C.String" return $ Just (Left castCharToCCharIde, CHSValArg)-lookupDftMarshIn "Char" [PrimET CUCharPT] =+lookupDftMarshIn "Char" [PrimET CUCharPT] = do+ addHsDependency "Foreign.C.String" return $ Just (Left castCharToCUCharIde, CHSValArg)-lookupDftMarshIn "Char" [PrimET CSCharPT] =+lookupDftMarshIn "Char" [PrimET CSCharPT] = do+ addHsDependency "Foreign.C.String" return $ Just (Left castCharToCSCharIde, CHSValArg)-lookupDftMarshIn "String" [PtrET (PrimET CCharPT)] =+lookupDftMarshIn "String" [PtrET (PrimET CCharPT)] = do+ addHsDependency "Foreign.C.String" return $ Just (Left withCStringIde, CHSIOArg) lookupDftMarshIn "CString" [PtrET (PrimET CCharPT)] = return $ Just (Right "flip ($)", CHSIOArg) lookupDftMarshIn "String" [PtrET (PrimET CCharPT), PrimET pt]- | isIntegralCPrimType pt =+ | isIntegralCPrimType pt = do+ addHsDependency "Foreign.C.String" return $ Just (Right stringIn , CHSIOArg) lookupDftMarshIn hsTy [PtrET (PrimET pt)]- | isIntegralHsType hsTy && isIntegralCPrimType pt =- return $ Just (Right "with . fromIntegral", CHSIOArg)+ | isIntegralHsType hsTy && isIntegralCPrimType pt = do+ addHsDependency "Foreign.Marshal.Utils"+ return $ Just (Right $ impm "with" ++ " . fromIntegral", CHSIOArg) lookupDftMarshIn hsTy [PtrET (PrimET pt)]- | isFloatHsType hsTy && isFloatCPrimType pt =- return $ Just (Right "with . realToFrac", CHSIOArg)+ | isFloatHsType hsTy && isFloatCPrimType pt = do+ addHsDependency "Foreign.Marshal.Utils"+ return $ Just (Right $ impm "with" ++ " . realToFrac", CHSIOArg) lookupDftMarshIn "Bool" [PtrET (PrimET pt)]- | isIntegralCPrimType pt =- return $ Just (Right "with . fromBool", CHSIOArg)+ | isIntegralCPrimType pt = do+ addHsDependency "Foreign.Marshal.Utils"+ return $ Just (Right $ impm "with" ++ " . fromBool", CHSIOArg) lookupDftMarshIn hsTy [PtrET UnitET] | "Ptr " `isPrefixOf` hsTy = return $ Just (Left idIde, CHSValArg) lookupDftMarshIn hsTy [PrimET (CAliasedPT tds hsAlias _)] = do@@ -231,18 +248,21 @@ lookupDftMarshIn hsty _ = do om <- readCT objmap isenum <- queryEnum hsty- return $ case (isenum, (internalIdent hsty) `lookup` om) of+ case (isenum, (internalIdent hsty) `lookup` om) of -- 1. enumeration hooks- (True, Nothing) -> Just (Right "fromIntegral . fromEnum", CHSValArg)+ (True, Nothing) ->+ return $ Just (Right "fromIntegral . fromEnum", CHSValArg) -- 2. naked and newtype pointer hooks- (False, Just (Pointer CHSPtr _)) -> Just (Left idIde, CHSValArg)+ (False, Just (Pointer CHSPtr _)) ->+ return $ Just (Left idIde, CHSValArg) -- 3. foreign pointer hooks- (False, Just (Pointer (CHSForeignPtr _) False)) ->- Just (Left withForeignPtrIde, CHSIOArg)+ (False, Just (Pointer (CHSForeignPtr _) False)) -> do+ addHsDependency "Foreign.ForeignPtr"+ return $ Just (Left withForeignPtrIde, CHSIOArg) -- 4. foreign newtype pointer hooks (False, Just (Pointer (CHSForeignPtr _) True)) ->- Just (Right $ "with" ++ hsty, CHSIOArg)- _ -> Nothing+ return $ Just (Right $ "with" ++ hsty, CHSIOArg)+ _ -> return Nothing -- FIXME: handle array-list conversion @@ -251,7 +271,9 @@ lookupDftMarshOut :: String -> [ExtType] -> GB CHSMarsh lookupDftMarshOut "()" _ = return $ Just (Left voidIde, CHSVoidArg)-lookupDftMarshOut "Bool" [PrimET pt] | isIntegralCPrimType pt =+lookupDftMarshOut hsTy [IOET cTy] = lookupDftMarshOut hsTy [cTy]+lookupDftMarshOut "Bool" [PrimET pt] | isIntegralCPrimType pt = do+ addHsDependency "Foreign.Marshal.Utils" return $ Just (Left cToBoolIde, CHSValArg) lookupDftMarshOut hsTy [PrimET pt] | isIntegralHsType hsTy && isIntegralCPrimType pt =@@ -259,19 +281,25 @@ lookupDftMarshOut hsTy [PrimET pt] | isFloatHsType hsTy && isFloatCPrimType pt = return $ Just (Left cFloatConvIde, CHSValArg)-lookupDftMarshOut "Char" [PrimET CCharPT] =+lookupDftMarshOut "Char" [PrimET CCharPT] = do+ addHsDependency "Foreign.C.String" return $ Just (Left castCCharToCharIde, CHSValArg)-lookupDftMarshOut "Char" [PrimET CUCharPT] =+lookupDftMarshOut "Char" [PrimET CUCharPT] = do+ addHsDependency "Foreign.C.String" return $ Just (Left castCUCharToCharIde, CHSValArg)-lookupDftMarshOut "Char" [PrimET CSCharPT] =+lookupDftMarshOut "Char" [PrimET CSCharPT] = do+ addHsDependency "Foreign.C.String" return $ Just (Left castCSCharToCharIde, CHSValArg)-lookupDftMarshOut "String" [PtrET (PrimET CCharPT)] =+lookupDftMarshOut "String" [PtrET (PrimET CCharPT)] = do+ addHsDependency "Foreign.C.String" return $ Just (Left peekCStringIde, CHSIOArg)-lookupDftMarshOut "CString" [PtrET (PrimET CCharPT)] =+lookupDftMarshOut "CString" [PtrET (PrimET CCharPT)] = return $ Just (Left returnIde, CHSIOArg) lookupDftMarshOut "String" [PtrET (PrimET CCharPT), PrimET pt]- | isIntegralCPrimType pt =- return $ Just (Right "\\(s, n) -> peekCStringLen (s, fromIntegral n)",+ | isIntegralCPrimType pt = do+ addHsDependency "Foreign.C.String"+ return $ Just (Right $ "\\(s, n) -> " ++ impm "peekCStringLen" +++ " (s, fromIntegral n)", CHSIOArg) lookupDftMarshOut hsTy [PtrET UnitET] | "Ptr " `isPrefixOf` hsTy = return $ Just (Left idIde, CHSValArg)@@ -298,18 +326,21 @@ -- 2. naked and newtype pointer hooks (False, Just (Pointer CHSPtr _)) -> return $ Just (Left idIde, CHSValArg) -- 3. foreign pointer hooks- (False, Just (Pointer (CHSForeignPtr Nothing) False)) ->+ (False, Just (Pointer (CHSForeignPtr Nothing) False)) -> do+ addHsDependency "Foreign.ForeignPtr" return $ Just (Left newForeignPtr_Ide, CHSIOArg) (False, Just (Pointer (CHSForeignPtr (Just fin)) False)) -> do code <- newForeignPtrCode fin return $ Just (Right $ code, CHSIOArg) -- 4. foreign newtype pointer hooks- (False, Just (Pointer (CHSForeignPtr Nothing) True)) ->- return $ Just (Right $ "newForeignPtr_ >=> (return . " ++- hsty ++ ")", CHSIOArg)+ (False, Just (Pointer (CHSForeignPtr Nothing) True)) -> do+ addHsDependency "Foreign.ForeignPtr"+ return $ Just (Right $ "\\x -> " ++ impm "newForeignPtr_ x >>= " +++ " (return . " ++ hsty ++ ")",+ CHSIOArg) (False, Just (Pointer (CHSForeignPtr (Just fin)) True)) -> do code <- newForeignPtrCode fin- return $ Just (Right $ code ++ " >=> (return . " +++ return $ Just (Right $ "\\x -> " ++ code ++ " x >>= (return . " ++ hsty ++ ")", CHSIOArg) _ -> return Nothing return res@@ -320,7 +351,8 @@ newForeignPtrCode (cide, ohside) = do (_, cide') <- findFunObj cide True let fin = (identToString cide') `maybe` identToString $ ohside- return $ "newForeignPtr " ++ fin+ addHsDependency "Foreign.ForeignPtr"+ return $ impm "newForeignPtr" ++ " " ++ fin -- | check for integral Haskell types@@ -382,23 +414,23 @@ newForeignPtr_Ide, withForeignPtrIde, returnIde, castCharToCCharIde, castCharToCUCharIde, castCharToCSCharIde, castCCharToCharIde, castCUCharToCharIde, castCSCharToCharIde :: Ident-voidIde = internalIdent "void" -- never appears in the output-cFromBoolIde = internalIdent "fromBool"-cToBoolIde = internalIdent "toBool"+voidIde = internalIdent $ impm "void" -- never appears in the output+cFromBoolIde = internalIdent $ impm "fromBool"+cToBoolIde = internalIdent $ impm "toBool" cIntConvIde = internalIdent "fromIntegral" cFloatConvIde = internalIdent "realToFrac"-withCStringIde = internalIdent "withCString"-peekCStringIde = internalIdent "peekCString"+withCStringIde = internalIdent $ impm "withCString"+peekCStringIde = internalIdent $ impm "peekCString" idIde = internalIdent "id"-newForeignPtr_Ide = internalIdent "newForeignPtr_"-withForeignPtrIde = internalIdent "withForeignPtr"+newForeignPtr_Ide = internalIdent $ impm "newForeignPtr_"+withForeignPtrIde = internalIdent $ impm "withForeignPtr" returnIde = internalIdent "return"-castCharToCCharIde = internalIdent "castCharToCChar"-castCharToCUCharIde = internalIdent "castCharToCUChar"-castCharToCSCharIde = internalIdent "castCharToCSChar"-castCCharToCharIde = internalIdent "castCCharToChar"-castCUCharToCharIde = internalIdent "castCUCharToChar"-castCSCharToCharIde = internalIdent "castCSCharToChar"+castCharToCCharIde = internalIdent $ impm "castCharToCChar"+castCharToCUCharIde = internalIdent $ impm "castCharToCUChar"+castCharToCSCharIde = internalIdent $ impm "castCharToCSChar"+castCCharToCharIde = internalIdent $ impm "castCCharToChar"+castCUCharToCharIde = internalIdent $ impm "castCUCharToChar"+castCSCharToCharIde = internalIdent $ impm "castCSCharToChar" -- expansion of binding hooks@@ -426,6 +458,8 @@ -- traceInfoExpand frags' <- expandFrags mfrags+ hsdeps <- getHsDependencies+ let frags'' = addImports frags' hsdeps delayedFrags <- getDelayedCode -- get .chi dump@@ -445,7 +479,7 @@ traceInfoOK warnmsgs <- showErrors wraps <- getWrappers- return (CHSModule (frags' ++ delayedFrags), chi, wraps, warnmsgs)+ return (CHSModule (frags'' ++ delayedFrags), chi, wraps, warnmsgs) where traceInfoExpand = putTraceStr tracePhasesSW ("...expanding binding hooks...\n")@@ -454,6 +488,48 @@ traceInfoOK = putTraceStr tracePhasesSW ("...successfully completed.\n") +-- | add import declarations for modules required internally by C2HS+--+addImports :: [CHSFrag] -> [String] -> [CHSFrag]+addImports fs imps = before ++ impfrags ++ after+ where impfrags = sp ++ concatMap impfrag imps ++ sp+ sp = [CHSVerb "\n" imppos]+ impfrag i =+ [CHSVerb ("import qualified " ++ i ++ " as " ++ imp) imppos,+ CHSVerb "\n" imppos]+ (before, after) = doSplit 0 Nothing False [] fs+ imppos = posOf $ last before++ -- Find the appropriate location to put the import+ -- declarations. This relies heavily on the details of the+ -- CHS parser to deal with Haskell comments, but a simple+ -- approach like this seems to be a better idea than using+ -- haskell-src-exts or something like that, mostly because+ -- none of the Haskell parsing packages deal with *all* GHC+ -- extensions. The approach taken here isn't pretty, but it+ -- seems to work.+ doSplit :: Int -> Maybe Int -> Bool ->+ [CHSFrag] -> [CHSFrag] -> ([CHSFrag], [CHSFrag])+ doSplit _ Nothing _ _ [] = (fs, [])+ doSplit _ (Just ln) _ _ [] = splitAt (ln-1) fs+ doSplit 0 mln wh acc (f@(CHSVerb s pos) : fs')+ | "--" `isPrefixOf` s = doSplit 0 mln wh (f:acc) fs'+ | s == "{-" = doSplit 1 mln wh (f:acc) fs'+ | wh && "where" `isInfixOf` s = (reverse (f:acc), fs')+ | "module" `isPrefixOf` (dropWhile isSpace s) =+ if (" where" `isInfixOf` s || ")where" `isInfixOf` s)+ then (reverse (f:acc), fs')+ else doSplit 0 mln True (f:acc) fs'+ | otherwise = if null (dropWhile isSpace s) || isJust mln+ then doSplit 0 mln wh (f:acc) fs'+ else doSplit 0 (Just $ posRow pos) wh (f:acc) fs'+ doSplit cdep mln wh acc (f@(CHSVerb s _) : fs')+ | s == "-}" = doSplit (cdep-1) mln wh (f:acc) fs'+ | s == "{-" = doSplit (cdep+1) mln wh (f:acc) fs'+ | otherwise = doSplit cdep mln wh (f:acc) fs'+ doSplit cdep mln wh acc (f:fs') = doSplit cdep mln wh (f:acc) fs'++ expandFrags :: [CHSFrag] -> GB [CHSFrag] expandFrags = liftM concat . mapM expandFrag @@ -517,6 +593,7 @@ ty <- extractSimpleType False pos decl traceInfoDump (render $ pretty decl) ty when (isVariadic ty) (variadicErr pos (posOf decl))+ addExtTypeDependency ty return $ "(" ++ showExtType ty ++ ")" where traceInfoType = traceGenBind "** Type hook:\n"@@ -582,8 +659,17 @@ let ideLexeme = identToString ide' -- orignl name might have been a shadow hsLexeme = ideLexeme `maybe` identToString $ oalias cdecl' = ide' `simplifyDecl` cdecl- callImport hook isPure isUns [] ideLexeme hsLexeme cdecl' Nothing pos- return hsLexeme+ ty <- extractFunType pos cdecl' Nothing+ let args = concat [ " x" ++ show n | n <- [1..numArgs ty] ]+ callImport hook isUns [] ideLexeme hsLexeme cdecl' Nothing pos+ when isPure $ addHsDependency "System.IO.Unsafe"+ case (isPure, length args) of+ (False, _) -> return hsLexeme+ (True, 0) -> return $ "(" ++ impm "unsafePerformIO" +++ " " ++ hsLexeme ++ ")"+ (True, _) -> return $ "(\\" ++ args ++ " -> " +++ impm "unsafePerformIO" ++ " (" +++ hsLexeme ++ args ++ "))" where traceEnter = traceGenBind $ "** Call hook for `" ++ identToString ide ++ "':\n"@@ -610,9 +696,14 @@ -- cdecl' = ide `simplifyDecl` cdecl args = concat [ " x" ++ show n | n <- [1..numArgs ty] ] - callImportDyn hook isPure isUns ideLexeme hsLexeme decl ty pos- return $ "(\\o" ++ args ++ " -> " ++ set_get ++ " o >>= \\f -> "- ++ hsLexeme ++ " f" ++ args ++ ")"+ callImportDyn hook isUns ideLexeme hsLexeme decl ty pos+ let res = "(\\o" ++ args ++ " -> " ++ set_get ++ " o >>= \\f -> "+ ++ hsLexeme ++ " f" ++ args ++ ")"+ if isPure+ then do+ addHsDependency "System.IO.Unsafe"+ return $ "(" ++ impm "unsafePerformIO" ++ " " ++ res ++ ")"+ else return res where traceEnter = traceGenBind $ "** Indirect call hook for `" ++@@ -643,10 +734,10 @@ wrapped = Just $ concatMap isWrapped parms varTypes <- convertVarTypes hsLexeme pos inVarTypes- callImport callHook isPure isUns varTypes (identToString cide)+ callImport callHook isUns varTypes (identToString cide) fiLexeme cdecl' wrapped pos - extTy <- extractFunType pos cdecl' True wrapped+ extTy <- extractFunType pos cdecl' wrapped funDef isPure hsLexeme fiLexeme extTy varTypes ctxt parms parm Nothing pos hkpos where@@ -676,7 +767,7 @@ -- cdecl' = cide `simplifyDecl` cdecl -- args = concat [ " x" ++ show n | n <- [1..numArgs ty] ] callHook = CHSCall isPure isUns apath (Just fiIde) pos- callImportDyn callHook isPure isUns ideLexeme fiLexeme decl ty pos+ callImportDyn callHook isUns ideLexeme fiLexeme decl ty pos set_get <- setGet pos CHSGet offsets Nothing ptrTy Nothing funDef isPure hsLexeme fiLexeme (FunET ptrTy $ purify ty) []@@ -740,7 +831,7 @@ hsIde `objIs` Pointer ptrKind isNewtype -- register Haskell object decl <- findAndChaseDeclOrTag cName False True- (sz, _) <- sizeAlignOf decl+ (sz, _) <- sizeAlignOfPtr decl hsIde `sizeIs` (padBits sz) -- -- we check for a typedef declaration or tag (struct, union, or enum)@@ -1029,14 +1120,14 @@ -- * the C declaration is a simplified declaration of the function that we -- want to import into Haskell land ---callImport :: CHSHook -> Bool -> Bool -> [ExtType] -> String ->+callImport :: CHSHook -> Bool -> [ExtType] -> String -> String -> CDecl -> Maybe [Bool] -> Position -> GB ()-callImport hook isPure isUns varTypes ideLexeme hsLexeme cdecl owrapped pos =+callImport hook isUns varTypes ideLexeme hsLexeme cdecl owrapped pos = do -- compute the external type from the declaration, and delay the foreign -- export declaration --- extType <- extractFunType pos cdecl isPure owrapped+ extType <- extractFunType pos cdecl owrapped header <- getSwitch headerSB let bools@(boolres, boolargs) = boolArgs extType needwrapper1 = boolres || or boolargs@@ -1048,6 +1139,7 @@ ide = if needwrapper1 || needwrapper2 then "__c2hs_wrapped__" ++ ideLexeme else ideLexeme+ addExtTypeDependency extType delayCode hook (foreignImport (extractCallingConvention cdecl) header ide hsLexeme isUns extType varTypes) when (needwrapper1 || needwrapper2) $@@ -1057,14 +1149,15 @@ traceFunType et = traceGenBind $ "Imported function type: " ++ showExtType et ++ "\n" -callImportDyn :: CHSHook -> Bool -> Bool -> String -> String -> CDecl -> ExtType+callImportDyn :: CHSHook -> Bool -> String -> String -> CDecl -> ExtType -> Position -> GB ()-callImportDyn hook _isPure isUns ideLexeme hsLexeme cdecl ty pos =+callImportDyn hook isUns ideLexeme hsLexeme cdecl ty pos = do -- compute the external type from the declaration, and delay the foreign -- export declaration -- when (isVariadic ty) (variadicErr pos (posOf cdecl))+ addExtTypeDependency ty delayCode hook (foreignImportDyn (extractCallingConvention cdecl) ideLexeme hsLexeme isUns ty) traceFunType ty@@ -1093,8 +1186,8 @@ foreignImportDyn cconv _ident hsIdent isUnsafe ty = "foreign import " ++ showCallingConvention cconv ++ " " ++ safety ++ " \"dynamic\"\n " ++- hsIdent ++ " :: FunPtr( " ++ showExtType ty ++ " ) -> " ++- showExtType ty ++ "\n"+ hsIdent ++ " :: " ++ impm "FunPtr" ++ "( " +++ showExtType ty ++ " ) -> " ++ showExtType ty ++ "\n" where safety = if isUnsafe then "unsafe" else "safe" @@ -1123,9 +1216,9 @@ parm@(CHSParm _ hsParmTy _ _ _ _ _) marsh2 pos hkpos = do when (countPlus parms > 1 || isPlus parm) $ illegalPlusErr pos- (parms', parm', isImpure) <- addDftMarshaller pos parms parm extTy varExtTys+ (parms', parm') <- addDftMarshaller pos parms parm extTy varExtTys - traceMarsh parms' parm' isImpure+ traceMarsh parms' parm' marshs <- zipWithM marshArg [1..] parms' let sig = hsLexeme ++ " :: " ++ funTy parms' parm' ++ "\n"@@ -1135,10 +1228,10 @@ marshOuts = [marshOut | (_, _, _, marshOut, _) <- marshs, marshOut /= ""] retArgs = [retArg | (_, _, _, _, retArg) <- marshs, retArg /= ""] funHead = hsLexeme ++ join funArgs ++ " =\n" ++- if isPure && isImpure then " unsafePerformIO $\n" else ""- call = if isPure- then " let {res = " ++ fiLexeme ++ joinCallArgs ++ "} in\n"- else " " ++ fiLexeme ++ joinCallArgs ++ case parm of+ if isPure+ then " " ++ impm "unsafePerformIO" ++ " $\n"+ else ""+ call = " " ++ fiLexeme ++ joinCallArgs ++ case parm of CHSParm _ "()" _ Nothing _ _ _ -> " >>\n" _ -> if countPlus parms == 1@@ -1178,13 +1271,13 @@ call ++ marshRes ++ joinLines marshOuts ++- " " ++- (if isImpure || not isPure then "return " else "") ++ ret+ " return " ++ ret pad code = let padding = replicate (posColumn hkpos - 1) ' ' (l:ls) = lines code in unlines $ l : map (padding ++) ls + when isPure $ addHsDependency "System.IO.Unsafe" return $ pad $ sig ++ funHead ++ funBody where countPlus :: [CHSParm] -> Int@@ -1272,17 +1365,17 @@ let a = "a" ++ show (i :: Int) bdr1 = a ++ "'" bdr2 = a ++ "''"- marshIn = "mallocForeignPtrBytes " ++ show sz +++ marshIn = impm "mallocForeignPtrBytes" ++ " " ++ show sz ++ " >>= \\" ++ bdr2 ++- " -> withForeignPtr " ++ bdr2 ++ " $ \\" ++- bdr1 ++ " -> "+ " -> " ++ impm "withForeignPtr" ++ " " ++ bdr2 +++ " $ \\" ++ bdr1 ++ " -> "+ addHsDependency "Foreign.ForeignPtr" return ("", marshIn, [bdr1], "", hsParmTy ++ " " ++ bdr2) marshArg _ _ = interr "GenBind.funDef: Missing default?" --- traceMarsh parms' parm' isImpure = traceGenBind $+ traceMarsh parms' parm' = traceGenBind $ "Marshalling specification including defaults: \n" ++- showParms (parms' ++ [parm']) "" ++- " The marshalling is " ++ if isImpure then "impure.\n" else "pure.\n"+ showParms (parms' ++ [parm']) "\n" where showParms [] = id showParms (parm'':parms'') = showString " "@@ -1293,12 +1386,12 @@ -- | add default marshallers for "in" and "out" marshalling -- addDftMarshaller :: Position -> [CHSParm] -> CHSParm -> ExtType -> [ExtType]- -> GB ([CHSParm], CHSParm, Bool)+ -> GB ([CHSParm], CHSParm) addDftMarshaller pos parms parm extTy varExTys = do let (resTy, argTys) = splitFunTy extTy varExTys- (parm' , isImpure1) <- checkResMarsh parm resTy- (parms', isImpure2) <- addDft parms argTys- return (parms', parm', isImpure1 || isImpure2)+ parm' <- checkResMarsh parm resTy+ parms' <- addDft parms argTys+ return (parms', parm') where -- the result marshalling may not use an "in" marshaller and can only have -- one C value@@ -1310,9 +1403,9 @@ checkResMarsh (CHSParm _ _ True _ _ pos' _) _ = resMarshIllegalTwoCValErr pos' checkResMarsh (CHSParm _ ty _ omMarsh _ pos' c) cTy = do- (imMarsh', _ ) <- addDftVoid Nothing- (omMarsh', isImpure) <- addDftOut pos' omMarsh ty [cTy]- return (CHSParm imMarsh' ty False omMarsh' False pos' c, isImpure)+ imMarsh' <- addDftVoid Nothing+ omMarsh' <- addDftOut pos' omMarsh ty [cTy]+ return (CHSParm imMarsh' ty False omMarsh' False pos' c) -- splitFunTy (FunET UnitET ty) vts = splitFunTy ty vts splitFunTy (FunET ty1 ty2) vts = let (resTy, argTys) = splitFunTy ty2 vts@@ -1324,47 +1417,41 @@ -- match Haskell with C arguments (and results) -- addDft ((CHSPlusParm):parms'') (_:cTys) = do- (parms', _) <- addDft parms'' cTys- return (CHSPlusParm : parms', True)+ parms' <- addDft parms'' cTys+ return (CHSPlusParm : parms') addDft ((CHSParm imMarsh hsTy False omMarsh _ p c):parms'') (cTy:cTys) = do- (imMarsh', isImpureIn ) <- addDftIn p imMarsh hsTy [cTy]- (omMarsh', isImpureOut) <- addDftVoid omMarsh- (parms' , isImpure ) <- addDft parms'' cTys- return (CHSParm imMarsh' hsTy False omMarsh' False p c : parms',- isImpure || isImpureIn || isImpureOut)+ imMarsh' <- addDftIn p imMarsh hsTy [cTy]+ omMarsh' <- addDftVoid omMarsh+ parms' <- addDft parms'' cTys+ return (CHSParm imMarsh' hsTy False omMarsh' False p c : parms') addDft ((CHSParm imMarsh hsTy True omMarsh _ p c):parms'') (ct1:ct2:cts) = do- (imMarsh', isImpureIn ) <- addDftIn p imMarsh hsTy [ct1, ct2]- (omMarsh', isImpureOut) <- addDftVoid omMarsh- (parms' , isImpure ) <- addDft parms'' cts- return (CHSParm imMarsh' hsTy True omMarsh' False p c : parms',- isImpure || isImpureIn || isImpureOut)- addDft [] [] = return ([], False)+ imMarsh' <- addDftIn p imMarsh hsTy [ct1, ct2]+ omMarsh' <- addDftVoid omMarsh+ parms' <- addDft parms'' cts+ return (CHSParm imMarsh' hsTy True omMarsh' False p c : parms')+ addDft [] [] = return [] addDft ((CHSParm _ _ _ _ _ pos' _):_) [] = marshArgMismatchErr pos' "This parameter is in excess of the C arguments." addDft [] (_:_) = marshArgMismatchErr pos "Parameter marshallers are missing." --- addDftIn _ imMarsh@(Just (_, kind)) _ _ = return (imMarsh, kind == CHSIOArg)+ addDftIn _ imMarsh@(Just (_, _)) _ _ = return imMarsh addDftIn pos' _imMarsh@Nothing hsTy cts = do marsh <- lookupDftMarshIn hsTy cts- when (isNothing marsh) $- noDftMarshErr pos' "\"in\"" hsTy cts- return (marsh, case marsh of {Just (_, kind) -> kind == CHSIOArg})+ when (isNothing marsh) $ noDftMarshErr pos' "\"in\"" hsTy cts+ return marsh --- addDftOut _ omMarsh@(Just (_, kind)) _ _ =- return (omMarsh, kind == CHSIOArg)+ addDftOut _ omMarsh@(Just (_, _)) _ _ = return omMarsh addDftOut pos' _omMarsh@Nothing hsTy cts = do marsh <- lookupDftMarshOut hsTy cts- when (isNothing marsh) $- noDftMarshErr pos' "\"out\"" hsTy cts- return (marsh, case marsh of {Just (_, kind) -> kind == CHSIOArg})+ when (isNothing marsh) $ noDftMarshErr pos' "\"out\"" hsTy cts+ return marsh -- -- add void marshaller if no explict one is given --- addDftVoid marsh@(Just (_, kind)) = return (marsh, kind == CHSIOArg)- addDftVoid Nothing = do- return (Just (Left (internalIdent "void"), CHSVoidArg), False)+ addDftVoid marsh@(Just (_, _)) = return marsh+ addDftVoid Nothing = return $ Just (Left (internalIdent "void"), CHSVoidArg) -- | compute from an access path, the declarator finally accessed and the index -- path required for the access@@ -1475,10 +1562,10 @@ declNamed :: CDecl -> Ident -> Bool (CDecl _ [(Nothing , _, _)] _) `declNamed` _ = False (CDecl _ [(Just declr, _, _)] _) `declNamed` ide = declr `declrNamed` ide-(CDecl _ [] _) `declNamed` _ =- interr "GenBind.declNamed: Abstract declarator in structure!"-_ `declNamed` _ =- interr "GenBind.declNamed: More than one declarator!"+cdecl@(CDecl _ [] _) `declNamed` _ =+ errorAtPos (posOf cdecl) ["GenBind.declNamed: Abstract declarator in structure!"]+cdecl `declNamed` _ =+ errorAtPos (posOf cdecl) ["GenBind.declNamed: More than one declarator!"] -- | Haskell code for writing to or reading from a struct --@@ -1500,39 +1587,51 @@ do bf <- checkType ty case bf of- Nothing -> return $ case access of -- not a bitfield+ Nothing -> case access of -- not a bitfield CHSGet -> peekOp offset ty arrSize CHSSet -> pokeOp offset ty "val" arrSize --FIXME: must take `bitfieldDirection' into account- Just (_, bs) -> return $ case access of -- a bitfield- CHSGet -> "val <- " ++ peekOp offset ty arrSize- ++ extractBitfield- CHSSet -> "org <- " ++ peekOp offset ty arrSize- ++ insertBitfield- ++ pokeOp offset ty "val'" arrSize+ Just (_, bs) -> case access of -- a bitfield+ CHSGet -> do+ op <- peekOp offset ty arrSize+ addHsDependency "Data.Bits"+ addHsDependency "Foreign.C.Types"+ return $ "val <- " ++ op ++ extractBitfield+ CHSSet -> do+ op <- peekOp offset ty arrSize+ op2 <- pokeOp offset ty "val'" arrSize+ addHsDependency "Data.Bits"+ addHsDependency "Foreign.C.Types"+ return $ "org <- " ++ op ++ insertBitfield+ ++ op2 where -- we have to be careful here to ensure proper sign extension; -- in particular, shifting right followed by anding a mask is -- *not* sufficient; instead, we exploit in the following that -- `shiftR' performs sign extension --- extractBitfield = "; return $ (val `shiftL` ("+ extractBitfield = "; return $ (val `" ++ impm "shiftL" ++ "` (" ++ bitsPerField ++ " - "- ++ show (bs + bitOffset) ++ ")) `shiftR` ("+ ++ show (bs + bitOffset) ++ ")) `"+ ++ impm "shiftR" ++ "` (" ++ bitsPerField ++ " - " ++ show bs ++ ")" bitsPerField = show $ size CIntPT * 8 --- insertBitfield = "; let {val' = (org .&. " ++ middleMask- ++ ") .|. (val `shiftL` "+ insertBitfield = "; let {val' = (org " ++ impm ".&." ++ " "+ ++ middleMask ++ ") " ++ impm ".|."+ ++ " (val `" ++ impm "shiftL" ++ "` " ++ show bitOffset ++ ")}; "- middleMask = "fromIntegral (((maxBound::CUInt) `shiftL` "- ++ show bs ++ ") `rotateL` "+ middleMask = "fromIntegral (((maxBound::" ++ impm "CUInt"+ ++ ") `" ++ impm "shiftL" ++ "` "+ ++ show bs ++ ") `" ++ impm "rotateL" ++ "` " ++ show bitOffset ++ ")" setGetBody (BitSize offset 0 : offsetsrem) = do code <- setGetBody offsetsrem- return $ "ptr <- peekByteOff ptr " ++ show offset ++ "; " ++ code+ addHsDependency "Foreign.Storable"+ return $ "ptr <- " ++ impm "peekByteOff" ++ " ptr "+ ++ show offset ++ "; " ++ code setGetBody (BitSize _ _ : _ ) = derefBitfieldErr pos --@@ -1540,28 +1639,49 @@ -- bitfields -- checkType (VarFunET _ ) = variadicErr pos pos- checkType (IOET _ ) = interr "GenBind.setGet: Illegal \- \type!"+ checkType (IOET _ ) = errorAtPos pos ["GenBind.setGet: Illegal \+ \type!"] checkType (UnitET ) = voidFieldErr pos checkType (DefinedET _ _ ) = return Nothing-- can't check further checkType (PrimET (CUFieldPT bs)) = return $ Just (False, bs) checkType (PrimET (CSFieldPT bs)) = return $ Just (True , bs) checkType _ = return Nothing --- peekOp off (PrimET CBoolPT) Nothing =- "toBool `fmap` (peekByteOff ptr " ++ show off ++ " :: IO CInt)"- peekOp off t Nothing =- "peekByteOff ptr " ++ show off ++ " :: IO " ++ showExtType t- peekOp off t (Just _) =- "return $ ptr `plusPtr` " ++ show off ++ " :: IO " ++ showExtType t- pokeOp off (PrimET CBoolPT) var Nothing =- "pokeByteOff ptr " ++ show off ++ " (fromBool " ++ var ++ " :: CInt)"- pokeOp off t var Nothing =- "pokeByteOff ptr " ++ show off ++ " (" ++ var ++ " :: " ++- showExtType t ++ ")"- pokeOp off t var (Just sz) =- "copyArray (ptr `plusPtr` " ++ show off ++ ") (" ++- var ++ " :: " ++ showExtType t ++ ") " ++ show sz+ peekOp off (PrimET CBoolPT) Nothing = do+ addHsDependency "Foreign.Marshal.Utils"+ addHsDependency "Foreign.C.Types"+ addHsDependency "Foreign.Storable"+ return $ impm "toBool" ++ " `fmap` (" ++ impm "peekByteOff"+ ++ " ptr " ++ show off ++ " :: IO " ++ impm "CInt" ++ ")"+ peekOp off t Nothing = do+ addHsDependency "Foreign.Storable"+ addExtTypeDependency t+ return $ impm "peekByteOff" ++ " ptr " ++ show off+ ++ " :: IO " ++ showExtType t+ peekOp off t (Just _) = do+ addHsDependency "Foreign.Ptr"+ addExtTypeDependency t+ return $ "return $ ptr `" ++ impm "plusPtr" ++ "` " ++ show off +++ " :: IO " ++ showExtType t+ pokeOp off (PrimET CBoolPT) var Nothing = do+ addHsDependency "Foreign.Marshal.Utils"+ addHsDependency "Foreign.C.Types"+ addHsDependency "Foreign.Storable"+ return $ impm "pokeByteOff" ++ " ptr " ++ show off+ ++ " (" ++ impm "fromBool" ++ " " +++ var ++ " :: " ++ impm "CInt" ++ ")"+ pokeOp off t var Nothing = do+ addHsDependency "Foreign.Storable"+ addExtTypeDependency t+ return $ impm "pokeByteOff" ++ " ptr " ++ show off ++ " (" ++ var ++ " :: " +++ showExtType t ++ ")"+ pokeOp off t var (Just sz) = do+ addHsDependency "Foreign.Ptr"+ addHsDependency "Foreign.Marshal.Array"+ addExtTypeDependency t+ return $ impm "copyArray" ++ " (ptr `" ++ impm "plusPtr" ++ "` "+ ++ show off ++ ") (" +++ var ++ " :: " ++ showExtType t ++ ") " ++ show sz -- | generate the type definition for a pointer hook and enter the required type -- mapping into the 'ptrmap'@@ -1576,18 +1696,26 @@ -> Bool -- shall we emit code? -> GB String pointerDef isStar cNameFull hsName ptrKind isNewtype hsType isFun emit =+ -- ====> NEED TO DO DEPENDENCIES HERE! do let ptrArg = if isNewtype then hsName -- abstract type else hsType -- concrete type ptrCon = case ptrKind of- CHSPtr | isFun -> "FunPtr"- _ -> show ptrKind+ CHSPtr | isFun -> impm "FunPtr"+ _ -> impm $ show ptrKind ptrType = ptrCon ++ " (" ++ ptrArg ++ ")" thePtr = (isStar, cNameFull) case ptrKind of- CHSForeignPtr _ -> thePtr `ptrMapsTo` ("Ptr (" ++ ptrArg ++ ")",- "Ptr (" ++ ptrArg ++ ")")+ CHSPtr -> addHsDependency "Foreign.Ptr"+ CHSForeignPtr _ -> do+ addHsDependency "Foreign.ForeignPtr"+ addHsDependency "Foreign.Ptr"+ CHSStablePtr -> addHsDependency "Foreign.StablePtr"+ case ptrKind of+ CHSForeignPtr _ -> do+ thePtr `ptrMapsTo` (impm "Ptr (" ++ ptrArg ++ ")",+ impm "Ptr (" ++ ptrArg ++ ")") _ -> thePtr `ptrMapsTo` (hsName, hsName) return $ case (emit, isNewtype) of@@ -1604,8 +1732,10 @@ withForeignFun | isForeign ptrKind = "\nwith" ++ hsName ++ " :: " ++- hsName ++ " -> (Ptr " ++ hsName ++ " -> IO b) -> IO b" ++- "\nwith" ++ hsName ++ " (" ++ hsName ++ " fptr) = withForeignPtr fptr"+ hsName ++ " -> (" ++ impm "Ptr" ++ " " ++ hsName+ ++ " -> IO b) -> IO b" +++ "\n" ++ "with" ++ hsName ++ " (" ++ hsName +++ " fptr) = " ++ impm "withForeignPtr" ++ " fptr" | otherwise = "" isForeign (CHSForeignPtr _) = True isForeign _ = False@@ -1620,6 +1750,7 @@ finHsIde = finCIde `maybe` identToString $ ohside cdecl' = cide' `simplifyDecl` cdecl header <- getSwitch headerSB+ addHsDependency "Foreign.ForeignPtr" delayCode hook (finalizerImport (extractCallingConvention cdecl') header finCIde finHsIde ptrHsIde) traceFunType ptrHsIde@@ -1635,7 +1766,7 @@ String -> String finalizerImport cconv header ident hsIdent hsPtrName = "foreign import " ++ showCallingConvention cconv ++ " " ++ show entity ++- "\n " ++ hsIdent ++ " :: FinalizerPtr " ++ hsPtrName ++ "\n"+ "\n " ++ hsIdent ++ " :: " ++ impm "FinalizerPtr" ++ " " ++ hsPtrName ++ "\n" where entity | null header = "&" ++ ident | otherwise = header ++ " &" ++ ident@@ -1659,7 +1790,7 @@ do let toMethodName = case typeName of- "" -> interr "GenBind.classDef: Illegal identifier!"+ "" -> errorAtPos pos ["GenBind.classDef: Illegal identifier!"] c:cs -> toLower c : cs fromMethodName = "from" ++ typeName classDefContext = case superClasses of@@ -1682,7 +1813,7 @@ unless (ptrType == ptrType') $ pointerTypeMismatchErr pos className superName let toMethodName = case ptrName of- "" -> interr "GenBind.classDef: Illegal identifier - 2!"+ "" -> errorAtPos pos ["GenBind.classDef: Illegal identifier - 2!"] c:cs -> toLower c : cs fromMethodName = "from" ++ ptrName castFun = "cast" ++ show ptrType@@ -1754,6 +1885,7 @@ isFunExtType _ = False numArgs :: ExtType -> Int+numArgs (FunET UnitET f) = numArgs f numArgs (FunET _ f) = 1 + numArgs f numArgs _ = 0 @@ -1783,34 +1915,52 @@ showExtType (VarFunET res) = "( ... -> " ++ showExtType res ++ ")" showExtType (IOET t) = "(IO " ++ showExtType t ++ ")" showExtType (PtrET t) = let ptrCon = if isFunExtType t- then "FunPtr" else "Ptr"+ then impm "FunPtr"+ else impm "Ptr" in "(" ++ ptrCon ++ " " ++ showExtType t ++ ")" showExtType (DefinedET _ str) = "(" ++ str ++ ")"-showExtType (PrimET CPtrPT) = "(Ptr ())"-showExtType (PrimET CFunPtrPT) = "(FunPtr ())"-showExtType (PrimET CCharPT) = "CChar"-showExtType (PrimET CUCharPT) = "CUChar"-showExtType (PrimET CSCharPT) = "CSChar"-showExtType (PrimET CIntPT) = "CInt"-showExtType (PrimET CShortPT) = "CShort"-showExtType (PrimET CLongPT) = "CLong"-showExtType (PrimET CLLongPT) = "CLLong"-showExtType (PrimET CUIntPT) = "CUInt"-showExtType (PrimET CUShortPT) = "CUShort"-showExtType (PrimET CULongPT) = "CULong"-showExtType (PrimET CULLongPT) = "CULLong"-showExtType (PrimET CFloatPT) = "CFloat"-showExtType (PrimET CDoublePT) = "CDouble"-showExtType (PrimET CLDoublePT) = "CLDouble"-showExtType (PrimET CBoolPT) = "CInt{-bool-}"-showExtType (PrimET (CSFieldPT bs)) = "CInt{-:" ++ show bs ++ "-}"-showExtType (PrimET (CUFieldPT bs)) = "CUInt{-:" ++ show bs ++ "-}"+showExtType (PrimET CPtrPT) = "(" ++ impm "Ptr" ++ " ())"+showExtType (PrimET CFunPtrPT) = "(" ++ impm "FunPtr" ++ " ())"+showExtType (PrimET CCharPT) = impm "CChar"+showExtType (PrimET CUCharPT) = impm "CUChar"+showExtType (PrimET CSCharPT) = impm "CSChar"+showExtType (PrimET CIntPT) = impm "CInt"+showExtType (PrimET CShortPT) = impm "CShort"+showExtType (PrimET CLongPT) = impm "CLong"+showExtType (PrimET CLLongPT) = impm "CLLong"+showExtType (PrimET CUIntPT) = impm "CUInt"+showExtType (PrimET CUShortPT) = impm "CUShort"+showExtType (PrimET CULongPT) = impm "CULong"+showExtType (PrimET CULLongPT) = impm "CULLong"+showExtType (PrimET CFloatPT) = impm "CFloat"+showExtType (PrimET CDoublePT) = impm "CDouble"+showExtType (PrimET CLDoublePT) = impm "CLDouble"+showExtType (PrimET CBoolPT) = impm "CInt{-bool-}"+showExtType (PrimET (CSFieldPT bs)) = impm "CInt{-:" ++ show bs ++ "-}"+showExtType (PrimET (CUFieldPT bs)) = impm "CUInt{-:" ++ show bs ++ "-}" showExtType (PrimET (CAliasedPT _ hs _)) = hs showExtType UnitET = "()"-showExtType (SUET _) = "(Ptr ())"+showExtType (SUET _) = "(" ++ impm "Ptr" ++ " ())" +addExtTypeDependency :: ExtType -> GB ()+addExtTypeDependency (FunET UnitET res) = addExtTypeDependency res+addExtTypeDependency (FunET arg res) = do+ addExtTypeDependency arg+ addExtTypeDependency res+addExtTypeDependency (VarFunET res) = addExtTypeDependency res+addExtTypeDependency (IOET t) = addExtTypeDependency t+addExtTypeDependency (PtrET t) = do+ addHsDependency "Foreign.Ptr"+ addExtTypeDependency t+addExtTypeDependency (PrimET CPtrPT) = addHsDependency "Foreign.Ptr"+addExtTypeDependency (PrimET CFunPtrPT) = addHsDependency "Foreign.Ptr"+addExtTypeDependency (PrimET (CAliasedPT _ _ _)) = return ()+addExtTypeDependency (PrimET _) = addHsDependency "Foreign.C.Types"+addExtTypeDependency (SUET _) = addHsDependency "Foreign.Ptr"+addExtTypeDependency _ = return ()+ showExtFunType :: ExtType -> [ExtType] -> String showExtFunType (FunET UnitET res) _ = showExtType res showExtFunType (FunET arg res) vas =@@ -1825,14 +1975,13 @@ -- -- * the identifier specifies in which of the declarators we are interested ----- * if the third argument is 'True', the function result should not be--- wrapped into an 'IO' type+-- * the function result is wrapped into an 'IO' type -- -- * the caller has to guarantee that the object does indeed refer to a -- function ---extractFunType :: Position -> CDecl -> Bool -> Maybe [Bool] -> GB ExtType-extractFunType pos cdecl isPure wrapped =+extractFunType :: Position -> CDecl -> Maybe [Bool] -> GB ExtType+extractFunType pos cdecl wrapped = do -- remove all declarators except that of the function we are processing; -- then, extract the functions arguments and result type (also check that@@ -1844,9 +1993,7 @@ -- -- we can now add the 'IO' monad if this is no pure function --- let protoResultType = if isPure- then preResultType- else IOET preResultType+ let protoResultType = IOET preResultType let resultType = if variadic then VarFunET protoResultType else protoResultType@@ -1909,7 +2056,7 @@ extractCompType :: Bool -> Bool -> Bool -> CDecl -> GB ExtType extractCompType isResult usePtrAliases isPtr cdecl@(CDecl specs' declrs ats) = if length declrs > 1- then interr "GenBind.extractCompType: Too many declarators!"+ then errorAtPos (posOf cdecl) ["GenBind.extractCompType: Too many declarators!"] else case declrs of [(Just declr, _, sz)] | isPtr || isPtrDeclr declr -> ptrType declr | isFunDeclr declr -> funType@@ -1946,7 +2093,7 @@ funType = do traceFunType -- ??? IS Nothing OK HERE?- extractFunType (posOf cdecl) cdecl False Nothing+ extractFunType (posOf cdecl) cdecl Nothing makeAliasedCompType :: Ident -> CHSTypedefInfo -> GB ExtType makeAliasedCompType cIde (hsIde, et) = do@@ -2070,8 +2217,8 @@ case tspecs of [CSUType cu _] -> return $ SUET cu -- struct or union [CEnumType _ _] -> return $ PrimET CIntPT -- enum- [CTypeDef _ _] -> interr "GenBind.specType: Illegal typedef alias!"- _ -> trace ("\nERROR:\nspecs''=" ++ show specs'' ++ "\nosize=" ++ show osize ++ "\ntspecs=" ++ show tspecs ++ "\nlookup=" ++ show (lookupTSpec tspecs typeMap) ++ "\n\n") $ illegalTypeSpecErr cpos+ [CTypeDef _ _] -> errorAtPos cpos ["GenBind.specType: Illegal typedef alias!"]+ _ -> illegalTypeSpecErr cpos where lookupTSpec = lookupBy matches --@@ -2271,7 +2418,9 @@ -- | compute the size and alignment constraint of a given C declaration -- sizeAlignOf :: CDecl -> GB (BitSize, Int)-sizeAlignOfSingle :: CDecl -> GB (BitSize, Int)+sizeAlignOfPtr :: CDecl -> GB (BitSize, Int)+sizeAlignOfBase :: Bool -> CDecl -> GB (BitSize, Int)+sizeAlignOfSingle :: Bool -> CDecl -> GB (BitSize, Int) -- -- * we make use of the assertion that 'extractCompType' can only return a -- 'DefinedET' when the declaration is a pointer declaration@@ -2281,10 +2430,12 @@ -- and I have no idea what happens when an array-of-bitfield is -- declared. At this time I don't care. -- U.S. 05/2006 ---sizeAlignOf (CDecl dclspec- [(Just (CDeclr oide (CArrDeclr _ (CArrSize _ lexpr) _ :- derived') _asm _ats n), init', expr)]- attr) =+sizeAlignOf = sizeAlignOfBase False+sizeAlignOfPtr = sizeAlignOfBase True+sizeAlignOfBase _ (CDecl dclspec+ [(Just (CDeclr oide (CArrDeclr _ (CArrSize _ lexpr) _ :+ derived') _asm _ats n), init', expr)]+ attr) = do (bitsize, align) <- sizeAlignOf (CDecl dclspec@@ -2292,13 +2443,13 @@ attr) IntResult len <- evalConstCExpr lexpr return (fromIntegral len `scaleBitSize` bitsize, align)-sizeAlignOf (CDecl _ [(Just (CDeclr _ (CArrDeclr _ (CNoArrSize _) _ :- _) _ _ _), _init, _expr)] _) =- interr "GenBind.sizeAlignOf: array of undeclared size."-sizeAlignOf cdecl = do+sizeAlignOfBase _ cdecl@(CDecl _ [(Just (CDeclr _ (CArrDeclr _ (CNoArrSize _) _ :+ _) _ _ _), _init, _expr)] _) =+ errorAtPos (posOf cdecl) ["GenBind.sizeAlignOf: array of undeclared size."]+sizeAlignOfBase ptr cdecl = do traceAliasCheck case checkForOneAliasName cdecl of- Nothing -> sizeAlignOfSingle cdecl+ Nothing -> sizeAlignOfSingle ptr cdecl Just ide -> do -- this is a typedef alias traceAlias ide cdecl' <- getDeclOf ide@@ -2311,7 +2462,7 @@ "extractCompType: found an alias called `" ++ identToString ide ++ "'\n" -sizeAlignOfSingle cdecl = do+sizeAlignOfSingle ptr cdecl = do ct <- extractCompType False False False cdecl case ct of FunET _ _ -> do@@ -2320,7 +2471,7 @@ VarFunET _ -> do align <- alignment CFunPtrPT return (bitSize CFunPtrPT, align)- IOET _ -> interr "GenBind.sizeof: Illegal IO type!"+ IOET _ -> errorAtPos (posOf cdecl) ["GenBind.sizeof: Illegal IO type!"] PtrET t | isFunExtType t -> do align <- alignment CFunPtrPT@@ -2329,11 +2480,15 @@ align <- alignment CPtrPT return (bitSize CPtrPT, align) DefinedET _ _ ->- interr "GenBind.sizeAlignOf: Should never get a defined type"+ errorAtPos (posOf cdecl) ["GenBind.sizeAlignOf: Should never get a defined type"] PrimET pt -> do align <- alignment pt return (bitSize pt, align)- UnitET -> voidFieldErr (posOf cdecl)+ UnitET -> if ptr+ then do+ align <- alignment CPtrPT+ return (bitSize CPtrPT, align)+ else voidFieldErr (posOf cdecl) SUET su -> do let (fields, tag) = structMembers su fields' <- let ide = structName su@@ -2427,7 +2582,7 @@ illegalConstExprErr (posOf at) "function call" evalConstCExpr (CMember _ _ _ at) = illegalConstExprErr (posOf at) "a . or -> operator"-evalConstCExpr (CVar ide''' at) =+evalConstCExpr cdecl@(CVar ide''' at) = do (cobj, _) <- findValueObj ide''' False case cobj of@@ -2444,7 +2599,7 @@ -- Compute the tag value for `ide' defined in the given enumerator list -- enumTagValue _ [] _ =- interr "GenBind.enumTagValue: enumerator not in declaration"+ errorAtPos (posOf cdecl) ["GenBind.enumTagValue: enumerator not in declaration"] enumTagValue ide ((ide', oexpr):enumrs) val = do val' <- case oexpr of@@ -2538,14 +2693,14 @@ (IntResult y) = return $ IntResult (x .|. y) applyBin _ CAndOp (IntResult x) (IntResult y) = return $ IntResult (x .&. y)-applyBin _ _ (IntResult _)+applyBin pos _ (IntResult _) (IntResult _) =- todo "GenBind.applyBin: Not yet implemented operator in constant expression."-applyBin _ _ (FloatResult _)+ todo $ "GenBind.applyBin: Not yet implemented operator in constant expression. " ++ show pos+applyBin pos _ (FloatResult _) (FloatResult _) =- todo "GenBind.applyBin: Not yet implemented operator in constant expression."-applyBin _ _ _ _ =- interr "GenBind.applyBinOp: Illegal combination!"+ todo $ "GenBind.applyBin: Not yet implemented operator in constant expression. " ++ show pos+applyBin pos _ _ _ =+ errorAtPos pos ["GenBind.applyBinOp: Illegal combination!"] applyUnary :: Position -> CUnaryOp -> ConstResult -> GB ConstResult applyUnary cpos CPreIncOp _ =@@ -2563,8 +2718,8 @@ applyUnary _ CPlusOp arg = return arg applyUnary _ CMinOp (IntResult x) = return (IntResult (-x)) applyUnary _ CMinOp (FloatResult x) = return (FloatResult (-x))-applyUnary _ CCompOp _ =- todo "GenBind.applyUnary: ~ not yet implemented."+applyUnary pos CCompOp _ =+ todo $ "GenBind.applyUnary: ~ not yet implemented. " ++ show pos applyUnary _ CNegOp (IntResult x) = let r = toInteger . fromEnum $ (x == 0) in return (IntResult r)@@ -2646,7 +2801,7 @@ "which ANSI C89 does not permit."] voidFieldErr :: Position -> GB a-voidFieldErr cpos =+voidFieldErr cpos = raiseErrorCTExc cpos ["Void field in struct!", "Attempt to access a structure field of type void."]
src/C2HS/Gen/Monad.hs view
@@ -77,7 +77,8 @@ objIs, queryObj, sizeIs, querySize, queryClass, queryPointer, mergeMaps, dumpMaps, queryEnum, isEnum, queryTypedef, isC2HSTypedef, queryDefaultMarsh, isDefaultMarsh,- addWrapper, getWrappers+ addWrapper, getWrappers,+ addHsDependency, getHsDependencies ) where -- standard libraries@@ -249,6 +250,8 @@ type WrapperSet = Set Wrapper +type Dependencies = Set String+ {- FIXME: What a mess... instance Show HsObject where show (Pointer ptrType isNewtype) =@@ -310,7 +313,8 @@ enums :: EnumSet, -- enumeration hooks tdmap :: TypedefMap, -- typedefs dmmap :: DefaultMarshMap, -- user-defined default marshallers- wrappers :: WrapperSet+ wrappers :: WrapperSet, -- C wrapper functions+ deps :: Dependencies -- Haskell dependencies (for imports) } type GB a = CT GBState a@@ -327,7 +331,8 @@ enums = Set.empty, tdmap = Map.empty, dmmap = Map.empty,- wrappers = Set.empty+ wrappers = Set.empty,+ deps = Set.empty } -- | set the dynamic library and library prefix@@ -558,6 +563,14 @@ getWrappers :: GB [Wrapper] getWrappers = Set.toList `fmap` readCT wrappers+++-- | add Haskell module dependency for import generation+addHsDependency :: String -> GB ()+addHsDependency m = transCT (\st -> (st { deps = Set.insert m (deps st) }, ()))++getHsDependencies :: GB [String]+getHsDependencies = Set.toList `fmap` readCT deps -- error messages
src/C2HS/Gen/Wrapper.hs view
@@ -71,9 +71,9 @@ let fspecs = if boolres then map replaceBoolSpec specs else specs+ expr <- callBody ofn pos args decl+ let body = CCompound [] [CBlockStmt (CReturn (Just expr) undefNode)] undefNode wrapfn = CFunDef fspecs wrapdecl [] body undefNode- body = CCompound [] [CBlockStmt (CReturn expr undefNode)] undefNode- expr = Just $ callBody ofn args decl return $ DL.fromList [render (pretty wrapfn) ++ "\n"] genWrapper (Wrapper _ ofn _ _ _ pos) = internalWrapperErr pos ["genWrapper:" ++ ofn]@@ -95,7 +95,7 @@ -> CST s CDerivedDeclr fixFunArgs ofn pos args bools (CFunDeclr (Right (adecls, flg)) attrs n) = do- adecls' <- zipWithM (fixDecl ofn pos) (zip args bools) adecls+ adecls' <- zipWithM (fixDecl ofn pos) (zip3 args bools [1..]) adecls return $ CFunDeclr (Right (adecls', flg)) attrs n fixFunArgs ofn pos args bools cdecl = internalWrapperErr pos ["fixFunArgs:" ++ ofn,@@ -110,18 +110,20 @@ replaceBoolSpec (CTypeSpec (CBoolType tn)) = CTypeSpec (CIntType tn) replaceBoolSpec t = t -fixDecl :: String -> Position -> (Bool, Bool) -> CDecl -> CST s CDecl-fixDecl _ _ (False, True) d = return $ replaceBool d-fixDecl _ _ (False, False) d = return d-fixDecl _ pos (True, _) (CDecl specs [(Just decl, Nothing, Nothing)] n) = do+fixDecl :: String -> Position -> (Bool, Bool, Int) -> CDecl -> CST s CDecl+fixDecl _ _ (False, True, idx) d = return $ replaceBool $ fixEmpty d idx+fixDecl _ _ (False, False, idx) d = return $ fixEmpty d idx+fixDecl _ pos (True, _, idx) din = do+ let (CDecl specs [(Just decl, Nothing, Nothing)] n) = fixEmpty din idx decl' <- addPtr pos decl return $ CDecl specs [(Just decl', Nothing, Nothing)] n-fixDecl ofn pos (arg, bool) cdecl =- internalWrapperErr pos ["fixDecl:ofn=" ++ ofn,- "arg=" ++ show arg,- "bool=" ++ show bool,- "cdecl=" ++ show cdecl] +fixEmpty :: CDecl -> Int -> CDecl+fixEmpty d@(CDecl _ [(Just _, Nothing, Nothing)] _) _ = d+fixEmpty (CDecl ss [] n) idx =+ let d = CDeclr (Just $ internalIdent $ "c2hs__dummy_arg_" ++ show idx) [] Nothing [] n+ in CDecl ss [(Just d, Nothing, Nothing)] n+ addPtr :: Position -> CDeclr -> CST s CDeclr addPtr _ (CDeclr ide [] cs attrs n) = return $ CDeclr ide [CPtrDeclr [] n] cs attrs n@@ -129,15 +131,26 @@ then wrapperOnPointerErr pos else invalidWrapperErr pos -callBody :: String -> [Bool] -> CDeclr -> CExpr-callBody fn args (CDeclr _ (fd:_) _ _ n) =- CCall (CVar (internalIdent fn) n) (zipWith makeArg args (funArgs fd)) n+callBody :: String -> Position -> [Bool] -> CDeclr -> CST s CExpr+callBody fn pos args (CDeclr _ (fd:_) _ _ n) = do+ as <- zipWithM (makeArg pos) (zip args [1..]) (funArgs fd)+ return $ CCall (CVar (internalIdent fn) n) as n -makeArg :: Bool -> CDecl -> CExpr-makeArg arg (CDecl _ [(Just (CDeclr (Just i) _ _ _ _), _, _)] n) =- case arg of++makeArg :: Position -> (Bool, Int) -> CDecl -> CST s CExpr+makeArg _ (arg, _) (CDecl _ [(Just (CDeclr (Just i) _ _ _ _), _, _)] n) =+ return $ case arg of False -> CVar i n True -> CUnary CIndOp (CVar i n) n+makeArg _ (arg, idx) (CDecl _ [] n) =+ let i = internalIdent $ "c2hs__dummy_arg_" ++ show idx+ in return $ case arg of+ False -> CVar i n+ True -> CUnary CIndOp (CVar i n) n+makeArg pos (arg, idx) cdecl =+ internalWrapperErr pos ["makeArg:arg=" ++ show arg,+ "cdecl=" ++ show cdecl,+ "idx=" ++ show idx] funArgs :: CDerivedDeclr -> [CDecl] funArgs (CFunDeclr (Right (adecls, _)) _ _) = adecls
src/C2HS/Version.hs view
@@ -9,8 +9,8 @@ name = "C->Haskell Compiler" versnum = Paths_c2hs.version-versnick = "Snowboundest"-date = "31 Oct 2014"+versnick = "Budburst"+date = "4 April 2015" version = name ++ ", version " ++ showVersion versnum ++ " " ++ versnick ++ ", " ++ date copyright = "Copyright (c) 1999-2007 Manuel M T Chakravarty\n" ++ " 2005-2008 Duncan Coutts\n"
tests/bugs/issue-10/Issue10.chs view
@@ -1,7 +1,6 @@ module Main where import Control.Monad-import Foreign.C #include "issue10.h"
tests/bugs/issue-102/Issue102.chs view
@@ -1,10 +1,5 @@ module Main where -import Control.Monad-import Foreign-import Foreign.C.String-import Foreign.C.Types- #include <stdio.h> #include <fcntl.h>
tests/bugs/issue-115/Issue115.chs view
@@ -1,7 +1,6 @@ module Main where -import Foreign-import Foreign.C+import Foreign.Marshal.Array #include "issue115.h"
tests/bugs/issue-123/Issue123.chs view
@@ -1,7 +1,6 @@ module Main where import Foreign-import Foreign.C #include "issue123.h"
tests/bugs/issue-127/Issue127.chs view
@@ -1,8 +1,5 @@ module Main where -import Foreign-import Foreign.C.Types- #include "issue127.h" {#fun tst as ^ {`Int'} -> `Bool'#}
− tests/bugs/issue-128/tst.c
@@ -1,2 +0,0 @@-#include <stdio.h>-int main(int argc, char *argv[]) { printf("%u\n", sizeof(_Bool)); }
+ tests/bugs/issue-130/Issue130.chs view
@@ -0,0 +1,15 @@+module Main where++import Foreign.C.Types+import Foreign.Marshal.Alloc+import Foreign.Storable++#include "issue130.h"++main :: IO ()+main = do+ print (myAdd 1 2)+ print =<< myAddIO 1 2++{#fun pure unsafe my_add as myAdd {`CInt', `CInt', alloca- `CInt' peek* } -> `()'#}+{#fun unsafe my_add as myAddIO {`CInt', `CInt', alloca- `CInt' peek* } -> `()'#}
+ tests/bugs/issue-130/issue130.c view
@@ -0,0 +1,6 @@+#include "issue130.h"++void my_add(int *a, int *b, int *result)+{+ *result = *a + *b;+}
+ tests/bugs/issue-130/issue130.h view
@@ -0,0 +1,1 @@+void my_add(int *a, int *b, int *result);
+ tests/bugs/issue-131/Issue131.chs view
@@ -0,0 +1,17 @@+module Main where++import Control.Monad+import Foreign.C.Types+import Foreign.Marshal.Utils++#include "issue131.h"++{#fun f1 as ^ {`Int', `Bool'} -> `Int'#}+{#fun f2 as ^ {`Int'} -> `Bool'#}++main :: IO ()+main = do+ f1 4 True >>= print+ f1 4 False >>= print+ f2 4 >>= print+ f2 0 >>= print
+ tests/bugs/issue-131/issue131.c view
@@ -0,0 +1,15 @@+#include <stdlib.h>+#include "issue131.h"++int f1(int n, bool incr)+{+ if (incr)+ return n + 1;+ else+ return n - 1;+}++bool f2(int n)+{+ return n > 0;+}
+ tests/bugs/issue-131/issue131.h view
@@ -0,0 +1,4 @@+#include <stdbool.h>++int f1(int, bool);+bool f2(int);
+ tests/bugs/issue-133/Issue133.chs view
@@ -0,0 +1,9 @@+module Main where++#include "issue133.h"++{#pointer tdptst as VoidTest1#}+{#pointer *tdtst as VoidTest2#}++main :: IO ()+main = putStrLn "OK"
+ tests/bugs/issue-133/issue133.h view
@@ -0,0 +1,2 @@+typedef void *tdptst;+typedef void tdtst;
+ tests/bugs/issue-134/Issue134.chs view
@@ -0,0 +1,8 @@+module Main where++#include "issue134.h"++{# pointer *tst as ^ foreign newtype #}++main :: IO ()+main = putStrLn "OK"
+ tests/bugs/issue-134/issue134.h view
@@ -0,0 +1,3 @@+struct tst { int a; };++int tst(int, int);
+ tests/bugs/issue-136/Issue136.chs view
@@ -0,0 +1,43 @@+{-# LANGUAGE EmptyDataDecls,+ ForeignFunctionInterface #-}++{- |+This will break things if you're not careful about comment parsing...+-- Hmmm...+-}++-- And so will this -}++module Main where++import Control.Applicative ( (<$>)+ , (<*>)+ , (*>))+import Foreign.Marshal.Utils+import Foreign.Storable++#include "issue136.h"++data Foo+data Bar = Bar Int Int++instance Storable Bar where+ sizeOf _ = {#sizeof bar_t #}+ alignment _ = {#alignof bar_t #}+ peek p = Bar+ <$> (fromIntegral <$> {#get bar_t.y #} p)+ <*> (fromIntegral <$> {#get bar_t.z #} p)+ poke p (Bar y z) =+ ({#set bar_t.y #} p $ fromIntegral y)+ *> ({#set bar_t.z #} p $ fromIntegral z)++{#pointer *foo_t as FooPtr -> Foo #}+{#pointer *bar_t as BarPtr -> Bar #}++{#fun unsafe mutate_foo as mutateFoo+ { `FooPtr'+ , with* `Bar'+ } -> `()' #}++main :: IO ()+main = putStrLn "OK"
+ tests/bugs/issue-136/issue136.c view
@@ -0,0 +1,5 @@+#include "issue136.h"++void mutate_foo(foo_t *foo, bar_t *bar) {+ foo->bar = *bar;+}
+ tests/bugs/issue-136/issue136.h view
@@ -0,0 +1,11 @@+typedef struct {+ int y;+ int z;+} bar_t;++typedef struct {+ int x;+ bar_t bar;+} foo_t;++void mutate_foo(foo_t *foo, bar_t *bar);
tests/bugs/issue-15/Issue15.chs view
@@ -1,6 +1,5 @@ module Main where -import Foreign.C.Types import Numeric import Data.Char
tests/bugs/issue-23/Issue23.chs view
@@ -1,7 +1,5 @@ module Main where -import Foreign.C- #include "issue23.h" #include "issue23x.h"
tests/bugs/issue-25/Issue25.chs view
@@ -1,6 +1,5 @@ module Main where -import Foreign import Foreign.C #include <wchar.h>
tests/bugs/issue-31/Issue31.chs view
@@ -1,9 +1,5 @@ module Main where -import Control.Monad-import Foreign-import Foreign.C- #include "issue31.h" -- CASE 1:
tests/bugs/issue-32/Issue32.chs view
@@ -1,10 +1,5 @@ module Main where -import Data.Bits-import Foreign.C-import Foreign.Ptr-import Foreign.Storable- #include "issue32.h" {#pointer *testStruct as TestStructPtr #}
tests/bugs/issue-36/Issue36.chs view
@@ -1,7 +1,5 @@ module Main where -import Foreign- #include "issue36.h" data Hit1 a = Hit1 a
tests/bugs/issue-38/Issue38.chs view
@@ -1,7 +1,5 @@ module Main where -import Foreign.C- #include "issue38.h" {#enum test_enum as TestEnum {underscoreToCase} deriving (Eq, Show)#}
tests/bugs/issue-44/Issue44.chs view
@@ -1,7 +1,5 @@ module Main where -import Foreign- #include "issue44.h" {#pointer *foo as ^ foreign newtype#}
tests/bugs/issue-45/Issue45.chs view
@@ -1,7 +1,5 @@ module Main where -import Foreign.C- #include "issue45.h" main :: IO ()
tests/bugs/issue-46/Issue46.chs view
@@ -1,8 +1,5 @@ module Main where -import Foreign-import Foreign.C.Types- #include "issue46.h" {#pointer *oid as Oid foreign newtype#}
tests/bugs/issue-47/Issue47.chs view
@@ -1,7 +1,5 @@ module Main where -import Foreign.C- #include "issue47.h" {#fun foo {`Int'} -> `()'#}
tests/bugs/issue-48/Issue48.chs view
@@ -1,6 +1,5 @@ module Main where -import Foreign.C import Foreign.C.Types #include "issue48.h"
tests/bugs/issue-54/Issue54.chs view
@@ -1,8 +1,5 @@ module Main where -import Foreign-import Foreign.C- #include "issue54.h" {#pointer *bar as Bar#}
tests/bugs/issue-69/Issue69.chs view
@@ -1,7 +1,5 @@ module Main where -import Foreign.C- #include "issue69.h" {#fun foo1 {`Int'} -> `()'#}
tests/bugs/issue-73/Issue73.chs view
@@ -1,9 +1,5 @@ module Main where -import Control.Monad-import Foreign-import Foreign.C- #include "issue73.h" -- * withForeignPtr and newForeignPtr_ for foreign pointer hooks
tests/bugs/issue-75/Issue75.chs view
@@ -1,8 +1,5 @@ module Main where -import Foreign-import Foreign.C- {#context prefix="chk"#} #include "issue75.h"@@ -16,4 +13,3 @@ s <- makeTst aval <- {#get CHK_TST.a#} s putStrLn $ show aval-
tests/bugs/issue-96/Issue96.chs view
@@ -1,8 +1,6 @@ module Main where import Foreign.C.Types-import Foreign.Ptr-import Foreign.Storable #include "issue96.h"
tests/bugs/issue-97/Issue97.chs view
@@ -5,6 +5,7 @@ {#import Issue97A#} import Foreign import Foreign.C.Types+import System.IO.Unsafe (unsafePerformIO) #include "issue97.h"
tests/bugs/issue-98/Issue98.chs view
@@ -1,8 +1,5 @@ module Main where -import Foreign.C.Types-import Foreign.C.String- #include "issue98.h" {#fun pure identichar as ^ { `Char' } -> `Char' #}
tests/regression-suite.hs view
@@ -23,7 +23,11 @@ , cabalBuildTools :: [Text] , specialSetup :: [Text] , extraPath :: [Text]+ , extraSOPath :: [Text]+ , extraIncludeDirs :: [Text]+ , extraLibDirs :: [Text] , onTravis :: Bool+ , runTests :: Bool } deriving (Eq, Show) instance FromJSON RegressionTest where@@ -35,9 +39,34 @@ <*> v .:? "cabal-build-tools" .!= [] <*> v .:? "special-setup" .!= [] <*> v .:? "extra-path" .!= []+ <*> v .:? "extra-so-path" .!= []+ <*> v .:? "extra-include-dirs" .!= []+ <*> v .:? "extra-lib-dirs" .!= [] <*> v .:? "on-travis" .!= True+ <*> v .:? "run-tests" .!= False parseJSON _ = mzero +data Code = TestOK+ | DepsFailed+ | ConfFailed+ | BuildFailed+ | TestsFailed+ deriving Eq++instance Show Code where+ show TestOK = "OK"+ show DepsFailed = "dependencies"+ show ConfFailed = "configuration"+ show BuildFailed = "build"+ show TestsFailed = "tests"++makeCode :: (Int, Int, Int, Int) -> Code+makeCode (0, 0, 0, 0) = TestOK+makeCode (0, 0, 0, _) = TestsFailed+makeCode (0, 0, _, _) = BuildFailed+makeCode (0, _, _, _) = ConfFailed+makeCode (_, _, _, _) = DepsFailed+ readTests :: FilePath -> IO [RegressionTest] readTests fp = maybe [] id <$> decodeFile fp @@ -67,6 +96,7 @@ buildTools = nub $ concatMap cabalBuildTools tests specials = concatMap specialSetup tests extraPaths = concatMap extraPath tests+ extraSOPaths = concatMap extraSOPath tests when (not travis) $ echo "ASSUMING THAT ALL NECESSARY LIBRARIES ALREADY INSTALLED!\n"@@ -99,24 +129,52 @@ appendToPath $ fromText p echo "\n" + when (not (null extraSOPaths)) $ do+ echo "ADDING SHARED LIBRARY PATHS\n"+ forM_ extraSOPaths $ \p -> do+ echo p+ appendToSOPath p+ echo "\n"+ codes <- forM (filter cabal tests) $ \t -> do let n = name t+ tst = runTests t infs = concatMap (\f -> ["-f", f]) $ flags t+ extralibs = map (\f -> "--extra-lib-dirs=" <> f) $+ extraLibDirs t+ extraincs = map (\f -> "--extra-include-dirs=" <> f) $+ extraIncludeDirs t mefs <- get_env $ "C2HS_REGRESSION_FLAGS_" <> n- let fs = case mefs of+ let fs = if tst then ["--enable-tests"] else [] ++ case mefs of Nothing -> infs Just efs -> infs ++ concatMap (\f -> ["-f", f]) (T.splitOn "," efs) echo $ "\nREGRESSION TEST: " <> n <> "\n" errExit False $ do- run_ "cabal" $ ["install", "--jobs=1", "-v"] ++ fs ++ [n]- lastExitCode+ unpack <- run "cabal" ["unpack", n]+ let d = T.drop (T.length "Unpacking to ") $ T.init $ last $ T.lines unpack+ chdir (fromText d) $ do+ run_ "cabal" $ ["sandbox", "init"]+ run_ "cabal" $ ["install", "--only-dep", "-v"] ++ fs+ dep <- lastExitCode+ run_ "cabal" $ ["configure"] ++ extraincs ++ extralibs ++ fs+ conf <- lastExitCode+ run_ "cabal" $ ["build"]+ build <- lastExitCode+ test <-+ if tst then do+ run_ "cabal" ["test"]+ lastExitCode+ else return 0+ return $ makeCode (dep, conf, build, test) - if all (== 0) codes+ if all (== TestOK) codes then exit 0 else do- let failed = filter (\(c, _) -> c /= 0) $ zip codes (filter cabal tests)- forM_ failed $ \(c, t) -> echo $ "FAILED: " <> name t- echo "SOME TESTS FAILED"+ echo "\n\nSOME TESTS FAILED\n"+ let failed = filter (\(c, _) -> c /= TestOK) $ zip codes (filter cabal tests)+ forM_ failed $ \(c, t) -> echo $ "FAILED: " <> name t <>+ " (" <> T.pack (show c) <> ")"+ exit 1 escapedWords :: Text -> [Text] escapedWords = map (T.pack . reverse) . escWords False "" . T.unpack@@ -136,3 +194,8 @@ escWords True acc (c:cs) | c == '\'' = acc : escWords False "" cs | otherwise = escWords True (c:acc) cs++appendToSOPath :: Text -> Sh ()+appendToSOPath tp = do+ pe <- get_env_text "LD_LIBRARY_PATH"+ setenv "LD_LIBRARY_PATH" $ pe <> ":" <> tp
tests/system/cpp/Cpp.chs view
@@ -4,6 +4,7 @@ import Foreign import Foreign.C+import System.IO.Unsafe (unsafePerformIO) -- CPP directive -- -
tests/system/enums/Enums.chs view
@@ -2,6 +2,7 @@ import Control.Monad import Foreign import Foreign.C+import System.IO.Unsafe (unsafePerformIO) cToEnum :: (Integral i, Enum e) => i -> e cToEnum = toEnum . fromIntegral@@ -24,7 +25,7 @@ {#enum enums_enums as Enums {underscoreToCase, ENUMS_TWO as Two}#} colourOfSide :: Side -> Colour-colourOfSide = +colourOfSide = cToEnum . {#call fun colourOfSide as colourOfSidePrim#} . cFromEnum #c@@ -42,7 +43,7 @@ {#enum ThisThatCast {}#} -main :: IO () +main :: IO () main = do const (return ()) discard unless (1 == fromEnum One) $
tests/system/structs/Structs.chs view
@@ -7,6 +7,7 @@ import Control.Monad (liftM, when) import Foreign import Foreign.C+import System.IO.Unsafe (unsafePerformIO) cIntConv :: (Integral a, Integral b) => a -> b cIntConv = fromIntegral@@ -24,7 +25,7 @@ bar = {#sizeof SDL_Event#} -- regression test -main :: IO () +main :: IO () main = do val <- liftM cIntConv $ {#get _point.y#} $! unPoint pnt val' <- liftM cIntConv $ {#get point->y#} $! unPoint pnt@@ -34,7 +35,7 @@ val2 <- liftM cIntConv $ {#get weird->x#} weird val3 <- liftM cIntConv $ {#get weird->nested.z#} weird val4 <- liftM cIntConv $ {#get weird->nested.pnt->y#} weird- const nop $ {#set cpoint->col#} nullPtr 5 + const nop $ {#set cpoint->col#} nullPtr 5 -- only for seeing what is generated spacePtr <- {#call getSpacePtr#} space <- liftM castCCharToChar $ {#get *mychar#} spacePtr;
tests/test-bugs.hs view
@@ -80,6 +80,11 @@ , testCase "Issue #123" issue123 , testCase "Issue #127" issue127 , testCase "Issue #128" issue128+ , testCase "Issue #130" issue130+ , testCase "Issue #131" issue131+ , testCase "Issue #133" issue133+ , testCase "Issue #134" issue134+ , testCase "Issue #136" issue136 ] ++ -- Some tests that won't work on Windows. if os /= "cygwin32" && os /= "mingw32"@@ -99,6 +104,31 @@ res <- absPath "./Capital" >>= cmd let expected = ["upper C();", "lower c();", "upper C();"] liftIO $ assertBool "" (T.lines res == expected)++issue136 :: Assertion+issue136 = build_issue_tolerant 136++issue134 :: Assertion+issue134 = hs_only_build_issue 134++issue133 :: Assertion+issue133 = hs_only_build_issue 133++issue131 :: Assertion+issue131 = c2hsShelly $ chdir "tests/bugs/issue-131" $ do+ mapM_ rm_f ["Issue131.hs", "Issue131.chs.h", "Issue131.chs.c", "Issue131.chi",+ "issue131_c.o", "Issue131.chs.o", "Issue131"]+ cmd "c2hs" "Issue131.chs"+ cmd cc "-c" "-o" "issue131_c.o" "issue131.c"+ cmd cc "-c" "Issue131.chs.c"+ cmd "ghc" "--make" "issue131_c.o" "Issue131.chs.o" "Issue131.hs"+ res <- absPath "./Issue131" >>= cmd+ let expected = ["5", "3",+ "True", "False"]+ liftIO $ assertBool "" (T.lines res == expected)++issue130 :: Assertion+issue130 = expect_issue 130 ["3", "3"] issue128 :: Assertion issue128 = c2hsShelly $ chdir "tests/bugs/issue-128" $ do