X-Git-Url: http://wien.tomnetworks.com/gitweb/?a=blobdiff_plain;f=JVM%2FClassFile.hs;h=217e7bcfc7afc6a128a13da1518da0ce3f683be7;hb=312938f1af414da6443d21246e51a55e4457a885;hp=02a7adaf60aec86bb253ef42cd872d020c96f4b6;hpb=59fdc71dedd2203ebd919ab2edad6a867c68dcb8;p=hs-java.git diff --git a/JVM/ClassFile.hs b/JVM/ClassFile.hs index 02a7ada..217e7bc 100644 --- a/JVM/ClassFile.hs +++ b/JVM/ClassFile.hs @@ -5,6 +5,7 @@ module JVM.ClassFile (-- * About -- $about -- + -- -- * Internal class file structures Attribute (..), FieldType (..), @@ -25,6 +26,7 @@ module JVM.ClassFile NameType (..), fieldNameType, methodNameType, lookupField, lookupMethod, + long, toString, className, apsize, arsize, arlist @@ -32,7 +34,9 @@ module JVM.ClassFile where import Control.Monad +import Control.Monad.Trans (lift) import Control.Applicative +import qualified Control.Monad.State as St import Data.Binary import Data.Binary.IEEE754 import Data.Binary.Get @@ -143,11 +147,11 @@ class (Binary (Signature a), Show (Signature a), Eq (Signature a)) => HasSignature a where type Signature a -instance HasSignature Field where - type Signature Field = FieldSignature +instance HasSignature (Field Direct) where + type Signature (Field Direct) = FieldSignature -instance HasSignature Method where - type Signature Method = MethodSignature +instance HasSignature (Method Direct) where + type Signature (Method Direct) = MethodSignature -- | Name and signature pair. Used for methods and fields. data NameType a = NameType { @@ -167,13 +171,13 @@ instance HasSignature a => Binary (NameType a) where -- | Constant pool item data Constant stage = CClass (Link stage B.ByteString) - | CField (Link stage B.ByteString) (Link stage (NameType Field)) - | CMethod (Link stage B.ByteString) (Link stage (NameType Method)) - | CIfaceMethod (Link stage B.ByteString) (Link stage (NameType Method)) + | CField (Link stage B.ByteString) (Link stage (NameType (Field stage))) + | CMethod (Link stage B.ByteString) (Link stage (NameType (Method stage))) + | CIfaceMethod (Link stage B.ByteString) (Link stage (NameType (Method stage))) | CString (Link stage B.ByteString) | CInteger Word32 | CFloat Float - | CLong Integer + | CLong Word64 | CDouble Double | CNameType (Link stage B.ByteString) (Link stage B.ByteString) | CUTF8 {getString :: B.ByteString} @@ -203,22 +207,22 @@ type Pool stage = M.Map Word16 (Constant stage) -- | Generic .class file format data Class stage = Class { - magic :: Word32, -- ^ Magic value: 0xCAFEBABE + magic :: Word32, -- ^ Magic value: 0xCAFEBABE minorVersion :: Word16, majorVersion :: Word16, - constsPoolSize :: Word16, -- ^ Number of items in constants pool - constsPool :: Pool stage, -- ^ Constants pool itself - accessFlags :: AccessFlags stage, -- ^ See @JVM.Types.AccessFlag@ - thisClass :: Link stage B.ByteString, -- ^ Constants pool item index for this class - superClass :: Link stage B.ByteString, -- ^ --/-- for super class, zero for java.lang.Object - interfacesCount :: Word16, -- ^ Number of implemented interfaces - interfaces :: [Link stage B.ByteString], -- ^ Constants pool item indexes for implemented interfaces - classFieldsCount :: Word16, -- ^ Number of class fileds - classFields :: [Field stage], -- ^ Class fields - classMethodsCount :: Word16, -- ^ Number of class methods - classMethods :: [Method stage], -- ^ Class methods - classAttributesCount :: Word16, -- ^ Number of class attributes - classAttributes :: Attributes stage -- ^ Class attributes + constsPoolSize :: Word16, -- ^ Number of items in constants pool + constsPool :: Pool stage, -- ^ Constants pool itself + accessFlags :: AccessFlags stage, -- ^ See @JVM.Types.AccessFlag@ + thisClass :: Link stage B.ByteString, -- ^ Constants pool item index for this class + superClass :: Link stage B.ByteString, -- ^ --/-- for super class, zero for java.lang.Object + interfacesCount :: Word16, -- ^ Number of implemented interfaces + interfaces :: [Link stage B.ByteString], -- ^ Constants pool item indexes for implemented interfaces + classFieldsCount :: Word16, -- ^ Number of class fileds + classFields :: [Field stage], -- ^ Class fields + classMethodsCount :: Word16, -- ^ Number of class methods + classMethods :: [Method stage], -- ^ Class methods + classAttributesCount :: Word16, -- ^ Number of class attributes + classAttributes :: Attributes stage -- ^ Class attributes } deriving instance Eq (Class File) @@ -256,8 +260,7 @@ instance Binary (Class File) where put magic put minorVersion put majorVersion - put constsPoolSize - forM_ (M.elems constsPool) put + putPool constsPool put accessFlags put thisClass put superClass @@ -272,23 +275,26 @@ instance Binary (Class File) where get = do magic <- get + when (magic /= 0xCAFEBABE) $ + fail $ "Invalid .class file MAGIC value: " ++ show magic minor <- get major <- get - poolsize <- get - pool <- replicateM (fromIntegral poolsize - 1) get - af <- get + when (major > 50) $ + fail $ "Too new .class file format: " ++ show major + poolsize <- getWord16be + pool <- getPool (poolsize - 1) + af <- get this <- get super <- get interfacesCount <- get ifaces <- replicateM (fromIntegral interfacesCount) get - classFieldsCount <- get + classFieldsCount <- getWord16be classFields <- replicateM (fromIntegral classFieldsCount) get classMethodsCount <- get classMethods <- replicateM (fromIntegral classMethodsCount) get asCount <- get as <- replicateM (fromIntegral $ asCount) get - let pool' = M.fromList $ zip [1..] pool - return $ Class magic minor major poolsize pool' af this super + return $ Class magic minor major poolsize pool af this super interfacesCount ifaces classFieldsCount classFields classMethodsCount classMethods asCount (AP as) @@ -455,49 +461,80 @@ whileJust m = do return (x: next) Nothing -> return [] -instance Binary (Constant File) where - put (CClass i) = putWord8 7 >> put i - put (CField i j) = putWord8 9 >> put i >> put j - put (CMethod i j) = putWord8 10 >> put i >> put j - put (CIfaceMethod i j) = putWord8 11 >> put i >> put j - put (CString i) = putWord8 8 >> put i - put (CInteger x) = putWord8 3 >> put x - put (CFloat x) = putWord8 4 >> putFloat32be x - put (CLong x) = putWord8 5 >> put x - put (CDouble x) = putWord8 6 >> putFloat64be x - put (CNameType i j) = putWord8 12 >> put i >> put j - put (CUTF8 bs) = do - putWord8 1 - put (fromIntegral (B.length bs) :: Word16) - putLazyByteString bs - put (CUnicode bs) = do - putWord8 2 - put (fromIntegral (B.length bs) :: Word16) - putLazyByteString bs - - get = do - !offset <- bytesRead - tag <- getWord8 - case tag of - 1 -> do - l <- get - bs <- getLazyByteString (fromIntegral (l :: Word16)) - return $ CUTF8 bs - 2 -> do - l <- get - bs <- getLazyByteString (fromIntegral (l :: Word16)) - return $ CUnicode bs - 3 -> CInteger <$> get - 4 -> CFloat <$> getFloat32be - 5 -> CLong <$> get - 6 -> CDouble <$> getFloat64be - 7 -> CClass <$> get - 8 -> CString <$> get - 9 -> CField <$> get <*> get - 10 -> CMethod <$> get <*> get - 11 -> CIfaceMethod <$> get <*> get - 12 -> CNameType <$> get <*> get - _ -> fail $ "Unknown constants pool entry tag: " ++ show tag +long :: Constant stage -> Bool +long (CLong _) = True +long (CDouble _) = True +long _ = False + +putPool :: Pool File -> Put +putPool pool = do + let list = M.elems pool + d = length $ filter long list + putWord16be $ fromIntegral (M.size pool + d + 1) + forM_ list putC + where + putC (CClass i) = putWord8 7 >> put i + putC (CField i j) = putWord8 9 >> put i >> put j + putC (CMethod i j) = putWord8 10 >> put i >> put j + putC (CIfaceMethod i j) = putWord8 11 >> put i >> put j + putC (CString i) = putWord8 8 >> put i + putC (CInteger x) = putWord8 3 >> put x + putC (CFloat x) = putWord8 4 >> putFloat32be x + putC (CLong x) = putWord8 5 >> put x + putC (CDouble x) = putWord8 6 >> putFloat64be x + putC (CNameType i j) = putWord8 12 >> put i >> put j + putC (CUTF8 bs) = do + putWord8 1 + put (fromIntegral (B.length bs) :: Word16) + putLazyByteString bs + putC (CUnicode bs) = do + putWord8 2 + put (fromIntegral (B.length bs) :: Word16) + putLazyByteString bs + +getPool :: Word16 -> Get (Pool File) +getPool n = do + items <- St.evalStateT go 1 + return $ M.fromList items + where + go :: St.StateT Word16 Get [(Word16, Constant File)] + go = do + i <- St.get + if i > n + then return [] + else do + c <- lift getC + let i' = if long c + then i+2 + else i+1 + St.put i' + next <- go + return $ (i,c): next + + getC = do + !offset <- bytesRead + tag <- getWord8 + case tag of + 1 -> do + l <- get + bs <- getLazyByteString (fromIntegral (l :: Word16)) + return $ CUTF8 bs + 2 -> do + l <- get + bs <- getLazyByteString (fromIntegral (l :: Word16)) + return $ CUnicode bs + 3 -> CInteger <$> get + 4 -> CFloat <$> getFloat32be + 5 -> CLong <$> get + 6 -> CDouble <$> getFloat64be + 7 -> CClass <$> get + 8 -> CString <$> get + 9 -> CField <$> get <*> get + 10 -> CMethod <$> get <*> get + 11 -> CIfaceMethod <$> get <*> get + 12 -> CNameType <$> get <*> get + _ -> fail $ "Unknown constants pool entry tag: " ++ show tag +-- _ -> return $ CInteger 0 -- | Class field format data Field stage = Field { @@ -520,7 +557,7 @@ lookupField name cls = look (classFields cls) | fieldName f == name = Just f | otherwise = look fs -fieldNameType :: Field Direct -> NameType Field +fieldNameType :: Field Direct -> NameType (Field Direct) fieldNameType f = NameType (fieldName f) (fieldSignature f) instance Binary (Field File) where @@ -533,9 +570,9 @@ instance Binary (Field File) where get = do af <- get - ni <- get + ni <- getWord16be si <- get - n <- get + n <- getWord16be as <- replicateM (fromIntegral n) get return $ Field af ni si n (AP as) @@ -552,7 +589,7 @@ deriving instance Eq (Method Direct) deriving instance Show (Method File) deriving instance Show (Method Direct) -methodNameType :: Method Direct -> NameType Method +methodNameType :: Method Direct -> NameType (Method Direct) methodNameType m = NameType (methodName m) (methodSignature m) lookupMethod :: B.ByteString -> Class Direct -> Maybe (Method Direct) @@ -601,7 +638,7 @@ instance Binary Attribute where get = do offset <- bytesRead - name <- get + name <- getWord16be len <- getWord32be value <- getLazyByteString (fromIntegral len) return $ Attribute name len value