diff --git a/src/ByteCode/ClassFile/Generator.hs b/src/ByteCode/ClassFile/Generator.hs index 69382b3..fef967c 100644 --- a/src/ByteCode/ClassFile/Generator.hs +++ b/src/ByteCode/ClassFile/Generator.hs @@ -52,7 +52,7 @@ memberInfoDescriptor constants MemberInfo { descriptor = constants!!((fromIntegral descriptorIndex) - 1) in case descriptor of Utf8Info descriptorText -> descriptorText - _ -> ("Invalid Item at Constant pool index " ++ show descriptorIndex) + _ -> ("Invalid Item at Constant pool index " ++ show descriptorIndex) memberInfoName :: [ConstantInfo] -> MemberInfo -> String @@ -64,11 +64,11 @@ memberInfoName constants MemberInfo { name = constants!!((fromIntegral nameIndex) - 1) in case name of Utf8Info nameText -> nameText - _ -> ("Invalid Item at Constant pool index " ++ show nameIndex) + _ -> ("Invalid Item at Constant pool index " ++ show nameIndex) methodDescriptor :: MethodDeclaration -> String -methodDescriptor (MethodDeclaration returntype _ parameters _) = let +methodDescriptor (MethodDeclaration returntype _ parameters _) = let parameter_types = [datatype | ParameterDeclaration datatype _ <- parameters] in "(" @@ -104,8 +104,8 @@ classBuilder (Class name methods fields) _ = let classFileWithAssembledMethods = foldr methodAssembler classFileWithMethods methods in classFileWithAssembledMethods - - + + fieldBuilder :: ClassFileBuilder VariableDeclaration fieldBuilder (VariableDeclaration datatype name _) input = let @@ -135,7 +135,7 @@ methodBuilder (MethodDeclaration returntype name parameters statement) input = l Utf8Info name, Utf8Info (methodDescriptor (MethodDeclaration returntype name parameters (Block []))) ] - + method = MemberInfo { memberAccessFlags = accessPublic, memberNameIndex = (fromIntegral baseIndex), @@ -157,7 +157,7 @@ methodAssembler (MethodDeclaration returntype name parameters statement) input = Just index -> let declaration = MethodDeclaration returntype name parameters statement (pre, method : post) = splitAt index (methods input) - (_, bytecode) = assembleMethod declaration (constantPool input, []) + (_, bytecode) = assembleMethod (constantPool input, []) declaration assembledMethod = method { memberAttributes = [ CodeAttribute { @@ -171,11 +171,11 @@ methodAssembler (MethodDeclaration returntype name parameters statement) input = input { methods = pre ++ (assembledMethod : post) } - -type Assembler a = a -> ([ConstantInfo], [Operation]) -> ([ConstantInfo], [Operation]) + +type Assembler a = ([ConstantInfo], [Operation]) -> a -> ([ConstantInfo], [Operation]) returnOperation :: DataType -> Operation returnOperation dtype @@ -201,67 +201,72 @@ comparisonOperation CompareGreaterOrEqual branchLocation = Opif_icmpge branchLoc assembleMethod :: Assembler MethodDeclaration -assembleMethod (MethodDeclaration _ name _ (TypedStatement _ (Block statements))) (constants, ops) - | name == "" = let - (constants_a, ops_a) = foldr assembleStatement (constants, ops) statements +assembleMethod (constants, ops) (MethodDeclaration _ name _ (TypedStatement _ (Block statements))) + | name == "" = let + (constants_a, ops_a) = foldl assembleStatement (constants, ops) statements init_ops = [Opaload 0, Opinvokespecial 2] in (constants_a, init_ops ++ ops_a ++ [Opreturn]) | otherwise = let - (constants_a, ops_a) = foldr assembleStatement (constants, ops) statements + (constants_a, ops_a) = foldl assembleStatement (constants, ops) statements init_ops = [Opaload 0] in (constants_a, init_ops ++ ops_a) -assembleMethod (MethodDeclaration _ _ _ stmt) (_, _) = error ("Block expected for method body, got: " ++ show stmt) +assembleMethod _ (MethodDeclaration _ _ _ stmt) = error ("Block expected for method body, got: " ++ show stmt) assembleStatement :: Assembler Statement -assembleStatement (TypedStatement stype (Return expr)) (constants, ops) = case expr of +assembleStatement (constants, ops) (TypedStatement stype (Return expr)) = case expr of Nothing -> (constants, ops ++ [Opreturn]) Just expr -> let - (expr_constants, expr_ops) = assembleExpression expr (constants, ops) - in + (expr_constants, expr_ops) = assembleExpression (constants, ops) expr + in (expr_constants, expr_ops ++ [returnOperation stype]) -assembleStatement (TypedStatement _ (Block statements)) (constants, ops) = - foldr assembleStatement (constants, ops) statements -assembleStatement (TypedStatement _ (If expr if_stmt else_stmt)) (constants, ops) = let - (constants_cmp, ops_cmp) = assembleExpression expr (constants, []) - (constants_ifa, ops_ifa) = assembleStatement if_stmt (constants_cmp, []) - skip_length = sum (map opcodeEncodingLength ops_ifa) +assembleStatement (constants, ops) (TypedStatement _ (Block statements)) = + foldl assembleStatement (constants, ops) statements +assembleStatement (constants, ops) (TypedStatement _ (If expr if_stmt else_stmt)) = let + (constants_cmp, ops_cmp) = assembleExpression (constants, []) expr + (constants_ifa, ops_ifa) = assembleStatement (constants_cmp, []) if_stmt + (constants_elsea, ops_elsea) = case else_stmt of + Nothing -> (constants_ifa, []) + Just stmt -> assembleStatement (constants_ifa, []) stmt + -- +6 because we insert 2 gotos, one for if, one for else + if_length = sum (map opcodeEncodingLength ops_ifa) + 6 + else_length = sum (map opcodeEncodingLength ops_ifa) in - (constants_ifa, ops ++ ops_cmp ++ [Opsipush 0, Opif_icmpeq skip_length] ++ ops_ifa) - + (constants_ifa, ops ++ ops_cmp ++ [Opsipush 0, Opif_icmpeq if_length] ++ ops_ifa ++ [Opgoto else_length] ++ ops_elsea) +assembleStatement stmt _ = error ("Not yet implemented: " ++ show stmt) assembleExpression :: Assembler Expression -assembleExpression (TypedExpression _ (BinaryOperation op a b)) (constants, ops) +assembleExpression (constants, ops) (TypedExpression _ (BinaryOperation op a b)) | elem op [Addition, Subtraction, Multiplication, Division, BitwiseAnd, BitwiseOr, BitwiseXor] = let - (aConstants, aOps) = assembleExpression a (constants, ops) - (bConstants, bOps) = assembleExpression b (aConstants, aOps) + (aConstants, aOps) = assembleExpression (constants, ops) a + (bConstants, bOps) = assembleExpression (aConstants, aOps) b in (bConstants, bOps ++ [binaryOperation op]) | elem op [CompareEqual, CompareNotEqual, CompareLessThan, CompareLessOrEqual, CompareGreaterThan, CompareGreaterOrEqual] = let - (aConstants, aOps) = assembleExpression a (constants, ops) - (bConstants, bOps) = assembleExpression b (aConstants, aOps) + (aConstants, aOps) = assembleExpression (constants, ops) a + (bConstants, bOps) = assembleExpression (aConstants, aOps) b cmp_op = comparisonOperation op 9 cmp_ops = [cmp_op, Opsipush 0, Opgoto 6, Opsipush 1] in (bConstants, bOps ++ cmp_ops) -assembleExpression (TypedExpression _ (CharacterLiteral literal)) (constants, ops) = +assembleExpression (constants, ops) (TypedExpression _ (CharacterLiteral literal)) = (constants, ops ++ [Opsipush (fromIntegral (ord literal))]) -assembleExpression (TypedExpression _ (BooleanLiteral literal)) (constants, ops) = +assembleExpression (constants, ops) (TypedExpression _ (BooleanLiteral literal)) = (constants, ops ++ [Opsipush (if literal then 1 else 0)]) -assembleExpression (TypedExpression _ (IntegerLiteral literal)) (constants, ops) +assembleExpression (constants, ops) (TypedExpression _ (IntegerLiteral literal)) | literal <= 32767 && literal >= -32768 = (constants, ops ++ [Opsipush (fromIntegral literal)]) | otherwise = (constants ++ [IntegerInfo (fromIntegral literal)], ops ++ [Opldc_w (fromIntegral (1 + length constants))]) -assembleExpression (TypedExpression _ NullLiteral) (constants, ops) = +assembleExpression (constants, ops) (TypedExpression _ NullLiteral) = (constants, ops ++ [Opaconst_null]) -assembleExpression (TypedExpression etype (UnaryOperation Not expr)) (constants, ops) = let - (exprConstants, exprOps) = assembleExpression expr (constants, ops) +assembleExpression (constants, ops) (TypedExpression etype (UnaryOperation Not expr)) = let + (exprConstants, exprOps) = assembleExpression (constants, ops) expr newConstant = fromIntegral (1 + length exprConstants) in case etype of "int" -> (exprConstants ++ [IntegerInfo 0x7FFFFFFF], exprOps ++ [Opldc_w newConstant, Opixor]) "char" -> (exprConstants, exprOps ++ [Opsipush 0xFFFF, Opixor]) "boolean" -> (exprConstants, exprOps ++ [Opsipush 0x01, Opixor]) -assembleExpression (TypedExpression _ (UnaryOperation Minus expr)) (constants, ops) = let - (exprConstants, exprOps) = assembleExpression expr (constants, ops) +assembleExpression (constants, ops) (TypedExpression _ (UnaryOperation Minus expr)) = let + (exprConstants, exprOps) = assembleExpression (constants, ops) expr in (exprConstants, exprOps ++ [Opineg])