Compare commits
122 Commits
7cbf8aad08
...
b1735c6300
Author | SHA1 | Date | |
---|---|---|---|
b1735c6300 | |||
f02226bca8 | |||
7e13b3fac3 | |||
2139e7832c | |||
baf9362634 | |||
710ec43959 | |||
b525d14192 | |||
a62fe50a0d | |||
7c52084bbe | |||
|
98b02446ba | ||
82b2b4a6e1 | |||
3d351ee02b | |||
05b599b8ff | |||
060321f323 | |||
fc96eba52e | |||
af093fa3bb | |||
666856b33a | |||
30365d76bd | |||
|
2b7d217e8a | ||
2acba0f283 | |||
84613fabe0 | |||
408111df51 | |||
|
6abb9ae8ba | ||
45114caffb | |||
a62d4c35e1 | |||
4c82f5bfdd | |||
8cf022e6e0 | |||
d4f474ba54 | |||
761244df74 | |||
c690b01396 | |||
56cc1a9374 | |||
25c0c33109 | |||
|
5aa193bc08 | ||
|
2e7c28812b | ||
|
2ac3b60e79 | ||
1e59ba9e27 | |||
f4d31a85cc | |||
0694dfb77d | |||
6ab64371b5 | |||
067bf8d796 | |||
24c2920c9c | |||
3c70f9f1f6 | |||
|
6f4143a60a | ||
c347e6c630 | |||
|
fadbdf1035 | ||
f81a812f59 | |||
|
d0d2cbd081 | ||
e95377ee72 | |||
|
ddab04f063 | ||
|
09f70ca789 | ||
2a502a6c67 | |||
|
d13e24c216 | ||
|
53e1afc9e4 | ||
|
535a6891ad | ||
07837f7d5f | |||
a80dc1d34b | |||
e572975bda | |||
|
207fb5c5f3 | ||
b11adcf907 | |||
b095678769 | |||
a4d41b9ef7 | |||
9f658397de | |||
524c667c43 | |||
|
a4fff37b07 | ||
|
c02de8f9b2 | ||
|
a179dec3ea | ||
5723f6c662 | |||
|
95178366a2 | ||
fef619ac03 | |||
|
f9f984568f | ||
a7b4c7e58e | |||
|
5284d6ecba | ||
aa3b196ab5 | |||
|
d1d9a5d6e1 | ||
7ba9743b0a | |||
83e6964d71 | |||
f8b0b59c5d | |||
fae3498bd9 | |||
3fa9736172 | |||
|
86e15b5856 | ||
|
393253c9bb | ||
|
09469e0e45 | ||
64829c2086 | |||
666fb4ee1a | |||
e350c23db1 | |||
20184c5e26 | |||
c29aa13d69 | |||
de078639fc | |||
1d5463582f | |||
4f61431c79 | |||
f82776e636 | |||
8de0309107 | |||
90fa658c8f | |||
ebf54bf4cb | |||
b957f512ad | |||
b82e205bcd | |||
98321fa162 | |||
58367a95e6 | |||
ea18431b77 | |||
9e6f31479f | |||
f183b8b183 | |||
3130f7f7d4 | |||
f57f360abf | |||
5e90f0d0ee | |||
301b87c9ac | |||
decc909c23 | |||
|
d54c7cd7e6 | ||
|
9d7af6effb | ||
c49b7f556c | |||
c8ce7f4b43 | |||
ebfb912183 | |||
e8151ad2f0 | |||
a4b933d659 | |||
2f81f82661 | |||
fecc7eceaa | |||
5e8a2a90ed | |||
158197b440 | |||
e3fa3efd95 | |||
d3ea0d6d7b | |||
bea9a039a8 | |||
32cce1f137 | |||
e04c475c55 |
@ -107,10 +107,12 @@ testBasicConstantPool = TestCase $ assertEqual "basic constant pool" expectedCla
|
|||||||
testFields = TestCase $ assertEqual "fields in constant pool" expectedClassWithFields $ classBuilder classWithFields emptyClassFile
|
testFields = TestCase $ assertEqual "fields in constant pool" expectedClassWithFields $ classBuilder classWithFields emptyClassFile
|
||||||
testMethodDescriptor = TestCase $ assertEqual "method descriptor" "(II)I" (methodDescriptor method)
|
testMethodDescriptor = TestCase $ assertEqual "method descriptor" "(II)I" (methodDescriptor method)
|
||||||
testMethodAssembly = TestCase $ assertEqual "method assembly" expectedClassWithMethod (classBuilder classWithMethod emptyClassFile)
|
testMethodAssembly = TestCase $ assertEqual "method assembly" expectedClassWithMethod (classBuilder classWithMethod emptyClassFile)
|
||||||
|
testFindMethodIndex = TestCase $ assertEqual "find method" (Just 0) (findMethodIndex expectedClassWithMethod "add_two_numbers")
|
||||||
|
|
||||||
tests = TestList [
|
tests = TestList [
|
||||||
TestLabel "Basic constant pool" testBasicConstantPool,
|
TestLabel "Basic constant pool" testBasicConstantPool,
|
||||||
TestLabel "Fields constant pool" testFields,
|
TestLabel "Fields constant pool" testFields,
|
||||||
TestLabel "Method descriptor building" testMethodDescriptor,
|
TestLabel "Method descriptor building" testMethodDescriptor,
|
||||||
TestLabel "Method assembly" testMethodAssembly
|
TestLabel "Method assembly" testMethodAssembly,
|
||||||
|
TestLabel "Find method by name" testFindMethodIndex
|
||||||
]
|
]
|
@ -18,11 +18,286 @@ testBooleanField = TestCase $
|
|||||||
testIntField = TestCase $
|
testIntField = TestCase $
|
||||||
assertEqual "expect class with int field" [Class "WithInt" [] [VariableDeclaration "int" "value" Nothing]] $
|
assertEqual "expect class with int field" [Class "WithInt" [] [VariableDeclaration "int" "value" Nothing]] $
|
||||||
parse [CLASS,IDENTIFIER "WithInt",LBRACKET,INT,IDENTIFIER "value",SEMICOLON,RBRACKET]
|
parse [CLASS,IDENTIFIER "WithInt",LBRACKET,INT,IDENTIFIER "value",SEMICOLON,RBRACKET]
|
||||||
|
testCustomTypeField = TestCase $
|
||||||
|
assertEqual "expect class with foo field" [Class "WithFoo" [] [VariableDeclaration "Foo" "value" Nothing]] $
|
||||||
|
parse [CLASS,IDENTIFIER "WithFoo",LBRACKET,IDENTIFIER "Foo",IDENTIFIER "value",SEMICOLON,RBRACKET]
|
||||||
|
testMultipleDeclarationSameLine = TestCase $
|
||||||
|
assertEqual "expect class with two int fields" [Class "TwoInts" [] [VariableDeclaration "int" "num1" Nothing, VariableDeclaration "int" "num2" Nothing]] $
|
||||||
|
parse [CLASS,IDENTIFIER "TwoInts",LBRACKET,INT,IDENTIFIER "num1",COMMA,IDENTIFIER "num2",SEMICOLON,RBRACKET]
|
||||||
|
testMultipleDeclarations = TestCase $
|
||||||
|
assertEqual "expect class with int and char field" [Class "Multiple" [] [VariableDeclaration "int" "value" Nothing, VariableDeclaration "char" "letter" Nothing]] $
|
||||||
|
parse [CLASS,IDENTIFIER "Multiple",LBRACKET,INT,IDENTIFIER "value",SEMICOLON,CHAR,IDENTIFIER "letter",SEMICOLON,RBRACKET]
|
||||||
|
testWithModifier = TestCase $
|
||||||
|
assertEqual "expect class with int field" [Class "WithInt" [] [VariableDeclaration "int" "value" Nothing]] $
|
||||||
|
parse [ABSTRACT,CLASS,IDENTIFIER "WithInt",LBRACKET,PUBLIC,INT,IDENTIFIER "value",SEMICOLON,RBRACKET]
|
||||||
|
|
||||||
|
testEmptyMethod = TestCase $
|
||||||
|
assertEqual "expect class with method" [Class "WithMethod" [MethodDeclaration "int" "foo" [] (Block [])] []] $
|
||||||
|
parse [CLASS,IDENTIFIER "WithMethod",LBRACKET,INT,IDENTIFIER "foo",LBRACE,RBRACE,SEMICOLON,RBRACKET]
|
||||||
|
testEmptyPrivateMethod = TestCase $
|
||||||
|
assertEqual "expect class with method" [Class "WithMethod" [MethodDeclaration "int" "foo" [] (Block [])] []] $
|
||||||
|
parse [CLASS,IDENTIFIER "WithMethod",LBRACKET,PRIVATE,INT,IDENTIFIER "foo",LBRACE,RBRACE,LBRACKET,RBRACKET,RBRACKET]
|
||||||
|
testEmptyVoidMethod = TestCase $
|
||||||
|
assertEqual "expect class with method" [Class "WithMethod" [MethodDeclaration "void" "foo" [] (Block [])] []] $
|
||||||
|
parse [CLASS,IDENTIFIER "WithMethod",LBRACKET,VOID,IDENTIFIER "foo",LBRACE,RBRACE,LBRACKET,RBRACKET,RBRACKET]
|
||||||
|
testEmptyMethodWithParam = TestCase $
|
||||||
|
assertEqual "expect class with method with param" [Class "WithParam" [MethodDeclaration "void" "foo" [ParameterDeclaration "int" "param"] (Block [])] []] $
|
||||||
|
parse [CLASS,IDENTIFIER "WithParam",LBRACKET,VOID,IDENTIFIER "foo",LBRACE,INT,IDENTIFIER "param",RBRACE,SEMICOLON,RBRACKET]
|
||||||
|
testEmptyMethodWithParams = TestCase $
|
||||||
|
assertEqual "expect class with multiple params" [Class "WithParams" [MethodDeclaration "void" "foo" [ParameterDeclaration "int" "p1",ParameterDeclaration "Custom" "p2"] (Block [])] []] $
|
||||||
|
parse [CLASS,IDENTIFIER "WithParams",LBRACKET,VOID,IDENTIFIER "foo",LBRACE,INT,IDENTIFIER "p1",COMMA,IDENTIFIER "Custom",IDENTIFIER "p2",RBRACE,SEMICOLON,RBRACKET]
|
||||||
|
testClassWithMethodAndField = TestCase $
|
||||||
|
assertEqual "expect class with method and field" [Class "WithMethodAndField" [MethodDeclaration "void" "foo" [] (Block []), MethodDeclaration "int" "bar" [] (Block [])] [VariableDeclaration "int" "value" Nothing]] $
|
||||||
|
parse [CLASS,IDENTIFIER "WithMethodAndField",LBRACKET,VOID,IDENTIFIER "foo",LBRACE,RBRACE,LBRACKET,RBRACKET,INT,IDENTIFIER "value",SEMICOLON,INT,IDENTIFIER "bar",LBRACE,RBRACE,SEMICOLON,RBRACKET]
|
||||||
|
testClassWithConstructor = TestCase $
|
||||||
|
assertEqual "expect class with constructor" [Class "WithConstructor" [MethodDeclaration "void" "<init>" [] (Block [])] []] $
|
||||||
|
parse [CLASS,IDENTIFIER "WithConstructor",LBRACKET,IDENTIFIER "WithConstructor",LBRACE,RBRACE,LBRACKET,RBRACKET,RBRACKET]
|
||||||
|
testConstructorWithParams = TestCase $
|
||||||
|
assertEqual "expect constructor with params" [Class "WithParams" [MethodDeclaration "void" "<init>" [ParameterDeclaration "int" "p1"] (Block [])] []] $
|
||||||
|
parse [CLASS,IDENTIFIER "WithParams",LBRACKET,IDENTIFIER "WithParams",LBRACE,INT,IDENTIFIER "p1",RBRACE,LBRACKET,RBRACKET,RBRACKET]
|
||||||
|
testConstructorWithStatements = TestCase $
|
||||||
|
assertEqual "expect constructor with statement" [Class "WithConstructor" [MethodDeclaration "void" "<init>" [] (Block [Return Nothing])] []] $
|
||||||
|
parse [CLASS,IDENTIFIER "WithConstructor",LBRACKET,IDENTIFIER "WithConstructor",LBRACE,RBRACE,LBRACKET,RETURN,SEMICOLON,RBRACKET,RBRACKET]
|
||||||
|
|
||||||
|
|
||||||
|
testEmptyBlock = TestCase $ assertEqual "expect empty block" [Block []] $ parseStatement [LBRACKET,RBRACKET]
|
||||||
|
testBlockWithLocalVarDecl = TestCase $
|
||||||
|
assertEqual "expect block with local var delcaration" [Block [LocalVariableDeclaration $ VariableDeclaration "int" "localvar" Nothing]] $
|
||||||
|
parseStatement [LBRACKET,INT,IDENTIFIER "localvar",SEMICOLON,RBRACKET]
|
||||||
|
testBlockWithMultipleLocalVarDecls = TestCase $
|
||||||
|
assertEqual "expect block with multiple local var declarations" [Block [LocalVariableDeclaration $ VariableDeclaration "int" "var1" Nothing, LocalVariableDeclaration $ VariableDeclaration "boolean" "var2" Nothing]] $
|
||||||
|
parseStatement [LBRACKET,INT,IDENTIFIER "var1",SEMICOLON,BOOLEAN,IDENTIFIER "var2",SEMICOLON,RBRACKET]
|
||||||
|
testNestedBlocks = TestCase $
|
||||||
|
assertEqual "expect block with block inside" [Block [Block []]] $
|
||||||
|
parseStatement [LBRACKET,LBRACKET,RBRACKET,RBRACKET]
|
||||||
|
testBlockWithEmptyStatement = TestCase $
|
||||||
|
assertEqual "expect empty block" [Block []] $
|
||||||
|
parseStatement [LBRACKET,SEMICOLON,SEMICOLON,RBRACKET]
|
||||||
|
|
||||||
|
testExpressionIntLiteral = TestCase $
|
||||||
|
assertEqual "expect IntLiteral" (IntegerLiteral 3) $
|
||||||
|
parseExpression [INTEGERLITERAL 3]
|
||||||
|
testFieldWithInitialization = TestCase $
|
||||||
|
assertEqual "expect Class with initialized field" [Class "WithInitField" [] [VariableDeclaration "int" "number" $ Just $ IntegerLiteral 3]] $
|
||||||
|
parse [CLASS,IDENTIFIER "WithInitField",LBRACKET,INT,IDENTIFIER "number",ASSIGN,INTEGERLITERAL 3,SEMICOLON,RBRACKET]
|
||||||
|
testLocalBoolWithInitialization = TestCase $
|
||||||
|
assertEqual "expect block with with initialized local var" [Block [LocalVariableDeclaration $ VariableDeclaration "boolean" "b" $ Just $ BooleanLiteral False]] $
|
||||||
|
parseStatement [LBRACKET,BOOLEAN,IDENTIFIER "b",ASSIGN,BOOLLITERAL False,SEMICOLON,RBRACKET]
|
||||||
|
testFieldNullWithInitialization = TestCase $
|
||||||
|
assertEqual "expect Class with initialized field" [Class "WithInitField" [] [VariableDeclaration "Object" "bar" $ Just NullLiteral]] $
|
||||||
|
parse [CLASS,IDENTIFIER "WithInitField",LBRACKET,IDENTIFIER "Object",IDENTIFIER "bar",ASSIGN,NULLLITERAL,SEMICOLON,RBRACKET]
|
||||||
|
testReturnVoid = TestCase $
|
||||||
|
assertEqual "expect block with return nothing" [Block [Return Nothing]] $
|
||||||
|
parseStatement [LBRACKET,RETURN,SEMICOLON,RBRACKET]
|
||||||
|
|
||||||
|
testExpressionNot = TestCase $
|
||||||
|
assertEqual "expect expression not" (UnaryOperation Not (Reference "boar")) $
|
||||||
|
parseExpression [NOT,IDENTIFIER "boar"]
|
||||||
|
testExpressionMinus = TestCase $
|
||||||
|
assertEqual "expect expression minus" (UnaryOperation Minus (Reference "boo")) $
|
||||||
|
parseExpression [MINUS,IDENTIFIER "boo"]
|
||||||
|
testExpressionMultiplication = TestCase $
|
||||||
|
assertEqual "expect multiplication" (BinaryOperation Multiplication (Reference "bar") (IntegerLiteral 3)) $
|
||||||
|
parseExpression [IDENTIFIER "bar",TIMES,INTEGERLITERAL 3]
|
||||||
|
testExpressionDivision = TestCase $
|
||||||
|
assertEqual "expect division" (BinaryOperation Division (Reference "bar") (IntegerLiteral 3)) $
|
||||||
|
parseExpression [IDENTIFIER "bar",DIV,INTEGERLITERAL 3]
|
||||||
|
testExpressionModulo = TestCase $
|
||||||
|
assertEqual "expect modulo operation" (BinaryOperation Modulo (Reference "bar") (IntegerLiteral 3)) $
|
||||||
|
parseExpression [IDENTIFIER "bar",MODULO,INTEGERLITERAL 3]
|
||||||
|
testExpressionAddition = TestCase $
|
||||||
|
assertEqual "expect addition" (BinaryOperation Addition (Reference "bar") (IntegerLiteral 3)) $
|
||||||
|
parseExpression [IDENTIFIER "bar",PLUS,INTEGERLITERAL 3]
|
||||||
|
testExpressionSubtraction = TestCase $
|
||||||
|
assertEqual "expect subtraction" (BinaryOperation Subtraction (Reference "bar") (IntegerLiteral 3)) $
|
||||||
|
parseExpression [IDENTIFIER "bar",MINUS,INTEGERLITERAL 3]
|
||||||
|
testExpressionLessThan = TestCase $
|
||||||
|
assertEqual "expect comparision less than" (BinaryOperation CompareLessThan (Reference "bar") (IntegerLiteral 3)) $
|
||||||
|
parseExpression [IDENTIFIER "bar",LESS,INTEGERLITERAL 3]
|
||||||
|
testExpressionGreaterThan = TestCase $
|
||||||
|
assertEqual "expect comparision greater than" (BinaryOperation CompareGreaterThan (Reference "bar") (IntegerLiteral 3)) $
|
||||||
|
parseExpression [IDENTIFIER "bar",GREATER,INTEGERLITERAL 3]
|
||||||
|
testExpressionLessThanEqual = TestCase $
|
||||||
|
assertEqual "expect comparision less than or equal" (BinaryOperation CompareLessOrEqual (Reference "bar") (IntegerLiteral 3)) $
|
||||||
|
parseExpression [IDENTIFIER "bar",LESSEQUAL,INTEGERLITERAL 3]
|
||||||
|
testExpressionGreaterThanOrEqual = TestCase $
|
||||||
|
assertEqual "expect comparision greater than or equal" (BinaryOperation CompareGreaterOrEqual (Reference "bar") (IntegerLiteral 3)) $
|
||||||
|
parseExpression [IDENTIFIER "bar",GREATEREQUAL,INTEGERLITERAL 3]
|
||||||
|
testExpressionEqual = TestCase $
|
||||||
|
assertEqual "expect comparison equal" (BinaryOperation CompareEqual (Reference "bar") (IntegerLiteral 3)) $
|
||||||
|
parseExpression [IDENTIFIER "bar",EQUAL,INTEGERLITERAL 3]
|
||||||
|
testExpressionNotEqual = TestCase $
|
||||||
|
assertEqual "expect comparison equal" (BinaryOperation CompareNotEqual (Reference "bar") (IntegerLiteral 3)) $
|
||||||
|
parseExpression [IDENTIFIER "bar",NOTEQUAL,INTEGERLITERAL 3]
|
||||||
|
testExpressionAnd = TestCase $
|
||||||
|
assertEqual "expect and expression" (BinaryOperation And (Reference "bar") (Reference "baz")) $
|
||||||
|
parseExpression [IDENTIFIER "bar",AND,IDENTIFIER "baz"]
|
||||||
|
testExpressionXor = TestCase $
|
||||||
|
assertEqual "expect xor expression" (BinaryOperation BitwiseXor (Reference "bar") (Reference "baz")) $
|
||||||
|
parseExpression [IDENTIFIER "bar",XOR,IDENTIFIER "baz"]
|
||||||
|
testExpressionOr = TestCase $
|
||||||
|
assertEqual "expect or expression" (BinaryOperation Or (Reference "bar") (Reference "baz")) $
|
||||||
|
parseExpression [IDENTIFIER "bar",OR,IDENTIFIER "baz"]
|
||||||
|
testExpressionPostIncrement = TestCase $
|
||||||
|
assertEqual "expect PostIncrement" (StatementExpressionExpression $ PostIncrement (Reference "a")) $
|
||||||
|
parseExpression [IDENTIFIER "a",INCREMENT]
|
||||||
|
testExpressionPostDecrement = TestCase $
|
||||||
|
assertEqual "expect PostDecrement" (StatementExpressionExpression $ PostDecrement (Reference "a")) $
|
||||||
|
parseExpression [IDENTIFIER "a",DECREMENT]
|
||||||
|
testExpressionPreIncrement = TestCase $
|
||||||
|
assertEqual "expect PreIncrement" (StatementExpressionExpression $ PreIncrement (Reference "a")) $
|
||||||
|
parseExpression [INCREMENT,IDENTIFIER "a"]
|
||||||
|
testExpressionPreDecrement = TestCase $
|
||||||
|
assertEqual "expect PreIncrement" (StatementExpressionExpression $ PreDecrement (Reference "a")) $
|
||||||
|
parseExpression [DECREMENT,IDENTIFIER "a"]
|
||||||
|
testExpressionAssign = TestCase $
|
||||||
|
assertEqual "expect assign 5 to a" (StatementExpressionExpression (Assignment (Reference "a") (IntegerLiteral 5))) $
|
||||||
|
parseExpression [IDENTIFIER "a",ASSIGN,INTEGERLITERAL 5]
|
||||||
|
testExpressionTimesEqual = TestCase $
|
||||||
|
assertEqual "expect assign and multiplication" (StatementExpressionExpression (Assignment (Reference "a") (BinaryOperation Multiplication (Reference "a") (IntegerLiteral 5)))) $
|
||||||
|
parseExpression [IDENTIFIER "a",TIMESEQUAL,INTEGERLITERAL 5]
|
||||||
|
testExpressionDivideEqual = TestCase $
|
||||||
|
assertEqual "expect assign and division" (StatementExpressionExpression (Assignment (Reference "a") (BinaryOperation Division (Reference "a") (IntegerLiteral 5)))) $
|
||||||
|
parseExpression [IDENTIFIER "a",DIVEQUAL,INTEGERLITERAL 5]
|
||||||
|
testExpressionPlusEqual = TestCase $
|
||||||
|
assertEqual "expect assign and addition" (StatementExpressionExpression (Assignment (Reference "a") (BinaryOperation Addition (Reference "a") (IntegerLiteral 5)))) $
|
||||||
|
parseExpression [IDENTIFIER "a",PLUSEQUAL,INTEGERLITERAL 5]
|
||||||
|
testExpressionMinusEqual = TestCase $
|
||||||
|
assertEqual "expect assign and subtraction" (StatementExpressionExpression (Assignment (Reference "a") (BinaryOperation Subtraction (Reference "a") (IntegerLiteral 5)))) $
|
||||||
|
parseExpression [IDENTIFIER "a",MINUSEQUAL,INTEGERLITERAL 5]
|
||||||
|
testExpressionThis = TestCase $
|
||||||
|
assertEqual "expect this" (Reference "this") $
|
||||||
|
parseExpression [THIS]
|
||||||
|
testExpressionBraced = TestCase $
|
||||||
|
assertEqual "expect braced expresssion" (BinaryOperation Multiplication (Reference "b") (BinaryOperation Addition (Reference "a") (IntegerLiteral 3))) $
|
||||||
|
parseExpression [IDENTIFIER "b",TIMES,LBRACE,IDENTIFIER "a",PLUS,INTEGERLITERAL 3,RBRACE]
|
||||||
|
|
||||||
|
testExpressionPrecedence = TestCase $
|
||||||
|
assertEqual "expect times to be inner expression" (BinaryOperation Addition (BinaryOperation Multiplication (Reference "b") (Reference "a")) (IntegerLiteral 3)) $
|
||||||
|
parseExpression [IDENTIFIER "b",TIMES,IDENTIFIER "a",PLUS,INTEGERLITERAL 3]
|
||||||
|
|
||||||
|
testExpressionMethodCallNoParams = TestCase $
|
||||||
|
assertEqual "expect methodcall no params" (StatementExpressionExpression (MethodCall (Reference "this") "foo" [])) $
|
||||||
|
parseExpression [IDENTIFIER "foo",LBRACE,RBRACE]
|
||||||
|
testExpressionMethodCallOneParam = TestCase $
|
||||||
|
assertEqual "expect methodcall one param" (StatementExpressionExpression (MethodCall (Reference "this") "foo" [Reference "a"])) $
|
||||||
|
parseExpression [IDENTIFIER "foo",LBRACE,IDENTIFIER "a",RBRACE]
|
||||||
|
testExpressionMethodCallTwoParams = TestCase $
|
||||||
|
assertEqual "expect methocall two params" (StatementExpressionExpression (MethodCall (Reference "this") "foo" [Reference "a", IntegerLiteral 5])) $
|
||||||
|
parseExpression [IDENTIFIER "foo",LBRACE,IDENTIFIER "a",COMMA,INTEGERLITERAL 5,RBRACE]
|
||||||
|
testExpressionThisMethodCall = TestCase $
|
||||||
|
assertEqual "expect this methocall" (StatementExpressionExpression (MethodCall (Reference "this") "foo" [])) $
|
||||||
|
parseExpression [THIS,DOT,IDENTIFIER "foo",LBRACE,RBRACE]
|
||||||
|
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"]
|
||||||
|
testExpressionConstructorCall = TestCase $
|
||||||
|
assertEqual "expect constructor call" (StatementExpressionExpression (ConstructorCall "Foo" [])) $
|
||||||
|
parseExpression [NEW,IDENTIFIER "Foo",LBRACE,RBRACE]
|
||||||
|
|
||||||
|
testStatementIfThen = TestCase $
|
||||||
|
assertEqual "expect empty ifthen" [If (Reference "a") (Block [Block []]) Nothing] $
|
||||||
|
parseStatement [IF,LBRACE,IDENTIFIER "a",RBRACE,LBRACKET,RBRACKET]
|
||||||
|
testStatementIfThenElse = TestCase $
|
||||||
|
assertEqual "expect empty ifthen" [If (Reference "a") (Block [Block []]) (Just (Block [Block []]))] $
|
||||||
|
parseStatement [IF,LBRACE,IDENTIFIER "a",RBRACE,LBRACKET,RBRACKET,ELSE,LBRACKET,RBRACKET]
|
||||||
|
testStatementWhile = TestCase $
|
||||||
|
assertEqual "expect while" [While (Reference "a") (Block [Block []])] $
|
||||||
|
parseStatement [WHILE,LBRACE,IDENTIFIER "a",RBRACE,LBRACKET,RBRACKET]
|
||||||
|
testStatementAssign = TestCase $
|
||||||
|
assertEqual "expect assign 5" [StatementExpressionStatement (Assignment (Reference "a") (IntegerLiteral 5))] $
|
||||||
|
parseStatement [IDENTIFIER "a",ASSIGN,INTEGERLITERAL 5,SEMICOLON]
|
||||||
|
|
||||||
|
testStatementMethodCallNoParams = TestCase $
|
||||||
|
assertEqual "expect methodcall statement no params" [StatementExpressionStatement (MethodCall (Reference "this") "foo" [])] $
|
||||||
|
parseStatement [IDENTIFIER "foo",LBRACE,RBRACE,SEMICOLON]
|
||||||
|
testStatementConstructorCall = TestCase $
|
||||||
|
assertEqual "expect constructor call" [StatementExpressionStatement (ConstructorCall "Foo" [])] $
|
||||||
|
parseStatement [NEW,IDENTIFIER "Foo",LBRACE,RBRACE,SEMICOLON]
|
||||||
|
testStatementConstructorCallWithArgs = TestCase $
|
||||||
|
assertEqual "expect constructor call" [StatementExpressionStatement (ConstructorCall "Foo" [Reference "b"])] $
|
||||||
|
parseStatement [NEW,IDENTIFIER "Foo",LBRACE,IDENTIFIER "b",RBRACE,SEMICOLON]
|
||||||
|
|
||||||
|
testStatementPreIncrement = TestCase $
|
||||||
|
assertEqual "expect increment" [StatementExpressionStatement $ PostIncrement $ Reference "a"] $
|
||||||
|
parseStatement [IDENTIFIER "a",INCREMENT,SEMICOLON]
|
||||||
|
|
||||||
|
|
||||||
tests = TestList [
|
tests = TestList [
|
||||||
testSingleEmptyClass,
|
testSingleEmptyClass,
|
||||||
testTwoEmptyClasses,
|
testTwoEmptyClasses,
|
||||||
testBooleanField,
|
testBooleanField,
|
||||||
testIntField
|
testIntField,
|
||||||
|
testCustomTypeField,
|
||||||
|
testMultipleDeclarations,
|
||||||
|
testWithModifier,
|
||||||
|
testEmptyMethod,
|
||||||
|
testEmptyPrivateMethod,
|
||||||
|
testEmptyVoidMethod,
|
||||||
|
testEmptyMethodWithParam,
|
||||||
|
testEmptyMethodWithParams,
|
||||||
|
testClassWithMethodAndField,
|
||||||
|
testClassWithConstructor,
|
||||||
|
testConstructorWithParams,
|
||||||
|
testConstructorWithStatements,
|
||||||
|
testEmptyBlock,
|
||||||
|
testBlockWithLocalVarDecl,
|
||||||
|
testBlockWithMultipleLocalVarDecls,
|
||||||
|
testNestedBlocks,
|
||||||
|
testBlockWithEmptyStatement,
|
||||||
|
testExpressionIntLiteral,
|
||||||
|
testFieldWithInitialization,
|
||||||
|
testLocalBoolWithInitialization,
|
||||||
|
testFieldNullWithInitialization,
|
||||||
|
testReturnVoid,
|
||||||
|
testExpressionNot,
|
||||||
|
testExpressionMinus,
|
||||||
|
testExpressionLessThan,
|
||||||
|
testExpressionGreaterThan,
|
||||||
|
testExpressionLessThanEqual,
|
||||||
|
testExpressionGreaterThanOrEqual,
|
||||||
|
testExpressionEqual,
|
||||||
|
testExpressionNotEqual,
|
||||||
|
testExpressionAnd,
|
||||||
|
testExpressionXor,
|
||||||
|
testExpressionOr,
|
||||||
|
testExpressionPostIncrement,
|
||||||
|
testExpressionPostDecrement,
|
||||||
|
testExpressionPreIncrement,
|
||||||
|
testExpressionPreDecrement,
|
||||||
|
testExpressionAssign,
|
||||||
|
testExpressionTimesEqual,
|
||||||
|
testExpressionTimesEqual,
|
||||||
|
testExpressionDivideEqual,
|
||||||
|
testExpressionPlusEqual,
|
||||||
|
testExpressionMinusEqual,
|
||||||
|
testExpressionBraced,
|
||||||
|
testExpressionThis,
|
||||||
|
testExpressionPrecedence,
|
||||||
|
testExpressionMethodCallNoParams,
|
||||||
|
testExpressionMethodCallOneParam,
|
||||||
|
testExpressionMethodCallTwoParams,
|
||||||
|
testExpressionThisMethodCall,
|
||||||
|
testExpressionThisMethodCallParam,
|
||||||
|
testExpressionFieldAccess,
|
||||||
|
testExpressionSimpleFieldAccess,
|
||||||
|
testExpressionFieldSubAccess,
|
||||||
|
testExpressionConstructorCall,
|
||||||
|
testStatementIfThen,
|
||||||
|
testStatementIfThenElse,
|
||||||
|
testStatementWhile,
|
||||||
|
testStatementAssign,
|
||||||
|
testStatementMethodCallNoParams,
|
||||||
|
testStatementConstructorCall,
|
||||||
|
testStatementConstructorCallWithArgs,
|
||||||
|
testStatementPreIncrement
|
||||||
]
|
]
|
@ -12,18 +12,21 @@ executable compiler
|
|||||||
utf8-string,
|
utf8-string,
|
||||||
bytestring
|
bytestring
|
||||||
default-language: Haskell2010
|
default-language: Haskell2010
|
||||||
hs-source-dirs: src,
|
hs-source-dirs: src
|
||||||
src/ByteCode,
|
|
||||||
src/ByteCode/ClassFile
|
|
||||||
build-tool-depends: alex:alex, happy:happy
|
build-tool-depends: alex:alex, happy:happy
|
||||||
other-modules: Parser.Lexer,
|
other-modules: Parser.Lexer,
|
||||||
Parser.JavaParser
|
Parser.JavaParser,
|
||||||
Ast,
|
Ast,
|
||||||
Example,
|
Example,
|
||||||
Typecheck,
|
Typecheck,
|
||||||
ByteCode.ByteUtil,
|
ByteCode.ByteUtil,
|
||||||
ByteCode.ClassFile,
|
ByteCode.ClassFile,
|
||||||
ByteCode.ClassFile.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
|
ByteCode.Constants
|
||||||
|
|
||||||
test-suite tests
|
test-suite tests
|
||||||
|
@ -20,10 +20,14 @@ data Statement
|
|||||||
deriving (Show, Eq)
|
deriving (Show, Eq)
|
||||||
|
|
||||||
data StatementExpression
|
data StatementExpression
|
||||||
= Assignment Identifier Expression
|
= Assignment Expression Expression
|
||||||
| ConstructorCall DataType [Expression]
|
| ConstructorCall DataType [Expression]
|
||||||
| MethodCall Expression Identifier [Expression]
|
| MethodCall Expression Identifier [Expression]
|
||||||
| TypedStatementExpression DataType StatementExpression
|
| TypedStatementExpression DataType StatementExpression
|
||||||
|
| PostIncrement Expression
|
||||||
|
| PostDecrement Expression
|
||||||
|
| PreIncrement Expression
|
||||||
|
| PreDecrement Expression
|
||||||
deriving (Show, Eq)
|
deriving (Show, Eq)
|
||||||
|
|
||||||
data BinaryOperator
|
data BinaryOperator
|
||||||
@ -31,6 +35,7 @@ data BinaryOperator
|
|||||||
| Subtraction
|
| Subtraction
|
||||||
| Multiplication
|
| Multiplication
|
||||||
| Division
|
| Division
|
||||||
|
| Modulo
|
||||||
| BitwiseAnd
|
| BitwiseAnd
|
||||||
| BitwiseOr
|
| BitwiseOr
|
||||||
| BitwiseXor
|
| BitwiseXor
|
||||||
|
@ -5,7 +5,8 @@ module ByteCode.ClassFile(
|
|||||||
ClassFile(..),
|
ClassFile(..),
|
||||||
Operation(..),
|
Operation(..),
|
||||||
serialize,
|
serialize,
|
||||||
emptyClassFile
|
emptyClassFile,
|
||||||
|
opcodeEncodingLength
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Data.Word
|
import Data.Word
|
||||||
@ -31,6 +32,7 @@ data Operation = Opiadd
|
|||||||
| Opior
|
| Opior
|
||||||
| Opixor
|
| Opixor
|
||||||
| Opineg
|
| Opineg
|
||||||
|
| Opdup
|
||||||
| Opif_icmplt Word16
|
| Opif_icmplt Word16
|
||||||
| Opif_icmple Word16
|
| Opif_icmple Word16
|
||||||
| Opif_icmpgt Word16
|
| Opif_icmpgt Word16
|
||||||
@ -41,6 +43,8 @@ data Operation = Opiadd
|
|||||||
| Opreturn
|
| Opreturn
|
||||||
| Opireturn
|
| Opireturn
|
||||||
| Opareturn
|
| Opareturn
|
||||||
|
| Opinvokespecial Word16
|
||||||
|
| Opgoto Word16
|
||||||
| Opsipush Word16
|
| Opsipush Word16
|
||||||
| Opldc_w Word16
|
| Opldc_w Word16
|
||||||
| Opaload Word16
|
| Opaload Word16
|
||||||
@ -48,7 +52,7 @@ data Operation = Opiadd
|
|||||||
| Opastore Word16
|
| Opastore Word16
|
||||||
| Opistore Word16
|
| Opistore Word16
|
||||||
| Opputfield Word16
|
| Opputfield Word16
|
||||||
| OpgetField Word16
|
| Opgetfield Word16
|
||||||
deriving (Show, Eq)
|
deriving (Show, Eq)
|
||||||
|
|
||||||
|
|
||||||
@ -87,6 +91,37 @@ emptyClassFile = ClassFile {
|
|||||||
attributes = []
|
attributes = []
|
||||||
}
|
}
|
||||||
|
|
||||||
|
opcodeEncodingLength :: Operation -> Word16
|
||||||
|
opcodeEncodingLength Opiadd = 1
|
||||||
|
opcodeEncodingLength Opisub = 1
|
||||||
|
opcodeEncodingLength Opimul = 1
|
||||||
|
opcodeEncodingLength Opidiv = 1
|
||||||
|
opcodeEncodingLength Opiand = 1
|
||||||
|
opcodeEncodingLength Opior = 1
|
||||||
|
opcodeEncodingLength Opixor = 1
|
||||||
|
opcodeEncodingLength Opineg = 1
|
||||||
|
opcodeEncodingLength Opdup = 1
|
||||||
|
opcodeEncodingLength (Opif_icmplt _) = 3
|
||||||
|
opcodeEncodingLength (Opif_icmple _) = 3
|
||||||
|
opcodeEncodingLength (Opif_icmpgt _) = 3
|
||||||
|
opcodeEncodingLength (Opif_icmpge _) = 3
|
||||||
|
opcodeEncodingLength (Opif_icmpeq _) = 3
|
||||||
|
opcodeEncodingLength (Opif_icmpne _) = 3
|
||||||
|
opcodeEncodingLength Opaconst_null = 1
|
||||||
|
opcodeEncodingLength Opreturn = 1
|
||||||
|
opcodeEncodingLength Opireturn = 1
|
||||||
|
opcodeEncodingLength Opareturn = 1
|
||||||
|
opcodeEncodingLength (Opinvokespecial _) = 3
|
||||||
|
opcodeEncodingLength (Opgoto _) = 3
|
||||||
|
opcodeEncodingLength (Opsipush _) = 3
|
||||||
|
opcodeEncodingLength (Opldc_w _) = 3
|
||||||
|
opcodeEncodingLength (Opaload _) = 4
|
||||||
|
opcodeEncodingLength (Opiload _) = 4
|
||||||
|
opcodeEncodingLength (Opastore _) = 4
|
||||||
|
opcodeEncodingLength (Opistore _) = 4
|
||||||
|
opcodeEncodingLength (Opputfield _) = 3
|
||||||
|
opcodeEncodingLength (Opgetfield _) = 3
|
||||||
|
|
||||||
class Serializable a where
|
class Serializable a where
|
||||||
serialize :: a -> [Word8]
|
serialize :: a -> [Word8]
|
||||||
|
|
||||||
@ -116,6 +151,7 @@ instance Serializable Operation where
|
|||||||
serialize Opior = [0x80]
|
serialize Opior = [0x80]
|
||||||
serialize Opixor = [0x82]
|
serialize Opixor = [0x82]
|
||||||
serialize Opineg = [0x74]
|
serialize Opineg = [0x74]
|
||||||
|
serialize Opdup = [0x59]
|
||||||
serialize (Opif_icmplt branch) = 0xA1 : unpackWord16 branch
|
serialize (Opif_icmplt branch) = 0xA1 : unpackWord16 branch
|
||||||
serialize (Opif_icmple branch) = 0xA4 : unpackWord16 branch
|
serialize (Opif_icmple branch) = 0xA4 : unpackWord16 branch
|
||||||
serialize (Opif_icmpgt branch) = 0xA3 : unpackWord16 branch
|
serialize (Opif_icmpgt branch) = 0xA3 : unpackWord16 branch
|
||||||
@ -126,6 +162,8 @@ instance Serializable Operation where
|
|||||||
serialize Opreturn = [0xB1]
|
serialize Opreturn = [0xB1]
|
||||||
serialize Opireturn = [0xAC]
|
serialize Opireturn = [0xAC]
|
||||||
serialize Opareturn = [0xB0]
|
serialize Opareturn = [0xB0]
|
||||||
|
serialize (Opinvokespecial index) = 0xB7 : unpackWord16 index
|
||||||
|
serialize (Opgoto index) = 0xA7 : unpackWord16 index
|
||||||
serialize (Opsipush index) = 0x11 : unpackWord16 index
|
serialize (Opsipush index) = 0x11 : unpackWord16 index
|
||||||
serialize (Opldc_w index) = 0x13 : unpackWord16 index
|
serialize (Opldc_w index) = 0x13 : unpackWord16 index
|
||||||
serialize (Opaload index) = [0xC4, 0x19] ++ unpackWord16 index
|
serialize (Opaload index) = [0xC4, 0x19] ++ unpackWord16 index
|
||||||
@ -133,7 +171,7 @@ instance Serializable Operation where
|
|||||||
serialize (Opastore index) = [0xC4, 0x3A] ++ unpackWord16 index
|
serialize (Opastore index) = [0xC4, 0x3A] ++ unpackWord16 index
|
||||||
serialize (Opistore index) = [0xC4, 0x36] ++ unpackWord16 index
|
serialize (Opistore index) = [0xC4, 0x36] ++ unpackWord16 index
|
||||||
serialize (Opputfield index) = 0xB5 : unpackWord16 index
|
serialize (Opputfield index) = 0xB5 : unpackWord16 index
|
||||||
serialize (OpgetField index) = 0xB4 : unpackWord16 index
|
serialize (Opgetfield index) = 0xB4 : unpackWord16 index
|
||||||
|
|
||||||
instance Serializable Attribute where
|
instance Serializable Attribute where
|
||||||
serialize (CodeAttribute { attributeMaxStack = maxStack,
|
serialize (CodeAttribute { attributeMaxStack = maxStack,
|
||||||
@ -151,7 +189,7 @@ instance Serializable Attribute where
|
|||||||
++ unpackWord16 0 -- attributes_count
|
++ unpackWord16 0 -- attributes_count
|
||||||
|
|
||||||
instance Serializable ClassFile where
|
instance Serializable ClassFile where
|
||||||
serialize classfile = unpackWord32 0xC0FEBABE -- magic
|
serialize classfile = unpackWord32 0xCAFEBABE -- magic
|
||||||
++ unpackWord16 0 -- minor version
|
++ unpackWord16 0 -- minor version
|
||||||
++ unpackWord16 49 -- major version
|
++ unpackWord16 49 -- major version
|
||||||
++ unpackWord16 (fromIntegral (1 + length (constantPool classfile))) -- constant pool count
|
++ unpackWord16 (fromIntegral (1 + length (constantPool classfile))) -- constant pool count
|
||||||
|
@ -1,169 +0,0 @@
|
|||||||
module ByteCode.ClassFile.Generator(
|
|
||||||
classBuilder,
|
|
||||||
datatypeDescriptor,
|
|
||||||
methodParameterDescriptor,
|
|
||||||
methodDescriptor,
|
|
||||||
) where
|
|
||||||
|
|
||||||
import ByteCode.Constants
|
|
||||||
import ByteCode.ClassFile (ClassFile (..), ConstantInfo (..), MemberInfo(..), Operation(..), Attribute(..))
|
|
||||||
import Ast
|
|
||||||
import Data.Char
|
|
||||||
|
|
||||||
|
|
||||||
type ClassFileBuilder a = a -> ClassFile -> ClassFile
|
|
||||||
|
|
||||||
|
|
||||||
datatypeDescriptor :: String -> String
|
|
||||||
datatypeDescriptor "void" = "V"
|
|
||||||
datatypeDescriptor "int" = "I"
|
|
||||||
datatypeDescriptor "char" = "C"
|
|
||||||
datatypeDescriptor "boolean" = "B"
|
|
||||||
datatypeDescriptor x = "L" ++ x
|
|
||||||
|
|
||||||
methodParameterDescriptor :: String -> String
|
|
||||||
methodParameterDescriptor "void" = "V"
|
|
||||||
methodParameterDescriptor "int" = "I"
|
|
||||||
methodParameterDescriptor "char" = "C"
|
|
||||||
methodParameterDescriptor "boolean" = "B"
|
|
||||||
methodParameterDescriptor x = "L" ++ x ++ ";"
|
|
||||||
|
|
||||||
methodDescriptor :: MethodDeclaration -> String
|
|
||||||
methodDescriptor (MethodDeclaration returntype _ parameters _) = let
|
|
||||||
parameter_types = [datatype | ParameterDeclaration datatype _ <- parameters]
|
|
||||||
in
|
|
||||||
"("
|
|
||||||
++ (concat (map methodParameterDescriptor parameter_types))
|
|
||||||
++ ")"
|
|
||||||
++ datatypeDescriptor returntype
|
|
||||||
|
|
||||||
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 = []
|
|
||||||
}
|
|
||||||
in
|
|
||||||
foldr methodBuilder (foldr fieldBuilder nakedClassFile fields) methods
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
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 = [
|
|
||||||
FieldRefInfo (fromIntegral (thisClass input)) (fromIntegral (baseIndex + 1)),
|
|
||||||
NameAndTypeInfo (fromIntegral (baseIndex + 2)) (fromIntegral (baseIndex + 3)),
|
|
||||||
Utf8Info name,
|
|
||||||
Utf8Info (methodDescriptor (MethodDeclaration returntype name parameters (Block [])))
|
|
||||||
]
|
|
||||||
--code = assembleByteCode statement
|
|
||||||
method = MemberInfo {
|
|
||||||
memberAccessFlags = accessPublic,
|
|
||||||
memberNameIndex = (fromIntegral (baseIndex + 2)),
|
|
||||||
memberDescriptorIndex = (fromIntegral (baseIndex + 3)),
|
|
||||||
memberAttributes = [
|
|
||||||
CodeAttribute {
|
|
||||||
attributeMaxStack = 420,
|
|
||||||
attributeMaxLocals = 420,
|
|
||||||
attributeCode = [Opiadd]
|
|
||||||
}
|
|
||||||
]
|
|
||||||
}
|
|
||||||
in
|
|
||||||
input {
|
|
||||||
constantPool = (constantPool input) ++ constants,
|
|
||||||
methods = (fields input) ++ [method]
|
|
||||||
}
|
|
||||||
|
|
||||||
type Assembler a = a -> ([ConstantInfo], [Operation]) -> ([ConstantInfo], [Operation])
|
|
||||||
|
|
||||||
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
|
|
||||||
|
|
||||||
assembleMethod :: Assembler MethodDeclaration
|
|
||||||
assembleMethod (MethodDeclaration _ _ _ (Block statements)) (constants, ops) =
|
|
||||||
foldr assembleStatement (constants, ops) statements
|
|
||||||
|
|
||||||
assembleStatement :: Assembler Statement
|
|
||||||
assembleStatement (TypedStatement stype (Return expr)) (constants, ops) = case expr of
|
|
||||||
Nothing -> (constants, ops ++ [Opreturn])
|
|
||||||
Just expr -> let
|
|
||||||
(expr_constants, expr_ops) = assembleExpression expr (constants, ops)
|
|
||||||
in
|
|
||||||
(expr_constants, expr_ops ++ [returnOperation stype])
|
|
||||||
|
|
||||||
assembleExpression :: Assembler Expression
|
|
||||||
assembleExpression (TypedExpression _ (BinaryOperation op a b)) (constants, ops)
|
|
||||||
| elem op [Addition, Subtraction, Multiplication, Division, BitwiseAnd, BitwiseOr, BitwiseXor] = let
|
|
||||||
(aConstants, aOps) = assembleExpression a (constants, ops)
|
|
||||||
(bConstants, bOps) = assembleExpression b (aConstants, aOps)
|
|
||||||
in
|
|
||||||
(bConstants, bOps ++ [binaryOperation op])
|
|
||||||
assembleExpression (TypedExpression _ (CharacterLiteral literal)) (constants, ops) =
|
|
||||||
(constants, ops ++ [Opsipush (fromIntegral (ord literal))])
|
|
||||||
assembleExpression (TypedExpression _ (BooleanLiteral literal)) (constants, ops) =
|
|
||||||
(constants, ops ++ [Opsipush (if literal then 1 else 0)])
|
|
||||||
assembleExpression (TypedExpression _ (IntegerLiteral literal)) (constants, ops)
|
|
||||||
| literal <= 32767 && literal >= -32768 = (constants, ops ++ [Opsipush (fromIntegral literal)])
|
|
||||||
| otherwise = (constants ++ [IntegerInfo (fromIntegral literal)], ops ++ [Opldc_w (fromIntegral (1 + length constants))])
|
|
||||||
assembleExpression (TypedExpression _ NullLiteral) (constants, ops) =
|
|
||||||
(constants, ops ++ [Opaconst_null])
|
|
||||||
assembleExpression (TypedExpression etype (UnaryOperation Not expr)) (constants, ops) = let
|
|
||||||
(exprConstants, exprOps) = assembleExpression expr (constants, ops)
|
|
||||||
newConstant = fromIntegral (1 + length exprConstants)
|
|
||||||
in case etype of
|
|
||||||
"int" -> (exprConstants ++ [IntegerInfo 0x7FFFFFFF], exprOps ++ [Opldc_w newConstant, Opixor])
|
|
||||||
"char" -> (exprConstants, exprOps ++ [Opsipush 0xFFFF, Opixor])
|
|
||||||
"boolean" -> (exprConstants, exprOps ++ [Opsipush 0x01, Opixor])
|
|
||||||
assembleExpression (TypedExpression _ (UnaryOperation Minus expr)) (constants, ops) = let
|
|
||||||
(exprConstants, exprOps) = assembleExpression expr (constants, ops)
|
|
||||||
in
|
|
||||||
(exprConstants, exprOps ++ [Opineg])
|
|
228
src/ByteCode/Generation/Assembler/ExpressionAndStatement.hs
Normal file
228
src/ByteCode/Generation/Assembler/ExpressionAndStatement.hs
Normal 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
20
src/ByteCode/Generation/Assembler/Method.hs
Normal 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
44
src/ByteCode/Generation/Builder/Class.hs
Normal 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
46
src/ByteCode/Generation/Builder/Field.hs
Normal 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
80
src/ByteCode/Generation/Builder/Method.hs
Normal 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
73
src/ByteCode/Generation/Generator.hs
Normal 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
|
@ -49,7 +49,7 @@ exampleExpression :: Expression
|
|||||||
exampleExpression = BinaryOperation NameResolution (Reference "bob") (Reference "age")
|
exampleExpression = BinaryOperation NameResolution (Reference "bob") (Reference "age")
|
||||||
|
|
||||||
exampleAssignment :: Expression
|
exampleAssignment :: Expression
|
||||||
exampleAssignment = StatementExpressionExpression (Assignment "a" (IntegerLiteral 30))
|
exampleAssignment = StatementExpressionExpression (Assignment (Reference "a") (IntegerLiteral 30))
|
||||||
|
|
||||||
exampleMethodCall :: Statement
|
exampleMethodCall :: Statement
|
||||||
exampleMethodCall = StatementExpressionStatement (MethodCall (Reference "this") "setAge" [IntegerLiteral 30])
|
exampleMethodCall = StatementExpressionStatement (MethodCall (Reference "this") "setAge" [IntegerLiteral 30])
|
||||||
@ -58,7 +58,7 @@ exampleConstructorCall :: Statement
|
|||||||
exampleConstructorCall = LocalVariableDeclaration (VariableDeclaration "Person" "bob" (Just (StatementExpressionExpression (ConstructorCall "Person" [IntegerLiteral 30]))))
|
exampleConstructorCall = LocalVariableDeclaration (VariableDeclaration "Person" "bob" (Just (StatementExpressionExpression (ConstructorCall "Person" [IntegerLiteral 30]))))
|
||||||
|
|
||||||
exampleNameResolution :: Expression
|
exampleNameResolution :: Expression
|
||||||
exampleNameResolution = BinaryOperation NameResolution (Reference "b") (Reference "age")
|
exampleNameResolution = BinaryOperation NameResolution (Reference "bob2") (Reference "age")
|
||||||
|
|
||||||
exampleBlockResolution :: Statement
|
exampleBlockResolution :: Statement
|
||||||
exampleBlockResolution = Block [
|
exampleBlockResolution = Block [
|
||||||
@ -80,7 +80,7 @@ exampleMethodCallAndAssignment = Block [
|
|||||||
LocalVariableDeclaration (VariableDeclaration "int" "age" (Just (StatementExpressionExpression (MethodCall (Reference "bob") "getAge" [])))),
|
LocalVariableDeclaration (VariableDeclaration "int" "age" (Just (StatementExpressionExpression (MethodCall (Reference "bob") "getAge" [])))),
|
||||||
StatementExpressionStatement (MethodCall (Reference "bob") "setAge" [IntegerLiteral 30]),
|
StatementExpressionStatement (MethodCall (Reference "bob") "setAge" [IntegerLiteral 30]),
|
||||||
LocalVariableDeclaration (VariableDeclaration "int" "a" Nothing),
|
LocalVariableDeclaration (VariableDeclaration "int" "a" Nothing),
|
||||||
StatementExpressionStatement (Assignment "a" (Reference "age"))
|
StatementExpressionStatement (Assignment (Reference "a") (Reference "age"))
|
||||||
]
|
]
|
||||||
|
|
||||||
|
|
||||||
@ -89,9 +89,30 @@ exampleMethodCallAndAssignmentFail = Block [
|
|||||||
LocalVariableDeclaration (VariableDeclaration "Person" "bob" (Just (StatementExpressionExpression (ConstructorCall "Person" [IntegerLiteral 30])))),
|
LocalVariableDeclaration (VariableDeclaration "Person" "bob" (Just (StatementExpressionExpression (ConstructorCall "Person" [IntegerLiteral 30])))),
|
||||||
LocalVariableDeclaration (VariableDeclaration "int" "age" (Just (StatementExpressionExpression (MethodCall (Reference "bob") "getAge" [])))),
|
LocalVariableDeclaration (VariableDeclaration "int" "age" (Just (StatementExpressionExpression (MethodCall (Reference "bob") "getAge" [])))),
|
||||||
StatementExpressionStatement (MethodCall (Reference "bob") "setAge" [IntegerLiteral 30]),
|
StatementExpressionStatement (MethodCall (Reference "bob") "setAge" [IntegerLiteral 30]),
|
||||||
StatementExpressionStatement (Assignment "a" (Reference "age"))
|
StatementExpressionStatement (Assignment (Reference "a") (Reference "age"))
|
||||||
]
|
]
|
||||||
|
|
||||||
|
exampleNameResolutionAssignment :: Statement
|
||||||
|
exampleNameResolutionAssignment = Block [
|
||||||
|
LocalVariableDeclaration (VariableDeclaration "Person" "bob" (Just (StatementExpressionExpression (ConstructorCall "Person" [IntegerLiteral 30])))),
|
||||||
|
StatementExpressionStatement (Assignment (BinaryOperation NameResolution (Reference "bob") (Reference "age")) (IntegerLiteral 30))
|
||||||
|
]
|
||||||
|
|
||||||
|
exampleCharIntOperation :: Expression
|
||||||
|
exampleCharIntOperation = BinaryOperation Addition (CharacterLiteral 'a') (IntegerLiteral 1)
|
||||||
|
|
||||||
|
exampleNullDeclaration :: Statement
|
||||||
|
exampleNullDeclaration = LocalVariableDeclaration (VariableDeclaration "Person" "bob" (Just NullLiteral))
|
||||||
|
|
||||||
|
exampleNullDeclarationFail :: Statement
|
||||||
|
exampleNullDeclarationFail = LocalVariableDeclaration (VariableDeclaration "int" "a" (Just NullLiteral))
|
||||||
|
|
||||||
|
exampleNullAssignment :: Statement
|
||||||
|
exampleNullAssignment = StatementExpressionStatement (Assignment (Reference "a") NullLiteral)
|
||||||
|
|
||||||
|
exampleIncrement :: Statement
|
||||||
|
exampleIncrement = StatementExpressionStatement (PostIncrement (Reference "a"))
|
||||||
|
|
||||||
testClasses :: [Class]
|
testClasses :: [Class]
|
||||||
testClasses = [
|
testClasses = [
|
||||||
Class "Person" [
|
Class "Person" [
|
||||||
@ -113,10 +134,12 @@ testClasses = [
|
|||||||
(Block [
|
(Block [
|
||||||
LocalVariableDeclaration (VariableDeclaration "Person" "bob" (Just (StatementExpressionExpression (ConstructorCall "Person" [IntegerLiteral 25])))),
|
LocalVariableDeclaration (VariableDeclaration "Person" "bob" (Just (StatementExpressionExpression (ConstructorCall "Person" [IntegerLiteral 25])))),
|
||||||
StatementExpressionStatement (MethodCall (Reference "bob") "setAge" [IntegerLiteral 30]),
|
StatementExpressionStatement (MethodCall (Reference "bob") "setAge" [IntegerLiteral 30]),
|
||||||
LocalVariableDeclaration (VariableDeclaration "int" "bobAge" (Just (StatementExpressionExpression (MethodCall (Reference "bob") "getAge" [])))),
|
LocalVariableDeclaration (VariableDeclaration "int" "bobAge" (Just (StatementExpressionExpression (MethodCall (Reference "bob2") "getAge" [])))),
|
||||||
Return (Just (Reference "bobAge"))
|
Return (Just (Reference "bobAge"))
|
||||||
])
|
])
|
||||||
] []
|
] [
|
||||||
|
VariableDeclaration "Person" "bob2" Nothing
|
||||||
|
]
|
||||||
]
|
]
|
||||||
|
|
||||||
runTypeCheck :: IO ()
|
runTypeCheck :: IO ()
|
||||||
@ -151,7 +174,7 @@ runTypeCheck = do
|
|||||||
|
|
||||||
catch (do
|
catch (do
|
||||||
print "====================================================================================="
|
print "====================================================================================="
|
||||||
evaluatedNameResolution <- evaluate (typeCheckExpression exampleNameResolution [("b", "Person")] sampleClasses)
|
evaluatedNameResolution <- evaluate (typeCheckExpression exampleNameResolution [("this", "Main")] testClasses)
|
||||||
printSuccess "Type checking of name resolution completed successfully"
|
printSuccess "Type checking of name resolution completed successfully"
|
||||||
printResult "Result Name Resolution:" evaluatedNameResolution
|
printResult "Result Name Resolution:" evaluatedNameResolution
|
||||||
) handleError
|
) handleError
|
||||||
@ -189,7 +212,7 @@ runTypeCheck = do
|
|||||||
let mainClass = fromJust $ find (\(Class className _ _) -> className == "Main") testClasses
|
let mainClass = fromJust $ find (\(Class className _ _) -> className == "Main") testClasses
|
||||||
case mainClass of
|
case mainClass of
|
||||||
Class _ [mainMethod] _ -> do
|
Class _ [mainMethod] _ -> do
|
||||||
let result = typeCheckMethodDeclaration mainMethod [] testClasses
|
let result = typeCheckMethodDeclaration mainMethod [("this", "Main")] testClasses
|
||||||
printSuccess "Full program type checking completed successfully."
|
printSuccess "Full program type checking completed successfully."
|
||||||
printResult "Main method result:" result
|
printResult "Main method result:" result
|
||||||
) handleError
|
) handleError
|
||||||
@ -201,3 +224,44 @@ runTypeCheck = do
|
|||||||
printResult "Typed Program:" typedProgram
|
printResult "Typed Program:" typedProgram
|
||||||
) handleError
|
) handleError
|
||||||
|
|
||||||
|
catch (do
|
||||||
|
print "====================================================================================="
|
||||||
|
typedAssignment <- evaluate (typeCheckStatement exampleNameResolutionAssignment [] sampleClasses)
|
||||||
|
printSuccess "Type checking of name resolution assignment completed successfully"
|
||||||
|
printResult "Result Name Resolution Assignment:" typedAssignment
|
||||||
|
) handleError
|
||||||
|
|
||||||
|
catch (do
|
||||||
|
print "====================================================================================="
|
||||||
|
evaluatedCharIntOperation <- evaluate (typeCheckExpression exampleCharIntOperation [] sampleClasses)
|
||||||
|
printSuccess "Type checking of char int operation completed successfully"
|
||||||
|
printResult "Result Char Int Operation:" evaluatedCharIntOperation
|
||||||
|
) handleError
|
||||||
|
|
||||||
|
catch (do
|
||||||
|
print "====================================================================================="
|
||||||
|
evaluatedNullDeclaration <- evaluate (typeCheckStatement exampleNullDeclaration [] sampleClasses)
|
||||||
|
printSuccess "Type checking of null declaration completed successfully"
|
||||||
|
printResult "Result Null Declaration:" evaluatedNullDeclaration
|
||||||
|
) handleError
|
||||||
|
|
||||||
|
catch (do
|
||||||
|
print "====================================================================================="
|
||||||
|
evaluatedNullDeclarationFail <- evaluate (typeCheckStatement exampleNullDeclarationFail [] sampleClasses)
|
||||||
|
printSuccess "Type checking of null declaration failed"
|
||||||
|
printResult "Result Null Declaration:" evaluatedNullDeclarationFail
|
||||||
|
) handleError
|
||||||
|
|
||||||
|
catch (do
|
||||||
|
print "====================================================================================="
|
||||||
|
evaluatedNullAssignment <- evaluate (typeCheckStatement exampleNullAssignment [("a", "Person")] sampleClasses)
|
||||||
|
printSuccess "Type checking of null assignment completed successfully"
|
||||||
|
printResult "Result Null Assignment:" evaluatedNullAssignment
|
||||||
|
) handleError
|
||||||
|
|
||||||
|
catch (do
|
||||||
|
print "====================================================================================="
|
||||||
|
evaluatedIncrement <- evaluate (typeCheckStatement exampleIncrement [("a", "int")] sampleClasses)
|
||||||
|
printSuccess "Type checking of increment completed successfully"
|
||||||
|
printResult "Result Increment:" evaluatedIncrement
|
||||||
|
) handleError
|
||||||
|
14
src/Main.hs
14
src/Main.hs
@ -2,7 +2,19 @@ module Main where
|
|||||||
|
|
||||||
import Example
|
import Example
|
||||||
import Typecheck
|
import Typecheck
|
||||||
|
import Parser.Lexer (alexScanTokens)
|
||||||
|
import Parser.JavaParser
|
||||||
|
import ByteCode.Generation.Generator
|
||||||
|
import ByteCode.Generation.Builder.Class
|
||||||
|
import ByteCode.ClassFile
|
||||||
|
import Data.ByteString (pack, writeFile)
|
||||||
|
|
||||||
main = do
|
main = do
|
||||||
Example.runTypeCheck
|
file <- readFile "Testklasse.java"
|
||||||
|
|
||||||
|
let untypedAST = parse $ alexScanTokens file
|
||||||
|
let typedAST = head (typeCheckCompilationUnit untypedAST)
|
||||||
|
let abstractClassFile = classBuilder typedAST emptyClassFile
|
||||||
|
let assembledClassFile = pack (serialize abstractClassFile)
|
||||||
|
|
||||||
|
Data.ByteString.writeFile "Testklasse.class" assembledClassFile
|
||||||
|
@ -1,12 +1,15 @@
|
|||||||
{
|
{
|
||||||
module Parser.JavaParser (parse) where
|
module Parser.JavaParser (parse, parseStatement, parseExpression) where
|
||||||
import Ast
|
import Ast
|
||||||
import Parser.Lexer
|
import Parser.Lexer
|
||||||
}
|
}
|
||||||
|
|
||||||
%name parse
|
%name parse
|
||||||
|
%name parseStatement statement
|
||||||
|
%name parseExpression expression
|
||||||
%tokentype { Token }
|
%tokentype { Token }
|
||||||
%error { parseError }
|
%error { parseError }
|
||||||
|
%errorhandlertype explist
|
||||||
|
|
||||||
%token
|
%token
|
||||||
BOOLEAN { BOOLEAN }
|
BOOLEAN { BOOLEAN }
|
||||||
@ -41,7 +44,6 @@ import Parser.Lexer
|
|||||||
JNULL { NULLLITERAL }
|
JNULL { NULLLITERAL }
|
||||||
BOOLLITERAL { BOOLLITERAL $$ }
|
BOOLLITERAL { BOOLLITERAL $$ }
|
||||||
DIV { DIV }
|
DIV { DIV }
|
||||||
LOGICALOR { OR }
|
|
||||||
NOTEQUAL { NOTEQUAL }
|
NOTEQUAL { NOTEQUAL }
|
||||||
INSTANCEOF { INSTANCEOF }
|
INSTANCEOF { INSTANCEOF }
|
||||||
ANDEQUAL { ANDEQUAL }
|
ANDEQUAL { ANDEQUAL }
|
||||||
@ -80,17 +82,17 @@ compilationunit : typedeclarations { $1 }
|
|||||||
typedeclarations : typedeclaration { [$1] }
|
typedeclarations : typedeclaration { [$1] }
|
||||||
| typedeclarations typedeclaration { $1 ++ [$2] }
|
| typedeclarations typedeclaration { $1 ++ [$2] }
|
||||||
|
|
||||||
name : qualifiedname { }
|
name : simplename { Reference $1 }
|
||||||
| simplename { }
|
| qualifiedname { $1 }
|
||||||
|
|
||||||
typedeclaration : classdeclaration { $1 }
|
typedeclaration : classdeclaration { $1 }
|
||||||
|
|
||||||
qualifiedname : name DOT IDENTIFIER { }
|
qualifiedname : name DOT IDENTIFIER { BinaryOperation NameResolution $1 (Reference $3) }
|
||||||
|
|
||||||
simplename : IDENTIFIER { }
|
simplename : IDENTIFIER { $1 }
|
||||||
|
|
||||||
classdeclaration : CLASS IDENTIFIER classbody { case $3 of (methods, fields) -> Class $2 methods fields }
|
classdeclaration : CLASS IDENTIFIER classbody { case $3 of (methods, fields) -> Class $2 methods fields }
|
||||||
-- | modifiers CLASS IDENTIFIER classbody { case $4 of (methods, fields) -> Class $3 methods fields }
|
| modifiers CLASS IDENTIFIER classbody { case $4 of (methods, fields) -> Class $3 methods fields }
|
||||||
|
|
||||||
classbody : LBRACKET RBRACKET { ([], []) }
|
classbody : LBRACKET RBRACKET { ([], []) }
|
||||||
| LBRACKET classbodydeclarations RBRACKET { $2 }
|
| LBRACKET classbodydeclarations RBRACKET { $2 }
|
||||||
@ -103,11 +105,11 @@ classbodydeclarations : classbodydeclaration {
|
|||||||
MethodDecl method -> ([method], [])
|
MethodDecl method -> ([method], [])
|
||||||
FieldDecls fields -> ([], fields)
|
FieldDecls fields -> ([], fields)
|
||||||
}
|
}
|
||||||
-- | classbodydeclarations classbodydeclaration {
|
| classbodydeclarations classbodydeclaration {
|
||||||
-- case ($1, $2) of
|
case ($1, $2) of
|
||||||
-- ((methods, fields), MethodDecl method) -> ((methods ++ [method]), fields)
|
((methods, fields), MethodDecl method) -> ((methods ++ [method]), fields)
|
||||||
-- ((methods, fields), FieldDecl field) -> (methods, (fields ++ [field]))
|
((methods, fields), FieldDecls newFields) -> (methods, (fields ++ newFields))
|
||||||
-- }
|
}
|
||||||
|
|
||||||
modifier : PUBLIC { }
|
modifier : PUBLIC { }
|
||||||
| PROTECTED { }
|
| PROTECTED { }
|
||||||
@ -115,54 +117,54 @@ modifier : PUBLIC { }
|
|||||||
| STATIC { }
|
| STATIC { }
|
||||||
| ABSTRACT { }
|
| ABSTRACT { }
|
||||||
|
|
||||||
classtype : classorinterfacetype{ }
|
classtype : classorinterfacetype { $1 }
|
||||||
|
|
||||||
classbodydeclaration : classmemberdeclaration { $1 }
|
classbodydeclaration : classmemberdeclaration { $1 }
|
||||||
-- | constructordeclaration { FieldDecl $ VariableDeclaration "int" "a" Nothing } -- TODO
|
| constructordeclaration { $1 }
|
||||||
|
|
||||||
classorinterfacetype : name{ }
|
classorinterfacetype : simplename { $1 }
|
||||||
|
|
||||||
classmemberdeclaration : fielddeclaration { $1 }
|
classmemberdeclaration : fielddeclaration { $1 }
|
||||||
-- | methoddeclaration { }
|
| methoddeclaration { $1 }
|
||||||
|
|
||||||
constructordeclaration : constructordeclarator constructorbody { }
|
constructordeclaration : constructordeclarator constructorbody { MethodDecl $ MethodDeclaration "void" "<init>" $1 $2 }
|
||||||
| modifiers constructordeclarator constructorbody { }
|
| modifiers constructordeclarator constructorbody { MethodDecl $ MethodDeclaration "void" "<init>" $2 $3 }
|
||||||
|
|
||||||
fielddeclaration : type variabledeclarators SEMICOLON { FieldDecls $ map (convertDeclarator $1) $2 }
|
fielddeclaration : type variabledeclarators SEMICOLON { FieldDecls $ map (convertDeclarator $1) $2 }
|
||||||
-- | modifiers type variabledeclarators SEMICOLON {}
|
| modifiers type variabledeclarators SEMICOLON { FieldDecls $ map (convertDeclarator $2) $3 }
|
||||||
|
|
||||||
methoddeclaration : methodheader methodbody { }
|
methoddeclaration : methodheader methodbody { case $1 of (returnType, (name, parameters)) -> MethodDecl (MethodDeclaration returnType name parameters $2) }
|
||||||
|
|
||||||
block : LBRACKET RBRACKET { }
|
block : LBRACKET RBRACKET { Block [] }
|
||||||
| LBRACKET blockstatements RBRACKET { }
|
| LBRACKET blockstatements RBRACKET { Block $2 }
|
||||||
|
|
||||||
constructordeclarator : simplename LBRACE RBRACE { }
|
constructordeclarator : simplename LBRACE RBRACE { [] }
|
||||||
| simplename LBRACE formalparameterlist RBRACE { }
|
| simplename LBRACE formalparameterlist RBRACE { $3 }
|
||||||
|
|
||||||
constructorbody : LBRACKET RBRACKET { }
|
constructorbody : LBRACKET RBRACKET { Block [] }
|
||||||
| LBRACKET explicitconstructorinvocation RBRACKET { }
|
-- | LBRACKET explicitconstructorinvocation RBRACKET { }
|
||||||
| LBRACKET blockstatements RBRACKET { }
|
| LBRACKET blockstatements RBRACKET { Block $2 }
|
||||||
| LBRACKET explicitconstructorinvocation blockstatements RBRACKET { }
|
-- | LBRACKET explicitconstructorinvocation blockstatements RBRACKET { }
|
||||||
|
|
||||||
methodheader : type methoddeclarator { }
|
methodheader : type methoddeclarator { ($1, $2) }
|
||||||
| modifiers type methoddeclarator { }
|
| modifiers type methoddeclarator { ($2, $3) }
|
||||||
| VOID methoddeclarator { }
|
| VOID methoddeclarator { ("void", $2) }
|
||||||
| modifiers VOID methoddeclarator { }
|
| modifiers VOID methoddeclarator { ("void", $3)}
|
||||||
|
|
||||||
type : primitivetype { $1 }
|
type : primitivetype { $1 }
|
||||||
-- | referencetype { }
|
| referencetype { $1 }
|
||||||
|
|
||||||
variabledeclarators : variabledeclarator { [$1] }
|
variabledeclarators : variabledeclarator { [$1] }
|
||||||
-- | variabledeclarators COMMA variabledeclarator { $1 ++ [$3] }
|
| variabledeclarators COMMA variabledeclarator { $1 ++ [$3] }
|
||||||
|
|
||||||
methodbody : block { }
|
methodbody : block { $1 }
|
||||||
| SEMICOLON { }
|
| SEMICOLON { Block [] }
|
||||||
|
|
||||||
blockstatements : blockstatement { }
|
blockstatements : blockstatement { $1 }
|
||||||
| blockstatements blockstatement { }
|
| blockstatements blockstatement { $1 ++ $2}
|
||||||
|
|
||||||
formalparameterlist : formalparameter { }
|
formalparameterlist : formalparameter { [$1] }
|
||||||
| formalparameterlist COMMA formalparameter{ }
|
| formalparameterlist COMMA formalparameter { $1 ++ [$3] }
|
||||||
|
|
||||||
explicitconstructorinvocation : THIS LBRACE RBRACE SEMICOLON { }
|
explicitconstructorinvocation : THIS LBRACE RBRACE SEMICOLON { }
|
||||||
| THIS LBRACE argumentlist RBRACE SEMICOLON { }
|
| THIS LBRACE argumentlist RBRACE SEMICOLON { }
|
||||||
@ -170,192 +172,196 @@ explicitconstructorinvocation : THIS LBRACE RBRACE SEMICOLON { }
|
|||||||
classtypelist : classtype { }
|
classtypelist : classtype { }
|
||||||
| classtypelist COMMA classtype { }
|
| classtypelist COMMA classtype { }
|
||||||
|
|
||||||
methoddeclarator : IDENTIFIER LBRACE RBRACE { }
|
methoddeclarator : IDENTIFIER LBRACE RBRACE { ($1, []) }
|
||||||
| IDENTIFIER LBRACE formalparameterlist RBRACE { }
|
| IDENTIFIER LBRACE formalparameterlist RBRACE { ($1, $3) }
|
||||||
|
|
||||||
primitivetype : BOOLEAN { "boolean" }
|
primitivetype : BOOLEAN { "boolean" }
|
||||||
| numerictype { $1 }
|
| numerictype { $1 }
|
||||||
|
|
||||||
referencetype : classorinterfacetype { }
|
referencetype : classorinterfacetype { $1 }
|
||||||
|
|
||||||
|
|
||||||
variabledeclarator : variabledeclaratorid { Declarator $1 Nothing }
|
variabledeclarator : variabledeclaratorid { Declarator $1 Nothing }
|
||||||
-- | variabledeclaratorid ASSIGN variableinitializer { Declarator $1 Nothing } -- TODO
|
| variabledeclaratorid ASSIGN variableinitializer { Declarator $1 (Just $3) }
|
||||||
|
|
||||||
blockstatement : localvariabledeclarationstatement { }
|
blockstatement : localvariabledeclarationstatement { $1 } -- expected type statement
|
||||||
| statement { }
|
| statement { $1 }
|
||||||
|
|
||||||
formalparameter : type variabledeclaratorid { }
|
formalparameter : type variabledeclaratorid { ParameterDeclaration $1 $2 }
|
||||||
|
|
||||||
argumentlist : expression { }
|
argumentlist : expression { [$1] }
|
||||||
| argumentlist COMMA expression { }
|
| argumentlist COMMA expression { $1 ++ [$3] }
|
||||||
|
|
||||||
numerictype : integraltype { $1 }
|
numerictype : integraltype { $1 }
|
||||||
|
|
||||||
variabledeclaratorid : IDENTIFIER { $1 }
|
variabledeclaratorid : IDENTIFIER { $1 }
|
||||||
|
|
||||||
variableinitializer : expression { }
|
variableinitializer : expression { $1 }
|
||||||
|
|
||||||
localvariabledeclarationstatement : localvariabledeclaration SEMICOLON { }
|
localvariabledeclarationstatement : localvariabledeclaration SEMICOLON { $1 }
|
||||||
|
|
||||||
statement : statementwithouttrailingsubstatement{ }
|
statement : statementwithouttrailingsubstatement{ $1 } -- statement returns a list of statements
|
||||||
| ifthenstatement { }
|
| ifthenstatement { [$1] }
|
||||||
| ifthenelsestatement { }
|
| ifthenelsestatement { [$1] }
|
||||||
| whilestatement { }
|
| whilestatement { [$1] }
|
||||||
|
|
||||||
|
|
||||||
expression : assignmentexpression { }
|
expression : assignmentexpression { $1 }
|
||||||
|
|
||||||
integraltype : INT { "int" }
|
integraltype : INT { "int" }
|
||||||
| CHAR { "char" }
|
| CHAR { "char" }
|
||||||
|
|
||||||
localvariabledeclaration : type variabledeclarators { }
|
localvariabledeclaration : type variabledeclarators { map LocalVariableDeclaration $ map (convertDeclarator $1) $2 }
|
||||||
|
|
||||||
statementwithouttrailingsubstatement : block { }
|
statementwithouttrailingsubstatement : block { [$1] }
|
||||||
| emptystatement { }
|
| emptystatement { [] }
|
||||||
| expressionstatement { }
|
| expressionstatement { [$1] }
|
||||||
| returnstatement { }
|
| returnstatement { [$1] }
|
||||||
|
|
||||||
ifthenstatement : IF LBRACE expression RBRACE statement { }
|
ifthenstatement : IF LBRACE expression RBRACE statement { If $3 (Block $5) Nothing }
|
||||||
|
|
||||||
ifthenelsestatement : IF LBRACE expression RBRACE statementnoshortif ELSE statement { }
|
ifthenelsestatement : IF LBRACE expression RBRACE statementnoshortif ELSE statement { If $3 (Block $5) (Just (Block $7)) }
|
||||||
|
|
||||||
whilestatement : WHILE LBRACE expression RBRACE statement { }
|
whilestatement : WHILE LBRACE expression RBRACE statement { While $3 (Block $5) }
|
||||||
|
|
||||||
assignmentexpression : conditionalexpression { }
|
assignmentexpression : conditionalexpression { $1 }
|
||||||
| assignment{ }
|
| assignment { StatementExpressionExpression $1 }
|
||||||
|
|
||||||
emptystatement : SEMICOLON { }
|
emptystatement : SEMICOLON { Block [] }
|
||||||
|
|
||||||
expressionstatement : statementexpression SEMICOLON { }
|
expressionstatement : statementexpression SEMICOLON { StatementExpressionStatement $1 }
|
||||||
|
|
||||||
returnstatement : RETURN SEMICOLON { }
|
returnstatement : RETURN SEMICOLON { Return Nothing }
|
||||||
| RETURN expression SEMICOLON { }
|
| RETURN expression SEMICOLON { Return $ Just $2 }
|
||||||
|
|
||||||
statementnoshortif : statementwithouttrailingsubstatement { }
|
statementnoshortif : statementwithouttrailingsubstatement { $1 }
|
||||||
| ifthenelsestatementnoshortif { }
|
-- | ifthenelsestatementnoshortif { }
|
||||||
| whilestatementnoshortif { }
|
-- | whilestatementnoshortif { }
|
||||||
|
|
||||||
conditionalexpression : conditionalorexpression { }
|
conditionalexpression : conditionalorexpression { $1 }
|
||||||
| conditionalorexpression QUESMARK expression COLON conditionalexpression { }
|
-- | conditionalorexpression QUESMARK expression COLON conditionalexpression { }
|
||||||
|
|
||||||
assignment :lefthandside assignmentoperator assignmentexpression { }
|
assignment : lefthandside assignmentoperator assignmentexpression {
|
||||||
|
case $2 of
|
||||||
|
Nothing -> Assignment $1 $3
|
||||||
|
Just operator -> Assignment $1 (BinaryOperation operator $1 $3)
|
||||||
|
}
|
||||||
|
|
||||||
|
|
||||||
statementexpression : assignment { }
|
statementexpression : assignment { $1 }
|
||||||
| preincrementexpression { }
|
| preincrementexpression { $1 }
|
||||||
| predecrementexpression { }
|
| predecrementexpression { $1 }
|
||||||
| postincrementexpression { }
|
| postincrementexpression { $1 }
|
||||||
| postdecrementexpression { }
|
| postdecrementexpression { $1 }
|
||||||
| methodinvocation { }
|
| methodinvocation { $1 }
|
||||||
| classinstancecreationexpression { }
|
| classinstancecreationexpression { $1 }
|
||||||
|
|
||||||
ifthenelsestatementnoshortif :IF LBRACE expression RBRACE statementnoshortif
|
ifthenelsestatementnoshortif :IF LBRACE expression RBRACE statementnoshortif
|
||||||
ELSE statementnoshortif { }
|
ELSE statementnoshortif { }
|
||||||
|
|
||||||
whilestatementnoshortif : WHILE LBRACE expression RBRACE statementnoshortif { }
|
whilestatementnoshortif : WHILE LBRACE expression RBRACE statementnoshortif { }
|
||||||
|
|
||||||
conditionalorexpression : conditionalandexpression { }
|
conditionalorexpression : conditionalandexpression { $1 }
|
||||||
| conditionalorexpression LOGICALOR conditionalandexpression{ }
|
-- | conditionalorexpression LOGICALOR conditionalandexpression{ }
|
||||||
|
|
||||||
lefthandside : name { }
|
lefthandside : name { $1 }
|
||||||
|
|
||||||
assignmentoperator : ASSIGN{ }
|
assignmentoperator : ASSIGN { Nothing }
|
||||||
| TIMESEQUAL { }
|
| TIMESEQUAL { Just Multiplication }
|
||||||
| DIVIDEEQUAL { }
|
| DIVIDEEQUAL { Just Division }
|
||||||
| MODULOEQUAL { }
|
| MODULOEQUAL { Just Modulo }
|
||||||
| PLUSEQUAL { }
|
| PLUSEQUAL { Just Addition }
|
||||||
| MINUSEQUAL { }
|
| MINUSEQUAL { Just Subtraction }
|
||||||
| SHIFTLEFTEQUAL { }
|
-- | SHIFTLEFTEQUAL { }
|
||||||
| SIGNEDSHIFTRIGHTEQUAL { }
|
-- | SIGNEDSHIFTRIGHTEQUAL { }
|
||||||
| UNSIGNEDSHIFTRIGHTEQUAL { }
|
-- | UNSIGNEDSHIFTRIGHTEQUAL { }
|
||||||
| ANDEQUAL { }
|
| ANDEQUAL { Just BitwiseAnd }
|
||||||
| XOREQUAL { }
|
| XOREQUAL { Just BitwiseXor }
|
||||||
| OREQUAL{ }
|
| OREQUAL{ Just BitwiseOr }
|
||||||
|
|
||||||
preincrementexpression : INCREMENT unaryexpression { }
|
preincrementexpression : INCREMENT unaryexpression { PreIncrement $2 }
|
||||||
|
|
||||||
predecrementexpression : DECREMENT unaryexpression { }
|
predecrementexpression : DECREMENT unaryexpression { PreDecrement $2 }
|
||||||
|
|
||||||
postincrementexpression : postfixexpression INCREMENT { }
|
postincrementexpression : postfixexpression INCREMENT { PostIncrement $1 }
|
||||||
|
|
||||||
postdecrementexpression : postfixexpression DECREMENT { }
|
postdecrementexpression : postfixexpression DECREMENT { PostDecrement $1 }
|
||||||
|
|
||||||
methodinvocation : name LBRACE RBRACE { }
|
methodinvocation : simplename LBRACE RBRACE { MethodCall (Reference "this") $1 [] }
|
||||||
| name LBRACE argumentlist RBRACE { }
|
| simplename LBRACE argumentlist RBRACE { MethodCall (Reference "this") $1 $3 }
|
||||||
| primary DOT IDENTIFIER LBRACE RBRACE { }
|
| primary DOT IDENTIFIER LBRACE RBRACE { MethodCall $1 $3 [] }
|
||||||
| primary DOT IDENTIFIER LBRACE argumentlist RBRACE { }
|
| primary DOT IDENTIFIER LBRACE argumentlist RBRACE { MethodCall $1 $3 $5 }
|
||||||
|
|
||||||
classinstancecreationexpression : NEW classtype LBRACE RBRACE { }
|
classinstancecreationexpression : NEW classtype LBRACE RBRACE { ConstructorCall $2 [] }
|
||||||
| NEW classtype LBRACE argumentlist RBRACE { }
|
| NEW classtype LBRACE argumentlist RBRACE { ConstructorCall $2 $4 }
|
||||||
|
|
||||||
conditionalandexpression : inclusiveorexpression { }
|
conditionalandexpression : inclusiveorexpression { $1 }
|
||||||
|
|
||||||
fieldaccess : primary DOT IDENTIFIER { }
|
fieldaccess : primary DOT IDENTIFIER { BinaryOperation NameResolution $1 (Reference $3) }
|
||||||
|
|
||||||
unaryexpression : preincrementexpression { }
|
unaryexpression : unaryexpressionnotplusminus { $1 }
|
||||||
| predecrementexpression { }
|
| predecrementexpression { StatementExpressionExpression $1 }
|
||||||
| PLUS unaryexpression { }
|
| PLUS unaryexpression { $2 }
|
||||||
| MINUS unaryexpression { }
|
| MINUS unaryexpression { UnaryOperation Minus $2 }
|
||||||
| unaryexpressionnotplusminus { }
|
| preincrementexpression { StatementExpressionExpression $1 }
|
||||||
|
|
||||||
postfixexpression : primary { }
|
postfixexpression : primary { $1 }
|
||||||
| name { }
|
| name { $1 }
|
||||||
| postincrementexpression { }
|
| postincrementexpression { StatementExpressionExpression $1 }
|
||||||
| postdecrementexpression{ }
|
| postdecrementexpression { StatementExpressionExpression $1 }
|
||||||
|
|
||||||
primary : primarynonewarray { }
|
primary : primarynonewarray { $1 }
|
||||||
|
|
||||||
inclusiveorexpression : exclusiveorexpression { }
|
inclusiveorexpression : exclusiveorexpression { $1 }
|
||||||
| inclusiveorexpression OR exclusiveorexpression { }
|
| inclusiveorexpression OR exclusiveorexpression { BinaryOperation Or $1 $3 }
|
||||||
|
|
||||||
primarynonewarray : literal { }
|
primarynonewarray : literal { $1 }
|
||||||
| THIS { }
|
| THIS { Reference "this" }
|
||||||
| LBRACE expression RBRACE { }
|
| LBRACE expression RBRACE { $2 }
|
||||||
| classinstancecreationexpression { }
|
| classinstancecreationexpression { StatementExpressionExpression $1 }
|
||||||
| fieldaccess { }
|
| fieldaccess { $1 }
|
||||||
| methodinvocation { }
|
| methodinvocation { StatementExpressionExpression $1 }
|
||||||
|
|
||||||
unaryexpressionnotplusminus : postfixexpression { }
|
unaryexpressionnotplusminus : postfixexpression { $1 }
|
||||||
| TILDE unaryexpression { }
|
-- | TILDE unaryexpression { }
|
||||||
| EXCLMARK unaryexpression { }
|
| EXCLMARK unaryexpression { UnaryOperation Not $2 }
|
||||||
| castexpression{ }
|
-- | castexpression{ }
|
||||||
|
|
||||||
exclusiveorexpression : andexpression { }
|
exclusiveorexpression : andexpression { $1 }
|
||||||
| exclusiveorexpression XOR andexpression { }
|
| exclusiveorexpression XOR andexpression { BinaryOperation BitwiseXor $1 $3 }
|
||||||
|
|
||||||
literal : INTLITERAL { }
|
literal : INTLITERAL { IntegerLiteral $1 }
|
||||||
| BOOLLITERAL { }
|
| BOOLLITERAL { BooleanLiteral $1 }
|
||||||
| CHARLITERAL { }
|
| CHARLITERAL { CharacterLiteral $1 }
|
||||||
| JNULL { }
|
| JNULL { NullLiteral }
|
||||||
|
|
||||||
castexpression : LBRACE primitivetype RBRACE unaryexpression { }
|
castexpression : LBRACE primitivetype RBRACE unaryexpression { }
|
||||||
| LBRACE expression RBRACE unaryexpressionnotplusminus{ }
|
| LBRACE expression RBRACE unaryexpressionnotplusminus{ }
|
||||||
|
|
||||||
andexpression : equalityexpression { }
|
andexpression : equalityexpression { $1 }
|
||||||
| andexpression AND equalityexpression { }
|
| andexpression AND equalityexpression { BinaryOperation And $1 $3 }
|
||||||
|
|
||||||
equalityexpression : relationalexpression { }
|
equalityexpression : relationalexpression { $1 }
|
||||||
| equalityexpression EQUAL relationalexpression { }
|
| equalityexpression EQUAL relationalexpression { BinaryOperation CompareEqual $1 $3 }
|
||||||
| equalityexpression NOTEQUAL relationalexpression { }
|
| equalityexpression NOTEQUAL relationalexpression { BinaryOperation CompareNotEqual $1 $3 }
|
||||||
|
|
||||||
relationalexpression : shiftexpression { }
|
relationalexpression : shiftexpression { $1 }
|
||||||
| relationalexpression LESS shiftexpression { }
|
| relationalexpression LESS shiftexpression { BinaryOperation CompareLessThan $1 $3 }
|
||||||
| relationalexpression GREATER shiftexpression { }
|
| relationalexpression GREATER shiftexpression { BinaryOperation CompareGreaterThan $1 $3 }
|
||||||
| relationalexpression LESSEQUAL shiftexpression { }
|
| relationalexpression LESSEQUAL shiftexpression { BinaryOperation CompareLessOrEqual $1 $3 }
|
||||||
| relationalexpression GREATEREQUAL shiftexpression { }
|
| relationalexpression GREATEREQUAL shiftexpression { BinaryOperation CompareGreaterOrEqual $1 $3 }
|
||||||
| relationalexpression INSTANCEOF referencetype { }
|
-- | relationalexpression INSTANCEOF referencetype { }
|
||||||
|
|
||||||
shiftexpression : additiveexpression { }
|
shiftexpression : additiveexpression { $1 }
|
||||||
|
|
||||||
additiveexpression : multiplicativeexpression { }
|
additiveexpression : multiplicativeexpression { $1 }
|
||||||
| additiveexpression PLUS multiplicativeexpression { }
|
| additiveexpression PLUS multiplicativeexpression { BinaryOperation Addition $1 $3 }
|
||||||
| additiveexpression MINUS multiplicativeexpression { }
|
| additiveexpression MINUS multiplicativeexpression { BinaryOperation Subtraction $1 $3 }
|
||||||
|
|
||||||
multiplicativeexpression : unaryexpression { }
|
multiplicativeexpression : unaryexpression { $1 }
|
||||||
| multiplicativeexpression MUL unaryexpression { }
|
| multiplicativeexpression MUL unaryexpression { BinaryOperation Multiplication $1 $3 }
|
||||||
| multiplicativeexpression DIV unaryexpression { }
|
| multiplicativeexpression DIV unaryexpression { BinaryOperation Division $1 $3 }
|
||||||
| multiplicativeexpression MOD unaryexpression { }
|
| multiplicativeexpression MOD unaryexpression { BinaryOperation Modulo $1 $3 }
|
||||||
|
|
||||||
|
|
||||||
{
|
{
|
||||||
@ -365,13 +371,13 @@ data MethodOrFieldDeclaration = MethodDecl MethodDeclaration
|
|||||||
|
|
||||||
data Declarator = Declarator Identifier (Maybe Expression)
|
data Declarator = Declarator Identifier (Maybe Expression)
|
||||||
|
|
||||||
-- convertDeclaratorList :: [DataType] -> MethodOrFieldDeclaration
|
|
||||||
-- convertDeclaratorList = FieldDecls $ map
|
|
||||||
|
|
||||||
convertDeclarator :: DataType -> Declarator -> VariableDeclaration
|
convertDeclarator :: DataType -> Declarator -> VariableDeclaration
|
||||||
convertDeclarator dataType (Declarator id assigment) = VariableDeclaration dataType id assigment
|
convertDeclarator dataType (Declarator id assigment) = VariableDeclaration dataType id assigment
|
||||||
|
|
||||||
parseError :: [Token] -> a
|
data StatementWithoutSub = Statement
|
||||||
parseError msg = error ("Parse error: " ++ show msg)
|
|
||||||
|
|
||||||
|
parseError :: ([Token], [String]) -> a
|
||||||
|
parseError (errortoken, expected) = error ("parse error on token: " ++ show errortoken ++ "\nexpected one of: " ++ show expected)
|
||||||
|
|
||||||
}
|
}
|
||||||
|
@ -72,7 +72,7 @@ tokens :-
|
|||||||
-- end keywords
|
-- end keywords
|
||||||
$JavaLetter$JavaLetterOrDigit* { \s -> IDENTIFIER s }
|
$JavaLetter$JavaLetterOrDigit* { \s -> IDENTIFIER s }
|
||||||
-- Literals
|
-- Literals
|
||||||
[1-9]([0-9\_]*[0-9])* { \s -> case readMaybe $ filter ((/=) '_') s of Just a -> INTEGERLITERAL a; Nothing -> error ("failed to parse INTLITERAL " ++ s) }
|
[0-9]([0-9\_]*[0-9])* { \s -> case readMaybe $ filter ((/=) '_') s of Just a -> INTEGERLITERAL a; Nothing -> error ("failed to parse INTLITERAL " ++ s) }
|
||||||
"'"."'" { \s -> case (s) of _ : c : _ -> CHARLITERAL c; _ -> error ("failed to parse CHARLITERAL " ++ s) }
|
"'"."'" { \s -> case (s) of _ : c : _ -> CHARLITERAL c; _ -> error ("failed to parse CHARLITERAL " ++ s) }
|
||||||
-- separators
|
-- separators
|
||||||
"(" { \_ -> LBRACE }
|
"(" { \_ -> LBRACE }
|
||||||
|
381
src/Typecheck.hs
381
src/Typecheck.hs
@ -9,25 +9,42 @@ typeCheckCompilationUnit classes = map (`typeCheckClass` classes) classes
|
|||||||
typeCheckClass :: Class -> [Class] -> Class
|
typeCheckClass :: Class -> [Class] -> Class
|
||||||
typeCheckClass (Class className methods fields) classes =
|
typeCheckClass (Class className methods fields) classes =
|
||||||
let
|
let
|
||||||
-- Create a symbol table from class fields and method entries
|
-- Fields and methods dont need to be added to the symtab because they are looked upon automatically under "this"
|
||||||
classFields = [(id, dt) | VariableDeclaration dt id _ <- fields]
|
-- if its not a declared local variable. Also shadowing wouldnt be possible then.
|
||||||
methodEntries = [(methodName, className) | MethodDeclaration _ methodName _ _ <- methods]
|
initalSymTab = [("this", className)]
|
||||||
initalSymTab = ("this", className) : classFields ++ methodEntries
|
|
||||||
checkedMethods = map (\method -> typeCheckMethodDeclaration method initalSymTab classes) methods
|
checkedMethods = map (\method -> typeCheckMethodDeclaration method initalSymTab classes) methods
|
||||||
in Class className checkedMethods fields
|
checkedFields = map (\field -> typeCheckVariableDeclaration field initalSymTab classes) fields
|
||||||
|
in Class className checkedMethods checkedFields
|
||||||
|
|
||||||
typeCheckMethodDeclaration :: MethodDeclaration -> [(Identifier, DataType)] -> [Class] -> MethodDeclaration
|
typeCheckMethodDeclaration :: MethodDeclaration -> [(Identifier, DataType)] -> [Class] -> MethodDeclaration
|
||||||
typeCheckMethodDeclaration (MethodDeclaration retType name params body) classFields classes =
|
typeCheckMethodDeclaration (MethodDeclaration retType name params body) symtab classes =
|
||||||
let
|
let
|
||||||
-- Combine class fields with method parameters to form the initial symbol table for the method
|
|
||||||
methodParams = [(identifier, dataType) | ParameterDeclaration dataType identifier <- params]
|
methodParams = [(identifier, dataType) | ParameterDeclaration dataType identifier <- params]
|
||||||
initialSymtab = classFields ++ methodParams
|
initialSymtab = ("thisMeth", retType) : symtab ++ methodParams
|
||||||
checkedBody = typeCheckStatement body initialSymtab classes
|
checkedBody = typeCheckStatement body initialSymtab classes
|
||||||
bodyType = getTypeFromStmt checkedBody
|
bodyType = getTypeFromStmt checkedBody
|
||||||
-- Check if the type of the body matches the declared return type
|
in if bodyType == retType || (bodyType == "void" && retType == "void") || (bodyType == "null" && isObjectType retType) || isSubtype bodyType retType classes
|
||||||
in if bodyType == retType || (bodyType == "void" && retType == "void")
|
|
||||||
then MethodDeclaration retType name params checkedBody
|
then MethodDeclaration retType name params checkedBody
|
||||||
else error $ "Return type mismatch in method " ++ name ++ ": expected " ++ retType ++ ", found " ++ bodyType
|
else error $ "Method Declaration: Return type mismatch in method " ++ name ++ ": expected " ++ retType ++ ", found " ++ bodyType
|
||||||
|
|
||||||
|
typeCheckVariableDeclaration :: VariableDeclaration -> [(Identifier, DataType)] -> [Class] -> VariableDeclaration
|
||||||
|
typeCheckVariableDeclaration (VariableDeclaration dataType identifier maybeExpr) symtab classes =
|
||||||
|
let
|
||||||
|
-- Ensure the type is valid (either a primitive type or a valid class name)
|
||||||
|
validType = dataType `elem` ["int", "boolean", "char"] || isUserDefinedClass dataType classes
|
||||||
|
-- Ensure no redefinition in the same scope
|
||||||
|
redefined = any ((== identifier) . snd) symtab
|
||||||
|
-- Type check the initializer expression if it exists
|
||||||
|
checkedExpr = fmap (\expr -> typeCheckExpression expr symtab classes) maybeExpr
|
||||||
|
exprType = fmap getTypeFromExpr checkedExpr
|
||||||
|
in case (validType, redefined, exprType) of
|
||||||
|
(False, _, _) -> error $ "Type '" ++ dataType ++ "' is not a valid type for variable '" ++ identifier ++ "'"
|
||||||
|
(_, True, _) -> error $ "Variable '" ++ identifier ++ "' is redefined in the same scope"
|
||||||
|
(_, _, Just t)
|
||||||
|
| t == "null" && isObjectType dataType -> VariableDeclaration dataType identifier checkedExpr
|
||||||
|
| t /= dataType -> error $ "Type mismatch in declaration of '" ++ identifier ++ "': expected " ++ dataType ++ ", found " ++ t
|
||||||
|
| otherwise -> VariableDeclaration dataType identifier checkedExpr
|
||||||
|
(_, _, Nothing) -> VariableDeclaration dataType identifier checkedExpr
|
||||||
|
|
||||||
-- ********************************** Type Checking: Expressions **********************************
|
-- ********************************** Type Checking: Expressions **********************************
|
||||||
|
|
||||||
@ -37,118 +54,47 @@ typeCheckExpression (CharacterLiteral c) _ _ = TypedExpression "char" (Character
|
|||||||
typeCheckExpression (BooleanLiteral b) _ _ = TypedExpression "boolean" (BooleanLiteral b)
|
typeCheckExpression (BooleanLiteral b) _ _ = TypedExpression "boolean" (BooleanLiteral b)
|
||||||
typeCheckExpression NullLiteral _ _ = TypedExpression "null" NullLiteral
|
typeCheckExpression NullLiteral _ _ = TypedExpression "null" NullLiteral
|
||||||
typeCheckExpression (Reference id) symtab classes =
|
typeCheckExpression (Reference id) symtab classes =
|
||||||
let type' = lookupType id symtab
|
case lookup id symtab of
|
||||||
in TypedExpression type' (Reference id)
|
Just t -> TypedExpression t (LocalVariable id)
|
||||||
|
Nothing ->
|
||||||
|
case lookup "this" symtab of
|
||||||
|
Just className ->
|
||||||
|
let classDetails = find (\(Class name _ _) -> name == className) classes
|
||||||
|
in case classDetails of
|
||||||
|
Just (Class _ _ fields) ->
|
||||||
|
let fieldTypes = [dt | VariableDeclaration dt fieldId _ <- fields, fieldId == id]
|
||||||
|
-- this case only happens when its a field of its own class so the implicit this will be converted to explicit this
|
||||||
|
in case fieldTypes of
|
||||||
|
[fieldType] -> TypedExpression fieldType (BinaryOperation NameResolution (TypedExpression className (LocalVariable "this")) (TypedExpression fieldType (FieldVariable id)))
|
||||||
|
[] -> error $ "Field '" ++ id ++ "' not found in class '" ++ className ++ "'"
|
||||||
|
_ -> error $ "Ambiguous reference to field '" ++ id ++ "' in class '" ++ className ++ "'"
|
||||||
|
Nothing -> error $ "Class '" ++ className ++ "' not found for 'this'"
|
||||||
|
Nothing -> error $ "Context for 'this' not found in symbol table, unable to resolve '" ++ id ++ "'"
|
||||||
|
|
||||||
typeCheckExpression (BinaryOperation op expr1 expr2) symtab classes =
|
typeCheckExpression (BinaryOperation op expr1 expr2) symtab classes =
|
||||||
let expr1' = typeCheckExpression expr1 symtab classes
|
let expr1' = typeCheckExpression expr1 symtab classes
|
||||||
expr2' = typeCheckExpression expr2 symtab classes
|
expr2' = typeCheckExpression expr2 symtab classes
|
||||||
type1 = getTypeFromExpr expr1'
|
type1 = getTypeFromExpr expr1'
|
||||||
type2 = getTypeFromExpr expr2'
|
type2 = getTypeFromExpr expr2'
|
||||||
|
resultType = resolveResultType type1 type2
|
||||||
in case op of
|
in case op of
|
||||||
Addition ->
|
Addition -> checkArithmeticOperation op expr1' expr2' type1 type2 resultType
|
||||||
if type1 == "int" && type2 == "int"
|
Subtraction -> checkArithmeticOperation op expr1' expr2' type1 type2 resultType
|
||||||
then
|
Multiplication -> checkArithmeticOperation op expr1' expr2' type1 type2 resultType
|
||||||
TypedExpression "int" (BinaryOperation op expr1' expr2')
|
Division -> checkArithmeticOperation op expr1' expr2' type1 type2 resultType
|
||||||
else
|
Modulo -> checkArithmeticOperation op expr1' expr2' type1 type2 resultType
|
||||||
error "Addition operation requires two operands of type int"
|
BitwiseAnd -> checkBitwiseOperation op expr1' expr2' type1 type2
|
||||||
Subtraction ->
|
BitwiseOr -> checkBitwiseOperation op expr1' expr2' type1 type2
|
||||||
if type1 == "int" && type2 == "int"
|
BitwiseXor -> checkBitwiseOperation op expr1' expr2' type1 type2
|
||||||
then
|
CompareLessThan -> checkComparisonOperation op expr1' expr2' type1 type2
|
||||||
TypedExpression "int" (BinaryOperation op expr1' expr2')
|
CompareLessOrEqual -> checkComparisonOperation op expr1' expr2' type1 type2
|
||||||
else
|
CompareGreaterThan -> checkComparisonOperation op expr1' expr2' type1 type2
|
||||||
error "Subtraction operation requires two operands of type int"
|
CompareGreaterOrEqual -> checkComparisonOperation op expr1' expr2' type1 type2
|
||||||
Multiplication ->
|
CompareEqual -> checkEqualityOperation op expr1' expr2' type1 type2
|
||||||
if type1 == "int" && type2 == "int"
|
CompareNotEqual -> checkEqualityOperation op expr1' expr2' type1 type2
|
||||||
then
|
And -> checkLogicalOperation op expr1' expr2' type1 type2
|
||||||
TypedExpression "int" (BinaryOperation op expr1' expr2')
|
Or -> checkLogicalOperation op expr1' expr2' type1 type2
|
||||||
else
|
NameResolution -> resolveNameResolution expr1' expr2 symtab classes
|
||||||
error "Multiplication operation requires two operands of type int"
|
|
||||||
Division ->
|
|
||||||
if type1 == "int" && type2 == "int"
|
|
||||||
then
|
|
||||||
TypedExpression "int" (BinaryOperation op expr1' expr2')
|
|
||||||
else
|
|
||||||
error "Division operation requires two operands of type int"
|
|
||||||
BitwiseAnd ->
|
|
||||||
if type1 == "int" && type2 == "int"
|
|
||||||
then
|
|
||||||
TypedExpression "int" (BinaryOperation op expr1' expr2')
|
|
||||||
else
|
|
||||||
error "Bitwise AND operation requires two operands of type int"
|
|
||||||
BitwiseOr ->
|
|
||||||
if type1 == "int" && type2 == "int"
|
|
||||||
then
|
|
||||||
TypedExpression "int" (BinaryOperation op expr1' expr2')
|
|
||||||
else
|
|
||||||
error "Bitwise OR operation requires two operands of type int"
|
|
||||||
BitwiseXor ->
|
|
||||||
if type1 == "int" && type2 == "int"
|
|
||||||
then
|
|
||||||
TypedExpression "int" (BinaryOperation op expr1' expr2')
|
|
||||||
else
|
|
||||||
error "Bitwise XOR operation requires two operands of type int"
|
|
||||||
CompareLessThan ->
|
|
||||||
if type1 == "int" && type2 == "int"
|
|
||||||
then
|
|
||||||
TypedExpression "boolean" (BinaryOperation op expr1' expr2')
|
|
||||||
else
|
|
||||||
error "Less than operation requires two operands of type int"
|
|
||||||
CompareLessOrEqual ->
|
|
||||||
if type1 == "int" && type2 == "int"
|
|
||||||
then
|
|
||||||
TypedExpression "boolean" (BinaryOperation op expr1' expr2')
|
|
||||||
else
|
|
||||||
error "Less than or equal operation requires two operands of type int"
|
|
||||||
CompareGreaterThan ->
|
|
||||||
if type1 == "int" && type2 == "int"
|
|
||||||
then
|
|
||||||
TypedExpression "boolean" (BinaryOperation op expr1' expr2')
|
|
||||||
else
|
|
||||||
error "Greater than operation requires two operands of type int"
|
|
||||||
CompareGreaterOrEqual ->
|
|
||||||
if type1 == "int" && type2 == "int"
|
|
||||||
then
|
|
||||||
TypedExpression "boolean" (BinaryOperation op expr1' expr2')
|
|
||||||
else
|
|
||||||
error "Greater than or equal operation requires two operands of type int"
|
|
||||||
CompareEqual ->
|
|
||||||
if type1 == type2
|
|
||||||
then
|
|
||||||
TypedExpression "boolean" (BinaryOperation op expr1' expr2')
|
|
||||||
else
|
|
||||||
error "Equality operation requires two operands of the same type"
|
|
||||||
CompareNotEqual ->
|
|
||||||
if type1 == type2
|
|
||||||
then
|
|
||||||
TypedExpression "boolean" (BinaryOperation op expr1' expr2')
|
|
||||||
else
|
|
||||||
error "Inequality operation requires two operands of the same type"
|
|
||||||
And ->
|
|
||||||
if type1 == "boolean" && type2 == "boolean"
|
|
||||||
then
|
|
||||||
TypedExpression "boolean" (BinaryOperation op expr1' expr2')
|
|
||||||
else
|
|
||||||
error "Logical AND operation requires two operands of type boolean"
|
|
||||||
Or ->
|
|
||||||
if type1 == "boolean" && type2 == "boolean"
|
|
||||||
then
|
|
||||||
TypedExpression "boolean" (BinaryOperation op expr1' expr2')
|
|
||||||
else
|
|
||||||
error "Logical OR operation requires two operands of type boolean"
|
|
||||||
NameResolution ->
|
|
||||||
case (expr1', expr2) of
|
|
||||||
(TypedExpression t1 (Reference obj), Reference member) ->
|
|
||||||
let objectType = lookupType obj symtab
|
|
||||||
classDetails = find (\(Class className _ _) -> className == objectType) classes
|
|
||||||
in case classDetails of
|
|
||||||
Just (Class _ _ fields) ->
|
|
||||||
let fieldTypes = [dt | VariableDeclaration dt id _ <- fields, id == member]
|
|
||||||
in case fieldTypes of
|
|
||||||
[resolvedType] -> TypedExpression resolvedType (BinaryOperation NameResolution expr1' (TypedExpression resolvedType expr2))
|
|
||||||
[] -> error $ "Field '" ++ member ++ "' not found in class '" ++ objectType ++ "'"
|
|
||||||
_ -> error $ "Ambiguous reference to field '" ++ member ++ "' in class '" ++ objectType ++ "'"
|
|
||||||
Nothing -> error $ "Object '" ++ obj ++ "' does not correspond to a known class"
|
|
||||||
_ -> error "Name resolution requires object reference and field name"
|
|
||||||
|
|
||||||
typeCheckExpression (UnaryOperation op expr) symtab classes =
|
typeCheckExpression (UnaryOperation op expr) symtab classes =
|
||||||
let expr' = typeCheckExpression expr symtab classes
|
let expr' = typeCheckExpression expr symtab classes
|
||||||
@ -161,11 +107,11 @@ typeCheckExpression (UnaryOperation op expr) symtab classes =
|
|||||||
else
|
else
|
||||||
error "Logical NOT operation requires an operand of type boolean"
|
error "Logical NOT operation requires an operand of type boolean"
|
||||||
Minus ->
|
Minus ->
|
||||||
if type' == "int"
|
if type' == "int" || type' == "char"
|
||||||
then
|
then
|
||||||
TypedExpression "int" (UnaryOperation op expr')
|
TypedExpression type' (UnaryOperation op expr')
|
||||||
else
|
else
|
||||||
error "Unary minus operation requires an operand of type int"
|
error "Unary minus operation requires an operand of type int or char"
|
||||||
|
|
||||||
typeCheckExpression (StatementExpressionExpression stmtExpr) symtab classes =
|
typeCheckExpression (StatementExpressionExpression stmtExpr) symtab classes =
|
||||||
let stmtExpr' = typeCheckStatementExpression stmtExpr symtab classes
|
let stmtExpr' = typeCheckStatementExpression stmtExpr symtab classes
|
||||||
@ -174,23 +120,29 @@ typeCheckExpression (StatementExpressionExpression stmtExpr) symtab classes =
|
|||||||
-- ********************************** Type Checking: StatementExpressions **********************************
|
-- ********************************** Type Checking: StatementExpressions **********************************
|
||||||
|
|
||||||
typeCheckStatementExpression :: StatementExpression -> [(Identifier, DataType)] -> [Class] -> StatementExpression
|
typeCheckStatementExpression :: StatementExpression -> [(Identifier, DataType)] -> [Class] -> StatementExpression
|
||||||
typeCheckStatementExpression (Assignment id expr) symtab classes =
|
typeCheckStatementExpression (Assignment ref expr) symtab classes =
|
||||||
let expr' = typeCheckExpression expr symtab classes
|
let expr' = typeCheckExpression expr symtab classes
|
||||||
|
ref' = typeCheckExpression ref symtab classes
|
||||||
type' = getTypeFromExpr expr'
|
type' = getTypeFromExpr expr'
|
||||||
type'' = lookupType id symtab
|
type'' = getTypeFromExpr ref'
|
||||||
in if type' == type''
|
in
|
||||||
then
|
if type'' == type' || (type' == "null" && isObjectType type'') then
|
||||||
TypedStatementExpression type' (Assignment id expr')
|
TypedStatementExpression type'' (Assignment ref' expr')
|
||||||
else
|
else
|
||||||
error "Assignment type mismatch"
|
error $ "Type mismatch in assignment to variable: expected " ++ type'' ++ ", found " ++ type'
|
||||||
|
|
||||||
typeCheckStatementExpression (ConstructorCall className args) symtab classes =
|
typeCheckStatementExpression (ConstructorCall className args) symtab classes =
|
||||||
case find (\(Class name _ _) -> name == className) classes of
|
case find (\(Class name _ _) -> name == className) classes of
|
||||||
Nothing -> error $ "Class '" ++ className ++ "' not found."
|
Nothing -> error $ "Class '" ++ className ++ "' not found."
|
||||||
Just (Class _ methods fields) ->
|
Just (Class _ methods fields) ->
|
||||||
-- Constructor needs the same name as the class
|
-- Find constructor matching the class name with void return type
|
||||||
case find (\(MethodDeclaration retType name params _) -> name == className && retType == className) methods of
|
case find (\(MethodDeclaration retType name params _) -> name == "<init>" && retType == "void") methods of
|
||||||
Nothing -> error $ "No valid constructor found for class '" ++ className ++ "'."
|
-- If no constructor is found, assume standard constructor with no parameters
|
||||||
|
Nothing ->
|
||||||
|
if null args then
|
||||||
|
TypedStatementExpression className (ConstructorCall className args)
|
||||||
|
else
|
||||||
|
error $ "No valid constructor found for class '" ++ className ++ "', but arguments were provided."
|
||||||
Just (MethodDeclaration _ _ params _) ->
|
Just (MethodDeclaration _ _ params _) ->
|
||||||
let
|
let
|
||||||
args' = map (\arg -> typeCheckExpression arg symtab classes) args
|
args' = map (\arg -> typeCheckExpression arg symtab classes) args
|
||||||
@ -234,20 +186,62 @@ typeCheckStatementExpression (MethodCall expr methodName args) symtab classes =
|
|||||||
Nothing -> error $ "Class for object type '" ++ objType ++ "' not found."
|
Nothing -> error $ "Class for object type '" ++ objType ++ "' not found."
|
||||||
_ -> error "Invalid object type for method call. Object must have a class type."
|
_ -> error "Invalid object type for method call. Object must have a class type."
|
||||||
|
|
||||||
|
typeCheckStatementExpression (PostIncrement expr) symtab classes =
|
||||||
|
let expr' = typeCheckExpression expr symtab classes
|
||||||
|
type' = getTypeFromExpr expr'
|
||||||
|
in if type' == "int" || type' == "char"
|
||||||
|
then
|
||||||
|
TypedStatementExpression type' (PostIncrement expr')
|
||||||
|
else
|
||||||
|
error "Post-increment operation requires an operand of type int or char"
|
||||||
|
|
||||||
|
typeCheckStatementExpression (PostDecrement expr) symtab classes =
|
||||||
|
let expr' = typeCheckExpression expr symtab classes
|
||||||
|
type' = getTypeFromExpr expr'
|
||||||
|
in if type' == "int" || type' == "char"
|
||||||
|
then
|
||||||
|
TypedStatementExpression type' (PostDecrement expr')
|
||||||
|
else
|
||||||
|
error "Post-decrement operation requires an operand of type int or char"
|
||||||
|
|
||||||
|
typeCheckStatementExpression (PreIncrement expr) symtab classes =
|
||||||
|
let expr' = typeCheckExpression expr symtab classes
|
||||||
|
type' = getTypeFromExpr expr'
|
||||||
|
in if type' == "int" || type' == "char"
|
||||||
|
then
|
||||||
|
TypedStatementExpression type' (PreIncrement expr')
|
||||||
|
else
|
||||||
|
error "Pre-increment operation requires an operand of type int or char"
|
||||||
|
|
||||||
|
typeCheckStatementExpression (PreDecrement expr) symtab classes =
|
||||||
|
let expr' = typeCheckExpression expr symtab classes
|
||||||
|
type' = getTypeFromExpr expr'
|
||||||
|
in if type' == "int" || type' == "char"
|
||||||
|
then
|
||||||
|
TypedStatementExpression type' (PreDecrement expr')
|
||||||
|
else
|
||||||
|
error "Pre-decrement operation requires an operand of type int or char"
|
||||||
|
|
||||||
-- ********************************** Type Checking: Statements **********************************
|
-- ********************************** Type Checking: Statements **********************************
|
||||||
|
|
||||||
typeCheckStatement :: Statement -> [(Identifier, DataType)] -> [Class] -> Statement
|
typeCheckStatement :: Statement -> [(Identifier, DataType)] -> [Class] -> Statement
|
||||||
typeCheckStatement (If cond thenStmt elseStmt) symtab classes =
|
typeCheckStatement (If cond thenStmt elseStmt) symtab classes =
|
||||||
let cond' = typeCheckExpression cond symtab classes
|
let
|
||||||
|
cond' = typeCheckExpression cond symtab classes
|
||||||
thenStmt' = typeCheckStatement thenStmt symtab classes
|
thenStmt' = typeCheckStatement thenStmt symtab classes
|
||||||
elseStmt' = case elseStmt of
|
elseStmt' = fmap (\stmt -> typeCheckStatement stmt symtab classes) elseStmt
|
||||||
Just stmt -> Just (typeCheckStatement stmt symtab classes)
|
|
||||||
Nothing -> Nothing
|
thenType = getTypeFromStmt thenStmt'
|
||||||
|
elseType = maybe "void" getTypeFromStmt elseStmt'
|
||||||
|
|
||||||
|
ifType = if thenType == "void" || elseType == "void"
|
||||||
|
then "void"
|
||||||
|
else unifyReturnTypes thenType elseType
|
||||||
|
|
||||||
in if getTypeFromExpr cond' == "boolean"
|
in if getTypeFromExpr cond' == "boolean"
|
||||||
then
|
then TypedStatement ifType (If cond' thenStmt' elseStmt')
|
||||||
TypedStatement (getTypeFromStmt thenStmt') (If cond' thenStmt' elseStmt')
|
else error "If condition must be of type boolean"
|
||||||
else
|
|
||||||
error "If condition must be of type boolean"
|
|
||||||
|
|
||||||
typeCheckStatement (LocalVariableDeclaration (VariableDeclaration dataType identifier maybeExpr)) symtab classes =
|
typeCheckStatement (LocalVariableDeclaration (VariableDeclaration dataType identifier maybeExpr)) symtab classes =
|
||||||
-- Check for redefinition in the current scope
|
-- Check for redefinition in the current scope
|
||||||
@ -258,8 +252,12 @@ typeCheckStatement (LocalVariableDeclaration (VariableDeclaration dataType ident
|
|||||||
let checkedExpr = fmap (\expr -> typeCheckExpression expr symtab classes) maybeExpr
|
let checkedExpr = fmap (\expr -> typeCheckExpression expr symtab classes) maybeExpr
|
||||||
exprType = fmap getTypeFromExpr checkedExpr
|
exprType = fmap getTypeFromExpr checkedExpr
|
||||||
in case exprType of
|
in case exprType of
|
||||||
Just t | t /= dataType -> error $ "Type mismatch in declaration of '" ++ identifier ++ "': expected " ++ dataType ++ ", found " ++ t
|
Just t
|
||||||
_ -> TypedStatement dataType (LocalVariableDeclaration (VariableDeclaration dataType identifier checkedExpr))
|
| t == "null" && isObjectType dataType ->
|
||||||
|
TypedStatement dataType (LocalVariableDeclaration (VariableDeclaration dataType identifier checkedExpr))
|
||||||
|
| t /= dataType -> error $ "Type mismatch in declaration of '" ++ identifier ++ "': expected " ++ dataType ++ ", found " ++ t
|
||||||
|
| otherwise -> TypedStatement dataType (LocalVariableDeclaration (VariableDeclaration dataType identifier checkedExpr))
|
||||||
|
Nothing -> TypedStatement dataType (LocalVariableDeclaration (VariableDeclaration dataType identifier checkedExpr))
|
||||||
|
|
||||||
typeCheckStatement (While cond stmt) symtab classes =
|
typeCheckStatement (While cond stmt) symtab classes =
|
||||||
let cond' = typeCheckExpression cond symtab classes
|
let cond' = typeCheckExpression cond symtab classes
|
||||||
@ -273,36 +271,46 @@ typeCheckStatement (While cond stmt) symtab classes =
|
|||||||
typeCheckStatement (Block statements) symtab classes =
|
typeCheckStatement (Block statements) symtab classes =
|
||||||
let
|
let
|
||||||
processStatements (accSts, currentSymtab, types) stmt =
|
processStatements (accSts, currentSymtab, types) stmt =
|
||||||
|
case stmt of
|
||||||
|
LocalVariableDeclaration (VariableDeclaration dataType identifier maybeExpr) ->
|
||||||
|
let
|
||||||
|
alreadyDefined = any (\(id, _) -> id == identifier) currentSymtab
|
||||||
|
newSymtab = if alreadyDefined
|
||||||
|
then error ("Variable " ++ identifier ++ " already defined in this scope.")
|
||||||
|
else (identifier, dataType) : currentSymtab
|
||||||
|
checkedExpr = fmap (\expr -> typeCheckExpression expr currentSymtab classes) maybeExpr
|
||||||
|
checkedStmt = typeCheckStatement stmt newSymtab classes
|
||||||
|
in (accSts ++ [checkedStmt], newSymtab, types)
|
||||||
|
|
||||||
|
_ ->
|
||||||
let
|
let
|
||||||
checkedStmt = typeCheckStatement stmt currentSymtab classes
|
checkedStmt = typeCheckStatement stmt currentSymtab classes
|
||||||
stmtType = getTypeFromStmt checkedStmt
|
stmtType = getTypeFromStmt checkedStmt
|
||||||
in case stmt of
|
in case stmt of
|
||||||
LocalVariableDeclaration (VariableDeclaration dataType identifier maybeExpr) ->
|
|
||||||
let
|
|
||||||
checkedExpr = fmap (\expr -> typeCheckExpression expr currentSymtab classes) maybeExpr
|
|
||||||
newSymtab = (identifier, dataType) : currentSymtab
|
|
||||||
in (accSts ++ [checkedStmt], newSymtab, types)
|
|
||||||
|
|
||||||
If {} -> (accSts ++ [checkedStmt], currentSymtab, if stmtType /= "void" then types ++ [stmtType] else types)
|
If {} -> (accSts ++ [checkedStmt], currentSymtab, if stmtType /= "void" then types ++ [stmtType] else types)
|
||||||
While _ _ -> (accSts ++ [checkedStmt], currentSymtab, if stmtType /= "void" then types ++ [stmtType] else types)
|
While _ _ -> (accSts ++ [checkedStmt], currentSymtab, if stmtType /= "void" then types ++ [stmtType] else types)
|
||||||
Return _ -> (accSts ++ [checkedStmt], currentSymtab, if stmtType /= "void" then types ++ [stmtType] else types)
|
Return _ -> (accSts ++ [checkedStmt], currentSymtab, if stmtType /= "void" then types ++ [stmtType] else types)
|
||||||
|
Block _ -> (accSts ++ [checkedStmt], currentSymtab, if stmtType /= "void" then types ++ [stmtType] else types)
|
||||||
_ -> (accSts ++ [checkedStmt], currentSymtab, types)
|
_ -> (accSts ++ [checkedStmt], currentSymtab, types)
|
||||||
|
|
||||||
-- Initial accumulator: empty statements list, initial symbol table, empty types list
|
-- Initial accumulator: empty statements list, initial symbol table, empty types list
|
||||||
(checkedStatements, finalSymtab, collectedTypes) = foldl processStatements ([], symtab, []) statements
|
(checkedStatements, finalSymtab, collectedTypes) = foldl processStatements ([], symtab, []) statements
|
||||||
|
|
||||||
-- Determine the block's type: unify all collected types, default to "Void" if none
|
-- Determine the block's type: unify all collected types, default to "void" if none (UpperBound)
|
||||||
blockType = if null collectedTypes then "void" else foldl1 unifyReturnTypes collectedTypes
|
blockType = if null collectedTypes then "void" else foldl1 unifyReturnTypes collectedTypes
|
||||||
|
|
||||||
in TypedStatement blockType (Block checkedStatements)
|
in TypedStatement blockType (Block checkedStatements)
|
||||||
|
|
||||||
|
|
||||||
typeCheckStatement (Return expr) symtab classes =
|
typeCheckStatement (Return expr) symtab classes =
|
||||||
let expr' = case expr of
|
let methodReturnType = fromMaybe (error "Method return type not found in symbol table") (lookup "thisMeth" symtab)
|
||||||
|
expr' = case expr of
|
||||||
Just e -> Just (typeCheckExpression e symtab classes)
|
Just e -> Just (typeCheckExpression e symtab classes)
|
||||||
Nothing -> Nothing
|
Nothing -> Nothing
|
||||||
in case expr' of
|
returnType = maybe "void" getTypeFromExpr expr'
|
||||||
Just e' -> TypedStatement (getTypeFromExpr e') (Return (Just e'))
|
in if returnType == methodReturnType || isSubtype returnType methodReturnType classes
|
||||||
Nothing -> TypedStatement "Void" (Return Nothing)
|
then TypedStatement returnType (Return expr')
|
||||||
|
else error $ "Return: Return type mismatch: expected " ++ methodReturnType ++ ", found " ++ returnType
|
||||||
|
|
||||||
typeCheckStatement (StatementExpressionStatement stmtExpr) symtab classes =
|
typeCheckStatement (StatementExpressionStatement stmtExpr) symtab classes =
|
||||||
let stmtExpr' = typeCheckStatementExpression stmtExpr symtab classes
|
let stmtExpr' = typeCheckStatementExpression stmtExpr symtab classes
|
||||||
@ -310,6 +318,20 @@ typeCheckStatement (StatementExpressionStatement stmtExpr) symtab classes =
|
|||||||
|
|
||||||
-- ********************************** Type Checking: Helpers **********************************
|
-- ********************************** Type Checking: Helpers **********************************
|
||||||
|
|
||||||
|
isSubtype :: DataType -> DataType -> [Class] -> Bool
|
||||||
|
isSubtype subType superType classes
|
||||||
|
| subType == superType = True
|
||||||
|
| subType == "null" && isObjectType superType = True
|
||||||
|
| superType == "Object" && isObjectType subType = True
|
||||||
|
| superType == "Object" && isUserDefinedClass subType classes = True
|
||||||
|
| otherwise = False
|
||||||
|
|
||||||
|
isUserDefinedClass :: DataType -> [Class] -> Bool
|
||||||
|
isUserDefinedClass dt classes = dt `elem` map (\(Class name _ _) -> name) classes
|
||||||
|
|
||||||
|
isObjectType :: DataType -> Bool
|
||||||
|
isObjectType dt = dt /= "int" && dt /= "boolean" && dt /= "char"
|
||||||
|
|
||||||
getTypeFromExpr :: Expression -> DataType
|
getTypeFromExpr :: Expression -> DataType
|
||||||
getTypeFromExpr (TypedExpression t _) = t
|
getTypeFromExpr (TypedExpression t _) = t
|
||||||
getTypeFromExpr _ = error "Untyped expression found where typed was expected"
|
getTypeFromExpr _ = error "Untyped expression found where typed was expected"
|
||||||
@ -325,10 +347,59 @@ getTypeFromStmtExpr _ = error "Untyped statement expression found where typed wa
|
|||||||
unifyReturnTypes :: DataType -> DataType -> DataType
|
unifyReturnTypes :: DataType -> DataType -> DataType
|
||||||
unifyReturnTypes dt1 dt2
|
unifyReturnTypes dt1 dt2
|
||||||
| dt1 == dt2 = dt1
|
| dt1 == dt2 = dt1
|
||||||
|
| dt1 == "null" = dt2
|
||||||
|
| dt2 == "null" = dt1
|
||||||
| otherwise = "Object"
|
| otherwise = "Object"
|
||||||
|
|
||||||
lookupType :: Identifier -> [(Identifier, DataType)] -> DataType
|
resolveResultType :: DataType -> DataType -> DataType
|
||||||
lookupType id symtab =
|
resolveResultType "char" "char" = "char"
|
||||||
case lookup id symtab of
|
resolveResultType "int" "int" = "int"
|
||||||
Just t -> t
|
resolveResultType "char" "int" = "int"
|
||||||
Nothing -> error ("Identifier " ++ id ++ " not found in symbol table")
|
resolveResultType "int" "char" = "int"
|
||||||
|
resolveResultType t1 t2
|
||||||
|
| t1 == t2 = t1
|
||||||
|
| otherwise = error $ "Incompatible types: " ++ t1 ++ " and " ++ t2
|
||||||
|
|
||||||
|
checkArithmeticOperation :: BinaryOperator -> Expression -> Expression -> DataType -> DataType -> DataType -> Expression
|
||||||
|
checkArithmeticOperation op expr1' expr2' type1 type2 resultType
|
||||||
|
| (type1 == "int" || type1 == "char") && (type2 == "int" || type2 == "char") =
|
||||||
|
TypedExpression resultType (BinaryOperation op expr1' expr2')
|
||||||
|
| otherwise = error $ "Arithmetic operation " ++ show op ++ " requires operands of type int or char"
|
||||||
|
|
||||||
|
checkBitwiseOperation :: BinaryOperator -> Expression -> Expression -> DataType -> DataType -> Expression
|
||||||
|
checkBitwiseOperation op expr1' expr2' type1 type2
|
||||||
|
| type1 == "int" && type2 == "int" =
|
||||||
|
TypedExpression "int" (BinaryOperation op expr1' expr2')
|
||||||
|
| otherwise = error $ "Bitwise operation " ++ show op ++ " requires operands of type int or char"
|
||||||
|
|
||||||
|
checkComparisonOperation :: BinaryOperator -> Expression -> Expression -> DataType -> DataType -> Expression
|
||||||
|
checkComparisonOperation op expr1' expr2' type1 type2
|
||||||
|
| (type1 == "int" || type1 == "char") && (type2 == "int" || type2 == "char") =
|
||||||
|
TypedExpression "boolean" (BinaryOperation op expr1' expr2')
|
||||||
|
| otherwise = error $ "Comparison operation " ++ show op ++ " requires operands of type int or char"
|
||||||
|
|
||||||
|
checkEqualityOperation :: BinaryOperator -> Expression -> Expression -> DataType -> DataType -> Expression
|
||||||
|
checkEqualityOperation op expr1' expr2' type1 type2
|
||||||
|
| type1 == type2 =
|
||||||
|
TypedExpression "boolean" (BinaryOperation op expr1' expr2')
|
||||||
|
| otherwise = error $ "Equality operation " ++ show op ++ " requires operands of the same type"
|
||||||
|
|
||||||
|
checkLogicalOperation :: BinaryOperator -> Expression -> Expression -> DataType -> DataType -> Expression
|
||||||
|
checkLogicalOperation op expr1' expr2' type1 type2
|
||||||
|
| type1 == "boolean" && type2 == "boolean" =
|
||||||
|
TypedExpression "boolean" (BinaryOperation op expr1' expr2')
|
||||||
|
| otherwise = error $ "Logical operation " ++ show op ++ " requires operands of type boolean"
|
||||||
|
|
||||||
|
resolveNameResolution :: Expression -> Expression -> [(Identifier, DataType)] -> [Class] -> Expression
|
||||||
|
resolveNameResolution expr1' (Reference ident2) symtab classes =
|
||||||
|
case getTypeFromExpr expr1' of
|
||||||
|
objType ->
|
||||||
|
case find (\(Class className _ _) -> className == objType) classes of
|
||||||
|
Just (Class _ _ fields) ->
|
||||||
|
let fieldTypes = [dt | VariableDeclaration dt id _ <- fields, id == ident2]
|
||||||
|
in case fieldTypes of
|
||||||
|
[resolvedType] -> TypedExpression resolvedType (BinaryOperation NameResolution expr1' (TypedExpression resolvedType (FieldVariable ident2)))
|
||||||
|
[] -> error $ "Field '" ++ ident2 ++ "' not found in class '" ++ objType ++ "'"
|
||||||
|
_ -> error $ "Ambiguous reference to field '" ++ ident2 ++ "' in class '" ++ objType ++ "'"
|
||||||
|
Nothing -> error $ "Class '" ++ objType ++ "' not found"
|
||||||
|
resolveNameResolution _ _ _ _ = error "Name resolution requires object reference and field name"
|
||||||
|
Loading…
Reference in New Issue
Block a user