c2hs 0.23.1 → 0.24.1
raw patch · 24 files changed
+647/−280 lines, 24 files
Files
- ChangeLog +9/−0
- c2hs.cabal +5/−2
- src/C2HS/C/Trav.hs +10/−5
- src/C2HS/CHS.hs +25/−5
- src/C2HS/CHS/Lexer.hs +4/−1
- src/C2HS/Gen/Bind.hs +211/−212
- src/C2HS/Gen/Monad.hs +25/−4
- src/C2HS/Gen/Wrapper.hs +154/−0
- src/C2HS/Version.hs +1/−1
- src/Main.hs +11/−2
- tests/bugs/issue-117/Issue117.chs +20/−0
- tests/bugs/issue-117/issue117.c +22/−0
- tests/bugs/issue-117/issue117.h +8/−0
- tests/bugs/issue-123/Issue123.chs +27/−0
- tests/bugs/issue-123/issue123.c +19/−0
- tests/bugs/issue-123/issue123.h +8/−0
- tests/bugs/issue-127/Issue127.chs +13/−0
- tests/bugs/issue-127/issue127.c +6/−0
- tests/bugs/issue-127/issue127.h +17/−0
- tests/bugs/issue-37/Issue37.chs +0/−17
- tests/bugs/issue-37/issue37.c +0/−12
- tests/bugs/issue-37/issue37.h +0/−2
- tests/test-bugs.hs +43/−12
- tests/test-system.hs +9/−5
ChangeLog view
@@ -1,3 +1,12 @@+0.24.1+ - Revert bad fix for bool handling [#127]+ - Wrapper generation for bare structure arguments [#117] plus custom+ setup script to support Cabal builds on versions of Cabal without+ explicit support for extra C sources generated by preprocessors+ (@RyanGIScott)+ - Arrays in structuress bug [#123]+ - Test fixes for Windows+ 0.23.1 - Typedef and default marshalling hooks [#20, #25, #48] - Test fixes for 32-bit platforms (Jürgen Keck: @j-keck)
c2hs.cabal view
@@ -1,5 +1,5 @@ Name: c2hs-Version: 0.23.1+Version: 0.24.1 License: GPL-2 License-File: COPYING Copyright: Copyright (c) 1999-2007 Manuel M T Chakravarty@@ -55,7 +55,6 @@ tests/bugs/issue-31/*.chs tests/bugs/issue-31/*.h tests/bugs/issue-31/*.c tests/bugs/issue-32/*.chs tests/bugs/issue-32/*.h tests/bugs/issue-32/*.c tests/bugs/issue-36/*.chs tests/bugs/issue-36/*.h- tests/bugs/issue-37/*.chs tests/bugs/issue-37/*.h tests/bugs/issue-37/*.c tests/bugs/issue-38/*.chs tests/bugs/issue-38/*.h tests/bugs/issue-38/*.c tests/bugs/issue-43/*.chs tests/bugs/issue-43/*.h tests/bugs/issue-43/*.c tests/bugs/issue-44/*.chs tests/bugs/issue-44/*.h tests/bugs/issue-44/*.c@@ -87,6 +86,9 @@ tests/bugs/issue-113/*.chs tests/bugs/issue-113/*.h tests/bugs/issue-113/*.c tests/bugs/issue-115/*.chs tests/bugs/issue-115/*.h tests/bugs/issue-115/*.c tests/bugs/issue-116/*.chs tests/bugs/issue-116/*.h tests/bugs/issue-116/*.c+ tests/bugs/issue-117/*.chs tests/bugs/issue-117/*.h tests/bugs/issue-117/*.c+ 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 source-repository head type: git@@ -119,6 +121,7 @@ C2HS.Gen.Monad C2HS.Gen.Bind C2HS.Gen.Header+ C2HS.Gen.Wrapper C2HS.State C2HS.Switches C2HS.Config
src/C2HS/C/Trav.hs view
@@ -99,6 +99,7 @@ setDefOfIdentC, updDefOfIdentC, CObj(..), CTag(..), CDef(..)) + -- the C traversal monad -- --------------------- @@ -540,10 +541,14 @@ -- | Need to distinguish between pointer and array declarations within -- structures. ---isArrDeclr :: CDeclr -> Bool-isArrDeclr (CDeclr _ (CArrDeclr _ _ _:_) _ _ _) = True-isArrDeclr _ = False+isArrDeclr :: CDeclr -> Maybe Int+isArrDeclr (CDeclr _ (CArrDeclr _ sz _:_) _ _ _) = Just $ szToInt sz+ where szToInt (CArrSize _ (CConst (CIntConst s _))) =+ fromIntegral $ getCInteger s+ szToInt _ = 1+isArrDeclr _ = Nothing + -- | drops the first pointer level from the given declarator -- -- * the declarator must declare a pointer object@@ -571,8 +576,8 @@ isPtrDecl _ = interr "CTrav.isPtrDecl: There was more than one declarator!" -isArrDecl :: CDecl -> Bool-isArrDecl (CDecl _ [] _) = False+isArrDecl :: CDecl -> Maybe Int+isArrDecl (CDecl _ [] _) = Nothing isArrDecl (CDecl _ [(Just declr, _, _)] _) = isArrDeclr declr isArrDecl _ = interr "CTrav.isArrDecl: There was more than one declarator!"
src/C2HS/CHS.hs view
@@ -103,7 +103,8 @@ CHSAPath(..), CHSPtrType(..), CHSTypedefInfo, CHSDefaultMarsh, Direction(..), loadCHS, dumpCHS, hssuffix, chssuffix, loadCHI, dumpCHI, chisuffix,- showCHSParm, apathToIdent, apathRootIdent, hasNonGNU)+ showCHSParm, apathToIdent, apathRootIdent, hasNonGNU,+ isParmWrapped) where -- standard libraries@@ -352,9 +353,16 @@ String -- Haskell type Bool -- C repr: two values? CHSMarsh -- "out" marshaller+ Bool -- wrapped? Position String -- Comment for this para +-- | Check whether parameter requires wrapping for bare structures.+--+isParmWrapped :: CHSParm -> Bool+isParmWrapped (CHSParm _ _ _ _ w _ _) = w+isParmWrapped _ = False+ -- | kinds of arguments in function hooks -- data CHSArg = CHSValArg -- plain value argument@@ -701,9 +709,10 @@ showCHSParm :: CHSParm -> ShowS showCHSParm CHSPlusParm = showChar '+'-showCHSParm (CHSParm oimMarsh hsTyStr twoCVals oomMarsh _ comment) =+showCHSParm (CHSParm oimMarsh hsTyStr twoCVals oomMarsh wrapped _ comment) = showOMarsh oimMarsh . showChar ' '+ . (if wrapped then showChar '%' else id) . showHsVerb hsTyStr . (if twoCVals then showChar '&' else id) . showChar ' '@@ -1142,6 +1151,7 @@ (octxt , toks'7) <- parseOptContext toks'6 (parms , toks'8) <- parseParms toks'7 (parm , toks'9) <- parseParm toks'8+ when (isParmWrapped parm) $ errorOutWrap $ head toks'8 toks'10 <- parseEndHook toks'9 frags <- parseFrags toks'10 return $@@ -1240,16 +1250,19 @@ parseParm toks = do (oimMarsh, toks' ) <- parseOptMarsh toks+ let (wrapped, toks'') = case toks' of+ (CHSTokPercent _:tokstmp) -> (True, tokstmp)+ _ -> (False, toks') (hsTyStr, twoCVals, pos, toks'2) <-- case toks' of+ case toks'' of (CHSTokHSVerb pos hsTyStr:CHSTokAmp _:toks'2) -> return (hsTyStr, True , pos, toks'2) (CHSTokHSVerb pos hsTyStr :toks'2) -> return (hsTyStr, False, pos, toks'2)- _toks -> syntaxError toks'+ _toks -> syntaxError toks'' (oomMarsh, toks'3) <- parseOptMarsh toks'2 (comments, toks'4) <- parseOptComments toks'3- return (CHSParm oimMarsh hsTyStr twoCVals oomMarsh pos+ return (CHSParm oimMarsh hsTyStr twoCVals oomMarsh wrapped pos (concat (intersperse " " comments)), toks'4) where parseOptMarsh :: [CHSToken] -> CST s (CHSMarsh, [CHSToken])@@ -1639,6 +1652,13 @@ ["Premature end of file!", "The .chs file ends in the middle of a binding hook."] raiseSyntaxError++errorOutWrap :: CHSToken -> CST s a+errorOutWrap tok = do+ raiseError (posOf tok)+ ["Syntax error!",+ "Structure wrapping is not allowed for return parameters."]+ raiseSyntaxError errorCHICorrupt :: String -> CST s a errorCHICorrupt ide = do
src/C2HS/CHS/Lexer.hs view
@@ -96,7 +96,7 @@ -- | `underscoreToCase' | `upcaseFirstLetter' | `unsafe' | -- | `with' | `const' | `omit' -- reservedsym -> `{#' | `#}' | `{' | `}' | `,' | `.' | `->' | `='--- | `=>' | '-' | `*' | `&' | `^' | `+'+-- | `=>' | '-' | `*' | `&' | `^' | `+' | `%' -- string -> `"' instr* `"' -- verbhs -> `\`' inhsverb* `\'' -- quoths -> `\'' inhsverb* `\''@@ -201,6 +201,7 @@ | CHSTokStar Position -- `*' | CHSTokAmp Position -- `&' | CHSTokHat Position -- `^'+ | CHSTokPercent Position -- `%' | CHSTokPlus Position -- `+' | CHSTokLBrace Position -- `{' | CHSTokRBrace Position -- `}'@@ -413,6 +414,7 @@ showsPrec _ (CHSTokStar _ ) = showString "*" showsPrec _ (CHSTokAmp _ ) = showString "&" showsPrec _ (CHSTokHat _ ) = showString "^"+ showsPrec _ (CHSTokPercent _ ) = showString "%" showsPrec _ (CHSTokPlus _ ) = showString "+" showsPrec _ (CHSTokLBrace _ ) = showString "{" showsPrec _ (CHSTokRBrace _ ) = showString "}"@@ -898,6 +900,7 @@ >||< sym "*" CHSTokStar >||< sym "&" CHSTokAmp >||< sym "^" CHSTokHat+ >||< sym "%" CHSTokPercent >||< sym "+" CHSTokPlus >||< sym "{" CHSTokLBrace >||< sym "}" CHSTokRBrace
src/C2HS/Gen/Bind.hs view
@@ -147,14 +147,15 @@ import C2HS.C.Info (CPrimType(..)) import qualified C2HS.C.Info as CInfo import C2HS.Gen.Monad (TransFun, transTabToTransFun, HsObject(..), GB,- GBState(..),+ GBState(..), Wrapper(..), initialGBState, setContext, getPrefix, getReplacementPrefix, delayCode, getDelayedCode, ptrMapsTo, queryPtr, objIs, sizeIs, querySize, queryClass, queryPointer, mergeMaps, dumpMaps, queryEnum, isEnum, queryTypedef, isC2HSTypedef,- queryDefaultMarsh, isDefaultMarsh)+ queryDefaultMarsh, isDefaultMarsh, addWrapper, getWrappers) +import Debug.Trace -- default marshallers -- -------------------@@ -404,12 +405,13 @@ -- -- * also returns all warning messages encountered (last component of result) ---expandHooks :: AttrC -> CHSModule -> CST s (CHSModule, String, String)-expandHooks ac mod' = do- (_, res) <- runCT (expandModule mod') ac initialGBState- return res+expandHooks :: AttrC -> CHSModule ->+ CST s (CHSModule, String, [Wrapper], String)+expandHooks ac mod' = do+ (_, res) <- runCT (expandModule mod') ac initialGBState+ return res -expandModule :: CHSModule -> GB (CHSModule, String, String)+expandModule :: CHSModule -> GB (CHSModule, String, [Wrapper], String) expandModule (CHSModule mfrags) = do -- expand hooks@@ -434,7 +436,8 @@ else do traceInfoOK warnmsgs <- showErrors- return (CHSModule (frags' ++ delayedFrags), chi, warnmsgs)+ wraps <- getWrappers+ return (CHSModule (frags' ++ delayedFrags), chi, wraps, warnmsgs) where traceInfoExpand = putTraceStr tracePhasesSW ("...expanding binding hooks...\n")@@ -538,7 +541,8 @@ "Size of declaration\n" ++ show decl ++ "\nis " ++ show (padBits size) ++ "\n" expandHook (CHSEnumDefine _ _ _ _) _ =- interr "Binding generation error : enum define hooks should be eliminated via preprocessing "+ interr $ "Binding generation error : enum define hooks " +++ "should be eliminated via preprocessing " expandHook (CHSEnum cide oalias chsTrans emit oprefix orepprefix derive pos) _ = do -- get the corresponding C declaration@@ -570,7 +574,7 @@ 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' pos+ callImport hook isPure isUns [] ideLexeme hsLexeme cdecl' Nothing pos return hsLexeme where traceEnter = traceGenBind $@@ -586,7 +590,7 @@ _ -> funPtrExpectedErr pos traceValueType ty- set_get <- setGet pos CHSGet offsets False ptrTy Nothing+ set_get <- setGet pos CHSGet offsets Nothing ptrTy Nothing -- get the corresponding C declaration; raises error if not found or not a -- function; we use shadow identifiers, so the returned identifier is used@@ -603,7 +607,8 @@ ++ hsLexeme ++ " f" ++ args ++ ")" where traceEnter = traceGenBind $- "** Indirect call hook for `" ++ identToString (apathToIdent apath) ++ "':\n"+ "** Indirect call hook for `" +++ identToString (apathToIdent apath) ++ "':\n" traceValueType et = traceGenBind $ "Type of accessed value: " ++ showExtType et ++ "\n" expandHook (CHSFun isPure isUns _ inVarTypes (CHSRoot _ ide)@@ -623,11 +628,17 @@ fiIde = internalIdent fiLexeme cdecl' = cide `simplifyDecl` cdecl callHook = CHSCall isPure isUns (CHSRoot False cide) (Just fiIde) pos+ isWrapped (CHSParm _ _ twovals _ w _ _)+ | twovals = [w, w]+ | otherwise = [w]+ isWrapped _ = [False]+ wrapped = Just $ concatMap isWrapped parms+ varTypes <- convertVarTypes hsLexeme pos inVarTypes callImport callHook isPure isUns varTypes (identToString cide)- fiLexeme cdecl' pos+ fiLexeme cdecl' wrapped pos - extTy <- extractFunType pos cdecl' True+ extTy <- extractFunType pos cdecl' True wrapped funDef isPure hsLexeme fiLexeme extTy varTypes ctxt parms parm Nothing pos hkpos where@@ -659,7 +670,7 @@ callHook = CHSCall isPure isUns apath (Just fiIde) pos callImportDyn callHook isPure isUns ideLexeme fiLexeme decl ty pos - set_get <- setGet pos CHSGet offsets False ptrTy Nothing+ set_get <- setGet pos CHSGet offsets Nothing ptrTy Nothing funDef isPure hsLexeme fiLexeme (FunET ptrTy $ purify ty) [] ctxt parms parm (Just set_get) pos hkpos where@@ -701,19 +712,16 @@ checkType decl offsets >>= \ offset -> return $ "(" ++ show offset ++ ")" where checkType decl [BitSize offset _] =- extractCompType True True decl >>= \ compTy ->+ extractCompType True True False decl >>= \ compTy -> case compTy of- ExtType et ->- case et of- (VarFunET _) -> variadicErr pos pos- (IOET _) ->- interr "GenBind.expandHook(CHSOffsetOf): Illegal type!"- (UnitET ) -> voidFieldErr pos- (DefinedET _ _) -> return offset- (PrimET (CUFieldPT _)) -> offsetBitfieldErr pos- (PrimET (CSFieldPT _)) -> offsetBitfieldErr pos- _ -> return offset- SUType _ -> return offset+ (VarFunET _) -> variadicErr pos pos+ (IOET _) ->+ interr "GenBind.expandHook(CHSOffsetOf): Illegal type!"+ (UnitET ) -> voidFieldErr pos+ (DefinedET _ _) -> return offset+ (PrimET (CUFieldPT _)) -> offsetBitfieldErr pos+ (PrimET (CSFieldPT _)) -> offsetBitfieldErr pos+ _ -> return offset checkType _ _ = offsetDerefErr pos expandHook hook@(CHSPointer isStar cName oalias ptrKind isNewtype oRefType emit pos) _ =@@ -827,9 +835,9 @@ let def = "__c2hs_typedef__" ++ identToString cIde ++ "__" ++ identToString hsIde Just (ObjCO cdecl) <- findObj $ internalIdent def- st <- extractCompType True True cdecl+ st <- extractCompType True True False cdecl et <- case st of- ExtType (PrimET e) -> return e+ PrimET e -> return e _ -> typeDefaultErr pos cIde `isC2HSTypedef` (hsIde, et) return ""@@ -843,9 +851,9 @@ Just (tdide, _) -> do let def = "__c2hs_typedef__" ++ cTy ++ "__" ++ identToString tdide Just (ObjCO cdecl) <- findObj $ internalIdent def- st <- extractCompType True True cdecl+ st <- extractCompType True True False cdecl case st of- ExtType (PrimET _) -> do+ PrimET _ -> do (dir, cTy, cPtr) `isDefaultMarsh` marsh return "" _ -> typeDefaultErr pos@@ -1014,16 +1022,22 @@ -- want to import into Haskell land -- callImport :: CHSHook -> Bool -> Bool -> [ExtType] -> String ->- String -> CDecl -> Position -> GB ()-callImport hook isPure isUns varTypes ideLexeme hsLexeme cdecl pos =+ String -> CDecl -> Maybe [Bool] -> Position -> GB ()+callImport hook isPure 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+ extType <- extractFunType pos cdecl isPure owrapped header <- getSwitch headerSB+ let (needwrapper, wraps, ide) = case owrapped of+ Nothing -> (False, [], ideLexeme)+ Just ws -> if or ws+ then (True, ws, "__c2hs_wrapped__" ++ ideLexeme)+ else (False, [], ideLexeme) delayCode hook (foreignImport (extractCallingConvention cdecl)- header ideLexeme hsLexeme isUns extType varTypes)+ header ide hsLexeme isUns extType varTypes)+ when needwrapper $ addWrapper ide ideLexeme cdecl wraps pos traceFunType extType where traceFunType et = traceGenBind $@@ -1057,9 +1071,11 @@ entity | null header = ident | otherwise = header ++ " " ++ ident --- | Haskell code for the foreign import dynamic declaration needed by a call hook+-- | Haskell code for the foreign import dynamic declaration needed by+-- a call hook ---foreignImportDyn :: CallingConvention -> String -> String -> Bool -> ExtType -> String+foreignImportDyn :: CallingConvention -> String -> String -> Bool ->+ ExtType -> String foreignImportDyn cconv _ident hsIdent isUnsafe ty = "foreign import " ++ showCallingConvention cconv ++ " " ++ safety ++ " \"dynamic\"\n " ++@@ -1090,7 +1106,7 @@ -> Position -- source location of the start of the hook -> GB String -- Haskell code in text form funDef isPure hsLexeme fiLexeme extTy varExtTys octxt parms- parm@(CHSParm _ hsParmTy _ _ _ _) marsh2 pos hkpos =+ parm@(CHSParm _ hsParmTy _ _ _ _ _) marsh2 pos hkpos = do when (countPlus parms > 1 || isPlus parm) $ illegalPlusErr pos (parms', parm', isImpure) <- addDftMarshaller pos parms parm extTy varExtTys@@ -1109,7 +1125,7 @@ call = if isPure then " let {res = " ++ fiLexeme ++ joinCallArgs ++ "} in\n" else " " ++ fiLexeme ++ joinCallArgs ++ case parm of- CHSParm _ "()" _ Nothing _ _ -> " >>\n"+ CHSParm _ "()" _ Nothing _ _ _ -> " >>\n" _ -> if countPlus parms == 1 then " >>\n" else " >>= \\res ->\n"@@ -1124,22 +1140,22 @@ marshRes = if countPlus parms == 1 then "" else case parm' of- CHSParm _ _ _twoCVal (Just (_ , CHSVoidArg )) _ _ -> ""- CHSParm _ _ _twoCVal (Just (omBody, CHSIOVoidArg)) _ _ ->+ CHSParm _ _ _twoCVal (Just (_, CHSVoidArg)) _ _ _ -> ""+ CHSParm _ _ _twoCVal (Just (omBody, CHSIOVoidArg)) _ _ _ -> " " ++ marshBody omBody ++ " res >> \n"- CHSParm _ _ _twoCVal (Just (omBody, CHSIOArg )) _ _ ->+ CHSParm _ _ _twoCVal (Just (omBody, CHSIOArg)) _ _ _ -> " " ++ marshBody omBody ++ " res >>= \\res' ->\n"- CHSParm _ _ _twoCVal (Just (omBody, CHSValArg )) _ _ ->+ CHSParm _ _ _twoCVal (Just (omBody, CHSValArg)) _ _ _ -> " let {res' = " ++ marshBody omBody ++ " res} in\n"- CHSParm _ _ _ Nothing _ _ ->+ 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+ CHSParm _ _ _ (Just (_, CHSVoidArg)) _ _ _ -> retArgs+ CHSParm _ _ _ (Just (_, CHSIOVoidArg)) _ _ _ -> retArgs _ -> if countPlus parms == 0 then "res'":retArgs else retArgs ret = "(" ++ concat (intersperse ", " retArgs') ++ ")"@@ -1178,12 +1194,12 @@ Nothing -> "" Just ctxtStr -> ctxtStr ++ " => " argTys = ["(" ++ ty ++ ")" ++ showComment c |- CHSParm im ty _ _ _ c <- parms', notVoid im]+ CHSParm im ty _ _ _ _ c <- parms', notVoid im] resTys = ["(" ++ ty ++ ")" |- CHSParm _ ty _ om _ _ <- parm':parms', notVoid om]+ CHSParm _ ty _ om _ _ _ <- parm':parms', notVoid om] resTup = let comment = case parm' of- CHSParm _ _ _ _ _ c -> c+ CHSParm _ _ _ _ _ _ c -> c (lp, rp) = if isPure && length resTys == 1 then ("", "") else ("(", ")")@@ -1203,7 +1219,7 @@ -- code fragments -- marshArg i (CHSParm (Just (imBody, imArgKind)) _ twoCVal- (Just (omBody, omArgKind)) _ _ ) = do+ (Just (omBody, omArgKind)) _ _ _ ) = do let a = "a" ++ show (i :: Int) imStr = marshBody imBody@@ -1275,14 +1291,14 @@ -- -- * a default marshaller maybe used for "out" marshalling --- checkResMarsh (CHSParm (Just _) _ _ _ pos' _) _ =+ checkResMarsh (CHSParm (Just _) _ _ _ _ pos' _) _ = resMarshIllegalInErr pos'- checkResMarsh (CHSParm _ _ True _ pos' _) _ =+ checkResMarsh (CHSParm _ _ True _ _ pos' _) _ = resMarshIllegalTwoCValErr pos'- checkResMarsh (CHSParm _ ty _ omMarsh pos' c) cTy = do+ checkResMarsh (CHSParm _ ty _ omMarsh _ pos' c) cTy = do (imMarsh', _ ) <- addDftVoid Nothing (omMarsh', isImpure) <- addDftOut pos' omMarsh ty [cTy]- return (CHSParm imMarsh' ty False omMarsh' pos' c, isImpure)+ return (CHSParm imMarsh' ty False omMarsh' False pos' c, isImpure) -- splitFunTy (FunET UnitET ty) vts = splitFunTy ty vts splitFunTy (FunET ty1 ty2) vts = let (resTy, argTys) = splitFunTy ty2 vts@@ -1296,46 +1312,44 @@ addDft ((CHSPlusParm):parms'') (_:cTys) = do (parms', _) <- addDft parms'' cTys return (CHSPlusParm : parms', True)- addDft ((CHSParm imMarsh hsTy False omMarsh p c):parms'') (cTy :cTys) = do- (imMarsh', isImpureIn ) <- addDftIn p imMarsh hsTy [cTy]- (omMarsh', isImpureOut) <- addDftVoid omMarsh+ 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' p c : parms',+ return (CHSParm imMarsh' hsTy False omMarsh' False p c : parms', isImpure || isImpureIn || isImpureOut)- addDft ((CHSParm imMarsh hsTy True omMarsh p c):parms'') (cTy1:cTy2:cTys) =+ addDft ((CHSParm imMarsh hsTy True omMarsh _ p c):parms'') (ct1:ct2:cts) = do- (imMarsh', isImpureIn ) <- addDftIn p imMarsh hsTy [cTy1, cTy2]- (omMarsh', isImpureOut) <- addDftVoid omMarsh- (parms' , isImpure ) <- addDft parms'' cTys- return (CHSParm imMarsh' hsTy True omMarsh' p c : parms',+ (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)- addDft ((CHSParm _ _ _ _ pos' _):_) [] =+ addDft [] [] = return ([], False)+ addDft ((CHSParm _ _ _ _ _ pos' _):_) [] = marshArgMismatchErr pos' "This parameter is in excess of the C arguments."- addDft [] (_:_) =+ addDft [] (_:_) = marshArgMismatchErr pos "Parameter marshallers are missing." --- addDftIn _ imMarsh@(Just (_, kind)) _ _ = return (imMarsh,- kind == CHSIOArg)- addDftIn pos' _imMarsh@Nothing hsTy cTys = do- marsh <- lookupDftMarshIn hsTy cTys+ addDftIn _ imMarsh@(Just (_, kind)) _ _ = return (imMarsh, kind == CHSIOArg)+ addDftIn pos' _imMarsh@Nothing hsTy cts = do+ marsh <- lookupDftMarshIn hsTy cts when (isNothing marsh) $- noDftMarshErr pos' "\"in\"" hsTy cTys+ noDftMarshErr pos' "\"in\"" hsTy cts return (marsh, case marsh of {Just (_, kind) -> kind == CHSIOArg}) --- addDftOut _ omMarsh@(Just (_, kind)) _ _ = return (omMarsh,- kind == CHSIOArg)- addDftOut pos' _omMarsh@Nothing hsTy cTys = do- marsh <- lookupDftMarshOut hsTy cTys+ addDftOut _ omMarsh@(Just (_, kind)) _ _ =+ return (omMarsh, kind == CHSIOArg)+ addDftOut pos' _omMarsh@Nothing hsTy cts = do+ marsh <- lookupDftMarshOut hsTy cts when (isNothing marsh) $- noDftMarshErr pos' "\"out\"" hsTy cTys+ noDftMarshErr pos' "\"out\"" hsTy cts return (marsh, case marsh of {Just (_, kind) -> kind == CHSIOArg}) -- -- add void marshaller if no explict one is given -- addDftVoid marsh@(Just (_, kind)) = return (marsh, kind == CHSIOArg)- addDftVoid Nothing = do+ addDftVoid Nothing = do return (Just (Left (internalIdent "void"), CHSVoidArg), False) -- | compute from an access path, the declarator finally accessed and the index@@ -1399,7 +1413,8 @@ do declr' <- derefDeclr declr return $ CDecl specs [(Just declr', oinit, oexpr)] at- derefDeclr (CDeclr oid (CPtrDeclr _ _: derived') asm ats n) = return $ CDeclr oid derived' asm ats n+ derefDeclr (CDeclr oid (CPtrDeclr _ _: derived') asm ats n) =+ return $ CDeclr oid derived' asm ats n derefDeclr (CDeclr _oid _unexp_deriv _ _ n) = ptrExpectedErr (posOf n) -- | replaces a decleration by its alias if any@@ -1453,9 +1468,9 @@ -- | Haskell code for writing to or reading from a struct ---setGet :: Position -> CHSAccess -> [BitSize] -> Bool -> ExtType -> Maybe Ident- -> GB String-setGet pos access offsets isArr ty onewtype =+setGet :: Position -> CHSAccess -> [BitSize] -> Maybe Int ->+ ExtType -> Maybe Ident -> GB String+setGet pos access offsets arrSize ty onewtype = do let pre = case (access, onewtype) of (CHSSet, Nothing) -> "(\\ptr val -> do {"@@ -1473,15 +1488,15 @@ bf <- checkType ty case bf of Nothing -> return $ case access of -- not a bitfield- CHSGet -> peekOp offset tyTag isArr- CHSSet -> pokeOp offset tyTag "val" isArr+ CHSGet -> peekOp offset tyTag arrSize+ CHSSet -> pokeOp offset tyTag "val" arrSize --FIXME: must take `bitfieldDirection' into account Just (_, bs) -> return $ case access of -- a bitfield- CHSGet -> "val <- " ++ peekOp offset tyTag isArr+ CHSGet -> "val <- " ++ peekOp offset tyTag arrSize ++ extractBitfield- CHSSet -> "org <- " ++ peekOp offset tyTag isArr+ CHSSet -> "org <- " ++ peekOp offset tyTag arrSize ++ insertBitfield- ++ pokeOp offset tyTag "val'" isArr+ ++ pokeOp offset tyTag "val'" arrSize where -- we have to be careful here to ensure proper sign extension; -- in particular, shifting right followed by anding a mask is@@ -1520,13 +1535,15 @@ checkType (PrimET (CSFieldPT bs)) = return $ Just (True , bs) checkType _ = return Nothing --- peekOp off tyTag False =+ peekOp off tyTag Nothing = "peekByteOff ptr " ++ show off ++ " ::IO " ++ tyTag- peekOp off tyTag True =+ peekOp off tyTag (Just _) = "return $ ptr `plusPtr` " ++ show off ++ " ::IO " ++ tyTag- pokeOp off tyTag var False =+ pokeOp off tyTag var Nothing = "pokeByteOff ptr " ++ show off ++ " (" ++ var ++ "::" ++ tyTag ++ ")"- pokeOp _ tyTag var True = "poke ptr (" ++ var ++ "::" ++ tyTag ++ ")"+ pokeOp off tyTag var (Just sz) =+ "copyArray (ptr `plusPtr` " ++ show off ++ ") (" +++ var ++ "::" ++ tyTag ++ ") " ++ show sz -- | generate the type definition for a pointer hook and enter the required type -- mapping into the 'ptrmap'@@ -1697,6 +1714,7 @@ | PrimET CPrimType -- basic C type | UnitET -- void | VarFunET ExtType -- variadic function+ | SUET CStructUnion -- structure or union deriving Show instance Eq ExtType where@@ -1706,13 +1724,9 @@ (DefinedET _ s ) == (DefinedET _ s' ) = s == s' (PrimET t ) == (PrimET t' ) = t == t' (VarFunET t ) == (VarFunET t' ) = t == t'+ (SUET (CStruct _ i _ _ _)) == (SUET (CStruct _ i' _ _ _)) = i == i' UnitET == UnitET = True --- | composite C type----data CompType = ExtType ExtType -- external type- | SUType CStructUnion -- structure or union- -- | check whether an external type denotes a function type -- isFunExtType :: ExtType -> Bool@@ -1731,7 +1745,7 @@ -- brackets; this however doesn't work consistently due to `DefinedET'; so, -- we give up on the idea (preferring simplicity) ---showExtType :: ExtType -> String+showExtType :: ExtType -> String showExtType (FunET UnitET res) = showExtType res showExtType (FunET arg res) = "(" ++ showExtType arg ++ " -> " ++ showExtType res ++ ")"@@ -1763,6 +1777,7 @@ showExtType (PrimET (CUFieldPT bs)) = "CUInt{-:" ++ show bs ++ "-}" showExtType (PrimET (CAliasedPT _ hs _)) = hs showExtType UnitET = "()"+showExtType (SUET _) = "(Ptr ())" showExtFunType :: ExtType -> [ExtType] -> String showExtFunType (FunET UnitET res) _ = showExtType res@@ -1784,8 +1799,8 @@ -- * the caller has to guarantee that the object does indeed refer to a -- function ---extractFunType :: Position -> CDecl -> Bool -> GB ExtType-extractFunType pos cdecl isPure =+extractFunType :: Position -> CDecl -> Bool -> Maybe [Bool] -> GB ExtType+extractFunType pos cdecl isPure wrapped = do -- remove all declarators except that of the function we are processing; -- then, extract the functions arguments and result type (also check that@@ -1808,25 +1823,19 @@ -- prototype with `void' as its single argument declares a nullary -- function) --- argTypes <- mapM (extractSimpleType False pos) args+ let wrap = case wrapped of+ Just w -> w+ Nothing -> repeat False+ argTypes <- zipWithM (extractCompType False True) wrap args return $ foldr FunET resultType argTypes + -- | compute a non-struct/union type from the given declaration -- -- * the declaration may have at most one declarator ---extractSimpleType :: Bool -> Position -> CDecl -> GB ExtType-extractSimpleType isResult pos cdecl =- do- traceEnter- ct <- extractCompType isResult True cdecl- case ct of- ExtType et -> return et- SUType _ -> illegalStructUnionErr (posOf cdecl) pos- where- traceEnter = traceGenBind $- "Entering `extractSimpleType' (" ++ (if isResult then "" else "not ")- ++ "for a result)...\n"+extractSimpleType :: Bool -> Position -> CDecl -> GB ExtType+extractSimpleType isResult _ cdecl = extractCompType isResult True False cdecl -- | compute a Haskell type for a type referenced in a C pointer type --@@ -1840,10 +1849,10 @@ -- extractPtrType :: CDecl -> GB ExtType extractPtrType cdecl = do- ct <- extractCompType False False cdecl+ ct <- extractCompType False False False cdecl case ct of- ExtType et -> return et- SUType _ -> return UnitET+ SUET _ -> return UnitET+ _ -> return ct -- | compute a Haskell type from the given C declaration, where C functions are -- represented by function pointers@@ -1865,12 +1874,12 @@ -- `extractCompType' from looking further "into" the -- definition of that pointer. ---extractCompType :: Bool -> Bool -> CDecl -> GB CompType-extractCompType isResult usePtrAliases cdecl@(CDecl specs' declrs ats) =+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!" else case declrs of- [(Just declr, _, size)] | isPtrDeclr declr -> ptrType declr+ [(Just declr, _, size)] | isPtr || isPtrDeclr declr -> ptrType declr | isFunDeclr declr -> funType | otherwise -> aliasOrSpecType size _ -> aliasOrSpecType Nothing@@ -1879,7 +1888,9 @@ -- ptrType declr = do tracePtrType- let declrs' = dropPtrDeclr declr -- remove indirection+ let declrs' = if isPtr -- remove indirection+ then declr+ else dropPtrDeclr declr cdecl' = CDecl specs' [(Just declrs', Nothing, Nothing)] ats oalias = checkForOneAliasName cdecl' -- is only an alias remaining? osu = checkForOneCUName cdecl'@@ -1890,10 +1901,10 @@ case oHsRepr of Just repr | usePtrAliases -> ptrAlias repr -- got an alias _ -> do -- no alias => recurs- ct <- extractCompType False usePtrAliases cdecl'- returnX $ case ct of- ExtType et -> PtrET et- SUType _ -> PtrET UnitET+ ct <- extractCompType False usePtrAliases False cdecl'+ return $ case ct of+ SUET _ -> PtrET UnitET+ _ -> PtrET ct -- -- handle explicit function types --@@ -1901,19 +1912,19 @@ -- functions); is this ever going to be a problem? -- funType = do- traceFunType- et <- extractFunType (posOf cdecl) cdecl False- returnX et+ traceFunType+ -- ??? IS Nothing OK HERE?+ extractFunType (posOf cdecl) cdecl False Nothing - makeAliasedCompType :: Ident -> CHSTypedefInfo -> GB CompType+ makeAliasedCompType :: Ident -> CHSTypedefInfo -> GB ExtType makeAliasedCompType cIde (hsIde, et) = do- return $ ExtType $ PrimET $+ return $ PrimET $ CAliasedPT (identToString cIde) (identToString hsIde) et -- -- handle all types, which are not obviously pointers or functions --- aliasOrSpecType :: Maybe CExpr -> GB CompType+ aliasOrSpecType :: Maybe CExpr -> GB ExtType aliasOrSpecType size = do traceAliasOrSpecType size case checkForOneAliasName cdecl of@@ -1934,16 +1945,12 @@ ide `simplifyDecl` cdecl' sdecl = CDecl specs [(declr, init', size)] at -- propagate `size' down (slightly kludgy)- extractCompType isResult usePtrAliases sdecl+ extractCompType isResult usePtrAliases False sdecl -- -- compute the result for a pointer alias -- ptrAlias (repr1, repr2) =- returnX $ DefinedET cdecl (if isResult then repr2 else repr1)- --- -- wrap an `ExtType' into a `CompType'- --- returnX retval = return $ ExtType retval+ return $ DefinedET cdecl (if isResult then repr2 else repr1) -- tracePtrType = traceGenBind $ "extractCompType: explicit pointer type\n" traceFunType = traceGenBind $ "extractCompType: explicit function type\n"@@ -2009,28 +2016,28 @@ return cdecl cdecls <- mapM doone ides forM cdecls $ \cdecl -> do- st <- extractCompType True True cdecl+ st <- extractCompType True True False cdecl case st of- ExtType et -> return et- _ -> variadicTypeErr pos+ SUET _ -> variadicTypeErr pos+ _ -> return st -- | compute the complex (external) type determined by a list of type specifiers -- -- * may not be called for a specifier that defines a typedef alias ---specType :: Position -> [CDeclSpec] -> Maybe CExpr -> GB CompType+specType :: Position -> [CDeclSpec] -> Maybe CExpr -> GB ExtType specType cpos specs'' osize = let tspecs = [ts | CTypeSpec ts <- specs''] in case lookupTSpec tspecs typeMap of Just et | isUnsupportedType et -> unsupportedTypeSpecErr cpos- | isNothing osize -> return $ ExtType et -- not a bitfield+ | isNothing osize -> return et -- not a bitfield | otherwise -> bitfieldSpec tspecs et osize -- bitfield Nothing -> case tspecs of- [CSUType cu _] -> return $ SUType cu -- struct or union- [CEnumType _ _] -> return $ ExtType (PrimET CIntPT) -- enum+ [CSUType cu _] -> return $ SUET cu -- struct or union+ [CEnumType _ _] -> return $ PrimET CIntPT -- enum [CTypeDef _ _] -> interr "GenBind.specType: Illegal typedef alias!"- _ -> illegalTypeSpecErr cpos+ _ -> trace ("\nERROR:\nspecs''=" ++ show specs'' ++ "\nosize=" ++ show osize ++ "\ntspecs=" ++ show tspecs ++ "\nlookup=" ++ show (lookupTSpec tspecs typeMap) ++ "\n\n") $ illegalTypeSpecErr cpos where lookupTSpec = lookupBy matches --@@ -2063,7 +2070,7 @@ eqSpec (CTypeDef _ _) (CTypeDef _ _) = True eqSpec _ _ = False --- bitfieldSpec :: [CTypeSpec] -> ExtType -> Maybe CExpr -> GB CompType+ bitfieldSpec :: [CTypeSpec] -> ExtType -> Maybe CExpr -> GB ExtType bitfieldSpec tspecs et (Just sizeExpr) = -- never called with 'Nothing' do PlatformSpec {bitfieldIntSignedPS = bitfieldIntSigned} <- getPlatform@@ -2083,7 +2090,7 @@ else CUFieldPT size _ -> illegalFieldSizeErr pos where- returnCT = return . ExtType . PrimET+ returnCT = return . PrimET -- int = CIntType undefined signed = CSignedType undefined@@ -2111,13 +2118,16 @@ in attrs' ++ funEndAttrs declrs ++ funPtrAttrs declrs -- attrs after the function name, e.g. void foo() __attribute__((...));- funEndAttrs [(Just ((CDeclr _ (CFunDeclr _ _ _ : _) _ attrs _)), _, _)] = attrs- funEndAttrs _ = []+ funEndAttrs [(Just ((CDeclr _ (CFunDeclr _ _ _ : _) _ attrs _)), _, _)] =+ attrs+ funEndAttrs _ = [] -- attrs appearing within the declarator of a function pointer. As an -- example: -- typedef int (__stdcall *fp)();- funPtrAttrs [(Just ((CDeclr _ (CPtrDeclr _ _ : CFunDeclr _ attrs _ : _) _ _ _)), _, _)] = attrs+ funPtrAttrs [(Just ((CDeclr _ (CPtrDeclr _ _ :+ CFunDeclr _ attrs _ : _) _ _ _)), _, _)] =+ attrs funPtrAttrs _ = [] @@ -2153,8 +2163,9 @@ -- | add two bit size values ---addBitSize :: BitSize -> BitSize -> BitSize-addBitSize (BitSize o1 b1) (BitSize o2 b2) = BitSize (o1 + o2 + overflow * CInfo.size CIntPT) rest+addBitSize :: BitSize -> BitSize -> BitSize+addBitSize (BitSize o1 b1) (BitSize o2 b2) =+ BitSize (o1 + o2 + overflow * CInfo.size CIntPT) rest where bitsPerBitfield = CInfo.size CIntPT * 8 (overflow, rest) = (b1 + b2) `divMod` bitsPerBitfield@@ -2236,15 +2247,18 @@ -- 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)]+ [(Just (CDeclr oide (CArrDeclr _ (CArrSize _ lexpr) _ :+ derived') _asm _ats n), init', expr)] attr) = do- (bitsize, align) <- sizeAlignOf (CDecl dclspec- [(Just (CDeclr oide derived' Nothing [] n), init', expr)]- attr)+ (bitsize, align) <-+ sizeAlignOf (CDecl dclspec+ [(Just (CDeclr oide derived' Nothing [] n), init', expr)]+ attr) IntResult len <- evalConstCExpr lexpr return (fromIntegral len `scaleBitSize` bitsize, align)-sizeAlignOf (CDecl _ [(Just (CDeclr _ (CArrDeclr _ (CNoArrSize _) _ : _) _ _ _), _init, _expr)] _) =+sizeAlignOf (CDecl _ [(Just (CDeclr _ (CArrDeclr _ (CNoArrSize _) _ :+ _) _ _ _), _init, _expr)] _) = interr "GenBind.sizeAlignOf: array of undeclared size." sizeAlignOf cdecl = do traceAliasCheck@@ -2262,50 +2276,41 @@ "extractCompType: found an alias called `" ++ identToString ide ++ "'\n" -sizeAlignOfSingle cdecl =- do- ct <- extractCompType False False cdecl- case ct of- ExtType (FunET _ _ ) -> do- align <- alignment CFunPtrPT- return (bitSize CFunPtrPT, align)- ExtType (VarFunET _ ) -> do- align <- alignment CFunPtrPT- return (bitSize CFunPtrPT, align)- ExtType (IOET _ ) -> interr "GenBind.sizeof: Illegal IO type!"- ExtType (PtrET t )- | isFunExtType t -> do- align <- alignment CFunPtrPT- return (bitSize CFunPtrPT, align)- | otherwise -> do- align <- alignment CPtrPT- return (bitSize CPtrPT, align)- ExtType (DefinedET _ _ ) ->- interr "GenBind.sizeAlignOf: Should never get a defined type"-{- OLD:- do- align <- alignment CPtrPT- return (bitSize CPtrPT, align)- -- FIXME: The defined type could be a function pointer!!!- -}- ExtType (PrimET pt ) -> do- align <- alignment pt- return (bitSize pt, align)- ExtType UnitET -> voidFieldErr (posOf cdecl)- SUType su ->- do- let (fields, tag) = structMembers su- fields' <- let ide = structName su- in- if (not . null $ fields) || isNothing ide- then return fields- else do -- get the real...- tag' <- findTag (fromJust ide) -- ...definition- case tag' of- Just (StructUnionCT su') -> return- (fst . structMembers $ su')- _ -> return fields- sizeAlignOfStructPad fields' tag+sizeAlignOfSingle cdecl = do+ ct <- extractCompType False False False cdecl+ case ct of+ FunET _ _ -> do+ align <- alignment CFunPtrPT+ return (bitSize CFunPtrPT, align)+ VarFunET _ -> do+ align <- alignment CFunPtrPT+ return (bitSize CFunPtrPT, align)+ IOET _ -> interr "GenBind.sizeof: Illegal IO type!"+ PtrET t+ | isFunExtType t -> do+ align <- alignment CFunPtrPT+ return (bitSize CFunPtrPT, align)+ | otherwise -> do+ align <- alignment CPtrPT+ return (bitSize CPtrPT, align)+ DefinedET _ _ ->+ interr "GenBind.sizeAlignOf: Should never get a defined type"+ PrimET pt -> do+ align <- alignment pt+ return (bitSize pt, align)+ UnitET -> voidFieldErr (posOf cdecl)+ SUET su -> do+ let (fields, tag) = structMembers su+ fields' <- let ide = structName su+ in if (not . null $ fields) || isNothing ide+ then return fields+ else do -- get the real...+ tag' <- findTag (fromJust ide) -- ...definition+ case tag' of+ Just (StructUnionCT su') -> return+ (fst . structMembers $ su')+ _ -> return fields+ sizeAlignOfStructPad fields' tag where bitSize et | sz < 0 = BitSize 0 (-sz) -- size is in bits | otherwise = BitSize sz 0@@ -2425,16 +2430,18 @@ evalCCast :: CExpr -> GB ConstResult evalCCast (CCast decl expr _) = do- compType <- extractCompType False False decl+ compType <- extractCompType False False False decl evalCCast' compType (getConstInt expr) where getConstInt (CConst (CIntConst (CInteger i _ _) _)) = i- getConstInt _ = todo "GenBind.evalCCast: Casts are implemented only for integral constants"+ getConstInt _ = todo $ "GenBind.evalCCast: Casts are implemented " +++ "only for integral constants" -evalCCast' :: CompType -> Integer -> GB ConstResult-evalCCast' (ExtType (PrimET primType)) i+evalCCast' :: ExtType -> Integer -> GB ConstResult+evalCCast' (PrimET primType) i | isIntegralCPrimType primType = return $ IntResult i-evalCCast' _ _ = todo "GenBind.evalCCast': Only integral trivial casts are implemented"+evalCCast' _ _ = todo $ "GenBind.evalCCast': Only integral trivial " +++ "casts are implemented" evalCConst :: CConst -> GB ConstResult evalCConst (CIntConst i _ ) = return $ IntResult (getCInteger i)@@ -2554,14 +2561,6 @@ "The structure has no member called `" ++ identToString ide ++ "'. The structure is defined at", show cpos ++ "."]--illegalStructUnionErr :: Position -> Position -> GB a-illegalStructUnionErr cpos pos =- raiseErrorCTExc pos- ["Illegal structure or union type!",- "There is not automatic support for marshaling of structures and",- "unions; the offending type is declared at "- ++ show cpos ++ "."] illegalTypeSpecErr :: Position -> GB a illegalTypeSpecErr cpos =
src/C2HS/Gen/Monad.hs view
@@ -71,12 +71,13 @@ module C2HS.Gen.Monad ( TransFun, transTabToTransFun, - HsObject(..), GB, GBState(..),+ HsObject(..), Wrapper(..), GB, GBState(..), initialGBState, setContext, getLibrary, getPrefix, getReplacementPrefix, delayCode, getDelayedCode, ptrMapsTo, queryPtr, objIs, queryObj, sizeIs, querySize, queryClass, queryPointer, mergeMaps, dumpMaps, queryEnum, isEnum,- queryTypedef, isC2HSTypedef, queryDefaultMarsh, isDefaultMarsh+ queryTypedef, isC2HSTypedef, queryDefaultMarsh, isDefaultMarsh,+ addWrapper, getWrappers ) where -- standard libraries@@ -91,6 +92,7 @@ -- Language.C import Language.C.Data.Position import Language.C.Data.Ident+import Language.C.Syntax import Data.Errors -- C -> Haskell@@ -230,6 +232,14 @@ -- Map from C type names to type default definitions. type DefaultMarshMap = Map (Direction, String, Bool) CHSDefaultMarsh +-- Definitions for bare structure function wrappers.+data Wrapper = Wrapper { wrapFn :: String+ , wrapOrigFn ::String+ , wrapDecl :: CDecl+ , wrapArgs :: [Bool]+ , wrapPos :: Position }+ deriving Show+ {- FIXME: What a mess... instance Show HsObject where show (Pointer ptrType isNewtype) =@@ -290,7 +300,8 @@ szmap :: SizeMap, -- object sizes enums :: EnumSet, -- enumeration hooks tdmap :: TypedefMap, -- typedefs- dmmap :: DefaultMarshMap -- user-defined default marshallers+ dmmap :: DefaultMarshMap, -- user-defined default marshallers+ wrappers :: [Wrapper] } type GB a = CT GBState a@@ -306,7 +317,8 @@ szmap = Map.empty, enums = Set.empty, tdmap = Map.empty,- dmmap = Map.empty+ dmmap = Map.empty,+ wrappers = [] } -- | set the dynamic library and library prefix@@ -527,6 +539,15 @@ isDefaultMarsh :: (Direction, String, Bool) -> CHSDefaultMarsh -> GB () isDefaultMarsh k dm = transCT (\state -> (state { dmmap = Map.insert k dm (dmmap state) }, ()))++-- | add a wrapper definition+addWrapper :: String -> String -> CDecl -> [Bool] -> Position -> GB ()+addWrapper wfn ofn cdecl args pos =+ let w = Wrapper wfn ofn cdecl args pos+ in transCT (\st -> (st { wrappers = w : (wrappers st) }, ()))++getWrappers :: GB [Wrapper]+getWrappers = readCT wrappers -- error messages
+ src/C2HS/Gen/Wrapper.hs view
@@ -0,0 +1,154 @@+-- C->Haskell Compiler: custom wrapper generator+--+-- Author : Manuel M T Chakravarty+-- Created: 5 February 2003+--+-- Copyright (c) 2004 Manuel M T Chakravarty+--+-- This file is free software; you can redistribute it and/or modify+-- it under the terms of the GNU General Public License as published by+-- the Free Software Foundation; either version 2 of the License, or+-- (at your option) any later version.+--+-- This file is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+-- GNU General Public License for more details.+--+--- DESCRIPTION ---------------------------------------------------------------+--+-- This module implements the generation of a custom C file to wrap+-- functions requiring marshalling of bare C structs to pointers.+--++module C2HS.Gen.Wrapper (+ genWrappers+) where++import Control.Monad++-- Language.C / Compiler Toolkit+import Language.C.Syntax+import Language.C.Pretty+import Text.PrettyPrint.HughesPJ (render)+import Language.C.Data.Node (undefNode)+import Language.C.Data.Position+import Language.C.Data.Ident (Ident(..), internalIdent)+import Data.DList (DList)+import qualified Data.DList as DL++-- C->Haskell+import C2HS.State (CST, raiseError, throwExc, catchExc,+ errorsPresent, showErrors, fatal)+import C2HS.C.Trav (isPtrDeclr)++-- friends+import C2HS.Gen.Monad (Wrapper(..))+++-- | Generate a custom C wrapper from a CHS binding module for+-- functions that require marshalling of bare C structs.+--+genWrappers :: [Wrapper] -> CST s [String]+genWrappers ws = do+ wraps <- mapM genWrapper (reverse ws) `ifWrapExc` return []+ errs <- errorsPresent+ if errs+ then do+ errmsgs <- showErrors+ fatal ("Errors during generation of C wrappers:\n\n" ++ errmsgs)+ else do+ return $ DL.toList . DL.concat $ wraps+++-- | Process a single fragment.+--+genWrapper :: Wrapper -> CST s (DList String)+genWrapper (Wrapper wfn ofn (CDecl specs [(Just decl, _, _)] _) args pos) = do+ let renamed = rename (internalIdent wfn) decl+ wrapdecl <- fixArgs ofn pos args renamed+ let wrapfn = CFunDef specs 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]++rename :: Ident -> CDeclr -> CDeclr+rename ide (CDeclr _ dds str attrs n) = CDeclr (Just ide) dds str attrs n++fixArgs :: String -> Position -> [Bool] -> CDeclr -> CST s CDeclr+fixArgs ofn pos args (CDeclr ide fd str attrs n) = do+ fd' <- case fd of+ [] -> return []+ f:fs -> do+ f' <- fixFunArgs ofn pos args f+ return $ f' : fs+ return $ CDeclr ide fd' str attrs n++fixFunArgs :: String -> Position -> [Bool] -> CDerivedDeclr+ -> CST s CDerivedDeclr+fixFunArgs ofn pos args (CFunDeclr (Right (adecls, flg)) attrs n) = do+ adecls' <- zipWithM (fixDecl ofn pos) args adecls+ return $ CFunDeclr (Right (adecls', flg)) attrs n+fixFunArgs ofn pos args cdecl =+ internalWrapperErr pos ["fixFunArgs:" ++ ofn,+ "args=" ++ show args,+ "cdecl=" ++ show cdecl]++fixDecl :: String -> Position -> Bool -> CDecl -> CST s CDecl+fixDecl _ _ False d = return d+fixDecl _ pos True (CDecl specs [(Just decl, Nothing, Nothing)] n) = do+ decl' <- addPtr pos decl+ return $ CDecl specs [(Just decl', Nothing, Nothing)] n+fixDecl ofn pos arg cdecl =+ internalWrapperErr pos ["fixDecl:ofn=" ++ ofn,+ "arg=" ++ show arg,+ "cdecl=" ++ show cdecl]++addPtr :: Position -> CDeclr -> CST s CDeclr+addPtr _ (CDeclr ide [] cs attrs n) =+ return $ CDeclr ide [CPtrDeclr [] n] cs attrs n+addPtr pos cdecl = if isPtrDeclr cdecl+ 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++makeArg :: Bool -> CDecl -> CExpr+makeArg arg (CDecl _ [(Just (CDeclr (Just i) _ _ _ _), _, _)] n) =+ case arg of+ False -> CVar i n+ True -> CUnary CIndOp (CVar i n) n++funArgs :: CDerivedDeclr -> [CDecl]+funArgs (CFunDeclr (Right (adecls, _)) _ _) = adecls++throwWrapExc :: CST s a+throwWrapExc = throwExc "wrapExc" "Error during wrapper generation"++ifWrapExc :: CST s a -> CST s a -> CST s a+ifWrapExc m handler = m `catchExc` ("wrapExc", const handler)++raiseErrorWrapper :: Position -> [String] -> CST s a+raiseErrorWrapper pos errs = raiseError pos errs >> throwWrapExc++internalWrapperErr :: Position -> [String] -> CST s a+internalWrapperErr pos msg =+ raiseErrorWrapper pos $+ ["Internal wrapper error!",+ "Something went wrong generating a bare structure wrapper."] ++ msg++wrapperOnPointerErr :: Position -> CST s a+wrapperOnPointerErr pos =+ raiseErrorWrapper pos $+ ["Bare structure wrapper error!",+ "Are you trying to put a wrapper on a pointer type?"]++invalidWrapperErr :: Position -> CST s a+invalidWrapperErr pos =+ raiseErrorWrapper pos $+ ["Bare structure wrapper error!",+ "Invalid bare structure wrapper"]
src/C2HS/Version.hs view
@@ -9,7 +9,7 @@ name = "C->Haskell Compiler" versnum = Paths_c2hs.version-versnick = "Snowbounder"+versnick = "Snowboundest" date = "31 Oct 2014" version = name ++ ", version " ++ showVersion versnum ++ " " ++ versnick ++ ", " ++ date copyright = "Copyright (c) 1999-2007 Manuel M T Chakravarty\n"
src/Main.hs view
@@ -136,9 +136,10 @@ SwitchBoard(..), Traces(..), setTraces, traceSet, setSwitch, getSwitch, putTraceStr) import qualified System.CIO as CIO-import C2HS.C (hsuffix, isuffix, loadAttrC)+import C2HS.C (csuffix, hsuffix, isuffix, loadAttrC) import C2HS.CHS (loadCHS, dumpCHS, hssuffix, chssuffix, dumpCHI, hasNonGNU) import C2HS.Gen.Header (genHeader)+import C2HS.Gen.Wrapper (genWrappers) import C2HS.Gen.Bind (expandHooks) import C2HS.Version (versnum, version, copyright, disclaimer) import C2HS.Config (cppopts, libfname, PlatformSpec(..),@@ -606,13 +607,21 @@ -- -- expand binding hooks into plain Haskell --- (hsMod, chi, hooksMsgs) <- expandHooks cheader strippedCHSMod+ (hsMod, chi, wrappers, hooksMsgs) <- expandHooks cheader strippedCHSMod CIO.putStr hooksMsgs -- -- output the result -- dumpCHS outFPath hsMod True dumpCHI outFPath chi -- different suffix will be appended+ --+ -- create new wrapper file if necessary+ --+ when (not $ null wrappers) $ do+ wrapper' <- genWrappers wrappers+ let newWrapperFile = outDir </> outFName <.> chssuffix <.> csuffix+ CIO.writeFile newWrapperFile $ concat $+ [ "#include \"" ++ newHeader ++ "\"\n" ] ++ wrapper' where tracePreproc cmd = putTraceStr tracePhasesSW $ "Invoking cpp as `" ++ cmd ++ "'...\n"
+ tests/bugs/issue-117/Issue117.chs view
@@ -0,0 +1,20 @@+module Main where++import Control.Monad+import Foreign.Ptr+import Foreign.ForeignPtr+import Foreign.C.Types+import System.IO.Unsafe++#include "issue117.h"++{#pointer *coord_t as CoordPtr foreign finalizer free_coord newtype#}++{#fun pure make_coord as makeCoord {`Int', `Int'} -> `CoordPtr'#}+{#fun pure coord_x as coordX {%`CoordPtr', `Int'} -> `Int'#}++main :: IO ()+main = do+ let c = makeCoord 5 6+ let x = coordX c 0+ print x
+ tests/bugs/issue-117/issue117.c view
@@ -0,0 +1,22 @@+#include <stdlib.h>++#include "issue117.h"++int coord_x(coord_t c, int dummy)+{+ return c.x;+}++coord_t *make_coord(int x, int y)+{+ coord_t *coord;+ coord = (coord_t *)malloc(sizeof(coord_t));+ coord->x = x;+ coord->y = y;+ return coord;+}++void free_coord(coord_t *coord)+{+ free(coord);+}
+ tests/bugs/issue-117/issue117.h view
@@ -0,0 +1,8 @@+typedef struct {+ int x;+ int y;+} coord_t;++coord_t *make_coord(int x, int y);+void free_coord(coord_t *coord);+int coord_x(coord_t c, int dummy);
+ tests/bugs/issue-123/Issue123.chs view
@@ -0,0 +1,27 @@+module Main where++import Foreign+import Foreign.C++#include "issue123.h"++{#pointer *array_t as MyStruct#}++{#fun get_struct {`Int', `Int', `Int'} -> `MyStruct' return* #}++main :: IO ()+main = do+ myStruct <- get_struct 7 42 93+ p1 <- {#get array_t->p#} myStruct >>= peekArray 3+ print p1+ a1 <- {#get array_t->a#} myStruct >>= peekArray 3+ print a1+ cInts <- mallocArray 3+ pokeArray cInts [2, 4, 8]+ {#set array_t->p#} myStruct cInts+ p2 <- {#get array_t->p#} myStruct >>= peekArray 3+ print p2+ pokeArray cInts [3, 9, 27]+ {#set array_t->a#} myStruct cInts+ a2 <- {#get array_t->a#} myStruct >>= peekArray 3+ print a2
+ tests/bugs/issue-123/issue123.c view
@@ -0,0 +1,19 @@+#include "issue123.h"++array_t myStruct;+int other_a[3];++array_t *get_struct(int n, int m, int o)+{+ myStruct.a[0] = n;+ myStruct.a[1] = m;+ myStruct.a[2] = o;++ other_a[0] = n + 1;+ other_a[1] = m + 1;+ other_a[2] = o + 1;++ myStruct.p = other_a;++ return &myStruct;+}
+ tests/bugs/issue-123/issue123.h view
@@ -0,0 +1,8 @@+#pragma once++typedef struct {+ int a[3]; /* An array of length 3. */+ int *p; /* A pointer to an array. */+} array_t;++array_t *get_struct(int n, int m, int o);
+ tests/bugs/issue-127/Issue127.chs view
@@ -0,0 +1,13 @@+module Main where++import Foreign+import Foreign.C.Types++#include "issue127.h"++{#fun tst as ^ {`Int'} -> `Bool'#}++main :: IO ()+main = do+ tst 5 >>= print+ tst (-2) >>= print
+ tests/bugs/issue-127/issue127.c view
@@ -0,0 +1,6 @@+#include "issue127.h"++bool tst(int n)+{+ return n > 0;+}
+ tests/bugs/issue-127/issue127.h view
@@ -0,0 +1,17 @@+typedef unsigned char TST_BOOL;++#if defined(__cplusplus)++/* Use the C++ compiler's bool type */+#define TST_BOOL bool++#else /* c89, c99, etc. */++/* There is no predefined bool - use our own */+#undef bool+#define bool TST_BOOL++#endif+++bool tst(int n);
− tests/bugs/issue-37/Issue37.chs
@@ -1,17 +0,0 @@-module Main where--import Foreign-import Foreign.C--#include "issue37.h"--{#fun f1 {`Int'} -> `Int'#}--{#fun f2 {`Float'} -> `Float'#}--main :: IO ()-main = do- tst1 <- f1 7- tst2 <- f2 23- putStrLn $ if tst1 == 14 then "SAME" else "DIFF"- putStrLn $ if tst2 == 69 then "SAME" else "DIFF"
− tests/bugs/issue-37/issue37.c
@@ -1,12 +0,0 @@-#include "issue37.h"--int f1(int *np)-{- return *np * 2;-}---float f2(float *np)-{- return *np * 3;-}
− tests/bugs/issue-37/issue37.h
@@ -1,2 +0,0 @@-int f1(int *np);-float f2(float *np);
tests/test-bugs.hs view
@@ -5,6 +5,7 @@ import Test.Framework.Providers.HUnit import Test.HUnit hiding (Test, assert) import System.FilePath (searchPathSeparator)+import System.Info (os) import Prelude hiding (FilePath) import Control.Monad.IO.Class import Shelly@@ -25,9 +26,12 @@ setenv "PATH" newpath as +cc :: FilePath+cc = if os == "cygwin32" || os == "mingw32" then "gcc" else "cc"+ tests :: [Test] tests =- [ testGroup "Bugs"+ [ testGroup "Bugs" $ [ testCase "call_capital (issue #??)" call_capital , testCase "Issue #7" issue07 , testCase "Issue #9" issue09@@ -50,7 +54,6 @@ , testCase "Issue #45" issue45 , testCase "Issue #46" issue46 , testCase "Issue #47" issue47- , testCase "Issue #48" issue48 , testCase "Issue #51" issue51 , testCase "Issue #54" issue54 , testCase "Issue #60" issue60@@ -63,19 +66,26 @@ , testCase "Issue #79" issue79 , testCase "Issue #80" issue80 , testCase "Issue #82" issue82- , testCase "Issue #83" issue83 , testCase "Issue #93" issue93 , testCase "Issue #95" issue95 , testCase "Issue #96" issue96 , testCase "Issue #97" issue97 , testCase "Issue #98" issue98- , testCase "Issue #102" issue102 , testCase "Issue #103" issue103 , testCase "Issue #107" issue107 , testCase "Issue #113" issue113 , testCase "Issue #115" issue115 , testCase "Issue #116" issue116- ]+ , testCase "Issue #117" issue117+ , testCase "Issue #123" issue123+ , testCase "Issue #127" issue127+ ] +++ -- Some tests that won't work on Windows.+ if os /= "cygwin32" && os /= "mingw32"+ then [ testCase "Issue #48" issue48+ , testCase "Issue #83" issue83+ , testCase "Issue #102" issue102 ]+ else [ ] ] call_capital :: Assertion@@ -83,12 +93,33 @@ mapM_ rm_f ["Capital.hs", "Capital.chs.h", "Capital.chi", "Capital_c.o", "Capital"] cmd "c2hs" "-d" "genbind" "Capital.chs"- cmd "cc" "-c" "-o" "Capital_c.o" "Capital.c"+ cmd cc "-c" "-o" "Capital_c.o" "Capital.c" cmd "ghc" "--make" "-cpp" "Capital_c.o" "Capital.hs" res <- absPath "./Capital" >>= cmd let expected = ["upper C();", "lower c();", "upper C();"] liftIO $ assertBool "" (T.lines res == expected) +issue127 :: Assertion+issue127 = expect_issue 127 ["True", "False"]++issue125 :: Assertion+issue125 = expect_issue 125 ["NYI"]++issue123 :: Assertion+issue123 = expect_issue 123 ["[8,43,94]", "[7,42,93]", "[2,4,8]", "[3,9,27]"]++issue117 :: Assertion+issue117 = c2hsShelly $ chdir "tests/bugs/issue-117" $ do+ mapM_ rm_f ["Issue117.hs", "Issue117.chs.h", "Issue117.chs.c", "Issue117.chi",+ "issue117_c.o", "Issue117.chs.o", "Issue117"]+ cmd "c2hs" "Issue117.chs"+ cmd cc "-c" "-o" "issue117_c.o" "issue117.c"+ cmd cc "-c" "Issue117.chs.c"+ cmd "ghc" "--make" "issue117_c.o" "Issue117.chs.o" "Issue117.hs"+ res <- absPath "./Issue117" >>= cmd+ let expected = ["5"]+ liftIO $ assertBool "" (T.lines res == expected)+ issue116 :: Assertion issue116 = build_issue 116 @@ -108,7 +139,7 @@ "issue103_c.o", "Issue103"] cmd "c2hs" "Issue103A.chs" cmd "c2hs" "Issue103.chs"- cmd "cc" "-c" "-o" "issue103_c.o" "issue103.c"+ cmd cc "-c" "-o" "issue103_c.o" "issue103.c" cmd "ghc" "--make" "issue103_c.o" "Issue103A.hs" "Issue103.hs" res <- absPath "./Issue103" >>= cmd let expected = ["1", "2", "3"]@@ -130,7 +161,7 @@ "issue97_c.o", "Issue97"] cmd "c2hs" "Issue97A.chs" cmd "c2hs" "Issue97.chs"- cmd "cc" "-c" "-o" "issue97_c.o" "issue97.c"+ cmd cc "-c" "-o" "issue97_c.o" "issue97.c" cmd "ghc" "--make" "issue97_c.o" "Issue97A.hs" "Issue97.hs" res <- absPath "./Issue97" >>= cmd let expected = ["42"]@@ -249,9 +280,9 @@ mv "Issue30Aux2.chi" "test 2" let sp = T.pack $ "test 1" ++ [searchPathSeparator] ++ "test 2" cmd "c2hs" "--include" sp "Issue30.chs"- cmd "cc" "-c" "-o" "issue30_c.o" "issue30.c"- cmd "cc" "-c" "-o" "issue30aux1_c.o" "issue30aux1.c"- cmd "cc" "-c" "-o" "issue30aux2_c.o" "issue30aux2.c"+ cmd cc "-c" "-o" "issue30_c.o" "issue30.c"+ cmd cc "-c" "-o" "issue30aux1_c.o" "issue30aux1.c"+ cmd cc "-c" "-o" "issue30aux2_c.o" "issue30aux2.c" cmd "ghc" "--make" "issue30_c.o" "issue30aux1_c.o" "issue30aux2_c.o" "Issue30Aux1.hs" "Issue30Aux2.hs" "Issue30.hs" res <- absPath "./Issue30" >>= cmd@@ -318,7 +349,7 @@ cd wdir mapM_ rm_f [uc <.> "hs", uc <.> "chs.h", uc <.> "chi", lcc <.> "o", uc] run "c2hs" $ c2hsargs ++ [toTextIgnore $ uc <.> "chs"]- when cbuild $ cmd "cc" "-c" "-o" (lcc <.> "o") (lc <.> "c")+ when cbuild $ cmd cc "-c" "-o" (lcc <.> "o") (lc <.> "c") if cbuild then cmd "ghc" "-Wall" "-Werror" "--make" (lcc <.> "o") (uc <.> "hs") else cmd "ghc" "-Wall" "-Werror" "--make" (uc <.> "hs")
tests/test-system.hs view
@@ -11,6 +11,7 @@ import Control.Monad (forM_) import Data.Text (Text) import Data.Monoid+import System.Info (os) import qualified Data.Text as T import Paths_c2hs default (T.Text)@@ -25,6 +26,9 @@ setenv "PATH" newpath as +cc :: FilePath+cc = if os == "cygwin32" || os == "mingw32" then "gcc" else "cc"+ tests :: [Test] tests = [ testGroup "System"@@ -67,7 +71,7 @@ test_enums :: Assertion test_enums = run_test_expect "tests/system/enums" [("c2hs", ["enums.h", "Enums.chs"]),- ("cc", ["-o", "enums_c.o", "-c", "enums.c"]),+ (cc, ["-o", "enums_c.o", "-c", "enums.c"]), ("ghc", ["-o", "enums", "enums_c.o", "Enums.hs"])] "./enums" ["Did it!"]@@ -83,14 +87,14 @@ test_pointer :: Assertion test_pointer = run_test_exit_code "tests/system/pointer" [("c2hs", ["pointer.h", "Pointer.chs"]),- ("cc", ["-o", "pointer_c.o", "-c", "pointer.c"]),+ (cc, ["-o", "pointer_c.o", "-c", "pointer.c"]), ("ghc", ["-o", "pointer", "pointer_c.o", "Pointer.hs"])] test_simple :: Assertion test_simple = run_test_expect "tests/system/simple" [("c2hs", ["simple.h", "Simple.chs"]), ("ghc", ["-c", "-o", "Simple_hs.o", "Simple.hs"]),- ("cc", ["-c", "simple.c"]),+ (cc, ["-c", "simple.c"]), ("ghc", ["-o", "simple", "simple.o", "Simple_hs.o"])] "./simple" ["I am the mighty foo!"]@@ -100,7 +104,7 @@ test_sizeof = run_test_expect "tests/system/sizeof" [("c2hs", ["sizeof.h", "Sizeof.chs"]), ("ghc", ["-c", "-o", "Sizeof.o", "Sizeof.hs"]),- ("cc", ["-o", "sizeof_c.o", "-c", "sizeof.c"]),+ (cc, ["-o", "sizeof_c.o", "-c", "sizeof.c"]), ("ghc", ["-o", "sizeof", "sizeof_c.o", "Sizeof.o"])] "./sizeof" ["16 & 64 & 4 & 10",@@ -110,7 +114,7 @@ test_structs = run_test_expect "tests/system/structs" [("c2hs", ["structs.h", "Structs.chs"]), ("ghc", ["-c", "-o", "Structs.o", "Structs.hs"]),- ("cc", ["-o", "structs_c.o", "-c", "structs.c"]),+ (cc, ["-o", "structs_c.o", "-c", "structs.c"]), ("ghc", ["-o", "structs", "structs_c.o", "Structs.o"])] "./structs" ["42 & -1 & 2 & 200 & ' '"]