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

diff --git a/JVM/Converter.hs b/JVM/Converter.hs
index 41cf05f..777bac6 100644
--- a/JVM/Converter.hs
+++ b/JVM/Converter.hs
@@ -3,153 +3,197 @@
 -- high-level Java classes, methods etc representation
 module JVM.Converter
   (parseClass, parseClassFile,
-   convertClass,
+   convertClass, classFile,
+   encodeClass,
    methodByName,
    attrByName,
    methodCode
   )
   where
 
+import Control.Monad.Exception
 import Data.List
 import Data.Word
 import Data.Bits
 import Data.Binary
 import qualified Data.ByteString.Lazy as B
-import Data.Array
 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
+parseClass :: B.ByteString -> Class Direct
 parseClass bstr = convertClass $ decode bstr
 
 -- | Parse class data from file
-parseClassFile :: FilePath -> IO Class
+parseClassFile :: FilePath -> IO (Class Direct)
 parseClassFile path = convertClass `fmap` decodeFile path
 
-encodeClass :: Class -> B.ByteString
+encodeClass :: (Class Direct) -> B.ByteString
 encodeClass cls = encode $ classFile cls
 
-convertClass :: ClassFile -> Class
-convertClass (ClassFile {..}) =
+convertClass :: Class File -> Class Direct
+convertClass (Class {..}) =
   let pool = constantPoolArray constsPool
       superName = className $ pool ! superClass
   in Class {
-      constantPool = pool,
-      classAccess = convertAccess accessFlags,
-      this = className $ pool ! thisClass,
-      super = if superClass == 0 then Nothing else Just superName,
-      implements = map (\i -> className $ pool ! i) interfaces,
-      fields = map (convertField pool) classFields,
-      methods = map (convertMethod pool) classMethods,
-      classAttrs = convertAttrs pool classAttributes }
-
-classFile :: Class -> ClassFile
-classFile (Class {..}) = ClassFile {
+      magic = 0xCAFEBABE,
+      minorVersion = 0,
+      majorVersion = 50,
+      constsPoolSize = fromIntegral (M.size pool),
+      constsPool = pool,
+      accessFlags = convertAccess accessFlags,
+      thisClass = className $ pool ! thisClass,
+      superClass = if superClass == 0 then "" else superName,
+      interfacesCount = interfacesCount,
+      interfaces = map (\i -> className $ pool ! i) interfaces,
+      classFieldsCount = classFieldsCount,
+      classFields = map (convertField pool) classFields,
+      classMethodsCount = classMethodsCount,
+      classMethods = map (convertMethod pool) classMethods,
+      classAttributesCount = classAttributesCount,
+      classAttributes = convertAttrs pool classAttributes }
+
+classFile :: Class Direct -> Class File
+classFile (Class {..}) = Class {
     magic = 0xCAFEBABE,
     minorVersion = 0,
     majorVersion = 50,
-    constsPoolSize = fromIntegral (length poolInfo),
+    constsPoolSize = fromIntegral (M.size poolInfo + 1),
     constsPool = poolInfo,
-    accessFlags = access2word16 classAccess,
-    thisClass = poolIndex poolInfo this,
-    superClass = poolIndex poolInfo this,
-    interfacesCount = fromIntegral (length implements),
-    interfaces = map (poolIndex poolInfo) implements,
-    classFieldsCount = fromIntegral (length fields),
-    classFields = map (fieldInfo poolInfo) fields,
-    classMethodsCount = fromIntegral (length methods),
-    classMethods = map (methodInfo poolInfo) methods,
-    classAttributesCount = fromIntegral (M.size classAttrs),
-    classAttributes = map (attrInfo poolInfo) (M.assocs classAttrs) }
+    accessFlags = access2word16 accessFlags,
+    thisClass = force "this" $ poolClassIndex poolInfo thisClass,
+    superClass = force "super" $ poolClassIndex poolInfo superClass,
+    interfacesCount = fromIntegral (length interfaces),
+    interfaces = map (force "ifaces" . poolIndex poolInfo) interfaces,
+    classFieldsCount = fromIntegral (length classFields),
+    classFields = map (fieldInfo poolInfo) classFields,
+    classMethodsCount = fromIntegral (length classMethods),
+    classMethods = map (methodInfo poolInfo) classMethods,
+    classAttributesCount = fromIntegral $ arsize classAttributes,
+    classAttributes = to (arlist classAttributes) }
   where
-    poolInfo = toCPInfo constantPool
+    poolInfo = toCPInfo constsPool
+    to :: [(B.ByteString, B.ByteString)] -> Attributes File
+    to pairs = AP (map (attrInfo poolInfo) pairs)
 
-toCPInfo :: Pool -> [CpInfo]
+toCPInfo :: Pool Direct -> Pool File
 toCPInfo pool = result
   where
-    result = map cpInfo $ elems pool
+    result = M.map cpInfo pool
 
-    cpInfo (CClass name) = CONSTANT_Class (poolIndex result name)
+    cpInfo :: Constant Direct -> Constant File
+    cpInfo (CClass name) = CClass (force "class" $ poolIndex result name)
     cpInfo (CField cls name) =
-      CONSTANT_Fieldref (poolIndex result cls) (poolIndex result name)
+      CField (force "field a" $ poolClassIndex result cls) (force "field b" $ poolNTIndex result name)
     cpInfo (CMethod cls name) =
-      CONSTANT_Methodref (poolIndex result cls) (poolIndex result name)
+      CMethod (force "method a" $ poolClassIndex result cls) (force ("method b: " ++ show name) $ poolNTIndex result name)
     cpInfo (CIfaceMethod cls name) =
-      CONSTANT_InterfaceMethodref (poolIndex result cls) (poolIndex result name)
-    cpInfo (CString s) = CONSTANT_String (poolIndex result s)
-    cpInfo (CInteger x) = CONSTANT_Integer x
-    cpInfo (CFloat x) = CONSTANT_Float x
-    cpInfo (CLong x) = CONSTANT_Long (fromIntegral x)
-    cpInfo (CDouble x) = CONSTANT_Double x
+      CIfaceMethod (force "iface method a" $ poolIndex result cls) (force "iface method b" $ poolNTIndex result name)
+    cpInfo (CString s) = CString (force "string" $ poolIndex result s)
+    cpInfo (CInteger x) = CInteger x
+    cpInfo (CFloat x) = CFloat x
+    cpInfo (CLong x) = CLong (fromIntegral x)
+    cpInfo (CDouble x) = CDouble x
     cpInfo (CNameType n t) =
-      CONSTANT_NameAndType (poolIndex result n) (poolIndex result t)
-    cpInfo (CUTF8 s) = CONSTANT_Utf8 (fromIntegral $ B.length s) s
-    cpInfo (CUnicode s) = CONSTANT_Unicode (fromIntegral $ B.length s) s
-
-poolIndex :: [CpInfo] -> B.ByteString -> Word16
-poolIndex list name = case findIndex test list of
-                        Nothing -> error $ "Internal error: no such item in pool: " ++ toString name
-                        Just i -> fromIntegral i
+      CNameType (force "name" $ poolIndex result n) (force "type" $ poolIndex result t)
+    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 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
     test (CUTF8 s)    | s == name = True
     test (CUnicode s) | s == name = True
-    test _                        = False
+    test _                                  = False
+
+-- | Find index of given string in the list of constants
+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) (M.elems list) of
+                                     Nothing -> throw (NoItemInPool $ i+1)
+                                     Just j  -> return $ fromIntegral $ j+1
+  where
+    checkString (CUTF8 s)    | s == name = True
+    checkString (CUnicode s) | s == name = True
+    checkString _                                  = False
 
+    checkClass i (CClass x) | i == x = True
+    checkClass _ _                           = False
 
+poolNTIndex list x@(NameType n t) = do
+    ni <- poolIndex list n
+    ti <- poolIndex list (byteString t)
+    case findIndex (check ni ti) (M.elems list) of
+      Nothing -> throw (NoItemInPool x)
+      Just i  -> return $ fromIntegral (i+1)
+  where
+    check ni ti (CNameType n' t')
+      | (ni == n') && (ti == t') = True
+    check _ _ _                  = False
 
-fieldInfo :: [CpInfo] -> Field -> FieldInfo
-fieldInfo pool (Field {..}) = FieldInfo {
-  fieldAccessFlags = access2word16 fieldAccess,
-  fieldNameIndex = poolIndex pool fieldName,
-  fieldSignatureIndex = poolIndex pool (encode fieldSignature),
-  fieldAttributesCount = fromIntegral (M.size fieldAttrs),
-  fieldAttributes = map (attrInfo pool) (M.assocs fieldAttrs) }
+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 (arsize fieldAttributes),
+    fieldAttributes = to (arlist fieldAttributes) }
+  where
+    to :: [(B.ByteString, B.ByteString)] -> Attributes File
+    to pairs = AP (map (attrInfo pool) pairs)
 
-methodInfo :: [CpInfo] -> Method -> MethodInfo
-methodInfo pool (Method {..}) = MethodInfo {
-  methodAccessFlags = access2word16 methodAccess,
-  methodNameIndex = poolIndex pool methodName,
-  methodSignatureIndex = poolIndex pool (encode methodSignature),
-  methodAttributesCount = fromIntegral (M.size methodAttrs),
-  methodAttributes = map (attrInfo pool) (M.assocs methodAttrs) }
+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 (arsize methodAttributes),
+    methodAttributes = to (arlist methodAttributes) }
+  where
+    to :: [(B.ByteString, B.ByteString)] -> Attributes File
+    to pairs = AP (map (attrInfo pool) pairs)
 
-attrInfo :: [CpInfo] -> (B.ByteString, B.ByteString) -> AttributeInfo
-attrInfo pool (name, value) = AttributeInfo {
-  attributeName = poolIndex pool name,
+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 :: [CpInfo] -> Pool
-constantPoolArray list = pool
+constantPoolArray :: Pool File -> Pool Direct
+constantPoolArray ps = pool
   where
-    pool :: Pool
-    pool = listArray (1,n) $ map convert list
-    n = fromIntegral $ length list
+    pool :: Pool Direct
+    pool = M.map convert ps
+
+    n = fromIntegral $ M.size ps
 
     convertNameType :: (HasSignature a, Binary (Signature a)) => Word16 -> NameType a
     convertNameType i =
       let (CNameType n s) = pool ! i
       in  NameType n (decode s)
 
-    convert (CONSTANT_Class i) = CClass $ getString $ pool ! i
-    convert (CONSTANT_Fieldref i j) = CField (className $ pool ! i) (convertNameType j)
-    convert (CONSTANT_Methodref i j) = CMethod (className $ pool ! i) (convertNameType j)
-    convert (CONSTANT_InterfaceMethodref i j) = CIfaceMethod (className $ pool ! i) (convertNameType j)
-    convert (CONSTANT_String i) = CString $ getString $ pool ! i
-    convert (CONSTANT_Integer x) = CInteger x
-    convert (CONSTANT_Float x)   = CFloat x
-    convert (CONSTANT_Long x)    = CLong (fromIntegral x)
-    convert (CONSTANT_Double x)  = CDouble x
-    convert (CONSTANT_NameAndType i j) = CNameType (getString $ pool ! i) (getString $ pool ! j)
-    convert (CONSTANT_Utf8 _ bs) = CUTF8 bs
-    convert (CONSTANT_Unicode _ bs) = CUnicode bs
-
-convertAccess :: Word16 -> Access
+    convert (CClass i) = CClass $ getString $ pool ! i
+    convert (CField i j) = CField (className $ pool ! i) (convertNameType j)
+    convert (CMethod i j) = CMethod (className $ pool ! i) (convertNameType j)
+    convert (CIfaceMethod i j) = CIfaceMethod (className $ pool ! i) (convertNameType j)
+    convert (CString i) = CString $ getString $ pool ! i
+    convert (CInteger x) = CInteger x
+    convert (CFloat x)   = CFloat x
+    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
+
+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,
@@ -163,43 +207,48 @@ convertAccess w = S.fromList $ concat $ zipWith (\i f -> if testBit w i then [f]
    ACC_INTERFACE,
    ACC_ABSTRACT ]
 
-access2word16 :: Access -> Word16
+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 -> FieldInfo -> Field
-convertField pool (FieldInfo {..}) = Field {
-  fieldAccess = convertAccess fieldAccessFlags,
-  fieldName = getString $ pool ! fieldNameIndex,
-  fieldSignature = decode $ getString $ pool ! fieldSignatureIndex,
-  fieldAttrs = convertAttrs pool fieldAttributes }
-
-convertMethod :: Pool -> MethodInfo -> Method
-convertMethod pool (MethodInfo {..}) = Method {
-  methodAccess = convertAccess methodAccessFlags,
-  methodName = getString $ pool ! methodNameIndex,
-  methodSignature = decode $ getString $ pool ! methodSignatureIndex,
-  methodAttrs = convertAttrs pool methodAttributes }
-
-convertAttrs :: Pool -> [AttributeInfo] -> Attributes
-convertAttrs pool attrs = M.fromList $ map go attrs
+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 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 Direct -> Attributes File -> Attributes Direct
+convertAttrs pool (AP attrs) = AR (M.fromList $ map go attrs)
   where
-    go (AttributeInfo {..}) = (getString $ pool ! attributeName,
-                               attributeValue)
+    go :: Attribute -> (B.ByteString, B.ByteString)
+    go (Attribute {..}) = (getString $ pool ! attributeName,
+                           attributeValue)
 
 -- | Try to get class method by name
-methodByName :: Class -> B.ByteString -> Maybe Method
+methodByName :: Class Direct -> B.ByteString -> Maybe (Method Direct)
 methodByName cls name =
-  find (\m -> methodName m == name) (methods cls)
+  find (\m -> methodName m == name) (classMethods cls)
 
 -- | Try to get object attribute by name
-attrByName :: (HasAttributes a) => a -> 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
+methodCode :: Class Direct
            -> B.ByteString       -- ^ Method name
            -> Maybe B.ByteString
 methodCode cls name = do