diff --git a/ChangeLog b/ChangeLog --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,32 @@ +0.18.1 + - Numerous improvements to Enum handling [#78] (Philipp Balzarek: + @Philonous) + - Handle Haddock comments within C2HS hook definitions [#62] (@tangboyun) + - Better error messages for missing files (Zejun Wu: @watashi) + - Write CHS dump files to output directory (Zejun Wu: @watashi) + - Handle C calling conventions within function pointer declarations [#88] + (Michael Steele: @mikesteele81) + - Fix FreeBSD libssh2 problem [#87] (Cindy Wang: @CindyLinz) + - Better error messages for hook syntax errors (Ryan Scott: @RyanGIScott) + - Fixes for GHC 7.9 [#100] (@int-index) + - Fix test suite to use C2HS from dist directory [#81] + - Allow free intermixing of command line options and input files [#86] + - Treat CLang "block" syntax and other "non-GNU" issues differently: + always undefine __BLOCKS__ CPP symbol to avoid problems with blocks; + add nonGNU directive to trigger undefine of GNU-specific pre-processor + symbols [#77] + - Handle indented CPP directives correctly [#80] + - Handle #sizeof and #alignof on non-typedef's structures [#95] + - Fix #get and #set hooks to access newtyped pointers [#96] + - Fix round-trip problem for interface files caused by changes in + language-c [#87] + - Treat "with" specially so that it can appear both as a marshaller + identifier in an input parameter definition and as a keyword in enum + definitions [#93] + - Temporarily disable CUDA regression suite examples (CUDA install + problems on Travis) + + 0.17.2 - Fix more regressions from 0.16.6 (affected packages included gnome-keyring, hsndfile and cuda) diff --git a/c2hs.cabal b/c2hs.cabal --- a/c2hs.cabal +++ b/c2hs.cabal @@ -1,5 +1,5 @@ Name: c2hs -Version: 0.17.2 +Version: 0.18.1 License: GPL-2 License-File: COPYING Copyright: Copyright (c) 1999-2007 Manuel M T Chakravarty @@ -68,8 +68,9 @@ Executable c2hs Build-Depends: base >= 2 && < 5, - language-c >= 0.4.2 && < 0.5, - filepath + language-c >= 0.4.5 && < 0.5, + filepath, + dlist if flag(base3) Build-Depends: base >= 3, process, directory, array, containers, pretty @@ -99,7 +100,6 @@ Control.State Control.StateTrans Data.Attributes - Data.DLists Data.Errors Data.NameSpaces System.CIO @@ -121,7 +121,8 @@ test-framework-hunit, HUnit, shelly >= 1.0, - text + text, + transformers Test-Suite test-system type: exitcode-stdio-1.0 @@ -133,10 +134,10 @@ test-framework-hunit, HUnit, shelly >= 1.0, - text + text, + transformers -Test-Suite regression-suite - type: exitcode-stdio-1.0 +Executable regression-suite build-depends: base, filepath, shelly >= 1.0, diff --git a/src/C2HS/C/Trav.hs b/src/C2HS/C/Trav.hs --- a/src/C2HS/C/Trav.hs +++ b/src/C2HS/C/Trav.hs @@ -73,7 +73,8 @@ declaredDeclr, declaredName, structMembers, expandDecl, structName, enumName, tagName, isPtrDeclr, dropPtrDeclr, isPtrDecl, isFunDeclr, structFromDecl, funResultAndArgs, - chaseDecl, findAndChaseDecl, checkForAlias, checkForOneCUName, + chaseDecl, findAndChaseDecl, findAndChaseDeclOrTag, + checkForAlias, checkForOneCUName, checkForOneAliasName, lookupEnum, lookupStructUnion, lookupDeclOrTag) where @@ -160,7 +161,7 @@ ctExc :: String ctExc = "ctExc" --- | throw an exception +-- | throw an exception -- throwCTExc :: CT s a throwCTExc = throwExc ctExc "Error during traversal of a C structure tree" @@ -316,7 +317,7 @@ -- | set the definition of an identifier -- refersToDef :: Ident -> CDef -> CT s () -refersToDef ide def = +refersToDef ide def = do traceCTrav $ "linking identifier: "++ dumpIdent ide ++ " --> " ++ show def transAttrCCT $ \akl -> (setDefOfIdentC akl ide def, ()) @@ -538,12 +539,12 @@ -- into an anonymous declarator and also change its attributes -- dropPtrDeclr :: CDeclr -> CDeclr -dropPtrDeclr (CDeclr ide (outermost:derived) asm ats node) = +dropPtrDeclr (CDeclr ide (outermost:derived) asm ats node) = case outermost of (CPtrDeclr _ _) -> CDeclr ide derived asm ats node (CArrDeclr _ _ _) -> CDeclr ide derived asm ats node _ -> interr "CTrav.dropPtrDeclr: No pointer!" - + -- | checks whether the given declaration defines a pointer object -- -- * there may only be a single declarator in the declaration @@ -590,7 +591,7 @@ where funArgs (CDeclr _ide derived _asm _ats node) = case derived of - (CFunDeclr (Right (args,variadic)) _ats' _dnode : derived') -> + (CFunDeclr (Right (args,variadic)) _ats' _dnode : derived') -> (args, CDeclr Nothing derived' Nothing [] node, variadic) (CFunDeclr (Left _) _ _ : _) -> interr "CTrav.funResultAndArgs: Old style function definition" @@ -639,12 +640,34 @@ findAndChaseDecl :: Ident -> Bool -> Bool -> CT s CDecl findAndChaseDecl ide ind useShadows = do - traceCTrav $ "findAndChaseDecl: " ++ show ide ++ "\n" + traceCTrav $ "findAndChaseDecl: " ++ show ide ++ " (" ++ + show useShadows ++ ")\n" (obj, ide') <- findTypeObj ide useShadows -- is there an object def? ide `refersToNewDef` ObjCD obj ide' `refersToNewDef` ObjCD obj -- assoc needed for chasing chaseDecl ide' ind +findAndChaseDeclOrTag :: Ident -> Bool -> Bool -> CT s CDecl +findAndChaseDeclOrTag ide ind useShadows = + do + traceCTrav $ "findAndChaseDeclOrTag: " ++ show ide ++ " (" ++ + show useShadows ++ ")\n" + mobjide <- findTypeObjMaybe ide useShadows -- is there an object def? + case mobjide of + Just (obj, ide') -> do + ide `refersToNewDef` ObjCD obj + ide' `refersToNewDef` ObjCD obj -- assoc needed for chasing + chaseDecl ide' ind + Nothing -> do + otag <- if useShadows + then findTagShadow ide + else liftM (fmap (\tag -> (tag, ide))) $ findTag ide + case otag of + Just (StructUnionCT su, _) -> do + let (CStruct _ _ _ _ nodeinfo) = su + return $ CDecl [CTypeSpec (CSUType su nodeinfo)] [] nodeinfo + _ -> unknownObjErr ide + -- | given a declaration (which must have exactly one declarator), if the -- declarator is an alias, chase it to the actual declaration -- @@ -664,7 +687,7 @@ checkForOneCUName :: CDecl -> Maybe Ident checkForOneCUName decl@(CDecl specs _ _) = case [ts | CTypeSpec ts <- specs] of - [CSUType (CStruct _ n _ _ _) _] -> + [CSUType (CStruct _ n _ _ _) _] -> case declaredDeclr decl of Nothing -> n Just (CDeclr _ [] _ _ _) -> n -- no type derivations @@ -826,7 +849,7 @@ _ -> return su where err ide bad_obj = - do interr $ "CTrav.extractStruct: Illegal reference! Expected " ++ dumpIdent ide ++ + do interr $ "CTrav.extractStruct: Illegal reference! Expected " ++ dumpIdent ide ++ " to link to TagCD but refers to "++ (show bad_obj) ++ "\n" extractStruct' :: Position -> CTag -> CT s (Maybe CStructUnion) diff --git a/src/C2HS/CHS.hs b/src/C2HS/CHS.hs --- a/src/C2HS/CHS.hs +++ b/src/C2HS/CHS.hs @@ -95,7 +95,7 @@ CHSChangeCase(..), CHSParm(..), CHSMarsh, CHSArg(..), CHSAccess(..), CHSAPath(..), CHSPtrType(..), loadCHS, dumpCHS, hssuffix, chssuffix, loadCHI, dumpCHI, chisuffix, - showCHSParm, apathToIdent) + showCHSParm, apathToIdent, apathRootIdent, hasNonGNU) where -- standard libraries @@ -165,6 +165,12 @@ [CHSFrag])] -- then/elif branches (Maybe [CHSFrag]) -- else branch +hasNonGNU :: CHSModule -> Bool +hasNonGNU (CHSModule frags) = any isNonGNU frags + where isNonGNU (CHSHook (CHSNonGNU _) _) = True + isNonGNU _ = False + + instance Pos CHSFrag where posOf (CHSVerb _ pos ) = pos posOf (CHSHook _ pos ) = pos @@ -185,6 +191,7 @@ (Maybe String) -- prefix (Maybe String) -- replacement prefix Position + | CHSNonGNU Position | CHSType Ident -- C type Position | CHSSizeof Ident -- C type @@ -304,6 +311,7 @@ Bool -- C repr: two values? CHSMarsh -- "out" marshaller Position + String -- Comment for this para -- | kinds of arguments in function hooks -- @@ -609,13 +617,15 @@ Just ide -> showString " as " . showCHSIdent ide) showCHSParm :: CHSParm -> ShowS -showCHSParm (CHSParm oimMarsh hsTyStr twoCVals oomMarsh _) = +showCHSParm (CHSParm oimMarsh hsTyStr twoCVals oomMarsh _ comment) = showOMarsh oimMarsh . showChar ' ' . showHsVerb hsTyStr . (if twoCVals then showChar '&' else id) . showChar ' ' . showOMarsh oomMarsh + . showChar ' ' + . showComment comment where showOMarsh Nothing = id showOMarsh (Just (body, argKind)) = showMarshBody body @@ -629,6 +639,9 @@ showMarshBody (Right str) = showChar '|' . showString str . showChar '|' -- showHsVerb str = showChar '`' . showString str . showChar '\'' + showComment str = if null str + then showString "" + else showString "-- " . showString str . showChar '\n' showCHSTrans :: CHSTrans -> ShowS showCHSTrans (CHSTrans _2Case chgCase assocs) = @@ -822,31 +835,48 @@ return $ CHSLine pos : frags parseFrags0 (CHSTokC pos s:toks) = parseC pos s toks parseFrags0 (CHSTokHook hkpos: - CHSTokImport pos :toks) = parseImport hkpos pos toks + CHSTokImport pos :toks) = parseImport hkpos pos + (removeCommentInHook toks) parseFrags0 (CHSTokHook hkpos: - CHSTokContext pos :toks) = parseContext hkpos pos toks + CHSTokContext pos :toks) = parseContext hkpos pos + (removeCommentInHook toks) parseFrags0 (CHSTokHook hkpos: - CHSTokType pos :toks) = parseType hkpos pos toks + CHSTokNonGNU pos :toks) = parseNonGNU hkpos pos + (removeCommentInHook toks) parseFrags0 (CHSTokHook hkpos: - CHSTokSizeof pos :toks) = parseSizeof hkpos pos toks + CHSTokType pos :toks) = parseType hkpos pos + (removeCommentInHook toks) parseFrags0 (CHSTokHook hkpos: - CHSTokAlignof pos :toks) = parseAlignof hkpos pos toks + CHSTokSizeof pos :toks) = parseSizeof hkpos pos + (removeCommentInHook toks) parseFrags0 (CHSTokHook hkpos: - CHSTokEnum pos :toks) = parseEnum hkpos pos toks + CHSTokAlignof pos :toks) = parseAlignof hkpos pos + (removeCommentInHook toks) + -- TODO: issue 70, add haddock support for enum hook parseFrags0 (CHSTokHook hkpos: - CHSTokCall pos :toks) = parseCall hkpos pos toks + CHSTokEnum pos :toks) = parseEnum hkpos pos + (removeCommentInHook toks) parseFrags0 (CHSTokHook hkpos: - CHSTokFun pos :toks) = parseFun hkpos pos toks + CHSTokCall pos :toks) = parseCall hkpos pos + (removeCommentInHook toks) parseFrags0 (CHSTokHook hkpos: - CHSTokGet pos :toks) = parseField hkpos pos CHSGet toks + CHSTokFun pos :toks) = parseFun hkpos pos toks parseFrags0 (CHSTokHook hkpos: - CHSTokSet pos :toks) = parseField hkpos pos CHSSet toks + CHSTokGet pos :toks) = parseField hkpos pos CHSGet + (removeCommentInHook toks) parseFrags0 (CHSTokHook hkpos: - CHSTokOffsetof pos :toks) = parseOffsetof hkpos pos toks + CHSTokSet pos :toks) = parseField hkpos pos CHSSet + (removeCommentInHook toks) parseFrags0 (CHSTokHook hkpos: - CHSTokClass pos :toks) = parseClass hkpos pos toks + CHSTokOffsetof pos :toks) = parseOffsetof hkpos pos + (removeCommentInHook toks) parseFrags0 (CHSTokHook hkpos: - CHSTokPointer pos :toks) = parsePointer hkpos pos toks + CHSTokClass pos :toks) = parseClass hkpos pos + (removeCommentInHook toks) + parseFrags0 (CHSTokHook hkpos: + CHSTokPointer pos :toks) = parsePointer hkpos pos + (removeCommentInHook toks) + parseFrags0 (CHSTokHook _ :toks) = syntaxError toks parseFrags0 toks = syntaxError toks -- -- skip to next Haskell or control token @@ -855,6 +885,15 @@ contFrags toks@(CHSTokHaskell _ _:_ ) = parseFrags toks contFrags toks@(CHSTokCtrl _ _:_ ) = parseFrags toks contFrags (_ :toks) = contFrags toks + -- + -- Only keep comment in fun hook + -- + isComment (CHSTokComment _ _) = True + isComment _ = False + isEndHook (CHSTokEndHook _) = True + isEndHook _ = False + removeCommentInHook xs = let (lhs,rhs) = span (not . isEndHook) xs + in filter (not . isComment) lhs ++ rhs parseC :: Position -> String -> [CHSToken] -> CST s [CHSFrag] parseC pos s toks = @@ -912,6 +951,13 @@ let frag = CHSContext olib opref oreppref pos return $ CHSHook frag hkpos : frags +parseNonGNU :: Position -> Position -> [CHSToken] -> CST s [CHSFrag] +parseNonGNU hkpos pos toks = do + toks2 <- parseEndHook toks + frags <- parseFrags toks2 + let frag = CHSNonGNU pos + return $ CHSHook frag hkpos : frags + parseType :: Position -> Position -> [CHSToken] -> CST s [CHSFrag] parseType hkpos pos (CHSTokIdent _ ide:toks) = do @@ -979,7 +1025,7 @@ CHSHook (CHSCall isPure isUnsafe apath oalias pos) hkpos : frags parseFun :: Position -> Position -> [CHSToken] -> CST s [CHSFrag] -parseFun hkpos pos toks = +parseFun hkpos pos inputToks = do (isPure , toks' ) <- parseIsPure toks (isUnsafe, toks'2) <- parseIsUnsafe toks' @@ -995,6 +1041,7 @@ (CHSFun isPure isUnsafe apath oalias octxt parms parm pos) hkpos : frags where + toks = removeIllPositionedComment inputToks parseOptContext (CHSTokHSVerb _ ctxt:CHSTokDArrow _:toks') = return (Just ctxt, toks') parseOptContext toks' = @@ -1008,6 +1055,10 @@ syntaxError toks' -- parseParms' (CHSTokRBrace _:CHSTokArrow _:toks') = return ([], toks') + parseParms' (CHSTokComma _:CHSTokComment _ _:toks') = do + (parm , toks'2 ) <- parseParm toks' + (parms, toks'3) <- parseParms' toks'2 + return (parm:parms, toks'3) parseParms' (CHSTokComma _ :toks') = do (parm , toks'2 ) <- parseParm toks' (parms, toks'3) <- parseParms' toks'2 @@ -1015,7 +1066,25 @@ parseParms' (CHSTokRBrace _ :toks') = syntaxError toks' -- gives better error messages parseParms' toks' = syntaxError toks' + -- + isComment (CHSTokComment _ _) = True + isComment _ = False + isLBrace (CHSTokLBrace _) = True + isLBrace _ = False + isRBrace (CHSTokRBrace _) = True + isRBrace _ = False + isHSVerb (CHSTokHSVerb _ _) = True + isHSVerb _ = False + -- remove comment(s) between + -- 1. {# and { + -- 2. } and `ResultType' + removeIllPositionedComment xs = let (lhs,rhs) = span (not . isLBrace) xs + (lhs',rhs') = span (not . isRBrace) rhs + (lhs'2,rhs'2) = span (not . isHSVerb) rhs' + in filter (not . isComment) lhs ++ lhs' ++ + (filter (not . isComment) lhs'2) ++ rhs'2 + parseIsPure :: [CHSToken] -> CST s (Bool, [CHSToken]) parseIsPure (CHSTokPure _:toks) = return (True , toks) parseIsPure (CHSTokFun _:toks) = return (True , toks) -- backwards compat. @@ -1039,6 +1108,11 @@ sel = upperFirst $ identToString ide' in internalIdentAt (posOf ide) (identToString ide ++ sel) +apathRootIdent :: CHSAPath -> Ident +apathRootIdent (CHSRoot _ ide) = ide +apathRootIdent (CHSDeref apath _) = apathRootIdent apath +apathRootIdent (CHSRef apath _) = apathRootIdent apath + parseParm :: [CHSToken] -> CST s (CHSParm, [CHSToken]) parseParm toks = do @@ -1051,7 +1125,9 @@ return (hsTyStr, False, pos, toks'2) _toks -> syntaxError toks' (oomMarsh, toks'3) <- parseOptMarsh toks'2 - return (CHSParm oimMarsh hsTyStr twoCVals oomMarsh pos, toks'3) + (comments, toks'4) <- parseOptComments toks'3 + return (CHSParm oimMarsh hsTyStr twoCVals oomMarsh pos + (concat (intersperse " " comments)), toks'4) where parseOptMarsh :: [CHSToken] -> CST s (CHSMarsh, [CHSToken]) parseOptMarsh (CHSTokIdent _ ide:toks') = @@ -1062,6 +1138,10 @@ do (marshType, toks'2) <- parseOptMarshType toks' return (Just (Right str, marshType), toks'2) + parseOptMarsh (CHSTokWith _ ide:toks') = + do + (marshType, toks'2) <- parseOptMarshType toks' + return (Just (Left ide, marshType), toks'2) parseOptMarsh toks' = return (Nothing, toks') @@ -1074,6 +1154,12 @@ parseOptMarshType toks' = return (CHSValArg, toks') +parseOptComments :: [CHSToken] -> CST s ([String], [CHSToken]) +parseOptComments = go [] + where + go acc (CHSTokComment _ s:toks) = go (s:acc) toks + go acc _toks = return (reverse acc,_toks) + parseField :: Position -> Position -> CHSAccess -> [CHSToken] -> CST s [CHSFrag] parseField hkpos pos access toks = do @@ -1161,12 +1247,12 @@ CHSTokEqual _ : CHSTokString _ str: toks) = return (Just str, toks) -parseOptPrefix True (CHSTokWith _ : +parseOptPrefix True (CHSTokWith _ _ : CHSTokPrefix _ : CHSTokEqual _ : CHSTokString _ str: toks) = return (Just str, toks) -parseOptPrefix _ (CHSTokWith _:toks) = syntaxError toks +parseOptPrefix _ (CHSTokWith _ _:toks) = syntaxError toks parseOptPrefix _ (CHSTokPrefix _:toks) = syntaxError toks parseOptPrefix _ toks = return (Nothing, toks) diff --git a/src/C2HS/CHS/Lexer.hs b/src/C2HS/CHS/Lexer.hs --- a/src/C2HS/CHS/Lexer.hs +++ b/src/C2HS/CHS/Lexer.hs @@ -211,6 +211,7 @@ | CHSTokCall Position -- `call' | CHSTokClass Position -- `class' | CHSTokContext Position -- `context' + | CHSTokNonGNU Position -- `nonGNU' | CHSTokDerive Position -- `deriving' | CHSTokDown Position -- `downcaseFirstLetter' | CHSTokEnum Position -- `enum' @@ -235,7 +236,7 @@ | CHSTok_2Case Position -- `underscoreToCase' | CHSTokUnsafe Position -- `unsafe' | CHSTokUpper Position -- `upcaseFirstLetter' - | CHSTokWith Position -- `with' + | CHSTokWith Position Ident -- `with' | CHSTokString Position String -- string | CHSTokHSVerb Position String -- verbatim Haskell (`...') | CHSTokHSQuot Position String -- quoted Haskell ('...') @@ -245,6 +246,7 @@ | CHSTokLine Position -- line pragma | CHSTokC Position String -- verbatim C code | CHSTokCtrl Position Char -- control code + | CHSTokComment Position String -- comment instance Pos CHSToken where posOf (CHSTokArrow pos ) = pos @@ -260,12 +262,14 @@ posOf (CHSTokRBrace pos ) = pos posOf (CHSTokLParen pos ) = pos posOf (CHSTokRParen pos ) = pos + posOf (CHSTokHook pos ) = pos posOf (CHSTokEndHook pos ) = pos posOf (CHSTokAdd pos ) = pos posOf (CHSTokAs pos ) = pos posOf (CHSTokCall pos ) = pos posOf (CHSTokClass pos ) = pos posOf (CHSTokContext pos ) = pos + posOf (CHSTokNonGNU pos ) = pos posOf (CHSTokDerive pos ) = pos posOf (CHSTokDown pos ) = pos posOf (CHSTokEnum pos ) = pos @@ -290,7 +294,7 @@ posOf (CHSTok_2Case pos ) = pos posOf (CHSTokUnsafe pos ) = pos posOf (CHSTokUpper pos ) = pos - posOf (CHSTokWith pos ) = pos + posOf (CHSTokWith pos _) = pos posOf (CHSTokString pos _) = pos posOf (CHSTokHSVerb pos _) = pos posOf (CHSTokHSQuot pos _) = pos @@ -300,6 +304,7 @@ posOf (CHSTokLine pos ) = pos posOf (CHSTokC pos _) = pos posOf (CHSTokCtrl pos _) = pos + posOf (CHSTokComment pos _) = pos instance Eq CHSToken where (CHSTokArrow _ ) == (CHSTokArrow _ ) = True @@ -315,12 +320,14 @@ (CHSTokRBrace _ ) == (CHSTokRBrace _ ) = True (CHSTokLParen _ ) == (CHSTokLParen _ ) = True (CHSTokRParen _ ) == (CHSTokRParen _ ) = True + (CHSTokHook _ ) == (CHSTokHook _ ) = True (CHSTokEndHook _ ) == (CHSTokEndHook _ ) = True (CHSTokAdd _ ) == (CHSTokAdd _ ) = True (CHSTokAs _ ) == (CHSTokAs _ ) = True (CHSTokCall _ ) == (CHSTokCall _ ) = True (CHSTokClass _ ) == (CHSTokClass _ ) = True (CHSTokContext _ ) == (CHSTokContext _ ) = True + (CHSTokNonGNU _ ) == (CHSTokNonGNU _ ) = True (CHSTokDerive _ ) == (CHSTokDerive _ ) = True (CHSTokDown _ ) == (CHSTokDown _ ) = True (CHSTokEnum _ ) == (CHSTokEnum _ ) = True @@ -345,7 +352,7 @@ (CHSTok_2Case _ ) == (CHSTok_2Case _ ) = True (CHSTokUnsafe _ ) == (CHSTokUnsafe _ ) = True (CHSTokUpper _ ) == (CHSTokUpper _ ) = True - (CHSTokWith _ ) == (CHSTokWith _ ) = True + (CHSTokWith _ _) == (CHSTokWith _ _) = True (CHSTokString _ _) == (CHSTokString _ _) = True (CHSTokHSVerb _ _) == (CHSTokHSVerb _ _) = True (CHSTokHSQuot _ _) == (CHSTokHSQuot _ _) = True @@ -355,6 +362,7 @@ (CHSTokLine _ ) == (CHSTokLine _ ) = True (CHSTokC _ _) == (CHSTokC _ _) = True (CHSTokCtrl _ _) == (CHSTokCtrl _ _) = True + (CHSTokComment _ _) == (CHSTokComment _ _) = True _ == _ = False instance Show CHSToken where @@ -371,12 +379,14 @@ showsPrec _ (CHSTokRBrace _ ) = showString "}" showsPrec _ (CHSTokLParen _ ) = showString "(" showsPrec _ (CHSTokRParen _ ) = showString ")" + showsPrec _ (CHSTokHook _ ) = showString "{#" showsPrec _ (CHSTokEndHook _ ) = showString "#}" showsPrec _ (CHSTokAdd _ ) = showString "add" showsPrec _ (CHSTokAs _ ) = showString "as" showsPrec _ (CHSTokCall _ ) = showString "call" showsPrec _ (CHSTokClass _ ) = showString "class" showsPrec _ (CHSTokContext _ ) = showString "context" + showsPrec _ (CHSTokNonGNU _ ) = showString "nonGNU" showsPrec _ (CHSTokDerive _ ) = showString "deriving" showsPrec _ (CHSTokDown _ ) = showString "downcaseFirstLetter" showsPrec _ (CHSTokEnum _ ) = showString "enum" @@ -401,7 +411,7 @@ showsPrec _ (CHSTok_2Case _ ) = showString "underscoreToCase" showsPrec _ (CHSTokUnsafe _ ) = showString "unsafe" showsPrec _ (CHSTokUpper _ ) = showString "upcaseFirstLetter" - showsPrec _ (CHSTokWith _ ) = showString "with" + showsPrec _ (CHSTokWith _ _) = showString "with" showsPrec _ (CHSTokString _ s) = showString ("\"" ++ s ++ "\"") showsPrec _ (CHSTokHSVerb _ s) = showString ("`" ++ s ++ "'") showsPrec _ (CHSTokHSQuot _ s) = showString ("'" ++ s ++ "'") @@ -411,7 +421,9 @@ showsPrec _ (CHSTokLine _ ) = id --TODO show line num? showsPrec _ (CHSTokC _ s) = showString s showsPrec _ (CHSTokCtrl _ c) = showChar c - + showsPrec _ (CHSTokComment _ s) = showString (if null s + then "" + else " -- " ++ s ++ "\n") -- lexer state -- ----------- @@ -621,11 +633,13 @@ cpp = directive where directive = - (string "\n#" >|< string "\0#") +> + --(string "\n#" >|< string "\0#") +> + alt "\n\0" +> alt " \t" `star` string "#" +> alt ('\t':inlineSet)`star` epsilon `lexmeta` - \t@(ld:_:dir) pos s -> -- strip off the "\n#" or "\0#" - case dir of + \t@(ld:spdir) pos s -> -- strip off the "\n" or "\0" + let dir = drop 1 $ dropWhile (`elem` " \t") spdir + in case dir of ['c'] -> -- #c (Nothing, incPos pos (length t), s, Just cLexer) -- a #c may be followed by whitespace @@ -666,7 +680,7 @@ >||< whitespace >||< endOfHook >||< string "--" +> anyButNL`star` char '\n' -- comment - `lexmeta` \_ pos s -> (Nothing, retPos pos, s, Nothing) + `lexaction` \cs pos -> Just (CHSTokComment pos (init (drop 2 cs))) where anyButNL = alt (anySet \\ ['\n']) endOfHook = string "#}" @@ -714,6 +728,7 @@ idkwtok pos "call" _ = CHSTokCall pos idkwtok pos "class" _ = CHSTokClass pos idkwtok pos "context" _ = CHSTokContext pos + idkwtok pos "nonGNU" _ = CHSTokNonGNU pos idkwtok pos "deriving" _ = CHSTokDerive pos idkwtok pos "downcaseFirstLetter" _ = CHSTokDown pos idkwtok pos "enum" _ = CHSTokEnum pos @@ -738,10 +753,11 @@ idkwtok pos "underscoreToCase" _ = CHSTok_2Case pos idkwtok pos "unsafe" _ = CHSTokUnsafe pos idkwtok pos "upcaseFirstLetter"_ = CHSTokUpper pos - idkwtok pos "with" _ = CHSTokWith pos + idkwtok pos "with" name = mkwith pos name idkwtok pos cs name = mkid pos cs name -- mkid pos cs name = CHSTokIdent pos (mkIdent pos cs name) + mkwith pos name = CHSTokWith pos (mkIdent pos "with" name) keywordToIdent :: CHSToken -> CHSToken keywordToIdent tok = @@ -751,6 +767,7 @@ CHSTokCall pos -> mkid pos "call" CHSTokClass pos -> mkid pos "class" CHSTokContext pos -> mkid pos "context" + CHSTokNonGNU pos -> mkid pos "nonGNU" CHSTokDerive pos -> mkid pos "deriving" CHSTokDown pos -> mkid pos "downcaseFirstLetter" CHSTokEnum pos -> mkid pos "enum" @@ -775,7 +792,7 @@ CHSTok_2Case pos -> mkid pos "underscoreToCase" CHSTokUnsafe pos -> mkid pos "unsafe" CHSTokUpper pos -> mkid pos "upcaseFirstLetter" - CHSTokWith pos -> mkid pos "with" + CHSTokWith pos ide -> CHSTokIdent pos ide _ -> tok where mkid pos str = CHSTokIdent pos (internalIdent str) diff --git a/src/C2HS/Gen/Bind.hs b/src/C2HS/Gen/Bind.hs --- a/src/C2HS/Gen/Bind.hs +++ b/src/C2HS/Gen/Bind.hs @@ -109,11 +109,13 @@ -- standard libraries import Data.Char (toLower) import Data.Function (on) -import Data.List (deleteBy, groupBy, sortBy, intersperse, find) +import Data.List (deleteBy, groupBy, sortBy, intersperse, find, nubBy, intercalate) import Data.Map (lookup) import Data.Maybe (isNothing, isJust, fromJust, fromMaybe) import Data.Bits ((.|.), (.&.)) +import Control.Arrow (second) import Control.Monad (when, unless, liftM, mapAndUnzipM) +import Data.Ord (comparing) -- Language.C / compiler toolkit import Language.C.Data.Position @@ -121,7 +123,6 @@ import Language.C.Pretty import Text.PrettyPrint.HughesPJ (render) import Data.Errors -import Data.Attributes (newAttrsOnlyPos) -- C->Haskell import C2HS.Config (PlatformSpec(..)) @@ -132,7 +133,7 @@ -- friends import C2HS.CHS (CHSModule(..), CHSFrag(..), CHSHook(..), CHSParm(..), CHSMarsh, CHSArg(..), CHSAccess(..), CHSAPath(..), - CHSPtrType(..), showCHSParm, apathToIdent) + CHSPtrType(..), showCHSParm, apathToIdent, apathRootIdent) import C2HS.C.Info (CPrimType(..), alignment, getPlatform) import qualified C2HS.C.Info as CInfo import C2HS.Gen.Monad (TransFun, transTabToTransFun, HsObject(..), GB, @@ -411,6 +412,7 @@ when (isJust oprefix) $ applyPrefixToNameSpaces (fromJust oprefix) (maybe "" id orepprefix) return "" +expandHook (CHSNonGNU _) _ = return "" expandHook (CHSType ide pos) _ = do traceInfoType @@ -427,7 +429,7 @@ expandHook (CHSAlignof ide _) _ = do traceInfoAlignof - decl <- findAndChaseDecl ide False True -- no indirection, but shadows + decl <- findAndChaseDeclOrTag ide False True -- no indirection, but shadows (_, align) <- sizeAlignOf decl traceInfoDump (render $ pretty decl) align return $ show align @@ -440,7 +442,7 @@ expandHook (CHSSizeof ide _) _ = do traceInfoSizeof - decl <- findAndChaseDecl ide False True -- no indirection, but shadows + decl <- findAndChaseDeclOrTag ide False True -- no indirection, but shadows (size, _) <- sizeAlignOf decl traceInfoDump (render $ pretty decl) size return $ show (padBits size) @@ -498,7 +500,7 @@ _ -> funPtrExpectedErr pos traceValueType ty - set_get <- setGet pos CHSGet offsets ptrTy + set_get <- setGet pos CHSGet offsets 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 @@ -510,7 +512,7 @@ -- cdecl' = ide `simplifyDecl` cdecl args = concat [ " x" ++ show n | n <- [1..numArgs ty] ] - callImportDyn hook isPure isUns ideLexeme hsLexeme ty pos + callImportDyn hook isPure isUns ideLexeme hsLexeme decl ty pos return $ "(\\o" ++ args ++ " -> " ++ set_get ++ " o >>= \\f -> " ++ hsLexeme ++ " f" ++ args ++ ")" where @@ -565,9 +567,9 @@ -- 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 + callImportDyn callHook isPure isUns ideLexeme fiLexeme decl ty pos - set_get <- setGet pos CHSGet offsets ptrTy + set_get <- setGet pos CHSGet offsets ptrTy Nothing funDef isPure hsLexeme fiLexeme (FunET ptrTy $ purify ty) ctxt parms parm (Just set_get) pos hkpos where @@ -585,11 +587,13 @@ do traceInfoField traceGenBind $ "path = " ++ show path ++ "\n" + onewtype <- apathNewtypeName path + traceGenBind $ "onewtype = " ++ show onewtype ++ "\n" (decl, offsets) <- accessPath path traceDepth offsets ty <- extractSimpleType False pos decl traceValueType ty - setGet pos access offsets ty + setGet pos access offsets ty onewtype where accessString = case access of CHSGet -> "Get" @@ -712,6 +716,19 @@ -- traceInfoClass = traceGenBind $ "** Class hook:\n" +apathNewtypeName :: CHSAPath -> GB (Maybe Ident) +apathNewtypeName path = do + let ide = apathRootIdent path + pm <- readCT ptrmap + case (True, ide) `lookup` pm of + Nothing -> return Nothing + Just (hsty, _) -> do + om <- readCT objmap + let hside = internalIdent hsty + case hside `lookup` om of + Just (Pointer _ True) -> return (Just hside) + _ -> return Nothing + -- | produce code for an enumeration -- -- * an extra instance declaration is required when any of the enumeration @@ -725,50 +742,36 @@ enumDef (CEnum _ (Just list) _ _) hident trans userDerive _ = do (list', enumAuto) <- evalTagVals list - let enumVals = [(trans ide, cexpr) | (ide, cexpr) <- list'] - toEnumVals = [(trans ide, cexpr) | - (ide, cexpr) <- stripEnumAliases list'] + let enumVals = fixTags [(trans ide, cexpr) | (ide, cexpr) <- list'] defHead = enumHead hident defBody = enumBody (length defHead - 2) enumVals inst = makeDerives (if enumAuto then "Enum" : userDerive else userDerive) ++ + "\n" ++ if enumAuto - then "\n" - else "\n" ++ enumInst hident enumVals toEnumVals + then "" + else enumInst hident enumVals isEnum hident return $ defHead ++ defBody ++ inst where - evalTagVals [] = return ([], True) - evalTagVals ((ide, Nothing ):list') = - do - (list'', derived) <- evalTagVals list' - return ((ide, Nothing):list'', derived) - evalTagVals ((ide, Just exp):list') = - do - (list'', _derived) <- evalTagVals list' + evalTagVals = liftM (second and . unzip) . mapM (uncurry evalTag) + evalTag ide Nothing = return ((ide, Nothing), True) + evalTag ide (Just exp) = do val <- evalConstCExpr exp case val of - IntResult val' -> - return ((ide, Just $ CConst (CIntConst (cInteger val') at1)):list'', - False) - FloatResult _ -> - illegalConstExprErr (posOf exp) "a float result" - where - at1 = newAttrsOnlyPos nopos + IntResult v -> return ((ide, Just v), False) + FloatResult _ -> illegalConstExprErr (posOf exp) "a float result" makeDerives [] = "" - makeDerives dList = "deriving (" ++ concat (intersperse "," dList) ++")" - stripEnumAliases :: [(Ident, Maybe CExpr)] -> [(Ident, Maybe CExpr)] - stripEnumAliases vs = - let okids = map (fst . head) . - groupBy ((==) `on` snd) . - sortBy (compare `on` snd) . - extractEnumVals $ vs - in filter ((`elem` okids) . fst) vs - extractEnumVals :: [(Ident, Maybe CExpr)] -> [(Ident, CInteger)] - extractEnumVals = go 0 - where go _ [] = [] - go k ((i, Nothing):vs') = (i,k) : go (k+1) vs' - go _ ((i, Just (CConst (CIntConst j _))):vs') = (i,j) : go (j+1) vs' + makeDerives dList = "\n deriving (" ++ intercalate "," dList ++ ")" + -- Fix implicit tag values + fixTags = go 0 + where + go _ [] = [] + go n ((ide, exp):rest) = + let val = case exp of + Nothing -> n + Just m -> m + in (ide, val) : go (val+1) rest -- | Haskell code for the head of an enumeration definition -- @@ -777,15 +780,14 @@ -- | Haskell code for the body of an enumeration definition -- -enumBody :: Int -> [(String, Maybe CExpr)] -> String -enumBody _ [] = "" -enumBody indent ((ide, _):list) = - ide ++ "\n" ++ replicate indent ' ' - ++ (if null list then "" else "| " ++ enumBody indent list) - +enumBody :: Int -> [(String, Integer)] -> String +enumBody indent ides = constrs + where + constrs = intercalate separator . map fst $ sortBy (comparing snd) ides + separator = "\n" ++ replicate indent ' ' ++ "| " -- | Num instance for C Integers --- We should preserve type flags and repr if possible +-- We should preserve type flags and repr if possible instance Num CInteger where fromInteger = cInteger (+) a b = cInteger (getCInteger a + getCInteger b) @@ -801,40 +803,72 @@ -- following tags are assigned values continuing from the explicitly -- specified one -- -enumInst :: String -> [(String, Maybe CExpr)] -> [(String, Maybe CExpr)] - -> String -enumInst ident list tolist = - "instance Enum " ++ ident ++ " where\n" - ++ fromDef list 0 ++ "\n" ++ toDef tolist 0 +enumInst :: String -> [(String, Integer)] -> String +enumInst ident list' = intercalate "\n" + [ "instance Enum " ++ ident ++ " where" + , succDef + , predDef + , enumFromToDef + , enumFromDef + , fromDef + , toDef + ] where - fromDef [] _ = "" - fromDef ((ide, exp):list') n = - " fromEnum " ++ ide ++ " = " ++ show' (getCInteger val) ++ "\n" - ++ fromDef list' (val + 1) - where - val = case exp of - Nothing -> n - Just (CConst (CIntConst m _)) -> m - Just _ -> - interr "GenBind.enumInst: Integer constant expected!" - -- - show' x = if x < 0 then "(" ++ show x ++ ")" else show x - -- - toDef [] _ = - " toEnum unmatched = error (\"" ++ ident - ++ ".toEnum: Cannot match \" ++ show unmatched)\n" - toDef ((ide, exp):list') n = - " toEnum " ++ show' val ++ " = " ++ ide ++ "\n" - ++ toDef list' (val + 1) - where - val = case exp of - Nothing -> n - Just (CConst (CIntConst m _)) -> m - Just _ -> - interr "GenBind.enumInst: Integer constant expected!" - -- - show' x = if x < 0 then "(" ++ show x ++ ")" else show x + concatFor = flip concatMap + -- List of _all values_ (including aliases) and their associated tags + list = sortBy (comparing snd) list' + -- List of values without aliases and their associated tags + toList = stripAliases list + -- Generate explicit tags for all values: + succDef = let idents = map fst toList + aliases = map (map fst) $ groupBy ((==) `on` snd) list + defs = concat $ zipWith + (\is s -> concatFor is $ \i -> " succ " ++ i + ++ " = " ++ s ++ "\n") + aliases + (tail idents) + lasts = concatFor (last aliases) $ \i -> + " succ " ++ i ++ " = error \"" + ++ ident ++ ".succ: " ++ i ++ + " has no successor\"\n" + in defs ++ lasts + predDef = let idents = map fst toList + aliases = map (map fst) $ groupBy ((==) `on` snd) list + defs = concat $ zipWith + (\is s -> concatFor is $ \i -> " pred " ++ i + ++ " = " ++ s ++ "\n") + (tail aliases) + idents + firsts = concatFor (head aliases) $ \i -> + " pred " ++ i ++ " = error \"" + ++ ident ++ ".pred: " ++ i ++ + " has no predecessor\"\n" + in defs ++ firsts + enumFromToDef = intercalate "\n" + [ " enumFromTo from to = go from" + , " where" + , " end = fromEnum to" + , " go v = case compare (fromEnum v) end of" + , " LT -> v : go (succ v)" + , " EQ -> [v]" + , " GT -> []" + , "" + ] + enumFromDef = let lastIdent = fst $ last list + in " enumFrom from = enumFromTo from " ++ lastIdent ++ "\n" + fromDef = concatFor list (\(ide, val) -> " fromEnum " ++ ide ++ " = " + ++ show' val ++ "\n") + + toDef = (concatFor toList (\(ide, val) -> " toEnum " ++ show' val ++ " = " + ++ ide ++ "\n")) + -- Default case: + ++ " toEnum unmatched = error (\"" ++ ident + ++ ".toEnum: Cannot match \" ++ show unmatched)\n" + show' x = if x < 0 then "(" ++ show x ++ ")" else show x + stripAliases :: [(String, Integer)] -> [(String, Integer)] + stripAliases = nubBy ((==) `on` snd) + -- | generate a foreign import declaration that is put into the delayed code -- -- * the C declaration is a simplified declaration of the function that we @@ -857,15 +891,16 @@ traceFunType et = traceGenBind $ "Imported function type: " ++ showExtType et ++ "\n" -callImportDyn :: CHSHook -> Bool -> Bool -> String -> String -> ExtType +callImportDyn :: CHSHook -> Bool -> Bool -> String -> String -> CDecl -> ExtType -> Position -> GB () -callImportDyn hook _isPure isUns ideLexeme hsLexeme ty pos = +callImportDyn hook _isPure 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 pos) -- FIXME? (posOf cdecl)) - delayCode hook (foreignImportDyn ideLexeme hsLexeme isUns ty) + when (isVariadic ty) (variadicErr pos (posOf cdecl)) + delayCode hook (foreignImportDyn (extractCallingConvention cdecl) + ideLexeme hsLexeme isUns ty) traceFunType ty where traceFunType et = traceGenBind $ @@ -885,9 +920,10 @@ -- | 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 " ++ +foreignImportDyn :: CallingConvention -> String -> String -> Bool -> ExtType -> String +foreignImportDyn cconv _ident hsIdent isUnsafe ty = + "foreign import " ++ showCallingConvention cconv ++ " " ++ safety + ++ " \"dynamic\"\n " ++ hsIdent ++ " :: FunPtr( " ++ showExtType ty ++ " ) -> " ++ showExtType ty ++ "\n" where @@ -931,7 +967,7 @@ call = if isPure then " let {res = " ++ fiLexeme ++ joinCallArgs ++ "} in\n" else " " ++ fiLexeme ++ joinCallArgs ++ case parm of - CHSParm _ "()" _ Nothing _ -> " >>\n" + CHSParm _ "()" _ Nothing _ _ -> " >>\n" _ -> " >>= \\res ->\n" joinCallArgs = case marsh2 of Nothing -> join callArgs @@ -942,22 +978,22 @@ join (take 1 callArgs) ++ " >>= \\b1' ->\n" marshRes = 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 _ -> "res'":retArgs ret = "(" ++ concat (intersperse ", " retArgs') ++ ")" funBody = joinLines marshIns ++ @@ -984,18 +1020,26 @@ -- funTy parms' parm' = let + showComment str = if null str + then "" + else " -- " ++ str ++ "\n" ctxt = case octxt of Nothing -> "" Just ctxtStr -> ctxtStr ++ " => " - argTys = ["(" ++ ty ++ ")" | CHSParm im ty _ _ _ <- parms' , notVoid im] - resTys = ["(" ++ ty ++ ")" | CHSParm _ ty _ om _ <- parm':parms', notVoid om] + argTys = ["(" ++ ty ++ ")" ++ showComment c | + CHSParm im ty _ _ _ c <- parms', notVoid im] + resTys = ["(" ++ ty ++ ")" | + CHSParm _ ty _ om _ _ <- parm':parms', notVoid om] resTup = let + comment = case parm' of + CHSParm _ _ _ _ _ c -> c (lp, rp) = if isPure && length resTys == 1 then ("", "") else ("(", ")") io = if isPure then "" else "IO " in - io ++ lp ++ concat (intersperse ", " resTys) ++ rp + io ++ lp ++ concat (intersperse ", " resTys) ++ rp ++ + showComment comment in ctxt ++ concat (intersperse " -> " (argTys ++ [resTup])) @@ -1008,7 +1052,7 @@ -- code fragments -- marshArg i (CHSParm (Just (imBody, imArgKind)) _ twoCVal - (Just (omBody, omArgKind)) _ ) = + (Just (omBody, omArgKind)) _ _ ) = let a = "a" ++ show (i :: Int) imStr = marshBody imBody @@ -1067,14 +1111,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') 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', isImpure) + return (CHSParm imMarsh' ty False omMarsh' pos' c, isImpure) -- splitFunTy (FunET UnitET ty ) = splitFunTy ty splitFunTy (FunET ty1 ty2) = let @@ -1085,22 +1129,22 @@ -- -- match Haskell with C arguments (and results) -- - addDft ((CHSParm imMarsh hsTy False omMarsh p):parms'') (cTy :cTys) = do + 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 : parms', + return (CHSParm imMarsh' hsTy False omMarsh' p c : parms', isImpure || isImpureIn || isImpureOut) - addDft ((CHSParm imMarsh hsTy True omMarsh p):parms'') (cTy1:cTy2:cTys) = + addDft ((CHSParm imMarsh hsTy True omMarsh p c):parms'') (cTy1:cTy2:cTys) = 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 : parms', + return (CHSParm imMarsh' hsTy True omMarsh' p c : parms', isImpure || isImpureIn || isImpureOut) addDft [] [] = return ([], False) - addDft ((CHSParm _ _ _ _ pos'):_) [] = + addDft ((CHSParm _ _ _ _ pos' _):_) [] = marshArgMismatchErr pos' "This parameter is in excess of the C arguments." addDft [] (_:_) = marshArgMismatchErr pos "Parameter marshallers are missing." @@ -1242,12 +1286,17 @@ -- | Haskell code for writing to or reading from a struct -- -setGet :: Position -> CHSAccess -> [BitSize] -> ExtType -> GB String -setGet pos access offsets ty = +setGet :: Position -> CHSAccess -> [BitSize] -> ExtType -> Maybe Ident + -> GB String +setGet pos access offsets ty onewtype = do - let pre = case access of - CHSSet -> "(\\ptr val -> do {" - CHSGet -> "(\\ptr -> do {" + let pre = case (access, onewtype) of + (CHSSet, Nothing) -> "(\\ptr val -> do {" + (CHSGet, Nothing) -> "(\\ptr -> do {" + (CHSSet, Just ide) -> + "(\\(" ++ identToString ide ++ " ptr) val -> do {" + (CHSGet, Just ide) -> + "(\\(" ++ identToString ide ++ " ptr) -> do {" body <- setGetBody (reverse offsets) return $ pre ++ body ++ "})" where @@ -1611,7 +1660,7 @@ [(Just declr, _, size)] | isPtrDeclr declr -> ptrType declr | isFunDeclr declr -> funType | otherwise -> aliasOrSpecType size - [] -> aliasOrSpecType Nothing + _ -> aliasOrSpecType Nothing where -- handle explicit pointer types -- @@ -1822,13 +1871,19 @@ funAttrs (CDecl specs declrs _) = let (_,attrs',_,_,_) = partitionDeclSpecs specs - in attrs' ++ funEndAttrs declrs + in attrs' ++ funEndAttrs declrs ++ funPtrAttrs declrs -- attrs after the function name, e.g. void foo() __attribute__((...)); 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 _ = [] + -- | generate the necessary parameter for "foreign import" for the -- provided calling convention showCallingConvention :: CallingConvention -> String @@ -2087,7 +2142,7 @@ do (cobj, _) <- findValueObj ide''' False case cobj of - EnumCO ide'' (CEnum _ (Just enumrs) _ _) -> + EnumCO ide'' (CEnum _ (Just enumrs) _ _) -> liftM IntResult $ enumTagValue ide'' enumrs 0 _ -> todo $ "GenBind.evalConstCExpr: variable names not implemented yet " ++ @@ -2130,8 +2185,8 @@ evalCCast' :: CompType -> Integer -> GB ConstResult evalCCast' (ExtType (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) evalCConst (CCharConst c _ ) = return $ IntResult (getCCharAsInt c) diff --git a/src/C2HS/Gen/Header.hs b/src/C2HS/Gen/Header.hs --- a/src/C2HS/Gen/Header.hs +++ b/src/C2HS/Gen/Header.hs @@ -53,8 +53,8 @@ import Language.C.Pretty import Language.C.Syntax import Data.Errors (interr) -import Data.DLists (DList) -import qualified Data.DLists as DL +import Data.DList (DList) +import qualified Data.DList as DL -- C->Haskell import C2HS.State (CST, runCST, transCST, raiseError, catchExc, @@ -132,7 +132,7 @@ (header, frags', last', _rest) <- ghFrags frags when (not . isEOF $ last') $ notOpenCondErr (posOf last') - return (DL.close header, CHSModule frags') + return (DL.toList header, CHSModule frags') -- | Collect header and fragments up to eof or a CPP directive that is part of a -- conditional @@ -142,7 +142,7 @@ -- concatenation of lines that go into the header. -- ghFrags :: [CHSFrag] -> GH (DList String, [CHSFrag], FragElem, [CHSFrag]) -ghFrags [] = return (DL.zero, [], EOF, []) +ghFrags [] = return (DL.empty, [], EOF, []) ghFrags frags = do (header, frag, rest) <- ghFrag frags @@ -150,7 +150,7 @@ Frag aFrag -> do (header2, frags', frag', rest') <- ghFrags rest -- FIXME: Not tail rec - return (header `DL.join` header2, aFrag:frags', + return (header `DL.append` header2, aFrag:frags', frag', rest') _ -> return (header, [], frag, rest) @@ -162,16 +162,16 @@ FragElem, -- processed fragment [CHSFrag]) -- not yet processed fragments ghFrag [] = - return (DL.zero, EOF, []) + return (DL.empty, EOF, []) ghFrag (frag@(CHSVerb _ _ ) : frags) = - return (DL.zero, Frag frag, frags) + return (DL.empty, Frag frag, frags) -- generate an enum __c2hs__enum__'id { __c2hs_enr__'id = DEF1, ... } and then process an -- ordinary enum directive ghFrag (_frag@(CHSHook (CHSEnumDefine hsident trans instances pos) hkpos) : frags) = do ide <- newEnumIdent (enrs,trans') <- createEnumerators trans - return (DL.open [show.pretty $ enumDef ide enrs,";\n"], Frag (enumFrag (identToString ide) trans'), frags) + return (DL.fromList [show.pretty $ enumDef ide enrs,";\n"], Frag (enumFrag (identToString ide) trans'), frags) where newEnumIdent = liftM internalIdent $ transCST $ \supply -> (tail supply, "__c2hs_enum__" ++ show (nameId $ head supply)) newEnrIdent = liftM internalIdent $ transCST $ \supply -> (tail supply, "__c2hs_enr__" ++ show (nameId $ head supply)) @@ -187,13 +187,13 @@ enumFrag ide trans' = CHSHook (CHSEnum (internalIdent ide) (Just hsident) trans' Nothing Nothing instances pos) hkpos ghFrag (frag@(CHSHook _ _) : frags) = - return (DL.zero, Frag frag, frags) + return (DL.empty, Frag frag, frags) ghFrag (frag@(CHSLine _ ) : frags) = - return (DL.zero, Frag frag, frags) + return (DL.empty, Frag frag, frags) ghFrag ( (CHSC s _ ) : frags) = do (header, frag, frags' ) <- ghFrag frags -- scan for next CHS fragment - return (DL.unit s `DL.join` header, frag, frags') + return (DL.singleton s `DL.append` header, frag, frags') -- FIXME: this is not tail recursive... ghFrag ( (CHSCond _ _ ) : _ ) = @@ -208,10 +208,10 @@ "if" -> openIf s pos frags "ifdef" -> openIf s pos frags "ifndef" -> openIf s pos frags - "else" -> return (DL.zero , Else pos , frags) - "elif" -> return (DL.zero , Elif s pos , frags) - "endif" -> return (DL.zero , Endif pos , frags) - _ -> return (DL.open ['#':s, "\n"], + "else" -> return (DL.empty , Else pos , frags) + "elif" -> return (DL.empty , Elif s pos , frags) + "endif" -> return (DL.empty , Endif pos , frags) + _ -> return (DL.fromList ['#':s, "\n"], Frag (CHSVerb (if nl then "\n" else "") pos), frags) where -- enter a new conditional (may be an #if[[n]def] or #elif) @@ -231,7 +231,7 @@ Endif _ -> closeIf ((headerTh `DL.snoc` "#else\n") - `DL.join` + `DL.append` (headerEl `DL.snoc` "#endif\n")) (s', fragsTh) @@ -243,7 +243,7 @@ (headerEl, condFrag, rest') <- openIf s'' pos' rest case condFrag of Frag (CHSCond alts dft) -> - closeIf (headerTh `DL.join` headerEl) + closeIf (headerTh `DL.append` headerEl) (s, fragsTh) alts dft @@ -270,9 +270,9 @@ -- don't use an internal ident, as we need to test for -- equality with identifiers read from the .i file -- during binding hook expansion - header = DL.open ['#':s', "\n", + header = DL.fromList ['#':s', "\n", "struct ", sentryName, ";\n"] - `DL.join` headerTail + `DL.append` headerTail return (header, Frag (CHSCond ((sentry, fragsTh):alts) oelse), rest) diff --git a/src/C2HS/Gen/Monad.hs b/src/C2HS/Gen/Monad.hs --- a/src/C2HS/Gen/Monad.hs +++ b/src/C2HS/Gen/Monad.hs @@ -223,16 +223,35 @@ show (Class osuper pointer ) = "Class " ++ show ptrType ++ show isNewtype -} + +-- Remove everything until the next element in the list (given by a +-- ","), the end of the list (marked by "]"), or the end of a record +-- "}". Everything inside parenthesis is ignored. +chopIdent :: String -> String +chopIdent str = goChop 0 str + where goChop :: Int -> String -> String + goChop 0 rest@('}':_) = rest + goChop 0 rest@(',':_) = rest + goChop 0 rest@(']':_) = rest + goChop level ('(':rest) = goChop (level+1) rest + goChop level (')':rest) = goChop (level-1) rest + goChop level (_ :rest) = goChop level rest + goChop level [] = [] + +extractIdent :: String -> (Ident, String) +extractIdent str = + let isQuote c = c == '\'' || c == '"' + (ideChars, rest) = span (not . isQuote) + . tail + . dropWhile (not . isQuote) $ str + in + if null ideChars + then error $ "Could not interpret " ++ show str ++ "as an Ident." + else (internalIdent ideChars, (chopIdent . tail) rest) + -- super kludgy (depends on Show instance of Ident) instance Read Ident where - readsPrec _ ('`':lexeme) = let (ideChars, rest) = span (/= '\'') lexeme - in - if null ideChars - then [] - else [(internalIdent ideChars, tail rest)] - readsPrec p (c:cs) - | isSpace c = readsPrec p cs - readsPrec _ _ = [] + readsPrec _ str = [extractIdent str] -- | the local state consists of -- @@ -467,4 +486,3 @@ ["Unknown name!", "`" ++ identToString ide ++ "' is unknown; it has *not* been defined by", "a previous hook."] - diff --git a/src/C2HS/Version.hs b/src/C2HS/Version.hs --- a/src/C2HS/Version.hs +++ b/src/C2HS/Version.hs @@ -9,8 +9,8 @@ name = "C->Haskell Compiler" versnum = Paths_c2hs.version -versnick = "Crystal Seed" -date = "24 Jan 2009" +versnick = "The shapeless maps" +date = "31 Oct 2014" version = name ++ ", version " ++ showVersion versnum ++ " " ++ versnick ++ ", " ++ date copyright = "Copyright (c) 1999-2007 Manuel M T Chakravarty\n" ++ " 2005-2008 Duncan Coutts\n" diff --git a/src/Control/StateBase.hs b/src/Control/StateBase.hs --- a/src/Control/StateBase.hs +++ b/src/Control/StateBase.hs @@ -56,6 +56,8 @@ import Data.Errors (ErrorLevel(..), Error) import Language.C.Data.Name +import Control.Applicative (Applicative(..)) +import Control.Monad (liftM, ap) -- state used in the whole compiler -- -------------------------------- @@ -80,6 +82,13 @@ -- newtype PreCST e s a = CST (STB (BaseState e) s a) + +instance Functor (PreCST e s) where + fmap = liftM + +instance Applicative (PreCST e s) where + pure = return + (<*>) = ap instance Monad (PreCST e s) where return = yield diff --git a/src/Control/StateTrans.hs b/src/Control/StateTrans.hs --- a/src/Control/StateTrans.hs +++ b/src/Control/StateTrans.hs @@ -73,6 +73,9 @@ throwExc, fatal, catchExc, fatalsHandledBy) where + +import Control.Applicative (Applicative(..)) +import Control.Monad (liftM, ap) import Control.Exception (catch) import Prelude hiding (catch) @@ -98,6 +101,13 @@ -- @Right a@ -- is a successfully delivered result -- newtype STB bs gs a = STB (bs -> gs -> IO (bs, gs, Either (String, String) a)) + +instance Functor (STB bs gs) where + fmap = liftM + +instance Applicative (STB bs gs) where + pure = return + (<*>) = ap instance Monad (STB bs gs) where return = yield diff --git a/src/Data/DLists.hs b/src/Data/DLists.hs deleted file mode 100644 --- a/src/Data/DLists.hs +++ /dev/null @@ -1,66 +0,0 @@ --- The Compiler Toolkit: difference lists --- --- Author : Manuel M. T. Chakravarty --- Created: 24 February 95 --- --- Copyright (c) [1995..2000] Manuel M. T. Chakravarty --- --- This library is free software; you can redistribute it and/or --- modify it under the terms of the GNU Library General Public --- License as published by the Free Software Foundation; either --- version 2 of the License, or (at your option) any later version. --- --- This library 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 --- Library General Public License for more details. --- ---- DESCRIPTION --------------------------------------------------------------- --- --- This module provides the functional equivalent of the difference lists --- from logic programming. They provide an O(1) append. --- ---- DOCU ---------------------------------------------------------------------- --- --- language: Haskell 98 --- ---- TODO ---------------------------------------------------------------------- --- - -module Data.DLists (DList, open, zero, unit, snoc, join, close) -where - --- | a difference list is a function that given a list returns the original --- contents of the difference list prepended at the given list --- -type DList a = [a] -> [a] - --- | open a list for use as a difference list --- -open :: [a] -> DList a -open = (++) - --- | create a difference list containing no elements --- -zero :: DList a -zero = id - --- | create difference list with given single element --- -unit :: a -> DList a -unit = (:) - --- | append a single element at a difference list --- -snoc :: DList a -> a -> DList a -snoc dl x = \l -> dl (x:l) - --- | appending difference lists --- -join :: DList a -> DList a -> DList a -join = (.) - --- | closing a difference list into a normal list --- -close :: DList a -> [a] -close = ($[]) diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -124,7 +124,7 @@ import System.Console.GetOpt (ArgOrder(..), OptDescr(..), ArgDescr(..), usageInfo, getOpt) import qualified System.FilePath as FilePath - (takeExtension, dropExtension, takeBaseName) + (takeDirectory, takeExtension, dropExtension) import System.FilePath ((<.>), (), splitSearchPath) import System.IO (stderr, openFile, IOMode(..)) import System.IO.Error (ioeGetErrorString, ioeGetFileName) @@ -136,7 +136,7 @@ traceSet, setSwitch, getSwitch, putTraceStr) import qualified System.CIO as CIO import C2HS.C (hsuffix, isuffix, loadAttrC) -import C2HS.CHS (loadCHS, dumpCHS, hssuffix, chssuffix, dumpCHI) +import C2HS.CHS (loadCHS, dumpCHS, hssuffix, chssuffix, dumpCHI, hasNonGNU) import C2HS.Gen.Header (genHeader) import C2HS.Gen.Bind (expandHooks) import C2HS.Version (versnum, version, copyright, disclaimer) @@ -178,8 +178,6 @@ -- data Flag = CPPOpts String -- ^ additional options for C preprocessor | CPP String -- ^ program name of C preprocessor - | NoGNU -- ^ suppress GNU preprocessor symbols - | NoBlocks -- ^ suppress MacOS __BLOCKS__ preproc. symbol | Dump DumpType -- ^ dump internal information | Help -- ^ print brief usage information | Keep -- ^ keep the .i file @@ -211,14 +209,6 @@ ["cpp"] (ReqArg CPP "CPP") "use executable CPP to invoke C preprocessor", - Option ['n'] - ["no-gnu"] - (NoArg NoGNU) - "suppress GNU preprocessor symbols", - Option ['b'] - ["no-blocks"] - (NoArg NoBlocks) - "suppress MacOS __BLOCKS__ preprocessor symbol", Option ['d'] ["dump"] (ReqArg dumpArg "TYPE") @@ -279,7 +269,7 @@ do setup cmdLine <- CIO.getArgs - case getOpt RequireOrder options cmdLine of + case getOpt Permute options cmdLine of (opts, [] , []) | noCompOpts opts -> doExecute opts Nothing (opts, args, []) -> case parseArgs args of @@ -330,7 +320,8 @@ fnMsg = case ioeGetFileName err of Nothing -> "" Just s -> " (file: `" ++ s ++ "')" - CIO.hPutStrLn stderr (msg ++ fnMsg) + name <- CIO.getProgName + CIO.hPutStrLn stderr $ concat [name, ": ", msg, fnMsg] CIO.exitWith $ CIO.ExitFailure 1 -- | set up base configuration @@ -370,19 +361,11 @@ let bndFileWithoutSuffix = FilePath.dropExtension bndFile computeOutputName bndFileWithoutSuffix process headerFiles bndFileWithoutSuffix - `fatalsHandledBy` die Nothing -> computeOutputName "." -- we need the output name for library copying copyLibrary - `fatalsHandledBy` die where atMostOne = (foldl (\_ x -> [x]) []) - -- - die ioerr = - do - name <- CIO.getProgName - CIO.putStr $ name ++ ": " ++ ioeGetErrorString ioerr ++ "\n" - CIO.exitWith $ CIO.ExitFailure 1 -- | emit help message -- @@ -403,8 +386,6 @@ processOpt :: Flag -> CST s () processOpt (CPPOpts cppopt ) = addCPPOpts [cppopt] processOpt (CPP cpp ) = setCPP cpp -processOpt (NoGNU ) = setNoGNU -processOpt (NoBlocks ) = setNoBlocks processOpt (Dump dt ) = setDump dt processOpt (Keep ) = setKeep processOpt (Library ) = setLibrary @@ -465,16 +446,6 @@ setCPP :: FilePath -> CST s () setCPP fname = setSwitch $ \sb -> sb {cppSB = fname} --- | set flag to suppress GNU preprocessor symbols --- -setNoGNU :: CST s () -setNoGNU = setSwitch $ \sb -> sb {noGnuSB = True} - --- | set flag to suppress MacOS __BLOCKS__ preprocessor symbols --- -setNoBlocks :: CST s () -setNoBlocks = setSwitch $ \sb -> sb {noBlocksSB = True} - -- set the given dump option -- setDump :: DumpType -> CST s () @@ -551,8 +522,22 @@ -- (chsMod , warnmsgs) <- loadCHS bndFile CIO.putStr warnmsgs - traceCHSDump chsMod -- + -- get output directory and create it if it's missing + -- + outFName <- getSwitch outputSB + outDir <- getSwitch outDirSB + let outFPath = outDir outFName + CIO.createDirectoryIfMissing True $ FilePath.takeDirectory outFPath + -- + -- dump the binding file when demanded + -- + flag <- traceSet dumpCHSSW + when flag $ do + let chsName = outFPath <.> "dump" + CIO.putStrLn $ "...dumping CHS to `" ++ chsName ++ "'..." + dumpCHS chsName chsMod False + -- -- extract CPP and inline-C embedded in the .chs file (all CPP and -- inline-C fragments are removed from the .chs tree and conditionals are -- replaced by structured conditionals) @@ -563,11 +548,9 @@ -- create new header file, make it #include `headerFile', and emit -- CPP and inline-C of .chs file into the new header -- - outFName <- getSwitch outputSB - outDir <- getSwitch outDirSB let newHeader = outFName <.> chssuffix <.> hsuffix newHeaderFile = outDir newHeader - preprocFile = FilePath.takeBaseName outFName <.> isuffix + preprocFile = outFPath <.> isuffix CIO.writeFile newHeaderFile $ concat $ [ "#include \"" ++ headerFile ++ "\"\n" | headerFile <- headerFiles ] @@ -586,14 +569,17 @@ -- cpp <- getSwitch cppSB cppOpts <- getSwitch cppOptsSB - noGnu <- getSwitch noGnuSB - noBlocks <- getSwitch noBlocksSB - let noGnuOpts = - if noGnu - then ["-U__GNUC__", "-U__GNUC_MINOR__", "-U__GNUC_PATCHLEVEL__"] + let nonGNUOpts = + if hasNonGNU chsMod + then [ "-U__GNUC__" + , "-U__GNUC_MINOR__" + , "-U__GNUC_PATCHLEVEL__" + , "-D__AVAILIBILITY__" + , "-D__OSX_AVAILABLE_STARTING(a,b)" + , "-D__OSX_AVAILABLE_BUT_DEPRECATED(a,b,c,d)" + , "-D__OSX_AVAILABLE_BUT_DEPRECATED_MSG(a,b,c,d,e)" ] else [] - noBlocksOpts = if noBlocks then ["-U__BLOCKS__"] else [] - args = cppOpts ++ noGnuOpts ++ noBlocksOpts ++ [newHeaderFile] + args = cppOpts ++ nonGNUOpts ++ ["-U__BLOCKS__"] ++ [newHeaderFile] tracePreproc (unwords (cpp:args)) exitCode <- CIO.liftIO $ do preprocHnd <- openFile preprocFile WriteMode @@ -627,17 +613,8 @@ -- -- output the result -- - dumpCHS (outDir outFName) hsMod True - dumpCHI (outDir outFName) chi -- different suffix will be appended + dumpCHS outFPath hsMod True + dumpCHI outFPath chi -- different suffix will be appended where tracePreproc cmd = putTraceStr tracePhasesSW $ "Invoking cpp as `" ++ cmd ++ "'...\n" - traceCHSDump mod' = do - flag <- traceSet dumpCHSSW - when flag $ - (do - CIO.putStr ("...dumping CHS to `" ++ chsName - ++ "'...\n") - dumpCHS chsName mod' False) - - chsName = FilePath.takeBaseName bndFile <.> "dump" diff --git a/src/System/CIO.hs b/src/System/CIO.hs --- a/src/System/CIO.hs +++ b/src/System/CIO.hs @@ -50,7 +50,7 @@ -- -- `Directory' -- - doesFileExist, removeFile, + createDirectoryIfMissing, doesFileExist, removeFile, -- -- `System' -- @@ -64,10 +64,11 @@ import Prelude (Bool, Char, String, FilePath, (.), ($), Show, return) import qualified System.IO as IO -import qualified System.Directory as IO (doesFileExist, removeFile) +import qualified System.Directory as IO + (createDirectoryIfMissing, doesFileExist, removeFile) import qualified System.Environment as IO (getArgs, getProgName) -import qualified System.Cmd as IO (system) -import qualified System.Exit as IO (ExitCode(..), exitWith) +import qualified System.Process as IO (system) +import qualified System.Exit as IO (ExitCode(..), exitWith) import Control.StateBase (PreCST, liftIO) @@ -149,6 +150,9 @@ -- `Directory' -- ----------- + +createDirectoryIfMissing :: Bool -> FilePath -> PreCST e s () +createDirectoryIfMissing p = liftIO . IO.createDirectoryIfMissing p doesFileExist :: FilePath -> PreCST e s Bool doesFileExist = liftIO . IO.doesFileExist diff --git a/src/Text/Lexers.hs b/src/Text/Lexers.hs --- a/src/Text/Lexers.hs +++ b/src/Text/Lexers.hs @@ -136,7 +136,7 @@ import Data.Array (Array, (!), assocs, accumArray) import Language.C.Data.Position -import qualified Data.DLists as DL +import qualified Data.DList as DL import Data.Errors (interr, ErrorLevel(..), Error, makeError) @@ -450,7 +450,7 @@ -- -- lexOne :: Lexer s t -> LexerState s t -- -> (Either Error (Maybe t), Lexer s t, LexerState s t) - lexOne l0 state' = oneLexeme l0 state' DL.zero lexErr + lexOne l0 state' = oneLexeme l0 state' DL.empty lexErr where -- the result triple of `lexOne' that signals a lexical error; -- the result state is advanced by one character for error correction @@ -504,7 +504,7 @@ -- execute the action if present and finalise the current lexeme -- action (Action f) csDL (cs, pos, s) _last = - case f (DL.close csDL) pos s of + case f (DL.toList csDL) pos s of (Nothing, pos', s', l') | not . null $ cs -> lexOne (fromMaybe l0 l') (cs, pos', s') (res , pos', s', l') -> (res, (fromMaybe l0 l'), (cs, pos', s')) diff --git a/tests/bugs/issue-51/Issue51.chs b/tests/bugs/issue-51/Issue51.chs deleted file mode 100644 --- a/tests/bugs/issue-51/Issue51.chs +++ /dev/null @@ -1,15 +0,0 @@ -module Main where - -import Foreign.C - -#include "issue51.h" - -foo :: CInt -> CInt -#ifdef __GNUC__ -foo = {#call pure fooGnu#} -#else -foo = {#call pure fooNonGnu#} -#endif - -main :: IO () -main = print $ foo 0 diff --git a/tests/bugs/issue-51/Issue51_GNU.chs b/tests/bugs/issue-51/Issue51_GNU.chs new file mode 100644 --- /dev/null +++ b/tests/bugs/issue-51/Issue51_GNU.chs @@ -0,0 +1,15 @@ +module Main where + +import Foreign.C + +#include "issue51.h" + +foo :: CInt -> CInt +#ifdef __GNUC__ +foo = {#call pure fooGnu#} +#else +foo = {#call pure fooNonGnu#} +#endif + +main :: IO () +main = print $ foo 0 diff --git a/tests/bugs/issue-51/Issue51_nonGNU.chs b/tests/bugs/issue-51/Issue51_nonGNU.chs new file mode 100644 --- /dev/null +++ b/tests/bugs/issue-51/Issue51_nonGNU.chs @@ -0,0 +1,16 @@ +module Main where + +import Foreign.C + +{#nonGNU#} +#include "issue51.h" + +foo :: CInt -> CInt +#ifdef __GNUC__ +foo = {#call pure fooGnu#} +#else +foo = {#call pure fooNonGnu#} +#endif + +main :: IO () +main = print $ foo 0 diff --git a/tests/regression-suite.hs b/tests/regression-suite.hs --- a/tests/regression-suite.hs +++ b/tests/regression-suite.hs @@ -19,6 +19,7 @@ , flags :: [Text] , aptPPA :: [Text] , aptPackages :: [Text] + , cabalBuildTools :: [Text] , specialSetup :: [Text] , extraPath :: [Text] } deriving (Eq, Show) @@ -29,6 +30,7 @@ <*> v .:? "flags" .!= [] <*> v .:? "apt-ppa" .!= [] <*> v .:? "apt-packages" .!= [] + <*> v .:? "cabal-build-tools" .!= [] <*> v .:? "special-setup" .!= [] <*> v .:? "extra-path" .!= [] parseJSON _ = mzero @@ -55,12 +57,16 @@ tests <- liftIO $ readTests "tests/regression-suite.yaml" let ppas = nub $ concatMap aptPPA tests pkgs = nub $ concatMap aptPackages tests + buildTools = nub $ concatMap cabalBuildTools tests specials = concatMap specialSetup tests extraPaths = concatMap extraPath tests when (not travis) $ echo "ASSUMING THAT ALL NECESSARY LIBRARIES ALREADY INSTALLED!\n" + home <- fromText <$> get_env_text "HOME" + appendToPath $ home ".cabal/bin" + when travis $ do when (not (null ppas)) $ do echo "SETTING UP APT PPAS\n" @@ -94,7 +100,7 @@ Just efs -> infs ++ concatMap (\f -> ["-f", f]) (T.splitOn "," efs) echo $ "\nREGRESSION TEST: " <> n <> "\n" errExit False $ do - run_ "cabal" $ ["install"] ++ fs ++ [n] + run_ "cabal" $ ["install", "--jobs=1"] ++ fs ++ [n] lastExitCode if all (== 0) codes diff --git a/tests/test-bugs.hs b/tests/test-bugs.hs --- a/tests/test-bugs.hs +++ b/tests/test-bugs.hs @@ -5,22 +5,37 @@ import Test.Framework.Providers.HUnit import Test.HUnit hiding (Test, assert) import System.FilePath (searchPathSeparator) +import Prelude hiding (FilePath) +import Control.Monad.IO.Class import Shelly import Data.Text (Text) import Data.Monoid import qualified Data.Text as T +import Paths_c2hs default (T.Text) main :: IO () main = defaultMain tests +c2hsShelly :: MonadIO m => Sh a -> m a +c2hsShelly as = shelly $ do + oldpath <- get_env_text "PATH" + let newpath = "../../../dist/build/c2hs:" <> oldpath + setenv "PATH" newpath + as + tests :: [Test] tests = [ testGroup "Bugs" [ testCase "call_capital (issue #??)" call_capital + , testCase "Issue #96" issue96 + , testCase "Issue #95" issue95 + , testCase "Issue #93" issue93 + , testCase "Issue #80" issue80 , testCase "Issue #79" issue79 , testCase "Issue #75" issue75 , testCase "Issue #69" issue69 + , testCase "Issue #62" issue62 , testCase "Issue #60" issue60 , testCase "Issue #51" issue51 , testCase "Issue #47" issue47 @@ -43,7 +58,7 @@ ] call_capital :: Assertion -call_capital = shelly $ chdir "tests/bugs/call_capital" $ do +call_capital = c2hsShelly $ chdir "tests/bugs/call_capital" $ do mapM_ rm_f ["Capital.hs", "Capital.chs.h", "Capital.chi", "Capital_c.o", "Capital"] cmd "c2hs" "-d" "genbind" "Capital.chs" @@ -53,6 +68,18 @@ let expected = ["upper C();", "lower c();", "upper C();"] liftIO $ assertBool "" (T.lines res == expected) +issue96 :: Assertion +issue96 = build_issue 96 + +issue95 :: Assertion +issue95 = build_issue 95 + +issue93 :: Assertion +issue93 = build_issue 93 + +issue80 :: Assertion +issue80 = build_issue 80 + issue79 :: Assertion issue79 = expect_issue 79 ["A=1", "B=2", "C=2", "D=3"] @@ -62,6 +89,9 @@ issue69 :: Assertion issue69 = build_issue 69 +issue62 :: Assertion +issue62 = build_issue 62 + issue60 :: Assertion issue60 = build_issue 60 @@ -71,7 +101,9 @@ "3", "0.3", "3", "0.3"] issue51 :: Assertion -issue51 = expect_issue_with 51 ["--no-gnu"] ["0"] +issue51 = do + expect_issue_with 51 "nonGNU" [] ["0"] + expect_issue_with 51 "GNU" [] ["1"] issue47 :: Assertion issue47 = build_issue 47 @@ -102,7 +134,7 @@ -- This is tricky to test since it's Windows-specific, but we can at -- least make sure that paths with spaces work OK. issue30 :: Assertion -issue30 = shelly $ chdir "tests/bugs/issue-30" $ do +issue30 = c2hsShelly $ chdir "tests/bugs/issue-30" $ do mkdir_p "test 1" mkdir_p "test 2" mapM_ rm_f ["Issue30.hs", "Issue30.chs.h", "Issue30.chi", @@ -113,7 +145,7 @@ mv "Issue30Aux1.chi" "test 1" cmd "c2hs" "Issue30Aux2.chs" mv "Issue30Aux2.chi" "test 2" - let sp = "test 1" ++ [searchPathSeparator] ++ "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" @@ -125,11 +157,11 @@ liftIO $ assertBool "" (T.lines res == expected) issue29 :: Assertion -issue29 = shelly $ do +issue29 = c2hsShelly $ do errExit False $ do cd "tests/bugs/issue-29" mapM_ rm_f ["Issue29.hs", "Issue29.chs.h", "Issue29.chi"] - run "c2hs" $ ["--no-blocks", toTextIgnore "Issue29.chs"] + run "c2hs" [toTextIgnore "Issue29.chs"] code <- lastExitCode liftIO $ assertBool "" (code == 0) @@ -149,21 +181,22 @@ issue10 = expect_issue 10 ["SAME", "SAME", "SAME"] issue7 :: Assertion -issue7 = shelly $ do +issue7 = c2hsShelly $ do errExit False $ do cd "tests/bugs/issue-7" mapM_ rm_f ["Issue7.hs", "Issue7.chs.h", "Issue7.chi"] setenv "LANG" "zh_CN.utf8" - run "c2hs" $ [toTextIgnore "Issue7.chs"] + run "c2hs" [toTextIgnore "Issue7.chs"] code <- lastExitCode liftIO $ assertBool "" (code == 0) -do_issue_build :: Int -> [Text] -> Sh () -do_issue_build n c2hsargs = +do_issue_build :: Int -> String -> [Text] -> Sh () +do_issue_build n ext c2hsargs = let wdir = "tests/bugs" ("issue-" <> show n) lc = "issue" <> show n lcc = lc <> "_c" - uc = fromText $ T.pack $ "Issue" <> show n + uc = fromText $ T.pack $ "Issue" <> show n <> + (if ext == "" then "" else "_" <> ext) in do cd wdir mapM_ rm_f [uc <.> "hs", uc <.> "chs.h", uc <.> "chi", lcc <.> "o", uc] @@ -172,17 +205,18 @@ cmd "ghc" "-Wall" "-Werror" "--make" (lcc <.> "o") (uc <.> "hs") expect_issue :: Int -> [Text] -> Assertion -expect_issue n expected = expect_issue_with n [] expected +expect_issue n expected = expect_issue_with n "" [] expected -expect_issue_with :: Int -> [Text] -> [Text] -> Assertion -expect_issue_with n c2hsargs expected = shelly $ do - do_issue_build n c2hsargs - res <- absPath ("." (fromText $ T.pack $ "Issue" <> show n)) >>= cmd +expect_issue_with :: Int -> String -> [Text] -> [Text] -> Assertion +expect_issue_with n ext c2hsargs expected = c2hsShelly $ do + do_issue_build n ext c2hsargs + res <- absPath ("." (fromText $ T.pack $ "Issue" <> show n <> + (if ext == "" then "" else "_" <> ext))) >>= cmd liftIO $ assertBool "" (T.lines res == expected) build_issue_with :: Int -> [Text] -> Assertion -build_issue_with n c2hsargs = shelly $ do - errExit False $ do_issue_build n c2hsargs +build_issue_with n c2hsargs = c2hsShelly $ do + errExit False $ do_issue_build n "" c2hsargs code <- lastExitCode liftIO $ assertBool "" (code == 0) diff --git a/tests/test-system.hs b/tests/test-system.hs --- a/tests/test-system.hs +++ b/tests/test-system.hs @@ -4,16 +4,27 @@ import Test.Framework (defaultMain, testGroup, Test) import Test.Framework.Providers.HUnit import Test.HUnit hiding (Test, assert) +import Control.Monad.IO.Class import Shelly import qualified Shelly as Sh +import Prelude hiding (FilePath) import Control.Monad (forM_) import Data.Text (Text) +import Data.Monoid import qualified Data.Text as T +import Paths_c2hs default (T.Text) main :: IO () main = defaultMain tests +c2hsShelly :: MonadIO m => Sh a -> m a +c2hsShelly as = shelly $ do + oldpath <- get_env_text "PATH" + let newpath = "../../../dist/build/c2hs:" <> oldpath + setenv "PATH" newpath + as + tests :: [Test] tests = [ testGroup "System" @@ -29,7 +40,7 @@ ] run_test_exit_code :: Sh.FilePath -> [(Sh.FilePath, [Text])] -> Assertion -run_test_exit_code dir cmds = shelly $ chdir dir $ do +run_test_exit_code dir cmds = c2hsShelly $ chdir dir $ do forM_ (init cmds) $ \(c, as) -> run c as errExit False $ run (fst $ last cmds) (snd $ last cmds) code <- lastExitCode @@ -37,7 +48,7 @@ run_test_expect :: Sh.FilePath -> [(Sh.FilePath, [Text])] -> Sh.FilePath -> [Text] -> Assertion -run_test_expect dir cmds expcmd expected = shelly $ chdir dir $ do +run_test_expect dir cmds expcmd expected = c2hsShelly $ chdir dir $ do forM_ cmds $ \(c, as) -> run c as res <- absPath expcmd >>= cmd liftIO $ assertBool "" (T.lines res == expected)