Add initial typechecker for AST #2
@ -98,6 +98,9 @@ exampleNameResolutionAssignment = Block [
|
|||||||
StatementExpressionStatement (Assignment (BinaryOperation NameResolution (Reference "bob") (Reference "age")) (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" [
|
||||||
@ -216,3 +219,10 @@ runTypeCheck = do
|
|||||||
printResult "Result Name Resolution Assignment:" typedAssignment
|
printResult "Result Name Resolution Assignment:" typedAssignment
|
||||||
) handleError
|
) 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
|
||||||
|
|
||||||
|
232
src/Typecheck.hs
232
src/Typecheck.hs
@ -52,129 +52,31 @@ typeCheckExpression (Reference id) symtab classes =
|
|||||||
_ -> error $ "Ambiguous reference to field '" ++ id ++ "' in class '" ++ className ++ "'"
|
_ -> error $ "Ambiguous reference to field '" ++ id ++ "' in class '" ++ className ++ "'"
|
||||||
Nothing -> error $ "Class '" ++ className ++ "' not found for 'this'"
|
Nothing -> error $ "Class '" ++ className ++ "' not found for 'this'"
|
||||||
Nothing -> error $ "Context for 'this' not found in symbol table, unable to resolve '" ++ id ++ "'"
|
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"
|
|
||||||
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"
|
|
||||||
|
|
||||||
typeCheckExpression (UnaryOperation op expr) symtab classes =
|
typeCheckExpression (UnaryOperation op expr) symtab classes =
|
||||||
let expr' = typeCheckExpression expr symtab classes
|
let expr' = typeCheckExpression expr symtab classes
|
||||||
@ -187,11 +89,50 @@ typeCheckExpression (UnaryOperation op expr) symtab classes =
|
|||||||
else
|
else
|
||||||
error "Logical NOT operation requires an operand of type boolean"
|
error "Logical NOT operation requires an operand of type boolean"
|
||||||
Minus ->
|
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"
|
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 "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
|
||||||
@ -329,7 +270,7 @@ typeCheckStatement (Return expr) symtab classes =
|
|||||||
Nothing -> Nothing
|
Nothing -> Nothing
|
||||||
in case expr' of
|
in case expr' of
|
||||||
Just e' -> TypedStatement (getTypeFromExpr e') (Return (Just e'))
|
Just e' -> TypedStatement (getTypeFromExpr e') (Return (Just e'))
|
||||||
Nothing -> TypedStatement "Void" (Return Nothing)
|
Nothing -> TypedStatement "void" (Return Nothing)
|
||||||
|
|
||||||
typeCheckStatement (StatementExpressionStatement stmtExpr) symtab classes =
|
typeCheckStatement (StatementExpressionStatement stmtExpr) symtab classes =
|
||||||
let stmtExpr' = typeCheckStatementExpression stmtExpr symtab classes
|
let stmtExpr' = typeCheckStatementExpression stmtExpr symtab classes
|
||||||
@ -359,3 +300,56 @@ lookupType id symtab =
|
|||||||
case lookup id symtab of
|
case lookup id symtab of
|
||||||
Just t -> Just t
|
Just t -> Just t
|
||||||
Nothing -> Nothing
|
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"
|
||||||
|
Loading…
Reference in New Issue
Block a user