diff --git a/ChangeLog b/ChangeLog --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,13 @@ +0.27.1 + - Alternate specification for sizes in "+" parameters [#140] + - Fix regression to do with incomplete structure types [#152] + - Fix pattern match error [PR #153] (deech) + +0.26.2 + - Missing import bug [#151] + - Parameter count checking for {#fun ...#} [#149] + - Error message for "incomplete types" [#141] + 0.26.1 - Better error messages [PR #139] (Noam Lewis) - Fix for OS X block syntax [#138] (Anthony Cowley) diff --git a/c2hs.cabal b/c2hs.cabal --- a/c2hs.cabal +++ b/c2hs.cabal @@ -1,5 +1,5 @@ Name: c2hs -Version: 0.26.2 +Version: 0.27.1 License: GPL-2 License-File: COPYING Copyright: Copyright (c) 1999-2007 Manuel M T Chakravarty @@ -95,9 +95,11 @@ tests/bugs/issue-133/*.chs tests/bugs/issue-133/*.h tests/bugs/issue-134/*.chs tests/bugs/issue-134/*.h tests/bugs/issue-136/*.chs tests/bugs/issue-136/*.h tests/bugs/issue-136/*.c + tests/bugs/issue-140/*.chs tests/bugs/issue-140/*.h tests/bugs/issue-140/*.c tests/bugs/issue-141/*.chs tests/bugs/issue-141/*.h tests/bugs/issue-149/*.chs tests/bugs/issue-149/*.h tests/bugs/issue-149/*.c tests/bugs/issue-151/*.chs tests/bugs/issue-151/*.h + tests/bugs/issue-152/*.chs tests/bugs/issue-152/*.h source-repository head type: git diff --git a/src/C2HS/CHS.hs b/src/C2HS/CHS.hs --- a/src/C2HS/CHS.hs +++ b/src/C2HS/CHS.hs @@ -101,7 +101,7 @@ module C2HS.CHS (CHSModule(..), CHSFrag(..), CHSHook(..), CHSTrans(..), CHSChangeCase(..), CHSParm(..), CHSMarsh, CHSArg(..), CHSAccess(..), CHSAPath(..), CHSPtrType(..), CHSTypedefInfo, CHSDefaultMarsh, - Direction(..), + Direction(..), CHSPlusParmType(..), loadCHS, dumpCHS, hssuffix, chssuffix, loadCHI, dumpCHI, chisuffix, showCHSParm, apathToIdent, apathRootIdent, hasNonGNU, isParmWrapped) @@ -141,6 +141,7 @@ deriving instance Show CHSFrag deriving instance Show CHSHook deriving instance Show CHSAccess +deriving instance Show CHSPlusParmType deriving instance Show CHSParm deriving instance Show CHSTrans deriving instance Show CHSArg @@ -346,9 +347,12 @@ -- | Type default information type CHSDefaultMarsh = (Either Ident String, CHSArg) +-- | Special "+" parameter types. +data CHSPlusParmType = CHSPlusBare | CHSPlusS | CHSPlusNum Int + -- | marshalling descriptor for function hooks -- -data CHSParm = CHSPlusParm -- special "+" parameter +data CHSParm = CHSPlusParm CHSPlusParmType -- special "+" parameter | CHSParm CHSMarsh -- "in" marshaller String -- Haskell type Bool -- C repr: two values? @@ -708,7 +712,9 @@ Just ide -> showString " as " . showCHSIdent ide) showCHSParm :: CHSParm -> ShowS -showCHSParm CHSPlusParm = showChar '+' +showCHSParm (CHSPlusParm CHSPlusBare) = showChar '+' +showCHSParm (CHSPlusParm CHSPlusS) = showString "+S" +showCHSParm (CHSPlusParm (CHSPlusNum sz)) = showChar '+' . showString (show sz) showCHSParm (CHSParm oimMarsh hsTyStr twoCVals oomMarsh wrapped _ comment) = showOMarsh oimMarsh . showChar ' ' @@ -1246,7 +1252,9 @@ apathRootIdent (CHSRef apath _) = apathRootIdent apath parseParm :: [CHSToken] -> CST s (CHSParm, [CHSToken]) -parseParm (CHSTokPlus _:toks') = return (CHSPlusParm, toks') +parseParm (CHSTokPlus _:toks') = return (CHSPlusParm CHSPlusBare, toks') +parseParm (CHSTokPlusS _:toks') = return (CHSPlusParm CHSPlusS, toks') +parseParm (CHSTokPlusNum _ sz:toks') = return (CHSPlusParm (CHSPlusNum sz), toks') parseParm toks = do (oimMarsh, toks' ) <- parseOptMarsh 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 @@ -203,6 +203,8 @@ | CHSTokHat Position -- `^' | CHSTokPercent Position -- `%' | CHSTokPlus Position -- `+' + | CHSTokPlusS Position -- `+S' + | CHSTokPlusNum Position Int -- `+' | CHSTokLBrace Position -- `{' | CHSTokRBrace Position -- `}' | CHSTokLParen Position -- `(' @@ -332,6 +334,7 @@ posOf (CHSTokComment pos _) = pos posOf (CHSTokCIdentTail pos _) = pos posOf (CHSTokCArg pos _) = pos + posOf (CHSTokPercent pos) = pos instance Eq CHSToken where (CHSTokArrow _ ) == (CHSTokArrow _ ) = True @@ -416,6 +419,8 @@ showsPrec _ (CHSTokHat _ ) = showString "^" showsPrec _ (CHSTokPercent _ ) = showString "%" showsPrec _ (CHSTokPlus _ ) = showString "+" + showsPrec _ (CHSTokPlusS _ ) = showString "+S" + showsPrec _ (CHSTokPlusNum _ sz) = showString ("+" ++ show sz) showsPrec _ (CHSTokLBrace _ ) = showString "{" showsPrec _ (CHSTokRBrace _ ) = showString "}" showsPrec _ (CHSTokLParen _ ) = showString "(" @@ -902,12 +907,17 @@ >||< sym "^" CHSTokHat >||< sym "%" CHSTokPercent >||< sym "+" CHSTokPlus + >||< sym "+S" CHSTokPlusS + >||< sym_with_num "+" CHSTokPlusNum >||< sym "{" CHSTokLBrace >||< sym "}" CHSTokRBrace >||< sym "(" CHSTokLParen >||< sym ")" CHSTokRParen where sym cs con = string cs `lexaction` \_ pos -> Just (con pos) + sym_with_num cs con = + string cs +> digit +> digit`star` epsilon + `lexaction` \(_:ds) pos -> Just (con pos (read ds)) -- | string -- 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 @@ -151,7 +151,7 @@ -- friends import C2HS.CHS (CHSModule(..), CHSFrag(..), CHSHook(..), CHSParm(..), CHSMarsh, CHSArg(..), CHSAccess(..), CHSAPath(..), - CHSTypedefInfo, Direction(..), + CHSTypedefInfo, Direction(..), CHSPlusParmType(..), CHSPtrType(..), showCHSParm, apathToIdent, apathRootIdent) import C2HS.C.Info (CPrimType(..)) import C2HS.Gen.Monad (TransFun, transTabToTransFun, HsObject(..), GB, @@ -1284,8 +1284,8 @@ where countPlus :: [CHSParm] -> Int countPlus = sum . map (\p -> if isPlus p then 1 else 0) - isPlus CHSPlusParm = True - isPlus _ = False + isPlus (CHSPlusParm _) = True + isPlus _ = False join = concatMap (' ':) joinLines = concatMap (\s -> " " ++ s ++ "\n") -- @@ -1359,20 +1359,24 @@ marshBody (Left ide) = identToString ide marshBody (Right str) = "(" ++ str ++ ")" return (funArg, marshIn, callArgs, marshOut, retArg) - marshArg i CHSPlusParm = do - msize <- querySize $ internalIdent hsParmTy - case msize of - Nothing -> interr "Missing size for \"+\" parameter allocation!" - Just sz -> do - let a = "a" ++ show (i :: Int) - bdr1 = a ++ "'" - bdr2 = a ++ "''" - marshIn = impm "mallocForeignPtrBytes" ++ " " ++ show sz ++ - " >>= \\" ++ bdr2 ++ - " -> " ++ impm "withForeignPtr" ++ " " ++ bdr2 ++ - " $ \\" ++ bdr1 ++ " -> " - addHsDependency "Foreign.ForeignPtr" - return ("", marshIn, [bdr1], "", hsParmTy ++ " " ++ bdr2) + marshArg i (CHSPlusParm ptype) = do + szstr <- case ptype of + CHSPlusBare -> do + msize <- querySize $ internalIdent hsParmTy + case msize of + Nothing -> interr "Missing size for \"+\" parameter allocation!" + Just sz -> return $ show sz + CHSPlusS -> return $ "(sizeOf (undefined :: " ++ hsParmTy ++ "))" + CHSPlusNum sz -> return $ show sz + let a = "a" ++ show (i :: Int) + bdr1 = a ++ "'" + bdr2 = a ++ "''" + marshIn = impm "mallocForeignPtrBytes" ++ " " ++ szstr ++ + " >>= \\" ++ bdr2 ++ + " -> " ++ impm "withForeignPtr" ++ " " ++ bdr2 ++ + " $ \\" ++ bdr1 ++ " -> " + addHsDependency "Foreign.ForeignPtr" + return ("", marshIn, [bdr1], "", hsParmTy ++ " " ++ bdr2) marshArg _ _ = interr "GenBind.funDef: Missing default?" -- traceMarsh parms' parm' = traceGenBind $ @@ -1418,9 +1422,9 @@ -- -- match Haskell with C arguments (and results) -- - addDft ((CHSPlusParm):parms'') (_:cTys) = do + addDft (p@(CHSPlusParm _):parms'') (_:cTys) = do parms' <- addDft parms'' cTys - return (CHSPlusParm : parms') + return (p : parms') addDft ((CHSParm imMarsh hsTy False omMarsh _ p c):parms'') (cTy:cTys) = do imMarsh' <- addDftIn p imMarsh hsTy [cTy] omMarsh' <- addDftVoid omMarsh @@ -2467,8 +2471,18 @@ checkForIncomplete cdecl = do ct <- extractCompType False False False cdecl case ct of - SUET (CStruct _ _ Nothing _ _) -> incompleteTypeErr $ posOf cdecl - _ -> return () + SUET su -> do + let (fields, _) = structMembers su + ide = structName su + if (not . null $ fields) || isNothing ide + then return () + else do -- get the real... + tag' <- findTag (fromJust ide) -- ...definition + case tag' of + Just (StructUnionCT (CStruct _ _ Nothing _ _)) -> + incompleteTypeErr $ posOf cdecl + _ -> return () + _ -> return () sizeAlignOfSingle ptr cdecl = do 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 = "Budburst" -date = "26 October 2015" +versnick = "Eternal Sunshine" +date = "29 November 2015" 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/tests/bugs/issue-140/Issue140.chs b/tests/bugs/issue-140/Issue140.chs new file mode 100644 --- /dev/null +++ b/tests/bugs/issue-140/Issue140.chs @@ -0,0 +1,34 @@ +module Main where + +import Foreign.Storable +import Foreign.Ptr + +#include "issue140.h" + + +{#pointer *ptr1 as Ptr1 foreign newtype#} +{#pointer *ptr2 as Ptr2 foreign newtype#} +{#pointer *ptr3 as Ptr3 foreign newtype#} + +instance Storable Ptr2 where + sizeOf _ = 8 + alignment _ = 1 + peekElemOff p i = peekElemOff (castPtr p) i + pokeElemOff p i x = pokeElemOff (castPtr p) i x + +{#fun f1 as ^ {+, `Int'} -> `Ptr1'#} +{#fun f2 as ^ {+S, `Int'} -> `Ptr2'#} +{#fun f3 as ^ {+16, `Int'} -> `Ptr3'#} + + +main :: IO () +main = do + p1 <- f1 123 + p2 <- f2 456 + p3 <- f3 789 + chk1 <- withPtr1 p1 {#get ptr1->a#} + chk2 <- withPtr2 p2 {#get ptr2->a#} + chk3 <- withPtr3 p3 {#get ptr3->a#} + print chk1 + print chk2 + print chk3 diff --git a/tests/bugs/issue-140/issue140.c b/tests/bugs/issue-140/issue140.c new file mode 100644 --- /dev/null +++ b/tests/bugs/issue-140/issue140.c @@ -0,0 +1,5 @@ +#include "issue140.h" + +void f1(ptr1 *p, int x) { p->a = x; } +void f2(ptr2 *p, int x) { p->a = x; } +void f3(ptr3 *p, int x) { p->a = x; } diff --git a/tests/bugs/issue-140/issue140.h b/tests/bugs/issue-140/issue140.h new file mode 100644 --- /dev/null +++ b/tests/bugs/issue-140/issue140.h @@ -0,0 +1,8 @@ +typedef struct _ptr1 { int a; } ptr1; +void f1(ptr1 *p, int x); + +typedef struct _ptr2 { int a; } ptr2; +void f2(ptr2 *p, int x); + +typedef struct _ptr3 { int a; } ptr3; +void f3(ptr3 *p, int x); diff --git a/tests/bugs/issue-152/Issue152.chs b/tests/bugs/issue-152/Issue152.chs new file mode 100644 --- /dev/null +++ b/tests/bugs/issue-152/Issue152.chs @@ -0,0 +1,10 @@ +module Main where + +#include "issue152.h" + +f, g :: Int +f = {# sizeof a #} +g = {# sizeof s_a #} + +main :: IO () +main = putStrLn "OK" diff --git a/tests/bugs/issue-152/issue152.h b/tests/bugs/issue-152/issue152.h new file mode 100644 --- /dev/null +++ b/tests/bugs/issue-152/issue152.h @@ -0,0 +1,3 @@ +struct a { int f; }; + +typedef struct a s_a; diff --git a/tests/test-bugs.hs b/tests/test-bugs.hs --- a/tests/test-bugs.hs +++ b/tests/test-bugs.hs @@ -86,9 +86,11 @@ , testCase "Issue #133" issue133 , testCase "Issue #134" issue134 , testCase "Issue #136" issue136 + , testCase "Issue #140" issue140 , testCase "Issue #141" issue141 , testCase "Issue #149" issue149 , testCase "Issue #151" issue151 + , testCase "Issue #152" issue152 ] ++ -- Some tests that won't work on Windows. if os /= "cygwin32" && os /= "mingw32" @@ -109,6 +111,9 @@ let expected = ["upper C();", "lower c();", "upper C();"] liftIO $ assertBool "" (T.lines res == expected) +issue152 :: Assertion +issue152 = hs_only_build_issue 152 + issue151 :: Assertion issue151 = hs_only_build_issue 151 @@ -124,6 +129,9 @@ errExit False $ cmd "c2hs" $ "Issue141" <> suff <> ".chs" lastExitCode liftIO $ assertBool "" (all (/= 0) codes) + +issue140 :: Assertion +issue140 = expect_issue 140 ["123", "456", "789"] issue136 :: Assertion issue136 = build_issue_tolerant 136