Method & constructor calls fully working
This commit is contained in:
mrab
parent
fbd76deca3
commit
613a280079
@ -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
|
||||
|
||||
@ -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
|
||||
localIndex = findIndex ((==) name) lvars
|
||||
(constants_a, ops_a, _) = assembleExpression (constants, ops, lvars) expr
|
||||
isPrimitive = elem dtype ["char", "boolean", "int"]
|
||||
in case localIndex of
|
||||
Just index -> (constants_a, ops_a ++ if isPrimitive then [Opistore (fromIntegral index)] else [Opastore (fromIntegral index)], lvars)
|
||||
Nothing -> error ("No such local variable found in local variable pool: " ++ name)
|
||||
|
||||
assembleStatementExpression
|
||||
(constants, ops, lvars)
|
||||
(TypedStatementExpression _ (Assignment (TypedExpression dtype (FieldVariable name)) expr)) = let
|
||||
fieldIndex = findFieldIndex constants name
|
||||
(constants_a, ops_a, _) = assembleExpression (constants, ops ++ [Opaload 0], lvars) expr
|
||||
in case fieldIndex of
|
||||
Just index -> (constants_a, ops_a ++ [Opputfield (fromIntegral index)], lvars)
|
||||
Nothing -> error ("No such field variable found in constant pool: " ++ name)
|
||||
(TypedStatementExpression _ (Assignment (TypedExpression dtype receiver) expr)) = let
|
||||
target = resolveNameChain (TypedExpression dtype receiver)
|
||||
in case target of
|
||||
(TypedExpression dtype (LocalVariable name)) -> let
|
||||
localIndex = findIndex ((==) name) lvars
|
||||
(constants_a, ops_a, _) = assembleExpression (constants, ops, lvars) expr
|
||||
isPrimitive = elem dtype ["char", "boolean", "int"]
|
||||
in case localIndex of
|
||||
Just index -> (constants_a, ops_a ++ if isPrimitive then [Opistore (fromIntegral index)] else [Opastore (fromIntegral index)], lvars)
|
||||
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
|
||||
(TypedExpression otype _) -> let
|
||||
(constants_f, fieldIndex) = getFieldIndex constants (otype, name, datatypeDescriptor dtype)
|
||||
(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
|
||||
(constants_r, ops_r, lvars_r) = assembleExpression (constants, ops, lvars) receiver
|
||||
(TypedStatementExpression rtype (MethodCall (TypedExpression otype receiver) name params)) = let
|
||||
(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
|
||||
in case methodIndex of
|
||||
Just index -> (constants_p, ops_p ++ [Opinvokespecial (fromIntegral index)], lvars_p)
|
||||
Nothing -> error("No such method found in constant pool: " ++ name)
|
||||
|
||||
|
||||
(constants_m, methodIndex) = getMethodIndex constants_p (otype, name, methodDescriptorFromParamlist params rtype)
|
||||
in
|
||||
(constants_m, ops_p ++ [Opinvokevirtual (fromIntegral methodIndex)], lvars_p)
|
||||
|
||||
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
|
||||
|
||||
@ -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)
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user