Compare commits

...

13 Commits

7 changed files with 230 additions and 159 deletions

View File

@ -50,23 +50,23 @@ testClassWithMethodAndField = TestCase $
assertEqual "expect class with method and field" [Class "WithMethodAndField" [MethodDeclaration "void" "foo" [] (Block []), MethodDeclaration "int" "bar" [] (Block [])] [VariableDeclaration "int" "value" Nothing]] $ assertEqual "expect class with method and field" [Class "WithMethodAndField" [MethodDeclaration "void" "foo" [] (Block []), MethodDeclaration "int" "bar" [] (Block [])] [VariableDeclaration "int" "value" Nothing]] $
parse [CLASS,IDENTIFIER "WithMethodAndField",LBRACKET,VOID,IDENTIFIER "foo",LBRACE,RBRACE,LBRACKET,RBRACKET,INT,IDENTIFIER "value",SEMICOLON,INT,IDENTIFIER "bar",LBRACE,RBRACE,SEMICOLON,RBRACKET] parse [CLASS,IDENTIFIER "WithMethodAndField",LBRACKET,VOID,IDENTIFIER "foo",LBRACE,RBRACE,LBRACKET,RBRACKET,INT,IDENTIFIER "value",SEMICOLON,INT,IDENTIFIER "bar",LBRACE,RBRACE,SEMICOLON,RBRACKET]
testClassWithConstructor = TestCase $ testClassWithConstructor = TestCase $
assertEqual "expect class with constructor" [Class "WithConstructor" [MethodDeclaration "WithConstructor" "<init>" [] (Block [])] []] $ assertEqual "expect class with constructor" [Class "WithConstructor" [MethodDeclaration "void" "<init>" [] (Block [])] []] $
parse [CLASS,IDENTIFIER "WithConstructor",LBRACKET,IDENTIFIER "WithConstructor",LBRACE,RBRACE,LBRACKET,RBRACKET,RBRACKET] parse [CLASS,IDENTIFIER "WithConstructor",LBRACKET,IDENTIFIER "WithConstructor",LBRACE,RBRACE,LBRACKET,RBRACKET,RBRACKET]
testEmptyBlock = TestCase $ assertEqual "expect empty block" (Block []) $ parseBlock [LBRACKET,RBRACKET] testEmptyBlock = TestCase $ assertEqual "expect empty block" [Block []] $ parseStatement [LBRACKET,RBRACKET]
testBlockWithLocalVarDecl = TestCase $ testBlockWithLocalVarDecl = TestCase $
assertEqual "expect block with local var delcaration" (Block [LocalVariableDeclaration $ VariableDeclaration "int" "localvar" Nothing]) $ assertEqual "expect block with local var delcaration" [Block [LocalVariableDeclaration $ VariableDeclaration "int" "localvar" Nothing]] $
parseBlock [LBRACKET,INT,IDENTIFIER "localvar",SEMICOLON,RBRACKET] parseStatement [LBRACKET,INT,IDENTIFIER "localvar",SEMICOLON,RBRACKET]
testBlockWithMultipleLocalVarDecls = TestCase $ testBlockWithMultipleLocalVarDecls = TestCase $
assertEqual "expect block with multiple local var declarations" (Block [LocalVariableDeclaration $ VariableDeclaration "int" "var1" Nothing, LocalVariableDeclaration $ VariableDeclaration "boolean" "var2" Nothing]) $ assertEqual "expect block with multiple local var declarations" [Block [LocalVariableDeclaration $ VariableDeclaration "int" "var1" Nothing, LocalVariableDeclaration $ VariableDeclaration "boolean" "var2" Nothing]] $
parseBlock [LBRACKET,INT,IDENTIFIER "var1",SEMICOLON,BOOLEAN,IDENTIFIER "var2",SEMICOLON,RBRACKET] parseStatement [LBRACKET,INT,IDENTIFIER "var1",SEMICOLON,BOOLEAN,IDENTIFIER "var2",SEMICOLON,RBRACKET]
testNestedBlocks = TestCase $ testNestedBlocks = TestCase $
assertEqual "expect block with block inside" (Block [Block []]) $ assertEqual "expect block with block inside" [Block [Block []]] $
parseBlock [LBRACKET,LBRACKET,RBRACKET,RBRACKET] parseStatement [LBRACKET,LBRACKET,RBRACKET,RBRACKET]
testBlockWithEmptyStatement = TestCase $ testBlockWithEmptyStatement = TestCase $
assertEqual "expect empty block" (Block []) $ assertEqual "expect empty block" [Block []] $
parseBlock [LBRACKET,SEMICOLON,SEMICOLON,RBRACKET] parseStatement [LBRACKET,SEMICOLON,SEMICOLON,RBRACKET]
testExpressionIntLiteral = TestCase $ testExpressionIntLiteral = TestCase $
assertEqual "expect IntLiteral" (IntegerLiteral 3) $ assertEqual "expect IntLiteral" (IntegerLiteral 3) $
@ -75,14 +75,14 @@ testFieldWithInitialization = TestCase $
assertEqual "expect Class with initialized field" [Class "WithInitField" [] [VariableDeclaration "int" "number" $ Just $ IntegerLiteral 3]] $ assertEqual "expect Class with initialized field" [Class "WithInitField" [] [VariableDeclaration "int" "number" $ Just $ IntegerLiteral 3]] $
parse [CLASS,IDENTIFIER "WithInitField",LBRACKET,INT,IDENTIFIER "number",ASSIGN,INTEGERLITERAL 3,SEMICOLON,RBRACKET] parse [CLASS,IDENTIFIER "WithInitField",LBRACKET,INT,IDENTIFIER "number",ASSIGN,INTEGERLITERAL 3,SEMICOLON,RBRACKET]
testLocalBoolWithInitialization = TestCase $ testLocalBoolWithInitialization = TestCase $
assertEqual "expect block with with initialized local var" (Block [LocalVariableDeclaration $ VariableDeclaration "boolean" "b" $ Just $ BooleanLiteral False]) $ assertEqual "expect block with with initialized local var" [Block [LocalVariableDeclaration $ VariableDeclaration "boolean" "b" $ Just $ BooleanLiteral False]] $
parseBlock [LBRACKET,BOOLEAN,IDENTIFIER "b",ASSIGN,BOOLLITERAL False,SEMICOLON,RBRACKET] parseStatement [LBRACKET,BOOLEAN,IDENTIFIER "b",ASSIGN,BOOLLITERAL False,SEMICOLON,RBRACKET]
testFieldNullWithInitialization = TestCase $ testFieldNullWithInitialization = TestCase $
assertEqual "expect Class with initialized field" [Class "WithInitField" [] [VariableDeclaration "Object" "bar" $ Just NullLiteral]] $ assertEqual "expect Class with initialized field" [Class "WithInitField" [] [VariableDeclaration "Object" "bar" $ Just NullLiteral]] $
parse [CLASS,IDENTIFIER "WithInitField",LBRACKET,IDENTIFIER "Object",IDENTIFIER "bar",ASSIGN,NULLLITERAL,SEMICOLON,RBRACKET] parse [CLASS,IDENTIFIER "WithInitField",LBRACKET,IDENTIFIER "Object",IDENTIFIER "bar",ASSIGN,NULLLITERAL,SEMICOLON,RBRACKET]
testReturnVoid = TestCase $ testReturnVoid = TestCase $
assertEqual "expect block with return nothing" (Block [Return Nothing]) $ assertEqual "expect block with return nothing" [Block [Return Nothing]] $
parseBlock [LBRACKET,RETURN,SEMICOLON,RBRACKET] parseStatement [LBRACKET,RETURN,SEMICOLON,RBRACKET]
testExpressionNot = TestCase $ testExpressionNot = TestCase $
assertEqual "expect expression not" (UnaryOperation Not (Reference "boar")) $ assertEqual "expect expression not" (UnaryOperation Not (Reference "boar")) $
@ -132,6 +132,18 @@ testExpressionXor = TestCase $
testExpressionOr = TestCase $ testExpressionOr = TestCase $
assertEqual "expect or expression" (BinaryOperation Or (Reference "bar") (Reference "baz")) $ assertEqual "expect or expression" (BinaryOperation Or (Reference "bar") (Reference "baz")) $
parseExpression [IDENTIFIER "bar",OR,IDENTIFIER "baz"] parseExpression [IDENTIFIER "bar",OR,IDENTIFIER "baz"]
testExpressionPostIncrement = TestCase $
assertEqual "expect PostIncrement" (UnaryOperation PostIncrement (Reference "a")) $
parseExpression [IDENTIFIER "a",INCREMENT]
testExpressionPostDecrement = TestCase $
assertEqual "expect PostDecrement" (UnaryOperation PostDecrement (Reference "a")) $
parseExpression [IDENTIFIER "a",DECREMENT]
testExpressionPreIncrement = TestCase $
assertEqual "expect PreIncrement" (UnaryOperation PreIncrement (Reference "a")) $
parseExpression [INCREMENT,IDENTIFIER "a"]
testExpressionPreDecrement = TestCase $
assertEqual "expect PreIncrement" (UnaryOperation PreDecrement (Reference "a")) $
parseExpression [DECREMENT,IDENTIFIER "a"]
tests = TestList [ tests = TestList [
@ -169,5 +181,9 @@ tests = TestList [
testExpressionNotEqual, testExpressionNotEqual,
testExpressionAnd, testExpressionAnd,
testExpressionXor, testExpressionXor,
testExpressionOr testExpressionOr,
testExpressionPostIncrement,
testExpressionPostDecrement,
testExpressionPreIncrement,
testExpressionPreDecrement
] ]

View File

@ -20,7 +20,7 @@ data Statement
deriving (Show, Eq) deriving (Show, Eq)
data StatementExpression data StatementExpression
= Assignment Identifier Expression = Assignment Expression Expression
| ConstructorCall DataType [Expression] | ConstructorCall DataType [Expression]
| MethodCall Expression Identifier [Expression] | MethodCall Expression Identifier [Expression]
| TypedStatementExpression DataType StatementExpression | TypedStatementExpression DataType StatementExpression
@ -49,6 +49,10 @@ data BinaryOperator
data UnaryOperator data UnaryOperator
= Not = Not
| Minus | Minus
| PostIncrement
| PostDecrement
| PreIncrement
| PreDecrement
deriving (Show, Eq) deriving (Show, Eq)
data Expression data Expression

View File

@ -206,7 +206,7 @@ assembleMethod (MethodDeclaration _ name _ (TypedStatement _ (Block statements))
(constants_a, ops_a) = foldr assembleStatement (constants, ops) statements (constants_a, ops_a) = foldr assembleStatement (constants, ops) statements
init_ops = [Opaload 0, Opinvokespecial 2] init_ops = [Opaload 0, Opinvokespecial 2]
in in
(constants_a, init_ops ++ ops_a) (constants_a, init_ops ++ ops_a ++ [Opreturn])
| otherwise = let | otherwise = let
(constants_a, ops_a) = foldr assembleStatement (constants, ops) statements (constants_a, ops_a) = foldr assembleStatement (constants, ops) statements
init_ops = [Opaload 0] init_ops = [Opaload 0]
@ -221,6 +221,15 @@ assembleStatement (TypedStatement stype (Return expr)) (constants, ops) = case e
(expr_constants, expr_ops) = assembleExpression expr (constants, ops) (expr_constants, expr_ops) = assembleExpression expr (constants, ops)
in in
(expr_constants, expr_ops ++ [returnOperation stype]) (expr_constants, expr_ops ++ [returnOperation stype])
assembleStatement (TypedStatement _ (Block statements)) (constants, ops) =
foldr assembleStatement (constants, ops) statements
assembleStatement (TypedStatement _ (If expr if_stmt else_stmt)) (constants, ops) = let
(constants_cmp, ops_cmp) = assembleExpression expr (constants, [])
(constants_ifa, ops_ifa) = assembleStatement if_stmt (constants_cmp, [])
skip_length = sum (map opcodeEncodingLength ops_ifa)
in
(constants_ifa, ops ++ ops_cmp ++ [Opsipush 0, Opif_icmpeq skip_length] ++ ops_ifa)
assembleExpression :: Assembler Expression assembleExpression :: Assembler Expression
assembleExpression (TypedExpression _ (BinaryOperation op a b)) (constants, ops) assembleExpression (TypedExpression _ (BinaryOperation op a b)) (constants, ops)

View File

@ -49,7 +49,7 @@ exampleExpression :: Expression
exampleExpression = BinaryOperation NameResolution (Reference "bob") (Reference "age") exampleExpression = BinaryOperation NameResolution (Reference "bob") (Reference "age")
exampleAssignment :: Expression exampleAssignment :: Expression
exampleAssignment = StatementExpressionExpression (Assignment "a" (IntegerLiteral 30)) exampleAssignment = StatementExpressionExpression (Assignment (Reference "a") (IntegerLiteral 30))
exampleMethodCall :: Statement exampleMethodCall :: Statement
exampleMethodCall = StatementExpressionStatement (MethodCall (Reference "this") "setAge" [IntegerLiteral 30]) exampleMethodCall = StatementExpressionStatement (MethodCall (Reference "this") "setAge" [IntegerLiteral 30])
@ -58,7 +58,7 @@ exampleConstructorCall :: Statement
exampleConstructorCall = LocalVariableDeclaration (VariableDeclaration "Person" "bob" (Just (StatementExpressionExpression (ConstructorCall "Person" [IntegerLiteral 30])))) exampleConstructorCall = LocalVariableDeclaration (VariableDeclaration "Person" "bob" (Just (StatementExpressionExpression (ConstructorCall "Person" [IntegerLiteral 30]))))
exampleNameResolution :: Expression exampleNameResolution :: Expression
exampleNameResolution = BinaryOperation NameResolution (Reference "b") (Reference "age") exampleNameResolution = BinaryOperation NameResolution (Reference "bob2") (Reference "age")
exampleBlockResolution :: Statement exampleBlockResolution :: Statement
exampleBlockResolution = Block [ exampleBlockResolution = Block [
@ -80,7 +80,7 @@ exampleMethodCallAndAssignment = Block [
LocalVariableDeclaration (VariableDeclaration "int" "age" (Just (StatementExpressionExpression (MethodCall (Reference "bob") "getAge" [])))), LocalVariableDeclaration (VariableDeclaration "int" "age" (Just (StatementExpressionExpression (MethodCall (Reference "bob") "getAge" [])))),
StatementExpressionStatement (MethodCall (Reference "bob") "setAge" [IntegerLiteral 30]), StatementExpressionStatement (MethodCall (Reference "bob") "setAge" [IntegerLiteral 30]),
LocalVariableDeclaration (VariableDeclaration "int" "a" Nothing), LocalVariableDeclaration (VariableDeclaration "int" "a" Nothing),
StatementExpressionStatement (Assignment "a" (Reference "age")) StatementExpressionStatement (Assignment (Reference "a") (Reference "age"))
] ]
@ -89,9 +89,18 @@ exampleMethodCallAndAssignmentFail = Block [
LocalVariableDeclaration (VariableDeclaration "Person" "bob" (Just (StatementExpressionExpression (ConstructorCall "Person" [IntegerLiteral 30])))), LocalVariableDeclaration (VariableDeclaration "Person" "bob" (Just (StatementExpressionExpression (ConstructorCall "Person" [IntegerLiteral 30])))),
LocalVariableDeclaration (VariableDeclaration "int" "age" (Just (StatementExpressionExpression (MethodCall (Reference "bob") "getAge" [])))), LocalVariableDeclaration (VariableDeclaration "int" "age" (Just (StatementExpressionExpression (MethodCall (Reference "bob") "getAge" [])))),
StatementExpressionStatement (MethodCall (Reference "bob") "setAge" [IntegerLiteral 30]), StatementExpressionStatement (MethodCall (Reference "bob") "setAge" [IntegerLiteral 30]),
StatementExpressionStatement (Assignment "a" (Reference "age")) StatementExpressionStatement (Assignment (Reference "a") (Reference "age"))
] ]
exampleNameResolutionAssignment :: Statement
exampleNameResolutionAssignment = Block [
LocalVariableDeclaration (VariableDeclaration "Person" "bob" (Just (StatementExpressionExpression (ConstructorCall "Person" [IntegerLiteral 30])))),
StatementExpressionStatement (Assignment (BinaryOperation NameResolution (Reference "bob") (Reference "age")) (IntegerLiteral 30))
]
exampleCharIntOperation :: Expression
exampleCharIntOperation = BinaryOperation Addition (CharacterLiteral 'a') (IntegerLiteral 1)
testClasses :: [Class] testClasses :: [Class]
testClasses = [ testClasses = [
Class "Person" [ Class "Person" [
@ -113,10 +122,12 @@ testClasses = [
(Block [ (Block [
LocalVariableDeclaration (VariableDeclaration "Person" "bob" (Just (StatementExpressionExpression (ConstructorCall "Person" [IntegerLiteral 25])))), LocalVariableDeclaration (VariableDeclaration "Person" "bob" (Just (StatementExpressionExpression (ConstructorCall "Person" [IntegerLiteral 25])))),
StatementExpressionStatement (MethodCall (Reference "bob") "setAge" [IntegerLiteral 30]), StatementExpressionStatement (MethodCall (Reference "bob") "setAge" [IntegerLiteral 30]),
LocalVariableDeclaration (VariableDeclaration "int" "bobAge" (Just (StatementExpressionExpression (MethodCall (Reference "bob") "getAge" [])))), LocalVariableDeclaration (VariableDeclaration "int" "bobAge" (Just (StatementExpressionExpression (MethodCall (Reference "bob2") "getAge" [])))),
Return (Just (Reference "bobAge")) Return (Just (Reference "bobAge"))
]) ])
] [] ] [
VariableDeclaration "Person" "bob2" Nothing
]
] ]
runTypeCheck :: IO () runTypeCheck :: IO ()
@ -151,7 +162,7 @@ runTypeCheck = do
catch (do catch (do
print "=====================================================================================" print "====================================================================================="
evaluatedNameResolution <- evaluate (typeCheckExpression exampleNameResolution [("b", "Person")] sampleClasses) evaluatedNameResolution <- evaluate (typeCheckExpression exampleNameResolution [("this", "Main")] testClasses)
printSuccess "Type checking of name resolution completed successfully" printSuccess "Type checking of name resolution completed successfully"
printResult "Result Name Resolution:" evaluatedNameResolution printResult "Result Name Resolution:" evaluatedNameResolution
) handleError ) handleError
@ -189,7 +200,7 @@ runTypeCheck = do
let mainClass = fromJust $ find (\(Class className _ _) -> className == "Main") testClasses let mainClass = fromJust $ find (\(Class className _ _) -> className == "Main") testClasses
case mainClass of case mainClass of
Class _ [mainMethod] _ -> do Class _ [mainMethod] _ -> do
let result = typeCheckMethodDeclaration mainMethod [] testClasses let result = typeCheckMethodDeclaration mainMethod [("this", "Main")] testClasses
printSuccess "Full program type checking completed successfully." printSuccess "Full program type checking completed successfully."
printResult "Main method result:" result printResult "Main method result:" result
) handleError ) handleError
@ -201,3 +212,17 @@ runTypeCheck = do
printResult "Typed Program:" typedProgram printResult "Typed Program:" typedProgram
) handleError ) handleError
catch (do
print "====================================================================================="
typedAssignment <- evaluate (typeCheckStatement exampleNameResolutionAssignment [] sampleClasses)
printSuccess "Type checking of name resolution assignment completed successfully"
printResult "Result Name Resolution Assignment:" typedAssignment
) handleError
catch (do
print "====================================================================================="
evaluatedCharIntOperation <- evaluate (typeCheckExpression exampleCharIntOperation [] sampleClasses)
printSuccess "Type checking of char int operation completed successfully"
printResult "Result Char Int Operation:" evaluatedCharIntOperation
) handleError

View File

@ -9,7 +9,9 @@ import ByteCode.ClassFile
import Data.ByteString (pack, writeFile) import Data.ByteString (pack, writeFile)
main = do main = do
let untypedAST = parse $ alexScanTokens "class Testklasse {Testklasse(){} boolean something(){return 5 + 8 - 12 * 22 > 9 - 2 + 3;}}" file <- readFile "Testklasse.java"
let untypedAST = parse $ alexScanTokens file
let typedAST = head (typeCheckCompilationUnit untypedAST) let typedAST = head (typeCheckCompilationUnit untypedAST)
let abstractClassFile = classBuilder typedAST emptyClassFile let abstractClassFile = classBuilder typedAST emptyClassFile
let assembledClassFile = pack (serialize abstractClassFile) let assembledClassFile = pack (serialize abstractClassFile)

View File

@ -1,11 +1,11 @@
{ {
module Parser.JavaParser (parse, parseBlock, parseExpression) where module Parser.JavaParser (parse, parseStatement, parseExpression) where
import Ast import Ast
import Parser.Lexer import Parser.Lexer
} }
%name parse %name parse
%name parseBlock block %name parseStatement statement
%name parseExpression expression %name parseExpression expression
%tokentype { Token } %tokentype { Token }
%error { parseError } %error { parseError }
@ -127,8 +127,8 @@ classorinterfacetype : name { $1 }
classmemberdeclaration : fielddeclaration { $1 } classmemberdeclaration : fielddeclaration { $1 }
| methoddeclaration { $1 } | methoddeclaration { $1 }
constructordeclaration : constructordeclarator constructorbody { case $1 of (classname, parameters) -> MethodDecl $ MethodDeclaration classname "<init>" parameters $2 } constructordeclaration : constructordeclarator constructorbody { case $1 of (classname, parameters) -> MethodDecl $ MethodDeclaration "void" "<init>" parameters $2 }
| modifiers constructordeclarator constructorbody { case $2 of (classname, parameters) -> MethodDecl $ MethodDeclaration classname "<init>" parameters $3 } | modifiers constructordeclarator constructorbody { case $2 of (classname, parameters) -> MethodDecl $ MethodDeclaration "void" "<init>" parameters $3 }
fielddeclaration : type variabledeclarators SEMICOLON { FieldDecls $ map (convertDeclarator $1) $2 } fielddeclaration : type variabledeclarators SEMICOLON { FieldDecls $ map (convertDeclarator $1) $2 }
| modifiers type variabledeclarators SEMICOLON { FieldDecls $ map (convertDeclarator $2) $3 } | modifiers type variabledeclarators SEMICOLON { FieldDecls $ map (convertDeclarator $2) $3 }
@ -275,13 +275,13 @@ assignmentoperator : ASSIGN{ }
-- | XOREQUAL { } -- | XOREQUAL { }
-- | OREQUAL{ } -- | OREQUAL{ }
preincrementexpression : INCREMENT unaryexpression { } preincrementexpression : INCREMENT unaryexpression { UnaryOperation PreIncrement $2 }
predecrementexpression : DECREMENT unaryexpression { } predecrementexpression : DECREMENT unaryexpression { UnaryOperation PreDecrement $2 }
postincrementexpression : postfixexpression INCREMENT { } postincrementexpression : postfixexpression INCREMENT { UnaryOperation PostIncrement $1 }
postdecrementexpression : postfixexpression DECREMENT { } postdecrementexpression : postfixexpression DECREMENT { UnaryOperation PostDecrement $1 }
methodinvocation : name LBRACE RBRACE { } methodinvocation : name LBRACE RBRACE { }
| name LBRACE argumentlist RBRACE { } | name LBRACE argumentlist RBRACE { }
@ -296,15 +296,15 @@ conditionalandexpression : inclusiveorexpression { $1 }
fieldaccess : primary DOT IDENTIFIER { } fieldaccess : primary DOT IDENTIFIER { }
unaryexpression : unaryexpressionnotplusminus { $1 } unaryexpression : unaryexpressionnotplusminus { $1 }
-- | predecrementexpression { } | predecrementexpression { $1 }
| PLUS unaryexpression { $2 } | PLUS unaryexpression { $2 }
| MINUS unaryexpression { UnaryOperation Minus $2 } | MINUS unaryexpression { UnaryOperation Minus $2 }
-- | preincrementexpression { $1 } | preincrementexpression { $1 }
postfixexpression : primary { $1 } postfixexpression : primary { $1 }
| name { Reference $1 } | name { Reference $1 }
-- | postincrementexpression { } | postincrementexpression { $1 }
-- | postdecrementexpression{ } | postdecrementexpression{ $1 }
primary : primarynonewarray { $1 } primary : primarynonewarray { $1 }

View File

@ -10,9 +10,9 @@ typeCheckClass :: Class -> [Class] -> Class
typeCheckClass (Class className methods fields) classes = typeCheckClass (Class className methods fields) classes =
let let
-- Create a symbol table from class fields and method entries -- Create a symbol table from class fields and method entries
classFields = [(id, dt) | VariableDeclaration dt id _ <- fields] -- TODO: Maybe remove method entries from the symbol table?
methodEntries = [(methodName, className) | MethodDeclaration _ methodName _ _ <- methods] methodEntries = [(methodName, className) | MethodDeclaration _ methodName _ _ <- methods]
initalSymTab = ("this", className) : classFields ++ methodEntries initalSymTab = ("this", className) : methodEntries
checkedMethods = map (\method -> typeCheckMethodDeclaration method initalSymTab classes) methods checkedMethods = map (\method -> typeCheckMethodDeclaration method initalSymTab classes) methods
in Class className checkedMethods fields in Class className checkedMethods fields
@ -37,118 +37,46 @@ typeCheckExpression (CharacterLiteral c) _ _ = TypedExpression "char" (Character
typeCheckExpression (BooleanLiteral b) _ _ = TypedExpression "boolean" (BooleanLiteral b) typeCheckExpression (BooleanLiteral b) _ _ = TypedExpression "boolean" (BooleanLiteral b)
typeCheckExpression NullLiteral _ _ = TypedExpression "null" NullLiteral typeCheckExpression NullLiteral _ _ = TypedExpression "null" NullLiteral
typeCheckExpression (Reference id) symtab classes = typeCheckExpression (Reference id) symtab classes =
let type' = lookupType id symtab case lookup id symtab of
in TypedExpression type' (Reference id) Just t -> TypedExpression t (LocalVariable id)
Nothing ->
case lookup "this" symtab of
Just className ->
let classDetails = find (\(Class name _ _) -> name == className) classes
in case classDetails of
Just (Class _ _ fields) ->
let fieldTypes = [dt | VariableDeclaration dt fieldId _ <- fields, fieldId == id]
in case fieldTypes of
[fieldType] -> TypedExpression fieldType (FieldVariable id)
[] -> error $ "Field '" ++ id ++ "' not found in class '" ++ className ++ "'"
_ -> error $ "Ambiguous reference to field '" ++ id ++ "' in class '" ++ className ++ "'"
Nothing -> error $ "Class '" ++ className ++ "' not found for 'this'"
Nothing -> error $ "Context for 'this' not found in symbol table, unable to resolve '" ++ id ++ "'"
typeCheckExpression (BinaryOperation op expr1 expr2) symtab classes = typeCheckExpression (BinaryOperation op expr1 expr2) symtab classes =
let expr1' = typeCheckExpression expr1 symtab classes let expr1' = typeCheckExpression expr1 symtab classes
expr2' = typeCheckExpression expr2 symtab classes expr2' = typeCheckExpression expr2 symtab classes
type1 = getTypeFromExpr expr1' type1 = getTypeFromExpr expr1'
type2 = getTypeFromExpr expr2' type2 = getTypeFromExpr expr2'
resultType = resolveResultType type1 type2
in case op of in case op of
Addition -> Addition -> checkArithmeticOperation op expr1' expr2' type1 type2 resultType
if type1 == "int" && type2 == "int" Subtraction -> checkArithmeticOperation op expr1' expr2' type1 type2 resultType
then Multiplication -> checkArithmeticOperation op expr1' expr2' type1 type2 resultType
TypedExpression "int" (BinaryOperation op expr1' expr2') Division -> checkArithmeticOperation op expr1' expr2' type1 type2 resultType
else Modulo -> checkArithmeticOperation op expr1' expr2' type1 type2 resultType
error "Addition operation requires two operands of type int" BitwiseAnd -> checkBitwiseOperation op expr1' expr2' type1 type2
Subtraction -> BitwiseOr -> checkBitwiseOperation op expr1' expr2' type1 type2
if type1 == "int" && type2 == "int" BitwiseXor -> checkBitwiseOperation op expr1' expr2' type1 type2
then CompareLessThan -> checkComparisonOperation op expr1' expr2' type1 type2
TypedExpression "int" (BinaryOperation op expr1' expr2') CompareLessOrEqual -> checkComparisonOperation op expr1' expr2' type1 type2
else CompareGreaterThan -> checkComparisonOperation op expr1' expr2' type1 type2
error "Subtraction operation requires two operands of type int" CompareGreaterOrEqual -> checkComparisonOperation op expr1' expr2' type1 type2
Multiplication -> CompareEqual -> checkEqualityOperation op expr1' expr2' type1 type2
if type1 == "int" && type2 == "int" CompareNotEqual -> checkEqualityOperation op expr1' expr2' type1 type2
then And -> checkLogicalOperation op expr1' expr2' type1 type2
TypedExpression "int" (BinaryOperation op expr1' expr2') Or -> checkLogicalOperation op expr1' expr2' type1 type2
else NameResolution -> resolveNameResolution expr1' expr2 symtab classes
error "Multiplication operation requires two operands of type int"
Division ->
if type1 == "int" && type2 == "int"
then
TypedExpression "int" (BinaryOperation op expr1' expr2')
else
error "Division operation requires two operands of type int"
BitwiseAnd ->
if type1 == "int" && type2 == "int"
then
TypedExpression "int" (BinaryOperation op expr1' expr2')
else
error "Bitwise AND operation requires two operands of type int"
BitwiseOr ->
if type1 == "int" && type2 == "int"
then
TypedExpression "int" (BinaryOperation op expr1' expr2')
else
error "Bitwise OR operation requires two operands of type int"
BitwiseXor ->
if type1 == "int" && type2 == "int"
then
TypedExpression "int" (BinaryOperation op expr1' expr2')
else
error "Bitwise XOR operation requires two operands of type int"
CompareLessThan ->
if type1 == "int" && type2 == "int"
then
TypedExpression "boolean" (BinaryOperation op expr1' expr2')
else
error "Less than operation requires two operands of type int"
CompareLessOrEqual ->
if type1 == "int" && type2 == "int"
then
TypedExpression "boolean" (BinaryOperation op expr1' expr2')
else
error "Less than or equal operation requires two operands of type int"
CompareGreaterThan ->
if type1 == "int" && type2 == "int"
then
TypedExpression "boolean" (BinaryOperation op expr1' expr2')
else
error "Greater than operation requires two operands of type int"
CompareGreaterOrEqual ->
if type1 == "int" && type2 == "int"
then
TypedExpression "boolean" (BinaryOperation op expr1' expr2')
else
error "Greater than or equal operation requires two operands of type int"
CompareEqual ->
if type1 == type2
then
TypedExpression "boolean" (BinaryOperation op expr1' expr2')
else
error "Equality operation requires two operands of the same type"
CompareNotEqual ->
if type1 == type2
then
TypedExpression "boolean" (BinaryOperation op expr1' expr2')
else
error "Inequality operation requires two operands of the same type"
And ->
if type1 == "boolean" && type2 == "boolean"
then
TypedExpression "boolean" (BinaryOperation op expr1' expr2')
else
error "Logical AND operation requires two operands of type boolean"
Or ->
if type1 == "boolean" && type2 == "boolean"
then
TypedExpression "boolean" (BinaryOperation op expr1' expr2')
else
error "Logical OR operation requires two operands of type boolean"
NameResolution ->
case (expr1', expr2) of
(TypedExpression t1 (Reference obj), Reference member) ->
let objectType = lookupType obj symtab
classDetails = find (\(Class className _ _) -> className == objectType) classes
in case classDetails of
Just (Class _ _ fields) ->
let fieldTypes = [dt | VariableDeclaration dt id _ <- fields, id == member]
in case fieldTypes of
[resolvedType] -> TypedExpression resolvedType (BinaryOperation NameResolution expr1' (TypedExpression resolvedType expr2))
[] -> error $ "Field '" ++ member ++ "' not found in class '" ++ objectType ++ "'"
_ -> error $ "Ambiguous reference to field '" ++ member ++ "' in class '" ++ objectType ++ "'"
Nothing -> error $ "Object '" ++ obj ++ "' does not correspond to a known class"
_ -> error "Name resolution requires object reference and field name"
typeCheckExpression (UnaryOperation op expr) symtab classes = typeCheckExpression (UnaryOperation op expr) symtab classes =
let expr' = typeCheckExpression expr symtab classes let expr' = typeCheckExpression expr symtab classes
@ -164,8 +92,47 @@ typeCheckExpression (UnaryOperation op expr) symtab classes =
if type' == "int" if type' == "int"
then then
TypedExpression "int" (UnaryOperation op expr') TypedExpression "int" (UnaryOperation op expr')
else if type' == "char"
then
TypedExpression "char" (UnaryOperation op expr')
else else
error "Unary minus operation requires an operand of type int" error "Unary minus operation requires an operand of type int or char"
PostIncrement ->
if type' == "int"
then
TypedExpression "int" (UnaryOperation op expr')
else if type' == "char"
then
TypedExpression "char" (UnaryOperation op expr')
else
error "Post-increment operation requires an operand of type int or char"
PostDecrement ->
if type' == "int"
then
TypedExpression "int" (UnaryOperation op expr')
else if type' == "char"
then
TypedExpression "char" (UnaryOperation op expr')
else
error "Post-decrement operation requires an operand of type int or char"
PreIncrement ->
if type' == "int"
then
TypedExpression "int" (UnaryOperation op expr')
else if type' == "char"
then
TypedExpression "char" (UnaryOperation op expr')
else
error "Pre-increment operation requires an operand of type int or char"
PreDecrement ->
if type' == "int"
then
TypedExpression "int" (UnaryOperation op expr')
else if type' == "char"
then
TypedExpression "char" (UnaryOperation op expr')
else
error "Pre-decrement operation requires an operand of type int or char"
typeCheckExpression (StatementExpressionExpression stmtExpr) symtab classes = typeCheckExpression (StatementExpressionExpression stmtExpr) symtab classes =
let stmtExpr' = typeCheckStatementExpression stmtExpr symtab classes let stmtExpr' = typeCheckStatementExpression stmtExpr symtab classes
@ -174,15 +141,16 @@ typeCheckExpression (StatementExpressionExpression stmtExpr) symtab classes =
-- ********************************** Type Checking: StatementExpressions ********************************** -- ********************************** Type Checking: StatementExpressions **********************************
typeCheckStatementExpression :: StatementExpression -> [(Identifier, DataType)] -> [Class] -> StatementExpression typeCheckStatementExpression :: StatementExpression -> [(Identifier, DataType)] -> [Class] -> StatementExpression
typeCheckStatementExpression (Assignment id expr) symtab classes = typeCheckStatementExpression (Assignment ref expr) symtab classes =
let expr' = typeCheckExpression expr symtab classes let expr' = typeCheckExpression expr symtab classes
ref' = typeCheckExpression ref symtab classes
type' = getTypeFromExpr expr' type' = getTypeFromExpr expr'
type'' = lookupType id symtab type'' = getTypeFromExpr ref'
in if type' == type'' in
then if type'' == type' then
TypedStatementExpression type' (Assignment id expr') TypedStatementExpression type' (Assignment ref' expr')
else else
error "Assignment type mismatch" error $ "Type mismatch in assignment to variable: expected " ++ type'' ++ ", found " ++ type'
typeCheckStatementExpression (ConstructorCall className args) symtab classes = typeCheckStatementExpression (ConstructorCall className args) symtab classes =
case find (\(Class name _ _) -> name == className) classes of case find (\(Class name _ _) -> name == className) classes of
@ -327,8 +295,55 @@ unifyReturnTypes dt1 dt2
| dt1 == dt2 = dt1 | dt1 == dt2 = dt1
| otherwise = "Object" | otherwise = "Object"
lookupType :: Identifier -> [(Identifier, DataType)] -> DataType resolveResultType :: DataType -> DataType -> DataType
lookupType id symtab = resolveResultType "char" "char" = "char"
case lookup id symtab of resolveResultType "int" "int" = "int"
Just t -> t resolveResultType "char" "int" = "int"
Nothing -> error ("Identifier " ++ id ++ " not found in symbol table") resolveResultType "int" "char" = "int"
resolveResultType t1 t2
| t1 == t2 = t1
| otherwise = error $ "Incompatible types: " ++ t1 ++ " and " ++ t2
checkArithmeticOperation :: BinaryOperator -> Expression -> Expression -> DataType -> DataType -> DataType -> Expression
checkArithmeticOperation op expr1' expr2' type1 type2 resultType
| (type1 == "int" || type1 == "char") && (type2 == "int" || type2 == "char") =
TypedExpression resultType (BinaryOperation op expr1' expr2')
| otherwise = error $ "Arithmetic operation " ++ show op ++ " requires operands of type int or char"
checkBitwiseOperation :: BinaryOperator -> Expression -> Expression -> DataType -> DataType -> Expression
checkBitwiseOperation op expr1' expr2' type1 type2
| type1 == "int" && type2 == "int" =
TypedExpression "int" (BinaryOperation op expr1' expr2')
| otherwise = error $ "Bitwise operation " ++ show op ++ " requires operands of type int"
checkComparisonOperation :: BinaryOperator -> Expression -> Expression -> DataType -> DataType -> Expression
checkComparisonOperation op expr1' expr2' type1 type2
| (type1 == "int" || type1 == "char") && (type2 == "int" || type2 == "char") =
TypedExpression "boolean" (BinaryOperation op expr1' expr2')
| otherwise = error $ "Comparison operation " ++ show op ++ " requires operands of type int or char"
checkEqualityOperation :: BinaryOperator -> Expression -> Expression -> DataType -> DataType -> Expression
checkEqualityOperation op expr1' expr2' type1 type2
| type1 == type2 =
TypedExpression "boolean" (BinaryOperation op expr1' expr2')
| otherwise = error $ "Equality operation " ++ show op ++ " requires operands of the same type"
checkLogicalOperation :: BinaryOperator -> Expression -> Expression -> DataType -> DataType -> Expression
checkLogicalOperation op expr1' expr2' type1 type2
| type1 == "boolean" && type2 == "boolean" =
TypedExpression "boolean" (BinaryOperation op expr1' expr2')
| otherwise = error $ "Logical operation " ++ show op ++ " requires operands of type boolean"
resolveNameResolution :: Expression -> Expression -> [(Identifier, DataType)] -> [Class] -> Expression
resolveNameResolution expr1' (Reference ident2) symtab classes =
case getTypeFromExpr expr1' of
objType ->
case find (\(Class className _ _) -> className == objType) classes of
Just (Class _ _ fields) ->
let fieldTypes = [dt | VariableDeclaration dt id _ <- fields, id == ident2]
in case fieldTypes of
[resolvedType] -> TypedExpression resolvedType (BinaryOperation NameResolution expr1' (TypedExpression resolvedType (FieldVariable ident2)))
[] -> error $ "Field '" ++ ident2 ++ "' not found in class '" ++ objType ++ "'"
_ -> error $ "Ambiguous reference to field '" ++ ident2 ++ "' in class '" ++ objType ++ "'"
Nothing -> error $ "Class '" ++ objType ++ "' not found"
resolveNameResolution _ _ _ _ = error "Name resolution requires object reference and field name"