From 8eb9c16c7a351802d1a5cdbe623a48f613edc908 Mon Sep 17 00:00:00 2001 From: Matthias Raba Date: Fri, 21 Jun 2024 08:49:55 +0200 Subject: [PATCH] typos, formatting, comments --- Test/JavaSources/Main.java | 2 +- Test/JavaSources/TestArithmetic.java | 2 +- src/Ast.hs | 2 +- src/ByteCode/Assembler.hs | 63 ++++++++-------- src/ByteCode/Builder.hs | 29 ++++---- src/ByteCode/ClassFile.hs | 22 ++---- src/ByteCode/Util.hs | 103 ++++++++------------------- 7 files changed, 86 insertions(+), 137 deletions(-) diff --git a/Test/JavaSources/Main.java b/Test/JavaSources/Main.java index d33fabb..b912e91 100644 --- a/Test/JavaSources/Main.java +++ b/Test/JavaSources/Main.java @@ -25,7 +25,7 @@ public class Main { // basic arithmetics assert arithmetic.basic(1, 2, 3) == 2; // we have boolean logic as well - assert arithmetic.logic(true, false, true) == true; + assert arithmetic.logic(false, false, true) == true; // multiple classes within one file work. Referencing another classes fields/methods works. assert multipleClasses.a.a == 42; // self-referencing classes work. diff --git a/Test/JavaSources/TestArithmetic.java b/Test/JavaSources/TestArithmetic.java index 2806fd6..410332a 100644 --- a/Test/JavaSources/TestArithmetic.java +++ b/Test/JavaSources/TestArithmetic.java @@ -6,6 +6,6 @@ public class TestArithmetic { public boolean logic(boolean a, boolean b, boolean c) { - return a && (c || b); + return !a && (c || b); } } diff --git a/src/Ast.hs b/src/Ast.hs index a20b8e8..fdf088b 100644 --- a/src/Ast.hs +++ b/src/Ast.hs @@ -2,7 +2,7 @@ module Ast where type CompilationUnit = [Class] type DataType = String -type Identifier = String +type Identifier = String data ParameterDeclaration = ParameterDeclaration DataType Identifier deriving (Show, Eq) data VariableDeclaration = VariableDeclaration DataType Identifier (Maybe Expression) deriving (Show, Eq) diff --git a/src/ByteCode/Assembler.hs b/src/ByteCode/Assembler.hs index aaa8542..101d7aa 100644 --- a/src/ByteCode/Assembler.hs +++ b/src/ByteCode/Assembler.hs @@ -12,12 +12,12 @@ type Assembler a = ([ConstantInfo], [Operation], [String]) -> a -> ([ConstantInf assembleExpression :: Assembler Expression assembleExpression (constants, ops, lvars) (TypedExpression _ (BinaryOperation op a b)) - | elem op [Addition, Subtraction, Multiplication, Division, Modulo, BitwiseAnd, BitwiseOr, BitwiseXor, And, Or] = let + | op `elem` [Addition, Subtraction, Multiplication, Division, Modulo, BitwiseAnd, BitwiseOr, BitwiseXor, And, Or] = let (aConstants, aOps, _) = assembleExpression (constants, ops, lvars) a (bConstants, bOps, _) = assembleExpression (aConstants, aOps, lvars) b in (bConstants, bOps ++ [binaryOperation op], lvars) - | elem op [CompareEqual, CompareNotEqual, CompareLessThan, CompareLessOrEqual, CompareGreaterThan, CompareGreaterOrEqual] = let + | op `elem` [CompareEqual, CompareNotEqual, CompareLessThan, CompareLessOrEqual, CompareGreaterThan, CompareGreaterOrEqual] = let (aConstants, aOps, _) = assembleExpression (constants, ops, lvars) a (bConstants, bOps, _) = assembleExpression (aConstants, aOps, lvars) b cmp_op = comparisonOperation op 9 @@ -60,7 +60,7 @@ assembleExpression (constants, ops, lvars) (TypedExpression _ (UnaryOperation Mi assembleExpression (constants, ops, lvars) (TypedExpression dtype (LocalVariable name)) | name == "this" = (constants, ops ++ [Opaload 0], lvars) | otherwise = let - localIndex = findIndex ((==) name) lvars + localIndex = elemIndex name lvars isPrimitive = elem dtype ["char", "boolean", "int"] in case localIndex of Just index -> (constants, ops ++ if isPrimitive then [Opiload (fromIntegral index)] else [Opaload (fromIntegral index)], lvars) @@ -69,7 +69,7 @@ assembleExpression (constants, ops, lvars) (TypedExpression dtype (LocalVariable assembleExpression (constants, ops, lvars) (TypedExpression dtype (StatementExpressionExpression stmtexp)) = assembleStatementExpression (constants, ops, lvars) stmtexp -assembleExpression _ expr = error ("unimplemented: " ++ show expr) +assembleExpression _ expr = error ("Unknown expression: " ++ show expr) assembleNameChain :: Assembler Expression assembleNameChain input (TypedExpression _ (BinaryOperation NameResolution (TypedExpression atype a) (TypedExpression _ (FieldVariable _)))) = @@ -84,7 +84,7 @@ assembleStatementExpression target = resolveNameChain (TypedExpression dtype receiver) in case target of (TypedExpression dtype (LocalVariable name)) -> let - localIndex = findIndex ((==) name) lvars + localIndex = elemIndex name lvars (constants_a, ops_a, _) = assembleExpression (constants, ops, lvars) expr isPrimitive = elem dtype ["char", "boolean", "int"] in case localIndex of @@ -99,20 +99,20 @@ assembleStatementExpression (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) + something_else -> error ("Expected TypedExpression, but got: " ++ show something_else) assembleStatementExpression (constants, ops, lvars) (TypedStatementExpression _ (PreIncrement (TypedExpression dtype receiver))) = let target = resolveNameChain (TypedExpression dtype receiver) in case target of - (TypedExpression dtype (LocalVariable name)) -> let - localIndex = findIndex ((==) name) lvars - expr = (TypedExpression dtype (LocalVariable name)) + (TypedExpression dtype (LocalVariable name)) -> let + localIndex = elemIndex name lvars + expr = TypedExpression dtype (LocalVariable name) (exprConstants, exprOps, _) = assembleExpression (constants, ops, lvars) expr in case localIndex of Just index -> (exprConstants, exprOps ++ [Opsipush 1, Opiadd, Opdup, Opistore (fromIntegral index)], lvars) - Nothing -> error("No such local variable found in local variable pool: " ++ name) + Nothing -> error ("No such local variable found in local variable pool: " ++ name) (TypedExpression dtype (FieldVariable name)) -> let owner = resolveNameChainOwner (TypedExpression dtype receiver) in case owner of @@ -121,20 +121,20 @@ assembleStatementExpression (constants_r, ops_r, _) = assembleNameChain (constants_f, ops, lvars) (TypedExpression dtype receiver) in (constants_r, ops_r ++ [Opdup, Opgetfield (fromIntegral fieldIndex), Opsipush 1, Opiadd, Opdup_x1, Opputfield (fromIntegral fieldIndex)], lvars) - something_else -> error ("expected TypedExpression, but got: " ++ show something_else) + something_else -> error ("Expected TypedExpression, but got: " ++ show something_else) assembleStatementExpression (constants, ops, lvars) (TypedStatementExpression _ (PreDecrement (TypedExpression dtype receiver))) = let target = resolveNameChain (TypedExpression dtype receiver) in case target of - (TypedExpression dtype (LocalVariable name)) -> let - localIndex = findIndex ((==) name) lvars - expr = (TypedExpression dtype (LocalVariable name)) + (TypedExpression dtype (LocalVariable name)) -> let + localIndex = elemIndex name lvars + expr = TypedExpression dtype (LocalVariable name) (exprConstants, exprOps, _) = assembleExpression (constants, ops, lvars) expr in case localIndex of Just index -> (exprConstants, exprOps ++ [Opsipush 1, Opisub, Opdup, Opistore (fromIntegral index)], lvars) - Nothing -> error("No such local variable found in local variable pool: " ++ name) + Nothing -> error ("No such local variable found in local variable pool: " ++ name) (TypedExpression dtype (FieldVariable name)) -> let owner = resolveNameChainOwner (TypedExpression dtype receiver) in case owner of @@ -143,20 +143,20 @@ assembleStatementExpression (constants_r, ops_r, _) = assembleNameChain (constants_f, ops, lvars) (TypedExpression dtype receiver) in (constants_r, ops_r ++ [Opdup, Opgetfield (fromIntegral fieldIndex), Opsipush 1, Opisub, Opdup_x1, Opputfield (fromIntegral fieldIndex)], lvars) - something_else -> error ("expected TypedExpression, but got: " ++ show something_else) + something_else -> error ("Expected TypedExpression, but got: " ++ show something_else) assembleStatementExpression (constants, ops, lvars) (TypedStatementExpression _ (PostIncrement (TypedExpression dtype receiver))) = let target = resolveNameChain (TypedExpression dtype receiver) in case target of - (TypedExpression dtype (LocalVariable name)) -> let - localIndex = findIndex ((==) name) lvars - expr = (TypedExpression dtype (LocalVariable name)) + (TypedExpression dtype (LocalVariable name)) -> let + localIndex = elemIndex name lvars + expr = TypedExpression dtype (LocalVariable name) (exprConstants, exprOps, _) = assembleExpression (constants, ops, lvars) expr in case localIndex of Just index -> (exprConstants, exprOps ++ [Opdup, Opsipush 1, Opiadd, Opistore (fromIntegral index)], lvars) - Nothing -> error("No such local variable found in local variable pool: " ++ name) + Nothing -> error ("No such local variable found in local variable pool: " ++ name) (TypedExpression dtype (FieldVariable name)) -> let owner = resolveNameChainOwner (TypedExpression dtype receiver) in case owner of @@ -165,20 +165,20 @@ assembleStatementExpression (constants_r, ops_r, _) = assembleNameChain (constants_f, ops, lvars) (TypedExpression dtype receiver) in (constants_r, ops_r ++ [Opdup, Opgetfield (fromIntegral fieldIndex), Opdup_x1, Opsipush 1, Opiadd, Opputfield (fromIntegral fieldIndex)], lvars) - something_else -> error ("expected TypedExpression, but got: " ++ show something_else) + something_else -> error ("Expected TypedExpression, but got: " ++ show something_else) assembleStatementExpression (constants, ops, lvars) (TypedStatementExpression _ (PostDecrement (TypedExpression dtype receiver))) = let target = resolveNameChain (TypedExpression dtype receiver) in case target of - (TypedExpression dtype (LocalVariable name)) -> let - localIndex = findIndex ((==) name) lvars - expr = (TypedExpression dtype (LocalVariable name)) + (TypedExpression dtype (LocalVariable name)) -> let + localIndex = elemIndex name lvars + expr = TypedExpression dtype (LocalVariable name) (exprConstants, exprOps, _) = assembleExpression (constants, ops, lvars) expr in case localIndex of Just index -> (exprConstants, exprOps ++ [Opdup, Opsipush 1, Opisub, Opistore (fromIntegral index)], lvars) - Nothing -> error("No such local variable found in local variable pool: " ++ name) + Nothing -> error ("No such local variable found in local variable pool: " ++ name) (TypedExpression dtype (FieldVariable name)) -> let owner = resolveNameChainOwner (TypedExpression dtype receiver) in case owner of @@ -187,7 +187,7 @@ assembleStatementExpression (constants_r, ops_r, _) = assembleNameChain (constants_f, ops, lvars) (TypedExpression dtype receiver) in (constants_r, ops_r ++ [Opdup, Opgetfield (fromIntegral fieldIndex), Opdup_x1, Opsipush 1, Opisub, Opputfield (fromIntegral fieldIndex)], lvars) - something_else -> error ("expected TypedExpression, but got: " ++ show something_else) + something_else -> error ("Expected TypedExpression, but got: " ++ show something_else) assembleStatementExpression (constants, ops, lvars) @@ -231,7 +231,7 @@ assembleStatement (constants, ops, lvars) (TypedStatement dtype (If expr if_stmt else_length = sum (map opcodeEncodingLength ops_elsea) in case dtype of "void" -> (constants_ifa, ops ++ ops_cmp ++ [Opsipush 0, Opif_icmpeq (if_length + 6)] ++ ops_ifa ++ [Opgoto (else_length + 3)] ++ ops_elsea, lvars) - otherwise -> (constants_ifa, ops ++ ops_cmp ++ [Opsipush 0, Opif_icmpeq (if_length + 3)] ++ ops_ifa ++ ops_elsea, lvars) + _ -> (constants_ifa, ops ++ ops_cmp ++ [Opsipush 0, Opif_icmpeq (if_length + 3)] ++ ops_ifa ++ ops_elsea, lvars) assembleStatement (constants, ops, lvars) (TypedStatement _ (While expr stmt)) = let (constants_cmp, ops_cmp, _) = assembleExpression (constants, [], lvars) expr @@ -257,20 +257,19 @@ assembleStatement (constants, ops, lvars) (TypedStatement _ (StatementExpression in (constants_e, ops_e ++ [Oppop], lvars_e) -assembleStatement _ stmt = error ("Not yet implemented: " ++ show stmt) +assembleStatement _ stmt = error ("Unknown statement: " ++ show stmt) assembleMethod :: Assembler MethodDeclaration assembleMethod (constants, ops, lvars) (MethodDeclaration returntype name _ (TypedStatement _ (Block statements))) | name == "" = let (constants_a, ops_a, lvars_a) = foldl assembleStatement (constants, ops, lvars) statements - init_ops = [Opaload 0, Opinvokespecial 2] in - (constants_a, init_ops ++ ops_a ++ [Opreturn], lvars_a) + (constants_a, [Opaload 0, Opinvokespecial 2] ++ ops_a ++ [Opreturn], lvars_a) | otherwise = case returntype of "void" -> let (constants_a, ops_a, lvars_a) = foldl assembleStatement (constants, ops, lvars) statements in (constants_a, ops_a ++ [Opreturn], lvars_a) - otherwise -> foldl assembleStatement (constants, ops, lvars) statements -assembleMethod _ (MethodDeclaration _ _ _ stmt) = error ("Typed block expected for method body, got: " ++ show stmt) + _ -> foldl assembleStatement (constants, ops, lvars) statements +assembleMethod _ (MethodDeclaration _ _ _ stmt) = error ("Typed block expected for method body, got: " ++ show stmt) diff --git a/src/ByteCode/Builder.hs b/src/ByteCode/Builder.hs index cf9d8c4..b717247 100644 --- a/src/ByteCode/Builder.hs +++ b/src/ByteCode/Builder.hs @@ -22,14 +22,14 @@ fieldBuilder (VariableDeclaration datatype name _) input = let ] field = MemberInfo { memberAccessFlags = accessPublic, - memberNameIndex = (fromIntegral (baseIndex + 2)), - memberDescriptorIndex = (fromIntegral (baseIndex + 3)), + memberNameIndex = fromIntegral (baseIndex + 2), + memberDescriptorIndex = fromIntegral (baseIndex + 3), memberAttributes = [] } in input { - constantPool = (constantPool input) ++ constants, - fields = (fields input) ++ [field] + constantPool = constantPool input ++ constants, + fields = fields input ++ [field] } @@ -46,16 +46,16 @@ methodBuilder (MethodDeclaration returntype name parameters statement) input = l method = MemberInfo { memberAccessFlags = accessPublic, - memberNameIndex = (fromIntegral (baseIndex + 2)), - memberDescriptorIndex = (fromIntegral (baseIndex + 3)), + memberNameIndex = fromIntegral (baseIndex + 2), + memberDescriptorIndex = fromIntegral (baseIndex + 3), memberAttributes = [] } in input { - constantPool = (constantPool input) ++ constants, - methods = (methods input) ++ [method] + constantPool = constantPool input ++ constants, + methods = methods input ++ [method] } - + methodAssembler :: ClassFileBuilder MethodDeclaration methodAssembler (MethodDeclaration returntype name parameters statement) input = let @@ -94,11 +94,12 @@ classBuilder (Class name methods fields) _ = let Utf8Info "java/lang/Object", Utf8Info "", Utf8Info "()V", - Utf8Info "Code" + Utf8Info "Code", + ClassInfo 9, + Utf8Info name ] - nameConstants = [ClassInfo 9, Utf8Info name] nakedClassFile = ClassFile { - constantPool = baseConstants ++ nameConstants, + constantPool = baseConstants, accessFlags = accessPublic, thisClass = 8, superClass = 1, @@ -107,9 +108,13 @@ classBuilder (Class name methods fields) _ = let attributes = [] } + -- if a class has no constructor, inject an empty one. methodsWithInjectedConstructor = injectDefaultConstructor methods + -- for every constructor, prepend all initialization assignments for fields. methodsWithInjectedInitializers = injectFieldInitializers name fields methodsWithInjectedConstructor + -- add fields, then method bodies to the classfile. After all referable names are known, + -- assemble the methods into bytecode. classFileWithFields = foldr fieldBuilder nakedClassFile fields classFileWithMethods = foldr methodBuilder classFileWithFields methodsWithInjectedInitializers classFileWithAssembledMethods = foldr methodAssembler classFileWithMethods methodsWithInjectedInitializers diff --git a/src/ByteCode/ClassFile.hs b/src/ByteCode/ClassFile.hs index 1fc15c9..7a20e97 100644 --- a/src/ByteCode/ClassFile.hs +++ b/src/ByteCode/ClassFile.hs @@ -1,14 +1,4 @@ -module ByteCode.ClassFile( - ConstantInfo(..), - Attribute(..), - MemberInfo(..), - ClassFile(..), - Operation(..), - serialize, - emptyClassFile, - opcodeEncodingLength, - className -) where +module ByteCode.ClassFile where import Data.Word import Data.Int @@ -99,11 +89,11 @@ emptyClassFile = ClassFile { className :: ClassFile -> String className classFile = let - classInfo = (constantPool classFile)!!(fromIntegral (thisClass classFile)) + classInfo = constantPool classFile !! fromIntegral (thisClass classFile) in case classInfo of Utf8Info className -> className - otherwise -> error ("expected Utf8Info but got: " ++ show otherwise) - + unexpected_element -> error ("expected Utf8Info but got: " ++ show unexpected_element) + opcodeEncodingLength :: Operation -> Word16 opcodeEncodingLength Opiadd = 1 @@ -201,10 +191,10 @@ instance Serializable Attribute where serialize (CodeAttribute { attributeMaxStack = maxStack, attributeMaxLocals = maxLocals, attributeCode = code }) = let - assembledCode = concat (map serialize code) + assembledCode = concatMap serialize code in unpackWord16 7 -- attribute_name_index - ++ unpackWord32 (12 + (fromIntegral (length assembledCode))) -- attribute_length + ++ unpackWord32 (12 + fromIntegral (length assembledCode)) -- attribute_length ++ unpackWord16 maxStack -- max_stack ++ unpackWord16 maxLocals -- max_locals ++ unpackWord32 (fromIntegral (length assembledCode)) -- code_length diff --git a/src/ByteCode/Util.hs b/src/ByteCode/Util.hs index 7517c6b..f177342 100644 --- a/src/ByteCode/Util.hs +++ b/src/ByteCode/Util.hs @@ -10,23 +10,22 @@ import Data.Word (Word8, Word16, Word32) -- 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)) +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)) - +resolveNameChainOwner invalidExpression = error ("expected a NameResolution or Local/Field Variable but got: " ++ show invalidExpression) methodDescriptor :: MethodDeclaration -> String methodDescriptor (MethodDeclaration returntype _ parameters _) = let parameter_types = [datatype | ParameterDeclaration datatype _ <- parameters] in "(" - ++ (concat (map datatypeDescriptor parameter_types)) + ++ concatMap datatypeDescriptor parameter_types ++ ")" ++ datatypeDescriptor returntype @@ -35,10 +34,12 @@ methodDescriptorFromParamlist parameters returntype = let parameter_types = [datatype | TypedExpression datatype _ <- parameters] in "(" - ++ (concat (map datatypeDescriptor parameter_types)) + ++ concatMap datatypeDescriptor parameter_types ++ ")" ++ datatypeDescriptor returntype +-- recursively parses a given type signature into a list of parameter types and the method return type. +-- As an initial parameter, you can supply ([], "void"). parseMethodType :: ([String], String) -> String -> ([String], String) parseMethodType (params, returnType) ('(' : descriptor) = parseMethodType (params, returnType) descriptor parseMethodType (params, returnType) ('I' : descriptor) = parseMethodType (params ++ ["I"], returnType) descriptor @@ -51,16 +52,16 @@ parseMethodType (params, returnType) ('L' : descriptor) = let (typeName, semicolon : restOfDescriptor) = splitAt length descriptor in parseMethodType (params ++ [typeName], returnType) restOfDescriptor - Nothing -> error $ "unterminated class type in function signature: " ++ (show descriptor) + Nothing -> error $ "unterminated class type in function signature: " ++ show descriptor parseMethodType (params, _) (')' : descriptor) = (params, descriptor) parseMethodType _ descriptor = error $ "expected start of type name (L, I, C, Z) but got: " ++ descriptor -- given a method index (constant pool index), -- returns the full type of the method. (i.e (LSomething;II)V) methodTypeFromIndex :: [ConstantInfo] -> Int -> String -methodTypeFromIndex constants index = case constants!!(fromIntegral (index - 1)) of - MethodRefInfo _ nameAndTypeIndex -> case constants!!(fromIntegral (nameAndTypeIndex - 1)) of - NameAndTypeInfo _ typeIndex -> case constants!!(fromIntegral (typeIndex - 1)) of +methodTypeFromIndex constants index = case constants !! fromIntegral (index - 1) of + MethodRefInfo _ nameAndTypeIndex -> case constants !! fromIntegral (nameAndTypeIndex - 1) of + NameAndTypeInfo _ typeIndex -> case constants !! fromIntegral (typeIndex - 1) of Utf8Info typeLiteral -> typeLiteral unexpectedElement -> error "Expected Utf8Info but got: " ++ show unexpectedElement unexpectedElement -> error "Expected NameAndTypeInfo but got: " ++ show unexpectedElement @@ -70,7 +71,7 @@ methodParametersFromIndex :: [ConstantInfo] -> Int -> ([String], String) methodParametersFromIndex constants index = parseMethodType ([], "V") (methodTypeFromIndex constants index) memberInfoIsMethod :: [ConstantInfo] -> MemberInfo -> Bool -memberInfoIsMethod constants info = elem '(' (memberInfoDescriptor constants info) +memberInfoIsMethod constants info = '(' `elem` memberInfoDescriptor constants info datatypeDescriptor :: String -> String datatypeDescriptor "void" = "V" @@ -79,35 +80,24 @@ datatypeDescriptor "char" = "C" datatypeDescriptor "boolean" = "Z" datatypeDescriptor x = "L" ++ x ++ ";" - memberInfoDescriptor :: [ConstantInfo] -> MemberInfo -> String -memberInfoDescriptor constants MemberInfo { - memberAccessFlags = _, - memberNameIndex = _, - memberDescriptorIndex = descriptorIndex, - memberAttributes = _ } = let - descriptor = constants!!((fromIntegral descriptorIndex) - 1) +memberInfoDescriptor constants MemberInfo { memberDescriptorIndex = descriptorIndex } = let + 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 -memberInfoName constants MemberInfo { - memberAccessFlags = _, - memberNameIndex = nameIndex, - memberDescriptorIndex = _, - memberAttributes = _ } = let - name = constants!!((fromIntegral nameIndex) - 1) +memberInfoName constants MemberInfo { memberNameIndex = nameIndex } = let + 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 returnOperation :: DataType -> Operation returnOperation dtype - | elem dtype ["int", "char", "boolean"] = Opireturn - | otherwise = Opareturn + | dtype `elem` ["int", "char", "boolean"] = Opireturn + | otherwise = Opareturn binaryOperation :: BinaryOperator -> Operation binaryOperation Addition = Opiadd @@ -141,50 +131,15 @@ comparisonOffset anything_else = Nothing isComparisonOperation :: Operation -> Bool isComparisonOperation op = isJust (comparisonOffset op) -findFieldIndex :: [ConstantInfo] -> String -> Maybe Int -findFieldIndex constants name = let - fieldRefNameInfos = [ - -- we only skip one entry to get the name since the Java constant pool - -- is 1-indexed (why) - (index, constants!!(fromIntegral index + 1)) - | (index, FieldRefInfo classIndex _) <- (zip [1..] constants) - ] - fieldRefNames = map (\(index, nameInfo) -> case nameInfo of - Utf8Info fieldName -> (index, fieldName) - something_else -> error ("Expected UTF8Info but got" ++ show something_else)) - fieldRefNameInfos - fieldIndex = find (\(index, fieldName) -> fieldName == name) fieldRefNames - in case fieldIndex of - Just (index, _) -> Just index - Nothing -> Nothing - -findMethodRefIndex :: [ConstantInfo] -> String -> Maybe Int -findMethodRefIndex constants name = let - methodRefNameInfos = [ - -- we only skip one entry to get the name since the Java constant pool - -- is 1-indexed (why) - (index, constants!!(fromIntegral index + 1)) - | (index, MethodRefInfo _ _) <- (zip [1..] constants) - ] - methodRefNames = map (\(index, nameInfo) -> case nameInfo of - Utf8Info methodName -> (index, methodName) - something_else -> error ("Expected UTF8Info but got " ++ show something_else)) - methodRefNameInfos - methodIndex = find (\(index, methodName) -> methodName == name) methodRefNames - in case methodIndex of - Just (index, _) -> Just index - Nothing -> Nothing - - findMethodIndex :: ClassFile -> String -> Maybe Int findMethodIndex classFile name = let constants = constantPool classFile in - findIndex (\method -> ((memberInfoIsMethod constants method) && (memberInfoName constants method) == name)) (methods classFile) + 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)] + 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)) @@ -198,10 +153,10 @@ 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, FieldRefInfo classIndex nameTypeIndex) <- zip [1..] constants ] ++ [ (index, constants!!(fromIntegral classIndex - 1), constants!!(fromIntegral nameTypeIndex - 1)) - | (index, MethodRefInfo classIndex nameTypeIndex) <- (zip [1..] constants) + | (index, MethodRefInfo classIndex nameTypeIndex) <- zip [1..] constants ] fieldsClassNameType = map (\(index, nameInfo, nameTypeInfo) -> case (nameInfo, nameTypeInfo) of @@ -280,9 +235,9 @@ injectFieldInitializers classname vars pre = let otherwise -> Nothing ) vars in - map (\(method) -> case method of + map (\method -> case method of MethodDeclaration "void" "" params (TypedStatement "void" (Block statements)) -> MethodDeclaration "void" "" params (TypedStatement "void" (Block (initializers ++ statements))) - otherwise -> method + _ -> method ) pre -- effect of one instruction/operation on the stack @@ -312,10 +267,10 @@ operationStackCost constants Opdup_x1 = 1 operationStackCost constants Oppop = -1 operationStackCost constants (Opinvokespecial idx) = let (params, returnType) = methodParametersFromIndex constants (fromIntegral idx) - in (length params + 1) - (fromEnum (returnType /= "V")) + in (length params + 1) - fromEnum (returnType /= "V") operationStackCost constants (Opinvokevirtual idx) = let (params, returnType) = methodParametersFromIndex constants (fromIntegral idx) - in (length params + 1) - (fromEnum (returnType /= "V")) + in (length params + 1) - fromEnum (returnType /= "V") operationStackCost constants (Opgoto _) = 0 operationStackCost constants (Opsipush _) = 1 operationStackCost constants (Opldc_w _) = 1