some updates.

[hs-java.git] / JVM / Generator.hs

diff --git a/JVM/Generator.hs b/JVM/Generator.hs
index d5db62cf83627cfc93e956066a5c0277f76df7bd..34b27edb76de907fcfd7f827cde0d90c8eeb24a5 100644 (file)
--- a/JVM/Generator.hs
+++ b/JVM/Generator.hs
@@ -2,7 +2,6 @@
 module JVM.Generator where
 
 import Control.Monad.State as St
-import Data.Array
 import Data.Word
 import Data.List
 import Data.Binary
@@ -16,50 +15,54 @@ import JVM.Assembler
 
 data GState = GState {
   generated :: [Instruction],
-  currentPool :: Pool,
-  doneMethods :: [Method],
-  currentMethod :: Maybe Method}
+  currentPool :: Pool Resolved,
+  doneMethods :: [Method Resolved],
+  currentMethod :: Maybe (Method Resolved)}
   deriving (Eq,Show)
 
 emptyGState = GState {
   generated = [],
-  currentPool = listArray (0,0) [CInteger 0],
+  currentPool = M.empty,
   doneMethods = [],
   currentMethod = Nothing }
 
 type Generate a = State GState a
 
-appendPool :: Constant -> Pool -> (Pool, Word16)
+appendPool :: Constant Resolved -> Pool Resolved -> (Pool Resolved, Word16)
 appendPool c pool =
-  let list = assocs pool
-      size = fromIntegral (length list)
-      list' = list ++ [(size, c)]
-  in  (array (0, size) list',
-       size)
+  let size = fromIntegral (M.size pool)
+      pool' = M.insert size c pool
+  in  (pool', size)
 
-addItem :: Constant -> Generate Word16
+addItem :: Constant Resolved -> Generate Word16
 addItem c = do
   pool <- St.gets currentPool
   case lookupPool c pool of
-    Just i -> return i
+    Just i -> return (i+1)
     Nothing -> do
       let (pool', i) = appendPool c pool
       st <- St.get
       St.put $ st {currentPool = pool'}
-      return i
+      return (i+1)
 
-lookupPool :: Constant -> Pool -> Maybe Word16
+lookupPool :: Constant Resolved -> Pool Resolved -> Maybe Word16
 lookupPool c pool =
-  fromIntegral `fmap` findIndex (== c) (elems pool)
+  fromIntegral `fmap` findIndex (== c) (M.elems pool)
 
 addNT :: Binary (Signature a) => NameType a -> Generate Word16
 addNT (NameType name sig) = do
   let bsig = encode sig
+  x <- addItem (CNameType name bsig)
   addItem (CUTF8 name)
   addItem (CUTF8 bsig)
-  addItem (CNameType name bsig)
+  return x
 
-addToPool :: Constant -> Generate Word16
+addSig :: MethodSignature -> Generate Word16
+addSig c@(MethodSignature args ret) = do
+  let bsig = encode c
+  addItem (CUTF8 bsig)
+
+addToPool :: Constant Resolved -> Generate Word16
 addToPool c@(CClass str) = do
   addItem (CUTF8 str)
   addItem c
@@ -93,19 +96,27 @@ putInstruction instr = do
 i0 :: Instruction -> Generate ()
 i0 = putInstruction
 
-i1 :: (Word16 -> Instruction) -> Constant -> Generate ()
+i1 :: (Word16 -> Instruction) -> Constant Resolved -> Generate ()
 i1 fn c = do
   ix <- addToPool c
   i0 (fn ix)
 
-startMethod :: B.ByteString -> MethodSignature -> Generate ()
-startMethod name sig = do
+i8 :: (Word8 -> Instruction) -> Constant Resolved -> Generate ()
+i8 fn c = do
+  ix <- addToPool c
+  i0 (fn $ fromIntegral ix)
+
+startMethod :: [AccessFlag] -> B.ByteString -> MethodSignature -> Generate ()
+startMethod flags name sig = do
+  addToPool (CString name)
+  addSig sig
   st <- St.get
   let method = Method {
-    methodAccess = S.fromList [ACC_PUBLIC],
+    methodAccessFlags = S.fromList flags,
     methodName = name,
     methodSignature = sig,
-    methodAttrs = M.empty }
+    methodAttributesCount = 0,
+    methodAttributes = AR M.empty }
   St.put $ st {generated = [],
                currentMethod = Just method }
 
@@ -116,17 +127,20 @@ endMethod = do
   case m of
     Nothing -> fail "endMethod without startMethod!"
     Just method -> do
-      let method' = method {methodAttrs = M.fromList [("Code", encodeMethod code)] }
+      let method' = method {methodAttributes = AR $ M.fromList [("Code", encodeMethod code)],
+                            methodAttributesCount = 1}
       st <- St.get
       St.put $ st {generated = [],
                    currentMethod = Nothing,
                    doneMethods = doneMethods st ++ [method']}
 
-newMethod :: B.ByteString -> [ArgumentSignature] -> ReturnSignature -> Generate () -> Generate ()
-newMethod name args ret gen = do
-  startMethod name (MethodSignature args ret)
+newMethod :: [AccessFlag] -> B.ByteString -> [ArgumentSignature] -> ReturnSignature -> Generate () -> Generate (NameType Method)
+newMethod flags name args ret gen = do
+  let sig = MethodSignature args ret
+  startMethod flags name sig
   gen
   endMethod
+  return (NameType name sig)
 
 genCode :: GState -> Code
 genCode st = Code {
@@ -137,21 +151,38 @@ genCode st = Code {
     codeExceptionsN = 0,
     codeExceptions = [],
     codeAttrsN = 0,
-    codeAttributes = [] }
+    codeAttributes = AP [] }
   where
     len = fromIntegral $ B.length $ encodeInstructions (generated st)
 
-generate :: B.ByteString -> Generate () -> Class
+initClass :: B.ByteString -> Generate Word16
+initClass name = do
+  addToPool (CClass "java/lang/Object")
+  addToPool (CClass name)
+  addToPool (CString "Code")
+
+generate :: B.ByteString -> Generate () -> Class Resolved
 generate name gen =
-  let res = execState gen emptyGState
+  let generator = do
+        initClass name
+        gen
+      res = execState generator emptyGState
       code = genCode res
   in  Class {
-        constantPool = currentPool res,
-        classAccess = S.fromList [ACC_PUBLIC],
-        this = name,
-        super = Nothing,
-        implements = [],
-        fields = [],
-        methods = doneMethods res,
-        classAttrs = M.empty }
+        magic = 0xCAFEBABE,
+        minorVersion = 0,
+        majorVersion = 50,
+        constsPoolSize = fromIntegral $ M.size (currentPool res),
+        constsPool = currentPool res,
+        accessFlags = S.fromList [ACC_PUBLIC, ACC_STATIC],
+        thisClass = name,
+        superClass = "java/lang/Object",
+        interfacesCount = 0,
+        interfaces = [],
+        classFieldsCount = 0,
+        classFields = [],
+        classMethodsCount = fromIntegral $ length (doneMethods res),
+        classMethods = doneMethods res,
+        classAttributesCount = 0,
+        classAttributes = AR M.empty }