HSFFIG 1.1.2 → 1.1.3

raw patch · 8 files changed

+192/−38 lines, 8 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• HSFFIG.cabal +4/−1
• dist/build/ffipkg/ffipkg-tmp/C_Lexer.hs +7/−7
• dist/build/hsffig/hsffig-tmp/C_Lexer.hs +7/−7
• dist/build/testparser/testparser-tmp/C_Lexer.hs +7/−7
• programs/HsfUtils.hs +112/−1
• programs/Makefile.hs +1/−1
• programs/WriteHsc.hs +52/−12
• programs/ffipkg.hs +2/−2

@@ -1,5 +1,5 @@ Name:		HSFFIG-Version:	1.1.2+Version:	1.1.3 License:	BSD3 License-file:	License.txt Copyright:	2005 - 2009, Dimitry Golubovsky@@ -44,18 +44,21 @@ Executable:	ffipkg Main-is:	ffipkg.hs Hs-source-dirs:	programs+Ghc-options:    -threaded Other-modules:	C_Lexer, ProcHdr, TokenOps, C_BNF, SplitBounds,                  WriteHsc, Template, HsfUtils,                 HGmain, SPmain, Makefile Setupfile SetupfileNew  Executable:	hsffig Main-is:	hsffig.hs+Ghc-options:    -threaded Hs-source-dirs:	programs Other-modules:	HGmain,                 C_Lexer, ProcHdr, TokenOps, C_BNF, SplitBounds, WriteHsc, Template, HsfUtils  Executable:     testparser Main-is:        testparser.hs+Ghc-options:    -threaded Hs-source-dirs: programs Other-modules:  C_Lexer, ProcHdr, TokenOps, C_BNF, SplitBounds 

@@ -317,9 +317,9 @@ -- ----------------------------------------------------------------------------- -- INTERNALS and main scanner engine -{-# LINE 35 "templates/GenericTemplate.hs" #-}+{-# LINE 37 "templates/GenericTemplate.hs" #-} -{-# LINE 45 "templates/GenericTemplate.hs" #-}+{-# LINE 47 "templates/GenericTemplate.hs" #-}   data AlexAddr = AlexA# Addr#@@ -433,12 +433,12 @@   	let-		base   = alexIndexInt32OffAddr alex_base s-		(I# (ord_c)) = ord c-		offset = (base +# ord_c)-		check  = alexIndexInt16OffAddr alex_check offset+		!(base) = alexIndexInt32OffAddr alex_base s+		!((I# (ord_c))) = ord c+		!(offset) = (base +# ord_c)+		!(check)  = alexIndexInt16OffAddr alex_check offset 		-		new_s = if (offset >=# 0#) && (check ==# ord_c)+		!(new_s) = if (offset >=# 0#) && (check ==# ord_c) 			  then alexIndexInt16OffAddr alex_table offset 			  else alexIndexInt16OffAddr alex_deflt s 	in

@@ -317,9 +317,9 @@ -- ----------------------------------------------------------------------------- -- INTERNALS and main scanner engine -{-# LINE 35 "templates/GenericTemplate.hs" #-}+{-# LINE 37 "templates/GenericTemplate.hs" #-} -{-# LINE 45 "templates/GenericTemplate.hs" #-}+{-# LINE 47 "templates/GenericTemplate.hs" #-}   data AlexAddr = AlexA# Addr#@@ -433,12 +433,12 @@   	let-		base   = alexIndexInt32OffAddr alex_base s-		(I# (ord_c)) = ord c-		offset = (base +# ord_c)-		check  = alexIndexInt16OffAddr alex_check offset+		!(base) = alexIndexInt32OffAddr alex_base s+		!((I# (ord_c))) = ord c+		!(offset) = (base +# ord_c)+		!(check)  = alexIndexInt16OffAddr alex_check offset 		-		new_s = if (offset >=# 0#) && (check ==# ord_c)+		!(new_s) = if (offset >=# 0#) && (check ==# ord_c) 			  then alexIndexInt16OffAddr alex_table offset 			  else alexIndexInt16OffAddr alex_deflt s 	in

@@ -317,9 +317,9 @@ -- ----------------------------------------------------------------------------- -- INTERNALS and main scanner engine -{-# LINE 35 "templates/GenericTemplate.hs" #-}+{-# LINE 37 "templates/GenericTemplate.hs" #-} -{-# LINE 45 "templates/GenericTemplate.hs" #-}+{-# LINE 47 "templates/GenericTemplate.hs" #-}   data AlexAddr = AlexA# Addr#@@ -433,12 +433,12 @@   	let-		base   = alexIndexInt32OffAddr alex_base s-		(I# (ord_c)) = ord c-		offset = (base +# ord_c)-		check  = alexIndexInt16OffAddr alex_check offset+		!(base) = alexIndexInt32OffAddr alex_base s+		!((I# (ord_c))) = ord c+		!(offset) = (base +# ord_c)+		!(check)  = alexIndexInt16OffAddr alex_check offset 		-		new_s = if (offset >=# 0#) && (check ==# ord_c)+		!(new_s) = if (offset >=# 0#) && (check ==# ord_c) 			  then alexIndexInt16OffAddr alex_table offset 			  else alexIndexInt16OffAddr alex_deflt s 	in

@@ -2,10 +2,72 @@  module HsfUtils where +import C_Lexer+import C_BNF++import System.IO import System.Cmd import System.Exit import Data.Char+import Data.Maybe+import Data.Either+import System.Process+import Control.Concurrent+import Text.ParserCombinators.Parsec+import qualified Data.Map as Map +-- Guessed type of a constant (via #define).++data GuessType =+  NoGuess                       -- type cannot be guessed, not a valid constant+ |Vague                         -- most likely a constant, but cannot guess type, run via gcc+ |GuessInt                      -- guessed an integer constant+ |GuessFloat                    -- guessed a floating point constant+  deriving (Ord, Eq, Show)++-- Utility: pipe processes together. Two StdStream's must be supplied: for pipeline's+-- stdin and stdout. Stderr's of all processes are as set in the process creation+-- descriptors. List of process handles is returned as well as handles for pipe ends.++runPipe :: StdStream            -- stdin+        -> StdStream            -- stdout+        -> [CreateProcess]      -- processes (start at left, end at right)+        -> IO (Maybe Handle     -- pipe in+              ,Maybe Handle     -- pipe out+              ,[ProcessHandle]) -- same order as in the input list of descriptors++runPipe ins outs [] = return (Nothing, Nothing, [])++runPipe ins outs [p] = do+  let p' = p {std_in = ins, std_out = outs}+  (pin, pout, _, ph) <- createProcess p'+  return (pin, pout, [ph])++runPipe ins outs (pstart:ps) = do+  let pstart' = pstart {std_in = ins}+      prev@(pend:rps) = reverse (pstart':ps)+      pend' = pend {std_out = outs}+  piper (pend':rps) [] Nothing Nothing++piper :: [CreateProcess] +      -> [ProcessHandle] +      -> Maybe Handle+      -> Maybe Handle+      -> IO (Maybe Handle, Maybe Handle, [ProcessHandle])++piper [] phs pin pend = return (pin, pend, phs)++piper (p:ps) [] Nothing Nothing = do+  let p' = p {std_in = CreatePipe}+  (pin, pend, _, ph) <- createProcess p'+  piper ps [ph] pin pend++piper (p:ps) phs pin pend = do+  let p' = p {std_in = CreatePipe, std_out = UseHandle (fromJust pin)}+  (pin', _, _, ph) <- createProcess p'+  piper ps (ph:phs) pin' pend++ -- A version of words, but works with any lists on any predicate.  parts pred s = case dropWhile pred s of@@ -13,14 +75,63 @@                                      s' -> w : parts pred s''                                          where (w, s'') = break pred s' +-- Run a compiler over a stream of consts, resolving them via preprocessor,+-- try to guess their types.++guessConsts fn gcc cnsts = do+  let delimc = '%'+      onestr s = concat [[delimc], s]+      cnstrs = "#include " ++ fn ++ "\n" ++ (unlines $ map onestr cnsts)+      gccproc = CreateProcess {+                  cmdspec = RawCommand gcc ["-E", "-"]+                 ,cwd = Nothing+                 ,env = Nothing+                 ,std_in = Inherit+                 ,std_out = Inherit+                 ,std_err = Inherit+                 ,close_fds = True+                }+      grepproc = CreateProcess {+                   cmdspec = RawCommand "grep" [[delimc]]+                  ,cwd = Nothing+                  ,env = Nothing+                  ,std_in = Inherit+                  ,std_out = Inherit+                  ,std_err = Inherit+                  ,close_fds = True+                 }+  (mbin, mbout, ps) <- runPipe CreatePipe CreatePipe [gccproc, grepproc]+  case (mbin, mbout) of+    (Just i, Just h) -> do+      forkIO (hPutStrLn i cnstrs >> return ())+      s <- hGetContents h >>= return . lines+      let cprs = map (span (/= '%')) s+          tryp = zip cnsts (map (tryparse . tail . snd) cprs)+      mapM_ waitForProcess ps+      return tryp+    (_, _) -> return [("-- Error", tryparse "")]++tryparse "" = (NoGuess, [])++tryparse x = let t = scanHeader x+                 p = runParser constant_expression (PState 0 Map.empty) "" t         + in case (t, p) of+      (_, Left _) -> (NoGuess, [])+      ([TKC_HEX _ _], Right _) -> (GuessInt, t)+      ([TKC_OCT _ _], Right _) -> (GuessInt, t)+      ([TKC_DEC _ _], Right _) -> (GuessInt, t)+      ([TKC_EXP _ _], Right _) -> (GuessFloat, t)+      (_, Right _) -> (Vague, t)+ -- Run a compiler to check if a #define is good for inclusion into the -- produced .hsc code: a #define is a simple constant, w/o arguments. -testConst fn cnst gcc = system cmdline+testConst fn gcc cnst = rawSystem "sh" ["-c", cmdline]   where cmdline = "echo '#include " ++                    fn ++                   "\nstatic int a = " ++                   cnst ++ ";' | " ++ gcc ++ " -pipe -x c -fsyntax-only - 2>/dev/null"+  -- Based on the include file name availability, produce either the file / module names -- themselves or placeholders for further sed'ing.

@@ -43,7 +43,7 @@   map chr [9,9,36,40,66,65,83,69,41,95,67,46,111,32,36,40,66,65,83,69,41,95,83,46,111,32,36,40,66,65,83,69,41,46,111],   map chr [9,36,40,82,77,41,32,45,102,32,36,64],   map chr [9,36,40,65,82,41,32,99,113,32,36,64,32,36,40,66,65,83,69,41,95,104,115,99,46,111,32,36,40,69,88,84,82,65,95,79,66,74,41],-  map chr [9,36,40,70,73,78,68,41,32,46,32,45,110,97,109,101,32,39,36,40,66,65,83,69,41,42,46,111,39,32,124,32,36,40,71,82,69,80,41,32,39,115,112,108,105,116,47,39,32,124,32,36,40,109,97,107,101,45,108,105,98,114,97,114,121,41],+  map chr [9,36,40,70,73,78,68,41,32,46,32,45,110,97,109,101,32,39,36,40,66,65,83,69,41,42,46,111,39,32,124,32,36,40,71,82,69,80,41,32,45,69,32,39,115,112,108,105,116,47,124,115,116,117,98,39,32,124,32,36,40,109,97,107,101,45,108,105,98,114,97,114,121,41],   map chr [],   map chr [],   map chr [37,46,104,105,32,37,46,111,32,58,32,37,46,104,115],

@@ -14,6 +14,8 @@ import Data.List import Control.Monad import System.IO+import Control.Concurrent+import GHC.Conc  -- Name for the HSFFIG field access class, and module to import @@ -109,27 +111,62 @@ -- This requires knowledge of the header file name. Therefore if it was impossible -- to determine it, constants will not be included. -writeConstAccess tus gcc Nothing = return ()-writeConstAccess tus gcc (Just fn) = -  do let cnsts = Map.keys $ Map.filterWithKey constonly tus+writeConstAccess _ _ Nothing = return ()+writeConstAccess tus gcc mbfn@(Just fn) = do+  let    cnsts = Map.keys $ Map.filterWithKey constonly tus          constonly _ DictDef = True          constonly _ _ = False-         fmfnc = (finalizeModuleName (Just fn)) ++ "_C"+  nsect <- writeConstAccess' 0 cnsts gcc mbfn+  let fmfnc = (finalizeModuleName (Just fn)) ++ "_C"+      cmods = map (((fmfnc ++ "_") ++) . show) [0 .. (nsect - 1)]+  putStrLn $ "\n" ++ splitBegin ++ "/" ++ fmfnc ++ "\n"+  writeSplitHeaderX cmods cmods fmfnc+  putStrLn $ "\n" ++ splitEnd ++ "\n"+  return ()++writeConstAccess' n [] _ _ = return n+writeConstAccess' n tusd gcc Nothing = return 0+writeConstAccess' n tusd gcc (Just fn) = +  do let cnsts = take 100 tusd+         trem = drop 100 tusd+         fmfnc = (finalizeModuleName (Just fn)) ++ "_C_" ++ show n+         finfn = finalizeFileName (Just fn)      putStrLn $ "\n" ++ splitBegin ++ "/" ++ fmfnc ++ "\n"      writeSplitHeader [] fmfnc-     mapM (oneconst fn gcc) cnsts +     guess <- guessConsts finfn gcc cnsts >>= return . filter ((/= NoGuess) . fst . snd)+     let vagues = filter ((== Vague) . fst . snd) guess+         ints = filter ((== GuessInt) . fst . snd) guess+         floats = filter ((== GuessFloat) . fst . snd) guess+     mapM (oneconst ExitSuccess) (map fst ints)+     mapM (oneconst ExitSuccess) (map fst floats)+     testsyn (testConst finfn gcc) (map fst vagues)      putStrLn $ "\n" ++ splitEnd ++ "\n"-     return ()+     writeConstAccess' (n + 1) trem gcc (Just fn) +testsyn fn [] = return ()++testsyn fn cs = do+  let nproc = 4+  let h = take nproc cs+      t = drop nproc cs+  let nt = length h+  mvs <- mapM (\_ -> newEmptyMVar) h+  hx <- zipWithM (\c v -> forkOS (do+    x <- fn c+    putMVar v x)) h mvs+  whx <- mapM takeMVar mvs+  zipWithM oneconst whx h+  testsyn fn t++ -- No import for #define alloca. -oneconst _ _ "alloca" = return ()+oneconst _ "alloca" = return () -oneconst fn gcc cnst = -  do rc <- testConst (finalizeFileName (Just fn)) cnst gcc-     case rc of-          ExitSuccess -> putStrLn $ "c_" ++ cnst ++ " = #const " ++ cnst-          _ -> return ()+oneconst rc cnst = +  case rc of+    ExitSuccess -> (putStrLn $ "c_" ++ cnst ++ " = #const " ++ cnst) >> hFlush stdout+    _ -> return ()  --------------------------------------------------------------------------------------- @@ -820,11 +857,13 @@ mapc2hs (TString "short") = TString' "CShort" mapc2hs (TString "unsigned_short") = TString' "CUShort" mapc2hs (TString "short_int") = TString' "CShort"+mapc2hs (TString "signed_short") = TString' "CShort" mapc2hs (TString "signed_short_int") = TString' "CShort" mapc2hs (TString "unsigned_short_int") = TString' "CUShort" mapc2hs (TString "char") = TString' "CChar" mapc2hs (TString "signed_char") = TString' "CSChar" mapc2hs (TString "unsigned_char") = TString' "CUChar"+mapc2hs (TString "signed_long") = TString' "CLong" mapc2hs (TString "long") = TString' "CLong" mapc2hs (TString "unsigned_long") = TString' "CULong" mapc2hs (TString "long_int") = TString' "CLong"@@ -1007,6 +1046,7 @@ isdirstruct ts = checktsrec isd ts where   isd (TString  ('@':_)) = True   isd (TString' ('@':_)) = True+  isd (TString' "CJmpBuf") = True   isd _ = False  -- Output a FFI declaration of a function or a variable.

@@ -288,7 +288,7 @@  fileToFd :: FilePath -> IO Fd -fileToFd s = openFd s WriteOnly (Just 420) defaultFileFlags+fileToFd s = openFd s WriteOnly (Just 420) (defaultFileFlags {trunc = True})  -- Redirect a Fd in a forked process. -- Credits to Donn Cave for the tip how to redirect stdout.@@ -490,7 +490,7 @@   hPutStrLn cabfd $ "Name: " ++ pkgName dopt   hPutStrLn cabfd $ "Version: " ++ pkgVersion dopt   hPutStrLn cabfd $ "Build-type: Custom"-  hPutStrLn cabfd $ "Build-depends: base, HSFFIG"+  hPutStrLn cabfd $ "Build-depends: base >= 4.0 && < 5, HSFFIG"   hPutStrLn cabfd $ "Exposed-modules: " ++ head modlist   hPutStrLn cabfd $ "Other-modules:\n" ++ intlv (map ("  " ++) (drop 1 modlist)) ",\n"   when (length (libDirs dopt) > 0) $