module Mate.ClassHierarchy
( isInstanceOf
, addClassEntry
+ , addInterfaceEntry
) where
import qualified Data.Map as M
import qualified Data.ByteString.Lazy as B
-import Control.Applicative
+import Data.List
import Control.Monad
-import Text.Printf
-import Foreign
+import Foreign hiding (unsafePerformIO)
+import System.IO.Unsafe
import Data.IORef
import Mate.NativeSizes
data Class
- = Class
- { clMtable :: NativeWord
- , clSuperClass :: NativeWord
- , clInterfaces :: [Interface]
- }
+ = Class NativeWord [B.ByteString]
| JavaLangObject
- { clMtable :: NativeWord
- }
-data Interface
- = Interface
- { ifSuperInterfaces :: [Interface]
- }
-
-type HierMap = (M.Map NativeWord Class)
-classHier :: IORef HierMap
+type ClassHier = M.Map NativeWord Class
+classHier :: IORef ClassHier
{-# NOINLINE classHier #-}
classHier = unsafePerformIO $ newIORef M.empty
-readHier :: IO HierMap
-readHier = readIORef classHier
+type InterfaceHier = M.Map B.ByteString [B.ByteString]
+interfaceHier :: IORef InterfaceHier
+{-# NOINLINE interfaceHier #-}
+interfaceHier = unsafePerformIO $ newIORef M.empty
+
+readClass :: IO ClassHier
+readClass = readIORef classHier
+readInterface :: IO InterfaceHier
+readInterface = readIORef interfaceHier
-writeHier :: HierMap -> IO ()
-writeHier = writeIORef classHier
+writeClass :: ClassHier -> IO ()
+writeClass = writeIORef classHier
+writeInterface :: InterfaceHier -> IO ()
+writeInterface = writeIORef interfaceHier
isInstanceOf :: NativeWord -> B.ByteString -> IO Bool
isInstanceOf 0 _ = return False
isInstanceOf obj classname = do
obj_mtable <- peek (intPtrToPtr . fromIntegral $ obj)
- class_mtable <- getMethodTable classname
- ch <- readHier
- return $ checkInstance obj_mtable class_mtable ch
+ ch <- readClass
+ ih <- readInterface
+ if M.member classname ih
+ then do -- interface check
+ let ai = allInterfaces obj_mtable ch
+ return $ checkInterfaces ai classname ih
+ else do -- class check
+ class_mtable <- getMethodTable classname
+ return $ checkInstance obj_mtable class_mtable ch
+
+allInterfaces :: NativeWord -> ClassHier -> [B.ByteString]
+allInterfaces obj_mtable ch =
+ case ch M.! obj_mtable of
+ JavaLangObject -> []
+ Class superclass ifaces -> ifaces ++ allInterfaces superclass ch
-checkInstance :: NativeWord -> NativeWord -> HierMap -> Bool
+checkInterfaces :: [B.ByteString] -> B.ByteString -> InterfaceHier -> Bool
+checkInterfaces [] _ _ = False
+checkInterfaces ifaces target ih
+ | target `elem` ifaces = True
+ | otherwise = checkInterfaces (nextifaces \\ ifaces) target ih
+ where
+ nextifaces = concatMap (\x -> ih M.! x) ifaces
+
+checkInstance :: NativeWord -> NativeWord -> ClassHier -> Bool
checkInstance obj cl_mtable ch
| obj == cl_mtable = True
| otherwise =
case ch M.! obj of
- Class _ super _ -> checkInstance super cl_mtable ch
- JavaLangObject _ -> False
-
-addClassEntry :: NativeWord -> NativeWord -> IO ()
-addClassEntry mtable 0 = do
- ch <- readHier
- writeHier (M.insert mtable (JavaLangObject mtable) ch)
-addClassEntry mtable super_mtable = do
- ch <- readHier
- when (not $ M.member super_mtable ch) $ error "classhierarchy: superclass should be in hierarchy!"
- let cl = Class mtable super_mtable []
- writeHier (M.insert mtable cl ch)
+ Class super _ -> checkInstance super cl_mtable ch
+ JavaLangObject -> False
+
+addClassEntry :: NativeWord -> NativeWord -> [B.ByteString] -> IO ()
+addClassEntry mtable 0 _ = do
+ ch <- readClass
+ writeClass (M.insert mtable JavaLangObject ch)
+addClassEntry mtable super_mtable ifaces = do
+ ch <- readClass
+ unless (M.member super_mtable ch) $ error "classhierarchy: superclass should be in hierarchy!"
+ writeClass (M.insert mtable (Class super_mtable ifaces) ch)
+
+addInterfaceEntry :: B.ByteString -> [B.ByteString] -> IO ()
+addInterfaceEntry iface super_ifaces = do
+ ch <- readInterface
+ -- TODO: check super if's
+ writeInterface (M.insert iface super_ifaces ch)
super_mtable <- case superclass of
Nothing -> return 0
Just x -> getMethodTable $ ciName x
- addClassEntry mbase super_mtable
+ addClassEntry mbase super_mtable (interfaces cfile)
return new_ci
-- create index of methods by this interface
let mm = zipbase max_off (classMethods cfile)
- -- create for each method from *every* superinterface a entry to,
+ -- create for each method from *every* superinterface an entry too,
-- but just put in the same offset as it is already in the map
let (ifnames, methodnames) = unzip $ concat
[ zip (repeat ifname) (classMethods $ imap' M.! ifname)
-- merge all offset tables
setInterfaceMethodMap $ M.fromList sm `M.union` M.fromList mm `M.union` immap
setInterfaceMap $ M.insert path cfile imap'
+
+ -- add Interface to Hierarchy
+ addInterfaceEntry path (interfaces cfile)
where
zipbase base = zipWith (\x y -> (entry y, x + base)) [0,ptrSize..]
entry = getname path
--- /dev/null
+package tests;
+
+public class InstanceOf3 {
+ static interface i1 { };
+ static interface i2 { };
+ static interface i3 extends i2 { };
+ static interface i4 extends i3 { };
+ static interface i5 { };
+ static class c1 { };
+ static class c2 extends c1 implements i1 { };
+ static class c3 extends c2 implements i4 { };
+ static class c4 { };
+
+ public static void main(String []args) {
+ Object x = new c3();
+ checkInstance(x instanceof i1, "x", "i1");
+ checkInstance(x instanceof i2, "x", "i2");
+ checkInstance(x instanceof i3, "x", "i3");
+ checkInstance(x instanceof i4, "x", "i4");
+ checkInstance(x instanceof i5, "x", "i5");
+ checkInstance(x instanceof c1, "x", "c1");
+ checkInstance(x instanceof c2, "x", "c2");
+ checkInstance(x instanceof c3, "x", "c3");
+ checkInstance(x instanceof c4, "x", "c4");
+ checkInstance(x instanceof String, "x", "String");
+ checkInstance(x instanceof Integer, "x", "Integer");
+ checkInstance(x instanceof Object, "x", "Object");
+ }
+
+ public static void checkInstance(boolean cond, String obj, String classname) {
+ System.out.printf(obj);
+ if (cond) {
+ System.out.printf(" is instance of ");
+ System.out.printf(classname);
+ System.out.printf(" :-)\n");
+ } else {
+ System.out.printf(" is *not* instance of ");
+ System.out.printf(classname);
+ System.out.printf(" :-(\n");
+ }
+ }
+}