c2hs 0.26.2 → 0.27.1
raw patch · 12 files changed
+140/−28 lines, 12 files
Files
- ChangeLog +10/−0
- c2hs.cabal +3/−1
- src/C2HS/CHS.hs +12/−4
- src/C2HS/CHS/Lexer.hs +10/−0
- src/C2HS/Gen/Bind.hs +35/−21
- src/C2HS/Version.hs +2/−2
- tests/bugs/issue-140/Issue140.chs +34/−0
- tests/bugs/issue-140/issue140.c +5/−0
- tests/bugs/issue-140/issue140.h +8/−0
- tests/bugs/issue-152/Issue152.chs +10/−0
- tests/bugs/issue-152/issue152.h +3/−0
- tests/test-bugs.hs +8/−0
ChangeLog view
@@ -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)
c2hs.cabal view
@@ -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
src/C2HS/CHS.hs view
@@ -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
src/C2HS/CHS/Lexer.hs view
@@ -203,6 +203,8 @@ | CHSTokHat Position -- `^' | CHSTokPercent Position -- `%' | CHSTokPlus Position -- `+'+ | CHSTokPlusS Position -- `+S'+ | CHSTokPlusNum Position Int -- `+<num>' | 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 --
src/C2HS/Gen/Bind.hs view
@@ -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
src/C2HS/Version.hs view
@@ -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"
+ tests/bugs/issue-140/Issue140.chs view
@@ -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
+ tests/bugs/issue-140/issue140.c view
@@ -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; }
+ tests/bugs/issue-140/issue140.h view
@@ -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);
+ tests/bugs/issue-152/Issue152.chs view
@@ -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"
+ tests/bugs/issue-152/issue152.h view
@@ -0,0 +1,3 @@+struct a { int f; };++typedef struct a s_a;
tests/test-bugs.hs view
@@ -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