Test/TestByteCodeGenerator.hs

@@ -107,12 +107,10 @@ testBasicConstantPool = TestCase $ assertEqual "basic constant pool" expectedCla
 testFields = TestCase $ assertEqual "fields in constant pool" expectedClassWithFields $ classBuilder classWithFields emptyClassFile
 testMethodDescriptor = TestCase $ assertEqual "method descriptor" "(II)I" (methodDescriptor method)
 testMethodAssembly = TestCase $ assertEqual "method assembly" expectedClassWithMethod (classBuilder classWithMethod emptyClassFile)
-testFindMethodIndex = TestCase $ assertEqual "find method" (Just 0) (findMethodIndex expectedClassWithMethod "add_two_numbers")
 
 tests = TestList [
     TestLabel "Basic constant pool" testBasicConstantPool,
     TestLabel "Fields constant pool" testFields,
     TestLabel "Method descriptor building" testMethodDescriptor,
-    TestLabel "Method assembly" testMethodAssembly,
+    TestLabel "Method assembly" testMethodAssembly
-    TestLabel "Find method by name" testFindMethodIndex
     ]

Test/TestParser.hs

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

project.cabal

@@ -12,21 +12,18 @@ executable compiler
                         utf8-string,
                         bytestring
     default-language:   Haskell2010
-    hs-source-dirs:     src
+    hs-source-dirs:     src,
+                        src/ByteCode,
+                        src/ByteCode/ClassFile
     build-tool-depends: alex:alex, happy:happy
     other-modules:      Parser.Lexer,
-                        Parser.JavaParser,
+                        Parser.JavaParser
                         Ast,
                         Example,
                         Typecheck,
                         ByteCode.ByteUtil,
                         ByteCode.ClassFile,
-                        ByteCode.Generation.Generator,
+                        ByteCode.ClassFile.Generator,
-                        ByteCode.Generation.Assembler.ExpressionAndStatement,
-                        ByteCode.Generation.Assembler.Method,
-                        ByteCode.Generation.Builder.Class,
-                        ByteCode.Generation.Builder.Field,
-                        ByteCode.Generation.Builder.Method,
                         ByteCode.Constants
 
 test-suite tests

src/ByteCode/ClassFile.hs

@@ -5,8 +5,7 @@ module ByteCode.ClassFile(
     ClassFile(..),
     Operation(..),
     serialize,
-    emptyClassFile,
+    emptyClassFile
-    opcodeEncodingLength
 ) where
 
 import Data.Word
@@ -32,7 +31,6 @@ data Operation = Opiadd
                | Opior
                | Opixor
                | Opineg
-               | Opdup
                | Opif_icmplt Word16
                | Opif_icmple Word16
                | Opif_icmpgt Word16
@@ -43,8 +41,6 @@ data Operation = Opiadd
                | Opreturn
                | Opireturn
                | Opareturn
-               | Opinvokespecial Word16
-               | Opgoto Word16
                | Opsipush Word16
                | Opldc_w Word16
                | Opaload Word16
@@ -52,7 +48,7 @@ data Operation = Opiadd
                | Opastore Word16
                | Opistore Word16
                | Opputfield Word16
-               | Opgetfield Word16
+               | OpgetField Word16
     deriving (Show, Eq)
 
 
@@ -91,37 +87,6 @@ emptyClassFile = ClassFile {
         attributes = []
     }
 
-opcodeEncodingLength :: Operation -> Word16
-opcodeEncodingLength Opiadd                 = 1
-opcodeEncodingLength Opisub                 = 1
-opcodeEncodingLength Opimul                 = 1
-opcodeEncodingLength Opidiv                 = 1
-opcodeEncodingLength Opiand                 = 1
-opcodeEncodingLength Opior                  = 1
-opcodeEncodingLength Opixor                 = 1
-opcodeEncodingLength Opineg                 = 1
-opcodeEncodingLength Opdup                  = 1
-opcodeEncodingLength (Opif_icmplt _)        = 3
-opcodeEncodingLength (Opif_icmple _)        = 3
-opcodeEncodingLength (Opif_icmpgt _)        = 3
-opcodeEncodingLength (Opif_icmpge _)        = 3
-opcodeEncodingLength (Opif_icmpeq _)        = 3
-opcodeEncodingLength (Opif_icmpne _)        = 3
-opcodeEncodingLength Opaconst_null          = 1
-opcodeEncodingLength Opreturn               = 1
-opcodeEncodingLength Opireturn              = 1
-opcodeEncodingLength Opareturn              = 1
-opcodeEncodingLength (Opinvokespecial _)    = 3
-opcodeEncodingLength (Opgoto _)             = 3
-opcodeEncodingLength (Opsipush _)           = 3
-opcodeEncodingLength (Opldc_w _)            = 3
-opcodeEncodingLength (Opaload _)            = 4
-opcodeEncodingLength (Opiload _)            = 4
-opcodeEncodingLength (Opastore _)           = 4
-opcodeEncodingLength (Opistore _)           = 4
-opcodeEncodingLength (Opputfield _)         = 3
-opcodeEncodingLength (Opgetfield _)         = 3
-
 class Serializable a where
     serialize :: a -> [Word8]
 
@@ -151,7 +116,6 @@ instance Serializable Operation where
     serialize Opior                = [0x80]
     serialize Opixor               = [0x82]
     serialize Opineg               = [0x74]
-    serialize Opdup                     = [0x59]
     serialize (Opif_icmplt branch) = 0xA1 : unpackWord16 branch
     serialize (Opif_icmple branch) = 0xA4 : unpackWord16 branch
     serialize (Opif_icmpgt branch) = 0xA3 : unpackWord16 branch
@@ -162,8 +126,6 @@ instance Serializable Operation where
     serialize Opreturn             = [0xB1]
     serialize Opireturn            = [0xAC]
     serialize Opareturn            = [0xB0]
-    serialize (Opinvokespecial index)   = 0xB7 : unpackWord16 index
-    serialize (Opgoto index)            = 0xA7 : unpackWord16 index
     serialize (Opsipush index)     = 0x11 : unpackWord16 index
     serialize (Opldc_w index)      = 0x13 : unpackWord16 index
     serialize (Opaload index)      = [0xC4, 0x19] ++ unpackWord16 index
@@ -171,7 +133,7 @@ instance Serializable Operation where
     serialize (Opastore index)     = [0xC4, 0x3A] ++ unpackWord16 index
     serialize (Opistore index)     = [0xC4, 0x36] ++ unpackWord16 index
     serialize (Opputfield index)   = 0xB5 : unpackWord16 index
-    serialize (Opgetfield index)        = 0xB4 : unpackWord16 index
+    serialize (OpgetField index)   = 0xB4 : unpackWord16 index
 
 instance Serializable Attribute where
     serialize (CodeAttribute { attributeMaxStack = maxStack,
@@ -189,7 +151,7 @@ instance Serializable Attribute where
             ++ unpackWord16 0                                               -- attributes_count
 
 instance Serializable ClassFile where
-    serialize classfile  = unpackWord32 0xCAFEBABE                                           -- magic
+    serialize classfile  = unpackWord32 0xC0FEBABE                                           -- magic
                         ++ unpackWord16 0                                                    -- minor version
                         ++ unpackWord16 49                                                   -- major version
                         ++ unpackWord16 (fromIntegral (1 + length (constantPool classfile))) -- constant pool count

src/ByteCode/ClassFile/Generator.hs

@@ -0,0 +1,169 @@
+module ByteCode.ClassFile.Generator(
+    classBuilder,
+    datatypeDescriptor,
+    methodParameterDescriptor,
+    methodDescriptor,
+) where
+
+import ByteCode.Constants
+import ByteCode.ClassFile (ClassFile (..), ConstantInfo (..), MemberInfo(..), Operation(..), Attribute(..))
+import Ast
+import Data.Char
+
+
+type ClassFileBuilder a = a -> ClassFile -> ClassFile
+
+
+datatypeDescriptor :: String -> String
+datatypeDescriptor "void" = "V"
+datatypeDescriptor "int" = "I"
+datatypeDescriptor "char" = "C"
+datatypeDescriptor "boolean" = "B"
+datatypeDescriptor x = "L" ++ x
+
+methodParameterDescriptor :: String -> String
+methodParameterDescriptor "void" = "V"
+methodParameterDescriptor "int" = "I"
+methodParameterDescriptor "char" = "C"
+methodParameterDescriptor "boolean" = "B"
+methodParameterDescriptor x = "L" ++ x ++ ";"
+
+methodDescriptor :: MethodDeclaration -> String
+methodDescriptor (MethodDeclaration returntype _ parameters _) = let 
+        parameter_types = [datatype | ParameterDeclaration datatype _ <- parameters]
+    in
+        "("
+        ++ (concat (map methodParameterDescriptor parameter_types))
+        ++ ")"
+        ++ datatypeDescriptor returntype
+
+classBuilder :: ClassFileBuilder Class
+classBuilder (Class name methods fields) _ = let
+        baseConstants = [
+            ClassInfo 4,
+            MethodRefInfo 1 3,
+            NameAndTypeInfo 5 6,
+            Utf8Info "java/lang/Object",
+            Utf8Info "<init>",
+            Utf8Info "()V",
+            Utf8Info "Code"
+            ]
+        nameConstants = [ClassInfo 9, Utf8Info name]
+        nakedClassFile = ClassFile {
+            constantPool = baseConstants ++ nameConstants,
+            accessFlags = accessPublic,
+            thisClass = 8,
+            superClass = 1,
+            fields = [],
+            methods = [],
+            attributes = []
+        }
+    in
+        foldr methodBuilder (foldr fieldBuilder nakedClassFile fields) methods
+        
+        
+
+fieldBuilder :: ClassFileBuilder VariableDeclaration
+fieldBuilder (VariableDeclaration datatype name _) input = let
+        baseIndex = 1 + length (constantPool input)
+        constants = [
+                FieldRefInfo (fromIntegral (thisClass input)) (fromIntegral (baseIndex + 1)),
+                NameAndTypeInfo (fromIntegral (baseIndex + 2)) (fromIntegral (baseIndex + 3)),
+                Utf8Info name,
+                Utf8Info (datatypeDescriptor datatype)
+            ]
+        field = MemberInfo {
+            memberAccessFlags = accessPublic,
+            memberNameIndex = (fromIntegral (baseIndex + 2)),
+            memberDescriptorIndex = (fromIntegral (baseIndex + 3)),
+            memberAttributes = []
+            }
+    in
+        input {
+            constantPool = (constantPool input) ++ constants,
+            fields = (fields input) ++ [field]
+        }
+
+methodBuilder :: ClassFileBuilder MethodDeclaration
+methodBuilder (MethodDeclaration returntype name parameters statement) input = let
+        baseIndex = 1 + length (constantPool input)
+        constants = [
+                FieldRefInfo (fromIntegral (thisClass input)) (fromIntegral (baseIndex + 1)),
+                NameAndTypeInfo (fromIntegral (baseIndex + 2)) (fromIntegral (baseIndex + 3)),
+                Utf8Info name,
+                Utf8Info (methodDescriptor (MethodDeclaration returntype name parameters (Block [])))
+            ]
+        --code = assembleByteCode statement
+        method = MemberInfo {
+            memberAccessFlags = accessPublic,
+            memberNameIndex = (fromIntegral (baseIndex + 2)),
+            memberDescriptorIndex = (fromIntegral (baseIndex + 3)),
+            memberAttributes = [
+                   CodeAttribute {
+                        attributeMaxStack = 420,
+                        attributeMaxLocals = 420,
+                        attributeCode = [Opiadd]
+                    }
+                ]
+            }
+    in
+        input {
+            constantPool = (constantPool input) ++ constants,
+            methods = (fields input) ++ [method]
+        }
+
+type Assembler a = a -> ([ConstantInfo], [Operation]) -> ([ConstantInfo], [Operation])
+
+returnOperation :: DataType -> Operation
+returnOperation dtype
+    | elem dtype ["int", "char", "boolean"] = Opireturn
+    | otherwise                             = Opareturn
+
+binaryOperation :: BinaryOperator -> Operation
+binaryOperation Addition        = Opiadd
+binaryOperation Subtraction     = Opisub
+binaryOperation Multiplication  = Opimul
+binaryOperation Division        = Opidiv
+binaryOperation BitwiseAnd      = Opiand
+binaryOperation BitwiseOr       = Opior
+binaryOperation BitwiseXor      = Opixor
+
+assembleMethod :: Assembler MethodDeclaration
+assembleMethod (MethodDeclaration _ _ _ (Block statements)) (constants, ops) =
+    foldr assembleStatement (constants, ops) statements
+
+assembleStatement :: Assembler Statement
+assembleStatement (TypedStatement stype (Return expr)) (constants, ops) = case expr of
+    Nothing -> (constants, ops ++ [Opreturn])
+    Just expr -> let
+            (expr_constants, expr_ops) = assembleExpression expr (constants, ops)
+        in  
+            (expr_constants, expr_ops ++ [returnOperation stype])
+
+assembleExpression :: Assembler Expression
+assembleExpression (TypedExpression _ (BinaryOperation op a b)) (constants, ops)
+    | elem op [Addition, Subtraction, Multiplication, Division, BitwiseAnd, BitwiseOr, BitwiseXor] = let
+            (aConstants, aOps) = assembleExpression a (constants, ops)
+            (bConstants, bOps) = assembleExpression b (aConstants, aOps)
+        in
+            (bConstants, bOps ++ [binaryOperation op])
+assembleExpression (TypedExpression _ (CharacterLiteral literal)) (constants, ops) = 
+    (constants, ops ++ [Opsipush (fromIntegral (ord literal))])
+assembleExpression (TypedExpression _ (BooleanLiteral literal)) (constants, ops) = 
+    (constants, ops ++ [Opsipush (if literal then 1 else 0)])
+assembleExpression (TypedExpression _ (IntegerLiteral literal)) (constants, ops)
+    | literal <= 32767 && literal >= -32768 = (constants, ops ++ [Opsipush (fromIntegral literal)])
+    | otherwise = (constants ++ [IntegerInfo (fromIntegral literal)], ops ++ [Opldc_w (fromIntegral (1 + length constants))])
+assembleExpression (TypedExpression _ NullLiteral) (constants, ops) = 
+    (constants, ops ++ [Opaconst_null])
+assembleExpression (TypedExpression etype (UnaryOperation Not expr)) (constants, ops) = let
+        (exprConstants, exprOps) = assembleExpression expr (constants, ops)
+        newConstant = fromIntegral (1 + length exprConstants)
+    in case etype of
+        "int" -> (exprConstants ++ [IntegerInfo 0x7FFFFFFF], exprOps ++ [Opldc_w newConstant, Opixor])
+        "char" -> (exprConstants, exprOps ++ [Opsipush 0xFFFF, Opixor])
+        "boolean" -> (exprConstants, exprOps ++ [Opsipush 0x01, Opixor])
+assembleExpression (TypedExpression _ (UnaryOperation Minus expr)) (constants, ops) = let
+        (exprConstants, exprOps) = assembleExpression expr (constants, ops)
+    in
+        (exprConstants, exprOps ++ [Opineg])

src/ByteCode/Generation/Assembler/ExpressionAndStatement.hs

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

src/ByteCode/Generation/Assembler/Method.hs

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

src/ByteCode/Generation/Builder/Class.hs

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

src/ByteCode/Generation/Builder/Field.hs

@@ -1,46 +0,0 @@
-module ByteCode.Generation.Builder.Field where
-
-import Ast
-import ByteCode.ClassFile(ClassFile (..), ConstantInfo (..), MemberInfo(..), Operation(..), Attribute(..), opcodeEncodingLength)
-import ByteCode.Generation.Generator
-import ByteCode.Constants
-import Data.List
-
-findFieldIndex :: [ConstantInfo] -> String -> Maybe Int
-findFieldIndex constants name = let
-        fieldRefNameInfos = [
-                -- we only skip one entry to get the name since the Java constant pool
-                -- is 1-indexed (why)
-                (index, constants!!(fromIntegral index + 1))
-                | (index, FieldRefInfo _ _) <- (zip [1..] constants)
-            ]
-        fieldRefNames = map (\(index, nameInfo) -> case nameInfo of
-            Utf8Info fieldName -> (index, fieldName)
-            something_else -> error ("Expected UTF8Info but got" ++ show something_else))
-                fieldRefNameInfos
-        fieldIndex = find (\(index, fieldName) -> fieldName == name) fieldRefNames
-    in case fieldIndex of
-        Just (index, _) -> Just index
-        Nothing -> Nothing
-
-
-fieldBuilder :: ClassFileBuilder VariableDeclaration
-fieldBuilder (VariableDeclaration datatype name _) input = let
-        baseIndex = 1 + length (constantPool input)
-        constants = [
-                FieldRefInfo (fromIntegral (thisClass input)) (fromIntegral (baseIndex + 1)),
-                NameAndTypeInfo (fromIntegral (baseIndex + 2)) (fromIntegral (baseIndex + 3)),
-                Utf8Info name,
-                Utf8Info (datatypeDescriptor datatype)
-            ]
-        field = MemberInfo {
-            memberAccessFlags = accessPublic,
-            memberNameIndex = (fromIntegral (baseIndex + 2)),
-            memberDescriptorIndex = (fromIntegral (baseIndex + 3)),
-            memberAttributes = []
-            }
-    in
-        input {
-            constantPool = (constantPool input) ++ constants,
-            fields = (fields input) ++ [field]
-        }

src/ByteCode/Generation/Builder/Method.hs

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

src/ByteCode/Generation/Generator.hs

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

src/Main.hs

@@ -2,19 +2,7 @@ module Main where
 
 import Example
 import Typecheck
-import Parser.Lexer (alexScanTokens)
-import Parser.JavaParser
-import ByteCode.Generation.Generator
-import ByteCode.Generation.Builder.Class
-import ByteCode.ClassFile
-import Data.ByteString (pack, writeFile)
 
 main = do
-    file <- readFile "Testklasse.java"
+    Example.runTypeCheck
     
-    let untypedAST = parse $ alexScanTokens file
-    let typedAST = head (typeCheckCompilationUnit untypedAST)
-    let abstractClassFile = classBuilder typedAST emptyClassFile
-    let assembledClassFile = pack (serialize abstractClassFile)
-
-    Data.ByteString.writeFile "Testklasse.class" assembledClassFile

src/Parser/JavaParser.y

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