X-Git-Url: http://wien.tomnetworks.com/gitweb/?a=blobdiff_plain;f=JVM%2FConverter.hs;h=777bac62b85ab2816406339553cde633ecbc7c30;hb=d47b4af2d4cf72352782e8c88a6e03670ca15737;hp=e53f380233bbdf60895fedddc30cea16091bee29;hpb=896d879a67070b87b0d5b9a1e8145bb6be1eebe8;p=hs-java.git

diff --git a/JVM/Converter.hs b/JVM/Converter.hs
index e53f380..777bac6 100644
--- a/JVM/Converter.hs
+++ b/JVM/Converter.hs
@@ -21,21 +21,21 @@ import qualified Data.Set as S
 import qualified Data.Map as M
 
 import JVM.ClassFile
-import JVM.Types
+import JVM.Common
 import JVM.Exceptions
 
 -- | Parse .class file data
-parseClass :: B.ByteString -> Class Resolved
+parseClass :: B.ByteString -> Class Direct
 parseClass bstr = convertClass $ decode bstr
 
 -- | Parse class data from file
-parseClassFile :: FilePath -> IO (Class Resolved)
+parseClassFile :: FilePath -> IO (Class Direct)
 parseClassFile path = convertClass `fmap` decodeFile path
 
-encodeClass :: (Class Resolved) -> B.ByteString
+encodeClass :: (Class Direct) -> B.ByteString
 encodeClass cls = encode $ classFile cls
 
-convertClass :: Class Pointers -> Class Resolved
+convertClass :: Class File -> Class Direct
 convertClass (Class {..}) =
   let pool = constantPoolArray constsPool
       superName = className $ pool ! superClass
@@ -57,7 +57,7 @@ convertClass (Class {..}) =
       classAttributesCount = classAttributesCount,
       classAttributes = convertAttrs pool classAttributes }
 
-classFile :: Class Resolved -> Class Pointers
+classFile :: Class Direct -> Class File
 classFile (Class {..}) = Class {
     magic = 0xCAFEBABE,
     minorVersion = 0,
@@ -73,17 +73,19 @@ classFile (Class {..}) = Class {
     classFields = map (fieldInfo poolInfo) classFields,
     classMethodsCount = fromIntegral (length classMethods),
     classMethods = map (methodInfo poolInfo) classMethods,
-    classAttributesCount = fromIntegral (M.size classAttributes),
-    classAttributes = map (attrInfo poolInfo) (M.assocs classAttributes) }
+    classAttributesCount = fromIntegral $ arsize classAttributes,
+    classAttributes = to (arlist classAttributes) }
   where
     poolInfo = toCPInfo constsPool
+    to :: [(B.ByteString, B.ByteString)] -> Attributes File
+    to pairs = AP (map (attrInfo poolInfo) pairs)
 
-toCPInfo :: Pool Resolved -> Pool Pointers
+toCPInfo :: Pool Direct -> Pool File
 toCPInfo pool = result
   where
     result = M.map cpInfo pool
 
-    cpInfo :: Constant Resolved -> Constant Pointers
+    cpInfo :: Constant Direct -> Constant File
     cpInfo (CClass name) = CClass (force "class" $ poolIndex result name)
     cpInfo (CField cls name) =
       CField (force "field a" $ poolClassIndex result cls) (force "field b" $ poolNTIndex result name)
@@ -98,12 +100,12 @@ toCPInfo pool = result
     cpInfo (CDouble x) = CDouble x
     cpInfo (CNameType n t) =
       CNameType (force "name" $ poolIndex result n) (force "type" $ poolIndex result t)
-    cpInfo (CUTF8 s) = CUTF8 (fromIntegral $ B.length s) s
-    cpInfo (CUnicode s) = CUnicode (fromIntegral $ B.length s) s
+    cpInfo (CUTF8 s) = CUTF8 s
+    cpInfo (CUnicode s) = CUnicode s
 
 -- | Find index of given string in the list of constants
-poolIndex :: (Throws NoItemInPool e) => Pool Pointers -> B.ByteString -> EM e Word16
-poolIndex list name = case findIndex test list of
+poolIndex :: (Throws NoItemInPool e) => Pool File -> B.ByteString -> EM e Word16
+poolIndex list name = case findIndex test (M.elems list) of
                         Nothing -> throw (NoItemInPool name)
                         Just i ->  return $ fromIntegral $ i+1
   where
@@ -112,10 +114,10 @@ poolIndex list name = case findIndex test list of
     test _                                  = False
 
 -- | Find index of given string in the list of constants
-poolClassIndex :: (Throws NoItemInPool e) => Pool Pointers -> B.ByteString -> EM e Word16
-poolClassIndex list name = case findIndex checkString list of
+poolClassIndex :: (Throws NoItemInPool e) => Pool File -> B.ByteString -> EM e Word16
+poolClassIndex list name = case findIndex checkString (M.elems list) of
                         Nothing -> throw (NoItemInPool name)
-                        Just i ->  case findIndex (checkClass $ fromIntegral $ i+1) list of
+                        Just i ->  case findIndex (checkClass $ fromIntegral $ i+1) (M.elems list) of
                                      Nothing -> throw (NoItemInPool $ i+1)
                                      Just j  -> return $ fromIntegral $ j+1
   where
@@ -129,7 +131,7 @@ poolClassIndex list name = case findIndex checkString list of
 poolNTIndex list x@(NameType n t) = do
     ni <- poolIndex list n
     ti <- poolIndex list (byteString t)
-    case findIndex (check ni ti) list of
+    case findIndex (check ni ti) (M.elems list) of
       Nothing -> throw (NoItemInPool x)
       Just i  -> return $ fromIntegral (i+1)
   where
@@ -137,35 +139,41 @@ poolNTIndex list x@(NameType n t) = do
       | (ni == n') && (ti == t') = True
     check _ _ _                  = False
 
-fieldInfo :: Pool Pointers -> Field Resolved -> Field Pointers
+fieldInfo :: Pool File -> Field Direct -> Field File
 fieldInfo pool (Field {..}) = Field {
-  fieldAccessFlags = access2word16 fieldAccessFlags,
-  fieldName = force "field name" $ poolIndex pool fieldName,
-  fieldSignature = force "signature" $ poolIndex pool (encode fieldSignature),
-  fieldAttributesCount = fromIntegral (M.size fieldAttributes),
-  fieldAttributes = map (attrInfo pool) (M.assocs fieldAttributes) }
+    fieldAccessFlags = access2word16 fieldAccessFlags,
+    fieldName = force "field name" $ poolIndex pool fieldName,
+    fieldSignature = force "signature" $ poolIndex pool (encode fieldSignature),
+    fieldAttributesCount = fromIntegral (arsize fieldAttributes),
+    fieldAttributes = to (arlist fieldAttributes) }
+  where
+    to :: [(B.ByteString, B.ByteString)] -> Attributes File
+    to pairs = AP (map (attrInfo pool) pairs)
 
-methodInfo :: Pool Pointers -> Method Resolved -> Method Pointers
+methodInfo :: Pool File -> Method Direct -> Method File
 methodInfo pool (Method {..}) = Method {
-  methodAccessFlags = access2word16 methodAccessFlags,
-  methodName = force "method name" $ poolIndex pool methodName,
-  methodSignature = force "method sig" $ poolIndex pool (encode methodSignature),
-  methodAttributesCount = fromIntegral (M.size methodAttributes),
-  methodAttributes = map (attrInfo pool) (M.assocs methodAttributes) }
+    methodAccessFlags = access2word16 methodAccessFlags,
+    methodName = force "method name" $ poolIndex pool methodName,
+    methodSignature = force "method sig" $ poolIndex pool (encode methodSignature),
+    methodAttributesCount = fromIntegral (arsize methodAttributes),
+    methodAttributes = to (arlist methodAttributes) }
+  where
+    to :: [(B.ByteString, B.ByteString)] -> Attributes File
+    to pairs = AP (map (attrInfo pool) pairs)
 
-attrInfo :: Pool Pointers -> (B.ByteString, B.ByteString) -> Attributes Pointers
+attrInfo :: Pool File -> (B.ByteString, B.ByteString) -> Attribute
 attrInfo pool (name, value) = Attribute {
   attributeName = force "attr name" $ poolIndex pool name,
   attributeLength = fromIntegral (B.length value),
   attributeValue = value }
 
-constantPoolArray :: Pool Pointers -> Pool Resolved
+constantPoolArray :: Pool File -> Pool Direct
 constantPoolArray ps = pool
   where
-    pool :: Pool
+    pool :: Pool Direct
     pool = M.map convert ps
 
-    n = fromIntegral $ length ps
+    n = fromIntegral $ M.size ps
 
     convertNameType :: (HasSignature a, Binary (Signature a)) => Word16 -> NameType a
     convertNameType i =
@@ -182,10 +190,10 @@ constantPoolArray ps = pool
     convert (CLong x)    = CLong (fromIntegral x)
     convert (CDouble x)  = CDouble x
     convert (CNameType i j) = CNameType (getString $ pool ! i) (getString $ pool ! j)
-    convert (CUTF8 _ bs) = CUTF8 bs
-    convert (CUnicode _ bs) = CUnicode bs
+    convert (CUTF8 bs) = CUTF8 bs
+    convert (CUnicode bs) = CUnicode bs
 
-convertAccess :: AccessFlags Pointers -> AccessFlags Resolved
+convertAccess :: AccessFlags File -> AccessFlags Direct
 convertAccess w = S.fromList $ concat $ zipWith (\i f -> if testBit w i then [f] else []) [0..] $ [
    ACC_PUBLIC,
    ACC_PRIVATE,
@@ -199,43 +207,48 @@ convertAccess w = S.fromList $ concat $ zipWith (\i f -> if testBit w i then [f]
    ACC_INTERFACE,
    ACC_ABSTRACT ]
 
-access2word16 :: AccessFlags Resolved -> AccessFlags Pointers
+access2word16 :: AccessFlags Direct -> AccessFlags File
 access2word16 fs = bitsOr $ map toBit $ S.toList fs
   where
     bitsOr = foldl (.|.) 0
     toBit f = 1 `shiftL` (fromIntegral $ fromEnum f)
 
-convertField :: Pool Resolved -> Field Pointers -> Field Resolved
+convertField :: Pool Direct -> Field File -> Field Direct
 convertField pool (Field {..}) = Field {
   fieldAccessFlags = convertAccess fieldAccessFlags,
   fieldName = getString $ pool ! fieldName,
   fieldSignature = decode $ getString $ pool ! fieldSignature,
+  fieldAttributesCount = fromIntegral (apsize fieldAttributes),
   fieldAttributes = convertAttrs pool fieldAttributes }
 
-convertMethod :: Pool Resolved -> Method Pointers -> Method Resolved
+convertMethod :: Pool Direct -> Method File -> Method Direct
 convertMethod pool (Method {..}) = Method {
   methodAccessFlags = convertAccess methodAccessFlags,
   methodName = getString $ pool ! methodName,
   methodSignature = decode $ getString $ pool ! methodSignature,
+  methodAttributesCount = fromIntegral (apsize methodAttributes),
   methodAttributes = convertAttrs pool methodAttributes }
 
-convertAttrs :: Pool Resolved -> Attributes Pointers -> Attributes Resolved
-convertAttrs pool attrs = M.fromList $ map go attrs
+convertAttrs :: Pool Direct -> Attributes File -> Attributes Direct
+convertAttrs pool (AP attrs) = AR (M.fromList $ map go attrs)
   where
+    go :: Attribute -> (B.ByteString, B.ByteString)
     go (Attribute {..}) = (getString $ pool ! attributeName,
                            attributeValue)
 
 -- | Try to get class method by name
-methodByName :: Class Resolved -> B.ByteString -> Maybe (Method Resolved)
+methodByName :: Class Direct -> B.ByteString -> Maybe (Method Direct)
 methodByName cls name =
   find (\m -> methodName m == name) (classMethods cls)
 
 -- | Try to get object attribute by name
-attrByName :: (HasAttributes a) => a Resolved -> B.ByteString -> Maybe B.ByteString
-attrByName x name = M.lookup name (attributes x)
+attrByName :: (HasAttributes a) => a Direct -> B.ByteString -> Maybe B.ByteString
+attrByName x name =
+  let (AR m) = attributes x
+  in  M.lookup name m
 
 -- | Try to get Code for class method (no Code for interface methods)
-methodCode :: Class Resolved
+methodCode :: Class Direct
            -> B.ByteString       -- ^ Method name
            -> Maybe B.ByteString
 methodCode cls name = do