New patches: [allow call hooks for FunPtrs inside structures Udo Stenzel **20060429155023] { hunk ./c2hs/chs/CHS.hs 95 - showCHSParm) + showCHSParm, apathToIdent) hunk ./c2hs/chs/CHS.hs 180 - Ident -- C function + CHSAPath -- C function hunk ./c2hs/chs/CHS.hs 185 - Ident -- C function + CHSAPath -- C function hunk ./c2hs/chs/CHS.hs 289 +instance Pos CHSAPath where + posOf (CHSRoot ide) = posOf ide + posOf (CHSDeref _ pos) = pos + posOf (CHSRef _ ide) = posOf ide + hunk ./c2hs/chs/CHS.hs 481 - . showIdAlias ide oalias + . showApAlias ide oalias hunk ./c2hs/chs/CHS.hs 486 - . showIdAlias ide oalias + . showApAlias ide oalias hunk ./c2hs/chs/CHS.hs 539 +showApAlias :: CHSAPath -> Maybe Ident -> ShowS +showApAlias apath oalias = + showCHSAPath apath + . (case oalias of + Nothing -> id + Just ide -> showString " as " . showCHSIdent ide) + hunk ./c2hs/chs/CHS.hs 861 - (ide , toks''' ) <- parseIdent toks'' - (oalias , toks'''') <- parseOptAs ide False toks''' + (apath , toks''' ) <- parsePath toks'' + (oalias , toks'''') <- parseOptAs (apathToIdent apath) False toks''' hunk ./c2hs/chs/CHS.hs 866 - CHSHook (CHSCall isPure isUnsafe ide (norm ide oalias) pos) : frags + CHSHook (CHSCall isPure isUnsafe apath (normAP apath oalias) pos) : frags hunk ./c2hs/chs/CHS.hs 873 - (ide , toks'3) <- parseIdent toks'2 - (oalias , toks'4) <- parseOptAs ide False toks'3 + (apath , toks'3) <- parsePath toks'2 + (oalias , toks'4) <- parseOptAs (apathToIdent apath) False toks'3 hunk ./c2hs/chs/CHS.hs 882 - (CHSFun isPure isUnsafe ide (norm ide oalias) octxt parms parm pos) : + (CHSFun isPure isUnsafe apath (normAP apath oalias) octxt parms parm pos) : hunk ./c2hs/chs/CHS.hs 916 +normAP :: CHSAPath -> Maybe Ident -> Maybe Ident +normAP ide Nothing = Nothing +normAP ide (Just ide') | apathToIdent ide == ide' = Nothing + | otherwise = Just ide' + + +-- FIXME: this "identifier" will be almost useless. a better idea would +-- be nice +apathToIdent :: CHSAPath -> Ident +apathToIdent (CHSRoot ide) = ide +apathToIdent (CHSDeref apath _) = apathToIdent apath +apathToIdent (CHSRef apath ide) = ide + + hunk ./c2hs/chs/CHS.hs 963 - frags <- parseFrags toks' + toks'' <- parseEndHook toks' + frags <- parseFrags toks'' hunk ./c2hs/chs/CHS.hs 1107 - do - toks' <- parseEndHook toks - return (id, toks') + return (id,toks) hunk ./c2hs/gen/GenBind.hs 145 - CHSPtrType(..), showCHSParm) + CHSPtrType(..), showCHSParm, apathToIdent) hunk ./c2hs/gen/GenBind.hs 425 -expandHook hook@(CHSCall isPure isUns ide oalias pos) = +expandHook hook@(CHSCall isPure isUns (CHSRoot ide) oalias pos) = hunk ./c2hs/gen/GenBind.hs 441 -expandHook hook@(CHSFun isPure isUns ide oalias ctxt parms parm pos) = +expandHook hook@(CHSCall isPure isUns apath oalias pos) = + do + traceEnter + + (decl, offsets) <- accessPath apath + ptrTy <- extractSimpleType False pos decl + ty <- case ptrTy of + PtrET f@(FunET _ _) -> return f + _ -> funPtrExpectedErr pos + + traceValueType ty + set_get <- setGet pos CHSGet offsets ptrTy + + -- get the corresponding C declaration; raises error if not found or not a + -- function; we use shadow identifiers, so the returned identifier is used + -- afterwards instead of the original one + -- + -- (ObjCO cdecl, ide) <- findFunObj ide True + let ideLexeme = identToLexeme $ apathToIdent apath + hsLexeme = ideLexeme `maybe` identToLexeme $ oalias + -- cdecl' = ide `simplifyDecl` cdecl + args = concat [ " x" ++ show n | n <- [1..numArgs ty] ] + + callImportDyn hook isPure isUns ideLexeme hsLexeme ty pos + return $ "(\\o" ++ args ++ " -> " ++ set_get ++ " o >>= \\f -> " + ++ hsLexeme ++ " f" ++ args ++ ")" + where + traceEnter = traceGenBind $ + "** Indirect call hook for `" ++ identToLexeme (apathToIdent apath) ++ "':\n" + traceValueType et = traceGenBind $ + "Type of accessed value: " ++ showExtType et ++ "\n" +expandHook hook@(CHSFun isPure isUns (CHSRoot ide) oalias ctxt parms parm pos) = hunk ./c2hs/gen/GenBind.hs 485 - callHook = CHSCall isPure isUns cide (Just fiIde) pos + callHook = CHSCall isPure isUns (CHSRoot cide) (Just fiIde) pos hunk ./c2hs/gen/GenBind.hs 714 + where + traceFunType et = traceGenBind $ + "Imported function type: " ++ showExtType et ++ "\n" + +callImportDyn :: CHSHook -> Bool -> Bool -> String -> String -> ExtType + -> Position -> GB () +callImportDyn hook isPure isUns ideLexeme hsLexeme ty pos = + do + -- compute the external type from the declaration, and delay the foreign + -- export declaration + -- + when (isVariadic ty) (variadicErr pos pos) -- huh? (posOf cdecl)) + delayCode hook (foreignImportDyn ideLexeme hsLexeme isUns ty) + traceFunType ty hunk ./c2hs/gen/GenBind.hs 738 + where + safety = if isUnsafe then "unsafe" else "safe" + +-- Haskell code for the foreign import dynamic declaration needed by a call hook +-- +foreignImportDyn :: String -> String -> Bool -> ExtType -> String +foreignImportDyn ident hsIdent isUnsafe ty = + "foreign import ccall " ++ safety ++ " \"dynamic\"\n " ++ + hsIdent ++ " :: FunPtr( " ++ showExtType ty ++ " ) -> " ++ + showExtType ty ++ "\n" hunk ./c2hs/gen/GenBind.hs 1291 + +numArgs :: ExtType -> Int +numArgs (FunET _ f) = 1 + numArgs f +numArgs _ = 0 hunk ./c2hs/gen/GenBind.hs 2082 + +funPtrExpectedErr :: Position -> GB a +funPtrExpectedErr pos = + raiseErrorCTExc pos + ["Expected a pointer-to-function object!", + "Attempt to use a non-pointer object in a `call' or `fun' hook."] } [improve translation of apath to identifier Udo Stenzel **20060429235900] { hunk ./c2hs/chs/CHS.hs 922 --- FIXME: this "identifier" will be almost useless. a better idea would --- be nice hunk ./c2hs/chs/CHS.hs 923 -apathToIdent (CHSRoot ide) = ide -apathToIdent (CHSDeref apath _) = apathToIdent apath -apathToIdent (CHSRef apath ide) = ide - +apathToIdent (CHSRoot ide) = + let lowerFirst (c:cs) = toLower c : cs + in onlyPosIdent (posOf ide) (lowerFirst $ identToLexeme ide) +apathToIdent (CHSDeref apath _) = + let ide = apathToIdent apath + in onlyPosIdent (posOf ide) (identToLexeme ide ++ "'") +apathToIdent (CHSRef apath ide') = + let ide = apathToIdent apath + in onlyPosIdent (posOf ide) (identToLexeme ide ++ identToLexeme ide) } [support fun hooks for FunPtrs inside structs Udo Stenzel **20060429235956 This is a bit hackish at times, as I cut-and-paste-coded a bit. Though pending cleanup, it seems to work. ] { hunk ./c2hs/gen/GenBind.hs 487 - funDef isPure hsLexeme fiLexeme cdecl' ctxt parms parm pos + + extTy <- extractFunType pos cdecl' True + funDef isPure hsLexeme fiLexeme extTy ctxt parms parm pos hunk ./c2hs/gen/GenBind.hs 493 +expandHook hook@(CHSFun isPure isUns apath oalias ctxt parms parm pos) = + do + traceEnter + + (decl, offsets) <- accessPath apath + ptrTy <- extractSimpleType False pos decl + ty <- case ptrTy of + PtrET f@(FunET _ _) -> return f + _ -> funPtrExpectedErr pos + + traceValueType ty + set_get <- setGet pos CHSGet offsets ptrTy + + -- get the corresponding C declaration; raises error if not found or not a + -- function; we use shadow identifiers, so the returned identifier is used + -- afterwards instead of the original one + -- + -- (ObjCO cdecl, cide) <- findFunObj ide True + let ideLexeme = identToLexeme $ apathToIdent apath + hsLexeme = ideLexeme `maybe` identToLexeme $ oalias + fiLexeme = hsLexeme ++ "'_" -- *Urgh* - probably unqiue... + fiIde = onlyPosIdent nopos fiLexeme + -- 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 ty pos + + let parm0 = CHSParm (Just (onlyPosIdent nopos "chs_deref_fun_ptr_", CHSIOArg)) + "Ptr ()" False Nothing nopos + fun <- funDef isPure hsLexeme fiLexeme (FunET ptrTy ty) ctxt (parm0:parms) parm pos + return $ fun ++ "\n where chs_deref_fun_ptr_ o io = " ++ set_get ++ " o >>= io" + where + traceEnter = traceGenBind $ + "** Fun hook for `" ++ identToLexeme (apathToIdent apath) ++ "':\n" + traceValueType et = traceGenBind $ + "Type of accessed value: " ++ showExtType et ++ "\n" hunk ./c2hs/gen/GenBind.hs 794 - -> CDecl -- simplified declaration of the C function + -> ExtType -- simplified declaration of the C function hunk ./c2hs/gen/GenBind.hs 800 -funDef isPure hsLexeme fiLexeme cdecl octxt parms parm pos = +funDef isPure hsLexeme fiLexeme extTy octxt parms parm pos = hunk ./c2hs/gen/GenBind.hs 802 - (parms', parm', isImpure) <- addDftMarshaller pos parms parm cdecl + (parms', parm', isImpure) <- addDftMarshaller pos parms parm extTy + hunk ./c2hs/gen/GenBind.hs 914 -addDftMarshaller :: Position -> [CHSParm] -> CHSParm -> CDecl +addDftMarshaller :: Position -> [CHSParm] -> CHSParm -> ExtType hunk ./c2hs/gen/GenBind.hs 916 -addDftMarshaller pos parms parm cdecl = do - (resTy, argTys) <- splitFunTy `liftM` extractFunType pos cdecl True +addDftMarshaller pos parms parm extTy = do + let (resTy, argTys) = splitFunTy extTy } [minor beautification Udo Stenzel **20060430215444] { hunk ./c2hs/chs/CHS.hs 928 - in onlyPosIdent (posOf ide) (identToLexeme ide ++ "'") + in onlyPosIdent (posOf ide) (identToLexeme ide ++ "_") hunk ./c2hs/chs/CHS.hs 931 - in onlyPosIdent (posOf ide) (identToLexeme ide ++ identToLexeme ide) + upperFirst (c:cs) = toLower c : cs + sel = upperFirst $ identToLexeme ide' + in onlyPosIdent (posOf ide) (identToLexeme ide ++ sel) hunk ./c2hs/gen/GenBind.hs 2 +-- vim:ts=8:noexpandtab hunk ./c2hs/gen/GenBind.hs 523 - fun <- funDef isPure hsLexeme fiLexeme (FunET ptrTy ty) ctxt (parm0:parms) parm pos + fun <- funDef isPure hsLexeme fiLexeme (FunET ptrTy $ purify ty) + ctxt (parm0:parms) parm pos hunk ./c2hs/gen/GenBind.hs 527 + -- remove IO from the result type of a function ExtType. necessary + -- due to an unexpected interaction with the way funDef works + purify (FunET a b) = FunET a (purify b) + purify (IOET b) = b + purify a = a + hunk ./c2hs/gen/GenBind.hs 771 - when (isVariadic ty) (variadicErr pos pos) -- huh? (posOf cdecl)) + when (isVariadic ty) (variadicErr pos pos) -- FIXME? (posOf cdecl)) hunk ./c2hs/gen/GenBind.hs 1417 - where - cpos = posOf cdecl } [change handling of marshallers for dynamic function hooks Udo Stenzel **20060515142639] { hunk ./c2hs/gen/GenBind.hs 490 - funDef isPure hsLexeme fiLexeme extTy ctxt parms parm pos + funDef isPure hsLexeme fiLexeme extTy ctxt parms parm Nothing pos hunk ./c2hs/gen/GenBind.hs 505 - set_get <- setGet pos CHSGet offsets ptrTy hunk ./c2hs/gen/GenBind.hs 520 - let parm0 = CHSParm (Just (onlyPosIdent nopos "chs_deref_fun_ptr_", CHSIOArg)) - "Ptr ()" False Nothing nopos - fun <- funDef isPure hsLexeme fiLexeme (FunET ptrTy $ purify ty) - ctxt (parm0:parms) parm pos - return $ fun ++ "\n where chs_deref_fun_ptr_ o io = " ++ set_get ++ " o >>= io" + set_get <- setGet pos CHSGet offsets ptrTy + funDef isPure hsLexeme fiLexeme (FunET ptrTy $ purify ty) + ctxt parms parm (Just set_get) pos hunk ./c2hs/gen/GenBind.hs 796 +-- * FIXME: There's an ugly special case in here: to support dynamic fun hooks +-- I had to add a special second marshaller for the first argument, +-- which, if present, is inserted just before the function call. This +-- is probably not the most elegant solution, it's just the only one I +-- can up with at the moment. If present, this special marshaller is +-- an io action (like 'peek' and unlike 'with'). -- US + hunk ./c2hs/gen/GenBind.hs 810 + -> Maybe String -- optional additional marshaller for first arg hunk ./c2hs/gen/GenBind.hs 813 -funDef isPure hsLexeme fiLexeme extTy octxt parms parm pos = +funDef isPure hsLexeme fiLexeme extTy octxt parms parm marsh2 pos = hunk ./c2hs/gen/GenBind.hs 823 - callArgs = [callArg | (_, _, callArg, _, _) <- marshs] + callArgs = [callArg | (_, _, cs, _, _) <- marshs, callArg <- cs] hunk ./c2hs/gen/GenBind.hs 829 - then " let {res = " ++ fiLexeme ++ join callArgs ++ "} in\n" - else " " ++ fiLexeme ++ join callArgs ++ " >>= \\res ->\n" + then " let {res = " ++ fiLexeme ++ joinCallArgs ++ "} in\n" + else " " ++ fiLexeme ++ joinCallArgs ++ " >>= \\res ->\n" + joinCallArgs = case marsh2 of + Nothing -> join callArgs + Just _ -> join ("b1'" : drop 1 callArgs) + mkMarsh2 = case marsh2 of + Nothing -> "" + Just m -> " " ++ m ++ " " ++ + join (take 1 callArgs) ++ + " >>= \\b1' ->\n" hunk ./c2hs/gen/GenBind.hs 852 + mkMarsh2 ++ hunk ./c2hs/gen/GenBind.hs 908 - callArg = if twoCVal - then "" ++ a ++ "'1 " ++ a ++ "'2" - else a ++ "'" - omApp = identToLexeme omIde ++ " " ++ callArg + callArgs = if twoCVal + then [a ++ "'1 ", a ++ "'2"] + else [a ++ "'"] + omApp = identToLexeme omIde ++ join callArgs hunk ./c2hs/gen/GenBind.hs 920 - (funArg, marshIn, callArg, marshOut, retArg) + (funArg, marshIn, callArgs, marshOut, retArg) } Context: [darcs.haskell.org repo Manuel M T Chakravarty **20060514224852] [Version 0.14.6 credits Manuel M T Chakravarty **20060429012404] [calculate size of embedded arrays correctly Udo Stenzel **20060502231635] [tolerate variadic functions Udo Stenzel **20060423234358 This adds support for pointers to variadic functions in structs. They cannot be called, but the rest of the struct is accessible without c2hs bombing out. ] [enum define workaround example Manuel M T Chakravarty **20051219124518] [TAG c2hs 0.14.5 Manuel M T Chakravarty **20051212115038] Patch bundle hash: 6052a8f966c3b229e2fbce5446920d9fadb57dad