From 1d5463582ff521f11117beee895082aacd4e5182 Mon Sep 17 00:00:00 2001 From: Fabian Noll Date: Wed, 8 May 2024 17:39:43 +0200 Subject: [PATCH 01/10] add differentiation between local and field variable --- src/Example.hs | 12 ++++---- src/Typecheck.hs | 72 +++++++++++++++++++++++++++++++----------------- 2 files changed, 54 insertions(+), 30 deletions(-) diff --git a/src/Example.hs b/src/Example.hs index 7f345b3..5c9cb51 100644 --- a/src/Example.hs +++ b/src/Example.hs @@ -58,7 +58,7 @@ exampleConstructorCall :: Statement exampleConstructorCall = LocalVariableDeclaration (VariableDeclaration "Person" "bob" (Just (StatementExpressionExpression (ConstructorCall "Person" [IntegerLiteral 30])))) exampleNameResolution :: Expression -exampleNameResolution = BinaryOperation NameResolution (Reference "b") (Reference "age") +exampleNameResolution = BinaryOperation NameResolution (Reference "bob2") (Reference "age") exampleBlockResolution :: Statement exampleBlockResolution = Block [ @@ -113,10 +113,12 @@ testClasses = [ (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 "bob") "getAge" [])))), + LocalVariableDeclaration (VariableDeclaration "int" "bobAge" (Just (StatementExpressionExpression (MethodCall (Reference "bob2") "getAge" [])))), Return (Just (Reference "bobAge")) ]) - ] [] + ] [ + VariableDeclaration "Person" "bob2" Nothing + ] ] runTypeCheck :: IO () @@ -151,7 +153,7 @@ runTypeCheck = do catch (do print "=====================================================================================" - evaluatedNameResolution <- evaluate (typeCheckExpression exampleNameResolution [("b", "Person")] sampleClasses) + evaluatedNameResolution <- evaluate (typeCheckExpression exampleNameResolution [("this", "Main")] testClasses) printSuccess "Type checking of name resolution completed successfully" printResult "Result Name Resolution:" evaluatedNameResolution ) handleError @@ -189,7 +191,7 @@ runTypeCheck = do let mainClass = fromJust $ find (\(Class className _ _) -> className == "Main") testClasses case mainClass of Class _ [mainMethod] _ -> do - let result = typeCheckMethodDeclaration mainMethod [] testClasses + let result = typeCheckMethodDeclaration mainMethod [("this", "Main")] testClasses printSuccess "Full program type checking completed successfully." printResult "Main method result:" result ) handleError diff --git a/src/Typecheck.hs b/src/Typecheck.hs index 7cdc3a7..5f1f28c 100644 --- a/src/Typecheck.hs +++ b/src/Typecheck.hs @@ -10,9 +10,9 @@ typeCheckClass :: Class -> [Class] -> Class typeCheckClass (Class className methods fields) classes = let -- 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] - initalSymTab = ("this", className) : classFields ++ methodEntries + initalSymTab = ("this", className) : methodEntries checkedMethods = map (\method -> typeCheckMethodDeclaration method initalSymTab classes) methods in Class className checkedMethods fields @@ -37,8 +37,21 @@ typeCheckExpression (CharacterLiteral c) _ _ = TypedExpression "char" (Character typeCheckExpression (BooleanLiteral b) _ _ = TypedExpression "boolean" (BooleanLiteral b) typeCheckExpression NullLiteral _ _ = TypedExpression "null" NullLiteral typeCheckExpression (Reference id) symtab classes = - let type' = lookupType id symtab - in TypedExpression type' (Reference id) + case lookup id symtab of + Just t -> TypedExpression t (LocalVariable id) + Nothing -> + case lookup "this" symtab of + Just className -> + let classDetails = find (\(Class name _ _) -> name == className) classes + in case classDetails of + Just (Class _ _ fields) -> + let fieldTypes = [dt | VariableDeclaration dt 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 = let expr1' = typeCheckExpression expr1 symtab classes expr2' = typeCheckExpression expr2 symtab classes @@ -137,18 +150,25 @@ typeCheckExpression (BinaryOperation op expr1 expr2) symtab classes = 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" + (TypedExpression objType (LocalVariable ident), Reference ident2) -> + 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 '" ++ ident ++ "' in class '" ++ objType ++ "'" + Nothing -> error $ "Class '" ++ objType ++ "' not found" + (TypedExpression objType (FieldVariable ident), Reference ident2) -> + 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 '" ++ ident ++ "' in class '" ++ objType ++ "'" + Nothing -> error $ "Class '" ++ objType ++ "' not found" + _ -> error "Name resolution requires object reference and field name" typeCheckExpression (UnaryOperation op expr) symtab classes = let expr' = typeCheckExpression expr symtab classes @@ -177,12 +197,14 @@ typeCheckStatementExpression :: StatementExpression -> [(Identifier, DataType)] typeCheckStatementExpression (Assignment id expr) symtab classes = let expr' = typeCheckExpression expr symtab classes type' = getTypeFromExpr expr' - type'' = lookupType id symtab - in if type' == type'' - then - TypedStatementExpression type' (Assignment id expr') - else - error "Assignment type mismatch" + maybeType'' = lookupType id symtab + in case maybeType'' of + Just type'' -> + if type' == type'' then + TypedStatementExpression type' (Assignment id expr') + else + error $ "Assignment type mismatch: expected " ++ type'' ++ ", found " ++ type' + Nothing -> error $ "Identifier '" ++ id ++ "' not found in symbol table" typeCheckStatementExpression (ConstructorCall className args) symtab classes = case find (\(Class name _ _) -> name == className) classes of @@ -327,8 +349,8 @@ unifyReturnTypes dt1 dt2 | dt1 == dt2 = dt1 | otherwise = "Object" -lookupType :: Identifier -> [(Identifier, DataType)] -> DataType +lookupType :: Identifier -> [(Identifier, DataType)] -> Maybe DataType lookupType id symtab = case lookup id symtab of - Just t -> t - Nothing -> error ("Identifier " ++ id ++ " not found in symbol table") + Just t -> Just t + Nothing -> Nothing From 20184c5e266a40384804698c8fecca07a3faf3ae Mon Sep 17 00:00:00 2001 From: Fabian Noll Date: Mon, 13 May 2024 13:13:24 +0200 Subject: [PATCH 02/10] add modulus to AST and Typecheck --- src/Ast.hs | 1 + src/Typecheck.hs | 6 ++++++ 2 files changed, 7 insertions(+) diff --git a/src/Ast.hs b/src/Ast.hs index 6253aa6..6554290 100644 --- a/src/Ast.hs +++ b/src/Ast.hs @@ -30,6 +30,7 @@ data BinaryOperator | Subtraction | Multiplication | Division + | Modulus | BitwiseAnd | BitwiseOr | BitwiseXor diff --git a/src/Typecheck.hs b/src/Typecheck.hs index 5f1f28c..7a7ac8d 100644 --- a/src/Typecheck.hs +++ b/src/Typecheck.hs @@ -82,6 +82,12 @@ typeCheckExpression (BinaryOperation op expr1 expr2) symtab classes = TypedExpression "int" (BinaryOperation op expr1' expr2') else error "Division operation requires two operands of type int" + Modulus -> + if type1 == "int" && type2 == "int" + then + TypedExpression "int" (BinaryOperation op expr1' expr2') + else + error "Modulus operation requires two operands of type int" BitwiseAnd -> if type1 == "int" && type2 == "int" then From e350c23db1ae68f9aec4f68ffd7a48374b016763 Mon Sep 17 00:00:00 2001 From: Fabian Noll Date: Tue, 14 May 2024 09:36:18 +0200 Subject: [PATCH 03/10] fix spelling error --- src/Ast.hs | 2 +- src/Typecheck.hs | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Ast.hs b/src/Ast.hs index 6554290..90dcc43 100644 --- a/src/Ast.hs +++ b/src/Ast.hs @@ -30,7 +30,7 @@ data BinaryOperator | Subtraction | Multiplication | Division - | Modulus + | Modulo | BitwiseAnd | BitwiseOr | BitwiseXor diff --git a/src/Typecheck.hs b/src/Typecheck.hs index 7a7ac8d..981d4d8 100644 --- a/src/Typecheck.hs +++ b/src/Typecheck.hs @@ -82,7 +82,7 @@ typeCheckExpression (BinaryOperation op expr1 expr2) symtab classes = TypedExpression "int" (BinaryOperation op expr1' expr2') else error "Division operation requires two operands of type int" - Modulus -> + Modulo -> if type1 == "int" && type2 == "int" then TypedExpression "int" (BinaryOperation op expr1' expr2') From 666fb4ee1a1beed363102aae90401445aeca1aca Mon Sep 17 00:00:00 2001 From: Fabian Noll Date: Tue, 14 May 2024 10:04:00 +0200 Subject: [PATCH 04/10] Assignment now rakes expression instead of identifier --- src/Ast.hs | 2 +- src/Example.hs | 19 ++++++++++++++++--- src/Typecheck.hs | 19 +++++++++---------- 3 files changed, 26 insertions(+), 14 deletions(-) diff --git a/src/Ast.hs b/src/Ast.hs index 90dcc43..cce19aa 100644 --- a/src/Ast.hs +++ b/src/Ast.hs @@ -19,7 +19,7 @@ data Statement deriving (Show) data StatementExpression - = Assignment Identifier Expression + = Assignment Expression Expression | ConstructorCall DataType [Expression] | MethodCall Expression Identifier [Expression] | TypedStatementExpression DataType StatementExpression diff --git a/src/Example.hs b/src/Example.hs index 5c9cb51..e36c64d 100644 --- a/src/Example.hs +++ b/src/Example.hs @@ -49,7 +49,7 @@ exampleExpression :: Expression exampleExpression = BinaryOperation NameResolution (Reference "bob") (Reference "age") exampleAssignment :: Expression -exampleAssignment = StatementExpressionExpression (Assignment "a" (IntegerLiteral 30)) +exampleAssignment = StatementExpressionExpression (Assignment (Reference "a") (IntegerLiteral 30)) exampleMethodCall :: Statement exampleMethodCall = StatementExpressionStatement (MethodCall (Reference "this") "setAge" [IntegerLiteral 30]) @@ -80,7 +80,7 @@ exampleMethodCallAndAssignment = Block [ LocalVariableDeclaration (VariableDeclaration "int" "age" (Just (StatementExpressionExpression (MethodCall (Reference "bob") "getAge" [])))), StatementExpressionStatement (MethodCall (Reference "bob") "setAge" [IntegerLiteral 30]), LocalVariableDeclaration (VariableDeclaration "int" "a" Nothing), - StatementExpressionStatement (Assignment "a" (Reference "age")) + StatementExpressionStatement (Assignment (Reference "a") (Reference "age")) ] @@ -89,7 +89,13 @@ 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 "a" (Reference "age")) + StatementExpressionStatement (Assignment (Reference "age") (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)) ] testClasses :: [Class] @@ -202,4 +208,11 @@ runTypeCheck = do 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 diff --git a/src/Typecheck.hs b/src/Typecheck.hs index 981d4d8..0346c5d 100644 --- a/src/Typecheck.hs +++ b/src/Typecheck.hs @@ -200,18 +200,17 @@ typeCheckExpression (StatementExpressionExpression stmtExpr) symtab classes = -- ********************************** Type Checking: StatementExpressions ********************************** typeCheckStatementExpression :: StatementExpression -> [(Identifier, DataType)] -> [Class] -> StatementExpression -typeCheckStatementExpression (Assignment id expr) symtab classes = +typeCheckStatementExpression (Assignment ref expr) symtab classes = let expr' = typeCheckExpression expr symtab classes + ref' = typeCheckExpression ref symtab classes type' = getTypeFromExpr expr' - maybeType'' = lookupType id symtab - in case maybeType'' of - Just type'' -> - if type' == type'' then - TypedStatementExpression type' (Assignment id expr') - else - error $ "Assignment type mismatch: expected " ++ type'' ++ ", found " ++ type' - Nothing -> error $ "Identifier '" ++ id ++ "' not found in symbol table" - + type'' = getTypeFromExpr ref' + in + if type'' == type' then + TypedStatementExpression type' (Assignment ref' expr') + else + error $ "Type mismatch in assignment to variable: expected " ++ type'' ++ ", found " ++ type' + typeCheckStatementExpression (ConstructorCall className args) symtab classes = case find (\(Class name _ _) -> name == className) classes of Nothing -> error $ "Class '" ++ className ++ "' not found." From 64829c2086cce87e2b66ac66174aa9b3eefd4dd1 Mon Sep 17 00:00:00 2001 From: Marvin Schlegel Date: Tue, 14 May 2024 10:16:56 +0200 Subject: [PATCH 05/10] replace parseBlock with parseStatement --- Test/TestParser.hs | 26 +++++++++++++------------- src/Parser/JavaParser.y | 4 ++-- 2 files changed, 15 insertions(+), 15 deletions(-) diff --git a/Test/TestParser.hs b/Test/TestParser.hs index 5e8eec5..a9885ea 100644 --- a/Test/TestParser.hs +++ b/Test/TestParser.hs @@ -54,19 +54,19 @@ testClassWithConstructor = TestCase $ 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 $ - assertEqual "expect block with local var delcaration" (Block [LocalVariableDeclaration $ VariableDeclaration "int" "localvar" Nothing]) $ - parseBlock [LBRACKET,INT,IDENTIFIER "localvar",SEMICOLON,RBRACKET] + assertEqual "expect block with local var delcaration" [Block [LocalVariableDeclaration $ VariableDeclaration "int" "localvar" Nothing]] $ + parseStatement [LBRACKET,INT,IDENTIFIER "localvar",SEMICOLON,RBRACKET] testBlockWithMultipleLocalVarDecls = TestCase $ - assertEqual "expect block with multiple local var declarations" (Block [LocalVariableDeclaration $ VariableDeclaration "int" "var1" Nothing, LocalVariableDeclaration $ VariableDeclaration "boolean" "var2" Nothing]) $ - parseBlock [LBRACKET,INT,IDENTIFIER "var1",SEMICOLON,BOOLEAN,IDENTIFIER "var2",SEMICOLON,RBRACKET] + assertEqual "expect block with multiple local var declarations" [Block [LocalVariableDeclaration $ VariableDeclaration "int" "var1" Nothing, LocalVariableDeclaration $ VariableDeclaration "boolean" "var2" Nothing]] $ + parseStatement [LBRACKET,INT,IDENTIFIER "var1",SEMICOLON,BOOLEAN,IDENTIFIER "var2",SEMICOLON,RBRACKET] testNestedBlocks = TestCase $ - assertEqual "expect block with block inside" (Block [Block []]) $ - parseBlock [LBRACKET,LBRACKET,RBRACKET,RBRACKET] + assertEqual "expect block with block inside" [Block [Block []]] $ + parseStatement [LBRACKET,LBRACKET,RBRACKET,RBRACKET] testBlockWithEmptyStatement = TestCase $ - assertEqual "expect empty block" (Block []) $ - parseBlock [LBRACKET,SEMICOLON,SEMICOLON,RBRACKET] + assertEqual "expect empty block" [Block []] $ + parseStatement [LBRACKET,SEMICOLON,SEMICOLON,RBRACKET] testExpressionIntLiteral = TestCase $ 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]] $ 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]) $ - parseBlock [LBRACKET,BOOLEAN,IDENTIFIER "b",ASSIGN,BOOLLITERAL False,SEMICOLON,RBRACKET] + assertEqual "expect block with with initialized local var" [Block [LocalVariableDeclaration $ VariableDeclaration "boolean" "b" $ Just $ BooleanLiteral False]] $ + parseStatement [LBRACKET,BOOLEAN,IDENTIFIER "b",ASSIGN,BOOLLITERAL False,SEMICOLON,RBRACKET] testFieldNullWithInitialization = TestCase $ assertEqual "expect Class with initialized field" [Class "WithInitField" [] [VariableDeclaration "Object" "bar" $ Just NullLiteral]] $ parse [CLASS,IDENTIFIER "WithInitField",LBRACKET,IDENTIFIER "Object",IDENTIFIER "bar",ASSIGN,NULLLITERAL,SEMICOLON,RBRACKET] testReturnVoid = TestCase $ - assertEqual "expect block with return nothing" (Block [Return Nothing]) $ - parseBlock [LBRACKET,RETURN,SEMICOLON,RBRACKET] + assertEqual "expect block with return nothing" [Block [Return Nothing]] $ + parseStatement [LBRACKET,RETURN,SEMICOLON,RBRACKET] testExpressionNot = TestCase $ assertEqual "expect expression not" (UnaryOperation Not (Reference "boar")) $ diff --git a/src/Parser/JavaParser.y b/src/Parser/JavaParser.y index 68be06c..49fbeb1 100644 --- a/src/Parser/JavaParser.y +++ b/src/Parser/JavaParser.y @@ -1,11 +1,11 @@ { -module Parser.JavaParser (parse, parseBlock, parseExpression) where +module Parser.JavaParser (parse, parseStatement, parseExpression) where import Ast import Parser.Lexer } %name parse -%name parseBlock block +%name parseStatement statement %name parseExpression expression %tokentype { Token } %error { parseError } From 3fa97361725eb974e0decca41a07e8438951d5ed Mon Sep 17 00:00:00 2001 From: Fabian Noll Date: Tue, 14 May 2024 11:19:26 +0200 Subject: [PATCH 06/10] add post and pre operations --- src/Ast.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Ast.hs b/src/Ast.hs index cce19aa..7f60c8e 100644 --- a/src/Ast.hs +++ b/src/Ast.hs @@ -48,6 +48,10 @@ data BinaryOperator data UnaryOperator = Not | Minus + | PostIncrement + | PostDecrement + | PreIncrement + | PreDecrement deriving (Show) data Expression From fae3498bd99460fb77710d58cf9666273b55c793 Mon Sep 17 00:00:00 2001 From: Fabian Noll Date: Tue, 14 May 2024 11:21:06 +0200 Subject: [PATCH 07/10] Refactor BinaryOperations and add char operations --- src/Example.hs | 10 ++ src/Typecheck.hs | 232 +++++++++++++++++++++++------------------------ 2 files changed, 123 insertions(+), 119 deletions(-) diff --git a/src/Example.hs b/src/Example.hs index e36c64d..28cf40c 100644 --- a/src/Example.hs +++ b/src/Example.hs @@ -98,6 +98,9 @@ exampleNameResolutionAssignment = Block [ StatementExpressionStatement (Assignment (BinaryOperation NameResolution (Reference "bob") (Reference "age")) (IntegerLiteral 30)) ] +exampleCharIntOperation :: Expression +exampleCharIntOperation = BinaryOperation Addition (CharacterLiteral 'a') (IntegerLiteral 1) + testClasses :: [Class] testClasses = [ Class "Person" [ @@ -216,3 +219,10 @@ runTypeCheck = do 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 + diff --git a/src/Typecheck.hs b/src/Typecheck.hs index 0346c5d..34a3b1f 100644 --- a/src/Typecheck.hs +++ b/src/Typecheck.hs @@ -52,129 +52,31 @@ typeCheckExpression (Reference id) symtab classes = _ -> error $ "Ambiguous reference to field '" ++ id ++ "' in class '" ++ className ++ "'" Nothing -> error $ "Class '" ++ className ++ "' not found for 'this'" Nothing -> error $ "Context for 'this' not found in symbol table, unable to resolve '" ++ id ++ "'" + typeCheckExpression (BinaryOperation op expr1 expr2) symtab classes = let expr1' = typeCheckExpression expr1 symtab classes expr2' = typeCheckExpression expr2 symtab classes type1 = getTypeFromExpr expr1' type2 = getTypeFromExpr expr2' + resultType = resolveResultType type1 type2 in case op of - Addition -> - if type1 == "int" && type2 == "int" - then - TypedExpression "int" (BinaryOperation op expr1' expr2') - else - error "Addition operation requires two operands of type int" - Subtraction -> - if type1 == "int" && type2 == "int" - then - TypedExpression "int" (BinaryOperation op expr1' expr2') - else - error "Subtraction operation requires two operands of type int" - Multiplication -> - if type1 == "int" && type2 == "int" - then - TypedExpression "int" (BinaryOperation op expr1' expr2') - else - error "Multiplication operation requires two operands of type int" - Division -> - if type1 == "int" && type2 == "int" - then - TypedExpression "int" (BinaryOperation op expr1' expr2') - else - error "Division operation requires two operands of type int" - Modulo -> - if type1 == "int" && type2 == "int" - then - TypedExpression "int" (BinaryOperation op expr1' expr2') - else - error "Modulus 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 objType (LocalVariable ident), Reference ident2) -> - 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 '" ++ ident ++ "' in class '" ++ objType ++ "'" - Nothing -> error $ "Class '" ++ objType ++ "' not found" - (TypedExpression objType (FieldVariable ident), Reference ident2) -> - 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 '" ++ ident ++ "' in class '" ++ objType ++ "'" - Nothing -> error $ "Class '" ++ objType ++ "' not found" - _ -> error "Name resolution requires object reference and field name" + Addition -> checkArithmeticOperation op expr1' expr2' type1 type2 resultType + Subtraction -> checkArithmeticOperation op expr1' expr2' type1 type2 resultType + Multiplication -> checkArithmeticOperation op expr1' expr2' type1 type2 resultType + Division -> checkArithmeticOperation op expr1' expr2' type1 type2 resultType + Modulo -> checkArithmeticOperation op expr1' expr2' type1 type2 resultType + BitwiseAnd -> checkBitwiseOperation op expr1' expr2' type1 type2 + BitwiseOr -> checkBitwiseOperation op expr1' expr2' type1 type2 + BitwiseXor -> checkBitwiseOperation op expr1' expr2' type1 type2 + CompareLessThan -> checkComparisonOperation op expr1' expr2' type1 type2 + CompareLessOrEqual -> checkComparisonOperation op expr1' expr2' type1 type2 + CompareGreaterThan -> checkComparisonOperation op expr1' expr2' type1 type2 + CompareGreaterOrEqual -> checkComparisonOperation op expr1' expr2' type1 type2 + CompareEqual -> checkEqualityOperation op expr1' expr2' type1 type2 + CompareNotEqual -> checkEqualityOperation op expr1' expr2' type1 type2 + And -> checkLogicalOperation op expr1' expr2' type1 type2 + Or -> checkLogicalOperation op expr1' expr2' type1 type2 + NameResolution -> resolveNameResolution expr1' expr2 symtab classes typeCheckExpression (UnaryOperation op expr) symtab classes = let expr' = typeCheckExpression expr symtab classes @@ -187,11 +89,50 @@ typeCheckExpression (UnaryOperation op expr) symtab classes = else error "Logical NOT operation requires an operand of type boolean" Minus -> + if type' == "int" + then + TypedExpression "int" (UnaryOperation op expr') + else if type' == "char" + then + TypedExpression "char" (UnaryOperation op expr') + else + 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 "Unary minus operation requires an operand of type int" + 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 = let stmtExpr' = typeCheckStatementExpression stmtExpr symtab classes @@ -329,7 +270,7 @@ typeCheckStatement (Return expr) symtab classes = Nothing -> Nothing in case expr' of Just e' -> TypedStatement (getTypeFromExpr e') (Return (Just e')) - Nothing -> TypedStatement "Void" (Return Nothing) + Nothing -> TypedStatement "void" (Return Nothing) typeCheckStatement (StatementExpressionStatement stmtExpr) symtab classes = let stmtExpr' = typeCheckStatementExpression stmtExpr symtab classes @@ -359,3 +300,56 @@ lookupType id symtab = case lookup id symtab of Just t -> Just t Nothing -> Nothing + +resolveResultType :: DataType -> DataType -> DataType +resolveResultType "char" "char" = "char" +resolveResultType "int" "int" = "int" +resolveResultType "char" "int" = "int" +resolveResultType "int" "char" = "int" +resolveResultType t1 t2 + | t1 == t2 = t1 + | otherwise = error $ "Incompatible types: " ++ t1 ++ " and " ++ t2 + +checkArithmeticOperation :: BinaryOperator -> Expression -> Expression -> DataType -> DataType -> DataType -> Expression +checkArithmeticOperation op expr1' expr2' type1 type2 resultType + | (type1 == "int" || type1 == "char") && (type2 == "int" || type2 == "char") = + TypedExpression resultType (BinaryOperation op expr1' expr2') + | otherwise = error $ "Arithmetic operation " ++ show op ++ " requires operands of type int or char" + +checkBitwiseOperation :: BinaryOperator -> Expression -> Expression -> DataType -> DataType -> Expression +checkBitwiseOperation op expr1' expr2' type1 type2 + | type1 == "int" && type2 == "int" = + TypedExpression "int" (BinaryOperation op expr1' expr2') + | otherwise = error $ "Bitwise operation " ++ show op ++ " requires operands of type int" + +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" From f8b0b59c5d9c67bcec9f94e5bc875d193c4275cf Mon Sep 17 00:00:00 2001 From: Fabian Noll Date: Tue, 14 May 2024 11:26:27 +0200 Subject: [PATCH 08/10] refactor unused function --- src/Example.hs | 2 +- src/Typecheck.hs | 16 +++++----------- 2 files changed, 6 insertions(+), 12 deletions(-) diff --git a/src/Example.hs b/src/Example.hs index 28cf40c..db4213f 100644 --- a/src/Example.hs +++ b/src/Example.hs @@ -89,7 +89,7 @@ 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 "age") (Reference "age")) + StatementExpressionStatement (Assignment (Reference "a") (Reference "age")) ] exampleNameResolutionAssignment :: Statement diff --git a/src/Typecheck.hs b/src/Typecheck.hs index 34a3b1f..0032d46 100644 --- a/src/Typecheck.hs +++ b/src/Typecheck.hs @@ -52,7 +52,7 @@ typeCheckExpression (Reference id) symtab classes = _ -> error $ "Ambiguous reference to field '" ++ id ++ "' in class '" ++ className ++ "'" Nothing -> error $ "Class '" ++ className ++ "' not found for 'this'" Nothing -> error $ "Context for 'this' not found in symbol table, unable to resolve '" ++ id ++ "'" - + typeCheckExpression (BinaryOperation op expr1 expr2) symtab classes = let expr1' = typeCheckExpression expr1 symtab classes expr2' = typeCheckExpression expr2 symtab classes @@ -89,10 +89,10 @@ typeCheckExpression (UnaryOperation op expr) symtab classes = else error "Logical NOT operation requires an operand of type boolean" Minus -> - if type' == "int" + if type' == "int" then TypedExpression "int" (UnaryOperation op expr') - else if type' == "char" + else if type' == "char" then TypedExpression "char" (UnaryOperation op expr') else @@ -147,11 +147,11 @@ typeCheckStatementExpression (Assignment ref expr) symtab classes = type' = getTypeFromExpr expr' type'' = getTypeFromExpr ref' in - if type'' == type' then + if type'' == type' then TypedStatementExpression type' (Assignment ref' expr') else error $ "Type mismatch in assignment to variable: expected " ++ type'' ++ ", found " ++ type' - + typeCheckStatementExpression (ConstructorCall className args) symtab classes = case find (\(Class name _ _) -> name == className) classes of Nothing -> error $ "Class '" ++ className ++ "' not found." @@ -295,12 +295,6 @@ unifyReturnTypes dt1 dt2 | dt1 == dt2 = dt1 | otherwise = "Object" -lookupType :: Identifier -> [(Identifier, DataType)] -> Maybe DataType -lookupType id symtab = - case lookup id symtab of - Just t -> Just t - Nothing -> Nothing - resolveResultType :: DataType -> DataType -> DataType resolveResultType "char" "char" = "char" resolveResultType "int" "int" = "int" From 7ba9743b0a7ccc2ac7144ce00d615c0b4a5db6d2 Mon Sep 17 00:00:00 2001 From: Marvin Schlegel Date: Tue, 14 May 2024 11:34:57 +0200 Subject: [PATCH 09/10] parser add increment decrement --- Test/TestParser.hs | 18 +++++++++++++++++- src/Parser/JavaParser.y | 16 ++++++++-------- 2 files changed, 25 insertions(+), 9 deletions(-) diff --git a/Test/TestParser.hs b/Test/TestParser.hs index a9885ea..d85b9f5 100644 --- a/Test/TestParser.hs +++ b/Test/TestParser.hs @@ -132,6 +132,18 @@ testExpressionXor = TestCase $ testExpressionOr = TestCase $ assertEqual "expect or expression" (BinaryOperation Or (Reference "bar") (Reference "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 [ @@ -169,5 +181,9 @@ tests = TestList [ testExpressionNotEqual, testExpressionAnd, testExpressionXor, - testExpressionOr + testExpressionOr, + testExpressionPostIncrement, + testExpressionPostDecrement, + testExpressionPreIncrement, + testExpressionPreDecrement ] \ No newline at end of file diff --git a/src/Parser/JavaParser.y b/src/Parser/JavaParser.y index 49fbeb1..53828ea 100644 --- a/src/Parser/JavaParser.y +++ b/src/Parser/JavaParser.y @@ -275,13 +275,13 @@ assignmentoperator : ASSIGN{ } -- | XOREQUAL { } -- | 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 { } | name LBRACE argumentlist RBRACE { } @@ -296,15 +296,15 @@ conditionalandexpression : inclusiveorexpression { $1 } fieldaccess : primary DOT IDENTIFIER { } unaryexpression : unaryexpressionnotplusminus { $1 } - -- | predecrementexpression { } + | predecrementexpression { $1 } | PLUS unaryexpression { $2 } | MINUS unaryexpression { UnaryOperation Minus $2 } - -- | preincrementexpression { $1 } + | preincrementexpression { $1 } postfixexpression : primary { $1 } | name { Reference $1 } - -- | postincrementexpression { } - -- | postdecrementexpression{ } + | postincrementexpression { $1 } + | postdecrementexpression{ $1 } primary : primarynonewarray { $1 } From aa3b196ab55d94a5c953ff9384df19043c2c89b0 Mon Sep 17 00:00:00 2001 From: Marvin Schlegel Date: Tue, 14 May 2024 12:33:42 +0200 Subject: [PATCH 10/10] set constructor return type void --- Test/TestParser.hs | 2 +- src/Parser/JavaParser.y | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/Test/TestParser.hs b/Test/TestParser.hs index d85b9f5..ba54821 100644 --- a/Test/TestParser.hs +++ b/Test/TestParser.hs @@ -50,7 +50,7 @@ testClassWithMethodAndField = TestCase $ assertEqual "expect class with method and field" [Class "WithMethodAndField" [MethodDeclaration "void" "foo" [] (Block []), MethodDeclaration "int" "bar" [] (Block [])] [VariableDeclaration "int" "value" Nothing]] $ parse [CLASS,IDENTIFIER "WithMethodAndField",LBRACKET,VOID,IDENTIFIER "foo",LBRACE,RBRACE,LBRACKET,RBRACKET,INT,IDENTIFIER "value",SEMICOLON,INT,IDENTIFIER "bar",LBRACE,RBRACE,SEMICOLON,RBRACKET] testClassWithConstructor = TestCase $ - assertEqual "expect class with constructor" [Class "WithConstructor" [MethodDeclaration "WithConstructor" "" [] (Block [])] []] $ + assertEqual "expect class with constructor" [Class "WithConstructor" [MethodDeclaration "void" "" [] (Block [])] []] $ parse [CLASS,IDENTIFIER "WithConstructor",LBRACKET,IDENTIFIER "WithConstructor",LBRACE,RBRACE,LBRACKET,RBRACKET,RBRACKET] diff --git a/src/Parser/JavaParser.y b/src/Parser/JavaParser.y index 53828ea..e51afb4 100644 --- a/src/Parser/JavaParser.y +++ b/src/Parser/JavaParser.y @@ -127,8 +127,8 @@ classorinterfacetype : name { $1 } classmemberdeclaration : fielddeclaration { $1 } | methoddeclaration { $1 } -constructordeclaration : constructordeclarator constructorbody { case $1 of (classname, parameters) -> MethodDecl $ MethodDeclaration classname "" parameters $2 } - | modifiers constructordeclarator constructorbody { case $2 of (classname, parameters) -> MethodDecl $ MethodDeclaration classname "" parameters $3 } +constructordeclaration : constructordeclarator constructorbody { case $1 of (classname, parameters) -> MethodDecl $ MethodDeclaration "void" "" parameters $2 } + | modifiers constructordeclarator constructorbody { case $2 of (classname, parameters) -> MethodDecl $ MethodDeclaration "void" "" parameters $3 } fielddeclaration : type variabledeclarators SEMICOLON { FieldDecls $ map (convertDeclarator $1) $2 } | modifiers type variabledeclarators SEMICOLON { FieldDecls $ map (convertDeclarator $2) $3 }