Support for loading field/method signatures in Generate monad.

[hs-java.git] / JVM / Builder / Monad.hs

diff --git a/JVM/Builder/Monad.hs b/JVM/Builder/Monad.hs
index 01e93f16c675b756c092765c0d563f74f2c9d1c7..623a44e2c2c3a3bbd8c2e39cc2c19f06f9dd8e44 100644 (file)
--- a/JVM/Builder/Monad.hs
+++ b/JVM/Builder/Monad.hs
@@ -9,6 +9,8 @@ module JVM.Builder.Monad
    i0, i1, i8,
    newMethod,
    setStackSize, setMaxLocals,
+   withClassPath,
+   getClassField, getClassMethod,
    generate
   ) where
 
@@ -23,6 +25,7 @@ import qualified Data.ByteString.Lazy as B
 import JVM.Common ()  -- import instances only
 import JVM.ClassFile
 import JVM.Assembler
+import Java.ClassPath
 
 -- | Generator state
 data GState = GState {
@@ -31,7 +34,8 @@ data GState = GState {
   doneMethods :: [Method Direct],         -- ^ Already generated class methods
   currentMethod :: Maybe (Method Direct), -- ^ Current method
   stackSize :: Word16,                      -- ^ Maximum stack size for current method
-  locals :: Word16                          -- ^ Maximum number of local variables for current method
+  locals :: Word16,                         -- ^ Maximum number of local variables for current method
+  classPath :: [Tree CPEntry]
   }
   deriving (Eq,Show)
 
@@ -43,10 +47,17 @@ emptyGState = GState {
   doneMethods = [],
   currentMethod = Nothing,
   stackSize = 496,
-  locals = 0 }
+  locals = 0,
+  classPath = []}
 
 -- | Generate monad
-type Generate a = State GState a
+type Generate a = StateT GState IO a
+
+withClassPath :: ClassPath () -> Generate ()
+withClassPath cp = do
+  res <- liftIO $ execClassPath cp
+  st <- St.get
+  St.put $ st {classPath = res}
 
 -- | Append a constant to pool
 appendPool :: Constant Direct -> Pool Direct -> (Pool Direct, Word16)
@@ -191,6 +202,31 @@ newMethod flags name args ret gen = do
   endMethod
   return (NameType name sig)
 
+getClass :: String -> Generate (Class Direct)
+getClass name = do
+  cp <- St.gets classPath
+  res <- liftIO $ getEntry cp name
+  case res of
+    Just (NotLoaded p) -> fail $ "Class file was not loaded: " ++ p
+    Just (Loaded _ c) -> return c
+    Just (NotLoadedJAR p c) -> fail $ "Class was not loaded from JAR " ++ p ++ ": " ++ c
+    Just (LoadedJAR _ c) -> return c
+    Nothing -> fail $ "No such class in ClassPath: " ++ name
+
+getClassField :: String -> B.ByteString -> Generate (NameType Field)
+getClassField clsName fldName = do
+  cls <- getClass clsName
+  case lookupField fldName cls of
+    Just fld -> return (fieldNameType fld)
+    Nothing  -> fail $ "No such field in class " ++ clsName ++ ": " ++ toString fldName
+
+getClassMethod :: String -> B.ByteString -> Generate (NameType Method)
+getClassMethod clsName mName = do
+  cls <- getClass clsName
+  case lookupMethod mName cls of
+    Just m -> return (methodNameType m)
+    Nothing  -> fail $ "No such method in class " ++ clsName ++ ": " ++ toString mName
+
 -- | Convert Generator state to method Code.
 genCode :: GState -> Code
 genCode st = Code {
@@ -213,28 +249,22 @@ initClass name = do
   addToPool (CString "Code")
 
 -- | Generate a class
-generate :: B.ByteString -> Generate () -> Class Direct
-generate name gen =
+generate :: [Tree CPEntry] -> B.ByteString -> Generate () -> IO (Class Direct)
+generate cp name gen = do
   let generator = do
         initClass name
+        st <- St.get
+        St.put $ st {classPath = cp}
         gen
-      res = execState generator emptyGState
-      code = genCode res
-  in  Class {
-        magic = 0xCAFEBABE,
-        minorVersion = 0,
-        majorVersion = 50,
+  res <- execStateT generator emptyGState
+  let code = genCode res
+      d = defaultClass :: Class Direct
+  return $ d {
         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 }
+        classMethods = doneMethods res }