From 4def6e5804e8ce8ec9f02544970f2615aec7baef Mon Sep 17 00:00:00 2001 From: Matthias Raba Date: Thu, 13 Jun 2024 15:35:42 +0200 Subject: [PATCH] name resolution for fields --- src/ByteCode/Generator.hs | 107 ++++++++++++++++++++++++++------------ 1 file changed, 75 insertions(+), 32 deletions(-) diff --git a/src/ByteCode/Generator.hs b/src/ByteCode/Generator.hs index 835c168..61d53d3 100644 --- a/src/ByteCode/Generator.hs +++ b/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)