Mate/Utilities.hs

   1 {-# LANGUAGE CPP #-}
   2 {-# LANGUAGE OverloadedStrings #-}
   3 module Mate.Utilities where
   4
   5 import Data.Word
   6 import qualified Data.Map as M
   7 import qualified Data.ByteString.Lazy as B
   8 import Data.List
   9
  10 import JVM.ClassFile
  11
  12 import Mate.Types
  13
  14
  15 buildMethodID :: Class Direct -> Word16 -> MethodInfo
  16 buildMethodID cls idx = MethodInfo (ntName nt) rc (ntSignature nt)
  17   where
  18     (rc, nt) = case constsPool cls M.! idx of
  19       (CMethod rc' nt') -> (rc', nt')
  20       (CIfaceMethod rc' nt') -> (rc', nt')
  21       _ -> error "buildMethodID: something wrong. abort."
  22
  23 buildStaticFieldID :: Class Direct -> Word16 -> StaticFieldInfo
  24 buildStaticFieldID cls idx = StaticFieldInfo rc (ntName fnt)
  25   where (CField rc fnt) = constsPool cls M.! idx
  26
  27 buildFieldOffset :: Class Direct -> Word16 -> (B.ByteString, B.ByteString)
  28 buildFieldOffset cls idx = (rc, ntName fnt)
  29   where (CField rc fnt) = constsPool cls M.! idx
  30
  31 buildClassID :: Class Direct -> Word16 -> B.ByteString
  32 buildClassID cls idx = cl
  33   where (CClass cl) = constsPool cls M.! idx
  34
  35 methodGetArgsCount :: Class Direct -> Word16 -> Word32
  36 methodGetArgsCount cls idx = fromIntegral $ length args
  37   where
  38     nt = case constsPool cls M.! idx of
  39       (CMethod _ nt') -> nt'
  40       (CIfaceMethod _ nt') -> nt'
  41       _ -> error "methodGetArgsCount: something wrong. abort."
  42     (MethodSignature args _) = ntSignature nt
  43
  44 -- TODO(bernhard): Extend it to more than just int, and provide typeinformation
  45 methodHaveReturnValue :: Class Direct -> Word16 -> Bool
  46 methodHaveReturnValue cls idx = case ret of
  47     ReturnsVoid -> False;
  48     (Returns BoolType) -> True
  49     (Returns CharByte) -> True
  50     (Returns IntType) -> True;
  51     (Returns (Array _ _)) -> True
  52     (Returns (ObjectType _)) -> True;
  53     _ -> error $ "methodHaveReturnValue: todo: " ++ show ret
  54   where
  55     nt = case constsPool cls M.! idx of
  56       (CMethod _ nt') -> nt'
  57       (CIfaceMethod _ nt') -> nt'
  58       _ -> error "methodHaveReturnValue: something wrong. abort."
  59     (MethodSignature _ ret) = ntSignature nt
  60
  61 lookupMethodSig :: B.ByteString -> MethodSignature -> Class Direct -> Maybe (Method Direct)
  62 lookupMethodSig name sig cls =
  63   find (\x -> methodName x == name && methodSignature x == sig) $ classMethods cls