MisterChaos69/MiniJavaCompiler
2
2
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Compare commits

base: MisterChaos69:06dad4d7f988e659eeec9abb3a395d6485362949
Branches Tags
MisterChaos69:master
MisterChaos69:bytecode
MisterChaos69:create-parser
MisterChaos69:typechecker_addPublicPrivate
MisterChaos69:typedAST
MisterChaos69:documentation
..
compare: MisterChaos69:2b7d217e8a78f880890bb5ca5a8f44f8d9f996d8
Branches Tags
MisterChaos69:master
MisterChaos69:bytecode
MisterChaos69:create-parser
MisterChaos69:typechecker_addPublicPrivate
MisterChaos69:typedAST
MisterChaos69:documentation

No commits in common. "06dad4d7f988e659eeec9abb3a395d6485362949" and "2b7d217e8a78f880890bb5ca5a8f44f8d9f996d8" have entirely different histories.
06dad4d7f9 ... 2b7d217e8a

12 changed files with 503 additions and 530 deletions
Show Stats Expand all files Collapse all files

12
Test/TestParser.hs
View File

@ -191,15 +191,6 @@ testExpressionThisMethodCall = TestCase $
testExpressionThisMethodCallParam = TestCase $
assertEqual "expect this methocall" (StatementExpressionExpression (MethodCall (Reference "this") "foo" [Reference "x"])) $
parseExpression [THIS,DOT,IDENTIFIER "foo",LBRACE,IDENTIFIER "x",RBRACE]
testExpressionFieldAccess = TestCase $
assertEqual "expect NameResolution" (BinaryOperation NameResolution (Reference "this") (Reference "b")) $
parseExpression [THIS,DOT,IDENTIFIER "b"]
testExpressionSimpleFieldAccess = TestCase $
assertEqual "expect Reference" (Reference "a") $
parseExpression [IDENTIFIER "a"]
testExpressionFieldSubAccess = TestCase $
assertEqual "expect NameResolution without this" (BinaryOperation NameResolution (Reference "a") (Reference "b")) $
parseExpression [IDENTIFIER "a",DOT,IDENTIFIER "b"]
testStatementIfThen = TestCase $
assertEqual "expect empty ifthen" [If (Reference "a") (Block [Block []]) Nothing] $
@ -276,9 +267,6 @@ tests = TestList [
testExpressionMethodCallTwoParams,
testExpressionThisMethodCall,
testExpressionThisMethodCallParam,
testExpressionFieldAccess,
testExpressionSimpleFieldAccess,
testExpressionFieldSubAccess,
testStatementIfThen,
testStatementIfThenElse,
testStatementWhile,

7
project.cabal
View File

@ -21,7 +21,12 @@ executable compiler
Typecheck,
ByteCode.ByteUtil,
ByteCode.ClassFile,
ByteCode.Generator,
ByteCode.Generation.Generator,
ByteCode.Generation.Assembler.ExpressionAndStatement,
ByteCode.Generation.Assembler.Method,
ByteCode.Generation.Builder.Class,
ByteCode.Generation.Builder.Field,
ByteCode.Generation.Builder.Method,
ByteCode.Constants
test-suite tests

9
src/ByteCode/ClassFile.hs
View File

@ -43,10 +43,7 @@ data Operation = Opiadd
| Opreturn
| Opireturn
| Opareturn
| Opdup_x1
| Oppop
| Opinvokespecial Word16
| Opinvokevirtual Word16
| Opgoto Word16
| Opsipush Word16
| Opldc_w Word16
@ -114,10 +111,7 @@ opcodeEncodingLength Opaconst_null = 1
opcodeEncodingLength Opreturn = 1
opcodeEncodingLength Opireturn = 1
opcodeEncodingLength Opareturn = 1
opcodeEncodingLength Opdup_x1 = 1
opcodeEncodingLength Oppop = 1
opcodeEncodingLength (Opinvokespecial _) = 3
opcodeEncodingLength (Opinvokevirtual _) = 3
opcodeEncodingLength (Opgoto _) = 3
opcodeEncodingLength (Opsipush _) = 3
opcodeEncodingLength (Opldc_w _) = 3
@ -168,10 +162,7 @@ instance Serializable Operation where
serialize Opreturn = [0xB1]
serialize Opireturn = [0xAC]
serialize Opareturn = [0xB0]
serialize Opdup_x1 = [0x5A]
serialize Oppop = [0x57]
serialize (Opinvokespecial index) = 0xB7 : unpackWord16 index
serialize (Opinvokevirtual index) = 0xB6 : unpackWord16 index
serialize (Opgoto index) = 0xA7 : unpackWord16 index
serialize (Opsipush index) = 0x11 : unpackWord16 index
serialize (Opldc_w index) = 0x13 : unpackWord16 index

228
src/ByteCode/Generation/Assembler/ExpressionAndStatement.hs Normal file
View File

@ -0,0 +1,228 @@
module ByteCode.Generation.Assembler.ExpressionAndStatement where
import Ast
import ByteCode.ClassFile(ClassFile (..), ConstantInfo (..), MemberInfo(..), Operation(..), Attribute(..), opcodeEncodingLength)
import ByteCode.Generation.Generator
import Data.List
import Data.Char
import ByteCode.Generation.Builder.Field
assembleExpression :: Assembler Expression
assembleExpression (constants, ops, lvars) (TypedExpression _ (BinaryOperation op a b))
| elem op [Addition, Subtraction, Multiplication, Division, BitwiseAnd, BitwiseOr, BitwiseXor] = 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
(aConstants, aOps, _) = assembleExpression (constants, ops, lvars) a
(bConstants, bOps, _) = assembleExpression (aConstants, aOps, lvars) b
cmp_op = comparisonOperation op 9
cmp_ops = [cmp_op, Opsipush 0, Opgoto 6, Opsipush 1]
in
(bConstants, bOps ++ cmp_ops, lvars)
assembleExpression (constants, ops, lvars) (TypedExpression _ (CharacterLiteral literal)) =
(constants, ops ++ [Opsipush (fromIntegral (ord literal))], lvars)
assembleExpression (constants, ops, lvars) (TypedExpression _ (BooleanLiteral literal)) =
(constants, ops ++ [Opsipush (if literal then 1 else 0)], lvars)
assembleExpression (constants, ops, lvars) (TypedExpression _ (IntegerLiteral literal))
| literal <= 32767 && literal >= -32768 = (constants, ops ++ [Opsipush (fromIntegral literal)], lvars)
| otherwise = (constants ++ [IntegerInfo (fromIntegral literal)], ops ++ [Opldc_w (fromIntegral (1 + length constants))], lvars)
assembleExpression (constants, ops, lvars) (TypedExpression _ NullLiteral) =
(constants, ops ++ [Opaconst_null], lvars)
assembleExpression (constants, ops, lvars) (TypedExpression etype (UnaryOperation Not expr)) = let
(exprConstants, exprOps, _) = assembleExpression (constants, ops, lvars) expr
newConstant = fromIntegral (1 + length exprConstants)
in case etype of
"int" -> (exprConstants ++ [IntegerInfo 0x7FFFFFFF], exprOps ++ [Opldc_w newConstant, Opixor], lvars)
"char" -> (exprConstants, exprOps ++ [Opsipush 0xFFFF, Opixor], lvars)
"boolean" -> (exprConstants, exprOps ++ [Opsipush 0x01, Opixor], lvars)
assembleExpression (constants, ops, lvars) (TypedExpression _ (UnaryOperation Minus expr)) = let
(exprConstants, exprOps, _) = assembleExpression (constants, ops, lvars) expr
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 (LocalVariable name)) = let
localIndex = findIndex ((==) 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)
Nothing -> error ("No such local variable found in local variable pool: " ++ name)
assembleExpression (constants, ops, lvars) (TypedExpression dtype (StatementExpressionExpression stmtexp)) =
assembleStatementExpression (constants, ops, lvars) stmtexp
assembleExpression _ expr = error ("unimplemented: " ++ show 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)
assembleStatementExpression
(constants, ops, lvars)
(TypedStatementExpression _ (PreIncrement (TypedExpression dtype (LocalVariable name)))) = let
localIndex = findIndex ((==) name) lvars
expr = (TypedExpression dtype (LocalVariable name))
(exprConstants, exprOps, _) = assembleExpression (constants, ops, lvars) expr
incrOps = exprOps ++ [Opsipush 1, Opiadd, Opdup]
in case localIndex of
Just index -> (exprConstants, incrOps ++ [Opistore (fromIntegral index)], lvars)
Nothing -> error("No such local variable found in local variable pool: " ++ name)
assembleStatementExpression
(constants, ops, lvars)
(TypedStatementExpression _ (PostIncrement (TypedExpression dtype (LocalVariable name)))) = let
localIndex = findIndex ((==) name) lvars
expr = (TypedExpression dtype (LocalVariable name))
(exprConstants, exprOps, _) = assembleExpression (constants, ops, lvars) expr
incrOps = exprOps ++ [Opdup, Opsipush 1, Opiadd]
in case localIndex of
Just index -> (exprConstants, incrOps ++ [Opistore (fromIntegral index)], lvars)
Nothing -> error("No such local variable found in local variable pool: " ++ name)
assembleStatementExpression
(constants, ops, lvars)
(TypedStatementExpression _ (PreDecrement (TypedExpression dtype (LocalVariable name)))) = let
localIndex = findIndex ((==) name) lvars
expr = (TypedExpression dtype (LocalVariable name))
(exprConstants, exprOps, _) = assembleExpression (constants, ops, lvars) expr
incrOps = exprOps ++ [Opsipush 1, Opiadd, Opisub]
in case localIndex of
Just index -> (exprConstants, incrOps ++ [Opistore (fromIntegral index)], lvars)
Nothing -> error("No such local variable found in local variable pool: " ++ name)
assembleStatementExpression
(constants, ops, lvars)
(TypedStatementExpression _ (PostDecrement (TypedExpression dtype (LocalVariable name)))) = let
localIndex = findIndex ((==) name) lvars
expr = (TypedExpression dtype (LocalVariable name))
(exprConstants, exprOps, _) = assembleExpression (constants, ops, lvars) expr
incrOps = exprOps ++ [Opdup, Opsipush 1, Opisub]
in case localIndex of
Just index -> (exprConstants, incrOps ++ [Opistore (fromIntegral index)], lvars)
Nothing -> error("No such local variable found in local variable pool: " ++ name)
assembleStatementExpression
(constants, ops, lvars)
(TypedStatementExpression _ (PreIncrement (TypedExpression dtype (FieldVariable name)))) = let
fieldIndex = findFieldIndex constants name
expr = (TypedExpression dtype (FieldVariable name))
(exprConstants, exprOps, _) = assembleExpression (constants, ops ++ [Opaload 0], lvars) expr
incrOps = exprOps ++ [Opsipush 1, Opiadd, Opdup]
in case fieldIndex of
Just index -> (exprConstants, incrOps ++ [Opputfield (fromIntegral index)], lvars)
Nothing -> error("No such field variable found in field variable pool: " ++ name)
assembleStatementExpression
(constants, ops, lvars)
(TypedStatementExpression _ (PostIncrement (TypedExpression dtype (FieldVariable name)))) = let
fieldIndex = findFieldIndex constants name
expr = (TypedExpression dtype (FieldVariable name))
(exprConstants, exprOps, _) = assembleExpression (constants, ops ++ [Opaload 0], lvars) expr
incrOps = exprOps ++ [Opdup, Opsipush 1, Opiadd]
in case fieldIndex of
Just index -> (exprConstants, incrOps ++ [Opputfield (fromIntegral index)], lvars)
Nothing -> error("No such field variable found in field variable pool: " ++ name)
assembleStatementExpression
(constants, ops, lvars)
(TypedStatementExpression _ (PreDecrement (TypedExpression dtype (FieldVariable name)))) = let
fieldIndex = findFieldIndex constants name
expr = (TypedExpression dtype (FieldVariable name))
(exprConstants, exprOps, _) = assembleExpression (constants, ops ++ [Opaload 0], lvars) expr
incrOps = exprOps ++ [Opsipush 1, Opiadd, Opisub]
in case fieldIndex of
Just index -> (exprConstants, incrOps ++ [Opputfield (fromIntegral index)], lvars)
Nothing -> error("No such field variable found in field variable pool: " ++ name)
assembleStatementExpression
(constants, ops, lvars)
(TypedStatementExpression _ (PostDecrement (TypedExpression dtype (FieldVariable name)))) = let
fieldIndex = findFieldIndex constants name
expr = (TypedExpression dtype (FieldVariable name))
(exprConstants, exprOps, _) = assembleExpression (constants, ops ++ [Opaload 0], lvars) expr
incrOps = exprOps ++ [Opdup, Opsipush 1, Opisub]
in case fieldIndex of
Just index -> (exprConstants, incrOps ++ [Opputfield (fromIntegral index)], lvars)
Nothing -> error("No such field variable found in field variable pool: " ++ name)
assembleStatement :: Assembler Statement
assembleStatement (constants, ops, lvars) (TypedStatement stype (Return expr)) = case expr of
Nothing -> (constants, ops ++ [Opreturn], lvars)
Just expr -> let
(expr_constants, expr_ops, _) = assembleExpression (constants, ops, lvars) expr
in
(expr_constants, expr_ops ++ [returnOperation stype], lvars)
assembleStatement (constants, ops, lvars) (TypedStatement _ (Block statements)) =
foldl assembleStatement (constants, ops, lvars) statements
assembleStatement (constants, ops, lvars) (TypedStatement _ (If expr if_stmt else_stmt)) = let
(constants_cmp, ops_cmp, _) = assembleExpression (constants, [], lvars) expr
(constants_ifa, ops_ifa, _) = assembleStatement (constants_cmp, [], lvars) if_stmt
(constants_elsea, ops_elsea, _) = case else_stmt of
Nothing -> (constants_ifa, [], lvars)
Just stmt -> assembleStatement (constants_ifa, [], lvars) stmt
-- +6 because we insert 2 gotos, one for if, one for else
if_length = sum (map opcodeEncodingLength ops_ifa) + 6
-- +3 because we need to account for the goto in the if statement.
else_length = sum (map opcodeEncodingLength ops_elsea) + 3
in
(constants_ifa, ops ++ ops_cmp ++ [Opsipush 0, Opif_icmpeq if_length] ++ ops_ifa ++ [Opgoto else_length] ++ ops_elsea, lvars)
assembleStatement (constants, ops, lvars) (TypedStatement _ (While expr stmt)) = let
(constants_cmp, ops_cmp, _) = assembleExpression (constants, [], lvars) expr
(constants_stmta, ops_stmta, _) = assembleStatement (constants_cmp, [], lvars) stmt
-- +3 because we insert 2 gotos, one for the comparison, one for the goto back to the comparison
stmt_length = sum (map opcodeEncodingLength ops_stmta) + 6
entire_length = stmt_length + sum (map opcodeEncodingLength ops_cmp)
in
(constants_stmta, ops ++ ops_cmp ++ [Opsipush 0, Opif_icmpeq stmt_length] ++ ops_stmta ++ [Opgoto (-entire_length)], lvars)
assembleStatement (constants, ops, lvars) (TypedStatement _ (LocalVariableDeclaration (VariableDeclaration dtype name expr))) = let
isPrimitive = elem dtype ["char", "boolean", "int"]
(constants_init, ops_init, _) = case expr of
Just exp -> assembleExpression (constants, ops, lvars) exp
Nothing -> (constants, ops ++ if isPrimitive then [Opsipush 0] else [Opaconst_null], lvars)
localIndex = fromIntegral (length lvars)
storeLocal = if isPrimitive then [Opistore localIndex] else [Opastore localIndex]
in
(constants_init, ops_init ++ storeLocal, lvars ++ [name])
assembleStatement (constants, ops, lvars) (TypedStatement _ (StatementExpressionStatement expr)) =
assembleStatementExpression (constants, ops, lvars) expr
assembleStatement _ stmt = error ("Not yet implemented: " ++ show stmt)

20
src/ByteCode/Generation/Assembler/Method.hs Normal file
View File

@ -0,0 +1,20 @@
module ByteCode.Generation.Assembler.Method where
import Ast
import ByteCode.ClassFile(ClassFile (..), ConstantInfo (..), MemberInfo(..), Operation(..), Attribute(..), opcodeEncodingLength)
import ByteCode.Generation.Generator
import ByteCode.Generation.Assembler.ExpressionAndStatement
assembleMethod :: Assembler MethodDeclaration
assembleMethod (constants, ops, lvars) (MethodDeclaration _ name _ (TypedStatement _ (Block statements)))
| name == "<init>" = 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)
| otherwise = let
(constants_a, ops_a, lvars_a) = foldl assembleStatement (constants, ops, lvars) statements
init_ops = [Opaload 0]
in
(constants_a, init_ops ++ ops_a, lvars_a)
assembleMethod _ (MethodDeclaration _ _ _ stmt) = error ("Block expected for method body, got: " ++ show stmt)

44
src/ByteCode/Generation/Builder/Class.hs Normal file
View File

@ -0,0 +1,44 @@
module ByteCode.Generation.Builder.Class where
import ByteCode.Generation.Builder.Field
import ByteCode.Generation.Builder.Method
import ByteCode.Generation.Generator
import Ast
import ByteCode.ClassFile(ClassFile (..), ConstantInfo (..), MemberInfo(..), Operation(..), Attribute(..), opcodeEncodingLength)
import ByteCode.Constants
injectDefaultConstructor :: [MethodDeclaration] -> [MethodDeclaration]
injectDefaultConstructor pre
| any (\(MethodDeclaration _ name _ _) -> name == "<init>") pre = pre
| otherwise = pre ++ [MethodDeclaration "void" "<init>" [] (TypedStatement "void" (Block []))]
classBuilder :: ClassFileBuilder Class
classBuilder (Class name methods fields) _ = let
baseConstants = [
ClassInfo 4,
MethodRefInfo 1 3,
NameAndTypeInfo 5 6,
Utf8Info "java/lang/Object",
Utf8Info "<init>",
Utf8Info "()V",
Utf8Info "Code"
]
nameConstants = [ClassInfo 9, Utf8Info name]
nakedClassFile = ClassFile {
constantPool = baseConstants ++ nameConstants,
accessFlags = accessPublic,
thisClass = 8,
superClass = 1,
fields = [],
methods = [],
attributes = []
}
methodsWithInjectedConstructor = injectDefaultConstructor methods
classFileWithFields = foldr fieldBuilder nakedClassFile fields
classFileWithMethods = foldr methodBuilder classFileWithFields methodsWithInjectedConstructor
classFileWithAssembledMethods = foldr methodAssembler classFileWithMethods methodsWithInjectedConstructor
in
classFileWithAssembledMethods

46
src/ByteCode/Generation/Builder/Field.hs Normal file
View File

@ -0,0 +1,46 @@
module ByteCode.Generation.Builder.Field where
import Ast
import ByteCode.ClassFile(ClassFile (..), ConstantInfo (..), MemberInfo(..), Operation(..), Attribute(..), opcodeEncodingLength)
import ByteCode.Generation.Generator
import ByteCode.Constants
import Data.List
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 _ _) <- (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
fieldBuilder :: ClassFileBuilder VariableDeclaration
fieldBuilder (VariableDeclaration datatype name _) input = let
baseIndex = 1 + length (constantPool input)
constants = [
FieldRefInfo (fromIntegral (thisClass input)) (fromIntegral (baseIndex + 1)),
NameAndTypeInfo (fromIntegral (baseIndex + 2)) (fromIntegral (baseIndex + 3)),
Utf8Info name,
Utf8Info (datatypeDescriptor datatype)
]
field = MemberInfo {
memberAccessFlags = accessPublic,
memberNameIndex = (fromIntegral (baseIndex + 2)),
memberDescriptorIndex = (fromIntegral (baseIndex + 3)),
memberAttributes = []
}
in
input {
constantPool = (constantPool input) ++ constants,
fields = (fields input) ++ [field]
}

80
src/ByteCode/Generation/Builder/Method.hs Normal file
View File

@ -0,0 +1,80 @@
module ByteCode.Generation.Builder.Method where
import Ast
import ByteCode.ClassFile(ClassFile (..), ConstantInfo (..), MemberInfo(..), Operation(..), Attribute(..), opcodeEncodingLength)
import ByteCode.Generation.Generator
import ByteCode.Generation.Assembler.Method
import ByteCode.Constants
import Data.List
methodDescriptor :: MethodDeclaration -> String
methodDescriptor (MethodDeclaration returntype _ parameters _) = let
parameter_types = [datatype | ParameterDeclaration datatype _ <- parameters]
in
"("
++ (concat (map methodParameterDescriptor parameter_types))
++ ")"
++ methodParameterDescriptor returntype
methodParameterDescriptor :: String -> String
methodParameterDescriptor "void" = "V"
methodParameterDescriptor "int" = "I"
methodParameterDescriptor "char" = "C"
methodParameterDescriptor "boolean" = "B"
methodParameterDescriptor x = "L" ++ x ++ ";"
memberInfoIsMethod :: [ConstantInfo] -> MemberInfo -> Bool
memberInfoIsMethod constants info = elem '(' (memberInfoDescriptor constants info)
findMethodIndex :: ClassFile -> String -> Maybe Int
findMethodIndex classFile name = let
constants = constantPool classFile
in
findIndex (\method -> ((memberInfoIsMethod constants method) && (memberInfoName constants method) == name)) (methods classFile)
methodBuilder :: ClassFileBuilder MethodDeclaration
methodBuilder (MethodDeclaration returntype name parameters statement) input = let
baseIndex = 1 + length (constantPool input)
constants = [
Utf8Info name,
Utf8Info (methodDescriptor (MethodDeclaration returntype name parameters (Block [])))
]
method = MemberInfo {
memberAccessFlags = accessPublic,
memberNameIndex = (fromIntegral baseIndex),
memberDescriptorIndex = (fromIntegral (baseIndex + 1)),
memberAttributes = []
}
in
input {
constantPool = (constantPool input) ++ constants,
methods = (methods input) ++ [method]
}
methodAssembler :: ClassFileBuilder MethodDeclaration
methodAssembler (MethodDeclaration returntype name parameters statement) input = let
methodConstantIndex = findMethodIndex input name
in case methodConstantIndex of
Nothing -> error ("Cannot find method entry in method pool for method: " ++ name)
Just index -> let
declaration = MethodDeclaration returntype name parameters statement
paramNames = "this" : [name | ParameterDeclaration _ name <- parameters]
(pre, method : post) = splitAt index (methods input)
(_, bytecode, _) = assembleMethod (constantPool input, [], paramNames) declaration
assembledMethod = method {
memberAttributes = [
CodeAttribute {
attributeMaxStack = 420,
attributeMaxLocals = 420,
attributeCode = bytecode
}
]
}
in
input {
methods = pre ++ (assembledMethod : post)
}

73
src/ByteCode/Generation/Generator.hs Normal file
View File

@ -0,0 +1,73 @@
module ByteCode.Generation.Generator(
datatypeDescriptor,
memberInfoName,
memberInfoDescriptor,
returnOperation,
binaryOperation,
comparisonOperation,
ClassFileBuilder,
Assembler
) where
import ByteCode.Constants
import ByteCode.ClassFile (ClassFile (..), ConstantInfo (..), MemberInfo(..), Operation(..), Attribute(..), opcodeEncodingLength)
import Ast
import Data.Char
import Data.List
import Data.Word
type ClassFileBuilder a = a -> ClassFile -> ClassFile
type Assembler a = ([ConstantInfo], [Operation], [String]) -> a -> ([ConstantInfo], [Operation], [String])
datatypeDescriptor :: String -> String
datatypeDescriptor "void" = "V"
datatypeDescriptor "int" = "I"
datatypeDescriptor "char" = "C"
datatypeDescriptor "boolean" = "B"
datatypeDescriptor x = "L" ++ x
memberInfoDescriptor :: [ConstantInfo] -> MemberInfo -> String
memberInfoDescriptor constants MemberInfo {
memberAccessFlags = _,
memberNameIndex = _,
memberDescriptorIndex = descriptorIndex,
memberAttributes = _ } = let
descriptor = constants!!((fromIntegral descriptorIndex) - 1)
in case descriptor of
Utf8Info descriptorText -> descriptorText
_ -> ("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)
in case name of
Utf8Info nameText -> nameText
_ -> ("Invalid Item at Constant pool index " ++ show nameIndex)
returnOperation :: DataType -> Operation
returnOperation dtype
| elem dtype ["int", "char", "boolean"] = Opireturn
| otherwise = Opareturn
binaryOperation :: BinaryOperator -> Operation
binaryOperation Addition = Opiadd
binaryOperation Subtraction = Opisub
binaryOperation Multiplication = Opimul
binaryOperation Division = Opidiv
binaryOperation BitwiseAnd = Opiand
binaryOperation BitwiseOr = Opior
binaryOperation BitwiseXor = Opixor
comparisonOperation :: BinaryOperator -> Word16 -> Operation
comparisonOperation CompareEqual branchLocation = Opif_icmpeq branchLocation
comparisonOperation CompareNotEqual branchLocation = Opif_icmpne branchLocation
comparisonOperation CompareLessThan branchLocation = Opif_icmplt branchLocation
comparisonOperation CompareLessOrEqual branchLocation = Opif_icmple branchLocation
comparisonOperation CompareGreaterThan branchLocation = Opif_icmpgt branchLocation
comparisonOperation CompareGreaterOrEqual branchLocation = Opif_icmpge branchLocation

503
src/ByteCode/Generator.hs
View File

@ -1,503 +0,0 @@
module ByteCode.Generator(
datatypeDescriptor,
memberInfoName,
memberInfoDescriptor,
returnOperation,
binaryOperation,
comparisonOperation,
ClassFileBuilder,
Assembler,
classBuilder
) where
import ByteCode.Constants
import ByteCode.ClassFile (ClassFile (..), ConstantInfo (..), MemberInfo(..), Operation(..), Attribute(..), opcodeEncodingLength)
import Ast
import Data.Char
import Data.List
import Data.Word
type ClassFileBuilder a = a -> ClassFile -> ClassFile
type Assembler a = ([ConstantInfo], [Operation], [String]) -> a -> ([ConstantInfo], [Operation], [String])
methodDescriptor :: MethodDeclaration -> String
methodDescriptor (MethodDeclaration returntype _ parameters _) = let
parameter_types = [datatype | ParameterDeclaration datatype _ <- parameters]
in
"("
++ (concat (map methodParameterDescriptor parameter_types))
++ ")"
++ methodParameterDescriptor returntype
methodParameterDescriptor :: String -> String
methodParameterDescriptor "void" = "V"
methodParameterDescriptor "int" = "I"
methodParameterDescriptor "char" = "C"
methodParameterDescriptor "boolean" = "B"
methodParameterDescriptor x = "L" ++ x ++ ";"
memberInfoIsMethod :: [ConstantInfo] -> MemberInfo -> Bool
memberInfoIsMethod constants info = elem '(' (memberInfoDescriptor constants info)
datatypeDescriptor :: String -> String
datatypeDescriptor "void" = "V"
datatypeDescriptor "int" = "I"
datatypeDescriptor "char" = "C"
datatypeDescriptor "boolean" = "B"
datatypeDescriptor x = "L" ++ x
memberInfoDescriptor :: [ConstantInfo] -> MemberInfo -> String
memberInfoDescriptor constants MemberInfo {
memberAccessFlags = _,
memberNameIndex = _,
memberDescriptorIndex = descriptorIndex,
memberAttributes = _ } = let
descriptor = constants!!((fromIntegral descriptorIndex) - 1)
in case descriptor of
Utf8Info descriptorText -> descriptorText
_ -> ("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)
in case name of
Utf8Info nameText -> nameText
_ -> ("Invalid Item at Constant pool index " ++ show nameIndex)
returnOperation :: DataType -> Operation
returnOperation dtype
| elem dtype ["int", "char", "boolean"] = Opireturn
| otherwise = Opareturn
binaryOperation :: BinaryOperator -> Operation
binaryOperation Addition = Opiadd
binaryOperation Subtraction = Opisub
binaryOperation Multiplication = Opimul
binaryOperation Division = Opidiv
binaryOperation BitwiseAnd = Opiand
binaryOperation BitwiseOr = Opior
binaryOperation BitwiseXor = Opixor
comparisonOperation :: BinaryOperator -> Word16 -> Operation
comparisonOperation CompareEqual branchLocation = Opif_icmpeq branchLocation
comparisonOperation CompareNotEqual branchLocation = Opif_icmpne branchLocation
comparisonOperation CompareLessThan branchLocation = Opif_icmplt branchLocation
comparisonOperation CompareLessOrEqual branchLocation = Opif_icmple branchLocation
comparisonOperation CompareGreaterThan branchLocation = Opif_icmpgt branchLocation
comparisonOperation CompareGreaterOrEqual branchLocation = Opif_icmpge branchLocation
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 _ _) <- (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)
fieldBuilder :: ClassFileBuilder VariableDeclaration
fieldBuilder (VariableDeclaration datatype name _) input = let
baseIndex = 1 + length (constantPool input)
constants = [
FieldRefInfo (fromIntegral (thisClass input)) (fromIntegral (baseIndex + 1)),
NameAndTypeInfo (fromIntegral (baseIndex + 2)) (fromIntegral (baseIndex + 3)),
Utf8Info name,
Utf8Info (datatypeDescriptor datatype)
]
field = MemberInfo {
memberAccessFlags = accessPublic,
memberNameIndex = (fromIntegral (baseIndex + 2)),
memberDescriptorIndex = (fromIntegral (baseIndex + 3)),
memberAttributes = []
}
in
input {
constantPool = (constantPool input) ++ constants,
fields = (fields input) ++ [field]
}
methodBuilder :: ClassFileBuilder MethodDeclaration
methodBuilder (MethodDeclaration returntype name parameters statement) input = let
baseIndex = 1 + length (constantPool input)
constants = [
MethodRefInfo (fromIntegral (thisClass input)) (fromIntegral (baseIndex + 1)),
NameAndTypeInfo (fromIntegral (baseIndex + 2)) (fromIntegral (baseIndex + 3)),
Utf8Info name,
Utf8Info (methodDescriptor (MethodDeclaration returntype name parameters (Block [])))
]
method = MemberInfo {
memberAccessFlags = accessPublic,
memberNameIndex = (fromIntegral (baseIndex + 2)),
memberDescriptorIndex = (fromIntegral (baseIndex + 3)),
memberAttributes = []
}
in
input {
constantPool = (constantPool input) ++ constants,
methods = (methods input) ++ [method]
}
methodAssembler :: ClassFileBuilder MethodDeclaration
methodAssembler (MethodDeclaration returntype name parameters statement) input = let
methodConstantIndex = findMethodIndex input name
in case methodConstantIndex of
Nothing -> error ("Cannot find method entry in method pool for method: " ++ name)
Just index -> let
declaration = MethodDeclaration returntype name parameters statement
paramNames = "this" : [name | ParameterDeclaration _ name <- parameters]
in case (splitAt index (methods input)) of
(pre, []) -> input
(pre, method : post) -> let
(_, bytecode, _) = assembleMethod (constantPool input, [], paramNames) declaration
assembledMethod = method {
memberAttributes = [
CodeAttribute {
attributeMaxStack = 420,
attributeMaxLocals = 420,
attributeCode = bytecode
}
]
}
in
input {
methods = pre ++ (assembledMethod : post)
}
injectDefaultConstructor :: [MethodDeclaration] -> [MethodDeclaration]
injectDefaultConstructor pre
| any (\(MethodDeclaration _ name _ _) -> name == "<init>") pre = pre
| otherwise = pre ++ [MethodDeclaration "void" "<init>" [] (TypedStatement "void" (Block []))]
classBuilder :: ClassFileBuilder Class
classBuilder (Class name methods fields) _ = let
baseConstants = [
ClassInfo 4,
MethodRefInfo 1 3,
NameAndTypeInfo 5 6,
Utf8Info "java/lang/Object",
Utf8Info "<init>",
Utf8Info "()V",
Utf8Info "Code"
]
nameConstants = [ClassInfo 9, Utf8Info name]
nakedClassFile = ClassFile {
constantPool = baseConstants ++ nameConstants,
accessFlags = accessPublic,
thisClass = 8,
superClass = 1,
fields = [],
methods = [],
attributes = []
}
methodsWithInjectedConstructor = injectDefaultConstructor methods
classFileWithFields = foldr fieldBuilder nakedClassFile fields
classFileWithMethods = foldr methodBuilder classFileWithFields methodsWithInjectedConstructor
classFileWithAssembledMethods = foldr methodAssembler classFileWithMethods methodsWithInjectedConstructor
in
classFileWithAssembledMethods
assembleExpression :: Assembler Expression
assembleExpression (constants, ops, lvars) (TypedExpression _ (BinaryOperation op a b))
| elem op [Addition, Subtraction, Multiplication, Division, BitwiseAnd, BitwiseOr, BitwiseXor] = 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
(aConstants, aOps, _) = assembleExpression (constants, ops, lvars) a
(bConstants, bOps, _) = assembleExpression (aConstants, aOps, lvars) b
cmp_op = comparisonOperation op 9
cmp_ops = [cmp_op, Opsipush 0, Opgoto 6, Opsipush 1]
in
(bConstants, bOps ++ cmp_ops, lvars)
assembleExpression (constants, ops, lvars) (TypedExpression _ (CharacterLiteral literal)) =
(constants, ops ++ [Opsipush (fromIntegral (ord literal))], lvars)
assembleExpression (constants, ops, lvars) (TypedExpression _ (BooleanLiteral literal)) =
(constants, ops ++ [Opsipush (if literal then 1 else 0)], lvars)
assembleExpression (constants, ops, lvars) (TypedExpression _ (IntegerLiteral literal))
| literal <= 32767 && literal >= -32768 = (constants, ops ++ [Opsipush (fromIntegral literal)], lvars)
| otherwise = (constants ++ [IntegerInfo (fromIntegral literal)], ops ++ [Opldc_w (fromIntegral (1 + length constants))], lvars)
assembleExpression (constants, ops, lvars) (TypedExpression _ NullLiteral) =
(constants, ops ++ [Opaconst_null], lvars)
assembleExpression (constants, ops, lvars) (TypedExpression etype (UnaryOperation Not expr)) = let
(exprConstants, exprOps, _) = assembleExpression (constants, ops, lvars) expr
newConstant = fromIntegral (1 + length exprConstants)
in case etype of
"int" -> (exprConstants ++ [IntegerInfo 0x7FFFFFFF], exprOps ++ [Opldc_w newConstant, Opixor], lvars)
"char" -> (exprConstants, exprOps ++ [Opsipush 0xFFFF, Opixor], lvars)
"boolean" -> (exprConstants, exprOps ++ [Opsipush 0x01, Opixor], lvars)
assembleExpression (constants, ops, lvars) (TypedExpression _ (UnaryOperation Minus expr)) = let
(exprConstants, exprOps, _) = assembleExpression (constants, ops, lvars) expr
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 (LocalVariable name))
| name == "this" = (constants, ops ++ [Opaload 0], lvars)
| otherwise = let
localIndex = findIndex ((==) 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)
Nothing -> error ("No such local variable found in local variable pool: " ++ name)
assembleExpression (constants, ops, lvars) (TypedExpression dtype (StatementExpressionExpression stmtexp)) =
assembleStatementExpression (constants, ops, lvars) stmtexp
assembleExpression _ expr = error ("unimplemented: " ++ show 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)
assembleStatementExpression
(constants, ops, lvars)
(TypedStatementExpression _ (PreIncrement (TypedExpression dtype (LocalVariable name)))) = let
localIndex = findIndex ((==) name) lvars
expr = (TypedExpression dtype (LocalVariable name))
(exprConstants, exprOps, _) = assembleExpression (constants, ops, lvars) expr
incrOps = exprOps ++ [Opsipush 1, Opiadd, Opdup_x1]
in case localIndex of
Just index -> (exprConstants, incrOps ++ [Opistore (fromIntegral index)], lvars)
Nothing -> error("No such local variable found in local variable pool: " ++ name)
assembleStatementExpression
(constants, ops, lvars)
(TypedStatementExpression _ (PostIncrement (TypedExpression dtype (LocalVariable name)))) = let
localIndex = findIndex ((==) name) lvars
expr = (TypedExpression dtype (LocalVariable name))
(exprConstants, exprOps, _) = assembleExpression (constants, ops, lvars) expr
incrOps = exprOps ++ [Opdup, Opsipush 1, Opiadd]
in case localIndex of
Just index -> (exprConstants, incrOps ++ [Opistore (fromIntegral index)], lvars)
Nothing -> error("No such local variable found in local variable pool: " ++ name)
assembleStatementExpression
(constants, ops, lvars)
(TypedStatementExpression _ (PreDecrement (TypedExpression dtype (LocalVariable name)))) = let
localIndex = findIndex ((==) name) lvars
expr = (TypedExpression dtype (LocalVariable name))
(exprConstants, exprOps, _) = assembleExpression (constants, ops, lvars) expr
incrOps = exprOps ++ [Opsipush 1, Opisub, Opdup_x1]
in case localIndex of
Just index -> (exprConstants, incrOps ++ [Opistore (fromIntegral index)], lvars)
Nothing -> error("No such local variable found in local variable pool: " ++ name)
assembleStatementExpression
(constants, ops, lvars)
(TypedStatementExpression _ (PostDecrement (TypedExpression dtype (LocalVariable name)))) = let
localIndex = findIndex ((==) name) lvars
expr = (TypedExpression dtype (LocalVariable name))
(exprConstants, exprOps, _) = assembleExpression (constants, ops, lvars) expr
incrOps = exprOps ++ [Opdup, Opsipush 1, Opisub]
in case localIndex of
Just index -> (exprConstants, incrOps ++ [Opistore (fromIntegral index)], lvars)
Nothing -> error("No such local variable found in local variable pool: " ++ name)
assembleStatementExpression
(constants, ops, lvars)
(TypedStatementExpression _ (PreIncrement (TypedExpression dtype (FieldVariable name)))) = let
fieldIndex = findFieldIndex constants name
expr = (TypedExpression dtype (FieldVariable name))
(exprConstants, exprOps, _) = assembleExpression (constants, ops ++ [Opaload 0], lvars) expr
incrOps = exprOps ++ [Opsipush 1, Opiadd, Opdup_x1]
in case fieldIndex of
Just index -> (exprConstants, incrOps ++ [Opputfield (fromIntegral index)], lvars)
Nothing -> error("No such field variable found in field variable pool: " ++ name)
assembleStatementExpression
(constants, ops, lvars)
(TypedStatementExpression _ (PostIncrement (TypedExpression dtype (FieldVariable name)))) = let
fieldIndex = findFieldIndex constants name
expr = (TypedExpression dtype (FieldVariable name))
(exprConstants, exprOps, _) = assembleExpression (constants, ops ++ [Opaload 0], lvars) expr
incrOps = exprOps ++ [Opdup_x1, Opsipush 1, Opiadd]
in case fieldIndex of
Just index -> (exprConstants, incrOps ++ [Opputfield (fromIntegral index)], lvars)
Nothing -> error("No such field variable found in field variable pool: " ++ name)
assembleStatementExpression
(constants, ops, lvars)
(TypedStatementExpression _ (PreDecrement (TypedExpression dtype (FieldVariable name)))) = let
fieldIndex = findFieldIndex constants name
expr = (TypedExpression dtype (FieldVariable name))
(exprConstants, exprOps, _) = assembleExpression (constants, ops ++ [Opaload 0], lvars) expr
incrOps = exprOps ++ [Opsipush 1, Opisub, Opdup_x1]
in case fieldIndex of
Just index -> (exprConstants, incrOps ++ [Opputfield (fromIntegral index)], lvars)
Nothing -> error("No such field variable found in field variable pool: " ++ name)
assembleStatementExpression
(constants, ops, lvars)
(TypedStatementExpression _ (PostDecrement (TypedExpression dtype (FieldVariable name)))) = let
fieldIndex = findFieldIndex constants name
expr = (TypedExpression dtype (FieldVariable name))
(exprConstants, exprOps, _) = assembleExpression (constants, ops ++ [Opaload 0], lvars) expr
incrOps = exprOps ++ [Opdup_x1, Opsipush 1, Opisub]
in case fieldIndex of
Just index -> (exprConstants, incrOps ++ [Opputfield (fromIntegral index)], lvars)
Nothing -> error("No such field variable found in field variable pool: " ++ name)
assembleStatementExpression
(constants, ops, lvars)
(TypedStatementExpression _ (MethodCall receiver name params)) = let
(constants_r, ops_r, lvars_r) = assembleExpression (constants, ops, lvars) 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)
assembleStatement :: Assembler Statement
assembleStatement (constants, ops, lvars) (TypedStatement stype (Return expr)) = case expr of
Nothing -> (constants, ops ++ [Opreturn], lvars)
Just expr -> let
(expr_constants, expr_ops, _) = assembleExpression (constants, ops, lvars) expr
in
(expr_constants, expr_ops ++ [returnOperation stype], lvars)
assembleStatement (constants, ops, lvars) (TypedStatement _ (Block statements)) =
foldl assembleStatement (constants, ops, lvars) statements
assembleStatement (constants, ops, lvars) (TypedStatement dtype (If expr if_stmt else_stmt)) = let
(constants_cmp, ops_cmp, _) = assembleExpression (constants, [], lvars) expr
(constants_ifa, ops_ifa, _) = assembleStatement (constants_cmp, [], lvars) if_stmt
(constants_elsea, ops_elsea, _) = case else_stmt of
Nothing -> (constants_ifa, [], lvars)
Just stmt -> assembleStatement (constants_ifa, [], lvars) stmt
-- +6 because we insert 2 gotos, one for if, one for else
if_length = sum (map opcodeEncodingLength ops_ifa)
-- +3 because we need to account for the goto in the if statement.
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)
assembleStatement (constants, ops, lvars) (TypedStatement _ (While expr stmt)) = let
(constants_cmp, ops_cmp, _) = assembleExpression (constants, [], lvars) expr
(constants_stmta, ops_stmta, _) = assembleStatement (constants_cmp, [], lvars) stmt
-- +3 because we insert 2 gotos, one for the comparison, one for the goto back to the comparison
stmt_length = sum (map opcodeEncodingLength ops_stmta) + 6
entire_length = stmt_length + sum (map opcodeEncodingLength ops_cmp)
in
(constants_stmta, ops ++ ops_cmp ++ [Opsipush 0, Opif_icmpeq stmt_length] ++ ops_stmta ++ [Opgoto (-entire_length)], lvars)
assembleStatement (constants, ops, lvars) (TypedStatement _ (LocalVariableDeclaration (VariableDeclaration dtype name expr))) = let
isPrimitive = elem dtype ["char", "boolean", "int"]
(constants_init, ops_init, _) = case expr of
Just exp -> assembleExpression (constants, ops, lvars) exp
Nothing -> (constants, ops ++ if isPrimitive then [Opsipush 0] else [Opaconst_null], lvars)
localIndex = fromIntegral (length lvars)
storeLocal = if isPrimitive then [Opistore localIndex] else [Opastore localIndex]
in
(constants_init, ops_init ++ storeLocal, lvars ++ [name])
assembleStatement (constants, ops, lvars) (TypedStatement _ (StatementExpressionStatement expr)) = let
(constants_e, ops_e, lvars_e) = assembleStatementExpression (constants, ops, lvars) expr
in
(constants_e, ops_e ++ [Oppop], lvars_e)
assembleStatement _ stmt = error ("Not yet implemented: " ++ show stmt)
assembleMethod :: Assembler MethodDeclaration
assembleMethod (constants, ops, lvars) (MethodDeclaration _ name _ (TypedStatement _ (Block statements)))
| name == "<init>" = 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)
| otherwise = foldl assembleStatement (constants, ops, lvars) statements
assembleMethod _ (MethodDeclaration _ _ _ stmt) = error ("Block expected for method body, got: " ++ show stmt)

3
src/Main.hs
View File

@ -4,7 +4,8 @@ import Example
import Typecheck
import Parser.Lexer (alexScanTokens)
import Parser.JavaParser
import ByteCode.Generator
import ByteCode.Generation.Generator
import ByteCode.Generation.Builder.Class
import ByteCode.ClassFile
import Data.ByteString (pack, writeFile)

8
src/Parser/JavaParser.y
View File

@ -83,11 +83,11 @@ typedeclarations : typedeclaration { [$1] }
| typedeclarations typedeclaration { $1 ++ [$2] }
name : simplename { Reference $1 }
| qualifiedname { $1 }
-- | qualifiedname { }
typedeclaration : classdeclaration { $1 }
qualifiedname : name DOT IDENTIFIER { BinaryOperation NameResolution $1 (Reference $3) }
qualifiedname : name DOT IDENTIFIER { }
simplename : IDENTIFIER { $1 }
@ -297,7 +297,7 @@ classinstancecreationexpression : NEW classtype LBRACE RBRACE { }
conditionalandexpression : inclusiveorexpression { $1 }
fieldaccess : primary DOT IDENTIFIER { BinaryOperation NameResolution $1 (Reference $3) }
fieldaccess : primary DOT IDENTIFIER { }
unaryexpression : unaryexpressionnotplusminus { $1 }
| predecrementexpression { StatementExpressionExpression $1 }
@ -319,7 +319,7 @@ primarynonewarray : literal { $1 }
| THIS { Reference "this" }
| LBRACE expression RBRACE { $2 }
-- | classinstancecreationexpression { }
| fieldaccess { $1 }
-- | fieldaccess { }
| methodinvocation { StatementExpressionExpression $1 }
unaryexpressionnotplusminus : postfixexpression { $1 }