Compare commits
236 Commits
8b5650dd61
...
typechecke
| Author | SHA1 | Date | |
|---|---|---|---|
| ab7077d8f0 | |||
| 53061fb73d | |||
| bac2a534b6 | |||
| 574628d3f7 | |||
| 30288731d3 | |||
| f7d135cdd6 | |||
| c05aa302a4 | |||
| 36d9b74df4 | |||
| 1348cea93f | |||
|
|
d648e5dd05 | ||
| 2b45d66ac1 | |||
|
|
fa285a4af2 | ||
|
|
0e1f31080e | ||
|
|
dee1fcb2df | ||
| c7e72dbde3 | |||
| 9657731a93 | |||
| b5efc76c17 | |||
|
|
25dd0802ad | ||
|
|
0a53ea14cf | ||
|
|
4c5dbd16f9 | ||
| d0bf34d331 | |||
| fe4ef2614f | |||
| 2154f8fd62 | |||
| 504e26dcdd | |||
| f09e6ad09e | |||
| 3e18efc097 | |||
|
|
cb462b5e75 | ||
|
|
3275b045cb | ||
| ae45251189 | |||
| 94ed7b5056 | |||
| 3d352035ee | |||
|
|
6b4b9b496d | ||
|
|
c8b3caa2af | ||
| 05a6de4a0d | |||
| 1eaeffb9a4 | |||
|
|
87f629282f | ||
|
|
6346cb237b | ||
|
|
74f52c3c35 | ||
|
|
711620bdd9 | ||
|
|
946a1f374c | ||
| 9ecadc8946 | |||
| 09dd11bb34 | |||
| 86aa87515b | |||
|
|
98735fd6ba | ||
|
|
8eb9c16c7a | ||
|
|
4435f7aac8 | ||
|
|
79ddafbf9a | ||
|
|
29faab5112 | ||
|
|
8c508e6d32 | ||
| faf3d1674e | |||
| bcbec9209a | |||
|
|
6547ad04f5 | ||
| 8a6dca4e36 | |||
|
|
ee302bb245 | ||
| 361643a85a | |||
|
|
d2554c9b22 | ||
|
|
5269971334 | ||
| e4693729dc | |||
|
|
d1bef2193e | ||
| 561a0b37d8 | |||
|
|
6e400ebb9d | ||
| dc2f845049 | |||
| 36c48d013a | |||
|
|
07fcda5827 | ||
| b1735c6300 | |||
|
|
fa9f8c3425 | ||
|
|
2c928ad69b | ||
|
|
b47da4633d | ||
|
|
3fc804e899 | ||
|
|
807aea112e | ||
|
|
9e43b015b7 | ||
|
|
79a989eecf | ||
| f02226bca8 | |||
|
|
3acbce8afc | ||
|
|
44c6d74afb | ||
|
|
3f6eb68e91 | ||
| 7e13b3fac3 | |||
|
|
613a280079 | ||
|
|
fbd76deca3 | ||
| 2139e7832c | |||
|
|
9a9c508fc7 | ||
| baf9362634 | |||
|
|
4def6e5804 | ||
| 2d6c7b1a06 | |||
|
|
3f78cdaa2d | ||
| 710ec43959 | |||
|
|
b41a77ba33 | ||
|
|
7317895800 | ||
|
|
06dad4d7f9 | ||
| b525d14192 | |||
| a62fe50a0d | |||
| 7c52084bbe | |||
|
|
98b02446ba | ||
| 82b2b4a6e1 | |||
| 3d351ee02b | |||
| 05b599b8ff | |||
| 060321f323 | |||
| fc96eba52e | |||
| af093fa3bb | |||
| 666856b33a | |||
|
|
578f959d7c | ||
|
|
bbe0d86670 | ||
| 30365d76bd | |||
|
|
c0caa7ce01 | ||
|
|
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 | |||
|
|
7cbf8aad08 | ||
|
|
93702071fb | ||
| e8151ad2f0 | |||
| a4b933d659 | |||
| 7bfdeed620 | |||
| 2f81f82661 | |||
| fecc7eceaa | |||
| 5e8a2a90ed | |||
|
|
176b98d659 | ||
| ced5d1df9c | |||
| acab0add95 | |||
|
|
c0d48b5274 | ||
| b040130569 | |||
| e723e9cb18 | |||
| d47c7f5a45 | |||
| 8c3c3625b9 | |||
| f9df24f456 | |||
| b7d8f19433 | |||
| 158197b440 | |||
| 358293d4d4 | |||
| 7422510267 | |||
| 40c7cab0e3 | |||
| e3fa3efd95 | |||
| d3ea0d6d7b | |||
| bea9a039a8 | |||
| 32cce1f137 | |||
| e04c475c55 | |||
| af7162ea54 | |||
| fa9cb761d5 | |||
| fa2dc24aa0 | |||
| fe4091da99 | |||
| db2b4a142c | |||
| 95063ac64f | |||
| 4108eb58c1 | |||
| ecd778cc70 | |||
| e5baa701b2 | |||
| 5d49da69a6 | |||
| b8e566a2a0 | |||
| 6d39110794 |
6
.gitignore
vendored
6
.gitignore
vendored
@@ -8,7 +8,6 @@ cabal-dev
|
||||
*.chs.h
|
||||
*.dyn_o
|
||||
*.dyn_hi
|
||||
*.java
|
||||
*.class
|
||||
*.local~*
|
||||
src/Parser/JavaParser.hs
|
||||
@@ -27,3 +26,8 @@ cabal.project.local
|
||||
cabal.project.local~
|
||||
.HTF/
|
||||
.ghc.environment.*
|
||||
texput.log
|
||||
doc/output/
|
||||
doc/*.aux
|
||||
doc/*.log
|
||||
doc/*.out
|
||||
@@ -5,7 +5,7 @@ Written in Haskell.
|
||||
# Cabal Commands
|
||||
run main
|
||||
```
|
||||
cabal run
|
||||
cabal run compiler <FILENAME>
|
||||
```
|
||||
|
||||
run tests
|
||||
|
||||
64
Test/JavaSources/Main.java
Normal file
64
Test/JavaSources/Main.java
Normal file
@@ -0,0 +1,64 @@
|
||||
// compile all test files using:
|
||||
// ls Test/JavaSources/*.java | grep -v ".*Main.java" | xargs -I {} cabal run compiler {}
|
||||
// compile (in project root) using:
|
||||
// pushd Test/JavaSources; javac -g:none Main.java; popd
|
||||
// afterwards, run using
|
||||
// java -ea -cp Test/JavaSources/ Main
|
||||
|
||||
public class Main {
|
||||
public static void main(String[] args)
|
||||
{
|
||||
TestEmpty empty = new TestEmpty();
|
||||
TestFields fields = new TestFields();
|
||||
TestConstructor constructor = new TestConstructor(42);
|
||||
TestArithmetic arithmetic = new TestArithmetic();
|
||||
TestMultipleClasses multipleClasses = new TestMultipleClasses();
|
||||
TestRecursion recursion = new TestRecursion(10);
|
||||
TestMalicious malicious = new TestMalicious();
|
||||
TestLoop loop = new TestLoop();
|
||||
TestMethodOverload overload = new TestMethodOverload();
|
||||
TestShenanigance shenanigance = new TestShenanigance();
|
||||
TestOptionalParameter optionalParameter = new TestOptionalParameter();
|
||||
|
||||
// constructing a basic class works
|
||||
assert empty != null;
|
||||
// initializers (and default initializers to 0/null) work
|
||||
assert fields.a == 0 && fields.b == 42;
|
||||
// constructor parameters override initializers
|
||||
assert constructor.a == 42;
|
||||
// basic arithmetics
|
||||
assert arithmetic.basic(1, 2, 3) == 2;
|
||||
// we have boolean logic as well
|
||||
assert arithmetic.logic(false, false, true) == true;
|
||||
// multiple classes within one file work. Referencing another classes fields/methods works.
|
||||
assert multipleClasses.a.a == 42;
|
||||
// self-referencing classes work.
|
||||
assert recursion.child.child.child.child.child.value == 5;
|
||||
// self-referencing methods work.
|
||||
assert recursion.fibonacci(15) == 610;
|
||||
assert loop.factorial(5) == 120;
|
||||
assert loop.weirdFor() == 5;
|
||||
// methods with the same name but different parameters work
|
||||
assert overload.MethodOverload() == 42;
|
||||
assert overload.MethodOverload(15) == 42 + 15;
|
||||
// constructor overloading works, too.
|
||||
assert (new TestConstructorOverload()).a == 42;
|
||||
assert (new TestConstructorOverload(12)).a == 12;
|
||||
// intentionally dodgy expressions work
|
||||
assert malicious.assignNegativeIncrement(42) == -42;
|
||||
assert malicious.tripleAddition(1, 2, 3) == 6;
|
||||
for(int i = 0; i < 3; i++)
|
||||
{
|
||||
assert malicious.cursedFormatting(i) == i;
|
||||
}
|
||||
// other syntactic sugar
|
||||
assert shenanigance.testAssignment() == 5;
|
||||
assert shenanigance.divEqual() == 234_343_000 / 4;
|
||||
assert shenanigance.testIf(5);
|
||||
// optional parameters
|
||||
assert optionalParameter.oneOptional() == 1;
|
||||
assert optionalParameter.oneOptional(2) == 2;
|
||||
assert optionalParameter.normalAndOptional(1) == 6;
|
||||
assert optionalParameter.normalAndOptional(1, 0) == 4;
|
||||
}
|
||||
}
|
||||
11
Test/JavaSources/TestArithmetic.java
Normal file
11
Test/JavaSources/TestArithmetic.java
Normal file
@@ -0,0 +1,11 @@
|
||||
public class TestArithmetic {
|
||||
public int basic(int a, int b, int c)
|
||||
{
|
||||
return a + b - c * a / b % c;
|
||||
}
|
||||
|
||||
public boolean logic(boolean a, boolean b, boolean c)
|
||||
{
|
||||
return !a && (c || b);
|
||||
}
|
||||
}
|
||||
9
Test/JavaSources/TestConstructor.java
Normal file
9
Test/JavaSources/TestConstructor.java
Normal file
@@ -0,0 +1,9 @@
|
||||
public class TestConstructor
|
||||
{
|
||||
public int a = -1;
|
||||
|
||||
public TestConstructor(int initial_value)
|
||||
{
|
||||
a = initial_value;
|
||||
}
|
||||
}
|
||||
12
Test/JavaSources/TestConstructorOverload.java
Normal file
12
Test/JavaSources/TestConstructorOverload.java
Normal file
@@ -0,0 +1,12 @@
|
||||
public class TestConstructorOverload {
|
||||
|
||||
public int a = 42;
|
||||
|
||||
TestConstructorOverload() {
|
||||
// nothing here, so a will assume the default value 42.
|
||||
}
|
||||
|
||||
TestConstructorOverload(int a) {
|
||||
this.a = a;
|
||||
}
|
||||
}
|
||||
4
Test/JavaSources/TestEmpty.java
Normal file
4
Test/JavaSources/TestEmpty.java
Normal file
@@ -0,0 +1,4 @@
|
||||
public class TestEmpty
|
||||
{
|
||||
|
||||
}
|
||||
5
Test/JavaSources/TestFields.java
Normal file
5
Test/JavaSources/TestFields.java
Normal file
@@ -0,0 +1,5 @@
|
||||
public class TestFields
|
||||
{
|
||||
public int a;
|
||||
public int b = 42;
|
||||
}
|
||||
19
Test/JavaSources/TestLoop.java
Normal file
19
Test/JavaSources/TestLoop.java
Normal file
@@ -0,0 +1,19 @@
|
||||
public class TestLoop {
|
||||
public int factorial(int n)
|
||||
{
|
||||
int tally = 1;
|
||||
for(int i = 1; i <= n; i++)
|
||||
{
|
||||
tally *= i;
|
||||
}
|
||||
|
||||
return tally;
|
||||
}
|
||||
|
||||
int weirdFor() {
|
||||
int k = 0;
|
||||
for (; k < 5; k++) {
|
||||
}
|
||||
return k;
|
||||
}
|
||||
}
|
||||
41
Test/JavaSources/TestMalicious.java
Normal file
41
Test/JavaSources/TestMalicious.java
Normal file
@@ -0,0 +1,41 @@
|
||||
public class TestMalicious {
|
||||
public int assignNegativeIncrement(int n)
|
||||
{
|
||||
return n=-++n+1;
|
||||
}
|
||||
|
||||
public int tripleAddition(int a, int b, int c)
|
||||
{
|
||||
return a+++b+++c++;
|
||||
}
|
||||
|
||||
public int cursedFormatting(int n)
|
||||
{
|
||||
if
|
||||
|
||||
|
||||
(n == 0)
|
||||
|
||||
{
|
||||
|
||||
return ((((0))));
|
||||
}
|
||||
|
||||
else
|
||||
|
||||
|
||||
if(n ==
|
||||
|
||||
1)
|
||||
{
|
||||
return
|
||||
|
||||
|
||||
1;
|
||||
}else {
|
||||
return
|
||||
2
|
||||
;
|
||||
}
|
||||
}
|
||||
}
|
||||
10
Test/JavaSources/TestMethodOverload.java
Normal file
10
Test/JavaSources/TestMethodOverload.java
Normal file
@@ -0,0 +1,10 @@
|
||||
public class TestMethodOverload {
|
||||
|
||||
public int MethodOverload() {
|
||||
return 42;
|
||||
}
|
||||
|
||||
public int MethodOverload(int a) {
|
||||
return 42 + a;
|
||||
}
|
||||
}
|
||||
9
Test/JavaSources/TestMultipleClasses.java
Normal file
9
Test/JavaSources/TestMultipleClasses.java
Normal file
@@ -0,0 +1,9 @@
|
||||
public class TestMultipleClasses
|
||||
{
|
||||
public AnotherTestClass a = new AnotherTestClass();
|
||||
}
|
||||
|
||||
class AnotherTestClass
|
||||
{
|
||||
public int a = 42;
|
||||
}
|
||||
10
Test/JavaSources/TestOptionalParameter.java
Normal file
10
Test/JavaSources/TestOptionalParameter.java
Normal file
@@ -0,0 +1,10 @@
|
||||
class TestOptionalParameter {
|
||||
|
||||
int oneOptional(int p = 1) {
|
||||
return p;
|
||||
}
|
||||
|
||||
int normalAndOptional(int a, int b = 2, int c = 3) {
|
||||
return a + b + c;
|
||||
}
|
||||
}
|
||||
34
Test/JavaSources/TestRecursion.java
Normal file
34
Test/JavaSources/TestRecursion.java
Normal file
@@ -0,0 +1,34 @@
|
||||
public class TestRecursion {
|
||||
|
||||
public int value = 0;
|
||||
public TestRecursion child = null;
|
||||
|
||||
public TestRecursion(int n)
|
||||
{
|
||||
this.value = n;
|
||||
|
||||
if(n > 0)
|
||||
{
|
||||
child = new TestRecursion(n - 1);
|
||||
}
|
||||
}
|
||||
|
||||
public int fibonacci(int n)
|
||||
{
|
||||
if(n < 2)
|
||||
{
|
||||
return n;
|
||||
}
|
||||
else
|
||||
{
|
||||
return fibonacci(n - 1) + this.fibonacci(n - 2);
|
||||
}
|
||||
}
|
||||
|
||||
public int ackermann(int m, int n)
|
||||
{
|
||||
if (m == 0) return n + 1;
|
||||
if (n == 0) return ackermann(m - 1, 1);
|
||||
return ackermann(m - 1, ackermann(m, n - 1));
|
||||
}
|
||||
}
|
||||
25
Test/JavaSources/TestShenanigance.java
Normal file
25
Test/JavaSources/TestShenanigance.java
Normal file
@@ -0,0 +1,25 @@
|
||||
class TestShenanigance {
|
||||
|
||||
int testAssignment() {
|
||||
int x = 1;
|
||||
int y = x = 5;
|
||||
return y;
|
||||
}
|
||||
|
||||
int divEqual() {
|
||||
int x = 234_343_000;
|
||||
x /= 4;
|
||||
return x;
|
||||
}
|
||||
|
||||
boolean testIf(int x) {
|
||||
if (true && x < 8) {
|
||||
char f = 'c';
|
||||
return f > x ;
|
||||
}
|
||||
ifn't {
|
||||
return false;
|
||||
}
|
||||
}
|
||||
|
||||
}
|
||||
15
Test/JavaSources/TestSingleton.java
Normal file
15
Test/JavaSources/TestSingleton.java
Normal file
@@ -0,0 +1,15 @@
|
||||
public class TestSingleton {
|
||||
|
||||
TestSingleton instance;
|
||||
|
||||
TestSingleton() {
|
||||
}
|
||||
|
||||
public TestSingleton getInstance() {
|
||||
if (instance == null) {
|
||||
instance = new TestSingleton();
|
||||
}
|
||||
return instance;
|
||||
}
|
||||
|
||||
}
|
||||
@@ -1,69 +0,0 @@
|
||||
module TestByteCodeGenerator where
|
||||
|
||||
import Test.HUnit
|
||||
import ByteCode.ClassFile.Generator
|
||||
import ByteCode.ClassFile
|
||||
import ByteCode.Constants
|
||||
import Ast
|
||||
|
||||
nakedClass = Class "Testklasse" [] []
|
||||
expectedClass = ClassFile {
|
||||
constantPool = [
|
||||
ClassInfo 4,
|
||||
MethodRefInfo 1 3,
|
||||
NameAndTypeInfo 5 6,
|
||||
Utf8Info "java/lang/Object",
|
||||
Utf8Info "<init>",
|
||||
Utf8Info "()V",
|
||||
Utf8Info "Code",
|
||||
ClassInfo 9,
|
||||
Utf8Info "Testklasse"
|
||||
],
|
||||
accessFlags = accessPublic,
|
||||
thisClass = 8,
|
||||
superClass = 1,
|
||||
fields = [],
|
||||
methods = [],
|
||||
attributes = []
|
||||
}
|
||||
|
||||
classWithFields = Class "Testklasse" [] [VariableDeclaration "int" "testvariable" Nothing]
|
||||
expectedClassWithFields = ClassFile {
|
||||
constantPool = [
|
||||
ClassInfo 4,
|
||||
MethodRefInfo 1 3,
|
||||
NameAndTypeInfo 5 6,
|
||||
Utf8Info "java/lang/Object",
|
||||
Utf8Info "<init>",
|
||||
Utf8Info "()V",
|
||||
Utf8Info "Code",
|
||||
ClassInfo 9,
|
||||
Utf8Info "Testklasse",
|
||||
FieldRefInfo (fromIntegral 8) (fromIntegral 11),
|
||||
NameAndTypeInfo (fromIntegral 12) (fromIntegral 13),
|
||||
Utf8Info "testvariable",
|
||||
Utf8Info "I"
|
||||
],
|
||||
accessFlags = accessPublic,
|
||||
thisClass = 8,
|
||||
superClass = 1,
|
||||
fields = [
|
||||
MemberInfo {
|
||||
memberAccessFlags = accessPublic,
|
||||
memberNameIndex = 12,
|
||||
memberDescriptorIndex = 13,
|
||||
memberAttributes = []
|
||||
}
|
||||
],
|
||||
methods = [],
|
||||
attributes = []
|
||||
}
|
||||
|
||||
|
||||
testBasicConstantPool = TestCase $ assertEqual "basic constant pool" expectedClass $ classBuilder nakedClass emptyClassFile
|
||||
testFields = TestCase $ assertEqual "fields in constant pool" expectedClassWithFields $ classBuilder classWithFields emptyClassFile
|
||||
|
||||
tests = TestList [
|
||||
TestLabel "Basic constant pool" testBasicConstantPool,
|
||||
TestLabel "Fields constant pool" testFields
|
||||
]
|
||||
@@ -4,14 +4,46 @@ import Test.HUnit
|
||||
import Parser.Lexer
|
||||
|
||||
|
||||
testCommentSomething = TestCase $ assertEqual "scan /*Something*/" [Comment "/*Something*/"] $ alexScanTokens "/*Something*/"
|
||||
testEmptyComment = TestCase $ assertEqual "scan /*x*/" [Comment "/**/"] $ alexScanTokens "/**/"
|
||||
testLineComment = TestCase $ assertEqual "scan // comment" [Comment "// comment"] $ alexScanTokens "// comment"
|
||||
emptyTokenList :: [Token]
|
||||
emptyTokenList = []
|
||||
testCommentSomething = TestCase $ assertEqual "scan '/*Something*/'" emptyTokenList $ alexScanTokens "/*Something*/"
|
||||
testEmptyComment = TestCase $ assertEqual "scan '/*x*/'" emptyTokenList $ alexScanTokens "/**/"
|
||||
testLineComment = TestCase $ assertEqual "scan '// comment'" emptyTokenList $ alexScanTokens "// comment"
|
||||
testLineCommentEnds = TestCase $ assertEqual "scan '// com\\n'" emptyTokenList $ alexScanTokens "// com\n"
|
||||
|
||||
testIdentifier = TestCase $ assertEqual "scan 'identifier'" [IDENTIFIER "identifier"] $ alexScanTokens "identifier"
|
||||
testShortIdentifier = TestCase $ assertEqual "scan 'i'" [IDENTIFIER "i"] $ alexScanTokens "i"
|
||||
testIdentifierWithNumber = TestCase $ assertEqual "scan 'i2'" [IDENTIFIER "i2"] $ alexScanTokens "i2"
|
||||
|
||||
testKeywordBreak = TestCase $ assertEqual "scan 'break'" [BREAK] $ alexScanTokens "break"
|
||||
testKeywordInt = TestCase $ assertEqual "scan 'int'" [INT] $ alexScanTokens "int"
|
||||
|
||||
testIntLiteral = TestCase $ assertEqual "scan '234'" [INTEGERLITERAL 234] $ alexScanTokens "234"
|
||||
testIntLiteral2 = TestCase $ assertEqual "scan '54_2'" [INTEGERLITERAL 542] $ alexScanTokens "54_2"
|
||||
|
||||
testCharLiteral = TestCase $ assertEqual "scan ''f''" [CHARLITERAL 'f'] $ alexScanTokens "'f'"
|
||||
|
||||
testBoolLiteralTrue = TestCase $ assertEqual "scan 'true'" [BOOLLITERAL True] $ alexScanTokens "true"
|
||||
testBoolLiteralFalse = TestCase $ assertEqual "scan 'false'" [BOOLLITERAL False] $ alexScanTokens "false"
|
||||
|
||||
testLBrace = TestCase $ assertEqual "scan '('" [LBRACE] $ alexScanTokens "("
|
||||
testAnd = TestCase $ assertEqual "scan '&&'" [AND] $ alexScanTokens "&&"
|
||||
|
||||
tests = TestList [
|
||||
TestLabel "TestCommentSomething" testCommentSomething,
|
||||
TestLabel "TestEmptyComment" testEmptyComment,
|
||||
TestLabel "TestLineComment" testLineComment
|
||||
TestLabel "TestLineComment" testLineComment,
|
||||
TestLabel "TestLineCommentEnds" testLineCommentEnds,
|
||||
TestLabel "TestIdentifier" testIdentifier,
|
||||
TestLabel "TestShortIdentifier" testShortIdentifier,
|
||||
TestLabel "TestIdentifierWithNumber" testIdentifierWithNumber,
|
||||
TestLabel "TestKeywordBreak" testKeywordBreak,
|
||||
TestLabel "TestKeywordInt" testKeywordInt,
|
||||
TestLabel "TestIntLiteral" testIntLiteral,
|
||||
TestLabel "TestIntLiteral2" testIntLiteral2,
|
||||
TestLabel "TestCharLiteral" testCharLiteral,
|
||||
TestLabel "TestBoolLiteralTrue" testBoolLiteralTrue,
|
||||
TestLabel "TestBoolLiteralFalse" testBoolLiteralFalse,
|
||||
TestLabel "TestLBrace" testLBrace,
|
||||
TestLabel "TestAnd" testAnd
|
||||
]
|
||||
352
Test/TestParser.hs
Normal file
352
Test/TestParser.hs
Normal file
@@ -0,0 +1,352 @@
|
||||
module TestParser(tests) where
|
||||
|
||||
import Test.HUnit
|
||||
import Parser.Lexer
|
||||
import Parser.JavaParser
|
||||
import Ast
|
||||
|
||||
|
||||
testSingleEmptyClass = TestCase $
|
||||
assertEqual "expect single empty class hello" [Class "Hello" [] [] []] $
|
||||
parse [CLASS, IDENTIFIER "Hello", LBRACKET, RBRACKET]
|
||||
testTwoEmptyClasses = TestCase $
|
||||
assertEqual "expect two empty classes" [Class "Class1" [] [] [], Class "Class2" [] [] []] $
|
||||
parse [CLASS,IDENTIFIER "Class1",LBRACKET,RBRACKET,CLASS,IDENTIFIER "Class2",LBRACKET,RBRACKET]
|
||||
testBooleanField = TestCase $
|
||||
assertEqual "expect class with boolean field" [Class "WithBool" [] [] [VariableDeclaration "boolean" "value" Nothing]] $
|
||||
parse [CLASS,IDENTIFIER "WithBool",LBRACKET,BOOLEAN,IDENTIFIER "value",SEMICOLON,RBRACKET]
|
||||
testIntField = TestCase $
|
||||
assertEqual "expect class with int field" [Class "WithInt" [] [] [VariableDeclaration "int" "value" Nothing]] $
|
||||
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" [ConstructorDeclaration "WithConstructor" [] (Block [])] [] []] $
|
||||
parse [CLASS,IDENTIFIER "WithConstructor",LBRACKET,IDENTIFIER "WithConstructor",LBRACE,RBRACE,LBRACKET,RBRACKET,RBRACKET]
|
||||
testConstructorWithParams = TestCase $
|
||||
assertEqual "expect constructor with params" [Class "WithParams" [ConstructorDeclaration "WithParams" [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" [ConstructorDeclaration "WithConstructor" [] (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]
|
||||
|
||||
testExpresssionExternalMethodCall = TestCase $
|
||||
assertEqual "expect method call on sub" (StatementExpressionExpression (MethodCall (Reference "Obj") "foo" [])) $
|
||||
parseExpression [IDENTIFIER "Obj",DOT,IDENTIFIER "foo",LBRACE,RBRACE]
|
||||
testExpressionAssignWithThis = TestCase $
|
||||
assertEqual "expect assignment on Field" (StatementExpressionExpression (Assignment (BinaryOperation NameResolution (Reference "this") (Reference "x")) (Reference "y"))) $
|
||||
parseExpression [THIS,DOT,IDENTIFIER "x",ASSIGN,IDENTIFIER "y"]
|
||||
|
||||
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]
|
||||
|
||||
testForLoop = TestCase $
|
||||
assertEqual "expect for loop" [Block [
|
||||
LocalVariableDeclaration (VariableDeclaration "int" "i" (Just (IntegerLiteral 0))),
|
||||
While (BinaryOperation CompareLessThan (Reference "i") (IntegerLiteral 3)) (Block [Block [], StatementExpressionStatement (PostIncrement (Reference "i"))])
|
||||
]] $
|
||||
parseStatement [FOR,LBRACE,INT,IDENTIFIER "i",ASSIGN,INTEGERLITERAL 0,SEMICOLON,IDENTIFIER "i",LESS,INTEGERLITERAL 3,SEMICOLON,IDENTIFIER "i",INCREMENT,RBRACE,LBRACKET,RBRACKET]
|
||||
testForLoopExpressionlistInInit = TestCase $
|
||||
assertEqual "expect expressionlist in init part of for loop" [Block [
|
||||
StatementExpressionStatement (PostIncrement (Reference "i")),
|
||||
While (BinaryOperation CompareLessThan (Reference "i") (IntegerLiteral 3)) (Block [Block [], StatementExpressionStatement (PostIncrement (Reference "i"))])
|
||||
]] $
|
||||
parseStatement [FOR,LBRACE,IDENTIFIER "i",INCREMENT,SEMICOLON,IDENTIFIER "i",LESS,INTEGERLITERAL 3,SEMICOLON,IDENTIFIER "i",INCREMENT,RBRACE,LBRACKET,RBRACKET]
|
||||
testForLoopMultipleUpdateExpressions = TestCase $
|
||||
assertEqual "expect for loop with multiple update statements" [Block [
|
||||
LocalVariableDeclaration (VariableDeclaration "int" "i" (Just (IntegerLiteral 0))),
|
||||
While (BinaryOperation CompareLessThan (Reference "i") (IntegerLiteral 3)) (Block [Block [], StatementExpressionStatement (PostIncrement (Reference "i")), StatementExpressionStatement (PostIncrement (Reference "k"))])
|
||||
]] $
|
||||
parseStatement [FOR,LBRACE,INT,IDENTIFIER "i",ASSIGN,INTEGERLITERAL 0,SEMICOLON,IDENTIFIER "i",LESS,INTEGERLITERAL 3,SEMICOLON,IDENTIFIER "i",INCREMENT,COMMA,IDENTIFIER "k",INCREMENT,RBRACE,LBRACKET,RBRACKET]
|
||||
testForLoopEmptyFirstPart = TestCase $
|
||||
assertEqual "expect for loop with empty init part" [Block [
|
||||
While (BinaryOperation CompareLessThan (Reference "i") (IntegerLiteral 3)) (Block [Block [], StatementExpressionStatement (PostIncrement (Reference "i"))])
|
||||
]] $
|
||||
parseStatement [FOR,LBRACE,SEMICOLON,IDENTIFIER "i",LESS,INTEGERLITERAL 3,SEMICOLON,IDENTIFIER "i",INCREMENT,RBRACE,LBRACKET,RBRACKET]
|
||||
testForLoopEmtpySecondPart = TestCase $
|
||||
assertEqual "expect for loop with empty expresion part" [Block [
|
||||
While (BooleanLiteral True) (Block [Block [], StatementExpressionStatement (PostIncrement (Reference "i"))])
|
||||
]] $
|
||||
parseStatement [FOR,LBRACE,SEMICOLON,SEMICOLON,IDENTIFIER "i",INCREMENT,RBRACE,LBRACKET,RBRACKET]
|
||||
testForLoopEmtpy = TestCase $
|
||||
assertEqual "expect empty for loop" [Block [While (BooleanLiteral True) (Block [Block []])]] $
|
||||
parseStatement [FOR,LBRACE,SEMICOLON,SEMICOLON,RBRACE,LBRACKET,RBRACKET]
|
||||
|
||||
|
||||
|
||||
|
||||
tests = TestList [
|
||||
testSingleEmptyClass,
|
||||
testTwoEmptyClasses,
|
||||
testBooleanField,
|
||||
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,
|
||||
testExpresssionExternalMethodCall,
|
||||
testExpressionAssignWithThis,
|
||||
testStatementIfThen,
|
||||
testStatementIfThenElse,
|
||||
testStatementWhile,
|
||||
testStatementAssign,
|
||||
testStatementMethodCallNoParams,
|
||||
testStatementConstructorCall,
|
||||
testStatementConstructorCallWithArgs,
|
||||
testStatementPreIncrement,
|
||||
testForLoop,
|
||||
testForLoopExpressionlistInInit,
|
||||
testForLoopMultipleUpdateExpressions,
|
||||
testForLoopEmptyFirstPart,
|
||||
testForLoopEmtpySecondPart,
|
||||
testForLoopEmtpy
|
||||
]
|
||||
@@ -2,10 +2,11 @@ module Main where
|
||||
|
||||
import Test.HUnit
|
||||
import TestLexer
|
||||
import TestByteCodeGenerator
|
||||
import TestParser
|
||||
|
||||
otherTest = TestCase $ assertEqual "math" (4+3) 7
|
||||
|
||||
tests = TestList [TestLabel "TestLexer" TestLexer.tests, TestLabel "mathTest" otherTest, TestLabel "bytecodeTest" TestByteCodeGenerator.tests]
|
||||
tests = TestList [
|
||||
TestLabel "TestLexer" TestLexer.tests,
|
||||
TestLabel "TestParser" TestParser.tests
|
||||
]
|
||||
|
||||
main = do runTestTTAndExit Main.tests
|
||||
107
doc/bytecode.tex
Normal file
107
doc/bytecode.tex
Normal file
@@ -0,0 +1,107 @@
|
||||
\section{Bytecodegenerierung}
|
||||
Die Bytecodegenerierung ist letztendlich eine zweistufige Transformation:
|
||||
|
||||
\vspace{20px}
|
||||
\texttt{Getypter AST -> [ClassFile] -> [[Word8]]}
|
||||
\vspace{20px}
|
||||
|
||||
Vom AST, der bereits den Typcheck durchlaufen hat, wird zunächst eine Abbildung in die einzelnen ClassFiles vorgenommen.
|
||||
Diese ClassFiles werden anschließend in deren Byte-Repräsentation serialisiert.
|
||||
|
||||
\subsection{Codegenerierung}
|
||||
Für die erste der beiden Transformationen (\texttt{Getypter AST -> [ClassFile]}) werden die Konzepte der ``Builder'' und ``Assembler'' eingeführt.
|
||||
Sie sind wie folgt definiert:
|
||||
|
||||
\vspace{20px}
|
||||
\begin{lstlisting}[language=haskell]
|
||||
type ClassFileBuilder a = a -> ClassFile -> ClassFile
|
||||
type Assembler a = ([ConstantInfo], [Operation], [String]) -> a
|
||||
-> ([ConstantInfo], [Operation], [String])
|
||||
\end{lstlisting}
|
||||
\vspace{20px}
|
||||
|
||||
Die Idee hinter beiden ist, dass sie jeweils zwei Inputs haben, wobei der Rückgabewert immer den gleichen Typ hat wie einer der Inputs.
|
||||
Das erlaubt es, eine Faltung durchzuführen. Ein ClassFileBuilder z.B bekommt als ersten Parameter den AST,
|
||||
und als zweiten Parameter (und Rückgabewert) eine ClassFile. Soll nun eine Klasse gebaut werden,
|
||||
wird der ClassFileBuilder mit dem AST und einer leeren ClassFile aufgerufen.
|
||||
Der Zustand dieser anfangs leeren ClassFile wird durch alle folgenden Builder/Assembler durchgeschleift, was es erlaubt,
|
||||
nach und nach kleinere Transformationen auf sie anzuwenden. Der Nutzer ruft beispielsweise die Funktion \texttt{classBuilder} auf.
|
||||
Diese wendet nach und nach folgende Transformationen an:
|
||||
|
||||
\vspace{20px}
|
||||
\begin{enumerate}
|
||||
\item Allen Konstruktoren werden Initialisierer aller Felder hinzugefügt
|
||||
\item Für jedes Feld der Klasse wird ein Eintrag im Konstantenpool \& der Classfile erstellt
|
||||
\item Für jede Methode wird ein Eintrag im Konstantenpool \& der Classfile erstellt
|
||||
\item Allen Methoden wird der zugehörige Bytecode erstellt und zugewiesen
|
||||
\item Allen Konstruktoren wird der zugehörige Bytecode erstellt und zugewiesen
|
||||
\end{enumerate}
|
||||
\vspace{20px}
|
||||
|
||||
Die Unterteilung von Deklaration der Methoden/Konstruktoren und Bytecodeerzeugung ist deswegen notwendig,
|
||||
weil der Code einer Methode auch eine andere, erst nachher deklarierte Methode aufrufen kann.
|
||||
Nach dem Hinzufügen der Deklarationen sind alle Methoden/Konstruktoren der Klasse bekannt.
|
||||
Wie oben beschrieben wird auch hier der Zustand über alle Faltungen mitgenommen.
|
||||
Jeder Schritt hat Zugriff auf alle Daten, die aus dem vorherigen Schritt bleiben. Sukzessive wird eine korrekte ClassFile aufgebaut.
|
||||
Besonders interessant sind hierbei die beiden letzten Schritte. Dort wird das Verhalten jeder einzelnen Methode/Konstruktor in Bytecode übersetzt.
|
||||
In diesem Schritt werden zusätzlich zu den \texttt{Buildern} noch die \texttt{Assembler} verwendet (Definition siehe oben.).
|
||||
Die Assembler funktionieren ähnlich wie die Builder, arbeiten allerdings nicht auf einer ClassFile, sondern auf dem Inhalt einer Methode;
|
||||
Sie verarbeiten jeweils ein Tupel der Form:
|
||||
|
||||
\vspace{20px}
|
||||
\texttt{([ConstantInfo], [Operation], [String])}
|
||||
\vspace{20px}
|
||||
|
||||
Dieses repräsentiert:
|
||||
|
||||
\vspace{20px}
|
||||
\texttt{(Konstantenpool, Bytecode, Lokale Variablen)}
|
||||
\vspace{20px}
|
||||
|
||||
In der Praxis werden meist nur Bytecode und Konstanten hinzugefügt. Prinzipiell können Assembler auch Code/Konstanten entfernen oder modifizieren.
|
||||
Als Beispiel dient hier der Assembler \texttt{assembleExpression}:
|
||||
|
||||
\vspace{20px}
|
||||
\begin{lstlisting}[language=haskell]
|
||||
assembleExpression (constants, ops, lvars) (TypedExpression _ NullLiteral)
|
||||
= (constants, ops ++ [Opaconst_null], lvars)
|
||||
\end{lstlisting}
|
||||
\vspace{20px}
|
||||
|
||||
Hier werden die Konstanten und lokalen Variablen des Inputs nicht berührt, dem Bytecode wird lediglich die Operation \texttt{aconst\_null} hinzugefügt.
|
||||
Damit ist das Verhalten des gematchten Inputs - eines Nullliterals - abgebildet.
|
||||
Die Assembler rufen sich teilweise rekursiv selbst auf, da ja auch der AST verschachteltes Verhalten abbilden kann.
|
||||
Der Startpunkt für die Assembly einer Methode ist der Builder \texttt{methodAssembler}. Dieser entspricht Schritt 3 in der obigen Übersicht.
|
||||
|
||||
\subsection{Serialisierung}
|
||||
Damit Bytecode generiert werden kann, braucht es Strukturen, die die Daten halten, die letztendlich serialisiert werden.
|
||||
Die JVM erwartet den kompilierten Code in handliche Pakete verpackt.
|
||||
Die Struktur dieser Pakete ist \href{https://docs.oracle.com/javase/specs/jvms/se7/html/jvms-4.html}{hier dokumentiert}.
|
||||
Jede Struktur, die in dieser übergreifenden Class File vorkommt, haben wir in Haskell abgebildet.
|
||||
Es gibt z.B die Struktur "ClassFile", die wiederum weitere Strukturen wie z.B Informationen über Felder oder Methoden der Klasse beinhaltet.
|
||||
Alle diese Strukturen implementieren folgende TypeClass:
|
||||
|
||||
\vspace{20px}
|
||||
\begin{lstlisting}[language=haskell]
|
||||
class Serializable a where
|
||||
serialize :: a -> [Word8]
|
||||
\end{lstlisting}
|
||||
\vspace{20px}
|
||||
|
||||
Hier ist ein Beispiel anhand der Serialisierung der einzelnen Operationen:
|
||||
|
||||
\vspace{20px}
|
||||
\begin{lstlisting}[language=haskell]
|
||||
instance Serializable Operation where
|
||||
serialize Opiadd = [0x60]
|
||||
serialize Opisub = [0x64]
|
||||
serialize Opimul = [0x68]
|
||||
...
|
||||
serialize (Opgetfield index) = 0xB4 : unpackWord16 index
|
||||
\end{lstlisting}
|
||||
\vspace{20px}
|
||||
|
||||
Die Struktur ClassFile ruft für deren Kinder rekursiv diese \texttt{serialize} Funktion auf und konkateniert die Ergebnisse.
|
||||
Am Ende bleibt eine flache Word8-Liste übrig, die Serialisierung ist damit abgeschlossen.
|
||||
Da der Typecheck sicherstellt, dass alle referenzierten Methoden/Felder gültig sind,
|
||||
kann die Übersetzung der einzelnen Klassen voneinander unabhängig geschehen.
|
||||
BIN
doc/documentation.pdf
Normal file
BIN
doc/documentation.pdf
Normal file
Binary file not shown.
34
doc/documentation.tex
Normal file
34
doc/documentation.tex
Normal file
@@ -0,0 +1,34 @@
|
||||
\documentclass[12pt, parskip=half, headheight=12pt, BCOR=8mm, footheight=16pt]{extarticle}
|
||||
|
||||
% General document formatting
|
||||
\usepackage[margin=1.0in]{geometry}
|
||||
\usepackage[parfill]{parskip}
|
||||
\usepackage[utf8]{inputenc}
|
||||
\usepackage[german]{babel}
|
||||
\usepackage{enumitem}
|
||||
\usepackage{listings}
|
||||
\usepackage{hyperref}
|
||||
|
||||
\renewcommand\descriptionlabel[1]{$\bullet$ \textbf{#1}}
|
||||
\hypersetup{
|
||||
colorlinks=true,
|
||||
linkcolor=blue,
|
||||
filecolor=magenta,
|
||||
urlcolor=cyan,
|
||||
}
|
||||
\let\clearpage\relax
|
||||
|
||||
\begin{document}
|
||||
|
||||
\include{features}
|
||||
\newpage
|
||||
\include{parser}
|
||||
\newpage
|
||||
\include{typecheck}
|
||||
\newpage
|
||||
\include{bytecode}
|
||||
\newpage
|
||||
\include{whodunit}
|
||||
\newpage
|
||||
|
||||
\end{document}
|
||||
34
doc/features.tex
Normal file
34
doc/features.tex
Normal file
@@ -0,0 +1,34 @@
|
||||
\section{Sprach-Features}
|
||||
\begin{itemize}
|
||||
\item Klassen
|
||||
\item Felder
|
||||
\item Methoden (mit Parametern)
|
||||
\item Konstruktoren (mit Parametern)
|
||||
\item Standardkonstruktoren
|
||||
\item Lokale Variablen
|
||||
\item Zuweisungen (Feld- und lokale Variablen)
|
||||
\item Arithmetik (\texttt{+, -, *, /, \%,} Klammern, Korrekte Operations-Präzedenz)
|
||||
\item Arithmetische Zuweisungen (\texttt{+=, -=, *=, /=, \%=, \&=, |=, \^{}=})
|
||||
\item Vergleichsoperationen (\texttt{<, >, <=, >=, ==, !=})
|
||||
\item Boolsche Operationen (\texttt{||, \&\&})
|
||||
\item Unäre Operationen (\texttt{-, ~})
|
||||
\item Binar-Operationen (\texttt{\&, |, \^})
|
||||
\item Pre/Post-Inkrement \& Dekrement
|
||||
\item Kontrollflussstrukturen:
|
||||
\begin{itemize}
|
||||
\item If/Else
|
||||
\item While
|
||||
\item For
|
||||
\item Return (mit/ohne Rückgabewert)
|
||||
\end{itemize}
|
||||
\item Default-Werte für alle Klassenfelder
|
||||
\item Mehrere Klassen in einer Datei
|
||||
\item Implizites \texttt{this}
|
||||
\item Beliebig verschachtelte Namensketten
|
||||
\item Beliebige Deklarationsreihenfolge
|
||||
\item Literale für Integer, Characters, Booleans
|
||||
\item Platzhalter/Separatoren in Integerliteralen (z.B. \texttt{1\_000\_000})
|
||||
\item Deklaration und Zuweisung in einer Anweisung
|
||||
\item Beliebig verschachtelte Blöcke
|
||||
\item Überladung von Methoden \& Konstruktoren
|
||||
\end{itemize}
|
||||
1
doc/generate.sh
Normal file
1
doc/generate.sh
Normal file
@@ -0,0 +1 @@
|
||||
pdflatex documentation.tex
|
||||
65
doc/parser.tex
Normal file
65
doc/parser.tex
Normal file
@@ -0,0 +1,65 @@
|
||||
\section{Lexer \& Parser}
|
||||
\subsection{Lexer}
|
||||
|
||||
Der Lexer wurde mit dem Alex tool implementiert. Dieser ist dafür zuständig den langen String in einzelne Tokens umzuwandeln. In der Alex Datei gibt es für jedes Token einen regulären Ausdruck. Bei den meisten Tokens ist das einfach das Schlüsselwort. Etwas komplexer waren Identifier, Integerliterale Strings und Chars. Für die Definition wurde sich eng an die offizielle Java Language Specification gehalten. Es ist beispielsweise auch möglich Unterstriche in Integerliterale einzubauen (Bsp.: \verb|234_343_000|) Es sind fast alle Schlüsselwörter von Java im Lexer implementiert, auch wenn nicht alle davon vom Parser geparst werden können. Whitespace und Kommentare werden direkt ignoriert und verworfen. Für Charliterale und Integerliterale gibt es auch spezielle Fehlermeldungen. Die meisten Tokens haben nur die Information, zu welchem Keyword sie gehören. Eine Ausnahme bilden der Identifier und die Literale. Für den Identifier wird noch der Name gespeichert und für die Literale der entsprechende Wert. Mit der Funktion alexScanTokens kann dann ein beliebiger String in Tokens umgewandelt werden.
|
||||
|
||||
Die komplexeren Tokens haben Unittests, welche mit dem Testframework HUnit geschrieben wurden. Es gibt Tests für Kommentare, Identifier, Literale und ein paar weitere Tokens.
|
||||
|
||||
\subsection{Parser}
|
||||
|
||||
Der Parser wurde mit dem Happy tool implementiert. Er baut aus einer Liste von Tokens einen ungetypten AST. Wir haben bereits eine Grammatik bekommen und mussten diese noch in den AST umwandeln.
|
||||
|
||||
Um den Parser aufzubauen wurde zuerst ein Großteil der Grammatik auskommentiert und Stück für Stück wurden die Umwandlungen hinzugefügt. Immer wenn ein neues Feature umgesetzt wurde, wurde dafür ein weiterer Unit Test geschrieben. Es gibt also für jede komplexe Ableitungsregel mindestens einen Unittest.
|
||||
|
||||
\subsubsection{Klassenaufbau}
|
||||
Als erstes wurden leere Konstruktoren Methoden und Felder umgesetzt. Da in Java Konstruktoren, Methoden und Felder durcheinander vorkommen können geben die Ableitungsregeln einen Datentyp namens `MemberDeclaration` zurück. Die classbodydeclarations Regel baut dann einen 3-Tupel mit einer Liste aus Konstruktoren, einer aus Methoden und einer aus Feldern. Über pattern matching werden diese Listen dann erweitert und in der darüberliegenden Regel schließlich extrahiert.
|
||||
|
||||
Bei folgender Klasse:
|
||||
\begin{lstlisting}[language=Java]
|
||||
class TestClass {
|
||||
int field;
|
||||
|
||||
TestClass() {}
|
||||
|
||||
void foo() {}
|
||||
}
|
||||
\end{lstlisting}
|
||||
würde die Regel folgendes Tupel zurückgeben:
|
||||
\begin{lstlisting}[language=Haskell]
|
||||
(
|
||||
[ConstructorDeclaration "TestClass" [] (Block [])],
|
||||
[MethodDeclaration "void" "foo" [] (Block [])],
|
||||
[VariableDeclaration "int" "field" Nothing]
|
||||
)
|
||||
\end{lstlisting}
|
||||
und folgende Klasse wird erstellt
|
||||
\begin{lstlisting}[language=Haskell]
|
||||
Class "TestClass"
|
||||
[ConstructorDeclaration "TestClass" [] (Block [])]
|
||||
[MethodDeclaration "void" "foo" [] (Block [])]
|
||||
[VariableDeclaration "int" "field" Nothing]
|
||||
\end{lstlisting}
|
||||
Das Nothing ist in diesem Fall ein Platzhalter für eine Zuweisung, da unser Compiler auch Zuweisung bei der Felddeklaration unterstützt.
|
||||
|
||||
In Java ist es möglich mehrere Variablen in einer Zeile zu deklarieren (Bsp.: `int x, y;`). Beim Parsen ergiebt sich dann die Schwierigkeit, dass man in dem Moment, wo man die Variable parst nicht weiß welchen Datentyp diese hat. Aus diesem Grund gibt es den Datentyp Declarator, welcher nur den Identifier und eventuell eine Zuweisung enthält. In den darüberliegenden Regeln fielddeclaration und localvariabledeclaration wird dann die Typinformation hinzugefügt mithilfe der Funktion convertDeclarator.
|
||||
|
||||
\subsubsection{Syntactic Sugar}
|
||||
Für die Zuweisung wird auch die Kombination mit Rechenoperatoren unterstützt. Das ganze ist durch Syntactic Sugar im Parser umgesetzt. Wenn es einen Zuweisungsoperator gibt, dann wird der Ausdruck in eine Zuweisung und Rechnung aufgeteilt. Bsp.: \verb|x += 3;| wird umgewandelt in \verb|x = x + 3|.
|
||||
|
||||
For-Schleifen wurde auch rein im Parser durch Syntactic Sugar implementiert. Eine For-Schleife wird dabei in eine While-Schleife umgewandelt. Dafür wird zuerst ein Block erstellt, sodass die deklarierten Variablen auch nur für den Bereich der Schleife gültig sind. Die Bedingung der For-Schleife kann in die While-Schleife übernommen werden. Innerhalb der While-Schleife folgen zuerst die Statements, die im Block der For-Schleife waren und danach die Update-Statements.
|
||||
|
||||
\begin{lstlisting}[language=Java]
|
||||
for (int i = 0; i < 9; i++) {
|
||||
foo();
|
||||
}
|
||||
\end{lstlisting}
|
||||
wird umgewandelt in:
|
||||
\begin{lstlisting}[language=Java]
|
||||
{
|
||||
int i = 0;
|
||||
while (i < 9) {
|
||||
foo();
|
||||
i++;
|
||||
}
|
||||
}
|
||||
\end{lstlisting}
|
||||
105
doc/typecheck.tex
Normal file
105
doc/typecheck.tex
Normal file
@@ -0,0 +1,105 @@
|
||||
\section{Typecheck}
|
||||
\subsection{Überblick \& Struktur}
|
||||
|
||||
Die Typprüfung beginnt mit der Funktion \texttt{typeCheckCompilationUnit}, die eine Kompilationseinheit als Eingabe erhält.
|
||||
Diese Kompilationseinheit besteht aus einer Liste von Klassen. Jede Klasse wird einzeln durch die Funktion \texttt{typeCheckClass} überprüft.
|
||||
Innerhalb dieser Funktion wird eine Symboltabelle erstellt, die den Namen der Klasse als Typ und \texttt{this} als Identifier enthält.
|
||||
Diese Symboltabelle wird verwendet, um Typinformationen nach dem Lokalitätsprinzip während der Typprüfung zugänglich zu machen und zu verwalten.
|
||||
Die Typprüfung einer Klasse umfasst die Überprüfung aller Konstruktoren, Methoden und Felder.
|
||||
Die Methode \texttt{typeCheckConstructorDeclaration} ist für die Typprüfung einzelner Konstruktordeklarationen verantwortlich,
|
||||
während \texttt{typeCheckMethodDeclaration} für die Typprüfung einzelner Methodendeklarationen zuständig ist.
|
||||
Beide Funktionen überprüfen die Parameter und den Rumpf der jeweiligen Konstruktoren bzw. Methoden.
|
||||
Der Rumpf wird durch rekursive Aufrufe von \texttt{typeCheckStatement} überprüft, die verschiedene Arten von Anweisungen wie If-Anweisungen,
|
||||
While-Schleifen, Rückgabeanweisungen und Blockanweisungen behandelt.
|
||||
|
||||
\subsection{Ablauf \& Symboltabellen}
|
||||
|
||||
Eine zentrale Komponente des Typecheckers ist die Symboltabelle ("symtab"), die Informationen über die Bezeichner und ihre zugehörigen Datentypen speichert.
|
||||
Die Symboltabelle wird kontinuierlich angepasst, während der Typechecker die verschiedenen Teile des Programms durchläuft.
|
||||
|
||||
\subsubsection{Anpassung der Symboltabelle}
|
||||
|
||||
\begin{description}
|
||||
\item[Klassenkontext] Beim Typcheck einer Klasse wird eine initiale Symboltabelle erstellt, die die \texttt{this}-Referenz enthält.
|
||||
Dies geschieht in der Funktion \texttt{typeCheckClass}.
|
||||
\item[Konstruktorkontext] Innerhalb eines Konstruktors wird die Symboltabelle um die Parameter des Konstruktors erweitert.
|
||||
Dies geschieht in \texttt{typeCheckConstructorDeclaration}. Der Rückgabetyp eines Konstruktors ist implizit \texttt{void},
|
||||
was überprüft wird, um sicherzustellen, dass kein Wert zurückgegeben wird.
|
||||
\item[Methodenkontext] Innerhalb einer Methode wird die Symboltabelle um die Parameter der Methode erweitert sowie den Rückgabetyp der Methode,
|
||||
um die einzelnen Returns dagegen zu prüfen. Dies geschieht in \texttt{typeCheckMethodDeclaration}.
|
||||
\item[Blockkontext] Bei der Überprüfung eines Blocks (\texttt{typeCheckStatement} für Block) wird die Symboltabelle für jede Anweisung
|
||||
innerhalb des Blocks aktualisiert. Lokale Variablen, die innerhalb des Blocks deklariert werden, werden zur Symboltabelle hinzugefügt.
|
||||
Das bedeutet, dass automatisch, sobald der Block zu Ende ist, alle dort deklarierten Variablen danach nicht mehr zugänglich sind.
|
||||
\end{description}
|
||||
|
||||
\subsubsection{Unterscheidung zwischen lokalen und Feldvariablen}
|
||||
|
||||
Bei der Typprüfung von Referenzen (\texttt{typeCheckExpression} für Reference) wird zuerst in der Symboltabelle nach dem Bezeichner gesucht.
|
||||
Sollte dieser gefunden werden, handelt es sich um eine lokale Variable. Wenn der Bezeichner nicht gefunden wird, wird angenommen,
|
||||
dass es sich um eine Feldvariable handelt. In diesem Fall wird die Klasse, zu der die \texttt{this}-Referenz gehört, durchsucht,
|
||||
um die Feldvariable zu finden. Dies ermöglicht die Unterscheidung zwischen lokalen Variablen und Feldvariablen.
|
||||
Dies ist auch nur möglich, da wir die Feldvariablen und Methoden nicht in die Symboltabelle gelegt haben und stattdessen nur die \texttt{this}-Referenz.
|
||||
|
||||
\subsection{Fehlerbehandlung}
|
||||
|
||||
Ein zentraler Aspekt des Typecheckers ist die Fehlerbehandlung. Bei Typinkonsistenzen oder ungültigen Operationen werden
|
||||
aussagekräftige Fehlermeldungen generiert. Beispiele für solche Fehlermeldungen sind:
|
||||
|
||||
\begin{description}
|
||||
\item[Typinkonsistenzen] Wenn der Rückgabetyp einer Methode nicht mit dem deklarierten Rückgabetyp übereinstimmt oder die Anzahl der Parameter nicht übereinstimmt.
|
||||
\item[Ungültige Operationen] Wenn eine arithmetische Operation auf inkompatiblen Typen durchgeführt wird.
|
||||
\item[Nicht gefundene Bezeichner] Wenn eine Referenz auf eine nicht definierte Variable verweist.
|
||||
\end{description}
|
||||
|
||||
Diese Fehlermeldungen helfen Entwicklern, die Ursachen von Typfehlern schnell zu identifizieren und zu beheben.
|
||||
Generell sind diese oftmals sehr spezifisch, was das Problem recht schnell identifizieren sollte.
|
||||
Z.B. falsche Reihenfolge / falsche Typen der Parameter beim Methodenaufruf sind direkt erkennbar.
|
||||
|
||||
\subsection{Typprüfung von Kontrollstrukturen und Blöcken}
|
||||
\subsubsection{If-Anweisungen}
|
||||
Bei der Typprüfung einer If-Anweisung (\texttt{typeCheckStatement} für If) wird zuerst der Typ der Bedingung überprüft, um sicherzustellen,
|
||||
dass es sich um einen booleschen Ausdruck handelt. Anschließend werden die Then- und Else-Zweige geprüft.
|
||||
Der Typ der If-Anweisung selbst wird durch die Vereinheitlichung der Typen der Then- und Else-Zweige bestimmt.
|
||||
Falls einer der Zweige keinen Rückgabewert hat, wird angenommen, dass der Rückgabewert \texttt{void} ist.
|
||||
Dies wurde so gelöst, um im Typchecker feststellen zu können, ob beide Zweige einen Return haben.
|
||||
Wenn nur einer der Zweige ein Return hat, wird im umliegenden Block ein weiteres benötigt, was durch den Typ \texttt{void} erzwungen wird.
|
||||
Dadurch weiß der Typchecker Bescheid.
|
||||
|
||||
\subsubsection{Block-Anweisungen}
|
||||
Die Typprüfung eines Blocks erfolgt in \texttt{typeCheckStatement} für Block.
|
||||
Jede Anweisung im Block wird nacheinander überprüft und die Symboltabelle wird entsprechend aktualisiert.
|
||||
Der Typ des Blocks wird durch die Vereinheitlichung der Typen aller Anweisungen im Block bestimmt.
|
||||
Wenn der Block keine Anweisungen hat, wird der Typ \texttt{void} angenommen.
|
||||
|
||||
\subsubsection{Rückgabeanweisungen}
|
||||
Die Typprüfung einer Rückgabeanweisung (\texttt{typeCheckStatement} für Return) überprüft,
|
||||
ob der Rückgabewert der Anweisung mit dem deklarierten Rückgabetyp der Methode übereinstimmt.
|
||||
Dafür wurde zu Beginn der Methodentypprüfung der Rückgabetyp der Methode in die Symboltabelle eingetragen. Wenn der Rückgabewert \texttt{null} ist,
|
||||
wird überprüft, ob der deklarierte Rückgabetyp ein Objekttyp ist. Dies stellt sicher, dass Methoden immer den korrekten Typ zurückgeben.
|
||||
Generell wird bei der Prüfung nach dem UpperBound geschaut und ebenfalls wird nachgeschaut, ob, wenn der Rückgabetyp \texttt{Object} ist,
|
||||
der Return-Wert auch eine tatsächlich existierende Klasse ist, indem in die Klassentabelle geschaut wird.
|
||||
|
||||
\subsubsection{Konstruktorüberladung und -prüfung}
|
||||
Die Typprüfung unterstützt Konstruktorüberladung. Bei der Typprüfung von Konstruktoraufrufen (\texttt{typeCheckStatementExpression}
|
||||
für \texttt{ConstructorCall}) wird überprüft, ob es mehrere Konstruktoren mit derselben Anzahl von Parametern gibt.
|
||||
Falls mehrere passende Konstruktoren gefunden werden, wird ein Fehler gemeldet.
|
||||
|
||||
\begin{description}
|
||||
\item[Parameterabgleich] Die Parameter eines Konstruktors werden gegen die Argumente des Aufrufs abgeglichen.
|
||||
Dies umfasst die Prüfung der Typen und, falls es sich um \texttt{null} handelt, die Überprüfung, ob der Parameter ein Objekttyp ist.
|
||||
\item[Fehlerbehandlung] Wenn kein passender Konstruktor gefunden wird, wird eine detaillierte Fehlermeldung generiert,
|
||||
die die erwarteten Signaturen und die tatsächlichen Argumenttypen anzeigt. Wenn mehrere passende Konstruktoren gefunden werden,
|
||||
wird ebenfalls ein Fehler gemeldet.
|
||||
\end{description}
|
||||
|
||||
\subsubsection{Methodenüberladung und -prüfung}
|
||||
Die Typprüfung unterstützt auch Methodenüberladung. Bei der Typprüfung von Methodenaufrufen (\texttt{typeCheckStatementExpression} für \texttt{MethodCall})
|
||||
wird überprüft, ob es mehrere Methoden mit demselben Namen, aber unterschiedlichen Parametertypen gibt.
|
||||
|
||||
\begin{description}
|
||||
\item[Parameterabgleich] Die Parameter einer Methode werden gegen die Argumente des Aufrufs abgeglichen.
|
||||
Dies umfasst die Prüfung der Typen und, falls es sich um \texttt{null} handelt, die Überprüfung, ob der Parameter ein Objekttyp ist.
|
||||
\item[Fehlerbehandlung] Wenn keine passende Methode gefunden wird, wird eine detaillierte Fehlermeldung generiert,
|
||||
die die erwarteten Signaturen und die tatsächlichen Argumenttypen anzeigt. Wenn mehrere passende Methoden gefunden werden,
|
||||
wird ebenfalls ein Fehler gemeldet.
|
||||
\end{description}
|
||||
19
doc/whodunit.tex
Normal file
19
doc/whodunit.tex
Normal file
@@ -0,0 +1,19 @@
|
||||
\section{Aufgabenverteilung}
|
||||
\begin{description}
|
||||
\item[Marvin Schlegel] Parser \& Lexer
|
||||
\item[Fabian Noll] Semantik- \& Typcheck
|
||||
\item[Christian Brier] Bytecodegenerierung
|
||||
\item[Matthias Raba] Bytecodegenerierung
|
||||
\end{description}
|
||||
\vspace{20px}
|
||||
|
||||
Marvin Schlegel und Fabian Noll haben ihre Teilaufgaben eigenständig bearbeitet.
|
||||
|
||||
Die Bytecodegenerierung wurde von Matthias Raba und Christian Brier im Stile des Pair Programmings zu zweit erarbeitet.
|
||||
Durch bisher gute Erfahrungen in vorherigen Projekten, sowie dem Interesse, alle Teile der Bytecodegenerierung zu sehen,
|
||||
wurde diese Programmierungsform als die Beste ausgewählt.
|
||||
|
||||
Während der Implementierungsphase wurde viel zwischen den 3 einzelnen Teams kommuniziert.
|
||||
Wurden Fehler in einer der Komponenten gefunden, wurden die jeweiligen Verantwortlichen informiert um das Problem zu beheben.
|
||||
Jedes der Teams arbeitete auf einem eigenen Branch, die einzelnen Beiträge wurde regelmäßig auf dem master-Branch zusammengeführt.
|
||||
Insgesamt lief die Implementierungsphase wie geplant und ohne weitere Komplikationen ab.
|
||||
@@ -1,31 +1,44 @@
|
||||
name: MiniJavaCompiler
|
||||
version: 0.1.0.0
|
||||
build-type: Simple
|
||||
cabal-version: >= 1.10
|
||||
Synopsis: A compiler for a minimal version of Java with watered down syntax.
|
||||
|
||||
executable compiler
|
||||
main-is: Main.hs
|
||||
build-depends: base,
|
||||
array,
|
||||
HUnit,
|
||||
utf8-string,
|
||||
bytestring
|
||||
default-language: Haskell2010
|
||||
hs-source-dirs: src,
|
||||
src/ByteCode,
|
||||
src/ByteCode/ClassFile
|
||||
build-tool-depends: alex:alex, happy:happy
|
||||
other-modules: Ast, Example, Typecheck, ByteCode.ByteUtil, ByteCode.ClassFile, ByteCode.ClassFile.Generator, ByteCode.Constants, ByteCode.Operations
|
||||
|
||||
test-suite tests
|
||||
type: exitcode-stdio-1.0
|
||||
main-is: TestSuite.hs
|
||||
hs-source-dirs: src,Test
|
||||
build-depends: base,
|
||||
array,
|
||||
HUnit,
|
||||
utf8-string,
|
||||
bytestring
|
||||
build-tool-depends: alex:alex, happy:happy
|
||||
other-modules: TestLexer, TestByteCodeGenerator
|
||||
name: MiniJavaCompiler
|
||||
version: 0.1.0.0
|
||||
build-type: Simple
|
||||
cabal-version: >= 1.10
|
||||
Synopsis: A compiler for a minimal version of Java with watered down syntax.
|
||||
|
||||
executable compiler
|
||||
main-is: Main.hs
|
||||
build-depends: base,
|
||||
array,
|
||||
HUnit,
|
||||
utf8-string,
|
||||
bytestring,
|
||||
filepath
|
||||
default-language: Haskell2010
|
||||
hs-source-dirs: src
|
||||
build-tool-depends: alex:alex, happy:happy
|
||||
other-modules: Parser.Lexer,
|
||||
Parser.JavaParser,
|
||||
Ast,
|
||||
Typecheck,
|
||||
ByteCode.Util,
|
||||
ByteCode.ByteUtil,
|
||||
ByteCode.ClassFile,
|
||||
ByteCode.Assembler,
|
||||
ByteCode.Builder,
|
||||
ByteCode.Constants
|
||||
|
||||
test-suite tests
|
||||
type: exitcode-stdio-1.0
|
||||
main-is: TestSuite.hs
|
||||
hs-source-dirs: src,Test
|
||||
build-depends: base,
|
||||
array,
|
||||
HUnit,
|
||||
utf8-string,
|
||||
bytestring,
|
||||
filepath
|
||||
build-tool-depends: alex:alex, happy:happy
|
||||
other-modules: Parser.Lexer,
|
||||
Parser.JavaParser,
|
||||
Ast,
|
||||
TestLexer,
|
||||
TestParser
|
||||
|
||||
35
src/Ast.hs
35
src/Ast.hs
@@ -1,13 +1,15 @@
|
||||
module Ast where
|
||||
|
||||
type CompilationUnit = [Class]
|
||||
type CompilationUnit = [Class]
|
||||
type DataType = String
|
||||
type Identifier = String
|
||||
type Identifier = String
|
||||
type Modifier = String
|
||||
|
||||
data ParameterDeclaration = ParameterDeclaration DataType Identifier deriving (Show)
|
||||
data VariableDeclaration = VariableDeclaration DataType Identifier (Maybe Expression) deriving (Show)
|
||||
data Class = Class DataType [MethodDeclaration] [VariableDeclaration] deriving (Show)
|
||||
data MethodDeclaration = MethodDeclaration DataType Identifier [ParameterDeclaration] Statement deriving (Show)
|
||||
data ParameterDeclaration = ParameterDeclaration DataType Identifier deriving (Show, Eq)
|
||||
data VariableDeclaration = VariableDeclaration DataType Modifier Identifier (Maybe Expression) deriving (Show, Eq)
|
||||
data Class = Class DataType Modifier [ConstructorDeclaration] [MethodDeclaration] [VariableDeclaration] deriving (Show, Eq)
|
||||
data MethodDeclaration = MethodDeclaration DataType Modifier Identifier [ParameterDeclaration] Statement deriving (Show, Eq)
|
||||
data ConstructorDeclaration = ConstructorDeclaration Modifier Identifier [ParameterDeclaration] Statement deriving (Show, Eq)
|
||||
|
||||
data Statement
|
||||
= If Expression Statement (Maybe Statement)
|
||||
@@ -17,20 +19,25 @@ data Statement
|
||||
| Return (Maybe Expression)
|
||||
| StatementExpressionStatement StatementExpression
|
||||
| TypedStatement DataType Statement
|
||||
deriving (Show)
|
||||
deriving (Show, Eq)
|
||||
|
||||
data StatementExpression
|
||||
= Assignment Identifier Expression
|
||||
= Assignment Expression Expression
|
||||
| ConstructorCall DataType [Expression]
|
||||
| MethodCall Identifier [Expression]
|
||||
| MethodCall Expression Identifier [Expression]
|
||||
| PostIncrement Expression
|
||||
| PostDecrement Expression
|
||||
| PreIncrement Expression
|
||||
| PreDecrement Expression
|
||||
| TypedStatementExpression DataType StatementExpression
|
||||
deriving (Show)
|
||||
deriving (Show, Eq)
|
||||
|
||||
data BinaryOperator
|
||||
= Addition
|
||||
| Subtraction
|
||||
| Multiplication
|
||||
| Division
|
||||
| Modulo
|
||||
| BitwiseAnd
|
||||
| BitwiseOr
|
||||
| BitwiseXor
|
||||
@@ -43,12 +50,12 @@ data BinaryOperator
|
||||
| And
|
||||
| Or
|
||||
| NameResolution
|
||||
deriving (Show)
|
||||
deriving (Show, Eq)
|
||||
|
||||
data UnaryOperator
|
||||
= Not
|
||||
| Minus
|
||||
deriving (Show)
|
||||
deriving (Show, Eq)
|
||||
|
||||
data Expression
|
||||
= IntegerLiteral Int
|
||||
@@ -56,8 +63,10 @@ data Expression
|
||||
| BooleanLiteral Bool
|
||||
| NullLiteral
|
||||
| Reference Identifier
|
||||
| LocalVariable Identifier
|
||||
| FieldVariable Identifier
|
||||
| BinaryOperation BinaryOperator Expression Expression
|
||||
| UnaryOperation UnaryOperator Expression
|
||||
| StatementExpressionExpression StatementExpression
|
||||
| TypedExpression DataType Expression
|
||||
deriving (Show)
|
||||
deriving (Show, Eq)
|
||||
|
||||
275
src/ByteCode/Assembler.hs
Normal file
275
src/ByteCode/Assembler.hs
Normal file
@@ -0,0 +1,275 @@
|
||||
module ByteCode.Assembler where
|
||||
|
||||
import ByteCode.Constants
|
||||
import ByteCode.ClassFile (ClassFile (..), ConstantInfo (..), MemberInfo(..), Operation(..), Attribute(..), opcodeEncodingLength)
|
||||
import ByteCode.Util
|
||||
import Ast
|
||||
import Data.Char
|
||||
import Data.List
|
||||
import Data.Word
|
||||
|
||||
type Assembler a = ([ConstantInfo], [Operation], [String]) -> a -> ([ConstantInfo], [Operation], [String])
|
||||
|
||||
assembleExpression :: Assembler Expression
|
||||
assembleExpression (constants, ops, lvars) (TypedExpression _ (BinaryOperation op a b))
|
||||
| op `elem` [Addition, Subtraction, Multiplication, Division, Modulo, BitwiseAnd, BitwiseOr, BitwiseXor, And, Or] = let
|
||||
(aConstants, aOps, _) = assembleExpression (constants, ops, lvars) a
|
||||
(bConstants, bOps, _) = assembleExpression (aConstants, aOps, lvars) b
|
||||
in
|
||||
(bConstants, bOps ++ [binaryOperation op], lvars)
|
||||
| op `elem` [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 _ (BinaryOperation NameResolution (TypedExpression atype a) (TypedExpression btype (FieldVariable b)))) = let
|
||||
(fConstants, fieldIndex) = getFieldIndex constants (atype, b, datatypeDescriptor btype)
|
||||
(aConstants, aOps, _) = assembleExpression (fConstants, ops, lvars) (TypedExpression atype a)
|
||||
in
|
||||
(aConstants, aOps ++ [Opgetfield (fromIntegral fieldIndex)], lvars)
|
||||
|
||||
assembleExpression (constants, ops, lvars) (TypedExpression _ (CharacterLiteral literal)) =
|
||||
(constants, ops ++ [Opsipush (fromIntegral (ord literal))], lvars)
|
||||
|
||||
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 dtype (LocalVariable name))
|
||||
| name == "this" = (constants, ops ++ [Opaload 0], lvars)
|
||||
| otherwise = let
|
||||
localIndex = elemIndex 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 ("Unknown expression: " ++ show expr)
|
||||
|
||||
assembleNameChain :: Assembler Expression
|
||||
assembleNameChain input (TypedExpression _ (BinaryOperation NameResolution (TypedExpression atype a) (TypedExpression _ (FieldVariable _)))) =
|
||||
assembleExpression input (TypedExpression atype a)
|
||||
assembleNameChain input expr = assembleExpression input expr
|
||||
|
||||
|
||||
assembleStatementExpression :: Assembler StatementExpression
|
||||
assembleStatementExpression
|
||||
(constants, ops, lvars)
|
||||
(TypedStatementExpression _ (Assignment (TypedExpression dtype receiver) expr)) = let
|
||||
target = resolveNameChain (TypedExpression dtype receiver)
|
||||
in case target of
|
||||
(TypedExpression dtype (LocalVariable name)) -> let
|
||||
localIndex = elemIndex 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 [Opdup, Opistore (fromIntegral index)] else [Opastore (fromIntegral index)], lvars)
|
||||
Nothing -> error ("No such local variable found in local variable pool: " ++ name)
|
||||
(TypedExpression dtype (FieldVariable name)) -> let
|
||||
owner = resolveNameChainOwner (TypedExpression dtype receiver)
|
||||
in case owner of
|
||||
(TypedExpression otype _) -> let
|
||||
(constants_f, fieldIndex) = getFieldIndex constants (otype, name, datatypeDescriptor dtype)
|
||||
(constants_r, ops_r, _) = assembleNameChain (constants_f, ops, lvars) (TypedExpression dtype receiver)
|
||||
(constants_a, ops_a, _) = assembleExpression (constants_r, ops_r, lvars) expr
|
||||
in
|
||||
(constants_a, ops_a ++ [Opdup_x1, Opputfield (fromIntegral fieldIndex)], lvars)
|
||||
something_else -> error ("Expected TypedExpression, but got: " ++ show something_else)
|
||||
|
||||
assembleStatementExpression
|
||||
(constants, ops, lvars)
|
||||
(TypedStatementExpression _ (PreIncrement (TypedExpression dtype receiver))) = let
|
||||
target = resolveNameChain (TypedExpression dtype receiver)
|
||||
in case target of
|
||||
(TypedExpression dtype (LocalVariable name)) -> let
|
||||
localIndex = elemIndex name lvars
|
||||
expr = TypedExpression dtype (LocalVariable name)
|
||||
(exprConstants, exprOps, _) = assembleExpression (constants, ops, lvars) expr
|
||||
in case localIndex of
|
||||
Just index -> (exprConstants, exprOps ++ [Opsipush 1, Opiadd, Opdup, Opistore (fromIntegral index)], lvars)
|
||||
Nothing -> error ("No such local variable found in local variable pool: " ++ name)
|
||||
(TypedExpression dtype (FieldVariable name)) -> let
|
||||
owner = resolveNameChainOwner (TypedExpression dtype receiver)
|
||||
in case owner of
|
||||
(TypedExpression otype _) -> let
|
||||
(constants_f, fieldIndex) = getFieldIndex constants (otype, name, datatypeDescriptor dtype)
|
||||
(constants_r, ops_r, _) = assembleNameChain (constants_f, ops, lvars) (TypedExpression dtype receiver)
|
||||
in
|
||||
(constants_r, ops_r ++ [Opdup, Opgetfield (fromIntegral fieldIndex), Opsipush 1, Opiadd, Opdup_x1, Opputfield (fromIntegral fieldIndex)], lvars)
|
||||
something_else -> error ("Expected TypedExpression, but got: " ++ show something_else)
|
||||
|
||||
assembleStatementExpression
|
||||
(constants, ops, lvars)
|
||||
(TypedStatementExpression _ (PreDecrement (TypedExpression dtype receiver))) = let
|
||||
target = resolveNameChain (TypedExpression dtype receiver)
|
||||
in case target of
|
||||
(TypedExpression dtype (LocalVariable name)) -> let
|
||||
localIndex = elemIndex name lvars
|
||||
expr = TypedExpression dtype (LocalVariable name)
|
||||
(exprConstants, exprOps, _) = assembleExpression (constants, ops, lvars) expr
|
||||
in case localIndex of
|
||||
Just index -> (exprConstants, exprOps ++ [Opsipush 1, Opisub, Opdup, Opistore (fromIntegral index)], lvars)
|
||||
Nothing -> error ("No such local variable found in local variable pool: " ++ name)
|
||||
(TypedExpression dtype (FieldVariable name)) -> let
|
||||
owner = resolveNameChainOwner (TypedExpression dtype receiver)
|
||||
in case owner of
|
||||
(TypedExpression otype _) -> let
|
||||
(constants_f, fieldIndex) = getFieldIndex constants (otype, name, datatypeDescriptor dtype)
|
||||
(constants_r, ops_r, _) = assembleNameChain (constants_f, ops, lvars) (TypedExpression dtype receiver)
|
||||
in
|
||||
(constants_r, ops_r ++ [Opdup, Opgetfield (fromIntegral fieldIndex), Opsipush 1, Opisub, Opdup_x1, Opputfield (fromIntegral fieldIndex)], lvars)
|
||||
something_else -> error ("Expected TypedExpression, but got: " ++ show something_else)
|
||||
|
||||
assembleStatementExpression
|
||||
(constants, ops, lvars)
|
||||
(TypedStatementExpression _ (PostIncrement (TypedExpression dtype receiver))) = let
|
||||
target = resolveNameChain (TypedExpression dtype receiver)
|
||||
in case target of
|
||||
(TypedExpression dtype (LocalVariable name)) -> let
|
||||
localIndex = elemIndex name lvars
|
||||
expr = TypedExpression dtype (LocalVariable name)
|
||||
(exprConstants, exprOps, _) = assembleExpression (constants, ops, lvars) expr
|
||||
in case localIndex of
|
||||
Just index -> (exprConstants, exprOps ++ [Opdup, Opsipush 1, Opiadd, Opistore (fromIntegral index)], lvars)
|
||||
Nothing -> error ("No such local variable found in local variable pool: " ++ name)
|
||||
(TypedExpression dtype (FieldVariable name)) -> let
|
||||
owner = resolveNameChainOwner (TypedExpression dtype receiver)
|
||||
in case owner of
|
||||
(TypedExpression otype _) -> let
|
||||
(constants_f, fieldIndex) = getFieldIndex constants (otype, name, datatypeDescriptor dtype)
|
||||
(constants_r, ops_r, _) = assembleNameChain (constants_f, ops, lvars) (TypedExpression dtype receiver)
|
||||
in
|
||||
(constants_r, ops_r ++ [Opdup, Opgetfield (fromIntegral fieldIndex), Opdup_x1, Opsipush 1, Opiadd, Opputfield (fromIntegral fieldIndex)], lvars)
|
||||
something_else -> error ("Expected TypedExpression, but got: " ++ show something_else)
|
||||
|
||||
assembleStatementExpression
|
||||
(constants, ops, lvars)
|
||||
(TypedStatementExpression _ (PostDecrement (TypedExpression dtype receiver))) = let
|
||||
target = resolveNameChain (TypedExpression dtype receiver)
|
||||
in case target of
|
||||
(TypedExpression dtype (LocalVariable name)) -> let
|
||||
localIndex = elemIndex name lvars
|
||||
expr = TypedExpression dtype (LocalVariable name)
|
||||
(exprConstants, exprOps, _) = assembleExpression (constants, ops, lvars) expr
|
||||
in case localIndex of
|
||||
Just index -> (exprConstants, exprOps ++ [Opdup, Opsipush 1, Opisub, Opistore (fromIntegral index)], lvars)
|
||||
Nothing -> error ("No such local variable found in local variable pool: " ++ name)
|
||||
(TypedExpression dtype (FieldVariable name)) -> let
|
||||
owner = resolveNameChainOwner (TypedExpression dtype receiver)
|
||||
in case owner of
|
||||
(TypedExpression otype _) -> let
|
||||
(constants_f, fieldIndex) = getFieldIndex constants (otype, name, datatypeDescriptor dtype)
|
||||
(constants_r, ops_r, _) = assembleNameChain (constants_f, ops, lvars) (TypedExpression dtype receiver)
|
||||
in
|
||||
(constants_r, ops_r ++ [Opdup, Opgetfield (fromIntegral fieldIndex), Opdup_x1, Opsipush 1, Opisub, Opputfield (fromIntegral fieldIndex)], lvars)
|
||||
something_else -> error ("Expected TypedExpression, but got: " ++ show something_else)
|
||||
|
||||
assembleStatementExpression
|
||||
(constants, ops, lvars)
|
||||
(TypedStatementExpression rtype (MethodCall (TypedExpression otype receiver) name params)) = let
|
||||
(constants_r, ops_r, lvars_r) = assembleExpression (constants, ops, lvars) (TypedExpression otype receiver)
|
||||
(constants_p, ops_p, lvars_p) = foldl assembleExpression (constants_r, ops_r, lvars_r) params
|
||||
(constants_m, methodIndex) = getMethodIndex constants_p (otype, name, methodDescriptorFromParamlist params rtype)
|
||||
in
|
||||
(constants_m, ops_p ++ [Opinvokevirtual (fromIntegral methodIndex)], lvars_p)
|
||||
|
||||
assembleStatementExpression
|
||||
(constants, ops, lvars)
|
||||
(TypedStatementExpression rtype (ConstructorCall name params)) = let
|
||||
(constants_c, classIndex) = getClassIndex constants name
|
||||
(constants_p, ops_p, lvars_p) = foldl assembleExpression (constants_c, ops ++ [Opnew (fromIntegral classIndex), Opdup], lvars) params
|
||||
(constants_m, methodIndex) = getMethodIndex constants_p (name, "<init>", methodDescriptorFromParamlist params "void")
|
||||
in
|
||||
(constants_m, ops_p ++ [Opinvokespecial (fromIntegral methodIndex)], lvars_p)
|
||||
|
||||
|
||||
assembleStatement :: Assembler Statement
|
||||
assembleStatement (constants, ops, lvars) (TypedStatement stype (Return expr)) = case expr of
|
||||
Nothing -> (constants, ops ++ [Opreturn], lvars)
|
||||
Just expr -> let
|
||||
(expr_constants, expr_ops, _) = assembleExpression (constants, ops, lvars) expr
|
||||
in
|
||||
(expr_constants, expr_ops ++ [returnOperation stype], lvars)
|
||||
|
||||
assembleStatement (constants, ops, lvars) (TypedStatement _ (Block statements)) =
|
||||
foldl assembleStatement (constants, ops, lvars) statements
|
||||
|
||||
assembleStatement (constants, ops, lvars) (TypedStatement dtype (If expr if_stmt else_stmt)) = let
|
||||
(constants_cmp, ops_cmp, _) = assembleExpression (constants, [], lvars) expr
|
||||
(constants_ifa, ops_ifa, lvars_ifa) = assembleStatement (constants_cmp, [], lvars) if_stmt
|
||||
(constants_elsea, ops_elsea, _) = case else_stmt of
|
||||
Nothing -> (constants_ifa, [], lvars_ifa)
|
||||
Just stmt -> assembleStatement (constants_ifa, [], lvars_ifa) stmt
|
||||
-- +6 because we insert 2 gotos, one for if, one for else
|
||||
if_length = sum (map opcodeEncodingLength ops_ifa)
|
||||
-- +3 because we need to account for the goto in the if statement.
|
||||
else_length = sum (map opcodeEncodingLength ops_elsea)
|
||||
in case dtype of
|
||||
"void" -> (constants_ifa, ops ++ ops_cmp ++ [Opsipush 0, Opif_icmpeq (if_length + 6)] ++ ops_ifa ++ [Opgoto (else_length + 3)] ++ ops_elsea, lvars_ifa)
|
||||
_ -> (constants_ifa, ops ++ ops_cmp ++ [Opsipush 0, Opif_icmpeq (if_length + 3)] ++ ops_ifa ++ ops_elsea, lvars_ifa)
|
||||
|
||||
assembleStatement (constants, ops, lvars) (TypedStatement _ (While expr stmt)) = let
|
||||
(constants_cmp, ops_cmp, _) = assembleExpression (constants, [], lvars) expr
|
||||
(constants_stmta, ops_stmta, lvars_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_stmta)
|
||||
|
||||
assembleStatement (constants, ops, lvars) (TypedStatement _ (LocalVariableDeclaration (VariableDeclaration dtype name expr))) = let
|
||||
isPrimitive = elem dtype ["char", "boolean", "int"]
|
||||
(constants_init, ops_init, _) = case expr of
|
||||
Just exp -> assembleExpression (constants, ops, lvars) exp
|
||||
Nothing -> (constants, ops ++ if isPrimitive then [Opsipush 0] else [Opaconst_null], lvars)
|
||||
localIndex = fromIntegral (length lvars)
|
||||
storeLocal = if isPrimitive then [Opistore localIndex] else [Opastore localIndex]
|
||||
in
|
||||
(constants_init, ops_init ++ storeLocal, lvars ++ [name])
|
||||
|
||||
assembleStatement (constants, ops, lvars) (TypedStatement _ (StatementExpressionStatement expr)) = let
|
||||
(constants_e, ops_e, lvars_e) = assembleStatementExpression (constants, ops, lvars) expr
|
||||
in
|
||||
(constants_e, ops_e ++ [Oppop], lvars_e)
|
||||
|
||||
assembleStatement _ stmt = error ("Unknown statement: " ++ show stmt)
|
||||
|
||||
|
||||
assembleMethod :: Assembler MethodDeclaration
|
||||
assembleMethod (constants, ops, lvars) (MethodDeclaration returntype name _ (TypedStatement _ (Block statements)))
|
||||
| name == "<init>" = let
|
||||
(constants_a, ops_a, lvars_a) = foldl assembleStatement (constants, ops, lvars) statements
|
||||
in
|
||||
(constants_a, [Opaload 0, Opinvokespecial 2] ++ ops_a ++ [Opreturn], lvars_a)
|
||||
| otherwise = case returntype of
|
||||
"void" -> let
|
||||
(constants_a, ops_a, lvars_a) = foldl assembleStatement (constants, ops, lvars) statements
|
||||
in
|
||||
(constants_a, ops_a ++ [Opreturn], lvars_a)
|
||||
_ -> foldl assembleStatement (constants, ops, lvars) statements
|
||||
assembleMethod _ (MethodDeclaration _ _ _ stmt) = error ("Typed block expected for method body, got: " ++ show stmt)
|
||||
128
src/ByteCode/Builder.hs
Normal file
128
src/ByteCode/Builder.hs
Normal file
@@ -0,0 +1,128 @@
|
||||
module ByteCode.Builder where
|
||||
|
||||
import ByteCode.Constants
|
||||
import ByteCode.ClassFile (ClassFile (..), ConstantInfo (..), MemberInfo(..), Operation(..), Attribute(..), opcodeEncodingLength)
|
||||
import ByteCode.Assembler
|
||||
import ByteCode.Util
|
||||
import Ast
|
||||
import Data.Char
|
||||
import Data.List
|
||||
import Data.Word
|
||||
|
||||
type ClassFileBuilder a = a -> ClassFile -> ClassFile
|
||||
|
||||
fieldBuilder :: ClassFileBuilder VariableDeclaration
|
||||
fieldBuilder (VariableDeclaration datatype name _) input = let
|
||||
baseIndex = 1 + length (constantPool input)
|
||||
constants = [
|
||||
FieldRefInfo (fromIntegral (thisClass input)) (fromIntegral (baseIndex + 1)),
|
||||
NameAndTypeInfo (fromIntegral (baseIndex + 2)) (fromIntegral (baseIndex + 3)),
|
||||
Utf8Info name,
|
||||
Utf8Info (datatypeDescriptor datatype)
|
||||
]
|
||||
field = MemberInfo {
|
||||
memberAccessFlags = accessPublic,
|
||||
memberNameIndex = fromIntegral (baseIndex + 2),
|
||||
memberDescriptorIndex = fromIntegral (baseIndex + 3),
|
||||
memberAttributes = []
|
||||
}
|
||||
in
|
||||
input {
|
||||
constantPool = constantPool input ++ constants,
|
||||
fields = fields input ++ [field]
|
||||
}
|
||||
|
||||
|
||||
|
||||
methodBuilder :: ClassFileBuilder MethodDeclaration
|
||||
methodBuilder (MethodDeclaration returntype name parameters statement) input = let
|
||||
baseIndex = 1 + length (constantPool input)
|
||||
constants = [
|
||||
MethodRefInfo (fromIntegral (thisClass input)) (fromIntegral (baseIndex + 1)),
|
||||
NameAndTypeInfo (fromIntegral (baseIndex + 2)) (fromIntegral (baseIndex + 3)),
|
||||
Utf8Info name,
|
||||
Utf8Info (methodDescriptor (MethodDeclaration returntype name parameters (Block [])))
|
||||
]
|
||||
|
||||
method = MemberInfo {
|
||||
memberAccessFlags = accessPublic,
|
||||
memberNameIndex = fromIntegral (baseIndex + 2),
|
||||
memberDescriptorIndex = fromIntegral (baseIndex + 3),
|
||||
memberAttributes = []
|
||||
}
|
||||
in
|
||||
input {
|
||||
constantPool = constantPool input ++ constants,
|
||||
methods = methods input ++ [method]
|
||||
}
|
||||
|
||||
constructorBuilder :: ClassFileBuilder ConstructorDeclaration
|
||||
constructorBuilder (ConstructorDeclaration name parameters statement) = methodBuilder (MethodDeclaration "void" "<init>" parameters statement)
|
||||
|
||||
|
||||
methodAssembler :: ClassFileBuilder MethodDeclaration
|
||||
methodAssembler (MethodDeclaration returntype name parameters statement) input = let
|
||||
methodConstantIndex = findMethodIndex input (MethodDeclaration returntype name parameters statement)
|
||||
in case methodConstantIndex of
|
||||
Nothing -> error ("Cannot find method entry in method pool for method: " ++ name)
|
||||
Just index -> let
|
||||
declaration = MethodDeclaration returntype name parameters statement
|
||||
paramNames = "this" : [name | ParameterDeclaration _ name <- parameters]
|
||||
in case splitAt index (methods input) of
|
||||
(pre, []) -> input
|
||||
(pre, method : post) -> let
|
||||
(constants, bytecode, aParamNames) = assembleMethod (constantPool input, [], paramNames) declaration
|
||||
assembledMethod = method {
|
||||
memberAttributes = [
|
||||
CodeAttribute {
|
||||
attributeMaxStack = fromIntegral $ maxStackDepth constants bytecode,
|
||||
attributeMaxLocals = fromIntegral $ length aParamNames,
|
||||
attributeCode = bytecode
|
||||
}
|
||||
]
|
||||
}
|
||||
in
|
||||
input {
|
||||
constantPool = constants,
|
||||
methods = pre ++ (assembledMethod : post)
|
||||
}
|
||||
|
||||
constructorAssembler :: ClassFileBuilder ConstructorDeclaration
|
||||
constructorAssembler (ConstructorDeclaration name parameters statement) = methodAssembler (MethodDeclaration "void" "<init>" parameters statement)
|
||||
|
||||
|
||||
classBuilder :: ClassFileBuilder Class
|
||||
classBuilder (Class name constructors methods fields) _ = let
|
||||
baseConstants = [
|
||||
ClassInfo 4,
|
||||
MethodRefInfo 1 3,
|
||||
NameAndTypeInfo 5 6,
|
||||
Utf8Info "java/lang/Object",
|
||||
Utf8Info "<init>",
|
||||
Utf8Info "()V",
|
||||
Utf8Info "Code",
|
||||
ClassInfo 9,
|
||||
Utf8Info name
|
||||
]
|
||||
nakedClassFile = ClassFile {
|
||||
constantPool = baseConstants,
|
||||
accessFlags = accessPublic,
|
||||
thisClass = 8,
|
||||
superClass = 1,
|
||||
fields = [],
|
||||
methods = [],
|
||||
attributes = []
|
||||
}
|
||||
|
||||
-- for every constructor, prepend all initialization assignments for fields.
|
||||
constructorsWithInitializers = injectFieldInitializers name fields constructors
|
||||
|
||||
-- add fields, then method bodies, then constructor bodies to the classfile. After all referable names are known,
|
||||
-- assemble the methods and constructors into bytecode.
|
||||
fieldsAdded = foldr fieldBuilder nakedClassFile fields
|
||||
methodsAdded = foldr methodBuilder fieldsAdded methods
|
||||
constructorsAdded = foldr constructorBuilder methodsAdded constructorsWithInitializers
|
||||
methodsAssembled = foldr methodAssembler constructorsAdded methods
|
||||
constructorsAssembled = foldr constructorAssembler methodsAssembled constructorsWithInitializers
|
||||
in
|
||||
constructorsAssembled
|
||||
@@ -1,7 +1,6 @@
|
||||
module ByteCode.ByteUtil(unpackWord16, unpackWord32) where
|
||||
module ByteCode.ByteUtil where
|
||||
|
||||
import Data.Word ( Word8, Word16, Word32 )
|
||||
import Data.Int
|
||||
import Data.Bits
|
||||
|
||||
unpackWord16 :: Word16 -> [Word8]
|
||||
|
||||
@@ -1,18 +1,11 @@
|
||||
module ByteCode.ClassFile(
|
||||
ConstantInfo(..),
|
||||
Attribute(..),
|
||||
MemberInfo(..),
|
||||
ClassFile(..),
|
||||
serialize,
|
||||
emptyClassFile
|
||||
) where
|
||||
module ByteCode.ClassFile where
|
||||
|
||||
import Data.Word
|
||||
import Data.Int
|
||||
import Data.ByteString (unpack)
|
||||
import Data.ByteString.UTF8 (fromString)
|
||||
import ByteCode.ByteUtil
|
||||
import ByteCode.Constants
|
||||
import ByteCode.ByteUtil
|
||||
|
||||
data ConstantInfo = ClassInfo Word16
|
||||
| FieldRefInfo Word16 Word16
|
||||
@@ -22,39 +15,40 @@ data ConstantInfo = ClassInfo Word16
|
||||
| Utf8Info [Char]
|
||||
deriving (Show, Eq)
|
||||
|
||||
|
||||
{-
|
||||
Code_attribute {
|
||||
u2 attribute_name_index;
|
||||
u4 attribute_length;
|
||||
u2 max_stack;
|
||||
u2 max_locals;
|
||||
u4 code_length;
|
||||
u1 code[code_length];
|
||||
u2 exception_table_length;
|
||||
{ u2 start_pc;
|
||||
u2 end_pc;
|
||||
u2 handler_pc;
|
||||
u2 catch_type;
|
||||
} exception_table[exception_table_length];
|
||||
u2 attributes_count;
|
||||
attribute_info attributes[attributes_count];
|
||||
-}
|
||||
--data Attribute = Attribute Word16 [Word8] deriving (Show, Eq)
|
||||
data Operation = Iadd
|
||||
| Isub
|
||||
| Imul
|
||||
| Idiv
|
||||
| Return
|
||||
| IReturn
|
||||
| Sipush Word16
|
||||
| Ldc_w Word16
|
||||
| Aload Word16
|
||||
| Iload Word16
|
||||
| Astore Word16
|
||||
| Istore Word16
|
||||
| Putfield Word16
|
||||
| GetField Word16
|
||||
data Operation = Opiadd
|
||||
| Opisub
|
||||
| Opimul
|
||||
| Opidiv
|
||||
| Opirem
|
||||
| Opiand
|
||||
| Opior
|
||||
| Opixor
|
||||
| Opineg
|
||||
| Opdup
|
||||
| Opnew Word16
|
||||
| Opif_icmplt Word16
|
||||
| Opif_icmple Word16
|
||||
| Opif_icmpgt Word16
|
||||
| Opif_icmpge Word16
|
||||
| Opif_icmpeq Word16
|
||||
| Opif_icmpne Word16
|
||||
| Opaconst_null
|
||||
| Opreturn
|
||||
| Opireturn
|
||||
| Opareturn
|
||||
| Opdup_x1
|
||||
| Oppop
|
||||
| Opinvokespecial Word16
|
||||
| Opinvokevirtual Word16
|
||||
| Opgoto Word16
|
||||
| Opsipush Word16
|
||||
| Opldc_w Word16
|
||||
| Opaload Word16
|
||||
| Opiload Word16
|
||||
| Opastore Word16
|
||||
| Opistore Word16
|
||||
| Opputfield Word16
|
||||
| Opgetfield Word16
|
||||
deriving (Show, Eq)
|
||||
|
||||
|
||||
@@ -93,6 +87,17 @@ emptyClassFile = ClassFile {
|
||||
attributes = []
|
||||
}
|
||||
|
||||
className :: ClassFile -> String
|
||||
className classFile = let
|
||||
classInfo = constantPool classFile !! fromIntegral (thisClass classFile)
|
||||
in case classInfo of
|
||||
Utf8Info className -> className
|
||||
unexpected_element -> error ("expected Utf8Info but got: " ++ show unexpected_element)
|
||||
|
||||
|
||||
opcodeEncodingLength :: Operation -> Word16
|
||||
opcodeEncodingLength op = fromIntegral . length . serialize $ op
|
||||
|
||||
class Serializable a where
|
||||
serialize :: a -> [Word8]
|
||||
|
||||
@@ -114,29 +119,49 @@ instance Serializable MemberInfo where
|
||||
++ concatMap serialize (memberAttributes member)
|
||||
|
||||
instance Serializable Operation where
|
||||
serialize Iadd = [0x60]
|
||||
serialize Isub = [0x64]
|
||||
serialize Imul = [0x68]
|
||||
serialize Idiv = [0x6C]
|
||||
serialize Return = [0xB1]
|
||||
serialize IReturn = [0xAC]
|
||||
serialize (Sipush index) = 0x11 : unpackWord16 index
|
||||
serialize (Ldc_w index) = 0x13 : unpackWord16 index
|
||||
serialize (Aload index) = [0xC4, 0x19] ++ unpackWord16 index
|
||||
serialize (Iload index) = [0xC4, 0x15] ++ unpackWord16 index
|
||||
serialize (Astore index) = [0xC4, 0x3A] ++ unpackWord16 index
|
||||
serialize (Istore index) = [0xC4, 0x36] ++ unpackWord16 index
|
||||
serialize (Putfield index) = 0xB5 : unpackWord16 index
|
||||
serialize (GetField index) = 0xB4 : unpackWord16 index
|
||||
serialize Opiadd = [0x60]
|
||||
serialize Opisub = [0x64]
|
||||
serialize Opimul = [0x68]
|
||||
serialize Opidiv = [0x6C]
|
||||
serialize Opirem = [0x70]
|
||||
serialize Opiand = [0x7E]
|
||||
serialize Opior = [0x80]
|
||||
serialize Opixor = [0x82]
|
||||
serialize Opineg = [0x74]
|
||||
serialize Opdup = [0x59]
|
||||
serialize (Opnew index) = 0xBB : unpackWord16 index
|
||||
serialize (Opif_icmplt branch) = 0xA1 : unpackWord16 branch
|
||||
serialize (Opif_icmple branch) = 0xA4 : unpackWord16 branch
|
||||
serialize (Opif_icmpgt branch) = 0xA3 : unpackWord16 branch
|
||||
serialize (Opif_icmpge branch) = 0xA2 : unpackWord16 branch
|
||||
serialize (Opif_icmpeq branch) = 0x9F : unpackWord16 branch
|
||||
serialize (Opif_icmpne branch) = 0xA0 : unpackWord16 branch
|
||||
serialize Opaconst_null = [0x01]
|
||||
serialize Opreturn = [0xB1]
|
||||
serialize Opireturn = [0xAC]
|
||||
serialize Opareturn = [0xB0]
|
||||
serialize Opdup_x1 = [0x5A]
|
||||
serialize Oppop = [0x57]
|
||||
serialize (Opinvokespecial index) = 0xB7 : unpackWord16 index
|
||||
serialize (Opinvokevirtual index) = 0xB6 : unpackWord16 index
|
||||
serialize (Opgoto index) = 0xA7 : unpackWord16 index
|
||||
serialize (Opsipush index) = 0x11 : unpackWord16 index
|
||||
serialize (Opldc_w index) = 0x13 : unpackWord16 index
|
||||
serialize (Opaload index) = [0xC4, 0x19] ++ unpackWord16 index
|
||||
serialize (Opiload index) = [0xC4, 0x15] ++ unpackWord16 index
|
||||
serialize (Opastore index) = [0xC4, 0x3A] ++ unpackWord16 index
|
||||
serialize (Opistore index) = [0xC4, 0x36] ++ unpackWord16 index
|
||||
serialize (Opputfield index) = 0xB5 : unpackWord16 index
|
||||
serialize (Opgetfield index) = 0xB4 : unpackWord16 index
|
||||
|
||||
instance Serializable Attribute where
|
||||
serialize (CodeAttribute { attributeMaxStack = maxStack,
|
||||
attributeMaxLocals = maxLocals,
|
||||
attributeCode = code }) = let
|
||||
assembledCode = concat (map serialize code)
|
||||
assembledCode = concatMap serialize code
|
||||
in
|
||||
unpackWord16 7 -- attribute_name_index
|
||||
++ unpackWord32 (12 + (fromIntegral (length assembledCode))) -- attribute_length
|
||||
++ unpackWord32 (12 + fromIntegral (length assembledCode)) -- attribute_length
|
||||
++ unpackWord16 maxStack -- max_stack
|
||||
++ unpackWord16 maxLocals -- max_locals
|
||||
++ unpackWord32 (fromIntegral (length assembledCode)) -- code_length
|
||||
@@ -145,7 +170,7 @@ instance Serializable Attribute where
|
||||
++ unpackWord16 0 -- attributes_count
|
||||
|
||||
instance Serializable ClassFile where
|
||||
serialize classfile = unpackWord32 0xC0FEBABE -- magic
|
||||
serialize classfile = unpackWord32 0xCAFEBABE -- magic
|
||||
++ unpackWord16 0 -- minor version
|
||||
++ unpackWord16 49 -- major version
|
||||
++ unpackWord16 (fromIntegral (1 + length (constantPool classfile))) -- constant pool count
|
||||
|
||||
@@ -1,66 +0,0 @@
|
||||
module ByteCode.ClassFile.Generator(
|
||||
classBuilder
|
||||
) where
|
||||
|
||||
import ByteCode.Constants
|
||||
import ByteCode.ClassFile (ClassFile (..), ConstantInfo (..), MemberInfo(..))
|
||||
import Ast
|
||||
import ByteCode.Operations
|
||||
|
||||
|
||||
type ClassFileBuilder a = a -> ClassFile -> ClassFile
|
||||
|
||||
|
||||
datatypeDescriptor :: String -> String
|
||||
datatypeDescriptor "int" = "I"
|
||||
datatypeDescriptor "char" = "C"
|
||||
datatypeDescriptor "boolean" = "B"
|
||||
datatypeDescriptor x = "L" ++ x
|
||||
|
||||
|
||||
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 fieldBuilder nakedClassFile fields
|
||||
|
||||
|
||||
|
||||
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]
|
||||
}
|
||||
@@ -1,3 +0,0 @@
|
||||
module ByteCode.Operations where
|
||||
data Operation = Iadd
|
||||
-- |
|
||||
291
src/ByteCode/Util.hs
Normal file
291
src/ByteCode/Util.hs
Normal file
@@ -0,0 +1,291 @@
|
||||
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
|
||||
{-# HLINT ignore "Use lambda-case" #-}
|
||||
module ByteCode.Util where
|
||||
|
||||
import Data.Int
|
||||
import Ast
|
||||
import ByteCode.ClassFile
|
||||
import Data.List
|
||||
import Data.Maybe (mapMaybe, isJust)
|
||||
import Data.Word (Word8, Word16, Word32)
|
||||
|
||||
-- walks the name resolution chain. returns the innermost Just LocalVariable/FieldVariable or Nothing.
|
||||
resolveNameChain :: Expression -> Expression
|
||||
resolveNameChain (TypedExpression _ (BinaryOperation NameResolution a b)) = resolveNameChain b
|
||||
resolveNameChain (TypedExpression dtype (LocalVariable name)) = TypedExpression dtype (LocalVariable name)
|
||||
resolveNameChain (TypedExpression dtype (FieldVariable name)) = TypedExpression dtype (FieldVariable name)
|
||||
resolveNameChain invalidExpression = error ("expected a NameResolution or Local/Field Variable but got: " ++ show invalidExpression)
|
||||
|
||||
-- walks the name resolution chain. returns the second-to-last item of the namechain.
|
||||
resolveNameChainOwner :: Expression -> Expression
|
||||
resolveNameChainOwner (TypedExpression _ (BinaryOperation NameResolution a (TypedExpression dtype (FieldVariable name)))) = a
|
||||
resolveNameChainOwner (TypedExpression _ (BinaryOperation NameResolution a b)) = resolveNameChain b
|
||||
resolveNameChainOwner invalidExpression = error ("expected a NameResolution or Local/Field Variable but got: " ++ show invalidExpression)
|
||||
|
||||
methodDescriptor :: MethodDeclaration -> String
|
||||
methodDescriptor (MethodDeclaration returntype _ parameters _) = let
|
||||
parameter_types = [datatype | ParameterDeclaration datatype _ <- parameters]
|
||||
in
|
||||
"("
|
||||
++ concatMap datatypeDescriptor parameter_types
|
||||
++ ")"
|
||||
++ datatypeDescriptor returntype
|
||||
|
||||
methodDescriptorFromParamlist :: [Expression] -> String -> String
|
||||
methodDescriptorFromParamlist parameters returntype = let
|
||||
parameter_types = [datatype | TypedExpression datatype _ <- parameters]
|
||||
in
|
||||
"("
|
||||
++ concatMap datatypeDescriptor parameter_types
|
||||
++ ")"
|
||||
++ datatypeDescriptor returntype
|
||||
|
||||
-- recursively parses a given type signature into a list of parameter types and the method return type.
|
||||
-- As an initial parameter, you can supply ([], "void").
|
||||
parseMethodType :: ([String], String) -> String -> ([String], String)
|
||||
parseMethodType (params, returnType) ('(' : descriptor) = parseMethodType (params, returnType) descriptor
|
||||
parseMethodType (params, returnType) ('I' : descriptor) = parseMethodType (params ++ ["I"], returnType) descriptor
|
||||
parseMethodType (params, returnType) ('C' : descriptor) = parseMethodType (params ++ ["C"], returnType) descriptor
|
||||
parseMethodType (params, returnType) ('Z' : descriptor) = parseMethodType (params ++ ["Z"], returnType) descriptor
|
||||
parseMethodType (params, returnType) ('L' : descriptor) = let
|
||||
typeLength = elemIndex ';' descriptor
|
||||
in case typeLength of
|
||||
Just length -> let
|
||||
(typeName, semicolon : restOfDescriptor) = splitAt length descriptor
|
||||
in
|
||||
parseMethodType (params ++ [typeName], returnType) restOfDescriptor
|
||||
Nothing -> error $ "unterminated class type in function signature: " ++ show descriptor
|
||||
parseMethodType (params, _) (')' : descriptor) = (params, descriptor)
|
||||
parseMethodType _ descriptor = error $ "expected start of type name (L, I, C, Z) but got: " ++ descriptor
|
||||
|
||||
-- given a method index (constant pool index),
|
||||
-- returns the full type of the method. (i.e (LSomething;II)V)
|
||||
methodTypeFromIndex :: [ConstantInfo] -> Int -> String
|
||||
methodTypeFromIndex constants index = case constants !! fromIntegral (index - 1) of
|
||||
MethodRefInfo _ nameAndTypeIndex -> case constants !! fromIntegral (nameAndTypeIndex - 1) of
|
||||
NameAndTypeInfo _ typeIndex -> case constants !! fromIntegral (typeIndex - 1) of
|
||||
Utf8Info typeLiteral -> typeLiteral
|
||||
unexpectedElement -> error "Expected Utf8Info but got: " ++ show unexpectedElement
|
||||
unexpectedElement -> error "Expected NameAndTypeInfo but got: " ++ show unexpectedElement
|
||||
unexpectedElement -> error "Expected MethodRefInfo but got: " ++ show unexpectedElement
|
||||
|
||||
methodParametersFromIndex :: [ConstantInfo] -> Int -> ([String], String)
|
||||
methodParametersFromIndex constants index = parseMethodType ([], "V") (methodTypeFromIndex constants index)
|
||||
|
||||
memberInfoIsMethod :: [ConstantInfo] -> MemberInfo -> Bool
|
||||
memberInfoIsMethod constants info = '(' `elem` memberInfoDescriptor constants info
|
||||
|
||||
datatypeDescriptor :: String -> String
|
||||
datatypeDescriptor "void" = "V"
|
||||
datatypeDescriptor "int" = "I"
|
||||
datatypeDescriptor "char" = "C"
|
||||
datatypeDescriptor "boolean" = "Z"
|
||||
datatypeDescriptor x = "L" ++ x ++ ";"
|
||||
|
||||
memberInfoDescriptor :: [ConstantInfo] -> MemberInfo -> String
|
||||
memberInfoDescriptor constants MemberInfo { memberDescriptorIndex = descriptorIndex } = 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 { memberNameIndex = nameIndex } = 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
|
||||
| dtype `elem` ["int", "char", "boolean"] = Opireturn
|
||||
| otherwise = Opareturn
|
||||
|
||||
binaryOperation :: BinaryOperator -> Operation
|
||||
binaryOperation Addition = Opiadd
|
||||
binaryOperation Subtraction = Opisub
|
||||
binaryOperation Multiplication = Opimul
|
||||
binaryOperation Division = Opidiv
|
||||
binaryOperation Modulo = Opirem
|
||||
binaryOperation BitwiseAnd = Opiand
|
||||
binaryOperation BitwiseOr = Opior
|
||||
binaryOperation BitwiseXor = Opixor
|
||||
binaryOperation And = Opiand
|
||||
binaryOperation Or = Opior
|
||||
|
||||
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
|
||||
|
||||
comparisonOffset :: Operation -> Maybe Int
|
||||
comparisonOffset (Opif_icmpeq offset) = Just $ fromIntegral offset
|
||||
comparisonOffset (Opif_icmpne offset) = Just $ fromIntegral offset
|
||||
comparisonOffset (Opif_icmplt offset) = Just $ fromIntegral offset
|
||||
comparisonOffset (Opif_icmple offset) = Just $ fromIntegral offset
|
||||
comparisonOffset (Opif_icmpgt offset) = Just $ fromIntegral offset
|
||||
comparisonOffset (Opif_icmpge offset) = Just $ fromIntegral offset
|
||||
comparisonOffset anything_else = Nothing
|
||||
|
||||
isComparisonOperation :: Operation -> Bool
|
||||
isComparisonOperation op = isJust (comparisonOffset op)
|
||||
|
||||
findMethodIndex :: ClassFile -> MethodDeclaration -> Maybe Int
|
||||
findMethodIndex classFile (MethodDeclaration rtype name params stmt) = let
|
||||
constants = constantPool classFile
|
||||
descriptor = methodDescriptor (MethodDeclaration rtype name params stmt)
|
||||
in
|
||||
findIndex (\method -> memberInfoIsMethod constants method && memberInfoName constants method == name && memberInfoDescriptor constants method == descriptor) (methods classFile)
|
||||
|
||||
findClassIndex :: [ConstantInfo] -> String -> Maybe Int
|
||||
findClassIndex constants name = let
|
||||
classNameIndices = [(index, constants!!(fromIntegral nameIndex - 1)) | (index, ClassInfo nameIndex) <- zip [1..] constants]
|
||||
classNames = map (\(index, nameInfo) -> case nameInfo of
|
||||
Utf8Info className -> (index, className)
|
||||
something_else -> error ("Expected UTF8Info but got " ++ show something_else))
|
||||
classNameIndices
|
||||
desiredClassIndex = find (\(index, className) -> className == name) classNames
|
||||
in case desiredClassIndex of
|
||||
Just (index, _) -> Just index
|
||||
Nothing -> Nothing
|
||||
|
||||
getKnownMembers :: [ConstantInfo] -> [(Int, (String, String, String))]
|
||||
getKnownMembers constants = let
|
||||
fieldsClassAndNT = [
|
||||
(index, constants!!(fromIntegral classIndex - 1), constants!!(fromIntegral nameTypeIndex - 1))
|
||||
| (index, FieldRefInfo classIndex nameTypeIndex) <- zip [1..] constants
|
||||
] ++ [
|
||||
(index, constants!!(fromIntegral classIndex - 1), constants!!(fromIntegral nameTypeIndex - 1))
|
||||
| (index, MethodRefInfo classIndex nameTypeIndex) <- zip [1..] constants
|
||||
]
|
||||
|
||||
fieldsClassNameType = map (\(index, nameInfo, nameTypeInfo) -> case (nameInfo, nameTypeInfo) of
|
||||
(ClassInfo nameIndex, NameAndTypeInfo fnameIndex ftypeIndex) -> (index, (constants!!(fromIntegral nameIndex - 1), constants!!(fromIntegral fnameIndex - 1), constants!!(fromIntegral ftypeIndex - 1)))
|
||||
something_else -> error ("Expected Class and NameType info, but got: " ++ show nameInfo ++ " and " ++ show nameTypeInfo))
|
||||
fieldsClassAndNT
|
||||
|
||||
fieldsResolved = map (\(index, (nameInfo, fnameInfo, ftypeInfo)) -> case (nameInfo, fnameInfo, ftypeInfo) of
|
||||
(Utf8Info cname, Utf8Info fname, Utf8Info ftype) -> (index, (cname, fname, ftype))
|
||||
something_else -> error ("Expected UTF8Infos but got " ++ show something_else))
|
||||
fieldsClassNameType
|
||||
in
|
||||
fieldsResolved
|
||||
|
||||
-- same as findClassIndex, but inserts a new entry into constant pool if not existing
|
||||
getClassIndex :: [ConstantInfo] -> String -> ([ConstantInfo], Int)
|
||||
getClassIndex constants name = case findClassIndex constants name of
|
||||
Just index -> (constants, index)
|
||||
Nothing -> (constants ++ [ClassInfo (fromIntegral (length constants) + 2), Utf8Info name], fromIntegral (length constants) + 1)
|
||||
|
||||
-- get the index for a field within a class, creating it if it does not exist.
|
||||
getFieldIndex :: [ConstantInfo] -> (String, String, String) -> ([ConstantInfo], Int)
|
||||
getFieldIndex constants (cname, fname, ftype) = case findMemberIndex constants (cname, fname, ftype) of
|
||||
Just index -> (constants, index)
|
||||
Nothing -> let
|
||||
(constantsWithClass, classIndex) = getClassIndex constants cname
|
||||
baseIndex = 1 + length constantsWithClass
|
||||
in
|
||||
(constantsWithClass ++ [
|
||||
FieldRefInfo (fromIntegral classIndex) (fromIntegral (baseIndex + 1)),
|
||||
NameAndTypeInfo (fromIntegral (baseIndex + 2)) (fromIntegral (baseIndex + 3)),
|
||||
Utf8Info fname,
|
||||
Utf8Info (datatypeDescriptor ftype)
|
||||
], baseIndex)
|
||||
|
||||
getMethodIndex :: [ConstantInfo] -> (String, String, String) -> ([ConstantInfo], Int)
|
||||
getMethodIndex constants (cname, mname, mtype) = case findMemberIndex constants (cname, mname, mtype) of
|
||||
Just index -> (constants, index)
|
||||
Nothing -> let
|
||||
(constantsWithClass, classIndex) = getClassIndex constants cname
|
||||
baseIndex = 1 + length constantsWithClass
|
||||
in
|
||||
(constantsWithClass ++ [
|
||||
MethodRefInfo (fromIntegral classIndex) (fromIntegral (baseIndex + 1)),
|
||||
NameAndTypeInfo (fromIntegral (baseIndex + 2)) (fromIntegral (baseIndex + 3)),
|
||||
Utf8Info mname,
|
||||
Utf8Info mtype
|
||||
], baseIndex)
|
||||
|
||||
findMemberIndex :: [ConstantInfo] -> (String, String, String) -> Maybe Int
|
||||
findMemberIndex constants (cname, fname, ftype) = let
|
||||
allMembers = getKnownMembers constants
|
||||
desiredMember = find (\(index, (c, f, ft)) -> (c, f, ft) == (cname, fname, ftype)) allMembers
|
||||
in
|
||||
fmap fst desiredMember
|
||||
|
||||
injectFieldInitializers :: String -> [VariableDeclaration] -> [ConstructorDeclaration] -> [ConstructorDeclaration]
|
||||
injectFieldInitializers classname vars constructors = let
|
||||
initializers = mapMaybe (\variable -> case variable of
|
||||
VariableDeclaration dtype name (Just initializer) -> Just (
|
||||
TypedStatement dtype (
|
||||
StatementExpressionStatement (
|
||||
TypedStatementExpression dtype (
|
||||
Assignment
|
||||
(TypedExpression dtype (BinaryOperation NameResolution (TypedExpression classname (LocalVariable "this")) (TypedExpression dtype (FieldVariable name))))
|
||||
initializer
|
||||
)
|
||||
)
|
||||
)
|
||||
)
|
||||
otherwise -> Nothing
|
||||
) vars
|
||||
in
|
||||
map (\con -> let
|
||||
ConstructorDeclaration classname params (TypedStatement "void" (Block statements)) = con
|
||||
in
|
||||
ConstructorDeclaration classname params (TypedStatement "void" (Block (initializers ++ statements)))
|
||||
) constructors
|
||||
|
||||
-- effect of one instruction/operation on the stack
|
||||
operationStackCost :: [ConstantInfo] -> Operation -> Int
|
||||
operationStackCost constants Opiadd = -1
|
||||
operationStackCost constants Opisub = -1
|
||||
operationStackCost constants Opimul = -1
|
||||
operationStackCost constants Opidiv = -1
|
||||
operationStackCost constants Opirem = -1
|
||||
operationStackCost constants Opiand = -1
|
||||
operationStackCost constants Opior = -1
|
||||
operationStackCost constants Opixor = -1
|
||||
operationStackCost constants Opineg = 0
|
||||
operationStackCost constants Opdup = 1
|
||||
operationStackCost constants (Opnew _) = 1
|
||||
operationStackCost constants (Opif_icmplt _) = -2
|
||||
operationStackCost constants (Opif_icmple _) = -2
|
||||
operationStackCost constants (Opif_icmpgt _) = -2
|
||||
operationStackCost constants (Opif_icmpge _) = -2
|
||||
operationStackCost constants (Opif_icmpeq _) = -2
|
||||
operationStackCost constants (Opif_icmpne _) = -2
|
||||
operationStackCost constants Opaconst_null = 1
|
||||
operationStackCost constants Opreturn = 0
|
||||
operationStackCost constants Opireturn = -1
|
||||
operationStackCost constants Opareturn = -1
|
||||
operationStackCost constants Opdup_x1 = 1
|
||||
operationStackCost constants Oppop = -1
|
||||
operationStackCost constants (Opinvokespecial idx) = let
|
||||
(params, returnType) = methodParametersFromIndex constants (fromIntegral idx)
|
||||
in (length params + 1) - fromEnum (returnType /= "V")
|
||||
operationStackCost constants (Opinvokevirtual idx) = let
|
||||
(params, returnType) = methodParametersFromIndex constants (fromIntegral idx)
|
||||
in (length params + 1) - fromEnum (returnType /= "V")
|
||||
operationStackCost constants (Opgoto _) = 0
|
||||
operationStackCost constants (Opsipush _) = 1
|
||||
operationStackCost constants (Opldc_w _) = 1
|
||||
operationStackCost constants (Opaload _) = 1
|
||||
operationStackCost constants (Opiload _) = 1
|
||||
operationStackCost constants (Opastore _) = -1
|
||||
operationStackCost constants (Opistore _) = -1
|
||||
operationStackCost constants (Opputfield _) = -2
|
||||
operationStackCost constants (Opgetfield _) = 0
|
||||
|
||||
simulateStackOperation :: (Int, Int) -> [ConstantInfo] -> Operation -> (Int, Int)
|
||||
simulateStackOperation (cd, md) constants op = let
|
||||
depth = cd + operationStackCost constants op
|
||||
in if depth < 0
|
||||
then error ("Consuming value off of empty stack: " ++ show op)
|
||||
else (depth, max depth md)
|
||||
|
||||
maxStackDepth :: [ConstantInfo] -> [Operation] -> Int
|
||||
maxStackDepth constants ops = snd $ foldl (`simulateStackOperation` constants) (0, 0) ops
|
||||
@@ -1,50 +0,0 @@
|
||||
module Example where
|
||||
|
||||
import Ast
|
||||
import Control.Exception (catch, evaluate, SomeException, displayException)
|
||||
import Control.Exception.Base
|
||||
import Typecheck
|
||||
|
||||
-- Example classes and their methods and fields
|
||||
sampleClasses :: [Class]
|
||||
sampleClasses = [
|
||||
Class "Person" [
|
||||
MethodDeclaration "void" "setAge" [ParameterDeclaration "Int" "newAge"]
|
||||
(Block [
|
||||
LocalVariableDeclaration (VariableDeclaration "Int" "age" (Just (Reference "newAge")))
|
||||
]),
|
||||
MethodDeclaration "Int" "getAge" [] (Return (Just (Reference "age")))
|
||||
] [
|
||||
VariableDeclaration "Int" "age" (Just (IntegerLiteral 25)),
|
||||
VariableDeclaration "String" "name" (Just (CharacterLiteral 'A'))
|
||||
]
|
||||
]
|
||||
|
||||
-- Symbol table, mapping identifiers to their data types
|
||||
initialSymtab :: [(DataType, Identifier)]
|
||||
initialSymtab = []
|
||||
|
||||
-- An example block of statements to type check
|
||||
exampleBlock :: Statement
|
||||
exampleBlock = Block [
|
||||
LocalVariableDeclaration (VariableDeclaration "Person" "bob" (Just (StatementExpressionExpression (ConstructorCall "Person" [])))),
|
||||
StatementExpressionStatement (MethodCall "setAge" [IntegerLiteral 30]),
|
||||
Return (Just (StatementExpressionExpression (MethodCall "getAge" [])))
|
||||
]
|
||||
|
||||
exampleExpression :: Expression
|
||||
exampleExpression = BinaryOperation NameResolution (Reference "bob") (Reference "age")
|
||||
|
||||
-- Function to perform type checking and handle errors
|
||||
runTypeCheck :: IO ()
|
||||
runTypeCheck = do
|
||||
-- Evaluate the block of statements
|
||||
--evaluatedBlock <- evaluate (typeCheckStatement exampleBlock initialSymtab sampleClasses)
|
||||
--putStrLn "Type checking of block completed successfully:"
|
||||
--print evaluatedBlock
|
||||
|
||||
-- Evaluate the expression
|
||||
evaluatedExpression <- evaluate (typeCheckExpression exampleExpression [("bob", "Person"), ("age", "int")] sampleClasses)
|
||||
putStrLn "Type checking of expression completed successfully:"
|
||||
print evaluatedExpression
|
||||
|
||||
30
src/Main.hs
30
src/Main.hs
@@ -1,8 +1,32 @@
|
||||
module Main where
|
||||
|
||||
import Example
|
||||
import Typecheck
|
||||
import Parser.Lexer (alexScanTokens)
|
||||
import Parser.JavaParser
|
||||
import ByteCode.Builder
|
||||
import ByteCode.ClassFile
|
||||
import Data.ByteString (pack, writeFile)
|
||||
import System.Environment
|
||||
import System.FilePath.Posix (takeDirectory)
|
||||
|
||||
main = do
|
||||
Example.runTypeCheck
|
||||
|
||||
args <- getArgs
|
||||
let filename = if null args
|
||||
then error "Missing filename, I need to know what to compile"
|
||||
else head args
|
||||
let outputDirectory = takeDirectory filename
|
||||
print ("Compiling " ++ filename)
|
||||
file <- readFile filename
|
||||
|
||||
let untypedAST = parse $ alexScanTokens file
|
||||
let typedAST = typeCheckCompilationUnit untypedAST
|
||||
let assembledClasses = map (`classBuilder` emptyClassFile) typedAST
|
||||
|
||||
mapM_ (\classFile -> let
|
||||
fileContent = pack (serialize classFile)
|
||||
fileName = outputDirectory ++ "/" ++ className classFile ++ ".class"
|
||||
in Data.ByteString.writeFile fileName fileContent
|
||||
) assembledClasses
|
||||
|
||||
|
||||
|
||||
|
||||
@@ -1,12 +1,16 @@
|
||||
{
|
||||
module Parser.JavaParser (parse) where
|
||||
--import AbsSyn
|
||||
module Parser.JavaParser (parse, parseStatement, parseExpression, parseMethod) where
|
||||
import Ast
|
||||
import Parser.Lexer
|
||||
}
|
||||
|
||||
%name parse
|
||||
%name parseStatement statement
|
||||
%name parseExpression expression
|
||||
%name parseMethod classbodydeclarations
|
||||
%tokentype { Token }
|
||||
%error { parseError }
|
||||
%errorhandlertype explist
|
||||
|
||||
%token
|
||||
BOOLEAN { BOOLEAN }
|
||||
@@ -14,10 +18,10 @@ import Parser.Lexer
|
||||
CASE { CASE }
|
||||
CHAR { CHAR }
|
||||
CLASS { CLASS}
|
||||
IDENTIFIER { IDENTIFIER $$}
|
||||
INTLITERAL { INTLITERAL $$}
|
||||
IDENTIFIER { IDENTIFIER $$ }
|
||||
INTLITERAL { INTEGERLITERAL $$}
|
||||
DOT { DOT }
|
||||
MOD { MOD }
|
||||
MOD { MODULO }
|
||||
TIMESEQUAL { TIMESEQUAL }
|
||||
GREATEREQUAL { GREATEREQUAL }
|
||||
WHILE { WHILE }
|
||||
@@ -29,30 +33,28 @@ import Parser.Lexer
|
||||
THIS { THIS }
|
||||
STATIC { STATIC }
|
||||
PROTECTED { PROTECTED }
|
||||
TILDE { TILDE }
|
||||
MUL { MUL }
|
||||
TILDE { BITWISENOT }
|
||||
MUL { TIMES }
|
||||
MINUS { MINUS }
|
||||
EXCLMARK { EXCLMARK }
|
||||
EXCLMARK { NOT }
|
||||
IF { IF }
|
||||
ELSE { ELSE }
|
||||
DIVIDEEQUAL { DIVIDEEQUAL }
|
||||
DIVIDEEQUAL { DIVEQUAL }
|
||||
NEW { NEW }
|
||||
LBRACKET { LBRACKET }
|
||||
JNULL { JNULL }
|
||||
BOOLLITERAL { BOOLLITERAL }
|
||||
JNULL { NULLLITERAL }
|
||||
BOOLLITERAL { BOOLLITERAL $$ }
|
||||
DIV { DIV }
|
||||
LOGICALOR { LOGICALOR }
|
||||
NOTEQUAL { NOTEQUAL }
|
||||
INSTANCEOF { INSTANCEOF }
|
||||
ANDEQUAL { ANDEQUAL }
|
||||
ASSIGN { ASSIGN }
|
||||
DECREMENT { DECREMENT }
|
||||
STRINGLITERAL { STRINGLITERAL }
|
||||
CHARLITERAL { CHARLITERAL }
|
||||
CHARLITERAL { CHARLITERAL $$ }
|
||||
AND { AND }
|
||||
XOREQUAL { XOREQUAL }
|
||||
RETURN { RETURN }
|
||||
QUESMARK { QUESMARK }
|
||||
QUESMARK { QUESTIONMARK }
|
||||
SHIFTLEFTEQUAL { SHIFTLEFTEQUAL }
|
||||
RBRACKET { RBRACKET }
|
||||
COMMA { COMMA }
|
||||
@@ -68,293 +70,367 @@ import Parser.Lexer
|
||||
INT { INT }
|
||||
ABSTRACT { ABSTRACT }
|
||||
SEMICOLON { SEMICOLON }
|
||||
SIGNEDSHIFTRIGHTEQUAL { SIGNEDSHIFTRIGHTEQUAL }
|
||||
SIGNEDSHIFTRIGHTEQUAL { SHIFTRIGHTEQUAL }
|
||||
UNSIGNEDSHIFTRIGHTEQUAL { UNSIGNEDSHIFTRIGHTEQUAL }
|
||||
PLUSEQUAL { PLUSEQUAL }
|
||||
OREQUAL { OREQUAL }
|
||||
COLON { COLON }
|
||||
LESS { LESS }
|
||||
FOR { FOR }
|
||||
%%
|
||||
|
||||
compilationunit : typedeclarations { }
|
||||
compilationunit : typedeclarations { $1 }
|
||||
|
||||
typedeclarations : typedeclaration { }
|
||||
| typedeclarations typedeclaration { }
|
||||
typedeclarations : typedeclaration { [$1] }
|
||||
| typedeclarations typedeclaration { $1 ++ [$2] }
|
||||
|
||||
name : qualifiedname { }
|
||||
| simplename { }
|
||||
name : simplename { Reference $1 }
|
||||
| qualifiedname { $1 }
|
||||
|
||||
typedeclaration : classdeclaration { }
|
||||
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 { }
|
||||
| modifiers CLASS IDENTIFIER classbody { }
|
||||
classdeclaration : CLASS IDENTIFIER classbody { case $3 of (constructors, methods, fields) -> Class $2 "public" constructors methods fields }
|
||||
| modifiers CLASS IDENTIFIER classbody { case $4 of (constructors, methods, fields) -> Class $3 (head $1) constructors methods fields }
|
||||
|
||||
classbody : LBRACKET RBRACKET { ([], []) }
|
||||
| LBRACKET classbodydeclarations RBRACKET { }
|
||||
classbody : LBRACKET RBRACKET { ([], [], []) }
|
||||
| LBRACKET classbodydeclarations RBRACKET { $2 }
|
||||
|
||||
modifiers : modifier { }
|
||||
| modifiers modifier { }
|
||||
modifiers : modifier { [$1] }
|
||||
| modifiers modifier { $1 ++ [$2] }
|
||||
|
||||
classbodydeclarations : classbodydeclaration { }
|
||||
| classbodydeclarations classbodydeclaration{ }
|
||||
classbodydeclarations : classbodydeclaration {
|
||||
case $1 of
|
||||
ConstructorDecl constructor -> ([constructor], [], [])
|
||||
MethodDecl method -> ([], (convertMethodDeclarationWithOptionals method), [])
|
||||
FieldDecls fields -> ([], [], fields)
|
||||
}
|
||||
| classbodydeclarations classbodydeclaration {
|
||||
case ($1, $2) of
|
||||
((constructors, methods, fields), ConstructorDecl constructor) -> ((constructors ++ [constructor]), methods, fields)
|
||||
((constructors, methods, fields), MethodDecl method) -> (constructors, (methods ++ (convertMethodDeclarationWithOptionals method)), fields)
|
||||
((constructors, methods, fields), FieldDecls newFields) -> (constructors, methods, (fields ++ newFields))
|
||||
}
|
||||
|
||||
modifier : PUBLIC { }
|
||||
| PROTECTED { }
|
||||
| PRIVATE { }
|
||||
| STATIC { }
|
||||
| ABSTRACT { }
|
||||
modifier : PUBLIC { "public" }
|
||||
| PROTECTED { "protected" }
|
||||
| PRIVATE { "private" }
|
||||
| STATIC { "static" }
|
||||
| ABSTRACT { "abstract" }
|
||||
|
||||
classtype : classorinterfacetype{ }
|
||||
classtype : classorinterfacetype { $1 }
|
||||
|
||||
classbodydeclaration : classmemberdeclaration { }
|
||||
| constructordeclaration { }
|
||||
classbodydeclaration : classmemberdeclaration { $1 }
|
||||
| constructordeclaration { $1 }
|
||||
|
||||
classorinterfacetype : name{ }
|
||||
classorinterfacetype : simplename { $1 }
|
||||
|
||||
classmemberdeclaration : fielddeclaration { }
|
||||
| methoddeclaration { }
|
||||
classmemberdeclaration : fielddeclaration { $1 }
|
||||
| methoddeclaration { $1 }
|
||||
|
||||
constructordeclaration : constructordeclarator constructorbody { }
|
||||
| modifiers constructordeclarator constructorbody { }
|
||||
constructordeclaration : constructordeclarator constructorbody { case $1 of (identifier, parameters) -> ConstructorDecl $ ConstructorDeclaration "public" identifier parameters $2 }
|
||||
| modifiers constructordeclarator constructorbody { case $2 of (identifier, parameters) -> ConstructorDecl $ ConstructorDeclaration (head $1) identifier parameters $3 }
|
||||
|
||||
fielddeclaration : type variabledeclarators SEMICOLON { }
|
||||
| modifiers type variabledeclarators SEMICOLON { }
|
||||
fielddeclaration : type variabledeclarators SEMICOLON { FieldDecls $ map (convertDeclarator "public" $1) $2 }
|
||||
| modifiers type variabledeclarators SEMICOLON { FieldDecls $ map (convertDeclarator (head $1) $2) $3 }
|
||||
|
||||
methoddeclaration : methodheader methodbody { }
|
||||
methoddeclaration : methodheader methodbody { case $1 of (returnType, modifier, (name, (parameters, optionalparameters))) -> MethodDecl (MethodDeclarationWithOptionals returnType modifier name parameters optionalparameters $2) }
|
||||
|
||||
block : LBRACKET RBRACKET { }
|
||||
| LBRACKET blockstatements RBRACKET { }
|
||||
block : LBRACKET RBRACKET { Block [] }
|
||||
| LBRACKET blockstatements RBRACKET { Block $2 }
|
||||
|
||||
constructordeclarator : simplename LBRACE RBRACE { }
|
||||
| simplename LBRACE formalparameterlist RBRACE { }
|
||||
constructordeclarator : simplename LBRACE RBRACE { ($1, []) }
|
||||
| simplename LBRACE formalparameterlist RBRACE { ($1, $3) }
|
||||
|
||||
constructorbody : LBRACKET RBRACKET { }
|
||||
| LBRACKET explicitconstructorinvocation RBRACKET { }
|
||||
| LBRACKET blockstatements RBRACKET { }
|
||||
| LBRACKET explicitconstructorinvocation blockstatements RBRACKET { }
|
||||
constructorbody : LBRACKET RBRACKET { Block [] }
|
||||
-- | LBRACKET explicitconstructorinvocation RBRACKET { }
|
||||
| LBRACKET blockstatements RBRACKET { Block $2 }
|
||||
-- | LBRACKET explicitconstructorinvocation blockstatements RBRACKET { }
|
||||
|
||||
methodheader : type methoddeclarator { }
|
||||
| modifiers type methoddeclarator { }
|
||||
| VOID methoddeclarator { }
|
||||
| modifiers VOID methoddeclarator { }
|
||||
methodheader : type methoddeclarator { ($1, "public", $2) }
|
||||
| modifiers type methoddeclarator { ($2, head $1, $3) }
|
||||
| VOID methoddeclarator { ("void", "public", $2) }
|
||||
| modifiers VOID methoddeclarator { ("void", head $1, $3) }
|
||||
|
||||
type : primitivetype { }
|
||||
| referencetype { }
|
||||
type : primitivetype { $1 }
|
||||
| referencetype { $1 }
|
||||
|
||||
variabledeclarators : variabledeclarator { }
|
||||
| variabledeclarators COMMA variabledeclarator { }
|
||||
variabledeclarators : variabledeclarator { [$1] }
|
||||
| variabledeclarators COMMA variabledeclarator { $1 ++ [$3] }
|
||||
|
||||
methodbody : block { }
|
||||
| SEMICOLON { }
|
||||
methodbody : block { $1 }
|
||||
| SEMICOLON { Block [] }
|
||||
|
||||
blockstatements : blockstatement { }
|
||||
| blockstatements blockstatement { }
|
||||
blockstatements : blockstatement { $1 }
|
||||
| blockstatements blockstatement { $1 ++ $2 }
|
||||
|
||||
formalparameterlist : formalparameter { }
|
||||
| formalparameterlist COMMA formalparameter{ }
|
||||
formalandoptionalparameterlist : formalparameterlist { ($1, []) }
|
||||
| formalparameterlist COMMA optionalparameterlist { ($1, $3) }
|
||||
| optionalparameterlist { ([], $1) }
|
||||
|
||||
formalparameterlist : formalparameter { [$1] }
|
||||
| formalparameterlist COMMA formalparameter { $1 ++ [$3] }
|
||||
|
||||
explicitconstructorinvocation : THIS LBRACE RBRACE SEMICOLON { }
|
||||
| THIS LBRACE argumentlist RBRACE SEMICOLON { }
|
||||
| THIS LBRACE argumentlist RBRACE SEMICOLON { }
|
||||
|
||||
classtypelist : classtype { }
|
||||
| classtypelist COMMA classtype { }
|
||||
| classtypelist COMMA classtype { }
|
||||
|
||||
methoddeclarator : IDENTIFIER LBRACE RBRACE { }
|
||||
| IDENTIFIER LBRACE formalparameterlist RBRACE { }
|
||||
methoddeclarator : IDENTIFIER LBRACE RBRACE { ($1, ([], [])) }
|
||||
| IDENTIFIER LBRACE formalandoptionalparameterlist RBRACE { ($1, $3) }
|
||||
|
||||
primitivetype : BOOLEAN { }
|
||||
| numerictype { }
|
||||
optionalparameterlist : optionalparameter { [$1] }
|
||||
| optionalparameterlist COMMA optionalparameter { $1 ++ [$3] }
|
||||
|
||||
referencetype : classorinterfacetype { }
|
||||
optionalparameter : type variabledeclaratorid ASSIGN variableinitializer { OptionalParameter $1 $2 $4 }
|
||||
|
||||
primitivetype : BOOLEAN { "boolean" }
|
||||
| numerictype { $1 }
|
||||
|
||||
variabledeclarator : variabledeclaratorid { }
|
||||
| variabledeclaratorid ASSIGN variableinitializer { }
|
||||
referencetype : classorinterfacetype { $1 }
|
||||
|
||||
blockstatement : localvariabledeclarationstatement { }
|
||||
| statement { }
|
||||
variabledeclarator : variabledeclaratorid { Declarator $1 Nothing }
|
||||
| variabledeclaratorid ASSIGN variableinitializer { Declarator $1 (Just $3) }
|
||||
|
||||
formalparameter : type variabledeclaratorid { }
|
||||
blockstatement : localvariabledeclarationstatement { $1 } -- expected type statement
|
||||
| statement { $1 }
|
||||
|
||||
argumentlist : expression { }
|
||||
| argumentlist COMMA expression { }
|
||||
formalparameter : type variabledeclaratorid { ParameterDeclaration $1 $2 }
|
||||
|
||||
numerictype : integraltype { }
|
||||
argumentlist : expression { [$1] }
|
||||
| argumentlist COMMA expression { $1 ++ [$3] }
|
||||
|
||||
variabledeclaratorid : IDENTIFIER { }
|
||||
numerictype : integraltype { $1 }
|
||||
|
||||
variableinitializer : expression { }
|
||||
variabledeclaratorid : IDENTIFIER { $1 }
|
||||
|
||||
localvariabledeclarationstatement : localvariabledeclaration SEMICOLON { }
|
||||
variableinitializer : expression { $1 }
|
||||
|
||||
statement : statementwithouttrailingsubstatement{ }
|
||||
| ifthenstatement { }
|
||||
| ifthenelsestatement { }
|
||||
| whilestatement { }
|
||||
|
||||
localvariabledeclarationstatement : localvariabledeclaration SEMICOLON { $1 }
|
||||
|
||||
expression : assignmentexpression { }
|
||||
statement : statementwithouttrailingsubstatement{ $1 } -- statement returns a list of statements
|
||||
| ifthenstatement { [$1] }
|
||||
| ifthenelsestatement { [$1] }
|
||||
| whilestatement { [$1] }
|
||||
| forstatement { [$1] }
|
||||
|
||||
|
||||
integraltype : INT { }
|
||||
| CHAR { }
|
||||
expression : assignmentexpression { $1 }
|
||||
|
||||
localvariabledeclaration : type variabledeclarators { }
|
||||
integraltype : INT { "int" }
|
||||
| CHAR { "char" }
|
||||
|
||||
statementwithouttrailingsubstatement : block { }
|
||||
| emptystatement { }
|
||||
| expressionstatement { }
|
||||
| returnstatement { }
|
||||
localvariabledeclaration : type variabledeclarators { map (LocalVariableDeclaration . convertDeclarator "public" $1) $2 }
|
||||
| modifiers type variabledeclarators { map (LocalVariableDeclaration . convertDeclarator (unwords $1) $2) $3 }
|
||||
|
||||
ifthenstatement : IF LBRACE expression RBRACE statement { }
|
||||
statementwithouttrailingsubstatement : block { [$1] }
|
||||
| emptystatement { [] }
|
||||
| expressionstatement { [$1] }
|
||||
| returnstatement { [$1] }
|
||||
|
||||
ifthenelsestatement : IF LBRACE expression RBRACE statementnoshortif ELSE statement { }
|
||||
ifthenstatement : IF LBRACE expression RBRACE statement { If $3 (Block $5) Nothing }
|
||||
|
||||
whilestatement : WHILE LBRACE expression RBRACE statement { }
|
||||
ifthenelsestatement : IF LBRACE expression RBRACE statementnoshortif ELSE statement { If $3 (Block $5) (Just (Block $7)) }
|
||||
|
||||
assignmentexpression : conditionalexpression { }
|
||||
| assignment{ }
|
||||
whilestatement : WHILE LBRACE expression RBRACE statement { While $3 (Block $5) }
|
||||
|
||||
emptystatement : SEMICOLON { }
|
||||
forstatement : FOR LBRACE forinit optionalexpression forupdate statement { Block ($3 ++ [While ($4) (Block ($6 ++ $5))]) }
|
||||
|
||||
expressionstatement : statementexpression SEMICOLON { }
|
||||
forinit : statementexpressionlist SEMICOLON { $1 }
|
||||
| localvariabledeclaration SEMICOLON { $1 }
|
||||
| SEMICOLON { [] }
|
||||
|
||||
returnstatement : RETURN SEMICOLON { }
|
||||
| RETURN expression SEMICOLON { }
|
||||
optionalexpression : expression SEMICOLON { $1 }
|
||||
| SEMICOLON { BooleanLiteral True }
|
||||
|
||||
statementnoshortif : statementwithouttrailingsubstatement { }
|
||||
| ifthenelsestatementnoshortif { }
|
||||
| whilestatementnoshortif { }
|
||||
forupdate : statementexpressionlist RBRACE { $1 }
|
||||
| RBRACE { [] }
|
||||
|
||||
conditionalexpression : conditionalorexpression { }
|
||||
| conditionalorexpression QUESMARK expression COLON conditionalexpression { }
|
||||
statementexpressionlist : statementexpression { [StatementExpressionStatement $1] }
|
||||
| statementexpressionlist COMMA statementexpression { $1 ++ [StatementExpressionStatement $3] }
|
||||
|
||||
assignment :lefthandside assignmentoperator assignmentexpression { }
|
||||
|
||||
assignmentexpression : conditionalexpression { $1 }
|
||||
| assignment { StatementExpressionExpression $1 }
|
||||
|
||||
statementexpression : assignment { }
|
||||
| preincrementexpression { }
|
||||
| predecrementexpression { }
|
||||
| postincrementexpression { }
|
||||
| postdecrementexpression { }
|
||||
| methodinvocation { }
|
||||
| classinstancecreationexpression { }
|
||||
emptystatement : SEMICOLON { Block [] }
|
||||
|
||||
expressionstatement : statementexpression SEMICOLON { StatementExpressionStatement $1 }
|
||||
|
||||
returnstatement : RETURN SEMICOLON { Return Nothing }
|
||||
| RETURN expression SEMICOLON { Return $ Just $2 }
|
||||
|
||||
statementnoshortif : statementwithouttrailingsubstatement { $1 }
|
||||
-- | ifthenelsestatementnoshortif { }
|
||||
-- | whilestatementnoshortif { }
|
||||
|
||||
conditionalexpression : conditionalorexpression { $1 }
|
||||
-- | conditionalorexpression QUESMARK expression COLON conditionalexpression { }
|
||||
|
||||
assignment : lefthandside assignmentoperator assignmentexpression {
|
||||
case $2 of
|
||||
Nothing -> Assignment $1 $3
|
||||
Just operator -> Assignment $1 (BinaryOperation operator $1 $3)
|
||||
}
|
||||
|
||||
|
||||
statementexpression : assignment { $1 }
|
||||
| preincrementexpression { $1 }
|
||||
| predecrementexpression { $1 }
|
||||
| postincrementexpression { $1 }
|
||||
| postdecrementexpression { $1 }
|
||||
| methodinvocation { $1 }
|
||||
| classinstancecreationexpression { $1 }
|
||||
|
||||
ifthenelsestatementnoshortif :IF LBRACE expression RBRACE statementnoshortif
|
||||
ELSE statementnoshortif { }
|
||||
ELSE statementnoshortif { }
|
||||
|
||||
whilestatementnoshortif : WHILE LBRACE expression RBRACE statementnoshortif { }
|
||||
|
||||
conditionalorexpression : conditionalandexpression { }
|
||||
| conditionalorexpression LOGICALOR conditionalandexpression{ }
|
||||
conditionalorexpression : conditionalandexpression { $1 }
|
||||
-- | conditionalorexpression LOGICALOR conditionalandexpression{ }
|
||||
|
||||
lefthandside : name { }
|
||||
lefthandside : name { $1 }
|
||||
| primary DOT IDENTIFIER { BinaryOperation NameResolution $1 (Reference $3) }
|
||||
|
||||
assignmentoperator : ASSIGN{ }
|
||||
| TIMESEQUAL { }
|
||||
| DIVIDEEQUAL { }
|
||||
| MODULOEQUAL { }
|
||||
| PLUSEQUAL { }
|
||||
| MINUSEQUAL { }
|
||||
| SHIFTLEFTEQUAL { }
|
||||
| SIGNEDSHIFTRIGHTEQUAL { }
|
||||
| UNSIGNEDSHIFTRIGHTEQUAL { }
|
||||
| ANDEQUAL { }
|
||||
| XOREQUAL { }
|
||||
| OREQUAL{ }
|
||||
assignmentoperator : ASSIGN { Nothing }
|
||||
| TIMESEQUAL { Just Multiplication }
|
||||
| DIVIDEEQUAL { Just Division }
|
||||
| MODULOEQUAL { Just Modulo }
|
||||
| PLUSEQUAL { Just Addition }
|
||||
| MINUSEQUAL { Just Subtraction }
|
||||
-- | SHIFTLEFTEQUAL { }
|
||||
-- | SIGNEDSHIFTRIGHTEQUAL { }
|
||||
-- | UNSIGNEDSHIFTRIGHTEQUAL { }
|
||||
| ANDEQUAL { Just BitwiseAnd }
|
||||
| XOREQUAL { Just BitwiseXor }
|
||||
| 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 { }
|
||||
| name LBRACE argumentlist RBRACE { }
|
||||
| primary DOT IDENTIFIER LBRACE RBRACE { }
|
||||
| primary DOT IDENTIFIER LBRACE argumentlist RBRACE { }
|
||||
methodinvocation : name LBRACE RBRACE { let (exp, functionname) = extractFunctionName $1 in (MethodCall exp functionname []) }
|
||||
| name LBRACE argumentlist RBRACE { let (exp, functionname) = extractFunctionName $1 in (MethodCall exp functionname $3) }
|
||||
| primary DOT IDENTIFIER LBRACE RBRACE { MethodCall $1 $3 [] }
|
||||
| primary DOT IDENTIFIER LBRACE argumentlist RBRACE { MethodCall $1 $3 $5 }
|
||||
|
||||
classinstancecreationexpression : NEW classtype LBRACE RBRACE { }
|
||||
| NEW classtype LBRACE argumentlist RBRACE { }
|
||||
classinstancecreationexpression : NEW classtype LBRACE RBRACE { ConstructorCall $2 [] }
|
||||
| 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 { }
|
||||
| predecrementexpression { }
|
||||
| PLUS unaryexpression { }
|
||||
| MINUS unaryexpression { }
|
||||
| unaryexpressionnotplusminus { }
|
||||
unaryexpression : unaryexpressionnotplusminus { $1 }
|
||||
| predecrementexpression { StatementExpressionExpression $1 }
|
||||
| PLUS unaryexpression { $2 }
|
||||
| MINUS unaryexpression { UnaryOperation Minus $2 }
|
||||
| preincrementexpression { StatementExpressionExpression $1 }
|
||||
|
||||
postfixexpression : primary { }
|
||||
| name { }
|
||||
| postincrementexpression { }
|
||||
| postdecrementexpression{ }
|
||||
postfixexpression : primary { $1 }
|
||||
| name { $1 }
|
||||
| postincrementexpression { StatementExpressionExpression $1 }
|
||||
| postdecrementexpression { StatementExpressionExpression $1 }
|
||||
|
||||
primary : primarynonewarray { }
|
||||
primary : primarynonewarray { $1 }
|
||||
|
||||
inclusiveorexpression : exclusiveorexpression { }
|
||||
| inclusiveorexpression OR exclusiveorexpression { }
|
||||
inclusiveorexpression : exclusiveorexpression { $1 }
|
||||
| inclusiveorexpression OR exclusiveorexpression { BinaryOperation Or $1 $3 }
|
||||
|
||||
primarynonewarray : literal { }
|
||||
| THIS { }
|
||||
| LBRACE expression RBRACE { }
|
||||
| classinstancecreationexpression { }
|
||||
| fieldaccess { }
|
||||
| methodinvocation { }
|
||||
primarynonewarray : literal { $1 }
|
||||
| THIS { Reference "this" }
|
||||
| LBRACE expression RBRACE { $2 }
|
||||
| classinstancecreationexpression { StatementExpressionExpression $1 }
|
||||
| fieldaccess { $1 }
|
||||
| methodinvocation { StatementExpressionExpression $1 }
|
||||
|
||||
unaryexpressionnotplusminus : postfixexpression { }
|
||||
| TILDE unaryexpression { }
|
||||
| EXCLMARK unaryexpression { }
|
||||
| castexpression{ }
|
||||
unaryexpressionnotplusminus : postfixexpression { $1 }
|
||||
-- | TILDE unaryexpression { }
|
||||
| EXCLMARK unaryexpression { UnaryOperation Not $2 }
|
||||
-- | castexpression{ }
|
||||
|
||||
exclusiveorexpression : andexpression { }
|
||||
| exclusiveorexpression XOR andexpression { }
|
||||
exclusiveorexpression : andexpression { $1 }
|
||||
| exclusiveorexpression XOR andexpression { BinaryOperation BitwiseXor $1 $3 }
|
||||
|
||||
literal : INTLITERAL { }
|
||||
| BOOLLITERAL { }
|
||||
| CHARLITERAL { }
|
||||
| STRINGLITERAL { }
|
||||
| JNULL { }
|
||||
literal : INTLITERAL { IntegerLiteral $1 }
|
||||
| BOOLLITERAL { BooleanLiteral $1 }
|
||||
| CHARLITERAL { CharacterLiteral $1 }
|
||||
| JNULL { NullLiteral }
|
||||
|
||||
castexpression : LBRACE primitivetype RBRACE unaryexpression { }
|
||||
| LBRACE expression RBRACE unaryexpressionnotplusminus{ }
|
||||
castexpression : LBRACE primitivetype RBRACE unaryexpression { }
|
||||
| LBRACE expression RBRACE unaryexpressionnotplusminus{ }
|
||||
|
||||
andexpression : equalityexpression { }
|
||||
| andexpression AND equalityexpression { }
|
||||
andexpression : equalityexpression { $1 }
|
||||
| andexpression AND equalityexpression { BinaryOperation And $1 $3 }
|
||||
|
||||
equalityexpression : relationalexpression { }
|
||||
| equalityexpression EQUAL relationalexpression { }
|
||||
| equalityexpression NOTEQUAL relationalexpression { }
|
||||
equalityexpression : relationalexpression { $1 }
|
||||
| equalityexpression EQUAL relationalexpression { BinaryOperation CompareEqual $1 $3 }
|
||||
| equalityexpression NOTEQUAL relationalexpression { BinaryOperation CompareNotEqual $1 $3 }
|
||||
|
||||
relationalexpression : shiftexpression { }
|
||||
| relationalexpression LESS shiftexpression { }
|
||||
| relationalexpression GREATER shiftexpression { }
|
||||
| relationalexpression LESSEQUAL shiftexpression { }
|
||||
| relationalexpression GREATEREQUAL shiftexpression { }
|
||||
| relationalexpression INSTANCEOF referencetype { }
|
||||
relationalexpression : shiftexpression { $1 }
|
||||
| relationalexpression LESS shiftexpression { BinaryOperation CompareLessThan $1 $3 }
|
||||
| relationalexpression GREATER shiftexpression { BinaryOperation CompareGreaterThan $1 $3 }
|
||||
| relationalexpression LESSEQUAL shiftexpression { BinaryOperation CompareLessOrEqual $1 $3 }
|
||||
| relationalexpression GREATEREQUAL shiftexpression { BinaryOperation CompareGreaterOrEqual $1 $3 }
|
||||
-- | relationalexpression INSTANCEOF referencetype { }
|
||||
|
||||
shiftexpression : additiveexpression { }
|
||||
shiftexpression : additiveexpression { $1 }
|
||||
|
||||
additiveexpression : multiplicativeexpression { }
|
||||
| additiveexpression PLUS multiplicativeexpression { }
|
||||
| additiveexpression MINUS multiplicativeexpression { }
|
||||
additiveexpression : multiplicativeexpression { $1 }
|
||||
| additiveexpression PLUS multiplicativeexpression { BinaryOperation Addition $1 $3 }
|
||||
| additiveexpression MINUS multiplicativeexpression { BinaryOperation Subtraction $1 $3 }
|
||||
|
||||
multiplicativeexpression : unaryexpression { }
|
||||
| multiplicativeexpression MUL unaryexpression { }
|
||||
| multiplicativeexpression DIV unaryexpression { }
|
||||
| multiplicativeexpression MOD unaryexpression { }
|
||||
multiplicativeexpression : unaryexpression { $1 }
|
||||
| multiplicativeexpression MUL unaryexpression { BinaryOperation Multiplication $1 $3 }
|
||||
| multiplicativeexpression DIV unaryexpression { BinaryOperation Division $1 $3 }
|
||||
| multiplicativeexpression MOD unaryexpression { BinaryOperation Modulo $1 $3 }
|
||||
|
||||
|
||||
{
|
||||
|
||||
parseError :: [Token] -> a
|
||||
parseError _ = error "Parse error"
|
||||
data MemberDeclaration = MethodDecl MethodDeclarationWithOptionals
|
||||
| ConstructorDecl ConstructorDeclaration
|
||||
| FieldDecls [VariableDeclaration] deriving (Show)
|
||||
|
||||
data Declarator = Declarator Identifier (Maybe Expression)
|
||||
|
||||
convertDeclarator :: Modifier -> DataType -> Declarator -> VariableDeclaration
|
||||
convertDeclarator modifier dataType (Declarator id assignment) = VariableDeclaration dataType modifier id assignment
|
||||
|
||||
extractFunctionName :: Expression -> (Expression, Identifier)
|
||||
extractFunctionName (BinaryOperation NameResolution exp (Reference functionname)) = (exp, functionname)
|
||||
extractFunctionName (Reference functionname) = ((Reference "this"), functionname)
|
||||
|
||||
data OptionalParameter = OptionalParameter DataType Identifier Expression deriving (Show)
|
||||
|
||||
data MethodDeclarationWithOptionals = MethodDeclarationWithOptionals DataType String Identifier [ParameterDeclaration] [OptionalParameter] Statement deriving (Show)
|
||||
|
||||
convertMethodDeclarationWithOptionals :: MethodDeclarationWithOptionals -> [MethodDeclaration]
|
||||
convertMethodDeclarationWithOptionals (MethodDeclarationWithOptionals returnType modifier id param [] stmt) = [MethodDeclaration returnType modifier id param stmt]
|
||||
convertMethodDeclarationWithOptionals (MethodDeclarationWithOptionals returnType modifier id param (opt : optRest) stmt) = generateHelperMethod returnType modifier id param opt : convertMethodDeclarationWithOptionals (generateBaseMethod returnType modifier id param opt optRest stmt)
|
||||
|
||||
convertOptionalParameter :: OptionalParameter -> ParameterDeclaration
|
||||
convertOptionalParameter (OptionalParameter dtype id exp) = ParameterDeclaration dtype id
|
||||
|
||||
generateHelperMethod :: DataType -> Modifier -> Identifier -> [ParameterDeclaration] -> OptionalParameter -> MethodDeclaration
|
||||
generateHelperMethod returnType modifier methodName params (OptionalParameter dtype id exp) =
|
||||
let references = ((map (\(ParameterDeclaration paramType ident) -> (Reference ident)) params) ++ [exp])
|
||||
methodcall = (MethodCall (Reference "this") methodName references)
|
||||
lastStatement = if returnType == "void" then StatementExpressionStatement methodcall else Return $ Just $ StatementExpressionExpression methodcall
|
||||
in MethodDeclaration returnType modifier methodName params $ Block [lastStatement]
|
||||
|
||||
generateBaseMethod :: DataType -> Modifier -> Identifier -> [ParameterDeclaration] -> OptionalParameter -> [OptionalParameter] -> Statement -> MethodDeclarationWithOptionals
|
||||
generateBaseMethod returnType modifier methodName params (OptionalParameter dtype id exp) optRest stmt = MethodDeclarationWithOptionals returnType modifier methodName (params ++ [ParameterDeclaration dtype id]) optRest stmt
|
||||
|
||||
parseError :: ([Token], [String]) -> a
|
||||
parseError (errortoken, expected) = error ("parse error on token: " ++ show errortoken ++ "\nexpected one of: " ++ show expected)
|
||||
|
||||
}
|
||||
|
||||
@@ -1,5 +1,6 @@
|
||||
{
|
||||
module Parser.Lexer(Token(..), alexScanTokens) where
|
||||
module Parser.Lexer(Token(..), alexScanTokens) where
|
||||
import Text.Read
|
||||
}
|
||||
|
||||
%wrapper "basic"
|
||||
@@ -7,18 +8,221 @@
|
||||
$digit = 0-9
|
||||
$alpha = [a-zA-Z]
|
||||
$alphanum = [a-zA-Z0-9]
|
||||
$JavaLetter = [A-Za-z\_\$]
|
||||
$JavaLetterOrDigit = [A-Za-z\_\$0-9]
|
||||
|
||||
tokens :-
|
||||
$white ;
|
||||
"/*"(.|\n)*"*/" { \s -> Comment s }
|
||||
"//".* {\s -> Comment s}
|
||||
|
||||
"/*"(.|\n)*"*/" ;
|
||||
"//".* ;
|
||||
-- keywords
|
||||
"abstract" { \_ -> ABSTRACT }
|
||||
"assert" { \_ -> BOOLEAN }
|
||||
"boolean" { \_ -> BOOLEAN}
|
||||
"break" { \_ -> BREAK}
|
||||
"byte" { \_ -> BYTE}
|
||||
"case" { \_ -> CASE}
|
||||
"catch" { \_ -> CATCH}
|
||||
"char" { \_ -> CHAR}
|
||||
"class" { \_ -> CLASS}
|
||||
"const" { \_ -> CONST}
|
||||
"continue" { \_ -> CONTINUE}
|
||||
"default" { \_ -> DEFAULT}
|
||||
"do" { \_ -> DO}
|
||||
"double" { \_ -> DOUBLE}
|
||||
("else"|"ifn't") { \_ -> ELSE}
|
||||
"enum" { \_ -> ENUM}
|
||||
"extends" { \_ -> EXTENDS}
|
||||
"final" { \_ -> FINAL}
|
||||
"finally" { \_ -> FINALLY}
|
||||
"float" { \_ -> FLOAT}
|
||||
"for" { \_ -> FOR}
|
||||
"if" { \_ -> IF}
|
||||
"goto" { \_ -> GOTO}
|
||||
"implements" { \_ -> IMPLEMENTS}
|
||||
"import" { \_ -> IMPORT}
|
||||
"instanceof" { \_ -> INSTANCEOF}
|
||||
"int" { \_ -> INT}
|
||||
"long" { \_ -> LONG}
|
||||
"native" { \_ -> NATIVE}
|
||||
"new" { \_ -> NEW}
|
||||
"package" { \_ -> PACKAGE}
|
||||
"private" { \_ -> PRIVATE}
|
||||
"protected" { \_ -> PROTECTED}
|
||||
"public" { \_ -> PUBLIC}
|
||||
"return" { \_ -> RETURN}
|
||||
"short" { \_ -> SHORT}
|
||||
"static" { \_ -> STATIC}
|
||||
"strictfp" { \_ -> STRICTFP}
|
||||
"super" { \_ -> SUPER}
|
||||
"switch" { \_ -> SWITCH}
|
||||
"synchronized" { \_ -> SYNCHRONIZED}
|
||||
"this" { \_ -> THIS}
|
||||
"throw" { \_ -> THROW}
|
||||
"throws" { \_ -> THROWS}
|
||||
"transient" { \_ -> TRANSIENT}
|
||||
"try" { \_ -> TRY}
|
||||
"void" { \_ -> VOID}
|
||||
"volatile" { \_ -> VOLATILE}
|
||||
"while" { \_ -> WHILE}
|
||||
-- Literals
|
||||
"true" { \_ -> BOOLLITERAL True }
|
||||
"false" { \_ -> BOOLLITERAL False }
|
||||
"null" { \_ -> NULLLITERAL }
|
||||
-- end keywords
|
||||
$JavaLetter$JavaLetterOrDigit* { \s -> IDENTIFIER s }
|
||||
-- Literals
|
||||
[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) }
|
||||
-- separators
|
||||
"(" { \_ -> LBRACE }
|
||||
")" { \_ -> RBRACE }
|
||||
"{" { \_ -> LBRACKET }
|
||||
"}" { \_ -> RBRACKET }
|
||||
";" { \_ -> SEMICOLON }
|
||||
"," { \_ -> COMMA}
|
||||
"." { \_ -> DOT }
|
||||
-- operators
|
||||
"=" { \_ -> ASSIGN }
|
||||
"==" { \_ -> EQUAL }
|
||||
"+" { \_ -> PLUS }
|
||||
"+=" { \_ -> PLUSEQUAL }
|
||||
">" { \_ -> GREATER }
|
||||
">=" { \_ -> GREATEREQUAL }
|
||||
"-" { \_ -> MINUS }
|
||||
"-=" { \_ -> MINUSEQUAL }
|
||||
"<" { \_ -> LESS }
|
||||
"<=" { \_ -> LESSEQUAL }
|
||||
"*" { \_ -> TIMES }
|
||||
"*=" { \_ -> TIMESEQUAL }
|
||||
"!" { \_ -> NOT }
|
||||
"!=" { \_ -> NOTEQUAL }
|
||||
"/" { \_ -> DIV }
|
||||
"/=" { \_ -> DIVEQUAL }
|
||||
"~" { \_ -> BITWISENOT }
|
||||
"&&" { \_ -> AND }
|
||||
"&" { \_ -> BITWISEAND }
|
||||
"&=" { \_ -> ANDEQUAL }
|
||||
"?" { \_ -> QUESTIONMARK }
|
||||
"||" { \_ -> OR }
|
||||
"|" { \_ -> BITWISEOR }
|
||||
"|=" { \_ -> OREQUAL }
|
||||
":" { \_ -> COLON }
|
||||
"++" { \_ -> INCREMENT }
|
||||
"^" { \_ -> XOR }
|
||||
"^=" { \_ -> XOREQUAL }
|
||||
"--" { \_ -> DECREMENT }
|
||||
"%" { \_ -> MODULO }
|
||||
"%=" { \_ -> MODULOEQUAL }
|
||||
"<<" { \_ -> SHIFTLEFT }
|
||||
"<<=" { \_ -> SHIFTLEFTEQUAL }
|
||||
">>" { \_ -> SHIFTRIGHT }
|
||||
">>=" { \_ -> SHIFTRIGHTEQUAL }
|
||||
">>>" { \_ -> UNSIGNEDSHIFTRIGHT }
|
||||
">>>=" { \_ -> UNSIGNEDSHIFTRIGHTEQUAL }
|
||||
|
||||
|
||||
{
|
||||
data Token
|
||||
= Comment String
|
||||
| Different
|
||||
= ABSTRACT
|
||||
| ASSERT
|
||||
| BOOLEAN
|
||||
| BREAK
|
||||
| BYTE
|
||||
| CASE
|
||||
| CATCH
|
||||
| CHAR
|
||||
| CLASS
|
||||
| CONST
|
||||
| CONTINUE
|
||||
| DEFAULT
|
||||
| DO
|
||||
| DOUBLE
|
||||
| ELSE
|
||||
| ENUM
|
||||
| EXTENDS
|
||||
| FINAL
|
||||
| FINALLY
|
||||
| FLOAT
|
||||
| FOR
|
||||
| IF
|
||||
| GOTO
|
||||
| IMPLEMENTS
|
||||
| IMPORT
|
||||
| INSTANCEOF
|
||||
| INT
|
||||
| INTERFACE
|
||||
| LONG
|
||||
| NATIVE
|
||||
| NEW
|
||||
| PACKAGE
|
||||
| PRIVATE
|
||||
| PROTECTED
|
||||
| PUBLIC
|
||||
| RETURN
|
||||
| SHORT
|
||||
| STATIC
|
||||
| STRICTFP
|
||||
| SUPER
|
||||
| SWITCH
|
||||
| SYNCHRONIZED
|
||||
| THIS
|
||||
| THROW
|
||||
| THROWS
|
||||
| TRANSIENT
|
||||
| TRY
|
||||
| VOID
|
||||
| VOLATILE
|
||||
| WHILE
|
||||
| IDENTIFIER String
|
||||
| INTEGERLITERAL Int
|
||||
| CHARLITERAL Char
|
||||
| BOOLLITERAL Bool
|
||||
| NULLLITERAL
|
||||
| LBRACE
|
||||
| RBRACE
|
||||
| LBRACKET
|
||||
| RBRACKET
|
||||
| SEMICOLON
|
||||
| COMMA
|
||||
| DOT
|
||||
| ASSIGN
|
||||
| EQUAL
|
||||
| PLUS
|
||||
| PLUSEQUAL
|
||||
| GREATER
|
||||
| GREATEREQUAL
|
||||
| MINUS
|
||||
| MINUSEQUAL
|
||||
| LESS
|
||||
| LESSEQUAL
|
||||
| TIMES
|
||||
| TIMESEQUAL
|
||||
| NOT
|
||||
| NOTEQUAL
|
||||
| DIV
|
||||
| DIVEQUAL
|
||||
| BITWISENOT
|
||||
| AND
|
||||
| BITWISEAND
|
||||
| ANDEQUAL
|
||||
| QUESTIONMARK
|
||||
| OR
|
||||
| BITWISEOR
|
||||
| OREQUAL
|
||||
| COLON
|
||||
| INCREMENT
|
||||
| XOR
|
||||
| XOREQUAL
|
||||
| DECREMENT
|
||||
| MODULO
|
||||
| MODULOEQUAL
|
||||
| SHIFTLEFT
|
||||
| SHIFTLEFTEQUAL
|
||||
| SHIFTRIGHT
|
||||
| SHIFTRIGHTEQUAL
|
||||
| UNSIGNEDSHIFTRIGHT
|
||||
| UNSIGNEDSHIFTRIGHTEQUAL
|
||||
deriving(Eq,Show)
|
||||
|
||||
}
|
||||
542
src/Typecheck.hs
542
src/Typecheck.hs
@@ -1,32 +1,82 @@
|
||||
module Typecheck where
|
||||
|
||||
import Data.List (find)
|
||||
import Data.Maybe
|
||||
import Ast
|
||||
|
||||
typeCheckCompilationUnit :: CompilationUnit -> CompilationUnit
|
||||
typeCheckCompilationUnit classes = map (`typeCheckClass` classes) classes
|
||||
typeCheckCompilationUnit classes =
|
||||
let
|
||||
-- Helper function to add a default constructor if none are present
|
||||
ensureDefaultConstructor :: Class -> Class
|
||||
ensureDefaultConstructor (Class className modifier constructors methods fields) =
|
||||
let
|
||||
defaultConstructor = ConstructorDeclaration modifier className [] (Block [])
|
||||
constructorsWithDefault = if null constructors then [defaultConstructor] else constructors
|
||||
in Class className modifier constructorsWithDefault methods fields
|
||||
|
||||
-- Inject default constructors into all classes
|
||||
classesWithDefaultConstructors = map ensureDefaultConstructor classes
|
||||
|
||||
in map (`typeCheckClass` classesWithDefaultConstructors) classesWithDefaultConstructors
|
||||
|
||||
typeCheckClass :: Class -> [Class] -> Class
|
||||
typeCheckClass (Class className methods fields) classes =
|
||||
typeCheckClass (Class className modifier constructors methods fields) classes =
|
||||
let
|
||||
-- Create a symbol table from class fields
|
||||
classFields = [(id, dt) | VariableDeclaration dt id _ <- fields]
|
||||
checkedMethods = map (\method -> typeCheckMethodDeclaration method classFields classes) methods
|
||||
in Class className checkedMethods fields
|
||||
-- Fields and methods dont need to be added to the symtab because they are looked upon automatically under "this"
|
||||
-- if its not a declared local variable. Also shadowing wouldnt be possible then.
|
||||
initalSymTab = [("this", className)]
|
||||
checkedConstructors = map (\constructor -> typeCheckConstructorDeclaration constructor initalSymTab classes) constructors
|
||||
checkedMethods = map (\method -> typeCheckMethodDeclaration method initalSymTab classes) methods
|
||||
checkedFields = map (\field -> typeCheckVariableDeclaration field initalSymTab classes) fields
|
||||
in Class className modifier checkedConstructors checkedMethods checkedFields
|
||||
|
||||
typeCheckMethodDeclaration :: MethodDeclaration -> [(Identifier, DataType)] -> [Class] -> MethodDeclaration
|
||||
typeCheckMethodDeclaration (MethodDeclaration retType name params body) classFields classes =
|
||||
typeCheckConstructorDeclaration :: ConstructorDeclaration -> [(Identifier, DataType)] -> [Class] -> ConstructorDeclaration
|
||||
typeCheckConstructorDeclaration (ConstructorDeclaration modifier name params body) symtab classes =
|
||||
let
|
||||
-- Combine class fields with method parameters to form the initial symbol table for the method
|
||||
methodParams = [(identifier, dataType) | ParameterDeclaration dataType identifier <- params]
|
||||
-- Ensure method parameters shadow class fields if names collide
|
||||
initialSymtab = classFields ++ methodParams
|
||||
-- Type check the body of the method using the combined symbol table
|
||||
constructorParams = [(identifier, dataType) | ParameterDeclaration dataType identifier <- params]
|
||||
initialSymtab = symtab ++ constructorParams
|
||||
className = fromMaybe (error "Constructor Declaration: 'this' not found in symtab") (lookup "this" symtab)
|
||||
checkedBody = typeCheckStatement body initialSymtab classes
|
||||
bodyType = getTypeFromStmt checkedBody
|
||||
-- Check if the type of the body matches the declared return type
|
||||
in if bodyType == retType || (bodyType == "void" && retType == "void")
|
||||
then MethodDeclaration retType name params checkedBody
|
||||
else error $ "Return type mismatch in method " ++ name ++ ": expected " ++ retType ++ ", found " ++ bodyType
|
||||
in if name == className
|
||||
then if bodyType == "void"
|
||||
then ConstructorDeclaration modifier name params checkedBody
|
||||
else error $ "Constructor Declaration: Return type mismatch in constructor " ++ name ++ ": expected void, found " ++ bodyType
|
||||
else error $ "Constructor Declaration: Constructor name " ++ name ++ " does not match class name " ++ className
|
||||
|
||||
typeCheckMethodDeclaration :: MethodDeclaration -> [(Identifier, DataType)] -> [Class] -> MethodDeclaration
|
||||
typeCheckMethodDeclaration (MethodDeclaration retType modifier name params body) symtab classes =
|
||||
let
|
||||
methodParams = [(identifier, dataType) | ParameterDeclaration dataType identifier <- params]
|
||||
initialSymtab = ("thisMeth", retType) : symtab ++ methodParams
|
||||
checkedBody = typeCheckStatement body initialSymtab classes
|
||||
bodyType = getTypeFromStmt checkedBody
|
||||
in if bodyType == retType || (bodyType == "void" && retType == "void") || (bodyType == "null" && isObjectType retType) || isSubtype bodyType retType classes
|
||||
then MethodDeclaration retType modifier name params checkedBody
|
||||
else error $ "Method Declaration: Return type mismatch in method " ++ name ++ ": expected " ++ retType ++ ", found " ++ bodyType
|
||||
|
||||
typeCheckVariableDeclaration :: VariableDeclaration -> [(Identifier, DataType)] -> [Class] -> VariableDeclaration
|
||||
typeCheckVariableDeclaration (VariableDeclaration dataType modifier 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
|
||||
checkedExprWithType = case exprType of
|
||||
Just "null" | isObjectType dataType -> Just (TypedExpression dataType NullLiteral)
|
||||
_ -> 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 modifier identifier checkedExprWithType
|
||||
| t /= dataType -> error $ "Type mismatch in declaration of '" ++ identifier ++ "': expected " ++ dataType ++ ", found " ++ t
|
||||
| otherwise -> VariableDeclaration dataType modifier identifier checkedExprWithType
|
||||
(_, _, Nothing) -> VariableDeclaration dataType modifier identifier checkedExprWithType
|
||||
|
||||
-- ********************************** Type Checking: Expressions **********************************
|
||||
|
||||
@@ -36,121 +86,47 @@ typeCheckExpression (CharacterLiteral c) _ _ = TypedExpression "char" (Character
|
||||
typeCheckExpression (BooleanLiteral b) _ _ = TypedExpression "boolean" (BooleanLiteral b)
|
||||
typeCheckExpression NullLiteral _ _ = TypedExpression "null" NullLiteral
|
||||
typeCheckExpression (Reference id) symtab classes =
|
||||
let type' = lookupType id symtab
|
||||
in TypedExpression type' (Reference id)
|
||||
case lookup id symtab of
|
||||
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 modifier 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 =
|
||||
let expr1' = typeCheckExpression expr1 symtab classes
|
||||
expr2' = typeCheckExpression expr2 symtab classes
|
||||
type1 = getTypeFromExpr expr1'
|
||||
type2 = getTypeFromExpr expr2'
|
||||
resultType = resolveResultType type1 type2
|
||||
in case op of
|
||||
Addition ->
|
||||
if type1 == "int" && type2 == "int"
|
||||
then
|
||||
TypedExpression "int" (BinaryOperation op expr1' expr2')
|
||||
else
|
||||
error "Addition operation requires two operands of type int"
|
||||
Subtraction ->
|
||||
if type1 == "int" && type2 == "int"
|
||||
then
|
||||
TypedExpression "int" (BinaryOperation op expr1' expr2')
|
||||
else
|
||||
error "Subtraction operation requires two operands of type int"
|
||||
Multiplication ->
|
||||
if type1 == "int" && type2 == "int"
|
||||
then
|
||||
TypedExpression "int" (BinaryOperation op expr1' expr2')
|
||||
else
|
||||
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) ->
|
||||
-- Lookup the class type of obj from the symbol table
|
||||
let objectType = lookupType obj symtab
|
||||
classDetails = find (\(Class className _ _) -> className == objectType) classes
|
||||
in case classDetails of
|
||||
Just (Class _ methods fields) ->
|
||||
-- Check both fields and methods to find a match for member
|
||||
let fieldTypes = [dt | VariableDeclaration dt id _ <- fields, id == member]
|
||||
methodTypes = [dt | MethodDeclaration dt id _ _ <- methods, id == member]
|
||||
in case fieldTypes ++ methodTypes of
|
||||
[resolvedType] -> TypedExpression resolvedType (BinaryOperation op expr1' (TypedExpression resolvedType (Reference member)))
|
||||
[] -> error $ "Member '" ++ member ++ "' not found in class '" ++ objectType ++ "'"
|
||||
_ -> error $ "Ambiguous reference to '" ++ member ++ "' in class '" ++ objectType ++ "'"
|
||||
Nothing -> error $ "Object '" ++ obj ++ "' does not correspond to a known class"
|
||||
_ -> error "Name resolution requires object reference and member name"
|
||||
Addition -> checkArithmeticOperation op expr1' expr2' type1 type2 resultType
|
||||
Subtraction -> checkArithmeticOperation op expr1' expr2' type1 type2 resultType
|
||||
Multiplication -> checkArithmeticOperation op expr1' expr2' type1 type2 resultType
|
||||
Division -> checkArithmeticOperation op expr1' expr2' type1 type2 resultType
|
||||
Modulo -> checkArithmeticOperation op expr1' expr2' type1 type2 resultType
|
||||
BitwiseAnd -> checkBitwiseOperation op expr1' expr2' type1 type2
|
||||
BitwiseOr -> checkBitwiseOperation op expr1' expr2' type1 type2
|
||||
BitwiseXor -> checkBitwiseOperation op expr1' expr2' type1 type2
|
||||
CompareLessThan -> checkComparisonOperation op expr1' expr2' type1 type2
|
||||
CompareLessOrEqual -> checkComparisonOperation op expr1' expr2' type1 type2
|
||||
CompareGreaterThan -> checkComparisonOperation op expr1' expr2' type1 type2
|
||||
CompareGreaterOrEqual -> checkComparisonOperation op expr1' expr2' type1 type2
|
||||
CompareEqual -> checkEqualityOperation op expr1' expr2' type1 type2
|
||||
CompareNotEqual -> checkEqualityOperation op expr1' expr2' type1 type2
|
||||
And -> checkLogicalOperation op expr1' expr2' type1 type2
|
||||
Or -> checkLogicalOperation op expr1' expr2' type1 type2
|
||||
NameResolution -> resolveNameResolution expr1' expr2 symtab classes
|
||||
|
||||
typeCheckExpression (UnaryOperation op expr) symtab classes =
|
||||
let expr' = typeCheckExpression expr symtab classes
|
||||
@@ -163,53 +139,163 @@ typeCheckExpression (UnaryOperation op expr) symtab classes =
|
||||
else
|
||||
error "Logical NOT operation requires an operand of type boolean"
|
||||
Minus ->
|
||||
if type' == "int"
|
||||
if type' == "int" || type' == "char"
|
||||
then
|
||||
TypedExpression "int" (UnaryOperation op expr')
|
||||
TypedExpression type' (UnaryOperation op expr')
|
||||
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 =
|
||||
let stmtExpr' = typeCheckStatementExpression stmtExpr symtab classes
|
||||
in TypedExpression (getTypeFromStmtExpr stmtExpr') (StatementExpressionExpression stmtExpr')
|
||||
|
||||
-- ********************************** Type Checking: StatementExpressions **********************************
|
||||
-- TODO: Implement type checking for StatementExpressions
|
||||
|
||||
typeCheckStatementExpression :: StatementExpression -> [(Identifier, DataType)] -> [Class] -> StatementExpression
|
||||
typeCheckStatementExpression (Assignment id expr) symtab classes =
|
||||
typeCheckStatementExpression (Assignment ref expr) symtab classes =
|
||||
let expr' = typeCheckExpression expr symtab classes
|
||||
ref' = typeCheckExpression ref symtab classes
|
||||
type' = getTypeFromExpr expr'
|
||||
type'' = lookupType id symtab
|
||||
in if type' == type''
|
||||
then
|
||||
TypedStatementExpression type' (Assignment id expr')
|
||||
else
|
||||
error "Assignment type mismatch"
|
||||
type'' = getTypeFromExpr ref'
|
||||
typeToAssign = if type' == "null" && isObjectType type'' then type'' else type'
|
||||
exprWithType = if type' == "null" && isObjectType type'' then TypedExpression type'' NullLiteral else expr'
|
||||
in
|
||||
if type'' == typeToAssign then
|
||||
TypedStatementExpression type'' (Assignment ref' exprWithType)
|
||||
else
|
||||
error $ "Type mismatch in assignment to variable: expected " ++ type'' ++ ", found " ++ typeToAssign
|
||||
|
||||
typeCheckStatementExpression (ConstructorCall className args) symtab classes =
|
||||
let args' = map (\arg -> typeCheckExpression arg symtab classes) args
|
||||
in TypedStatementExpression className (ConstructorCall className args')
|
||||
case find (\(Class name _ _ _ _) -> name == className) classes of
|
||||
Nothing -> error $ "Class '" ++ className ++ "' not found."
|
||||
Just (Class _ modifier constructors _ _) ->
|
||||
let matchParams (ParameterDeclaration paramType _) arg =
|
||||
let argTyped = typeCheckExpression arg symtab classes
|
||||
argType = getTypeFromExpr argTyped
|
||||
in if argType == "null" && isObjectType paramType
|
||||
then Just (TypedExpression paramType NullLiteral)
|
||||
else if argType == paramType
|
||||
then Just argTyped
|
||||
else Nothing
|
||||
|
||||
typeCheckStatementExpression (MethodCall methodName args) symtab classes =
|
||||
let args' = map (\arg -> typeCheckExpression arg symtab classes) args
|
||||
in TypedStatementExpression "Object" (MethodCall methodName args')
|
||||
matchConstructor (ConstructorDeclaration constructorModifier name params _)
|
||||
| constructorModifier == "public" = fmap (\checkedArgs -> (ConstructorDeclaration constructorModifier name params (Block []), checkedArgs)) (sequence $ zipWith matchParams params args)
|
||||
| constructorModifier == "private" = if checkAccess className (lookup "this" symtab)
|
||||
then fmap (\checkedArgs -> (ConstructorDeclaration constructorModifier name params (Block []), checkedArgs)) (sequence $ zipWith matchParams params args)
|
||||
else Nothing
|
||||
| otherwise = Nothing
|
||||
|
||||
validConstructors = filter (\(ConstructorDeclaration _ _ params _, _) -> length params == length args) $ mapMaybe matchConstructor constructors
|
||||
|
||||
expectedSignatures = [ map (\(ParameterDeclaration t _) -> t) params | ConstructorDeclaration _ _ params _ <- constructors ]
|
||||
actualSignature = map (\arg -> getTypeFromExpr (typeCheckExpression arg symtab classes)) args
|
||||
mismatchDetails = "Constructor not found for class '" ++ className ++ "' with given arguments.\n" ++
|
||||
"Expected signatures:\n" ++ show expectedSignatures ++
|
||||
"\nActual arguments:" ++ show actualSignature
|
||||
|
||||
in case validConstructors of
|
||||
[(ConstructorDeclaration _ _ params _, checkedArgs)] ->
|
||||
TypedStatementExpression className (ConstructorCall className checkedArgs)
|
||||
[] -> error mismatchDetails
|
||||
_ -> error $ "Multiple matching constructors found for class '" ++ className ++ "' with given arguments."
|
||||
|
||||
typeCheckStatementExpression (MethodCall expr methodName args) symtab classes =
|
||||
let objExprTyped = typeCheckExpression expr symtab classes
|
||||
in case objExprTyped of
|
||||
TypedExpression objType _ ->
|
||||
case find (\(Class className _ _ _ _) -> className == objType) classes of
|
||||
Just (Class className _ _ methods _) ->
|
||||
let matchParams (ParameterDeclaration paramType _) arg =
|
||||
let argTyped = typeCheckExpression arg symtab classes
|
||||
argType = getTypeFromExpr argTyped
|
||||
in if argType == "null" && isObjectType paramType
|
||||
then Just (TypedExpression paramType NullLiteral)
|
||||
else if argType == paramType
|
||||
then Just argTyped
|
||||
else Nothing
|
||||
|
||||
matchMethod (MethodDeclaration retType modifier name params _)
|
||||
| modifier == "public" = fmap (\checkedArgs -> (MethodDeclaration retType modifier name params (Block []), checkedArgs)) (sequence $ zipWith matchParams params args)
|
||||
| modifier == "private" = if checkAccess className (lookup "this" symtab)
|
||||
then fmap (\checkedArgs -> (MethodDeclaration retType modifier name params (Block []), checkedArgs)) (sequence $ zipWith matchParams params args)
|
||||
else Nothing
|
||||
| otherwise = Nothing
|
||||
|
||||
validMethods = filter (\(MethodDeclaration _ _ name params _, _) -> name == methodName && length params == length args) $ mapMaybe matchMethod methods
|
||||
|
||||
expectedSignatures = [ map (\(ParameterDeclaration t _) -> t) params | MethodDeclaration _ _ name params _ <- methods, name == methodName ]
|
||||
actualSignature = map (\arg -> getTypeFromExpr (typeCheckExpression arg symtab classes)) args
|
||||
mismatchDetails = "Method not found for class '" ++ objType ++ "' with given arguments.\n" ++
|
||||
"Expected signatures for method '" ++ methodName ++ "':\n" ++ unlines (map show expectedSignatures) ++
|
||||
"Actual arguments:\n" ++ show actualSignature
|
||||
|
||||
in case validMethods of
|
||||
[(MethodDeclaration retType _ _ params _, checkedArgs)] ->
|
||||
TypedStatementExpression retType (MethodCall objExprTyped methodName checkedArgs)
|
||||
[] -> error mismatchDetails
|
||||
_ -> error $ "Multiple matching methods found for class '" ++ objType ++ "' and method '" ++ methodName ++ "' with given arguments."
|
||||
|
||||
Nothing -> error $ "Class for object type '" ++ objType ++ "' not found."
|
||||
_ -> 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 **********************************
|
||||
|
||||
typeCheckStatement :: Statement -> [(Identifier, DataType)] -> [Class] -> Statement
|
||||
typeCheckStatement (If cond thenStmt elseStmt) symtab classes =
|
||||
let cond' = typeCheckExpression cond symtab classes
|
||||
thenStmt' = typeCheckStatement thenStmt symtab classes
|
||||
elseStmt' = case elseStmt of
|
||||
Just stmt -> Just (typeCheckStatement stmt symtab classes)
|
||||
Nothing -> Nothing
|
||||
in if getTypeFromExpr cond' == "boolean"
|
||||
then
|
||||
TypedStatement (getTypeFromStmt thenStmt') (If cond' thenStmt' elseStmt')
|
||||
else
|
||||
error "If condition must be of type boolean"
|
||||
let
|
||||
cond' = typeCheckExpression cond symtab classes
|
||||
thenStmt' = typeCheckStatement thenStmt symtab classes
|
||||
elseStmt' = fmap (\stmt -> typeCheckStatement stmt symtab classes) elseStmt
|
||||
|
||||
typeCheckStatement (LocalVariableDeclaration (VariableDeclaration dataType identifier maybeExpr)) symtab classes =
|
||||
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"
|
||||
then TypedStatement ifType (If cond' thenStmt' elseStmt')
|
||||
else error "If condition must be of type boolean"
|
||||
|
||||
typeCheckStatement (LocalVariableDeclaration (VariableDeclaration dataType modifier identifier maybeExpr)) symtab classes =
|
||||
-- Check for redefinition in the current scope
|
||||
if any ((== identifier) . snd) symtab
|
||||
then error $ "Variable '" ++ identifier ++ "' is redefined in the same scope"
|
||||
@@ -217,9 +303,16 @@ typeCheckStatement (LocalVariableDeclaration (VariableDeclaration dataType ident
|
||||
-- If there's an initializer expression, type check it
|
||||
let checkedExpr = fmap (\expr -> typeCheckExpression expr symtab classes) maybeExpr
|
||||
exprType = fmap getTypeFromExpr checkedExpr
|
||||
checkedExprWithType = case (exprType, dataType) of
|
||||
(Just "null", _) | isObjectType dataType -> Just (TypedExpression dataType NullLiteral)
|
||||
_ -> checkedExpr
|
||||
in case exprType of
|
||||
Just t | t /= dataType -> error $ "Type mismatch in declaration of '" ++ identifier ++ "': expected " ++ dataType ++ ", found " ++ t
|
||||
_ -> TypedStatement dataType (LocalVariableDeclaration (VariableDeclaration dataType identifier checkedExpr))
|
||||
Just t
|
||||
| t == "null" && isObjectType dataType ->
|
||||
TypedStatement dataType (LocalVariableDeclaration (VariableDeclaration dataType modifier identifier checkedExprWithType))
|
||||
| t /= dataType -> error $ "Type mismatch in declaration of '" ++ identifier ++ "': expected " ++ dataType ++ ", found " ++ t
|
||||
| otherwise -> TypedStatement dataType (LocalVariableDeclaration (VariableDeclaration dataType modifier identifier checkedExprWithType))
|
||||
Nothing -> TypedStatement dataType (LocalVariableDeclaration (VariableDeclaration dataType modifier identifier checkedExpr))
|
||||
|
||||
typeCheckStatement (While cond stmt) symtab classes =
|
||||
let cond' = typeCheckExpression cond symtab classes
|
||||
@@ -233,39 +326,69 @@ typeCheckStatement (While cond stmt) symtab classes =
|
||||
typeCheckStatement (Block statements) symtab classes =
|
||||
let
|
||||
processStatements (accSts, currentSymtab, types) stmt =
|
||||
let
|
||||
checkedStmt = typeCheckStatement stmt currentSymtab classes
|
||||
stmtType = getTypeFromStmt checkedStmt
|
||||
in case stmt of
|
||||
LocalVariableDeclaration (VariableDeclaration dataType identifier maybeExpr) ->
|
||||
case stmt of
|
||||
LocalVariableDeclaration (VariableDeclaration dataType modifier 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
|
||||
newSymtab = (identifier, dataType) : currentSymtab
|
||||
checkedStmt = typeCheckStatement stmt newSymtab classes
|
||||
in (accSts ++ [checkedStmt], newSymtab, 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)
|
||||
Return _ -> (accSts ++ [checkedStmt], currentSymtab, if stmtType /= "void" then types ++ [stmtType] else types)
|
||||
_ -> (accSts ++ [checkedStmt], currentSymtab, types)
|
||||
_ ->
|
||||
let
|
||||
checkedStmt = typeCheckStatement stmt currentSymtab classes
|
||||
stmtType = getTypeFromStmt checkedStmt
|
||||
in case stmt of
|
||||
If {} -> (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)
|
||||
Block _ -> (accSts ++ [checkedStmt], currentSymtab, if stmtType /= "void" then types ++ [stmtType] else types)
|
||||
_ -> (accSts ++ [checkedStmt], currentSymtab, types)
|
||||
|
||||
-- Initial accumulator: empty statements list, initial symbol table, empty types list
|
||||
(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
|
||||
|
||||
in TypedStatement blockType (Block checkedStatements)
|
||||
|
||||
typeCheckStatement (Return expr) symtab classes =
|
||||
let expr' = case expr of
|
||||
Just e -> Just (typeCheckExpression e symtab classes)
|
||||
let methodReturnType = fromMaybe (error "Method return type not found in symbol table") (lookup "thisMeth" symtab)
|
||||
expr' = case expr of
|
||||
Just e -> let eTyped = typeCheckExpression e symtab classes
|
||||
in if getTypeFromExpr eTyped == "null" && isObjectType methodReturnType
|
||||
then Just (TypedExpression methodReturnType NullLiteral)
|
||||
else Just eTyped
|
||||
Nothing -> Nothing
|
||||
in case expr' of
|
||||
Just e' -> TypedStatement (getTypeFromExpr e') (Return (Just e'))
|
||||
Nothing -> TypedStatement "Void" (Return Nothing)
|
||||
returnType = maybe "void" getTypeFromExpr expr'
|
||||
in if returnType == methodReturnType || isSubtype returnType methodReturnType classes
|
||||
then TypedStatement returnType (Return expr')
|
||||
else error $ "Return: Return type mismatch: expected " ++ methodReturnType ++ ", found " ++ returnType
|
||||
|
||||
typeCheckStatement (StatementExpressionStatement stmtExpr) symtab classes =
|
||||
let stmtExpr' = typeCheckStatementExpression stmtExpr symtab classes
|
||||
in TypedStatement (getTypeFromStmtExpr stmtExpr') (StatementExpressionStatement stmtExpr')
|
||||
|
||||
-- ********************************** 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 (TypedExpression t _) = t
|
||||
getTypeFromExpr _ = error "Untyped expression found where typed was expected"
|
||||
@@ -280,11 +403,74 @@ getTypeFromStmtExpr _ = error "Untyped statement expression found where typed wa
|
||||
|
||||
unifyReturnTypes :: DataType -> DataType -> DataType
|
||||
unifyReturnTypes dt1 dt2
|
||||
| dt1 == dt2 = dt1
|
||||
| otherwise = "Object"
|
||||
| dt1 == dt2 = dt1
|
||||
| dt1 == "null" = dt2
|
||||
| dt2 == "null" = dt1
|
||||
| otherwise = "Object"
|
||||
|
||||
resolveResultType :: DataType -> DataType -> DataType
|
||||
resolveResultType "char" "char" = "char"
|
||||
resolveResultType "int" "int" = "int"
|
||||
resolveResultType "char" "int" = "int"
|
||||
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 || (type1 == "null" && isObjectType type2) || (type2 == "null" && isObjectType type1) =
|
||||
TypedExpression "boolean" (BinaryOperation op expr1' expr2')
|
||||
| type1 /= type2 =
|
||||
error $ "Equality operation " ++ show op ++ " requires operands of the same type. Found types: " ++ type1 ++ " and " ++ type2
|
||||
| (type1 == "null" && not (isObjectType type2)) || (type2 == "null" && not (isObjectType type1)) =
|
||||
error $ "Equality operation " ++ show op ++ " requires that null can only be compared with object types. Found types: " ++ type1 ++ " and " ++ type2
|
||||
| otherwise = error $ "Equality operation " ++ show op ++ " encountered unexpected types: " ++ type1 ++ " and " ++ type2
|
||||
|
||||
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 fieldDetails = [(dt, mod) | VariableDeclaration dt mod id _ <- fields, id == ident2]
|
||||
className = objType
|
||||
in case fieldDetails of
|
||||
[(resolvedType, mod)] ->
|
||||
if mod == "public" || (mod == "private" && checkAccess objType (lookup "this" symtab))
|
||||
then TypedExpression resolvedType (BinaryOperation NameResolution expr1' (TypedExpression resolvedType (FieldVariable ident2)))
|
||||
else error $ "Field '" ++ ident2 ++ "' is private and cannot be accessed outside its class."
|
||||
[] -> 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"
|
||||
|
||||
|
||||
checkAccess :: DataType -> Maybe DataType -> Bool
|
||||
checkAccess objType (Just thisClass) = objType == thisClass
|
||||
checkAccess _ Nothing = False
|
||||
|
||||
lookupType :: Identifier -> [(Identifier, DataType)] -> DataType
|
||||
lookupType id symtab =
|
||||
case lookup id symtab of
|
||||
Just t -> t
|
||||
Nothing -> error ("Identifier " ++ id ++ " not found in symbol table")
|
||||
Reference in New Issue
Block a user