Compare commits

..

No commits in common. "master" and "documentation" have entirely different histories.

32 changed files with 727 additions and 1061 deletions

5
.gitignore vendored
View File

@ -26,8 +26,3 @@ cabal.project.local
cabal.project.local~ cabal.project.local~
.HTF/ .HTF/
.ghc.environment.* .ghc.environment.*
texput.log
doc/output/
doc/*.aux
doc/*.log
doc/*.out

View File

@ -5,7 +5,7 @@ Written in Haskell.
# Cabal Commands # Cabal Commands
run main run main
``` ```
cabal run compiler <FILENAME> cabal run
``` ```
run tests run tests

View File

@ -1,7 +1,7 @@
// compile all test files using: // compile all test files using:
// ls Test/JavaSources/*.java | grep -v ".*Main.java" | xargs -I {} cabal run compiler {} // ls Test/JavaSources/*.java | grep -v ".*Main.java" | xargs -I {} cabal run compiler {}
// compile (in project root) using: // compile (in project root) using:
// pushd Test/JavaSources; javac -g:none Main.java; popd // javac -g:none -sourcepath Test/JavaSources/ Test/JavaSources/Main.java
// afterwards, run using // afterwards, run using
// java -ea -cp Test/JavaSources/ Main // java -ea -cp Test/JavaSources/ Main
@ -11,39 +11,22 @@ public class Main {
TestEmpty empty = new TestEmpty(); TestEmpty empty = new TestEmpty();
TestFields fields = new TestFields(); TestFields fields = new TestFields();
TestConstructor constructor = new TestConstructor(42); TestConstructor constructor = new TestConstructor(42);
TestArithmetic arithmetic = new TestArithmetic();
TestMultipleClasses multipleClasses = new TestMultipleClasses(); TestMultipleClasses multipleClasses = new TestMultipleClasses();
TestRecursion recursion = new TestRecursion(10); TestRecursion recursion = new TestRecursion(10);
TestMalicious malicious = new TestMalicious(); 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 // constructing a basic class works
assert empty != null; assert empty != null;
// initializers (and default initializers to 0/null) work // initializers (and default initializers to 0/null) work
assert fields.a == 0 && fields.b == 42; assert fields.a == 0 && fields.b == 42;
// constructor parameters override initializers // constructor parameters override initializers
assert constructor.a == 42; 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. // multiple classes within one file work. Referencing another classes fields/methods works.
assert multipleClasses.a.a == 42; assert multipleClasses.a.a == 42;
// self-referencing classes work. // self-referencing classes work.
assert recursion.child.child.child.child.child.value == 5; assert recursion.child.child.child.child.child.value == 5;
// self-referencing methods work. // self-referencing methods work.
assert recursion.fibonacci(15) == 610; 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 // intentionally dodgy expressions work
assert malicious.assignNegativeIncrement(42) == -42; assert malicious.assignNegativeIncrement(42) == -42;
assert malicious.tripleAddition(1, 2, 3) == 6; assert malicious.tripleAddition(1, 2, 3) == 6;
@ -51,14 +34,5 @@ public class Main {
{ {
assert malicious.cursedFormatting(i) == 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;
} }
} }

View File

@ -1,11 +0,0 @@
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);
}
}

View File

@ -1,12 +0,0 @@
public class TestConstructorOverload {
public int a = 42;
TestConstructorOverload() {
// nothing here, so a will assume the default value 42.
}
TestConstructorOverload(int a) {
this.a = a;
}
}

View File

@ -1,19 +0,0 @@
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;
}
}

View File

@ -1,10 +0,0 @@
public class TestMethodOverload {
public int MethodOverload() {
return 42;
}
public int MethodOverload(int a) {
return 42 + a;
}
}

View File

@ -1,10 +0,0 @@
class TestOptionalParameter {
int oneOptional(int p = 1) {
return p;
}
int normalAndOptional(int a, int b = 2, int c = 3) {
return a + b + c;
}
}

View File

@ -5,7 +5,7 @@ public class TestRecursion {
public TestRecursion(int n) public TestRecursion(int n)
{ {
this.value = n; value = n;
if(n > 0) if(n > 0)
{ {
@ -23,12 +23,5 @@ public class TestRecursion {
{ {
return fibonacci(n - 1) + this.fibonacci(n - 2); 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));
}
} }

View File

@ -1,25 +0,0 @@
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;
}
}
}

View File

@ -1,15 +0,0 @@
public class TestSingleton {
TestSingleton instance;
TestSingleton() {
}
public TestSingleton getInstance() {
if (instance == null) {
instance = new TestSingleton();
}
return instance;
}
}

View File

@ -7,56 +7,56 @@ import Ast
testSingleEmptyClass = TestCase $ testSingleEmptyClass = TestCase $
assertEqual "expect single empty class hello" [Class "Hello" [] [] []] $ assertEqual "expect single empty class hello" [Class "Hello" [] []] $
parse [CLASS, IDENTIFIER "Hello", LBRACKET, RBRACKET] parse [CLASS, IDENTIFIER "Hello", LBRACKET, RBRACKET]
testTwoEmptyClasses = TestCase $ testTwoEmptyClasses = TestCase $
assertEqual "expect two empty classes" [Class "Class1" [] [] [], Class "Class2" [] [] []] $ assertEqual "expect two empty classes" [Class "Class1" [] [], Class "Class2" [] []] $
parse [CLASS,IDENTIFIER "Class1",LBRACKET,RBRACKET,CLASS,IDENTIFIER "Class2",LBRACKET,RBRACKET] parse [CLASS,IDENTIFIER "Class1",LBRACKET,RBRACKET,CLASS,IDENTIFIER "Class2",LBRACKET,RBRACKET]
testBooleanField = TestCase $ testBooleanField = TestCase $
assertEqual "expect class with boolean field" [Class "WithBool" [] [] [VariableDeclaration "boolean" "value" Nothing]] $ assertEqual "expect class with boolean field" [Class "WithBool" [] [VariableDeclaration "boolean" "value" Nothing]] $
parse [CLASS,IDENTIFIER "WithBool",LBRACKET,BOOLEAN,IDENTIFIER "value",SEMICOLON,RBRACKET] parse [CLASS,IDENTIFIER "WithBool",LBRACKET,BOOLEAN,IDENTIFIER "value",SEMICOLON,RBRACKET]
testIntField = TestCase $ testIntField = TestCase $
assertEqual "expect class with int field" [Class "WithInt" [] [] [VariableDeclaration "int" "value" Nothing]] $ assertEqual "expect class with int field" [Class "WithInt" [] [VariableDeclaration "int" "value" Nothing]] $
parse [CLASS,IDENTIFIER "WithInt",LBRACKET,INT,IDENTIFIER "value",SEMICOLON,RBRACKET] parse [CLASS,IDENTIFIER "WithInt",LBRACKET,INT,IDENTIFIER "value",SEMICOLON,RBRACKET]
testCustomTypeField = TestCase $ testCustomTypeField = TestCase $
assertEqual "expect class with foo field" [Class "WithFoo" [] [] [VariableDeclaration "Foo" "value" Nothing]] $ assertEqual "expect class with foo field" [Class "WithFoo" [] [VariableDeclaration "Foo" "value" Nothing]] $
parse [CLASS,IDENTIFIER "WithFoo",LBRACKET,IDENTIFIER "Foo",IDENTIFIER "value",SEMICOLON,RBRACKET] parse [CLASS,IDENTIFIER "WithFoo",LBRACKET,IDENTIFIER "Foo",IDENTIFIER "value",SEMICOLON,RBRACKET]
testMultipleDeclarationSameLine = TestCase $ testMultipleDeclarationSameLine = TestCase $
assertEqual "expect class with two int fields" [Class "TwoInts" [] [] [VariableDeclaration "int" "num1" Nothing, VariableDeclaration "int" "num2" Nothing]] $ 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] parse [CLASS,IDENTIFIER "TwoInts",LBRACKET,INT,IDENTIFIER "num1",COMMA,IDENTIFIER "num2",SEMICOLON,RBRACKET]
testMultipleDeclarations = TestCase $ testMultipleDeclarations = TestCase $
assertEqual "expect class with int and char field" [Class "Multiple" [] [] [VariableDeclaration "int" "value" Nothing, VariableDeclaration "char" "letter" Nothing]] $ 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] parse [CLASS,IDENTIFIER "Multiple",LBRACKET,INT,IDENTIFIER "value",SEMICOLON,CHAR,IDENTIFIER "letter",SEMICOLON,RBRACKET]
testWithModifier = TestCase $ testWithModifier = TestCase $
assertEqual "expect class with int field" [Class "WithInt" [] [] [VariableDeclaration "int" "value" Nothing]] $ assertEqual "expect class with int field" [Class "WithInt" [] [VariableDeclaration "int" "value" Nothing]] $
parse [ABSTRACT,CLASS,IDENTIFIER "WithInt",LBRACKET,PUBLIC,INT,IDENTIFIER "value",SEMICOLON,RBRACKET] parse [ABSTRACT,CLASS,IDENTIFIER "WithInt",LBRACKET,PUBLIC,INT,IDENTIFIER "value",SEMICOLON,RBRACKET]
testEmptyMethod = TestCase $ testEmptyMethod = TestCase $
assertEqual "expect class with method" [Class "WithMethod" [] [MethodDeclaration "int" "foo" [] (Block [])] []] $ assertEqual "expect class with method" [Class "WithMethod" [MethodDeclaration "int" "foo" [] (Block [])] []] $
parse [CLASS,IDENTIFIER "WithMethod",LBRACKET,INT,IDENTIFIER "foo",LBRACE,RBRACE,SEMICOLON,RBRACKET] parse [CLASS,IDENTIFIER "WithMethod",LBRACKET,INT,IDENTIFIER "foo",LBRACE,RBRACE,SEMICOLON,RBRACKET]
testEmptyPrivateMethod = TestCase $ testEmptyPrivateMethod = TestCase $
assertEqual "expect class with method" [Class "WithMethod" [] [MethodDeclaration "int" "foo" [] (Block [])] []] $ 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] parse [CLASS,IDENTIFIER "WithMethod",LBRACKET,PRIVATE,INT,IDENTIFIER "foo",LBRACE,RBRACE,LBRACKET,RBRACKET,RBRACKET]
testEmptyVoidMethod = TestCase $ testEmptyVoidMethod = TestCase $
assertEqual "expect class with method" [Class "WithMethod" [] [MethodDeclaration "void" "foo" [] (Block [])] []] $ assertEqual "expect class with method" [Class "WithMethod" [MethodDeclaration "void" "foo" [] (Block [])] []] $
parse [CLASS,IDENTIFIER "WithMethod",LBRACKET,VOID,IDENTIFIER "foo",LBRACE,RBRACE,LBRACKET,RBRACKET,RBRACKET] parse [CLASS,IDENTIFIER "WithMethod",LBRACKET,VOID,IDENTIFIER "foo",LBRACE,RBRACE,LBRACKET,RBRACKET,RBRACKET]
testEmptyMethodWithParam = TestCase $ testEmptyMethodWithParam = TestCase $
assertEqual "expect class with method with param" [Class "WithParam" [] [MethodDeclaration "void" "foo" [ParameterDeclaration "int" "param"] (Block [])] []] $ 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] parse [CLASS,IDENTIFIER "WithParam",LBRACKET,VOID,IDENTIFIER "foo",LBRACE,INT,IDENTIFIER "param",RBRACE,SEMICOLON,RBRACKET]
testEmptyMethodWithParams = TestCase $ testEmptyMethodWithParams = TestCase $
assertEqual "expect class with multiple params" [Class "WithParams" [] [MethodDeclaration "void" "foo" [ParameterDeclaration "int" "p1",ParameterDeclaration "Custom" "p2"] (Block [])] []] $ 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] parse [CLASS,IDENTIFIER "WithParams",LBRACKET,VOID,IDENTIFIER "foo",LBRACE,INT,IDENTIFIER "p1",COMMA,IDENTIFIER "Custom",IDENTIFIER "p2",RBRACE,SEMICOLON,RBRACKET]
testClassWithMethodAndField = TestCase $ testClassWithMethodAndField = TestCase $
assertEqual "expect class with method and field" [Class "WithMethodAndField" [] [MethodDeclaration "void" "foo" [] (Block []), MethodDeclaration "int" "bar" [] (Block [])] [VariableDeclaration "int" "value" Nothing]] $ 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] 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 $ testClassWithConstructor = TestCase $
assertEqual "expect class with constructor" [Class "WithConstructor" [ConstructorDeclaration "WithConstructor" [] (Block [])] [] []] $ assertEqual "expect class with constructor" [Class "WithConstructor" [MethodDeclaration "void" "<init>" [] (Block [])] []] $
parse [CLASS,IDENTIFIER "WithConstructor",LBRACKET,IDENTIFIER "WithConstructor",LBRACE,RBRACE,LBRACKET,RBRACKET,RBRACKET] parse [CLASS,IDENTIFIER "WithConstructor",LBRACKET,IDENTIFIER "WithConstructor",LBRACE,RBRACE,LBRACKET,RBRACKET,RBRACKET]
testConstructorWithParams = TestCase $ testConstructorWithParams = TestCase $
assertEqual "expect constructor with params" [Class "WithParams" [ConstructorDeclaration "WithParams" [ParameterDeclaration "int" "p1"] (Block [])] [] []] $ assertEqual "expect constructor with params" [Class "WithParams" [MethodDeclaration "void" "<init>" [ParameterDeclaration "int" "p1"] (Block [])] []] $
parse [CLASS,IDENTIFIER "WithParams",LBRACKET,IDENTIFIER "WithParams",LBRACE,INT,IDENTIFIER "p1",RBRACE,LBRACKET,RBRACKET,RBRACKET] parse [CLASS,IDENTIFIER "WithParams",LBRACKET,IDENTIFIER "WithParams",LBRACE,INT,IDENTIFIER "p1",RBRACE,LBRACKET,RBRACKET,RBRACKET]
testConstructorWithStatements = TestCase $ testConstructorWithStatements = TestCase $
assertEqual "expect constructor with statement" [Class "WithConstructor" [ConstructorDeclaration "WithConstructor" [] (Block [Return Nothing])] [] []] $ assertEqual "expect constructor with statement" [Class "WithConstructor" [MethodDeclaration "void" "<init>" [] (Block [Return Nothing])] []] $
parse [CLASS,IDENTIFIER "WithConstructor",LBRACKET,IDENTIFIER "WithConstructor",LBRACE,RBRACE,LBRACKET,RETURN,SEMICOLON,RBRACKET,RBRACKET] parse [CLASS,IDENTIFIER "WithConstructor",LBRACKET,IDENTIFIER "WithConstructor",LBRACE,RBRACE,LBRACKET,RETURN,SEMICOLON,RBRACKET,RBRACKET]
@ -78,13 +78,13 @@ testExpressionIntLiteral = TestCase $
assertEqual "expect IntLiteral" (IntegerLiteral 3) $ assertEqual "expect IntLiteral" (IntegerLiteral 3) $
parseExpression [INTEGERLITERAL 3] parseExpression [INTEGERLITERAL 3]
testFieldWithInitialization = TestCase $ testFieldWithInitialization = TestCase $
assertEqual "expect Class with initialized field" [Class "WithInitField" [] [] [VariableDeclaration "int" "number" $ Just $ IntegerLiteral 3]] $ 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] parse [CLASS,IDENTIFIER "WithInitField",LBRACKET,INT,IDENTIFIER "number",ASSIGN,INTEGERLITERAL 3,SEMICOLON,RBRACKET]
testLocalBoolWithInitialization = TestCase $ testLocalBoolWithInitialization = TestCase $
assertEqual "expect block with with initialized local var" [Block [LocalVariableDeclaration $ VariableDeclaration "boolean" "b" $ Just $ BooleanLiteral False]] $ 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] parseStatement [LBRACKET,BOOLEAN,IDENTIFIER "b",ASSIGN,BOOLLITERAL False,SEMICOLON,RBRACKET]
testFieldNullWithInitialization = TestCase $ testFieldNullWithInitialization = TestCase $
assertEqual "expect Class with initialized field" [Class "WithInitField" [] [] [VariableDeclaration "Object" "bar" $ Just NullLiteral]] $ 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] parse [CLASS,IDENTIFIER "WithInitField",LBRACKET,IDENTIFIER "Object",IDENTIFIER "bar",ASSIGN,NULLLITERAL,SEMICOLON,RBRACKET]
testReturnVoid = TestCase $ testReturnVoid = TestCase $
assertEqual "expect block with return nothing" [Block [Return Nothing]] $ assertEqual "expect block with return nothing" [Block [Return Nothing]] $
@ -204,13 +204,6 @@ testExpressionConstructorCall = TestCase $
assertEqual "expect constructor call" (StatementExpressionExpression (ConstructorCall "Foo" [])) $ assertEqual "expect constructor call" (StatementExpressionExpression (ConstructorCall "Foo" [])) $
parseExpression [NEW,IDENTIFIER "Foo",LBRACE,RBRACE] 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 $ testStatementIfThen = TestCase $
assertEqual "expect empty ifthen" [If (Reference "a") (Block [Block []]) Nothing] $ assertEqual "expect empty ifthen" [If (Reference "a") (Block [Block []]) Nothing] $
parseStatement [IF,LBRACE,IDENTIFIER "a",RBRACE,LBRACKET,RBRACKET] parseStatement [IF,LBRACE,IDENTIFIER "a",RBRACE,LBRACKET,RBRACKET]
@ -238,40 +231,6 @@ testStatementPreIncrement = TestCase $
assertEqual "expect increment" [StatementExpressionStatement $ PostIncrement $ Reference "a"] $ assertEqual "expect increment" [StatementExpressionStatement $ PostIncrement $ Reference "a"] $
parseStatement [IDENTIFIER "a",INCREMENT,SEMICOLON] 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 [ tests = TestList [
testSingleEmptyClass, testSingleEmptyClass,
@ -333,8 +292,6 @@ tests = TestList [
testExpressionSimpleFieldAccess, testExpressionSimpleFieldAccess,
testExpressionFieldSubAccess, testExpressionFieldSubAccess,
testExpressionConstructorCall, testExpressionConstructorCall,
testExpresssionExternalMethodCall,
testExpressionAssignWithThis,
testStatementIfThen, testStatementIfThen,
testStatementIfThenElse, testStatementIfThenElse,
testStatementWhile, testStatementWhile,
@ -342,11 +299,5 @@ tests = TestList [
testStatementMethodCallNoParams, testStatementMethodCallNoParams,
testStatementConstructorCall, testStatementConstructorCall,
testStatementConstructorCallWithArgs, testStatementConstructorCallWithArgs,
testStatementPreIncrement, testStatementPreIncrement
testForLoop,
testForLoopExpressionlistInInit,
testForLoopMultipleUpdateExpressions,
testForLoopEmptyFirstPart,
testForLoopEmtpySecondPart,
testForLoopEmtpy
] ]

69
doc/bytecode.md Normal file
View File

@ -0,0 +1,69 @@
# Bytecodegenerierung
Die Bytecodegenerierung ist letztendlich eine zweistufige Transformation:
`Getypter AST -> [ClassFile] -> [[Word8]]`
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.
## 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 [so definiert](https://docs.oracle.com/javase/specs/jvms/se7/html/jvms-4.html).
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. Alle diese Strukturen implementieren folgendes TypeClass:
```
class Serializable a where
serialize :: a -> [Word8]
```
Die Struktur ClassFile ruft für deren Kinder rekursiv diese `serialize` Funktion auf. Am Ende bleibt eine flache Word8-Liste übrig, die Serialisierung ist damit abgeschlossen.
## Codegenerierung
Für die erste der beiden Transformationen (`Getypter AST -> [ClassFile]`) werden die Konzepte der "Builder" und "Assembler" eingeführt. Sie sind wie folgt definiert:
```
type ClassFileBuilder a = a -> ClassFile -> ClassFile
type Assembler a = ([ConstantInfo], [Operation], [String]) -> a -> ([ConstantInfo], [Operation], [String])
```
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 `classBuilder` auf. Diese wendet nach und nach folgende Transformationen an:
```
methodsWithInjectedConstructor = injectDefaultConstructor methods
methodsWithInjectedInitializers = injectFieldInitializers name fields methodsWithInjectedConstructor
classFileWithFields = foldr fieldBuilder nakedClassFile fields
classFileWithMethods = foldr methodBuilder classFileWithFields methodsWithInjectedInitializers
classFileWithAssembledMethods = foldr methodAssembler classFileWithMethods methodsWithInjectedInitializers
```
Zuerst wird (falls notwendig) ein leerer Defaultkonstruktor in die Classfile eingefügt. Anschließend wird der AST so modifiziert, dass die Initialisierungen für alle Klassenfelder in allen Konstruktoren stattfinden. Nun beginnen die Faltungen:
1. Hinzufügen aller Klassenfelder
2. Hinzufügen aller Methoden (nur Prototypen)
3. Hinzufügen des Bytecodes in allen Methoden
Die Unterteilung von Schritt 2 und 3 ist deswegen notwendig, weil der Code einer Methode auch eine andere, erst nachher deklarierte Methode aufrufen kann. Nach Schritt 2 sind alle Methoden der Klasse bekannt. Wie beschrieben wird auch hier der Zustand über alle Faltungen mitgenommen. Jeder Schritt hat Zugriff auf alle Daten, die aus dem vorherigen Schritt bleiben. Sukkzessive wird eine korrekte ClassFile aufgebaut.
Besonders interessant ist hierbei Schritt 3. Dort wird das Verhalten jeder einzelnen Methode in Bytecode übersetzt. In diesem Schritt werden zusätzlich zu den `Buildern` noch die `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:
`([ConstantInfo], [Operation], [String])`
Dieses repräsentiert:
`(Konstantenpool, Bytecode, Lokale Variablen)`
In der Praxis werden oft nur Bytecode und Konstanten hinzugefügt. Prinzipiell können Assembler auch Code/Konstanten entfernen oder modifizieren. Als Beispiel dient hier der Assembler `assembleExpression`:
```
assembleExpression (constants, ops, lvars) (TypedExpression _ NullLiteral) =
(constants, ops ++ [Opaconst_null], lvars)
```
Hier werden die Konstanten und lokalen Variablen des Inputs nicht berührt, dem Bytecode wird lediglich die Operation `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 `methodAssembler`. Dieser entspricht Schritt 3 in der obigen Übersicht.

View File

@ -1,107 +0,0 @@
\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.

Binary file not shown.

View File

@ -1,67 +0,0 @@
\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,
}
%for code listings
\usepackage{listings}
\usepackage{xcolor}
\definecolor{ListingBackground}{HTML}{F8F8F8}
\lstdefinestyle{mystyle}{
language=Java, % default language
numbers=left, % position of line numbers (left, right)
stepnumber=1, % set number to each line
numbersep=5pt, % 5pt between number and source code
numberstyle=\tiny, % letter size of numbers
breaklines=true, % break lines if necessary (true, false)
breakautoindent=true, % indenting after break line (true, false)
postbreak=\space, % break line after space
tabsize=2, % tabulator size
basicstyle=\ttfamily\footnotesize, % font style
showspaces=false, % show space (true, false)
extendedchars=true, % show all Latin1 characters (true, false)
captionpos=b, % sets the caption-position to bottom
backgroundcolor=\color{ListingBackground}, % source code background
xleftmargin=10pt, % margin left
xrightmargin=5pt, % margin right
frame=single, % border settings
frameround=ffff,
rulecolor=\color{darkgray}, % border color
fillcolor=\color{ListingBackground},
aboveskip=20pt,
keywordstyle=\color[rgb]{0.133,0.133,0.6},
commentstyle=\color[rgb]{0.133,0.545,0.133},
stringstyle=\color[rgb]{0.627,0.126,0.941}
}
\lstset{style=mystyle}
\let\clearpage\relax
\begin{document}
\include{features}
\newpage
\include{parser}
\newpage
\include{typecheck}
\newpage
\include{bytecode}
\newpage
\include{whodunit}
\newpage
\end{document}

View File

@ -1,35 +0,0 @@
\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}[noitemsep]
\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
\item Parameter mit Standardwerten
\end{itemize}

5
doc/generate.sh Normal file → Executable file
View File

@ -1 +1,4 @@
pdflatex documentation.tex #!/usr/bin/sh
pandoc bytecode.md -o bytecode.docx
pandoc bytecode.md -o bytecode.pdf

View File

@ -1,88 +0,0 @@
\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 für die einzelnen Regeln noch die Rückgabewerte angeben.
Um den Parser aufzubauen wurde zuerst ein Großteil der Grammatik auskommentiert und Stück für Stück wurden die Rückgabewerte 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, welcher eines von den drei enthalten kann. Die \verb|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.
\pagebreak
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.
\subsubsection{Syntactic Sugar}
In Java ist es möglich mehrere Variablen in einer Zeile zu deklarieren (Bsp.: \verb|int x, y;|). Beim Parsen ergibt sich dann die Schwierigkeit, dass man in dem Moment, in dem 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 \verb|fielddeclaration| und \verb|localvariabledeclaration| wird dann die Typinformation hinzugefügt mithilfe der Funktion \verb|convertDeclarator|.
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 wurden 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}
Es wurden auch Parameter mit Standardwerten im Parser implementiert. Dieses Feature ist in der aktuellen Java Version (Java 22) noch nicht implementiert. Der Parser macht sich dafür das Überladen von Methoden zunutze. Er generiert für jedes Parameter mit Standardwert eine weitere Funktion, welche die ursprüngliche Funktion mit einem Standardwert aufruft.
%\lstinputlisting[language=Java,firstline=7,lastline=9]{../Test/JavaSources/TestOptionalParameter.java}
\begin{lstlisting}[language=Java]
int normalAndOptional(int a, int b = 2, int c = 3) {
return a + b + c;
}
\end{lstlisting}
wird umgewandelt in:
\begin{lstlisting}
int normalAndOptional(int a) {
return normalAndOptional(a, 2);
}
int normalAndOptional(int a, int b) {
return normalAndOptional(a, b, 3);
}
int normalAndOptional(int a, int b, int c) {
return a + b + c;
}
\end{lstlisting}

55
doc/typecheck.md Normal file
View File

@ -0,0 +1,55 @@
# Typcheck (Fabian Noll)
## Überblick und Struktur
Die Typprüfung beginnt mit der Funktion `typeCheckCompilationUnit`, die eine Kompilationseinheit als Eingabe erhält. Diese Kompilationseinheit besteht aus einer Liste von Klassen. Jede Klasse wird einzeln durch die Funktion `typeCheckClass` überprüft. Innerhalb dieser Funktion wird eine Symboltabelle erstellt, die den Namen der Klasse als Typ und `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 Methoden und Felder. Die Methode `typeCheckMethodDeclaration` ist für die Typprüfung einzelner Methodendeklarationen verantwortlich. Sie überprüft den Rückgabetyp der Methode, die Parameter und den Methodenrumpf. Der Methodenrumpf wird durch rekursive Aufrufe von `typeCheckStatement` überprüft, die verschiedene Arten von Anweisungen wie If-Anweisungen, While-Schleifen, Rückgabeanweisungen und Blockanweisungen behandelt.
## Ablauf und 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.
### Anpassung der Symboltabelle
- **Klassenkontext**:
Beim Typcheck einer Klasse wird eine initiale Symboltabelle erstellt, die die `this`-Referenz enthält. Dies geschieht in der Funktion `typeCheckClass`.
- **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 `typeCheckMethodDeclaration`.
- **Blockkontext**:
Bei der Überprüfung eines Blocks (`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.
### Unterscheidung zwischen lokalen und Feldvariablen
Bei der Typprüfung von Referenzen (`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 `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 `this`-Referenz.
## 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:
- **Typinkonsistenzen**:
Wenn der Rückgabetyp einer Methode nicht mit dem deklarierten Rückgabetyp übereinstimmt. Oder aber auch die Anzahl der Parameter nicht übereinstimmt.
- **Ungültige Operationen**:
Wenn eine arithmetische Operation auf inkompatiblen Typen durchgeführt wird.
- **Nicht gefundene Bezeichner**:
Wenn eine Referenz auf eine nicht definierte Variable verweist.
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.
## Typprüfung von Kontrollstrukturen und Blöcken
### If-Anweisungen
Bei der Typprüfung einer If-Anweisung (`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 `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 `void` erzwungen wird. Dadurch weiß der Typchecker Bescheid.
### Block-Anweisungen
Die Typprüfung eines Blocks erfolgt in `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 `void` angenommen.
### Rückgabeanweisungen
Die Typprüfung einer Rückgabeanweisung (`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 `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 `Object` ist, der Return-Wert auch eine tatsächlich existierende Klasse ist, indem in die Klassentabelle geschaut wird.

View File

@ -1,105 +0,0 @@
\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}

View File

@ -1,19 +0,0 @@
\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.

View File

@ -18,6 +18,7 @@ executable compiler
other-modules: Parser.Lexer, other-modules: Parser.Lexer,
Parser.JavaParser, Parser.JavaParser,
Ast, Ast,
Example,
Typecheck, Typecheck,
ByteCode.Util, ByteCode.Util,
ByteCode.ByteUtil, ByteCode.ByteUtil,
@ -41,4 +42,10 @@ test-suite tests
Parser.JavaParser, Parser.JavaParser,
Ast, Ast,
TestLexer, TestLexer,
TestParser TestParser,
ByteCode.Util,
ByteCode.ByteUtil,
ByteCode.ClassFile,
ByteCode.Assembler,
ByteCode.Builder,
ByteCode.Constants

View File

@ -2,13 +2,12 @@ module Ast where
type CompilationUnit = [Class] type CompilationUnit = [Class]
type DataType = String type DataType = String
type Identifier = String type Identifier = String
data ParameterDeclaration = ParameterDeclaration DataType Identifier deriving (Show, Eq) data ParameterDeclaration = ParameterDeclaration DataType Identifier deriving (Show, Eq)
data VariableDeclaration = VariableDeclaration DataType Identifier (Maybe Expression) deriving (Show, Eq) data VariableDeclaration = VariableDeclaration DataType Identifier (Maybe Expression) deriving (Show, Eq)
data Class = Class DataType [ConstructorDeclaration] [MethodDeclaration] [VariableDeclaration] deriving (Show, Eq) data Class = Class DataType [MethodDeclaration] [VariableDeclaration] deriving (Show, Eq)
data MethodDeclaration = MethodDeclaration DataType Identifier [ParameterDeclaration] Statement deriving (Show, Eq) data MethodDeclaration = MethodDeclaration DataType Identifier [ParameterDeclaration] Statement deriving (Show, Eq)
data ConstructorDeclaration = ConstructorDeclaration Identifier [ParameterDeclaration] Statement deriving (Show, Eq)
data Statement data Statement
= If Expression Statement (Maybe Statement) = If Expression Statement (Maybe Statement)
@ -24,11 +23,11 @@ data StatementExpression
= Assignment Expression Expression = Assignment Expression Expression
| ConstructorCall DataType [Expression] | ConstructorCall DataType [Expression]
| MethodCall Expression Identifier [Expression] | MethodCall Expression Identifier [Expression]
| TypedStatementExpression DataType StatementExpression
| PostIncrement Expression | PostIncrement Expression
| PostDecrement Expression | PostDecrement Expression
| PreIncrement Expression | PreIncrement Expression
| PreDecrement Expression | PreDecrement Expression
| TypedStatementExpression DataType StatementExpression
deriving (Show, Eq) deriving (Show, Eq)
data BinaryOperator data BinaryOperator

View File

@ -12,12 +12,12 @@ type Assembler a = ([ConstantInfo], [Operation], [String]) -> a -> ([ConstantInf
assembleExpression :: Assembler Expression assembleExpression :: Assembler Expression
assembleExpression (constants, ops, lvars) (TypedExpression _ (BinaryOperation op a b)) assembleExpression (constants, ops, lvars) (TypedExpression _ (BinaryOperation op a b))
| op `elem` [Addition, Subtraction, Multiplication, Division, Modulo, BitwiseAnd, BitwiseOr, BitwiseXor, And, Or] = let | elem op [Addition, Subtraction, Multiplication, Division, Modulo, BitwiseAnd, BitwiseOr, BitwiseXor, And, Or] = let
(aConstants, aOps, _) = assembleExpression (constants, ops, lvars) a (aConstants, aOps, _) = assembleExpression (constants, ops, lvars) a
(bConstants, bOps, _) = assembleExpression (aConstants, aOps, lvars) b (bConstants, bOps, _) = assembleExpression (aConstants, aOps, lvars) b
in in
(bConstants, bOps ++ [binaryOperation op], lvars) (bConstants, bOps ++ [binaryOperation op], lvars)
| op `elem` [CompareEqual, CompareNotEqual, CompareLessThan, CompareLessOrEqual, CompareGreaterThan, CompareGreaterOrEqual] = let | elem op [CompareEqual, CompareNotEqual, CompareLessThan, CompareLessOrEqual, CompareGreaterThan, CompareGreaterOrEqual] = let
(aConstants, aOps, _) = assembleExpression (constants, ops, lvars) a (aConstants, aOps, _) = assembleExpression (constants, ops, lvars) a
(bConstants, bOps, _) = assembleExpression (aConstants, aOps, lvars) b (bConstants, bOps, _) = assembleExpression (aConstants, aOps, lvars) b
cmp_op = comparisonOperation op 9 cmp_op = comparisonOperation op 9
@ -60,7 +60,7 @@ assembleExpression (constants, ops, lvars) (TypedExpression _ (UnaryOperation Mi
assembleExpression (constants, ops, lvars) (TypedExpression dtype (LocalVariable name)) assembleExpression (constants, ops, lvars) (TypedExpression dtype (LocalVariable name))
| name == "this" = (constants, ops ++ [Opaload 0], lvars) | name == "this" = (constants, ops ++ [Opaload 0], lvars)
| otherwise = let | otherwise = let
localIndex = elemIndex name lvars localIndex = findIndex ((==) name) lvars
isPrimitive = elem dtype ["char", "boolean", "int"] isPrimitive = elem dtype ["char", "boolean", "int"]
in case localIndex of in case localIndex of
Just index -> (constants, ops ++ if isPrimitive then [Opiload (fromIntegral index)] else [Opaload (fromIntegral index)], lvars) Just index -> (constants, ops ++ if isPrimitive then [Opiload (fromIntegral index)] else [Opaload (fromIntegral index)], lvars)
@ -69,7 +69,7 @@ assembleExpression (constants, ops, lvars) (TypedExpression dtype (LocalVariable
assembleExpression (constants, ops, lvars) (TypedExpression dtype (StatementExpressionExpression stmtexp)) = assembleExpression (constants, ops, lvars) (TypedExpression dtype (StatementExpressionExpression stmtexp)) =
assembleStatementExpression (constants, ops, lvars) stmtexp assembleStatementExpression (constants, ops, lvars) stmtexp
assembleExpression _ expr = error ("Unknown expression: " ++ show expr) assembleExpression _ expr = error ("unimplemented: " ++ show expr)
assembleNameChain :: Assembler Expression assembleNameChain :: Assembler Expression
assembleNameChain input (TypedExpression _ (BinaryOperation NameResolution (TypedExpression atype a) (TypedExpression _ (FieldVariable _)))) = assembleNameChain input (TypedExpression _ (BinaryOperation NameResolution (TypedExpression atype a) (TypedExpression _ (FieldVariable _)))) =
@ -84,7 +84,7 @@ assembleStatementExpression
target = resolveNameChain (TypedExpression dtype receiver) target = resolveNameChain (TypedExpression dtype receiver)
in case target of in case target of
(TypedExpression dtype (LocalVariable name)) -> let (TypedExpression dtype (LocalVariable name)) -> let
localIndex = elemIndex name lvars localIndex = findIndex ((==) name) lvars
(constants_a, ops_a, _) = assembleExpression (constants, ops, lvars) expr (constants_a, ops_a, _) = assembleExpression (constants, ops, lvars) expr
isPrimitive = elem dtype ["char", "boolean", "int"] isPrimitive = elem dtype ["char", "boolean", "int"]
in case localIndex of in case localIndex of
@ -99,20 +99,20 @@ assembleStatementExpression
(constants_a, ops_a, _) = assembleExpression (constants_r, ops_r, lvars) expr (constants_a, ops_a, _) = assembleExpression (constants_r, ops_r, lvars) expr
in in
(constants_a, ops_a ++ [Opdup_x1, Opputfield (fromIntegral fieldIndex)], lvars) (constants_a, ops_a ++ [Opdup_x1, Opputfield (fromIntegral fieldIndex)], lvars)
something_else -> error ("Expected TypedExpression, but got: " ++ show something_else) something_else -> error ("expected TypedExpression, but got: " ++ show something_else)
assembleStatementExpression assembleStatementExpression
(constants, ops, lvars) (constants, ops, lvars)
(TypedStatementExpression _ (PreIncrement (TypedExpression dtype receiver))) = let (TypedStatementExpression _ (PreIncrement (TypedExpression dtype receiver))) = let
target = resolveNameChain (TypedExpression dtype receiver) target = resolveNameChain (TypedExpression dtype receiver)
in case target of in case target of
(TypedExpression dtype (LocalVariable name)) -> let (TypedExpression dtype (LocalVariable name)) -> let
localIndex = elemIndex name lvars localIndex = findIndex ((==) name) lvars
expr = TypedExpression dtype (LocalVariable name) expr = (TypedExpression dtype (LocalVariable name))
(exprConstants, exprOps, _) = assembleExpression (constants, ops, lvars) expr (exprConstants, exprOps, _) = assembleExpression (constants, ops, lvars) expr
in case localIndex of in case localIndex of
Just index -> (exprConstants, exprOps ++ [Opsipush 1, Opiadd, Opdup, Opistore (fromIntegral index)], lvars) Just index -> (exprConstants, exprOps ++ [Opsipush 1, Opiadd, Opdup, Opistore (fromIntegral index)], lvars)
Nothing -> error ("No such local variable found in local variable pool: " ++ name) Nothing -> error("No such local variable found in local variable pool: " ++ name)
(TypedExpression dtype (FieldVariable name)) -> let (TypedExpression dtype (FieldVariable name)) -> let
owner = resolveNameChainOwner (TypedExpression dtype receiver) owner = resolveNameChainOwner (TypedExpression dtype receiver)
in case owner of in case owner of
@ -121,20 +121,20 @@ assembleStatementExpression
(constants_r, ops_r, _) = assembleNameChain (constants_f, ops, lvars) (TypedExpression dtype receiver) (constants_r, ops_r, _) = assembleNameChain (constants_f, ops, lvars) (TypedExpression dtype receiver)
in in
(constants_r, ops_r ++ [Opdup, Opgetfield (fromIntegral fieldIndex), Opsipush 1, Opiadd, Opdup_x1, Opputfield (fromIntegral fieldIndex)], lvars) (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) something_else -> error ("expected TypedExpression, but got: " ++ show something_else)
assembleStatementExpression assembleStatementExpression
(constants, ops, lvars) (constants, ops, lvars)
(TypedStatementExpression _ (PreDecrement (TypedExpression dtype receiver))) = let (TypedStatementExpression _ (PreDecrement (TypedExpression dtype receiver))) = let
target = resolveNameChain (TypedExpression dtype receiver) target = resolveNameChain (TypedExpression dtype receiver)
in case target of in case target of
(TypedExpression dtype (LocalVariable name)) -> let (TypedExpression dtype (LocalVariable name)) -> let
localIndex = elemIndex name lvars localIndex = findIndex ((==) name) lvars
expr = TypedExpression dtype (LocalVariable name) expr = (TypedExpression dtype (LocalVariable name))
(exprConstants, exprOps, _) = assembleExpression (constants, ops, lvars) expr (exprConstants, exprOps, _) = assembleExpression (constants, ops, lvars) expr
in case localIndex of in case localIndex of
Just index -> (exprConstants, exprOps ++ [Opsipush 1, Opisub, Opdup, Opistore (fromIntegral index)], lvars) Just index -> (exprConstants, exprOps ++ [Opsipush 1, Opisub, Opdup, Opistore (fromIntegral index)], lvars)
Nothing -> error ("No such local variable found in local variable pool: " ++ name) Nothing -> error("No such local variable found in local variable pool: " ++ name)
(TypedExpression dtype (FieldVariable name)) -> let (TypedExpression dtype (FieldVariable name)) -> let
owner = resolveNameChainOwner (TypedExpression dtype receiver) owner = resolveNameChainOwner (TypedExpression dtype receiver)
in case owner of in case owner of
@ -143,20 +143,20 @@ assembleStatementExpression
(constants_r, ops_r, _) = assembleNameChain (constants_f, ops, lvars) (TypedExpression dtype receiver) (constants_r, ops_r, _) = assembleNameChain (constants_f, ops, lvars) (TypedExpression dtype receiver)
in in
(constants_r, ops_r ++ [Opdup, Opgetfield (fromIntegral fieldIndex), Opsipush 1, Opisub, Opdup_x1, Opputfield (fromIntegral fieldIndex)], lvars) (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) something_else -> error ("expected TypedExpression, but got: " ++ show something_else)
assembleStatementExpression assembleStatementExpression
(constants, ops, lvars) (constants, ops, lvars)
(TypedStatementExpression _ (PostIncrement (TypedExpression dtype receiver))) = let (TypedStatementExpression _ (PostIncrement (TypedExpression dtype receiver))) = let
target = resolveNameChain (TypedExpression dtype receiver) target = resolveNameChain (TypedExpression dtype receiver)
in case target of in case target of
(TypedExpression dtype (LocalVariable name)) -> let (TypedExpression dtype (LocalVariable name)) -> let
localIndex = elemIndex name lvars localIndex = findIndex ((==) name) lvars
expr = TypedExpression dtype (LocalVariable name) expr = (TypedExpression dtype (LocalVariable name))
(exprConstants, exprOps, _) = assembleExpression (constants, ops, lvars) expr (exprConstants, exprOps, _) = assembleExpression (constants, ops, lvars) expr
in case localIndex of in case localIndex of
Just index -> (exprConstants, exprOps ++ [Opdup, Opsipush 1, Opiadd, Opistore (fromIntegral index)], lvars) Just index -> (exprConstants, exprOps ++ [Opdup, Opsipush 1, Opiadd, Opistore (fromIntegral index)], lvars)
Nothing -> error ("No such local variable found in local variable pool: " ++ name) Nothing -> error("No such local variable found in local variable pool: " ++ name)
(TypedExpression dtype (FieldVariable name)) -> let (TypedExpression dtype (FieldVariable name)) -> let
owner = resolveNameChainOwner (TypedExpression dtype receiver) owner = resolveNameChainOwner (TypedExpression dtype receiver)
in case owner of in case owner of
@ -165,20 +165,20 @@ assembleStatementExpression
(constants_r, ops_r, _) = assembleNameChain (constants_f, ops, lvars) (TypedExpression dtype receiver) (constants_r, ops_r, _) = assembleNameChain (constants_f, ops, lvars) (TypedExpression dtype receiver)
in in
(constants_r, ops_r ++ [Opdup, Opgetfield (fromIntegral fieldIndex), Opdup_x1, Opsipush 1, Opiadd, Opputfield (fromIntegral fieldIndex)], lvars) (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) something_else -> error ("expected TypedExpression, but got: " ++ show something_else)
assembleStatementExpression assembleStatementExpression
(constants, ops, lvars) (constants, ops, lvars)
(TypedStatementExpression _ (PostDecrement (TypedExpression dtype receiver))) = let (TypedStatementExpression _ (PostDecrement (TypedExpression dtype receiver))) = let
target = resolveNameChain (TypedExpression dtype receiver) target = resolveNameChain (TypedExpression dtype receiver)
in case target of in case target of
(TypedExpression dtype (LocalVariable name)) -> let (TypedExpression dtype (LocalVariable name)) -> let
localIndex = elemIndex name lvars localIndex = findIndex ((==) name) lvars
expr = TypedExpression dtype (LocalVariable name) expr = (TypedExpression dtype (LocalVariable name))
(exprConstants, exprOps, _) = assembleExpression (constants, ops, lvars) expr (exprConstants, exprOps, _) = assembleExpression (constants, ops, lvars) expr
in case localIndex of in case localIndex of
Just index -> (exprConstants, exprOps ++ [Opdup, Opsipush 1, Opisub, Opistore (fromIntegral index)], lvars) Just index -> (exprConstants, exprOps ++ [Opdup, Opsipush 1, Opisub, Opistore (fromIntegral index)], lvars)
Nothing -> error ("No such local variable found in local variable pool: " ++ name) Nothing -> error("No such local variable found in local variable pool: " ++ name)
(TypedExpression dtype (FieldVariable name)) -> let (TypedExpression dtype (FieldVariable name)) -> let
owner = resolveNameChainOwner (TypedExpression dtype receiver) owner = resolveNameChainOwner (TypedExpression dtype receiver)
in case owner of in case owner of
@ -187,7 +187,7 @@ assembleStatementExpression
(constants_r, ops_r, _) = assembleNameChain (constants_f, ops, lvars) (TypedExpression dtype receiver) (constants_r, ops_r, _) = assembleNameChain (constants_f, ops, lvars) (TypedExpression dtype receiver)
in in
(constants_r, ops_r ++ [Opdup, Opgetfield (fromIntegral fieldIndex), Opdup_x1, Opsipush 1, Opisub, Opputfield (fromIntegral fieldIndex)], lvars) (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) something_else -> error ("expected TypedExpression, but got: " ++ show something_else)
assembleStatementExpression assembleStatementExpression
(constants, ops, lvars) (constants, ops, lvars)
@ -221,26 +221,26 @@ assembleStatement (constants, ops, lvars) (TypedStatement _ (Block statements))
assembleStatement (constants, ops, lvars) (TypedStatement dtype (If expr if_stmt else_stmt)) = let assembleStatement (constants, ops, lvars) (TypedStatement dtype (If expr if_stmt else_stmt)) = let
(constants_cmp, ops_cmp, _) = assembleExpression (constants, [], lvars) expr (constants_cmp, ops_cmp, _) = assembleExpression (constants, [], lvars) expr
(constants_ifa, ops_ifa, lvars_ifa) = assembleStatement (constants_cmp, [], lvars) if_stmt (constants_ifa, ops_ifa, _) = assembleStatement (constants_cmp, [], lvars) if_stmt
(constants_elsea, ops_elsea, _) = case else_stmt of (constants_elsea, ops_elsea, _) = case else_stmt of
Nothing -> (constants_ifa, [], lvars_ifa) Nothing -> (constants_ifa, [], lvars)
Just stmt -> assembleStatement (constants_ifa, [], lvars_ifa) stmt Just stmt -> assembleStatement (constants_ifa, [], lvars) stmt
-- +6 because we insert 2 gotos, one for if, one for else -- +6 because we insert 2 gotos, one for if, one for else
if_length = sum (map opcodeEncodingLength ops_ifa) if_length = sum (map opcodeEncodingLength ops_ifa)
-- +3 because we need to account for the goto in the if statement. -- +3 because we need to account for the goto in the if statement.
else_length = sum (map opcodeEncodingLength ops_elsea) else_length = sum (map opcodeEncodingLength ops_elsea)
in case dtype of 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) "void" -> (constants_ifa, ops ++ ops_cmp ++ [Opsipush 0, Opif_icmpeq (if_length + 6)] ++ ops_ifa ++ [Opgoto (else_length + 3)] ++ ops_elsea, lvars)
_ -> (constants_ifa, ops ++ ops_cmp ++ [Opsipush 0, Opif_icmpeq (if_length + 3)] ++ ops_ifa ++ ops_elsea, lvars_ifa) otherwise -> (constants_ifa, ops ++ ops_cmp ++ [Opsipush 0, Opif_icmpeq (if_length + 3)] ++ ops_ifa ++ ops_elsea, lvars)
assembleStatement (constants, ops, lvars) (TypedStatement _ (While expr stmt)) = let assembleStatement (constants, ops, lvars) (TypedStatement _ (While expr stmt)) = let
(constants_cmp, ops_cmp, _) = assembleExpression (constants, [], lvars) expr (constants_cmp, ops_cmp, _) = assembleExpression (constants, [], lvars) expr
(constants_stmta, ops_stmta, lvars_stmta) = assembleStatement (constants_cmp, [], lvars) stmt (constants_stmta, ops_stmta, _) = assembleStatement (constants_cmp, [], lvars) stmt
-- +3 because we insert 2 gotos, one for the comparison, one for the goto back to the comparison -- +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 stmt_length = sum (map opcodeEncodingLength ops_stmta) + 6
entire_length = stmt_length + sum (map opcodeEncodingLength ops_cmp) entire_length = stmt_length + sum (map opcodeEncodingLength ops_cmp)
in in
(constants_stmta, ops ++ ops_cmp ++ [Opsipush 0, Opif_icmpeq stmt_length] ++ ops_stmta ++ [Opgoto (-entire_length)], lvars_stmta) (constants_stmta, ops ++ ops_cmp ++ [Opsipush 0, Opif_icmpeq stmt_length] ++ ops_stmta ++ [Opgoto (-entire_length)], lvars)
assembleStatement (constants, ops, lvars) (TypedStatement _ (LocalVariableDeclaration (VariableDeclaration dtype name expr))) = let assembleStatement (constants, ops, lvars) (TypedStatement _ (LocalVariableDeclaration (VariableDeclaration dtype name expr))) = let
isPrimitive = elem dtype ["char", "boolean", "int"] isPrimitive = elem dtype ["char", "boolean", "int"]
@ -252,25 +252,25 @@ assembleStatement (constants, ops, lvars) (TypedStatement _ (LocalVariableDeclar
in in
(constants_init, ops_init ++ storeLocal, lvars ++ [name]) (constants_init, ops_init ++ storeLocal, lvars ++ [name])
assembleStatement (constants, ops, lvars) (TypedStatement dtype (StatementExpressionStatement expr)) = let assembleStatement (constants, ops, lvars) (TypedStatement _ (StatementExpressionStatement expr)) = let
(constants_e, ops_e, lvars_e) = assembleStatementExpression (constants, ops, lvars) expr (constants_e, ops_e, lvars_e) = assembleStatementExpression (constants, ops, lvars) expr
in case dtype of in
"void" -> (constants_e, ops_e, lvars_e) (constants_e, ops_e ++ [Oppop], lvars_e)
_ -> (constants_e, ops_e ++ [Oppop], lvars_e)
assembleStatement _ stmt = error ("Unknown statement: " ++ show stmt) assembleStatement _ stmt = error ("Not yet implemented: " ++ show stmt)
assembleMethod :: Assembler MethodDeclaration assembleMethod :: Assembler MethodDeclaration
assembleMethod (constants, ops, lvars) (MethodDeclaration returntype name _ (TypedStatement _ (Block statements))) assembleMethod (constants, ops, lvars) (MethodDeclaration returntype name _ (TypedStatement _ (Block statements)))
| name == "<init>" = let | name == "<init>" = let
(constants_a, ops_a, lvars_a) = foldl assembleStatement (constants, ops, lvars) statements (constants_a, ops_a, lvars_a) = foldl assembleStatement (constants, ops, lvars) statements
init_ops = [Opaload 0, Opinvokespecial 2]
in in
(constants_a, [Opaload 0, Opinvokespecial 2] ++ ops_a ++ [Opreturn], lvars_a) (constants_a, init_ops ++ ops_a ++ [Opreturn], lvars_a)
| otherwise = case returntype of | otherwise = case returntype of
"void" -> let "void" -> let
(constants_a, ops_a, lvars_a) = foldl assembleStatement (constants, ops, lvars) statements (constants_a, ops_a, lvars_a) = foldl assembleStatement (constants, ops, lvars) statements
in in
(constants_a, ops_a ++ [Opreturn], lvars_a) (constants_a, ops_a ++ [Opreturn], lvars_a)
_ -> foldl assembleStatement (constants, ops, lvars) statements otherwise -> foldl assembleStatement (constants, ops, lvars) statements
assembleMethod _ (MethodDeclaration _ _ _ stmt) = error ("Typed block expected for method body, got: " ++ show stmt) assembleMethod _ (MethodDeclaration _ _ _ stmt) = error ("Typed block expected for method body, got: " ++ show stmt)

View File

@ -22,14 +22,14 @@ fieldBuilder (VariableDeclaration datatype name _) input = let
] ]
field = MemberInfo { field = MemberInfo {
memberAccessFlags = accessPublic, memberAccessFlags = accessPublic,
memberNameIndex = fromIntegral (baseIndex + 2), memberNameIndex = (fromIntegral (baseIndex + 2)),
memberDescriptorIndex = fromIntegral (baseIndex + 3), memberDescriptorIndex = (fromIntegral (baseIndex + 3)),
memberAttributes = [] memberAttributes = []
} }
in in
input { input {
constantPool = constantPool input ++ constants, constantPool = (constantPool input) ++ constants,
fields = fields input ++ [field] fields = (fields input) ++ [field]
} }
@ -46,53 +46,47 @@ methodBuilder (MethodDeclaration returntype name parameters statement) input = l
method = MemberInfo { method = MemberInfo {
memberAccessFlags = accessPublic, memberAccessFlags = accessPublic,
memberNameIndex = fromIntegral (baseIndex + 2), memberNameIndex = (fromIntegral (baseIndex + 2)),
memberDescriptorIndex = fromIntegral (baseIndex + 3), memberDescriptorIndex = (fromIntegral (baseIndex + 3)),
memberAttributes = [] memberAttributes = []
} }
in in
input { input {
constantPool = constantPool input ++ constants, constantPool = (constantPool input) ++ constants,
methods = methods input ++ [method] methods = (methods input) ++ [method]
} }
constructorBuilder :: ClassFileBuilder ConstructorDeclaration
constructorBuilder (ConstructorDeclaration name parameters statement) = methodBuilder (MethodDeclaration "void" "<init>" parameters statement)
methodAssembler :: ClassFileBuilder MethodDeclaration methodAssembler :: ClassFileBuilder MethodDeclaration
methodAssembler (MethodDeclaration returntype name parameters statement) input = let methodAssembler (MethodDeclaration returntype name parameters statement) input = let
methodConstantIndex = findMethodIndex input (MethodDeclaration returntype name parameters statement) methodConstantIndex = findMethodIndex input name
in case methodConstantIndex of in case methodConstantIndex of
Nothing -> error ("Cannot find method entry in method pool for method: " ++ name) Nothing -> error ("Cannot find method entry in method pool for method: " ++ name)
Just index -> let Just index -> let
declaration = MethodDeclaration returntype name parameters statement declaration = MethodDeclaration returntype name parameters statement
paramNames = "this" : [name | ParameterDeclaration _ name <- parameters] paramNames = "this" : [name | ParameterDeclaration _ name <- parameters]
in case splitAt index (methods input) of in case (splitAt index (methods input)) of
(pre, []) -> input (pre, []) -> input
(pre, method : post) -> let (pre, method : post) -> let
(constants, bytecode, aParamNames) = assembleMethod (constantPool input, [], paramNames) declaration (_, bytecode, _) = assembleMethod (constantPool input, [], paramNames) declaration
assembledMethod = method { assembledMethod = method {
memberAttributes = [ memberAttributes = [
CodeAttribute { CodeAttribute {
attributeMaxStack = fromIntegral $ maxStackDepth constants bytecode, attributeMaxStack = 420,
attributeMaxLocals = fromIntegral $ length aParamNames, attributeMaxLocals = 420,
attributeCode = bytecode attributeCode = bytecode
} }
] ]
} }
in in
input { input {
constantPool = constants,
methods = pre ++ (assembledMethod : post) methods = pre ++ (assembledMethod : post)
} }
constructorAssembler :: ClassFileBuilder ConstructorDeclaration
constructorAssembler (ConstructorDeclaration name parameters statement) = methodAssembler (MethodDeclaration "void" "<init>" parameters statement)
classBuilder :: ClassFileBuilder Class classBuilder :: ClassFileBuilder Class
classBuilder (Class name constructors methods fields) _ = let classBuilder (Class name methods fields) _ = let
baseConstants = [ baseConstants = [
ClassInfo 4, ClassInfo 4,
MethodRefInfo 1 3, MethodRefInfo 1 3,
@ -100,12 +94,11 @@ classBuilder (Class name constructors methods fields) _ = let
Utf8Info "java/lang/Object", Utf8Info "java/lang/Object",
Utf8Info "<init>", Utf8Info "<init>",
Utf8Info "()V", Utf8Info "()V",
Utf8Info "Code", Utf8Info "Code"
ClassInfo 9,
Utf8Info name
] ]
nameConstants = [ClassInfo 9, Utf8Info name]
nakedClassFile = ClassFile { nakedClassFile = ClassFile {
constantPool = baseConstants, constantPool = baseConstants ++ nameConstants,
accessFlags = accessPublic, accessFlags = accessPublic,
thisClass = 8, thisClass = 8,
superClass = 1, superClass = 1,
@ -114,15 +107,11 @@ classBuilder (Class name constructors methods fields) _ = let
attributes = [] attributes = []
} }
-- for every constructor, prepend all initialization assignments for fields. methodsWithInjectedConstructor = injectDefaultConstructor methods
constructorsWithInitializers = injectFieldInitializers name fields constructors methodsWithInjectedInitializers = injectFieldInitializers name fields methodsWithInjectedConstructor
-- add fields, then method bodies, then constructor bodies to the classfile. After all referable names are known, classFileWithFields = foldr fieldBuilder nakedClassFile fields
-- assemble the methods and constructors into bytecode. classFileWithMethods = foldr methodBuilder classFileWithFields methodsWithInjectedInitializers
fieldsAdded = foldr fieldBuilder nakedClassFile fields classFileWithAssembledMethods = foldr methodAssembler classFileWithMethods methodsWithInjectedInitializers
methodsAdded = foldr methodBuilder fieldsAdded methods
constructorsAdded = foldr constructorBuilder methodsAdded constructorsWithInitializers
methodsAssembled = foldr methodAssembler constructorsAdded methods
constructorsAssembled = foldr constructorAssembler methodsAssembled constructorsWithInitializers
in in
constructorsAssembled classFileWithAssembledMethods

View File

@ -1,4 +1,14 @@
module ByteCode.ClassFile where module ByteCode.ClassFile(
ConstantInfo(..),
Attribute(..),
MemberInfo(..),
ClassFile(..),
Operation(..),
serialize,
emptyClassFile,
opcodeEncodingLength,
className
) where
import Data.Word import Data.Word
import Data.Int import Data.Int
@ -89,14 +99,47 @@ emptyClassFile = ClassFile {
className :: ClassFile -> String className :: ClassFile -> String
className classFile = let className classFile = let
classInfo = constantPool classFile !! fromIntegral (thisClass classFile) classInfo = (constantPool classFile)!!(fromIntegral (thisClass classFile))
in case classInfo of in case classInfo of
Utf8Info className -> className Utf8Info className -> className
unexpected_element -> error ("expected Utf8Info but got: " ++ show unexpected_element) otherwise -> error ("expected Utf8Info but got: " ++ show otherwise)
opcodeEncodingLength :: Operation -> Word16 opcodeEncodingLength :: Operation -> Word16
opcodeEncodingLength op = fromIntegral . length . serialize $ op opcodeEncodingLength Opiadd = 1
opcodeEncodingLength Opisub = 1
opcodeEncodingLength Opimul = 1
opcodeEncodingLength Opidiv = 1
opcodeEncodingLength Opirem = 1
opcodeEncodingLength Opiand = 1
opcodeEncodingLength Opior = 1
opcodeEncodingLength Opixor = 1
opcodeEncodingLength Opineg = 1
opcodeEncodingLength Opdup = 1
opcodeEncodingLength (Opnew _) = 3
opcodeEncodingLength (Opif_icmplt _) = 3
opcodeEncodingLength (Opif_icmple _) = 3
opcodeEncodingLength (Opif_icmpgt _) = 3
opcodeEncodingLength (Opif_icmpge _) = 3
opcodeEncodingLength (Opif_icmpeq _) = 3
opcodeEncodingLength (Opif_icmpne _) = 3
opcodeEncodingLength Opaconst_null = 1
opcodeEncodingLength Opreturn = 1
opcodeEncodingLength Opireturn = 1
opcodeEncodingLength Opareturn = 1
opcodeEncodingLength Opdup_x1 = 1
opcodeEncodingLength Oppop = 1
opcodeEncodingLength (Opinvokespecial _) = 3
opcodeEncodingLength (Opinvokevirtual _) = 3
opcodeEncodingLength (Opgoto _) = 3
opcodeEncodingLength (Opsipush _) = 3
opcodeEncodingLength (Opldc_w _) = 3
opcodeEncodingLength (Opaload _) = 4
opcodeEncodingLength (Opiload _) = 4
opcodeEncodingLength (Opastore _) = 4
opcodeEncodingLength (Opistore _) = 4
opcodeEncodingLength (Opputfield _) = 3
opcodeEncodingLength (Opgetfield _) = 3
class Serializable a where class Serializable a where
serialize :: a -> [Word8] serialize :: a -> [Word8]
@ -158,10 +201,10 @@ instance Serializable Attribute where
serialize (CodeAttribute { attributeMaxStack = maxStack, serialize (CodeAttribute { attributeMaxStack = maxStack,
attributeMaxLocals = maxLocals, attributeMaxLocals = maxLocals,
attributeCode = code }) = let attributeCode = code }) = let
assembledCode = concatMap serialize code assembledCode = concat (map serialize code)
in in
unpackWord16 7 -- attribute_name_index unpackWord16 7 -- attribute_name_index
++ unpackWord32 (12 + fromIntegral (length assembledCode)) -- attribute_length ++ unpackWord32 (12 + (fromIntegral (length assembledCode))) -- attribute_length
++ unpackWord16 maxStack -- max_stack ++ unpackWord16 maxStack -- max_stack
++ unpackWord16 maxLocals -- max_locals ++ unpackWord16 maxLocals -- max_locals
++ unpackWord32 (fromIntegral (length assembledCode)) -- code_length ++ unpackWord32 (fromIntegral (length assembledCode)) -- code_length

View File

@ -1,33 +1,32 @@
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
{-# HLINT ignore "Use lambda-case" #-}
module ByteCode.Util where module ByteCode.Util where
import Data.Int import Data.Int
import Ast import Ast
import ByteCode.ClassFile import ByteCode.ClassFile
import Data.List import Data.List
import Data.Maybe (mapMaybe, isJust) import Data.Maybe (mapMaybe)
import Data.Word (Word8, Word16, Word32) import Data.Word (Word8, Word16, Word32)
-- walks the name resolution chain. returns the innermost Just LocalVariable/FieldVariable or Nothing. -- walks the name resolution chain. returns the innermost Just LocalVariable/FieldVariable or Nothing.
resolveNameChain :: Expression -> Expression resolveNameChain :: Expression -> Expression
resolveNameChain (TypedExpression _ (BinaryOperation NameResolution a b)) = resolveNameChain b resolveNameChain (TypedExpression _ (BinaryOperation NameResolution a b)) = resolveNameChain b
resolveNameChain (TypedExpression dtype (LocalVariable name)) = TypedExpression dtype (LocalVariable name) resolveNameChain (TypedExpression dtype (LocalVariable name)) = (TypedExpression dtype (LocalVariable name))
resolveNameChain (TypedExpression dtype (FieldVariable name)) = TypedExpression dtype (FieldVariable name) resolveNameChain (TypedExpression dtype (FieldVariable name)) = (TypedExpression dtype (FieldVariable name))
resolveNameChain invalidExpression = error ("expected a NameResolution or Local/Field Variable but got: " ++ show invalidExpression) 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. -- walks the name resolution chain. returns the second-to-last item of the namechain.
resolveNameChainOwner :: Expression -> Expression resolveNameChainOwner :: Expression -> Expression
resolveNameChainOwner (TypedExpression _ (BinaryOperation NameResolution a (TypedExpression dtype (FieldVariable name)))) = a resolveNameChainOwner (TypedExpression _ (BinaryOperation NameResolution a (TypedExpression dtype (FieldVariable name)))) = a
resolveNameChainOwner (TypedExpression _ (BinaryOperation NameResolution a b)) = resolveNameChain b resolveNameChainOwner (TypedExpression _ (BinaryOperation NameResolution a b)) = resolveNameChain b
resolveNameChainOwner invalidExpression = error ("expected a NameResolution or Local/Field Variable but got: " ++ show invalidExpression) resolveNameChainOwner invalidExpression = error ("expected a NameResolution or Local/Field Variable but got: " ++ show(invalidExpression))
methodDescriptor :: MethodDeclaration -> String methodDescriptor :: MethodDeclaration -> String
methodDescriptor (MethodDeclaration returntype _ parameters _) = let methodDescriptor (MethodDeclaration returntype _ parameters _) = let
parameter_types = [datatype | ParameterDeclaration datatype _ <- parameters] parameter_types = [datatype | ParameterDeclaration datatype _ <- parameters]
in in
"(" "("
++ concatMap datatypeDescriptor parameter_types ++ (concat (map datatypeDescriptor parameter_types))
++ ")" ++ ")"
++ datatypeDescriptor returntype ++ datatypeDescriptor returntype
@ -36,70 +35,50 @@ methodDescriptorFromParamlist parameters returntype = let
parameter_types = [datatype | TypedExpression datatype _ <- parameters] parameter_types = [datatype | TypedExpression datatype _ <- parameters]
in in
"(" "("
++ concatMap datatypeDescriptor parameter_types ++ (concat (map datatypeDescriptor parameter_types))
++ ")" ++ ")"
++ datatypeDescriptor returntype ++ 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 :: [ConstantInfo] -> MemberInfo -> Bool
memberInfoIsMethod constants info = '(' `elem` memberInfoDescriptor constants info memberInfoIsMethod constants info = elem '(' (memberInfoDescriptor constants info)
datatypeDescriptor :: String -> String datatypeDescriptor :: String -> String
datatypeDescriptor "void" = "V" datatypeDescriptor "void" = "V"
datatypeDescriptor "int" = "I" datatypeDescriptor "int" = "I"
datatypeDescriptor "char" = "C" datatypeDescriptor "char" = "C"
datatypeDescriptor "boolean" = "Z" datatypeDescriptor "boolean" = "B"
datatypeDescriptor x = "L" ++ x ++ ";" datatypeDescriptor x = "L" ++ x ++ ";"
memberInfoDescriptor :: [ConstantInfo] -> MemberInfo -> String memberInfoDescriptor :: [ConstantInfo] -> MemberInfo -> String
memberInfoDescriptor constants MemberInfo { memberDescriptorIndex = descriptorIndex } = let memberInfoDescriptor constants MemberInfo {
descriptor = constants !! (fromIntegral descriptorIndex - 1) memberAccessFlags = _,
memberNameIndex = _,
memberDescriptorIndex = descriptorIndex,
memberAttributes = _ } = let
descriptor = constants!!((fromIntegral descriptorIndex) - 1)
in case descriptor of in case descriptor of
Utf8Info descriptorText -> descriptorText Utf8Info descriptorText -> descriptorText
_ -> "Invalid Item at Constant pool index " ++ show descriptorIndex _ -> ("Invalid Item at Constant pool index " ++ show descriptorIndex)
memberInfoName :: [ConstantInfo] -> MemberInfo -> String memberInfoName :: [ConstantInfo] -> MemberInfo -> String
memberInfoName constants MemberInfo { memberNameIndex = nameIndex } = let memberInfoName constants MemberInfo {
name = constants !! (fromIntegral nameIndex - 1) memberAccessFlags = _,
memberNameIndex = nameIndex,
memberDescriptorIndex = _,
memberAttributes = _ } = let
name = constants!!((fromIntegral nameIndex) - 1)
in case name of in case name of
Utf8Info nameText -> nameText Utf8Info nameText -> nameText
_ -> "Invalid Item at Constant pool index " ++ show nameIndex _ -> ("Invalid Item at Constant pool index " ++ show nameIndex)
returnOperation :: DataType -> Operation returnOperation :: DataType -> Operation
returnOperation dtype returnOperation dtype
| dtype `elem` ["int", "char", "boolean"] = Opireturn | elem dtype ["int", "char", "boolean"] = Opireturn
| otherwise = Opareturn | otherwise = Opareturn
binaryOperation :: BinaryOperator -> Operation binaryOperation :: BinaryOperator -> Operation
binaryOperation Addition = Opiadd binaryOperation Addition = Opiadd
@ -121,31 +100,53 @@ comparisonOperation CompareLessOrEqual branchLocation = Opif_icmple branchLoc
comparisonOperation CompareGreaterThan branchLocation = Opif_icmpgt branchLocation comparisonOperation CompareGreaterThan branchLocation = Opif_icmpgt branchLocation
comparisonOperation CompareGreaterOrEqual branchLocation = Opif_icmpge branchLocation comparisonOperation CompareGreaterOrEqual branchLocation = Opif_icmpge branchLocation
comparisonOffset :: Operation -> Maybe Int findFieldIndex :: [ConstantInfo] -> String -> Maybe Int
comparisonOffset (Opif_icmpeq offset) = Just $ fromIntegral offset findFieldIndex constants name = let
comparisonOffset (Opif_icmpne offset) = Just $ fromIntegral offset fieldRefNameInfos = [
comparisonOffset (Opif_icmplt offset) = Just $ fromIntegral offset -- we only skip one entry to get the name since the Java constant pool
comparisonOffset (Opif_icmple offset) = Just $ fromIntegral offset -- is 1-indexed (why)
comparisonOffset (Opif_icmpgt offset) = Just $ fromIntegral offset (index, constants!!(fromIntegral index + 1))
comparisonOffset (Opif_icmpge offset) = Just $ fromIntegral offset | (index, FieldRefInfo classIndex _) <- (zip [1..] constants)
comparisonOffset anything_else = Nothing ]
fieldRefNames = map (\(index, nameInfo) -> case nameInfo of
Utf8Info fieldName -> (index, fieldName)
something_else -> error ("Expected UTF8Info but got" ++ show something_else))
fieldRefNameInfos
fieldIndex = find (\(index, fieldName) -> fieldName == name) fieldRefNames
in case fieldIndex of
Just (index, _) -> Just index
Nothing -> Nothing
isComparisonOperation :: Operation -> Bool findMethodRefIndex :: [ConstantInfo] -> String -> Maybe Int
isComparisonOperation op = isJust (comparisonOffset op) findMethodRefIndex constants name = let
methodRefNameInfos = [
-- we only skip one entry to get the name since the Java constant pool
-- is 1-indexed (why)
(index, constants!!(fromIntegral index + 1))
| (index, MethodRefInfo _ _) <- (zip [1..] constants)
]
methodRefNames = map (\(index, nameInfo) -> case nameInfo of
Utf8Info methodName -> (index, methodName)
something_else -> error ("Expected UTF8Info but got " ++ show something_else))
methodRefNameInfos
methodIndex = find (\(index, methodName) -> methodName == name) methodRefNames
in case methodIndex of
Just (index, _) -> Just index
Nothing -> Nothing
findMethodIndex :: ClassFile -> MethodDeclaration -> Maybe Int
findMethodIndex classFile (MethodDeclaration rtype name params stmt) = let findMethodIndex :: ClassFile -> String -> Maybe Int
findMethodIndex classFile name = let
constants = constantPool classFile constants = constantPool classFile
descriptor = methodDescriptor (MethodDeclaration rtype name params stmt)
in in
findIndex (\method -> memberInfoIsMethod constants method && memberInfoName constants method == name && memberInfoDescriptor constants method == descriptor) (methods classFile) findIndex (\method -> ((memberInfoIsMethod constants method) && (memberInfoName constants method) == name)) (methods classFile)
findClassIndex :: [ConstantInfo] -> String -> Maybe Int findClassIndex :: [ConstantInfo] -> String -> Maybe Int
findClassIndex constants name = let findClassIndex constants name = let
classNameIndices = [(index, constants!!(fromIntegral nameIndex - 1)) | (index, ClassInfo nameIndex) <- zip [1..] constants] classNameIndices = [(index, constants!!(fromIntegral nameIndex - 1)) | (index, ClassInfo nameIndex) <- (zip[1..] constants)]
classNames = map (\(index, nameInfo) -> case nameInfo of classNames = map (\(index, nameInfo) -> case nameInfo of
Utf8Info className -> (index, className) Utf8Info className -> (index, className)
something_else -> error ("Expected UTF8Info but got " ++ show something_else)) something_else -> error("Expected UTF8Info but got " ++ show something_else))
classNameIndices classNameIndices
desiredClassIndex = find (\(index, className) -> className == name) classNames desiredClassIndex = find (\(index, className) -> className == name) classNames
in case desiredClassIndex of in case desiredClassIndex of
@ -156,12 +157,12 @@ getKnownMembers :: [ConstantInfo] -> [(Int, (String, String, String))]
getKnownMembers constants = let getKnownMembers constants = let
fieldsClassAndNT = [ fieldsClassAndNT = [
(index, constants!!(fromIntegral classIndex - 1), constants!!(fromIntegral nameTypeIndex - 1)) (index, constants!!(fromIntegral classIndex - 1), constants!!(fromIntegral nameTypeIndex - 1))
| (index, FieldRefInfo classIndex nameTypeIndex) <- zip [1..] constants | (index, FieldRefInfo classIndex nameTypeIndex) <- (zip [1..] constants)
] ++ [ ] ++ [
(index, constants!!(fromIntegral classIndex - 1), constants!!(fromIntegral nameTypeIndex - 1)) (index, constants!!(fromIntegral classIndex - 1), constants!!(fromIntegral nameTypeIndex - 1))
| (index, MethodRefInfo classIndex nameTypeIndex) <- zip [1..] constants | (index, MethodRefInfo classIndex nameTypeIndex) <- (zip [1..] constants)
] ]
fieldsClassNameType = map (\(index, nameInfo, nameTypeInfo) -> case (nameInfo, nameTypeInfo) of 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))) (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)) something_else -> error ("Expected Class and NameType info, but got: " ++ show nameInfo ++ " and " ++ show nameTypeInfo))
@ -169,8 +170,8 @@ getKnownMembers constants = let
fieldsResolved = map (\(index, (nameInfo, fnameInfo, ftypeInfo)) -> case (nameInfo, fnameInfo, ftypeInfo) of fieldsResolved = map (\(index, (nameInfo, fnameInfo, ftypeInfo)) -> case (nameInfo, fnameInfo, ftypeInfo) of
(Utf8Info cname, Utf8Info fname, Utf8Info ftype) -> (index, (cname, fname, ftype)) (Utf8Info cname, Utf8Info fname, Utf8Info ftype) -> (index, (cname, fname, ftype))
something_else -> error ("Expected UTF8Infos but got " ++ show something_else)) something_else -> error("Expected UTF8Infos but got " ++ show something_else))
fieldsClassNameType fieldsClassNameType
in in
fieldsResolved fieldsResolved
@ -178,7 +179,7 @@ getKnownMembers constants = let
getClassIndex :: [ConstantInfo] -> String -> ([ConstantInfo], Int) getClassIndex :: [ConstantInfo] -> String -> ([ConstantInfo], Int)
getClassIndex constants name = case findClassIndex constants name of getClassIndex constants name = case findClassIndex constants name of
Just index -> (constants, index) Just index -> (constants, index)
Nothing -> (constants ++ [ClassInfo (fromIntegral (length constants) + 2), Utf8Info name], fromIntegral (length constants) + 1) Nothing -> (constants ++ [ClassInfo (fromIntegral (length constants)), Utf8Info name], fromIntegral (length constants))
-- get the index for a field within a class, creating it if it does not exist. -- get the index for a field within a class, creating it if it does not exist.
getFieldIndex :: [ConstantInfo] -> (String, String, String) -> ([ConstantInfo], Int) getFieldIndex :: [ConstantInfo] -> (String, String, String) -> ([ConstantInfo], Int)
@ -214,11 +215,16 @@ findMemberIndex constants (cname, fname, ftype) = let
allMembers = getKnownMembers constants allMembers = getKnownMembers constants
desiredMember = find (\(index, (c, f, ft)) -> (c, f, ft) == (cname, fname, ftype)) allMembers desiredMember = find (\(index, (c, f, ft)) -> (c, f, ft) == (cname, fname, ftype)) allMembers
in in
fmap fst desiredMember fmap (\(index, _) -> index) desiredMember
injectFieldInitializers :: String -> [VariableDeclaration] -> [ConstructorDeclaration] -> [ConstructorDeclaration] injectDefaultConstructor :: [MethodDeclaration] -> [MethodDeclaration]
injectFieldInitializers classname vars constructors = let injectDefaultConstructor pre
initializers = mapMaybe (\variable -> case variable of | any (\(MethodDeclaration _ name _ _) -> name == "<init>") pre = pre
| otherwise = pre ++ [MethodDeclaration "void" "<init>" [] (TypedStatement "void" (Block []))]
injectFieldInitializers :: String -> [VariableDeclaration] -> [MethodDeclaration] -> [MethodDeclaration]
injectFieldInitializers classname vars pre = let
initializers = mapMaybe (\(variable) -> case variable of
VariableDeclaration dtype name (Just initializer) -> Just ( VariableDeclaration dtype name (Just initializer) -> Just (
TypedStatement dtype ( TypedStatement dtype (
StatementExpressionStatement ( StatementExpressionStatement (
@ -233,59 +239,7 @@ injectFieldInitializers classname vars constructors = let
otherwise -> Nothing otherwise -> Nothing
) vars ) vars
in in
map (\con -> let map (\(method) -> case method of
ConstructorDeclaration classname params (TypedStatement "void" (Block statements)) = con MethodDeclaration "void" "<init>" params (TypedStatement "void" (Block statements)) -> MethodDeclaration "void" "<init>" params (TypedStatement "void" (Block (initializers ++ statements)))
in otherwise -> method
ConstructorDeclaration classname params (TypedStatement "void" (Block (initializers ++ statements))) ) pre
) 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

267
src/Example.hs Normal file
View File

@ -0,0 +1,267 @@
module Example where
import Ast
import Typecheck
import Control.Exception (catch, evaluate, SomeException, displayException)
import Control.Exception.Base
import System.IO (stderr, hPutStrLn)
import Data.Maybe
import Data.List
green, red, yellow, blue, magenta, cyan, white :: String -> String
green str = "\x1b[32m" ++ str ++ "\x1b[0m"
red str = "\x1b[31m" ++ str ++ "\x1b[0m"
yellow str = "\x1b[33m" ++ str ++ "\x1b[0m"
blue str = "\x1b[34m" ++ str ++ "\x1b[0m"
magenta str = "\x1b[35m" ++ str ++ "\x1b[0m"
cyan str = "\x1b[36m" ++ str ++ "\x1b[0m"
white str = "\x1b[37m" ++ str ++ "\x1b[0m"
printSuccess :: String -> IO ()
printSuccess msg = putStrLn $ green "Success:" ++ white msg
handleError :: SomeException -> IO ()
handleError e = hPutStrLn stderr $ red ("Error: " ++ displayException e)
printResult :: Show a => String -> a -> IO ()
printResult title result = do
putStrLn $ green title
print result
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"))),
MethodDeclaration "Person" "Person" [ParameterDeclaration "int" "initialAge"] (Block [])
] [
VariableDeclaration "int" "age" (Just (IntegerLiteral 25))
]
]
initialSymtab :: [(DataType, Identifier)]
initialSymtab = []
exampleExpression :: Expression
exampleExpression = BinaryOperation NameResolution (Reference "bob") (Reference "age")
exampleAssignment :: Expression
exampleAssignment = StatementExpressionExpression (Assignment (Reference "a") (IntegerLiteral 30))
exampleMethodCall :: Statement
exampleMethodCall = StatementExpressionStatement (MethodCall (Reference "this") "setAge" [IntegerLiteral 30])
exampleConstructorCall :: Statement
exampleConstructorCall = LocalVariableDeclaration (VariableDeclaration "Person" "bob" (Just (StatementExpressionExpression (ConstructorCall "Person" [IntegerLiteral 30]))))
exampleNameResolution :: Expression
exampleNameResolution = BinaryOperation NameResolution (Reference "bob2") (Reference "age")
exampleBlockResolution :: Statement
exampleBlockResolution = Block [
LocalVariableDeclaration (VariableDeclaration "Person" "bob" (Just (StatementExpressionExpression (ConstructorCall "Person" [IntegerLiteral 30])))),
LocalVariableDeclaration (VariableDeclaration "int" "age" (Just (StatementExpressionExpression (MethodCall (Reference "bob") "getAge" [])))),
StatementExpressionStatement (MethodCall (Reference "bob") "setAge" [IntegerLiteral 30])
]
exampleBlockResolutionFail :: Statement
exampleBlockResolutionFail = Block [
LocalVariableDeclaration (VariableDeclaration "Person" "bob" (Just (StatementExpressionExpression (ConstructorCall "Person" [IntegerLiteral 30])))),
LocalVariableDeclaration (VariableDeclaration "bool" "age" (Just (StatementExpressionExpression (MethodCall (Reference "bob") "getAge" [])))),
StatementExpressionStatement (MethodCall (Reference "bob") "setAge" [IntegerLiteral 30])
]
exampleMethodCallAndAssignment :: Statement
exampleMethodCallAndAssignment = Block [
LocalVariableDeclaration (VariableDeclaration "Person" "bob" (Just (StatementExpressionExpression (ConstructorCall "Person" [IntegerLiteral 30])))),
LocalVariableDeclaration (VariableDeclaration "int" "age" (Just (StatementExpressionExpression (MethodCall (Reference "bob") "getAge" [])))),
StatementExpressionStatement (MethodCall (Reference "bob") "setAge" [IntegerLiteral 30]),
LocalVariableDeclaration (VariableDeclaration "int" "a" Nothing),
StatementExpressionStatement (Assignment (Reference "a") (Reference "age"))
]
exampleMethodCallAndAssignmentFail :: Statement
exampleMethodCallAndAssignmentFail = Block [
LocalVariableDeclaration (VariableDeclaration "Person" "bob" (Just (StatementExpressionExpression (ConstructorCall "Person" [IntegerLiteral 30])))),
LocalVariableDeclaration (VariableDeclaration "int" "age" (Just (StatementExpressionExpression (MethodCall (Reference "bob") "getAge" [])))),
StatementExpressionStatement (MethodCall (Reference "bob") "setAge" [IntegerLiteral 30]),
StatementExpressionStatement (Assignment (Reference "a") (Reference "age"))
]
exampleNameResolutionAssignment :: Statement
exampleNameResolutionAssignment = Block [
LocalVariableDeclaration (VariableDeclaration "Person" "bob" (Just (StatementExpressionExpression (ConstructorCall "Person" [IntegerLiteral 30])))),
StatementExpressionStatement (Assignment (BinaryOperation NameResolution (Reference "bob") (Reference "age")) (IntegerLiteral 30))
]
exampleCharIntOperation :: Expression
exampleCharIntOperation = BinaryOperation Addition (CharacterLiteral 'a') (IntegerLiteral 1)
exampleNullDeclaration :: Statement
exampleNullDeclaration = LocalVariableDeclaration (VariableDeclaration "Person" "bob" (Just NullLiteral))
exampleNullDeclarationFail :: Statement
exampleNullDeclarationFail = LocalVariableDeclaration (VariableDeclaration "int" "a" (Just NullLiteral))
exampleNullAssignment :: Statement
exampleNullAssignment = StatementExpressionStatement (Assignment (Reference "a") NullLiteral)
exampleIncrement :: Statement
exampleIncrement = StatementExpressionStatement (PostIncrement (Reference "a"))
testClasses :: [Class]
testClasses = [
Class "Person" [
MethodDeclaration "Person" "Person" [ParameterDeclaration "int" "initialAge"]
(Block [
Return (Just (Reference "this"))
]),
MethodDeclaration "void" "setAge" [ParameterDeclaration "int" "newAge"]
(Block [
LocalVariableDeclaration (VariableDeclaration "int" "age" (Just (Reference "newAge")))
]),
MethodDeclaration "int" "getAge" []
(Return (Just (Reference "age")))
] [
VariableDeclaration "int" "age" Nothing -- initially unassigned
],
Class "Main" [
MethodDeclaration "int" "main" []
(Block [
LocalVariableDeclaration (VariableDeclaration "Person" "bob" (Just (StatementExpressionExpression (ConstructorCall "Person" [IntegerLiteral 25])))),
StatementExpressionStatement (MethodCall (Reference "bob") "setAge" [IntegerLiteral 30]),
LocalVariableDeclaration (VariableDeclaration "int" "bobAge" (Just (StatementExpressionExpression (MethodCall (Reference "bob2") "getAge" [])))),
Return (Just (Reference "bobAge"))
])
] [
VariableDeclaration "Person" "bob2" Nothing
]
]
runTypeCheck :: IO ()
runTypeCheck = do
catch (do
print "====================================================================================="
evaluatedExpression <- evaluate (typeCheckExpression exampleExpression [("bob", "Person")] sampleClasses)
printSuccess "Type checking of expression completed successfully"
printResult "Result Expression:" evaluatedExpression
) handleError
catch (do
print "====================================================================================="
evaluatedAssignment <- evaluate (typeCheckExpression exampleAssignment [("a", "int")] sampleClasses)
printSuccess "Type checking of assignment completed successfully"
printResult "Result Assignment:" evaluatedAssignment
) handleError
catch (do
print "====================================================================================="
evaluatedMethodCall <- evaluate (typeCheckStatement exampleMethodCall [("this", "Person"), ("setAge", "Person"), ("getAge", "Person")] sampleClasses)
printSuccess "Type checking of method call this completed successfully"
printResult "Result MethodCall:" evaluatedMethodCall
) handleError
catch (do
print "====================================================================================="
evaluatedConstructorCall <- evaluate (typeCheckStatement exampleConstructorCall [] sampleClasses)
printSuccess "Type checking of constructor call completed successfully"
printResult "Result Constructor Call:" evaluatedConstructorCall
) handleError
catch (do
print "====================================================================================="
evaluatedNameResolution <- evaluate (typeCheckExpression exampleNameResolution [("this", "Main")] testClasses)
printSuccess "Type checking of name resolution completed successfully"
printResult "Result Name Resolution:" evaluatedNameResolution
) handleError
catch (do
print "====================================================================================="
evaluatedBlockResolution <- evaluate (typeCheckStatement exampleBlockResolution [] sampleClasses)
printSuccess "Type checking of block resolution completed successfully"
printResult "Result Block Resolution:" evaluatedBlockResolution
) handleError
catch (do
print "====================================================================================="
evaluatedBlockResolutionFail <- evaluate (typeCheckStatement exampleBlockResolutionFail [] sampleClasses)
printSuccess "Type checking of block resolution failed"
printResult "Result Block Resolution:" evaluatedBlockResolutionFail
) handleError
catch (do
print "====================================================================================="
evaluatedMethodCallAndAssignment <- evaluate (typeCheckStatement exampleMethodCallAndAssignment [] sampleClasses)
printSuccess "Type checking of method call and assignment completed successfully"
printResult "Result Method Call and Assignment:" evaluatedMethodCallAndAssignment
) handleError
catch (do
print "====================================================================================="
evaluatedMethodCallAndAssignmentFail <- evaluate (typeCheckStatement exampleMethodCallAndAssignmentFail [] sampleClasses)
printSuccess "Type checking of method call and assignment failed"
printResult "Result Method Call and Assignment:" evaluatedMethodCallAndAssignmentFail
) handleError
catch (do
print "====================================================================================="
let mainClass = fromJust $ find (\(Class className _ _) -> className == "Main") testClasses
case mainClass of
Class _ [mainMethod] _ -> do
let result = typeCheckMethodDeclaration mainMethod [("this", "Main")] testClasses
printSuccess "Full program type checking completed successfully."
printResult "Main method result:" result
) handleError
catch (do
print "====================================================================================="
let typedProgram = typeCheckCompilationUnit testClasses
printSuccess "Type checking of Program completed successfully"
printResult "Typed Program:" typedProgram
) handleError
catch (do
print "====================================================================================="
typedAssignment <- evaluate (typeCheckStatement exampleNameResolutionAssignment [] sampleClasses)
printSuccess "Type checking of name resolution assignment completed successfully"
printResult "Result Name Resolution Assignment:" typedAssignment
) handleError
catch (do
print "====================================================================================="
evaluatedCharIntOperation <- evaluate (typeCheckExpression exampleCharIntOperation [] sampleClasses)
printSuccess "Type checking of char int operation completed successfully"
printResult "Result Char Int Operation:" evaluatedCharIntOperation
) handleError
catch (do
print "====================================================================================="
evaluatedNullDeclaration <- evaluate (typeCheckStatement exampleNullDeclaration [] sampleClasses)
printSuccess "Type checking of null declaration completed successfully"
printResult "Result Null Declaration:" evaluatedNullDeclaration
) handleError
catch (do
print "====================================================================================="
evaluatedNullDeclarationFail <- evaluate (typeCheckStatement exampleNullDeclarationFail [] sampleClasses)
printSuccess "Type checking of null declaration failed"
printResult "Result Null Declaration:" evaluatedNullDeclarationFail
) handleError
catch (do
print "====================================================================================="
evaluatedNullAssignment <- evaluate (typeCheckStatement exampleNullAssignment [("a", "Person")] sampleClasses)
printSuccess "Type checking of null assignment completed successfully"
printResult "Result Null Assignment:" evaluatedNullAssignment
) handleError
catch (do
print "====================================================================================="
evaluatedIncrement <- evaluate (typeCheckStatement exampleIncrement [("a", "int")] sampleClasses)
printSuccess "Type checking of increment completed successfully"
printResult "Result Increment:" evaluatedIncrement
) handleError

View File

@ -1,5 +1,6 @@
module Main where module Main where
import Example
import Typecheck import Typecheck
import Parser.Lexer (alexScanTokens) import Parser.Lexer (alexScanTokens)
import Parser.JavaParser import Parser.JavaParser
@ -13,20 +14,20 @@ main = do
args <- getArgs args <- getArgs
let filename = if null args let filename = if null args
then error "Missing filename, I need to know what to compile" then error "Missing filename, I need to know what to compile"
else head args else args!!0
let outputDirectory = takeDirectory filename let outputDirectory = takeDirectory filename
print ("Compiling " ++ filename) print ("Compiling " ++ filename)
file <- readFile filename file <- readFile filename
let untypedAST = parse $ alexScanTokens file let untypedAST = parse $ alexScanTokens file
let typedAST = typeCheckCompilationUnit untypedAST let typedAST = (typeCheckCompilationUnit untypedAST)
let assembledClasses = map (`classBuilder` emptyClassFile) typedAST let assembledClasses = map (\(typedClass) -> classBuilder typedClass emptyClassFile) typedAST
mapM_ (\classFile -> let mapM_ (\(classFile) -> let
fileContent = pack (serialize classFile) fileContent = pack (serialize classFile)
fileName = outputDirectory ++ "/" ++ className classFile ++ ".class" fileName = outputDirectory ++ "/" ++ (className classFile) ++ ".class"
in Data.ByteString.writeFile fileName fileContent in Data.ByteString.writeFile fileName fileContent
) assembledClasses ) assembledClasses

View File

@ -1,5 +1,5 @@
{ {
module Parser.JavaParser (parse, parseStatement, parseExpression, parseMethod) where module Parser.JavaParser (parse, parseStatement, parseExpression) where
import Ast import Ast
import Parser.Lexer import Parser.Lexer
} }
@ -7,7 +7,6 @@ import Parser.Lexer
%name parse %name parse
%name parseStatement statement %name parseStatement statement
%name parseExpression expression %name parseExpression expression
%name parseMethod classbodydeclarations
%tokentype { Token } %tokentype { Token }
%error { parseError } %error { parseError }
%errorhandlertype explist %errorhandlertype explist
@ -76,7 +75,6 @@ import Parser.Lexer
OREQUAL { OREQUAL } OREQUAL { OREQUAL }
COLON { COLON } COLON { COLON }
LESS { LESS } LESS { LESS }
FOR { FOR }
%% %%
compilationunit : typedeclarations { $1 } compilationunit : typedeclarations { $1 }
@ -93,10 +91,10 @@ qualifiedname : name DOT IDENTIFIER { BinaryOperation NameResolution $1 (Ref
simplename : IDENTIFIER { $1 } simplename : IDENTIFIER { $1 }
classdeclaration : CLASS IDENTIFIER classbody { case $3 of (constructors, methods, fields) -> Class $2 constructors methods fields } classdeclaration : CLASS IDENTIFIER classbody { case $3 of (methods, fields) -> Class $2 methods fields }
| modifiers CLASS IDENTIFIER classbody { case $4 of (constructors, methods, fields) -> Class $3 constructors methods fields } | modifiers CLASS IDENTIFIER classbody { case $4 of (methods, fields) -> Class $3 methods fields }
classbody : LBRACKET RBRACKET { ([], [], []) } classbody : LBRACKET RBRACKET { ([], []) }
| LBRACKET classbodydeclarations RBRACKET { $2 } | LBRACKET classbodydeclarations RBRACKET { $2 }
modifiers : modifier { } modifiers : modifier { }
@ -104,15 +102,13 @@ modifiers : modifier { }
classbodydeclarations : classbodydeclaration { classbodydeclarations : classbodydeclaration {
case $1 of case $1 of
ConstructorDecl constructor -> ([constructor], [], []) MethodDecl method -> ([method], [])
MethodDecl method -> ([], (convertMethodDeclarationWithOptionals method), []) FieldDecls fields -> ([], fields)
FieldDecls fields -> ([], [], fields)
} }
| classbodydeclarations classbodydeclaration { | classbodydeclarations classbodydeclaration {
case ($1, $2) of case ($1, $2) of
((constructors, methods, fields), ConstructorDecl constructor) -> ((constructors ++ [constructor]), methods, fields) ((methods, fields), MethodDecl method) -> ((methods ++ [method]), fields)
((constructors, methods, fields), MethodDecl method) -> (constructors, (methods ++ (convertMethodDeclarationWithOptionals method)), fields) ((methods, fields), FieldDecls newFields) -> (methods, (fields ++ newFields))
((constructors, methods, fields), FieldDecls newFields) -> (constructors, methods, (fields ++ newFields))
} }
modifier : PUBLIC { } modifier : PUBLIC { }
@ -131,19 +127,19 @@ classorinterfacetype : simplename { $1 }
classmemberdeclaration : fielddeclaration { $1 } classmemberdeclaration : fielddeclaration { $1 }
| methoddeclaration { $1 } | methoddeclaration { $1 }
constructordeclaration : constructordeclarator constructorbody { case $1 of (identifier, parameters) -> ConstructorDecl $ ConstructorDeclaration identifier parameters $2 } constructordeclaration : constructordeclarator constructorbody { MethodDecl $ MethodDeclaration "void" "<init>" $1 $2 }
| modifiers constructordeclarator constructorbody { case $2 of (identifier, parameters) -> ConstructorDecl $ ConstructorDeclaration identifier parameters $3 } | modifiers constructordeclarator constructorbody { MethodDecl $ MethodDeclaration "void" "<init>" $2 $3 }
fielddeclaration : type variabledeclarators SEMICOLON { FieldDecls $ map (convertDeclarator $1) $2 } fielddeclaration : type variabledeclarators SEMICOLON { FieldDecls $ map (convertDeclarator $1) $2 }
| modifiers type variabledeclarators SEMICOLON { FieldDecls $ map (convertDeclarator $2) $3 } | modifiers type variabledeclarators SEMICOLON { FieldDecls $ map (convertDeclarator $2) $3 }
methoddeclaration : methodheader methodbody { case $1 of (returnType, (name, (parameters, optionalparameters))) -> MethodDecl (MethodDeclarationWithOptionals returnType name parameters optionalparameters $2) } methoddeclaration : methodheader methodbody { case $1 of (returnType, (name, parameters)) -> MethodDecl (MethodDeclaration returnType name parameters $2) }
block : LBRACKET RBRACKET { Block [] } block : LBRACKET RBRACKET { Block [] }
| LBRACKET blockstatements RBRACKET { Block $2 } | LBRACKET blockstatements RBRACKET { Block $2 }
constructordeclarator : simplename LBRACE RBRACE { ($1, []) } constructordeclarator : simplename LBRACE RBRACE { [] }
| simplename LBRACE formalparameterlist RBRACE { ($1, $3) } | simplename LBRACE formalparameterlist RBRACE { $3 }
constructorbody : LBRACKET RBRACKET { Block [] } constructorbody : LBRACKET RBRACKET { Block [] }
-- | LBRACKET explicitconstructorinvocation RBRACKET { } -- | LBRACKET explicitconstructorinvocation RBRACKET { }
@ -167,10 +163,6 @@ methodbody : block { $1 }
blockstatements : blockstatement { $1 } blockstatements : blockstatement { $1 }
| blockstatements blockstatement { $1 ++ $2} | blockstatements blockstatement { $1 ++ $2}
formalandoptionalparameterlist : formalparameterlist { ($1, []) }
| formalparameterlist COMMA optionalparameterlist { ($1, $3) }
| optionalparameterlist { ([], $1) }
formalparameterlist : formalparameter { [$1] } formalparameterlist : formalparameter { [$1] }
| formalparameterlist COMMA formalparameter { $1 ++ [$3] } | formalparameterlist COMMA formalparameter { $1 ++ [$3] }
@ -180,13 +172,8 @@ explicitconstructorinvocation : THIS LBRACE RBRACE SEMICOLON { }
classtypelist : classtype { } classtypelist : classtype { }
| classtypelist COMMA classtype { } | classtypelist COMMA classtype { }
methoddeclarator : IDENTIFIER LBRACE RBRACE { ($1, ([], [])) } methoddeclarator : IDENTIFIER LBRACE RBRACE { ($1, []) }
| IDENTIFIER LBRACE formalandoptionalparameterlist RBRACE { ($1, $3) } | IDENTIFIER LBRACE formalparameterlist RBRACE { ($1, $3) }
optionalparameterlist : optionalparameter { [$1] }
| optionalparameterlist COMMA optionalparameter { $1 ++ [$3] }
optionalparameter : type variabledeclaratorid ASSIGN variableinitializer { OptionalParameter $1 $2 $4 }
primitivetype : BOOLEAN { "boolean" } primitivetype : BOOLEAN { "boolean" }
| numerictype { $1 } | numerictype { $1 }
@ -217,7 +204,6 @@ statement : statementwithouttrailingsubstatement{ $1 } -- statement retu
| ifthenstatement { [$1] } | ifthenstatement { [$1] }
| ifthenelsestatement { [$1] } | ifthenelsestatement { [$1] }
| whilestatement { [$1] } | whilestatement { [$1] }
| forstatement { [$1] }
expression : assignmentexpression { $1 } expression : assignmentexpression { $1 }
@ -238,21 +224,6 @@ ifthenelsestatement : IF LBRACE expression RBRACE statementnoshortif ELSE state
whilestatement : WHILE LBRACE expression RBRACE statement { While $3 (Block $5) } whilestatement : WHILE LBRACE expression RBRACE statement { While $3 (Block $5) }
forstatement : FOR LBRACE forinit optionalexpression forupdate statement { Block ($3 ++ [While ($4) (Block ($6 ++ $5))]) }
forinit : statementexpressionlist SEMICOLON { $1 }
| localvariabledeclaration SEMICOLON { $1 }
| SEMICOLON { [] }
optionalexpression : expression SEMICOLON { $1 }
| SEMICOLON { BooleanLiteral True }
forupdate : statementexpressionlist RBRACE { $1 }
| RBRACE { [] }
statementexpressionlist : statementexpression { [StatementExpressionStatement $1] }
| statementexpressionlist COMMA statementexpression { $1 ++ [StatementExpressionStatement $3] }
assignmentexpression : conditionalexpression { $1 } assignmentexpression : conditionalexpression { $1 }
| assignment { StatementExpressionExpression $1 } | assignment { StatementExpressionExpression $1 }
@ -294,7 +265,6 @@ conditionalorexpression : conditionalandexpression { $1 }
-- | conditionalorexpression LOGICALOR conditionalandexpression{ } -- | conditionalorexpression LOGICALOR conditionalandexpression{ }
lefthandside : name { $1 } lefthandside : name { $1 }
| primary DOT IDENTIFIER { BinaryOperation NameResolution $1 (Reference $3) }
assignmentoperator : ASSIGN { Nothing } assignmentoperator : ASSIGN { Nothing }
| TIMESEQUAL { Just Multiplication } | TIMESEQUAL { Just Multiplication }
@ -317,8 +287,8 @@ postincrementexpression : postfixexpression INCREMENT { PostIncrement $1 }
postdecrementexpression : postfixexpression DECREMENT { PostDecrement $1 } postdecrementexpression : postfixexpression DECREMENT { PostDecrement $1 }
methodinvocation : name LBRACE RBRACE { let (exp, functionname) = extractFunctionName $1 in (MethodCall exp functionname []) } methodinvocation : simplename LBRACE RBRACE { MethodCall (Reference "this") $1 [] }
| name LBRACE argumentlist RBRACE { let (exp, functionname) = extractFunctionName $1 in (MethodCall exp functionname $3) } | simplename LBRACE argumentlist RBRACE { MethodCall (Reference "this") $1 $3 }
| primary DOT IDENTIFIER LBRACE RBRACE { MethodCall $1 $3 [] } | primary DOT IDENTIFIER LBRACE RBRACE { MethodCall $1 $3 [] }
| primary DOT IDENTIFIER LBRACE argumentlist RBRACE { MethodCall $1 $3 $5 } | primary DOT IDENTIFIER LBRACE argumentlist RBRACE { MethodCall $1 $3 $5 }
@ -396,34 +366,16 @@ multiplicativeexpression : unaryexpression { $1 }
{ {
data MemberDeclaration = MethodDecl MethodDeclarationWithOptionals data MethodOrFieldDeclaration = MethodDecl MethodDeclaration
| ConstructorDecl ConstructorDeclaration | FieldDecls [VariableDeclaration]
| FieldDecls [VariableDeclaration] deriving (Show)
data Declarator = Declarator Identifier (Maybe Expression) data Declarator = Declarator Identifier (Maybe Expression)
convertDeclarator :: DataType -> Declarator -> VariableDeclaration convertDeclarator :: DataType -> Declarator -> VariableDeclaration
convertDeclarator dataType (Declarator id assigment) = VariableDeclaration dataType id assigment convertDeclarator dataType (Declarator id assigment) = VariableDeclaration dataType id assigment
extractFunctionName :: Expression -> (Expression, Identifier) data StatementWithoutSub = Statement
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 Identifier [ParameterDeclaration] [OptionalParameter] Statement deriving (Show)
convertMethodDeclarationWithOptionals :: MethodDeclarationWithOptionals -> [MethodDeclaration]
convertMethodDeclarationWithOptionals (MethodDeclarationWithOptionals returnType id param [] stmt) = [MethodDeclaration returnType id param stmt]
convertMethodDeclarationWithOptionals (MethodDeclarationWithOptionals returnType id param (opt : optRest) stmt) = generateHelperMethod returnType id param opt : convertMethodDeclarationWithOptionals (generateBaseMethod returnType id param opt optRest stmt)
convertOptionalParameter :: OptionalParameter -> ParameterDeclaration
convertOptionalParameter (OptionalParameter dtype id exp) = ParameterDeclaration dtype id
generateHelperMethod :: DataType -> Identifier -> [ParameterDeclaration] -> OptionalParameter -> MethodDeclaration
generateHelperMethod returnType 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 methodName params $ Block [lastStatement]
generateBaseMethod :: DataType -> Identifier -> [ParameterDeclaration] -> OptionalParameter -> [OptionalParameter] -> Statement -> MethodDeclarationWithOptionals
generateBaseMethod returnType methodName params (OptionalParameter dtype id exp) optRest stmt = MethodDeclarationWithOptionals returnType methodName (params ++ [ParameterDeclaration dtype id]) optRest stmt
parseError :: ([Token], [String]) -> a parseError :: ([Token], [String]) -> a
parseError (errortoken, expected) = error ("parse error on token: " ++ show errortoken ++ "\nexpected one of: " ++ show expected) parseError (errortoken, expected) = error ("parse error on token: " ++ show errortoken ++ "\nexpected one of: " ++ show expected)

View File

@ -3,48 +3,18 @@ import Data.List (find)
import Data.Maybe import Data.Maybe
import Ast import Ast
typeCheckCompilationUnit :: CompilationUnit -> CompilationUnit typeCheckCompilationUnit :: CompilationUnit -> CompilationUnit
typeCheckCompilationUnit classes = typeCheckCompilationUnit classes = map (`typeCheckClass` classes) classes
let
-- Helper function to add a default constructor if none are present
ensureDefaultConstructor :: Class -> Class
ensureDefaultConstructor (Class className constructors methods fields) =
let
defaultConstructor = ConstructorDeclaration className [] (Block [])
constructorsWithDefault = if null constructors then [defaultConstructor] else constructors
in Class className constructorsWithDefault methods fields
-- Inject default constructors into all classes
classesWithDefaultConstructors = map ensureDefaultConstructor classes
in map (`typeCheckClass` classesWithDefaultConstructors) classesWithDefaultConstructors
typeCheckClass :: Class -> [Class] -> Class typeCheckClass :: Class -> [Class] -> Class
typeCheckClass (Class className constructors methods fields) classes = typeCheckClass (Class className methods fields) classes =
let let
-- Fields and methods dont need to be added to the symtab because they are looked upon automatically under "this" -- 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. -- if its not a declared local variable. Also shadowing wouldnt be possible then.
initalSymTab = [("this", className)] initalSymTab = [("this", className)]
checkedConstructors = map (\constructor -> typeCheckConstructorDeclaration constructor initalSymTab classes) constructors
checkedMethods = map (\method -> typeCheckMethodDeclaration method initalSymTab classes) methods checkedMethods = map (\method -> typeCheckMethodDeclaration method initalSymTab classes) methods
checkedFields = map (\field -> typeCheckVariableDeclaration field initalSymTab classes) fields checkedFields = map (\field -> typeCheckVariableDeclaration field initalSymTab classes) fields
in Class className checkedConstructors checkedMethods checkedFields in Class className checkedMethods checkedFields
typeCheckConstructorDeclaration :: ConstructorDeclaration -> [(Identifier, DataType)] -> [Class] -> ConstructorDeclaration
typeCheckConstructorDeclaration (ConstructorDeclaration name params body) symtab classes =
let
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
in if name == className
then if bodyType == "void"
then ConstructorDeclaration 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 -> [(Identifier, DataType)] -> [Class] -> MethodDeclaration
typeCheckMethodDeclaration (MethodDeclaration retType name params body) symtab classes = typeCheckMethodDeclaration (MethodDeclaration retType name params body) symtab classes =
@ -67,18 +37,14 @@ typeCheckVariableDeclaration (VariableDeclaration dataType identifier maybeExpr)
-- Type check the initializer expression if it exists -- Type check the initializer expression if it exists
checkedExpr = fmap (\expr -> typeCheckExpression expr symtab classes) maybeExpr checkedExpr = fmap (\expr -> typeCheckExpression expr symtab classes) maybeExpr
exprType = fmap getTypeFromExpr checkedExpr exprType = fmap getTypeFromExpr checkedExpr
checkedExprWithType = case exprType of
Just "null" | isObjectType dataType -> Just (TypedExpression dataType NullLiteral)
_ -> checkedExpr
in case (validType, redefined, exprType) of in case (validType, redefined, exprType) of
(False, _, _) -> error $ "Type '" ++ dataType ++ "' is not a valid type for variable '" ++ identifier ++ "'" (False, _, _) -> error $ "Type '" ++ dataType ++ "' is not a valid type for variable '" ++ identifier ++ "'"
(_, True, _) -> error $ "Variable '" ++ identifier ++ "' is redefined in the same scope" (_, True, _) -> error $ "Variable '" ++ identifier ++ "' is redefined in the same scope"
(_, _, Just t) (_, _, Just t)
| t == "null" && isObjectType dataType -> VariableDeclaration dataType identifier checkedExprWithType | t == "null" && isObjectType dataType -> VariableDeclaration dataType identifier checkedExpr
| t /= dataType -> error $ "Type mismatch in declaration of '" ++ identifier ++ "': expected " ++ dataType ++ ", found " ++ t | t /= dataType -> error $ "Type mismatch in declaration of '" ++ identifier ++ "': expected " ++ dataType ++ ", found " ++ t
| otherwise -> VariableDeclaration dataType identifier checkedExprWithType | otherwise -> VariableDeclaration dataType identifier checkedExpr
(_, _, Nothing) -> VariableDeclaration dataType identifier checkedExprWithType (_, _, Nothing) -> VariableDeclaration dataType identifier checkedExpr
-- ********************************** Type Checking: Expressions ********************************** -- ********************************** Type Checking: Expressions **********************************
@ -93,9 +59,9 @@ typeCheckExpression (Reference id) symtab classes =
Nothing -> Nothing ->
case lookup "this" symtab of case lookup "this" symtab of
Just className -> Just className ->
let classDetails = find (\(Class name _ _ _) -> name == className) classes let classDetails = find (\(Class name _ _) -> name == className) classes
in case classDetails of in case classDetails of
Just (Class _ _ _ fields) -> Just (Class _ _ fields) ->
let fieldTypes = [dt | VariableDeclaration dt fieldId _ <- fields, fieldId == id] let fieldTypes = [dt | VariableDeclaration dt fieldId _ <- fields, fieldId == id]
-- this case only happens when its a field of its own class so the implicit this will be converted to explicit this -- 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 in case fieldTypes of
@ -159,83 +125,67 @@ typeCheckStatementExpression (Assignment ref expr) symtab classes =
ref' = typeCheckExpression ref symtab classes ref' = typeCheckExpression ref symtab classes
type' = getTypeFromExpr expr' type' = getTypeFromExpr expr'
type'' = getTypeFromExpr ref' 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 in
if type'' == typeToAssign then if type'' == type' || (type' == "null" && isObjectType type'') then
TypedStatementExpression type'' (Assignment ref' exprWithType) TypedStatementExpression type'' (Assignment ref' expr')
else else
error $ "Type mismatch in assignment to variable: expected " ++ type'' ++ ", found " ++ typeToAssign error $ "Type mismatch in assignment to variable: expected " ++ type'' ++ ", found " ++ type'
typeCheckStatementExpression (ConstructorCall className args) symtab classes = typeCheckStatementExpression (ConstructorCall className args) symtab classes =
case find (\(Class name _ _ _) -> name == className) classes of case find (\(Class name _ _) -> name == className) classes of
Nothing -> error $ "Class '" ++ className ++ "' not found." Nothing -> error $ "Class '" ++ className ++ "' not found."
Just (Class _ constructors _ _) -> Just (Class _ methods fields) ->
let -- Find constructor matching the class name with void return type
matchParams (ParameterDeclaration paramType _) arg = case find (\(MethodDeclaration retType name params _) -> name == "<init>" && retType == "void") methods of
let argTyped = typeCheckExpression arg symtab classes -- If no constructor is found, assume standard constructor with no parameters
argType = getTypeFromExpr argTyped Nothing ->
in if argType == "null" && isObjectType paramType if null args then
then Just (TypedExpression paramType NullLiteral) TypedStatementExpression className (ConstructorCall className args)
else if argType == paramType else
then Just argTyped error $ "No valid constructor found for class '" ++ className ++ "', but arguments were provided."
else Nothing Just (MethodDeclaration _ _ params _) ->
let
matchConstructor (ConstructorDeclaration name params _) = args' = map (\arg -> typeCheckExpression arg symtab classes) args
let matchedArgs = sequence $ zipWith matchParams params args -- Extract expected parameter types from the constructor's parameters
in fmap (\checkedArgs -> (params, checkedArgs)) matchedArgs expectedTypes = [dataType | ParameterDeclaration dataType _ <- params]
argTypes = map getTypeFromExpr args'
validConstructors = filter (\(params, _) -> length params == length args) $ mapMaybe matchConstructor constructors -- Check if the types of the provided arguments match the expected types
typeMatches = zipWith (\expected actual -> if expected == actual then Nothing else Just (expected, actual)) expectedTypes argTypes
expectedSignatures = [ map (\(ParameterDeclaration t _) -> t) params | ConstructorDeclaration _ params _ <- constructors ] mismatchErrors = map (\(exp, act) -> "Expected type '" ++ exp ++ "', found '" ++ act ++ "'.") (catMaybes typeMatches)
actualSignature = map (\arg -> getTypeFromExpr (typeCheckExpression arg symtab classes)) args in
mismatchDetails = "Constructor not found for class '" ++ className ++ "' with given arguments.\n" ++ if length args /= length params then
"Expected signatures:\n" ++ show expectedSignatures ++ error $ "Constructor for class '" ++ className ++ "' expects " ++ show (length params) ++ " arguments, but got " ++ show (length args) ++ "."
"\nActual arguments:" ++ show actualSignature else if not (null mismatchErrors) then
error $ unlines $ ("Type mismatch in constructor arguments for class '" ++ className ++ "':") : mismatchErrors
in case validConstructors of else
[(_, checkedArgs)] -> TypedStatementExpression className (ConstructorCall className args')
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 = typeCheckStatementExpression (MethodCall expr methodName args) symtab classes =
let objExprTyped = typeCheckExpression expr symtab classes let objExprTyped = typeCheckExpression expr symtab classes
in case objExprTyped of in case objExprTyped of
TypedExpression objType _ -> TypedExpression objType _ ->
case find (\(Class className _ _ _) -> className == objType) classes of case find (\(Class className _ _) -> className == objType) classes of
Just (Class _ _ methods _) -> Just (Class _ methods _) ->
let matchParams (ParameterDeclaration paramType _) arg = case find (\(MethodDeclaration retType name params _) -> name == methodName) methods of
let argTyped = typeCheckExpression arg symtab classes Just (MethodDeclaration retType _ params _) ->
argType = getTypeFromExpr argTyped let args' = map (\arg -> typeCheckExpression arg symtab classes) args
in if argType == "null" && isObjectType paramType expectedTypes = [dataType | ParameterDeclaration dataType _ <- params]
then Just (TypedExpression paramType NullLiteral) argTypes = map getTypeFromExpr args'
else if argType == paramType typeMatches = zipWith (\expType argType -> (expType == argType, expType, argType)) expectedTypes argTypes
then Just argTyped mismatches = filter (not . fst3) typeMatches
else Nothing where fst3 (a, _, _) = a
in
matchMethod (MethodDeclaration retType name params _) = if null mismatches && length args == length params then
let matchedArgs = sequence $ zipWith matchParams params args TypedStatementExpression retType (MethodCall objExprTyped methodName args')
in fmap (\checkedArgs -> (MethodDeclaration retType name params (Block []), checkedArgs)) matchedArgs else if not (null mismatches) then
error $ unlines $ ("Argument type mismatches for method '" ++ methodName ++ "':")
validMethods = filter (\(MethodDeclaration _ name params _, _) -> name == methodName && length params == length args) $ mapMaybe matchMethod methods : [ "Expected: " ++ expType ++ ", Found: " ++ argType | (_, expType, argType) <- mismatches ]
else
expectedSignatures = [ map (\(ParameterDeclaration t _) -> t) params | MethodDeclaration _ name params _ <- methods, name == methodName ] error $ "Incorrect number of arguments for method '" ++ methodName ++ "'. Expected " ++ show (length expectedTypes) ++ ", found " ++ show (length args) ++ "."
actualSignature = map (\arg -> getTypeFromExpr (typeCheckExpression arg symtab classes)) args Nothing -> error $ "Method '" ++ methodName ++ "' not found in class '" ++ objType ++ "'."
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." Nothing -> error $ "Class for object type '" ++ objType ++ "' not found."
_ -> error "Invalid object type for method call. Object must have a class type." _ -> error "Invalid object type for method call. Object must have a class type."
typeCheckStatementExpression (PostIncrement expr) symtab classes = typeCheckStatementExpression (PostIncrement expr) symtab classes =
let expr' = typeCheckExpression expr symtab classes let expr' = typeCheckExpression expr symtab classes
type' = getTypeFromExpr expr' type' = getTypeFromExpr expr'
@ -301,18 +251,14 @@ typeCheckStatement (LocalVariableDeclaration (VariableDeclaration dataType ident
-- If there's an initializer expression, type check it -- If there's an initializer expression, type check it
let checkedExpr = fmap (\expr -> typeCheckExpression expr symtab classes) maybeExpr let checkedExpr = fmap (\expr -> typeCheckExpression expr symtab classes) maybeExpr
exprType = fmap getTypeFromExpr checkedExpr exprType = fmap getTypeFromExpr checkedExpr
checkedExprWithType = case (exprType, dataType) of
(Just "null", _) | isObjectType dataType -> Just (TypedExpression dataType NullLiteral)
_ -> checkedExpr
in case exprType of in case exprType of
Just t Just t
| t == "null" && isObjectType dataType -> | t == "null" && isObjectType dataType ->
TypedStatement dataType (LocalVariableDeclaration (VariableDeclaration dataType identifier checkedExprWithType)) TypedStatement dataType (LocalVariableDeclaration (VariableDeclaration dataType identifier checkedExpr))
| t /= dataType -> error $ "Type mismatch in declaration of '" ++ identifier ++ "': expected " ++ dataType ++ ", found " ++ t | t /= dataType -> error $ "Type mismatch in declaration of '" ++ identifier ++ "': expected " ++ dataType ++ ", found " ++ t
| otherwise -> TypedStatement dataType (LocalVariableDeclaration (VariableDeclaration dataType identifier checkedExprWithType)) | otherwise -> TypedStatement dataType (LocalVariableDeclaration (VariableDeclaration dataType identifier checkedExpr))
Nothing -> TypedStatement dataType (LocalVariableDeclaration (VariableDeclaration dataType identifier checkedExpr)) Nothing -> TypedStatement dataType (LocalVariableDeclaration (VariableDeclaration dataType identifier checkedExpr))
typeCheckStatement (While cond stmt) symtab classes = typeCheckStatement (While cond stmt) symtab classes =
let cond' = typeCheckExpression cond symtab classes let cond' = typeCheckExpression cond symtab classes
stmt' = typeCheckStatement stmt symtab classes stmt' = typeCheckStatement stmt symtab classes
@ -359,17 +305,13 @@ typeCheckStatement (Block statements) symtab classes =
typeCheckStatement (Return expr) symtab classes = typeCheckStatement (Return expr) symtab classes =
let methodReturnType = fromMaybe (error "Method return type not found in symbol table") (lookup "thisMeth" symtab) let methodReturnType = fromMaybe (error "Method return type not found in symbol table") (lookup "thisMeth" symtab)
expr' = case expr of expr' = case expr of
Just e -> let eTyped = typeCheckExpression e symtab classes Just e -> Just (typeCheckExpression e symtab classes)
in if getTypeFromExpr eTyped == "null" && isObjectType methodReturnType
then Just (TypedExpression methodReturnType NullLiteral)
else Just eTyped
Nothing -> Nothing Nothing -> Nothing
returnType = maybe "void" getTypeFromExpr expr' returnType = maybe "void" getTypeFromExpr expr'
in if returnType == methodReturnType || isSubtype returnType methodReturnType classes in if returnType == methodReturnType || isSubtype returnType methodReturnType classes
then TypedStatement returnType (Return expr') then TypedStatement returnType (Return expr')
else error $ "Return: Return type mismatch: expected " ++ methodReturnType ++ ", found " ++ returnType else error $ "Return: Return type mismatch: expected " ++ methodReturnType ++ ", found " ++ returnType
typeCheckStatement (StatementExpressionStatement stmtExpr) symtab classes = typeCheckStatement (StatementExpressionStatement stmtExpr) symtab classes =
let stmtExpr' = typeCheckStatementExpression stmtExpr symtab classes let stmtExpr' = typeCheckStatementExpression stmtExpr symtab classes
in TypedStatement (getTypeFromStmtExpr stmtExpr') (StatementExpressionStatement stmtExpr') in TypedStatement (getTypeFromStmtExpr stmtExpr') (StatementExpressionStatement stmtExpr')
@ -385,7 +327,7 @@ isSubtype subType superType classes
| otherwise = False | otherwise = False
isUserDefinedClass :: DataType -> [Class] -> Bool isUserDefinedClass :: DataType -> [Class] -> Bool
isUserDefinedClass dt classes = dt `elem` map (\(Class name _ _ _) -> name) classes isUserDefinedClass dt classes = dt `elem` map (\(Class name _ _) -> name) classes
isObjectType :: DataType -> Bool isObjectType :: DataType -> Bool
isObjectType dt = dt /= "int" && dt /= "boolean" && dt /= "char" isObjectType dt = dt /= "int" && dt /= "boolean" && dt /= "char"
@ -438,14 +380,9 @@ checkComparisonOperation op expr1' expr2' type1 type2
checkEqualityOperation :: BinaryOperator -> Expression -> Expression -> DataType -> DataType -> Expression checkEqualityOperation :: BinaryOperator -> Expression -> Expression -> DataType -> DataType -> Expression
checkEqualityOperation op expr1' expr2' type1 type2 checkEqualityOperation op expr1' expr2' type1 type2
| type1 == type2 || (type1 == "null" && isObjectType type2) || (type2 == "null" && isObjectType type1) = | type1 == type2 =
TypedExpression "boolean" (BinaryOperation op expr1' expr2') TypedExpression "boolean" (BinaryOperation op expr1' expr2')
| type1 /= type2 = | otherwise = error $ "Equality operation " ++ show op ++ " requires operands of the same type"
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 :: BinaryOperator -> Expression -> Expression -> DataType -> DataType -> Expression
checkLogicalOperation op expr1' expr2' type1 type2 checkLogicalOperation op expr1' expr2' type1 type2
@ -457,8 +394,8 @@ resolveNameResolution :: Expression -> Expression -> [(Identifier, DataType)] ->
resolveNameResolution expr1' (Reference ident2) symtab classes = resolveNameResolution expr1' (Reference ident2) symtab classes =
case getTypeFromExpr expr1' of case getTypeFromExpr expr1' of
objType -> objType ->
case find (\(Class className _ _ _) -> className == objType) classes of case find (\(Class className _ _) -> className == objType) classes of
Just (Class _ _ _ fields) -> Just (Class _ _ fields) ->
let fieldTypes = [dt | VariableDeclaration dt id _ <- fields, id == ident2] let fieldTypes = [dt | VariableDeclaration dt id _ <- fields, id == ident2]
in case fieldTypes of in case fieldTypes of
[resolvedType] -> TypedExpression resolvedType (BinaryOperation NameResolution expr1' (TypedExpression resolvedType (FieldVariable ident2))) [resolvedType] -> TypedExpression resolvedType (BinaryOperation NameResolution expr1' (TypedExpression resolvedType (FieldVariable ident2)))