src/ByteCode/ClassFile.hs

@@ -34,6 +34,7 @@ data Operation = Opiadd
                | Opixor
                | Opineg
                | Opdup
+               | Opnew Word16
                | Opif_icmplt Word16
                | Opif_icmple Word16
                | Opif_icmpgt Word16
@@ -106,6 +107,7 @@ opcodeEncodingLength Opior                  = 1
 opcodeEncodingLength Opixor                 = 1
 opcodeEncodingLength Opineg                 = 1
 opcodeEncodingLength Opdup                  = 1
+opcodeEncodingLength (Opnew _)              = 3
 opcodeEncodingLength (Opif_icmplt _)        = 3
 opcodeEncodingLength (Opif_icmple _)        = 3
 opcodeEncodingLength (Opif_icmpgt _)        = 3
@@ -161,6 +163,7 @@ instance Serializable Operation where
     serialize Opixor                    = [0x82]
     serialize Opineg                    = [0x74]
     serialize Opdup                     = [0x59]
+    serialize (Opnew index)             = 0xBB : unpackWord16 index
     serialize (Opif_icmplt branch)      = 0xA1 : unpackWord16 branch
     serialize (Opif_icmple branch)      = 0xA4 : unpackWord16 branch
     serialize (Opif_icmpgt branch)      = 0xA3 : unpackWord16 branch

src/ByteCode/Generator.hs

@@ -29,6 +29,15 @@ methodDescriptor (MethodDeclaration returntype _ parameters _) = let
         ++ ")"
         ++ datatypeDescriptor returntype
 
+methodDescriptorFromParamlist :: [Expression] -> String -> String
+methodDescriptorFromParamlist parameters returntype = let
+        parameter_types = [datatype | TypedExpression datatype _ <- parameters]
+    in
+        "("
+        ++ (concat (map datatypeDescriptor parameter_types))
+        ++ ")"
+        ++ datatypeDescriptor returntype
+
 memberInfoIsMethod :: [ConstantInfo] -> MemberInfo -> Bool
 memberInfoIsMethod constants info = elem '(' (memberInfoDescriptor constants info)
 
@@ -40,6 +49,7 @@ datatypeDescriptor "char" = "C"
 datatypeDescriptor "boolean" = "B"
 datatypeDescriptor x = "L" ++ x ++ ";"
 
+
 memberInfoDescriptor :: [ConstantInfo] -> MemberInfo -> String
 memberInfoDescriptor constants MemberInfo {
     memberAccessFlags = _,
@@ -185,6 +195,20 @@ getFieldIndex constants (cname, fname, ftype) = case findMemberIndex constants (
                 Utf8Info (datatypeDescriptor ftype)
             ], baseIndex)
 
+getMethodIndex :: [ConstantInfo] -> (String, String, String) -> ([ConstantInfo], Int)
+getMethodIndex constants (cname, mname, mtype) = case findMemberIndex constants (cname, mname, mtype) of
+    Just index -> (constants, index)
+    Nothing -> let
+            (constantsWithClass, classIndex) = getClassIndex constants cname
+            baseIndex = 1 + length constantsWithClass
+        in
+            (constantsWithClass ++ [
+                MethodRefInfo (fromIntegral classIndex) (fromIntegral (baseIndex + 1)),
+                NameAndTypeInfo (fromIntegral (baseIndex + 2)) (fromIntegral (baseIndex + 3)),
+                Utf8Info mname,
+                Utf8Info mtype
+            ], baseIndex)
+
 findMemberIndex :: [ConstantInfo] -> (String, String, String) -> Maybe Int
 findMemberIndex constants (cname, fname, ftype) = let
         allMembers = getKnownMembers constants
@@ -214,6 +238,18 @@ fieldBuilder (VariableDeclaration datatype name _) input = let
             fields = (fields input) ++ [field]
         }
 
+-- walks the name resolution chain. returns the innermost Just LocalVariable/FieldVariable or Nothing.
+resolveNameChain :: Expression -> Expression
+resolveNameChain (TypedExpression _ (BinaryOperation NameResolution a b)) = resolveNameChain b
+resolveNameChain (TypedExpression dtype (LocalVariable name)) = (TypedExpression dtype (LocalVariable name))
+resolveNameChain (TypedExpression dtype (FieldVariable name)) = (TypedExpression dtype (FieldVariable name))
+resolveNameChain invalidExpression = error ("expected a NameResolution or Local/Field Variable but got: " ++ show(invalidExpression))
+
+-- walks the name resolution chain. returns the second-to-last item of the namechain.
+resolveNameChainOwner :: Expression -> Expression
+resolveNameChainOwner (TypedExpression _ (BinaryOperation NameResolution a (TypedExpression dtype (FieldVariable name)))) = a
+resolveNameChainOwner (TypedExpression _ (BinaryOperation NameResolution a b)) = resolveNameChain b
+resolveNameChainOwner invalidExpression = error ("expected a NameResolution or Local/Field Variable but got: " ++ show(invalidExpression))
 
 methodBuilder :: ClassFileBuilder MethodDeclaration
 methodBuilder (MethodDeclaration returntype name parameters statement) input = let
@@ -351,11 +387,6 @@ assembleExpression (constants, ops, lvars) (TypedExpression _ (UnaryOperation Mi
     in
         (exprConstants, exprOps ++ [Opineg], lvars)
 
-
---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)
     | otherwise = let
@@ -370,29 +401,36 @@ assembleExpression (constants, ops, lvars) (TypedExpression dtype (StatementExpr
 
 assembleExpression _ expr = error ("unimplemented: " ++ show expr)
 
-
+assembleNameChain :: Assembler Expression
+assembleNameChain input (TypedExpression _ (BinaryOperation NameResolution (TypedExpression atype a) (TypedExpression _ (FieldVariable _)))) =
+        assembleExpression input (TypedExpression atype a)
+assembleNameChain input expr = assembleExpression input expr
 
 
 -- TODO untested
 assembleStatementExpression :: Assembler StatementExpression
 assembleStatementExpression
     (constants, ops, lvars)
-    (TypedStatementExpression _ (Assignment (TypedExpression dtype (LocalVariable name)) expr)) = let
+    (TypedStatementExpression _ (Assignment (TypedExpression dtype receiver) expr)) = let
-        localIndex = findIndex ((==) name) lvars
+        target = resolveNameChain (TypedExpression dtype receiver)
-        (constants_a, ops_a, _) = assembleExpression (constants, ops, lvars) expr
+    in case target of
-        isPrimitive = elem dtype ["char", "boolean", "int"]
+        (TypedExpression dtype (LocalVariable name)) -> let
-    in case localIndex of
+                localIndex = findIndex ((==) name) lvars
-        Just index -> (constants_a, ops_a ++ if isPrimitive then [Opistore (fromIntegral index)] else [Opastore (fromIntegral index)], lvars)
+                (constants_a, ops_a, _) = assembleExpression (constants, ops, lvars) expr
-        Nothing -> error ("No such local variable found in local variable pool: " ++ name)
+                isPrimitive = elem dtype ["char", "boolean", "int"]
-
+            in case localIndex of
-assembleStatementExpression
+                Just index -> (constants_a, ops_a ++ if isPrimitive then [Opistore (fromIntegral index)] else [Opastore (fromIntegral index)], lvars)
-    (constants, ops, lvars)
+                Nothing -> error ("No such local variable found in local variable pool: " ++ name)
-    (TypedStatementExpression _ (Assignment (TypedExpression dtype (FieldVariable name)) expr)) = let
+        (TypedExpression dtype (FieldVariable name)) -> let
-        fieldIndex = findFieldIndex constants name
+                owner = resolveNameChainOwner (TypedExpression dtype receiver)
-        (constants_a, ops_a, _) = assembleExpression (constants, ops ++ [Opaload 0], lvars) expr
+            in case owner of
-    in case fieldIndex of
+                (TypedExpression otype _) -> let
-        Just index -> (constants_a, ops_a ++ [Opputfield (fromIntegral index)], lvars)
+                        (constants_f, fieldIndex) = getFieldIndex constants (otype, name, datatypeDescriptor dtype)
-        Nothing -> error ("No such field variable found in constant pool: " ++ name)
+                        (constants_r, ops_r, _) = assembleNameChain (constants_f, ops, lvars) (TypedExpression dtype receiver)
+                        (constants_a, ops_a, _) = assembleExpression (constants_r, ops_r, lvars) expr
+                    in
+                        (constants_a, ops_a ++ [Opdup_x1, Opputfield (fromIntegral fieldIndex)], lvars)
+                something_else -> error ("expected TypedExpression, but got: " ++ show something_else)
 
 
 assembleStatementExpression
@@ -485,16 +523,21 @@ assembleStatementExpression
 
 assembleStatementExpression
     (constants, ops, lvars)
-    (TypedStatementExpression _ (MethodCall receiver name params)) = let
+    (TypedStatementExpression rtype (MethodCall (TypedExpression otype receiver) name params)) = let
-        (constants_r, ops_r, lvars_r) = assembleExpression (constants, ops, lvars) receiver
+        (constants_r, ops_r, lvars_r) = assembleExpression (constants, ops, lvars) (TypedExpression otype receiver)
         (constants_p, ops_p, lvars_p) = foldl assembleExpression (constants_r, ops_r, lvars_r) params
-        methodIndex = findMethodRefIndex constants name
+        (constants_m, methodIndex) = getMethodIndex constants_p (otype, name, methodDescriptorFromParamlist params rtype)
-    in case methodIndex of
+    in
-        Just index -> (constants_p, ops_p ++ [Opinvokespecial (fromIntegral index)], lvars_p)
+        (constants_m, ops_p ++ [Opinvokevirtual (fromIntegral methodIndex)], lvars_p)
-        Nothing -> error("No such method found in constant pool: " ++ name)
-
-
 
+assembleStatementExpression
+    (constants, ops, lvars)
+    (TypedStatementExpression rtype (ConstructorCall name params)) = let
+        (constants_c, classIndex) = getClassIndex constants name
+        (constants_p, ops_p, lvars_p) = foldl assembleExpression (constants_c, ops ++ [Opnew (fromIntegral classIndex), Opdup], lvars) params
+        (constants_m, methodIndex) = getMethodIndex constants_p (name, "<init>", methodDescriptorFromParamlist params "void")
+    in
+        (constants_m, ops_p ++ [Opinvokespecial (fromIntegral methodIndex)], lvars_p)
 
 
 assembleStatement :: Assembler Statement
@@ -549,8 +592,6 @@ assembleStatement (constants, ops, lvars) (TypedStatement _ (StatementExpression
 assembleStatement _ stmt = error ("Not yet implemented: " ++ show stmt)
 
 
-
-
 assembleMethod :: Assembler MethodDeclaration
 assembleMethod (constants, ops, lvars) (MethodDeclaration returntype name _ (TypedStatement _ (Block statements)))
     | name == "<init>"  = let

src/Main.hs

@@ -13,6 +13,7 @@ main = do
 
     let untypedAST = parse $ alexScanTokens file
     let typedAST = head (typeCheckCompilationUnit untypedAST)
+    --print typedAST
     let abstractClassFile = classBuilder typedAST emptyClassFile
     let assembledClassFile = pack (serialize abstractClassFile)