move defaultconstructor injection to the beginning befor typechecking the classes

Reviewed-on: #6

README.md

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

Test/JavaSources/Main.java

@@ -1,7 +1,7 @@
 // compile all test files using:
 // ls Test/JavaSources/*.java | grep -v ".*Main.java" | xargs -I {} cabal run compiler {}
 // compile (in project root) using:
-// javac -g:none -sourcepath Test/JavaSources/ Test/JavaSources/Main.java 
+// pushd Test/JavaSources; javac -g:none Main.java; popd
 // afterwards, run using
 // java -ea -cp Test/JavaSources/ Main
 
@@ -11,6 +11,7 @@ public class Main {
         TestEmpty empty = new TestEmpty();
         TestFields fields = new TestFields();
         TestConstructor constructor = new TestConstructor(42);
+        TestArithmetic arithmetic = new TestArithmetic();
         TestMultipleClasses multipleClasses = new TestMultipleClasses();
         TestRecursion recursion = new TestRecursion(10);
         TestMalicious malicious = new TestMalicious();
@@ -21,6 +22,10 @@ public class Main {
         assert fields.a == 0 && fields.b == 42;
         // constructor parameters override initializers
         assert constructor.a == 42;
+        // basic arithmetics
+        assert arithmetic.basic(1, 2, 3) == 2;
+        // we have boolean logic as well
+        assert arithmetic.logic(false, false, true) == true;
         // multiple classes within one file work. Referencing another classes fields/methods works.
         assert multipleClasses.a.a == 42;
         // self-referencing classes work.

Test/JavaSources/TestArithmetic.java

@@ -0,0 +1,11 @@
+public class TestArithmetic {
+    public int basic(int a, int b, int c)
+    {
+        return a + b - c * a / b % c;
+    }
+
+    public boolean logic(boolean a, boolean b, boolean c)
+    {
+        return !a && (c || b);
+    }
+}

Test/JavaSources/TestConstructorOverload.java

@@ -0,0 +1,13 @@
+public class TestConstructorOverload {
+
+    TestConstructorOverload() {
+    }
+
+    TestConstructorOverload(int a) {
+    }
+
+    public void test() {
+        int a = 3;
+        TestConstructorOverload test = new TestConstructorOverload(a);
+    }
+}

Test/JavaSources/TestMethodOverload.java

@@ -0,0 +1,14 @@
+public class TestMethodOverload {
+
+    public void MethodOverload() {
+    }
+
+    public void MethodOverload(int a) {
+    }
+
+    public void test() {
+        int a = 3;
+        MethodOverload(a);
+    }
+    
+}

Test/JavaSources/TestRecursion.java

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

Test/JavaSources/TestSingleton.java

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

Test/TestParser.hs

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

doc/bytecode.md

@@ -4,20 +4,7 @@ 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.
+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. Dieser Teil der Aufgabenstellung wurde gemeinsam von Christian Brier und Matthias Raba umgesetzt.
 
 ## Codegenerierung
 
@@ -32,7 +19,6 @@ Die Idee hinter beiden ist, dass sie jeweils zwei Inputs haben, wobei der Rückg
 Der Nutzer ruft beispielsweise die Funktion `classBuilder` auf. Diese wendet nach und nach folgende Transformationen an:
 
 ```
-
         methodsWithInjectedConstructor = injectDefaultConstructor methods
         methodsWithInjectedInitializers = injectFieldInitializers name fields methodsWithInjectedConstructor
 
@@ -47,7 +33,7 @@ Zuerst wird (falls notwendig) ein leerer Defaultkonstruktor in die Classfile ein
     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.
+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. Sukzessive 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:
 
@@ -66,4 +52,28 @@ assembleExpression (constants, ops, lvars) (TypedExpression _ NullLiteral) =
 
 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.
+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.
+
+## 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 beinhaltet. Alle diese Strukturen implementieren folgende TypeClass:
+
+```
+class Serializable a where
+    serialize :: a -> [Word8]
+```
+
+Hier ist ein Beispiel anhand der Serialisierung der einzelnen Operationen:
+
+```
+instance Serializable Operation where
+    serialize Opiadd                    = [0x60]
+    serialize Opisub                    = [0x64]
+    serialize Opimul                    = [0x68]
+    ...
+    serialize (Opgetfield index)        = 0xB4 : unpackWord16 index
+```
+
+Die Struktur ClassFile ruft für deren Kinder rekursiv diese `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.

doc/features.md

@@ -0,0 +1,29 @@
+# Sprach-Features
+- Klassen
+- Felder
+- Methoden (mit Parametern)
+- Konstruktoren (mit Parametern)
+- Standardkonstruktoren
+- Lokale Variablen
+- Zuweisungen (Feld- und lokale Variablen)
+- Arithmetik (+, -, *, /, %, Klammern, Korrekte Operator Precedence)
+- Arithmetische Zuweisungen (+=, -=, *=, /=, %=, &=, |=, ^=)
+- Vergleichsoperationen (<, >, <=, >=, ==, !=)
+- Boolsche Operationen (||, &&)
+- Unäre Operationen (-, ~)
+- Binar-Operationen (&, |, ^)
+- Pre/Post-Inkrement & Dekrement
+- Kontrollflussstrukturen:
+    - If/Else
+    - While
+    - For
+    - Return (mit/ohne Rückgabewert)
+- Default-Werte für alle Klassenfelder
+- Methodenaufrufe (mit Parametern), auch über Klassengrenzen
+- Mehrere Klassen in einer Datei
+- implizites "this"
+- Beliebig verschachtelte Namensketten
+- Beliebige Deklarationsreihenfolge
+- Literale für Integer und Characters
+- Deklaration und Zuweisung in einer Anweisung
+- Beliebig verschachtelte Blöcke

doc/parser.md

@@ -0,0 +1,19 @@
+# Lexer 
+(Marvin Schlegel)
+
+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.: `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.
+
+# Parser
+(Marvin Schlegel)
+
+Der Parser wurde mit dem Happy tool implementiert. Er baut aus einer Liste von Tokens einen ungetypten AST. Wir haben bereits eine Grammatik bekommen und mussten diese noch in den AST umwandeln.
+
+Um den Parser aufzubauen wurde zuerst ein Großteil der Grammatik auskommentiert und Stück für Stück wurden die Umwandlungen hinzugefügt. Immer wenn ein neues Feature umgesetzt wurde, wurde dafür ein weiterer Unit Test geschrieben. Es gibt also für jede komplexe Ableitungsregel mindestens einen Unittest.
+
+Als erstes wurden leere Methoden und Felder umgesetzt. Da in Java Methoden und Felder durcheinander vorkommen können geben die Ableitungsregeln einen Datentype namens `MethodOrFieldDeclaration` zurück. Über Pattern Matching baut die classbodydeclarations Regel dann eine Tupel mit einer Liste aus Methoden und einer aus Feldern. Über pattern matching werden diese Listen dann erweitert und in der darüberliegenden Regel schließlich extrahiert. Die Konstruktoren sind in diesem Fall auch normale Methoden mit dem Rückgabewert `void` und dem Namen `<init>`. Auf diese Weise müssen sie nicht mehr vom Typcheck oder vom Bytecode verändert werden.
+
+In Java ist es möglich mehrere Variablen in einer Zeile zu deklarieren (Bsp.: `int x, y;`). Beim Parsen ergiebt sich dann die Schwierigkeit, dass man in dem Moment, wo man die Variable parst nicht weiß welchen Datentyp diese hat. Aus diesem Grund gibt es den Datentyp Declarator, welcher nur den Identifier und eventuell eine Zuweisung enthält. In den darüberliegenden Regeln fielddeclaration und localvariabledeclaration wird dann die Typinformation hinzugefügt mithilfe der Funktion convertDeclarator.
+
+Für die Zuweisung wird auch die Kombination mit Rechenoperatoren unterstützt. Das ganze ist als syntactic sugar im Parser umgesetzt. Wenn es einen Zuweisungsoperator gibt, dann wird der Ausdruck in eine Zuweisung und Rechnung aufgeteilt. Bsp.: `x += 3;` wird umgewandelt in `x = x + 3`.

doc/typecheck.md

@@ -1,10 +1,11 @@
-# Typcheck (Fabian Noll)
+
+# Typecheck (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.
+Die Typprüfung einer Klasse umfasst die Überprüfung aller Konstruktoren, Methoden und Felder. Die Methode `typeCheckConstructorDeclaration` ist für die Typprüfung einzelner Konstruktordeklarationen verantwortlich, während `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 `typeCheckStatement` überprüft, die verschiedene Arten von Anweisungen wie If-Anweisungen, While-Schleifen, Rückgabeanweisungen und Blockanweisungen behandelt.
 
 ## Ablauf und Symboltabellen
 
@@ -15,6 +16,9 @@ Eine zentrale Komponente des Typecheckers ist die Symboltabelle (symtab), die In
 - **Klassenkontext**:
   Beim Typcheck einer Klasse wird eine initiale Symboltabelle erstellt, die die `this`-Referenz enthält. Dies geschieht in der Funktion `typeCheckClass`.
 
+- **Konstruktorkontext**:
+  Innerhalb eines Konstruktors wird die Symboltabelle um die Parameter des Konstruktors erweitert. Dies geschieht in `typeCheckConstructorDeclaration`. Der Rückgabetyp eines Konstruktors ist implizit `void`, was überprüft wird, um sicherzustellen, dass kein Wert zurückgegeben wird.
+
 - **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`.
 
@@ -30,7 +34,7 @@ Bei der Typprüfung von Referenzen (`typeCheckExpression` für Reference) wird z
 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.
+  Wenn der Rückgabetyp einer Methode nicht mit dem deklarierten Rückgabetyp übereinstimmt oder die Anzahl der Parameter nicht übereinstimmt.
 
 - **Ungültige Operationen**:
   Wenn eine arithmetische Operation auf inkompatiblen Typen durchgeführt wird.
@@ -53,3 +57,23 @@ Die Typprüfung eines Blocks erfolgt in `typeCheckStatement` für Block. Jede An
 ### 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.
+
+### Konstruktorüberladung und -prüfung
+
+Die Typprüfung unterstützt Konstruktorüberladung. Bei der Typprüfung von Konstruktoraufrufen (`typeCheckStatementExpression` für `ConstructorCall`) wird überprüft, ob es mehrere Konstruktoren mit derselben Anzahl von Parametern gibt. Falls mehrere passende Konstruktoren gefunden werden, wird ein Fehler gemeldet.
+
+- **Parameterabgleich**:
+  Die Parameter eines Konstruktors werden gegen die Argumente des Aufrufs abgeglichen. Dies umfasst die Prüfung der Typen und, falls es sich um `null` handelt, die Überprüfung, ob der Parameter ein Objekttyp ist.
+
+- **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.
+
+### Methodenüberladung und -prüfung
+
+Die Typprüfung unterstützt auch Methodenüberladung. Bei der Typprüfung von Methodenaufrufen (`typeCheckStatementExpression` für `MethodCall`) wird überprüft, ob es mehrere Methoden mit demselben Namen, aber unterschiedlichen Parametertypen gibt.
+
+- **Parameterabgleich**:
+  Die Parameter einer Methode werden gegen die Argumente des Aufrufs abgeglichen. Dies umfasst die Prüfung der Typen und, falls es sich um `null` handelt, die Überprüfung, ob der Parameter ein Objekttyp ist.
+
+- **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.

project.cabal

@@ -42,10 +42,4 @@ test-suite tests
                         Parser.JavaParser,
                         Ast,
                         TestLexer,
-                        TestParser,
-                        ByteCode.Util,
-                        ByteCode.ByteUtil,
-                        ByteCode.ClassFile,
-                        ByteCode.Assembler,
-                        ByteCode.Builder,
-                        ByteCode.Constants
+                        TestParser

src/Ast.hs

@@ -2,12 +2,13 @@ module Ast where
 
 type CompilationUnit = [Class]
 type DataType = String
-type Identifier = String 
+type Identifier = String
 
 data ParameterDeclaration = ParameterDeclaration DataType Identifier deriving (Show, Eq)
 data VariableDeclaration = VariableDeclaration DataType Identifier (Maybe Expression) deriving (Show, Eq)
-data Class = Class DataType [MethodDeclaration] [VariableDeclaration] deriving (Show, Eq)
+data Class = Class DataType [ConstructorDeclaration] [MethodDeclaration] [VariableDeclaration] deriving (Show, Eq)
 data MethodDeclaration = MethodDeclaration DataType Identifier [ParameterDeclaration] Statement deriving (Show, Eq)
+data ConstructorDeclaration = ConstructorDeclaration Identifier [ParameterDeclaration] Statement deriving (Show, Eq)
 
 data Statement
   = If Expression Statement (Maybe Statement)

src/ByteCode/Assembler.hs

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

src/ByteCode/Builder.hs

@@ -22,14 +22,14 @@ fieldBuilder (VariableDeclaration datatype name _) input = let
             ]
         field = MemberInfo {
             memberAccessFlags = accessPublic,
-            memberNameIndex = (fromIntegral (baseIndex + 2)),
-            memberDescriptorIndex = (fromIntegral (baseIndex + 3)),
+            memberNameIndex = fromIntegral (baseIndex + 2),
+            memberDescriptorIndex = fromIntegral (baseIndex + 3),
             memberAttributes = []
             }
     in
         input {
-            constantPool = (constantPool input) ++ constants,
-            fields = (fields input) ++ [field]
+            constantPool = constantPool input ++ constants,
+            fields = fields input ++ [field]
         }
 
 
@@ -46,16 +46,15 @@ methodBuilder (MethodDeclaration returntype name parameters statement) input = l
 
         method = MemberInfo {
             memberAccessFlags = accessPublic,
-            memberNameIndex = (fromIntegral (baseIndex + 2)),
-            memberDescriptorIndex = (fromIntegral (baseIndex + 3)),
+            memberNameIndex = fromIntegral (baseIndex + 2),
+            memberDescriptorIndex = fromIntegral (baseIndex + 3),
             memberAttributes = []
             }
-    in 
+    in
         input {
-            constantPool = (constantPool input) ++ constants,
-            methods = (methods input) ++ [method]
+            constantPool = constantPool input ++ constants,
+            methods = methods input ++ [method]
         }
-        
 
 
 methodAssembler :: ClassFileBuilder MethodDeclaration
@@ -66,21 +65,22 @@ methodAssembler (MethodDeclaration returntype name parameters statement) input =
         Just index -> let
                 declaration = MethodDeclaration returntype name parameters statement
                 paramNames = "this" : [name | ParameterDeclaration _ name <- parameters]
-            in case (splitAt index (methods input)) of
+            in case splitAt index (methods input) of
                 (pre, []) -> input
                 (pre, method : post) -> let
-                        (_, bytecode, _) = assembleMethod (constantPool input, [], paramNames) declaration
+                        (constants, bytecode, aParamNames) = assembleMethod (constantPool input, [], paramNames) declaration
                         assembledMethod = method {
                             memberAttributes = [
                                 CodeAttribute {
-                                    attributeMaxStack = 420,
-                                    attributeMaxLocals = 420,
+                                    attributeMaxStack = fromIntegral $ maxStackDepth constants bytecode,
+                                    attributeMaxLocals = fromIntegral $ length aParamNames,
                                     attributeCode = bytecode
                                 }
                             ]
                         }
                     in
                         input {
+                            constantPool = constants,
                             methods = pre ++ (assembledMethod : post)
                         }
 
@@ -94,11 +94,12 @@ classBuilder (Class name methods fields) _ = let
             Utf8Info "java/lang/Object",
             Utf8Info "<init>",
             Utf8Info "()V",
-            Utf8Info "Code"
+            Utf8Info "Code",
+            ClassInfo 9,
+            Utf8Info name
             ]
-        nameConstants = [ClassInfo 9, Utf8Info name]
         nakedClassFile = ClassFile {
-            constantPool = baseConstants ++ nameConstants,
+            constantPool = baseConstants,
             accessFlags = accessPublic,
             thisClass = 8,
             superClass = 1,
@@ -107,9 +108,13 @@ classBuilder (Class name methods fields) _ = let
             attributes = []
         }
 
+        -- if a class has no constructor, inject an empty one.
         methodsWithInjectedConstructor = injectDefaultConstructor methods
+        -- for every constructor, prepend all initialization assignments for fields.
         methodsWithInjectedInitializers = injectFieldInitializers name fields methodsWithInjectedConstructor
 
+        -- add fields, then method bodies to the classfile. After all referable names are known,
+        -- assemble the methods into bytecode.
         classFileWithFields = foldr fieldBuilder nakedClassFile fields
         classFileWithMethods = foldr methodBuilder classFileWithFields methodsWithInjectedInitializers
         classFileWithAssembledMethods = foldr methodAssembler classFileWithMethods methodsWithInjectedInitializers

src/ByteCode/ClassFile.hs

@@ -1,14 +1,4 @@
-module ByteCode.ClassFile(
-    ConstantInfo(..),
-    Attribute(..),
-    MemberInfo(..),
-    ClassFile(..),
-    Operation(..),
-    serialize,
-    emptyClassFile,
-    opcodeEncodingLength,
-    className
-) where
+module ByteCode.ClassFile where
 
 import Data.Word
 import Data.Int
@@ -99,11 +89,11 @@ emptyClassFile = ClassFile {
 
 className :: ClassFile -> String
 className classFile = let
-        classInfo = (constantPool classFile)!!(fromIntegral (thisClass classFile))
+        classInfo = constantPool classFile !! fromIntegral (thisClass classFile)
     in case classInfo of
         Utf8Info className -> className
-        otherwise -> error ("expected Utf8Info but got: " ++ show otherwise)
-        
+        unexpected_element -> error ("expected Utf8Info but got: " ++ show unexpected_element)
+
 
 opcodeEncodingLength :: Operation -> Word16
 opcodeEncodingLength Opiadd                 = 1
@@ -201,10 +191,10 @@ instance Serializable Attribute where
     serialize (CodeAttribute { attributeMaxStack = maxStack,
                                attributeMaxLocals = maxLocals,
                                attributeCode = code }) = let
-            assembledCode = concat (map serialize code)
+            assembledCode = concatMap serialize code
         in
             unpackWord16 7                                                  -- attribute_name_index
-            ++ unpackWord32 (12 + (fromIntegral (length assembledCode)))    -- attribute_length
+            ++ unpackWord32 (12 + fromIntegral (length assembledCode))      -- attribute_length
             ++ unpackWord16 maxStack                                        -- max_stack
             ++ unpackWord16 maxLocals                                       -- max_locals
             ++ unpackWord32 (fromIntegral (length assembledCode))           -- code_length

src/ByteCode/Util.hs

@@ -4,29 +4,28 @@ import Data.Int
 import Ast
 import ByteCode.ClassFile
 import Data.List
-import Data.Maybe (mapMaybe)
+import Data.Maybe (mapMaybe, isJust)
 import Data.Word (Word8, Word16, Word32)
 
 -- walks the name resolution chain. returns the innermost Just LocalVariable/FieldVariable or Nothing.
 resolveNameChain :: Expression -> Expression
 resolveNameChain (TypedExpression _ (BinaryOperation NameResolution a b)) = resolveNameChain b
-resolveNameChain (TypedExpression dtype (LocalVariable name)) = (TypedExpression dtype (LocalVariable name))
-resolveNameChain (TypedExpression dtype (FieldVariable name)) = (TypedExpression dtype (FieldVariable name))
-resolveNameChain invalidExpression = error ("expected a NameResolution or Local/Field Variable but got: " ++ show(invalidExpression))
+resolveNameChain (TypedExpression dtype (LocalVariable name)) = TypedExpression dtype (LocalVariable name)
+resolveNameChain (TypedExpression dtype (FieldVariable name)) = TypedExpression dtype (FieldVariable name)
+resolveNameChain invalidExpression = error ("expected a NameResolution or Local/Field Variable but got: " ++ show invalidExpression)
 
 -- walks the name resolution chain. returns the second-to-last item of the namechain.
 resolveNameChainOwner :: Expression -> Expression
 resolveNameChainOwner (TypedExpression _ (BinaryOperation NameResolution a (TypedExpression dtype (FieldVariable name)))) = a
 resolveNameChainOwner (TypedExpression _ (BinaryOperation NameResolution a b)) = resolveNameChain b
-resolveNameChainOwner invalidExpression = error ("expected a NameResolution or Local/Field Variable but got: " ++ show(invalidExpression))
-
+resolveNameChainOwner invalidExpression = error ("expected a NameResolution or Local/Field Variable but got: " ++ show invalidExpression)
 
 methodDescriptor :: MethodDeclaration -> String
 methodDescriptor (MethodDeclaration returntype _ parameters _) = let
         parameter_types = [datatype | ParameterDeclaration datatype _ <- parameters]
     in
         "("
-        ++ (concat (map datatypeDescriptor parameter_types))
+        ++ concatMap datatypeDescriptor parameter_types
         ++ ")"
         ++ datatypeDescriptor returntype
 
@@ -35,50 +34,70 @@ methodDescriptorFromParamlist parameters returntype = let
         parameter_types = [datatype | TypedExpression datatype _ <- parameters]
     in
         "("
-        ++ (concat (map datatypeDescriptor parameter_types))
+        ++ concatMap datatypeDescriptor parameter_types
         ++ ")"
         ++ datatypeDescriptor returntype
 
-memberInfoIsMethod :: [ConstantInfo] -> MemberInfo -> Bool
-memberInfoIsMethod constants info = elem '(' (memberInfoDescriptor constants info)
+-- recursively parses a given type signature into a list of parameter types and the method return type.
+-- As an initial parameter, you can supply ([], "void").
+parseMethodType :: ([String], String) -> String -> ([String], String)
+parseMethodType (params, returnType) ('(' : descriptor) = parseMethodType (params, returnType) descriptor
+parseMethodType (params, returnType) ('I' : descriptor) = parseMethodType (params ++ ["I"], returnType) descriptor
+parseMethodType (params, returnType) ('C' : descriptor) = parseMethodType (params ++ ["C"], returnType) descriptor
+parseMethodType (params, returnType) ('Z' : descriptor) = parseMethodType (params ++ ["Z"], returnType) descriptor
+parseMethodType (params, returnType) ('L' : descriptor) = let
+        typeLength = elemIndex ';' descriptor
+    in case typeLength of
+        Just length -> let
+                (typeName, semicolon : restOfDescriptor) = splitAt length descriptor
+            in
+                parseMethodType (params ++ [typeName], returnType) restOfDescriptor
+        Nothing -> error $ "unterminated class type in function signature: " ++ show descriptor
+parseMethodType (params, _) (')' : descriptor) = (params, descriptor)
+parseMethodType _ descriptor = error $ "expected start of type name (L, I, C, Z) but got: " ++ descriptor
 
+-- given a method index (constant pool index), 
+-- returns the full type of the method. (i.e (LSomething;II)V)
+methodTypeFromIndex :: [ConstantInfo] -> Int -> String
+methodTypeFromIndex constants index = case constants !! fromIntegral (index - 1) of
+    MethodRefInfo _ nameAndTypeIndex -> case constants !! fromIntegral (nameAndTypeIndex - 1) of
+        NameAndTypeInfo _ typeIndex -> case constants !! fromIntegral (typeIndex - 1) of
+            Utf8Info typeLiteral -> typeLiteral
+            unexpectedElement -> error "Expected Utf8Info but got: " ++ show unexpectedElement
+        unexpectedElement -> error "Expected NameAndTypeInfo but got: " ++ show unexpectedElement
+    unexpectedElement -> error "Expected MethodRefInfo but got: " ++ show unexpectedElement
+
+methodParametersFromIndex :: [ConstantInfo] -> Int -> ([String], String)
+methodParametersFromIndex constants index = parseMethodType ([], "V") (methodTypeFromIndex constants index)
+
+memberInfoIsMethod :: [ConstantInfo] -> MemberInfo -> Bool
+memberInfoIsMethod constants info = '(' `elem` memberInfoDescriptor constants info
 
 datatypeDescriptor :: String -> String
 datatypeDescriptor "void" = "V"
 datatypeDescriptor "int" = "I"
 datatypeDescriptor "char" = "C"
-datatypeDescriptor "boolean" = "B"
+datatypeDescriptor "boolean" = "Z"
 datatypeDescriptor x = "L" ++ x ++ ";"
 
-
 memberInfoDescriptor :: [ConstantInfo] -> MemberInfo -> String
-memberInfoDescriptor constants MemberInfo {
-    memberAccessFlags = _,
-    memberNameIndex = _,
-    memberDescriptorIndex = descriptorIndex,
-    memberAttributes = _ } = let
-            descriptor = constants!!((fromIntegral descriptorIndex) - 1)
+memberInfoDescriptor constants MemberInfo { memberDescriptorIndex = descriptorIndex } = let
+            descriptor = constants !! (fromIntegral descriptorIndex - 1)
         in case descriptor of
             Utf8Info descriptorText -> descriptorText
-            _ -> ("Invalid Item at Constant pool index " ++ show descriptorIndex)
-
+            _ -> "Invalid Item at Constant pool index " ++ show descriptorIndex
 
 memberInfoName :: [ConstantInfo] -> MemberInfo -> String
-memberInfoName constants MemberInfo {
-    memberAccessFlags = _,
-    memberNameIndex = nameIndex,
-    memberDescriptorIndex = _,
-    memberAttributes = _ } = let
-            name = constants!!((fromIntegral nameIndex) - 1)
+memberInfoName constants MemberInfo { memberNameIndex = nameIndex } = let
+            name = constants !! (fromIntegral nameIndex - 1)
         in case name of
             Utf8Info nameText -> nameText
-            _ -> ("Invalid Item at Constant pool index " ++ show nameIndex)
-
+            _ -> "Invalid Item at Constant pool index " ++ show nameIndex
 
 returnOperation :: DataType -> Operation
 returnOperation dtype
-    | elem dtype ["int", "char", "boolean"] = Opireturn
-    | otherwise                             = Opareturn
+    | dtype `elem` ["int", "char", "boolean"] = Opireturn
+    | otherwise                               = Opareturn
 
 binaryOperation :: BinaryOperator -> Operation
 binaryOperation Addition       = Opiadd
@@ -100,53 +119,30 @@ comparisonOperation CompareLessOrEqual    branchLocation = Opif_icmple branchLoc
 comparisonOperation CompareGreaterThan    branchLocation = Opif_icmpgt branchLocation
 comparisonOperation CompareGreaterOrEqual branchLocation = Opif_icmpge branchLocation
 
-findFieldIndex :: [ConstantInfo] -> String -> Maybe Int
-findFieldIndex constants name = let
-        fieldRefNameInfos = [
-                -- we only skip one entry to get the name since the Java constant pool
-                -- is 1-indexed (why)
-                (index, constants!!(fromIntegral index + 1))
-                | (index, FieldRefInfo classIndex _) <- (zip [1..] constants)
-            ]
-        fieldRefNames = map (\(index, nameInfo) -> case nameInfo of
-            Utf8Info fieldName -> (index, fieldName)
-            something_else -> error ("Expected UTF8Info but got" ++ show something_else))
-                fieldRefNameInfos
-        fieldIndex = find (\(index, fieldName) -> fieldName == name) fieldRefNames
-    in case fieldIndex of
-        Just (index, _) -> Just index
-        Nothing -> Nothing
-
-findMethodRefIndex :: [ConstantInfo] -> String -> Maybe Int
-findMethodRefIndex constants name = let
-        methodRefNameInfos = [
-                -- we only skip one entry to get the name since the Java constant pool
-                -- is 1-indexed (why)
-                (index, constants!!(fromIntegral index + 1))
-                | (index, MethodRefInfo _ _) <- (zip [1..] constants)
-            ]
-        methodRefNames = map (\(index, nameInfo) -> case nameInfo of
-            Utf8Info methodName -> (index, methodName)
-            something_else -> error ("Expected UTF8Info but got " ++ show something_else))
-                methodRefNameInfos
-        methodIndex = find (\(index, methodName) -> methodName == name) methodRefNames
-    in case methodIndex of
-        Just (index, _) -> Just index
-        Nothing -> Nothing
+comparisonOffset :: Operation -> Maybe Int
+comparisonOffset (Opif_icmpeq offset) = Just $ fromIntegral offset
+comparisonOffset (Opif_icmpne offset) = Just $ fromIntegral offset
+comparisonOffset (Opif_icmplt offset) = Just $ fromIntegral offset
+comparisonOffset (Opif_icmple offset) = Just $ fromIntegral offset
+comparisonOffset (Opif_icmpgt offset) = Just $ fromIntegral offset
+comparisonOffset (Opif_icmpge offset) = Just $ fromIntegral offset
+comparisonOffset anything_else = Nothing
 
+isComparisonOperation :: Operation -> Bool
+isComparisonOperation op = isJust (comparisonOffset op)
 
 findMethodIndex :: ClassFile -> String -> Maybe Int
 findMethodIndex classFile name = let
         constants = constantPool classFile
     in
-        findIndex (\method -> ((memberInfoIsMethod constants method) && (memberInfoName constants method) == name)) (methods classFile)
+        findIndex (\method -> memberInfoIsMethod constants method && memberInfoName constants method == name) (methods classFile)
 
 findClassIndex :: [ConstantInfo] -> String -> Maybe Int
 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
             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
         desiredClassIndex = find (\(index, className) -> className == name) classNames
     in case desiredClassIndex of
@@ -157,12 +153,12 @@ getKnownMembers :: [ConstantInfo] -> [(Int, (String, String, String))]
 getKnownMembers constants = let
         fieldsClassAndNT = [
                 (index, constants!!(fromIntegral classIndex - 1), constants!!(fromIntegral nameTypeIndex - 1))
-                | (index, FieldRefInfo classIndex nameTypeIndex) <- (zip [1..] constants)
+                | (index, FieldRefInfo classIndex nameTypeIndex) <- zip [1..] constants
             ] ++ [
                 (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
             (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))
@@ -170,8 +166,8 @@ getKnownMembers constants = let
 
         fieldsResolved = map (\(index, (nameInfo, fnameInfo, ftypeInfo)) -> case (nameInfo, fnameInfo, ftypeInfo) of
             (Utf8Info cname, Utf8Info fname, Utf8Info ftype) -> (index, (cname, fname, ftype))
-            something_else -> error("Expected UTF8Infos but got " ++ show something_else))
-                fieldsClassNameType    
+            something_else -> error ("Expected UTF8Infos but got " ++ show something_else))
+                fieldsClassNameType
     in
         fieldsResolved
 
@@ -179,7 +175,7 @@ getKnownMembers constants = let
 getClassIndex :: [ConstantInfo] -> String -> ([ConstantInfo], Int)
 getClassIndex constants name = case findClassIndex constants name of
     Just index -> (constants, index)
-    Nothing -> (constants ++ [ClassInfo (fromIntegral (length constants)), Utf8Info name], fromIntegral (length constants))
+    Nothing -> (constants ++ [ClassInfo (fromIntegral (length constants) + 2), Utf8Info name], fromIntegral (length constants) + 1)
 
 -- get the index for a field within a class, creating it if it does not exist.
 getFieldIndex :: [ConstantInfo] -> (String, String, String) -> ([ConstantInfo], Int)
@@ -223,7 +219,7 @@ injectDefaultConstructor pre
     | otherwise = pre ++ [MethodDeclaration "void" "<init>" [] (TypedStatement "void" (Block []))]
 
 injectFieldInitializers :: String -> [VariableDeclaration] -> [MethodDeclaration] -> [MethodDeclaration]
-injectFieldInitializers classname vars pre = let 
+injectFieldInitializers classname vars pre = let
         initializers = mapMaybe (\(variable) -> case variable of
                 VariableDeclaration dtype name (Just initializer) -> Just (
                         TypedStatement dtype (
@@ -239,7 +235,58 @@ injectFieldInitializers classname vars pre = let
                 otherwise -> Nothing
             ) vars
     in
-        map (\(method) -> case method of
+        map (\method -> case method of
                 MethodDeclaration "void" "<init>" params (TypedStatement "void" (Block statements)) -> MethodDeclaration "void" "<init>" params (TypedStatement "void" (Block (initializers ++ statements)))
-                otherwise -> method
-            ) pre
+                _ -> method
+            ) pre
+
+-- 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 _)  = -1
+
+simulateStackOperation :: [ConstantInfo] -> Operation -> (Int, Int) -> (Int, Int)
+simulateStackOperation constants op (cd, md) = 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 $ foldr (simulateStackOperation constants) (0, 0) (reverse ops)

src/Example.hs

@@ -1,267 +0,0 @@
-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

src/Main.hs

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

src/Parser/JavaParser.y

@@ -75,6 +75,7 @@ import Parser.Lexer
         OREQUAL { OREQUAL }
         COLON { COLON }
         LESS { LESS }
+        FOR { FOR }
 %%
 
 compilationunit  : typedeclarations { $1 }
@@ -91,10 +92,10 @@ qualifiedname    : name  DOT IDENTIFIER { BinaryOperation NameResolution $1 (Ref
 
 simplename       : IDENTIFIER { $1 }
 
-classdeclaration : CLASS IDENTIFIER classbody { case $3 of (methods, fields) -> Class $2 methods fields }
-                 | modifiers CLASS IDENTIFIER classbody { case $4 of (methods, fields) -> Class $3 methods fields }
+classdeclaration : CLASS IDENTIFIER classbody { case $3 of (constructors, methods, fields) -> Class $2 constructors methods fields }
+                 | modifiers CLASS IDENTIFIER classbody { case $4 of (constructors, methods, fields) -> Class $3 constructors methods fields }
 
-classbody        : LBRACKET RBRACKET  { ([], []) }
+classbody        : LBRACKET RBRACKET  { ([], [], []) }
                  | LBRACKET classbodydeclarations  RBRACKET { $2 }
 
 modifiers        : modifier { }
@@ -102,13 +103,15 @@ modifiers        : modifier { }
 
 classbodydeclarations :  classbodydeclaration {
                         case $1 of
-                        MethodDecl method -> ([method], [])
-                        FieldDecls fields -> ([], fields)
+                        ConstructorDecl constructor -> ([constructor], [], [])
+                        MethodDecl method -> ([], [method], [])
+                        FieldDecls fields -> ([], [], fields)
                         }
                  | classbodydeclarations classbodydeclaration {
                         case ($1, $2) of
-                        ((methods, fields), MethodDecl method) -> ((methods ++ [method]), fields)
-                        ((methods, fields), FieldDecls newFields) -> (methods, (fields ++ newFields))
+                        ((constructors, methods, fields), ConstructorDecl constructor) -> ((constructors ++ [constructor]), methods, fields)
+                        ((constructors, methods, fields), MethodDecl method) -> (constructors, (methods ++ [method]), fields)
+                        ((constructors, methods, fields), FieldDecls newFields) -> (constructors, methods, (fields ++ newFields))
                         }
 
 modifier         : PUBLIC { }
@@ -127,8 +130,8 @@ classorinterfacetype : simplename { $1 }
 classmemberdeclaration : fielddeclaration { $1 }
                  | methoddeclaration { $1 }
 
-constructordeclaration : constructordeclarator constructorbody { MethodDecl $ MethodDeclaration "void" "<init>" $1 $2 }
-                 |  modifiers constructordeclarator constructorbody { MethodDecl $ MethodDeclaration "void" "<init>" $2 $3 }
+constructordeclaration : constructordeclarator constructorbody { case $1 of (identifier, parameters) -> ConstructorDecl $ ConstructorDeclaration identifier parameters $2 }
+                 |  modifiers constructordeclarator constructorbody { case $2 of (identifier, parameters) -> ConstructorDecl $ ConstructorDeclaration identifier parameters $3 }
 
 fielddeclaration : type variabledeclarators  SEMICOLON { FieldDecls $ map (convertDeclarator $1) $2 }
                  | modifiers type variabledeclarators  SEMICOLON { FieldDecls $ map (convertDeclarator $2) $3 }
@@ -138,8 +141,8 @@ methoddeclaration : methodheader methodbody { case $1 of (returnType, (name, par
 block            : LBRACKET   RBRACKET { Block [] }
                  | LBRACKET  blockstatements  RBRACKET { Block $2 }
 
-constructordeclarator :  simplename LBRACE  RBRACE  { [] }
-                 |  simplename LBRACE formalparameterlist RBRACE  { $3 }
+constructordeclarator :  simplename LBRACE  RBRACE  { ($1, []) }
+                 |  simplename LBRACE formalparameterlist RBRACE  { ($1, $3) }
 
 constructorbody  : LBRACKET RBRACKET { Block [] }
                 --  | LBRACKET explicitconstructorinvocation  RBRACKET { }
@@ -204,6 +207,7 @@ statement        : statementwithouttrailingsubstatement{ $1 }  -- statement retu
                  | ifthenstatement { [$1] }
                  | ifthenelsestatement { [$1] }
                  | whilestatement { [$1] }
+                 | forstatement { [$1] }
                                      
 
 expression       : assignmentexpression { $1 }
@@ -224,6 +228,21 @@ ifthenelsestatement : IF LBRACE expression  RBRACE statementnoshortif ELSE state
 
 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 }
                  | assignment { StatementExpressionExpression $1 }
 
@@ -265,6 +284,7 @@ conditionalorexpression : conditionalandexpression { $1 }
                 --  | conditionalorexpression LOGICALOR conditionalandexpression{ }
 
 lefthandside     : name { $1 }
+                 | primary DOT IDENTIFIER { BinaryOperation NameResolution $1 (Reference $3) }
 
 assignmentoperator : ASSIGN { Nothing }
                  | TIMESEQUAL { Just Multiplication }
@@ -287,8 +307,8 @@ postincrementexpression : postfixexpression INCREMENT { PostIncrement $1 }
 
 postdecrementexpression : postfixexpression DECREMENT { PostDecrement $1 }
 
-methodinvocation : simplename LBRACE   RBRACE  { MethodCall (Reference "this") $1 []  }
-                 | simplename LBRACE argumentlist RBRACE { MethodCall (Reference "this") $1 $3 }
+methodinvocation : name LBRACE RBRACE  { let (exp, functionname) = extractFunctionName $1 in (MethodCall exp functionname []) }
+                 | name LBRACE argumentlist RBRACE { let (exp, functionname) = extractFunctionName $1 in (MethodCall exp functionname $3) }
                  | primary  DOT IDENTIFIER LBRACE RBRACE  { MethodCall $1 $3 [] }
                  | primary  DOT IDENTIFIER LBRACE argumentlist  RBRACE  { MethodCall $1 $3 $5 }
      
@@ -367,6 +387,7 @@ multiplicativeexpression : unaryexpression { $1 }
 {
 
 data MethodOrFieldDeclaration = MethodDecl MethodDeclaration
+                              | ConstructorDecl ConstructorDeclaration
                               | FieldDecls [VariableDeclaration]
 
 data Declarator = Declarator Identifier (Maybe Expression)
@@ -374,8 +395,9 @@ data Declarator = Declarator Identifier (Maybe Expression)
 convertDeclarator :: DataType -> Declarator -> VariableDeclaration
 convertDeclarator dataType (Declarator id assigment) = VariableDeclaration dataType id assigment
 
-data StatementWithoutSub =  Statement
-
+extractFunctionName :: Expression -> (Expression, Identifier)
+extractFunctionName (BinaryOperation NameResolution exp (Reference functionname)) = (exp, functionname)
+extractFunctionName (Reference functionname) = ((Reference "this"), functionname)
 
 parseError :: ([Token], [String]) -> a
 parseError (errortoken, expected) = error ("parse error on token: " ++ show errortoken ++ "\nexpected one of:      " ++ show expected)

src/Typecheck.hs

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