src/ByteCode/Generator.hs

@@ -25,17 +25,9 @@ methodDescriptor (MethodDeclaration returntype _ parameters _) = let
         parameter_types = [datatype | ParameterDeclaration datatype _ <- parameters]
     in
         "("
-        ++ (concat (map methodParameterDescriptor parameter_types))
+        ++ (concat (map datatypeDescriptor parameter_types))
         ++ ")"
-        ++ methodParameterDescriptor returntype
-
-methodParameterDescriptor :: String -> String
-methodParameterDescriptor "void" = "V"
-methodParameterDescriptor "int" = "I"
-methodParameterDescriptor "char" = "C"
-methodParameterDescriptor "boolean" = "B"
-methodParameterDescriptor x = "L" ++ x ++ ";"
-
+        ++ datatypeDescriptor returntype
 
 memberInfoIsMethod :: [ConstantInfo] -> MemberInfo -> Bool
 memberInfoIsMethod constants info = elem '(' (memberInfoDescriptor constants info)
@@ -46,7 +38,7 @@ datatypeDescriptor "void" = "V"
 datatypeDescriptor "int" = "I"
 datatypeDescriptor "char" = "C"
 datatypeDescriptor "boolean" = "B"
-datatypeDescriptor x = "L" ++ x
+datatypeDescriptor x = "L" ++ x ++ ";"
 
 memberInfoDescriptor :: [ConstantInfo] -> MemberInfo -> String
 memberInfoDescriptor constants MemberInfo {
@@ -124,7 +116,7 @@ findMethodRefIndex constants name = let
             ]
         methodRefNames = map (\(index, nameInfo) -> case nameInfo of
             Utf8Info methodName -> (index, methodName)
-            something_else -> error ("Expected UTF8Info but got" ++ show something_else))
+            something_else -> error ("Expected UTF8Info but got " ++ show something_else))
                 methodRefNameInfos
         methodIndex = find (\(index, methodName) -> methodName == name) methodRefNames
     in case methodIndex of
@@ -138,6 +130,67 @@ findMethodIndex classFile name = let
     in
         findIndex (\method -> ((memberInfoIsMethod constants method) && (memberInfoName constants method) == name)) (methods classFile)
 
+findClassIndex :: [ConstantInfo] -> String -> Maybe Int
+findClassIndex constants name = let
+        classNameIndices = [(index, constants!!(fromIntegral nameIndex - 1)) | (index, ClassInfo nameIndex) <- (zip[1..] constants)]
+        classNames = map (\(index, nameInfo) -> case nameInfo of
+            Utf8Info className -> (index, className)
+            something_else -> error("Expected UTF8Info but got " ++ show something_else))
+                classNameIndices
+        desiredClassIndex = find (\(index, className) -> className == name) classNames
+    in case desiredClassIndex of
+        Just (index, _) -> Just index
+        Nothing -> Nothing
+
+getKnownMembers :: [ConstantInfo] -> [(Int, (String, String, String))]
+getKnownMembers constants = let
+        fieldsClassAndNT = [
+                (index, constants!!(fromIntegral classIndex - 1), constants!!(fromIntegral nameTypeIndex - 1))
+                | (index, FieldRefInfo classIndex nameTypeIndex) <- (zip [1..] constants)
+            ] ++ [
+                (index, constants!!(fromIntegral classIndex - 1), constants!!(fromIntegral nameTypeIndex - 1))
+                | (index, MethodRefInfo classIndex nameTypeIndex) <- (zip [1..] constants)
+            ]
+            
+        fieldsClassNameType = map (\(index, nameInfo, nameTypeInfo) -> case (nameInfo, nameTypeInfo) of
+            (ClassInfo nameIndex, NameAndTypeInfo fnameIndex ftypeIndex) -> (index, (constants!!(fromIntegral nameIndex - 1), constants!!(fromIntegral fnameIndex - 1), constants!!(fromIntegral ftypeIndex - 1)))
+            something_else -> error ("Expected Class and NameType info, but got: " ++ show nameInfo ++ " and " ++ show nameTypeInfo))
+                fieldsClassAndNT
+
+        fieldsResolved = map (\(index, (nameInfo, fnameInfo, ftypeInfo)) -> case (nameInfo, fnameInfo, ftypeInfo) of
+            (Utf8Info cname, Utf8Info fname, Utf8Info ftype) -> (index, (cname, fname, ftype))
+            something_else -> error("Expected UTF8Infos but got " ++ show something_else))
+                fieldsClassNameType    
+    in
+        fieldsResolved
+
+-- same as findClassIndex, but inserts a new entry into constant pool if not existing
+getClassIndex :: [ConstantInfo] -> String -> ([ConstantInfo], Int)
+getClassIndex constants name = case findClassIndex constants name of
+    Just index -> (constants, index)
+    Nothing -> (constants ++ [ClassInfo (fromIntegral (length constants)), Utf8Info name], fromIntegral (length constants))
+
+-- get the index for a field within a class, creating it if it does not exist.
+getFieldIndex :: [ConstantInfo] -> (String, String, String) -> ([ConstantInfo], Int)
+getFieldIndex constants (cname, fname, ftype) = case findMemberIndex constants (cname, fname, ftype) of
+    Just index -> (constants, index)
+    Nothing -> let
+            (constantsWithClass, classIndex) = getClassIndex constants cname
+            baseIndex = 1 + length constantsWithClass
+        in
+            (constantsWithClass ++ [
+                FieldRefInfo (fromIntegral classIndex) (fromIntegral (baseIndex + 1)),
+                NameAndTypeInfo (fromIntegral (baseIndex + 2)) (fromIntegral (baseIndex + 3)),
+                Utf8Info fname,
+                Utf8Info (datatypeDescriptor ftype)
+            ], baseIndex)
+
+findMemberIndex :: [ConstantInfo] -> (String, String, String) -> Maybe Int
+findMemberIndex constants (cname, fname, ftype) = let
+        allMembers = getKnownMembers constants
+        desiredMember = find (\(index, (c, f, ft)) -> (c, f, ft) == (cname, fname, ftype)) allMembers
+    in
+        fmap (\(index, _) -> index) desiredMember
 
 
 fieldBuilder :: ClassFileBuilder VariableDeclaration
@@ -266,21 +319,12 @@ assembleExpression (constants, ops, lvars) (TypedExpression _ (BinaryOperation o
         in
             (bConstants, bOps ++ cmp_ops, lvars)
 
-{-
-assembleExpression (constants, ops, lvars) (TypedExpression _ (BinaryOperation NameResolution lvar (TypedExpression _ (FieldVariable fvar)))) = let
-                constants_f = constants ++ [
-                    FieldRefInfo (fromIntegral (thisClass input)) (fromIntegral (baseIndex + 1)),
-                    NameAndTypeInfo (fromIntegral (baseIndex + 2)) (fromIntegral (baseIndex + 3)),
-                    Utf8Info name,
-                    Utf8Info (datatypeDescriptor datatype)
-                ]
-        (constants_l, ops_l, lvars_l) = assembleExpression (constants, ops, lvars) lvar
-        constants_
-        fieldIndex = findFieldIndex constants name
-    in case fieldIndex of
-        Just index -> (constants, ops ++ [Opload 0, Opgetfield (fromIntegral index)], lvars)
-        Nothing -> error ("No such field found in constant pool: " ++ name)
--}
+assembleExpression (constants, ops, lvars) (TypedExpression _ (BinaryOperation NameResolution (TypedExpression atype a) (TypedExpression btype (FieldVariable b)))) = let
+        (fConstants, fieldIndex) = getFieldIndex constants (atype, b, datatypeDescriptor btype)
+        (aConstants, aOps, _) = assembleExpression (fConstants, ops, lvars) (TypedExpression atype a)
+    in
+        (aConstants, aOps ++ [Opgetfield (fromIntegral fieldIndex)], lvars)
+
 assembleExpression (constants, ops, lvars) (TypedExpression _ (CharacterLiteral literal)) =
     (constants, ops ++ [Opsipush (fromIntegral (ord literal))], lvars)
 
@@ -307,11 +351,10 @@ assembleExpression (constants, ops, lvars) (TypedExpression _ (UnaryOperation Mi
     in
         (exprConstants, exprOps ++ [Opineg], lvars)
 
-assembleExpression (constants, ops, lvars) (TypedExpression _ (FieldVariable name)) = let
-        fieldIndex = findFieldIndex constants name
-    in case fieldIndex of
-        Just index -> (constants, ops ++ [Opaload 0, Opgetfield (fromIntegral index)], lvars)
-        Nothing -> error ("No such field found in constant pool: " ++ name)
+
+--assembleExpression (constants, ops, lvars) (TypedExpression dtype (FieldVariable name)) =
+--    assembleExpression (constants, ops, lvars) (TypedExpression dtype (BinaryOperation NameResolution ()))
+    
 
 assembleExpression (constants, ops, lvars) (TypedExpression dtype (LocalVariable name))
     | name == "this" = (constants, ops ++ [Opaload 0], lvars)