name resolution for fields
This commit is contained in:
Matthias Raba
parent
3f78cdaa2d
commit
4def6e5804
@ -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)
|
||||
|
||||
Loading…
Reference in New Issue
Block a user