Merge remote-tracking branch 'origin/typedAST' into create-parser

This commit is contained in:
Marvin Schlegel 2024-05-14 11:28:15 +02:00
commit 83e6964d71
3 changed files with 175 additions and 131 deletions

View File

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

View File

@ -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])
@ -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 [
@ -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,9 +89,18 @@ 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 "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 "Person" [
@ -113,10 +122,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 +162,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 +200,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
@ -200,4 +211,18 @@ 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
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

@ -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,118 +37,46 @@ 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
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"
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"
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
@ -164,8 +92,47 @@ typeCheckExpression (UnaryOperation op expr) symtab classes =
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 "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 =
let stmtExpr' = typeCheckStatementExpression stmtExpr symtab classes
@ -174,15 +141,16 @@ 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'
type'' = lookupType id symtab
in if type' == type''
then
TypedStatementExpression type' (Assignment id expr')
else
error "Assignment type mismatch"
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
@ -302,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
@ -327,8 +295,55 @@ unifyReturnTypes dt1 dt2
| dt1 == dt2 = dt1
| otherwise = "Object"
lookupType :: Identifier -> [(Identifier, DataType)] -> DataType
lookupType id symtab =
case lookup id symtab of
Just t -> t
Nothing -> error ("Identifier " ++ id ++ " not found in symbol table")
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"