+#ifdef DBG_BB
+printMapBB :: Maybe MapBB -> IO ()
+printMapBB Nothing = putStrLn "No BasicBlock"
+printMapBB (Just hmap) = do
+ putStr "BlockIDs: "
+ let keys = M.keys hmap
+ mapM_ (putStr . (flip (++)) ", " . show) keys
+ putStrLn "\n\nBasicBlocks:"
+ printMapBB' keys hmap
+ where
+ printMapBB' :: [BlockID] -> MapBB -> IO ()
+ printMapBB' [] _ = return ()
+ printMapBB' (i:is) hmap' = case M.lookup i hmap' of
+ Just bb -> do
+ putStrLn $ "Block " ++ (show i)
+ mapM_ putStrLn (map ((++) "\t" . show) $ code bb)
+ case successor bb of
+ Return -> putStrLn ""
+ FallThrough t1 -> putStrLn $ "Sucessor: " ++ (show t1) ++ "\n"
+ OneTarget t1 -> putStrLn $ "Sucessor: " ++ (show t1) ++ "\n"
+ TwoTarget t1 t2 -> putStrLn $ "Sucessor: " ++ (show t1) ++ ", " ++ (show t2) ++ "\n"
+ printMapBB' is hmap
+ Nothing -> error $ "BlockID " ++ show i ++ " not found."
+#endif
+
+#if 0
+#ifdef DBG_BB
+testInstance :: String -> B.ByteString -> MethodSignature -> IO ()
+testInstance cf method sig = do
+ cls <- parseClassFile cf
+ hmap <- parseMethod cls method sig
+ printMapBB hmap
+#endif
+
+#ifdef DBG_BB
+test_main :: IO ()
+test_main = do
+ test_01
+ test_02
+ test_03
+ test_04
+
+test_01, test_02, test_03, test_04 :: IO ()
+test_01 = testInstance "./tests/Fib.class" "fib"
+test_02 = testInstance "./tests/While.class" "f"
+test_03 = testInstance "./tests/While.class" "g"
+test_04 = testInstance "./tests/Fac.class" "fac"
+#endif
+#endif
+
+
+parseMethod :: Class Direct -> B.ByteString -> MethodSignature -> IO (Maybe MapBB)
+parseMethod cls method sig = do
+ let maybe_bb = testCFG $ lookupMethodSig method sig cls
+ let msig = methodSignature $ classMethods cls !! 1
+ printfBb "BB: analysing \"%s\"\n" $ toString (method `B.append` ": " `B.append` encode msig)
+#ifdef DBG_BB
+ printMapBB maybe_bb
+#endif
+ -- small example how to get information about
+ -- exceptions of a method
+ -- TODO: remove ;-)
+ let (Just m) = lookupMethodSig method sig cls
+ case attrByName m "Code" of
+ Nothing -> printfBb "exception: no handler for this method\n"
+ Just exceptionstream -> printfBb "exception: \"%s\"\n" (show $ codeExceptions $ decodeMethod exceptionstream)
+ return maybe_bb
+
+
+testCFG :: Maybe (Method Direct) -> Maybe MapBB
+testCFG m = do
+ m' <- m
+ bytecode <- attrByName m' "Code"
+ return $ buildCFG $ codeInstructions $ decodeMethod bytecode
+
+
+buildCFG :: [Instruction] -> MapBB
+buildCFG xs = buildCFG' M.empty xs' xs'
+ where
+ xs' :: [OffIns]
+ xs' = markBackwardTargets $ calculateInstructionOffset xs
+
+-- get already calculated jmp-targets and mark the predecessor of the
+-- target-instruction as "FallThrough". we just care about backwards
+-- jumps here (forward jumps are handled in buildCFG')
+markBackwardTargets :: [OffIns] -> [OffIns]
+markBackwardTargets [] = []
+markBackwardTargets (x:[]) = [x]
+markBackwardTargets insns@(x@((x_off,x_bbend),x_ins):y@((y_off,_),_):xs) =
+ x_new:markBackwardTargets (y:xs)
+ where
+ x_new = if isTarget then checkX y_off else x
+ checkX w16 = case x_bbend of
+ Just _ -> x -- already marked, don't change
+ Nothing -> ((x_off, Just $ FallThrough w16), x_ins) -- mark previous insn