*.swp
.*.swp
dump-class
+rebuild-class
+TestGen
dist/
+MANIFEST.MF
+META-INF
+*.jar
import Data.Word
import qualified Data.ByteString.Lazy as B
+import Codec.Binary.UTF8.String (encodeString)
+import Data.String
import JVM.ClassFile
import JVM.Assembler
getStaticField cls sig =
i1 GETSTATIC (CField cls sig)
-loadString :: Generator e g => B.ByteString -> g e ()
+loadString :: Generator e g => String -> g e ()
loadString str =
- i8 LDC1 (CString str)
+ i8 LDC1 (CString $ fromString $ encodeString $ str)
allocArray :: Generator e g => B.ByteString -> g e ()
allocArray cls =
import Control.Monad.State as St
import Control.Monad.Exception
import Data.Word
-import Data.List
import Data.Binary
import qualified Data.Map as M
import qualified Data.Set as S
import qualified Data.ByteString.Lazy as B
-import JVM.Common () -- import instances only
+import JVM.Common
import JVM.ClassFile
import JVM.Assembler
import JVM.Exceptions
-- | Append a constant to pool
appendPool :: Constant Direct -> Pool Direct -> (Pool Direct, Word16)
appendPool c pool =
- let size = fromIntegral (M.size pool)
- pool' = M.insert size c pool
- in (pool', size)
+ let ix = if M.null pool then 1 else maximum (M.keys pool) + 1
+ pool' = M.insert ix c pool
+ in (pool', ix)
-- | Add a constant to pool
addItem :: (Generator e g) => Constant Direct -> g e Word16
addItem c = do
pool <- St.gets currentPool
case lookupPool c pool of
- Just i -> return (i+1)
+ Just i -> return i
Nothing -> do
let (pool', i) = appendPool c pool
st <- St.get
St.put $ st {currentPool = pool'}
- return (i+1)
+ return i
-- | Lookup in a pool
lookupPool :: Constant Direct -> Pool Direct -> Maybe Word16
lookupPool c pool =
- fromIntegral `fmap` findIndex (== c) (M.elems pool)
+ fromIntegral `fmap` mapFindIndex (== c) pool
addNT :: (Generator e g, HasSignature a) => NameType a -> g e Word16
addNT (NameType name sig) = do
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
| 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}
put magic
put minorVersion
put majorVersion
- put constsPoolSize
- forM_ (M.elems constsPool) put
+ putPool constsPool
put accessFlags
put thisClass
put superClass
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)
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
+long (CLong _) = True
+long (CDouble _) = True
+long _ = False
- 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
+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 {
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)
get = do
offset <- bytesRead
- name <- get
+ name <- getWord16be
len <- getWord32be
value <- getLazyByteString (fromIntegral len)
return $ Attribute name len value
poolSize,
(!),
showListIx,
+ mapFindIndex,
byteString
) where
-import Codec.Binary.UTF8.String (encodeString)
import Data.Binary
import Data.Binary.Put
import qualified Data.ByteString.Lazy as B
import qualified Data.Map as M
import Data.Default
-import Data.Char
-import Data.String
+import Data.List
import JVM.ClassFile
-instance IsString B.ByteString where
- fromString s = B.pack $ map (fromIntegral . ord) $ encodeString s
-
instance Default B.ByteString where
def = B.empty
(!) :: (Ord k) => M.Map k a -> k -> a
(!) = (M.!)
-showListIx :: (Show a) => [a] -> String
-showListIx list = unlines $ zipWith s [1..] list
- where s i x = show i ++ ":\t" ++ show x
+showListIx :: (Show i, Show a) => [(i,a)] -> String
+showListIx list = unlines $ map s list
+ where s (i, x) = show i ++ ":\t" ++ show x
byteString :: (Binary t) => t -> B.ByteString
byteString x = runPut (put x)
+mapFindIndex :: (Num k) => (v -> Bool) -> M.Map k v -> Maybe k
+mapFindIndex check m =
+ case find (check . snd) (M.assocs m) of
+ Nothing -> Nothing
+ Just (k,_) -> Just k
+
import Data.Binary
import Data.Default () -- import instances only
import qualified Data.ByteString.Lazy as B
+import qualified Data.ByteString.Lazy.Char8 ()
import qualified Data.Set as S
import qualified Data.Map as M
-- | 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
+poolIndex list name = case mapFindIndex test list of
Nothing -> throw (NoItemInPool name)
- Just i -> return $ fromIntegral $ i+1
+ Just i -> return $ fromIntegral i
where
test (CUTF8 s) | s == name = True
test (CUnicode s) | s == name = True
-- | 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
+poolClassIndex list name = case mapFindIndex checkString 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
+ Just i -> case mapFindIndex (checkClass $ fromIntegral i) list of
+ Nothing -> throw (NoItemInPool i)
+ Just j -> return $ fromIntegral j
where
checkString (CUTF8 s) | s == name = True
checkString (CUnicode s) | s == name = True
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
+ case mapFindIndex (check ni ti) list of
Nothing -> throw (NoItemInPool x)
- Just i -> return $ fromIntegral (i+1)
+ Just i -> return $ fromIntegral i
where
check ni ti (CNameType n' t')
| (ni == n') && (ti == t') = True
convertNameType :: (HasSignature a) => Word16 -> NameType a
convertNameType i =
- let (CNameType n s) = pool ! i
- in NameType n (decode s)
+ case pool ! i of
+ CNameType n s -> NameType n (decode s)
+ x -> error $ "Unexpected: " ++ show i
- convert (CClass i) = CClass $ getString $ pool ! i
+ convert (CClass i) = case pool ! i of
+ CUTF8 name -> CClass name
+ x -> error $ "Unexpected class name: " ++ show x ++ " at " ++ show 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)
merge1 (x@(File e): es) y@(File e') | e == e' = x: es
| otherwise = x: merge1 es y
merge1 (d@(Directory _ _):es) f@(File _) = d: merge1 es f
+merge1 (f@(File _):es) d@(Directory _ _) = f: merge1 es d
merge1 (x@(Directory dir f):es) y@(Directory dir' f')
| dir == dir' = Directory dir (merge $ f ++ f'): es
| otherwise = x: merge1 es y
files <- Zip.fileNames []
return $ mapF (NotLoadedJAR jarfile) (buildTree $ filter good files)
where
- good name = str `isPrefixOf` name
+ good name = (str `isPrefixOf` name) && (".class" `isSuffixOf` name)
-- | Read entries from JAR file, using MANIFEST.MF if it exists.
readJAR :: FilePath -> IO [Tree CPEntry]
import qualified Codec.Archive.LibZip as Zip
import Data.Binary
+import Data.List
import qualified Data.ByteString.Lazy as B
import Java.ClassPath.Types
-- | Read all entires from JAR file
readAllJAR :: FilePath -> IO [Tree CPEntry]
readAllJAR jarfile = do
- files <- Zip.withArchive [] jarfile $ Zip.fileNames []
- return $ mapF (NotLoadedJAR jarfile) (buildTree files)
+ files <- Zip.withArchive [] jarfile $ Zip.fileNames []
+ return $ mapF (NotLoadedJAR jarfile) (buildTree $ filter good files)
+ where
+ good file = ".class" `isSuffixOf` file
-- | Read one class from JAR file
readFromJAR :: FilePath -> FilePath -> IO (Class Direct)
addDirectory "."
-- Load method signature: Hello.hello() from Hello.class
- helloJava <- getClassMethod "Hello" "hello"
+ helloJava <- getClassMethod "./Hello" "hello"
-- Initializer method. Just calls java.lang.Object.<init>
newMethod [ACC_PUBLIC] "<init>" [] ReturnsVoid $ do
case args of
[clspath] -> do
clsFile <- decodeFile clspath
- putStrLn $ showListIx $ M.elems $ constsPool (clsFile :: Class File)
+ putStrLn $ showListIx $ M.assocs $ constsPool (clsFile :: Class File)
cls <- parseClassFile clspath
dumpClass cls
_ -> error "Synopsis: dump-class File.class"
cls <- parseClassFile clspath
clsfile <- decodeFile clspath :: IO (Class File)
dumpClass cls
- putStrLn $ "Source pool:\n" ++ showListIx (M.elems $ constsPool clsfile)
+ putStrLn $ "Source pool:\n" ++ showListIx (M.assocs $ constsPool clsfile)
let result = classDirect2File cls
- putStrLn $ "Result pool:\n" ++ showListIx (M.elems $ constsPool result)
+ putStrLn $ "Result pool:\n" ++ showListIx (M.assocs $ constsPool result)
B.writeFile outpath (encodeClass cls)
_ -> error "Synopsis: rebuild-class File.class Output.class"
projects / hs-java.git / commitdiff