fix nullliterals having the type null instead of their corresponding object types
This commit is contained in:
Maybe Fabian Noll aber vielleicht auch nicht. Ist ein bisschen ne Glaubenssache :)
parent
8a6dca4e36
commit
bcbec9209a
@ -37,14 +37,18 @@ typeCheckVariableDeclaration (VariableDeclaration dataType identifier maybeExpr)
|
||||
-- Type check the initializer expression if it exists
|
||||
checkedExpr = fmap (\expr -> typeCheckExpression expr symtab classes) maybeExpr
|
||||
exprType = fmap getTypeFromExpr checkedExpr
|
||||
checkedExprWithType = case exprType of
|
||||
Just "null" | isObjectType dataType -> Just (TypedExpression dataType NullLiteral)
|
||||
_ -> checkedExpr
|
||||
in case (validType, redefined, exprType) of
|
||||
(False, _, _) -> error $ "Type '" ++ dataType ++ "' is not a valid type for variable '" ++ identifier ++ "'"
|
||||
(_, True, _) -> error $ "Variable '" ++ identifier ++ "' is redefined in the same scope"
|
||||
(_, _, Just t)
|
||||
| t == "null" && isObjectType dataType -> VariableDeclaration dataType identifier checkedExpr
|
||||
| t == "null" && isObjectType dataType -> VariableDeclaration dataType identifier checkedExprWithType
|
||||
| t /= dataType -> error $ "Type mismatch in declaration of '" ++ identifier ++ "': expected " ++ dataType ++ ", found " ++ t
|
||||
| otherwise -> VariableDeclaration dataType identifier checkedExpr
|
||||
(_, _, Nothing) -> VariableDeclaration dataType identifier checkedExpr
|
||||
| otherwise -> VariableDeclaration dataType identifier checkedExprWithType
|
||||
(_, _, Nothing) -> VariableDeclaration dataType identifier checkedExprWithType
|
||||
|
||||
|
||||
-- ********************************** Type Checking: Expressions **********************************
|
||||
|
||||
@ -125,11 +129,14 @@ typeCheckStatementExpression (Assignment ref expr) symtab classes =
|
||||
ref' = typeCheckExpression ref symtab classes
|
||||
type' = getTypeFromExpr expr'
|
||||
type'' = getTypeFromExpr ref'
|
||||
typeToAssign = if type' == "null" && isObjectType type'' then type'' else type'
|
||||
exprWithType = if type' == "null" && isObjectType type'' then TypedExpression type'' NullLiteral else expr'
|
||||
in
|
||||
if type'' == type' || (type' == "null" && isObjectType type'') then
|
||||
TypedStatementExpression type'' (Assignment ref' expr')
|
||||
if type'' == typeToAssign then
|
||||
TypedStatementExpression type'' (Assignment ref' exprWithType)
|
||||
else
|
||||
error $ "Type mismatch in assignment to variable: expected " ++ type'' ++ ", found " ++ type'
|
||||
error $ "Type mismatch in assignment to variable: expected " ++ type'' ++ ", found " ++ typeToAssign
|
||||
|
||||
|
||||
typeCheckStatementExpression (ConstructorCall className args) symtab classes =
|
||||
case find (\(Class name _ _) -> name == className) classes of
|
||||
@ -168,25 +175,30 @@ typeCheckStatementExpression (MethodCall expr methodName args) symtab classes =
|
||||
Just (Class _ methods _) ->
|
||||
case find (\(MethodDeclaration retType name params _) -> name == methodName) methods of
|
||||
Just (MethodDeclaration retType _ params _) ->
|
||||
let args' = map (\arg -> typeCheckExpression arg symtab classes) args
|
||||
let args' = zipWith
|
||||
(\arg (ParameterDeclaration paramType _) ->
|
||||
let argTyped = typeCheckExpression arg symtab classes
|
||||
in if getTypeFromExpr argTyped == "null" && isObjectType paramType
|
||||
then TypedExpression paramType NullLiteral
|
||||
else argTyped
|
||||
) args params
|
||||
expectedTypes = [dataType | ParameterDeclaration dataType _ <- params]
|
||||
argTypes = map getTypeFromExpr args'
|
||||
typeMatches = zipWith (\expType argType -> (expType == argType || (argType == "null" && isObjectType expType), expType, argType)) expectedTypes argTypes
|
||||
typeMatches = zipWith
|
||||
(\expType argType -> (expType == argType || (argType == "null" && isObjectType expType), expType, argType))
|
||||
expectedTypes argTypes
|
||||
mismatches = filter (not . fst3) typeMatches
|
||||
where fst3 (a, _, _) = a
|
||||
in
|
||||
if null mismatches && length args == length params then
|
||||
TypedStatementExpression retType (MethodCall objExprTyped methodName args')
|
||||
else if not (null mismatches) then
|
||||
error $ unlines $ ("Argument type mismatches for method '" ++ methodName ++ "':")
|
||||
fst3 (a, _, _) = a
|
||||
in if null mismatches && length args == length params
|
||||
then TypedStatementExpression retType (MethodCall objExprTyped methodName args')
|
||||
else if not (null mismatches)
|
||||
then error $ unlines $ ("Argument type mismatches for method '" ++ methodName ++ "':")
|
||||
: [ "Expected: " ++ expType ++ ", Found: " ++ argType | (_, expType, argType) <- mismatches ]
|
||||
else
|
||||
error $ "Incorrect number of arguments for method '" ++ methodName ++ "'. Expected " ++ show (length expectedTypes) ++ ", found " ++ show (length args) ++ "."
|
||||
else error $ "Incorrect number of arguments for method '" ++ methodName ++ "'. Expected " ++ show (length expectedTypes) ++ ", found " ++ show (length args) ++ "."
|
||||
Nothing -> error $ "Method '" ++ methodName ++ "' not found in class '" ++ objType ++ "'."
|
||||
Nothing -> error $ "Class for object type '" ++ objType ++ "' not found."
|
||||
_ -> error "Invalid object type for method call. Object must have a class type."
|
||||
|
||||
|
||||
|
||||
typeCheckStatementExpression (PostIncrement expr) symtab classes =
|
||||
let expr' = typeCheckExpression expr symtab classes
|
||||
type' = getTypeFromExpr expr'
|
||||
@ -252,14 +264,18 @@ typeCheckStatement (LocalVariableDeclaration (VariableDeclaration dataType ident
|
||||
-- If there's an initializer expression, type check it
|
||||
let checkedExpr = fmap (\expr -> typeCheckExpression expr symtab classes) maybeExpr
|
||||
exprType = fmap getTypeFromExpr checkedExpr
|
||||
checkedExprWithType = case (exprType, dataType) of
|
||||
(Just "null", _) | isObjectType dataType -> Just (TypedExpression dataType NullLiteral)
|
||||
_ -> checkedExpr
|
||||
in case exprType of
|
||||
Just t
|
||||
| t == "null" && isObjectType dataType ->
|
||||
TypedStatement dataType (LocalVariableDeclaration (VariableDeclaration dataType identifier checkedExpr))
|
||||
TypedStatement dataType (LocalVariableDeclaration (VariableDeclaration dataType identifier checkedExprWithType))
|
||||
| t /= dataType -> error $ "Type mismatch in declaration of '" ++ identifier ++ "': expected " ++ dataType ++ ", found " ++ t
|
||||
| otherwise -> TypedStatement dataType (LocalVariableDeclaration (VariableDeclaration dataType identifier checkedExpr))
|
||||
| otherwise -> TypedStatement dataType (LocalVariableDeclaration (VariableDeclaration dataType identifier checkedExprWithType))
|
||||
Nothing -> TypedStatement dataType (LocalVariableDeclaration (VariableDeclaration dataType identifier checkedExpr))
|
||||
|
||||
|
||||
typeCheckStatement (While cond stmt) symtab classes =
|
||||
let cond' = typeCheckExpression cond symtab classes
|
||||
stmt' = typeCheckStatement stmt symtab classes
|
||||
@ -306,13 +322,17 @@ typeCheckStatement (Block statements) symtab classes =
|
||||
typeCheckStatement (Return expr) symtab classes =
|
||||
let methodReturnType = fromMaybe (error "Method return type not found in symbol table") (lookup "thisMeth" symtab)
|
||||
expr' = case expr of
|
||||
Just e -> Just (typeCheckExpression e symtab classes)
|
||||
Just e -> let eTyped = typeCheckExpression e symtab classes
|
||||
in if getTypeFromExpr eTyped == "null" && isObjectType methodReturnType
|
||||
then Just (TypedExpression methodReturnType NullLiteral)
|
||||
else Just eTyped
|
||||
Nothing -> Nothing
|
||||
returnType = maybe "void" getTypeFromExpr expr'
|
||||
in if returnType == methodReturnType || isSubtype returnType methodReturnType classes
|
||||
then TypedStatement returnType (Return expr')
|
||||
else error $ "Return: Return type mismatch: expected " ++ methodReturnType ++ ", found " ++ returnType
|
||||
|
||||
|
||||
typeCheckStatement (StatementExpressionStatement stmtExpr) symtab classes =
|
||||
let stmtExpr' = typeCheckStatementExpression stmtExpr symtab classes
|
||||
in TypedStatement (getTypeFromStmtExpr stmtExpr') (StatementExpressionStatement stmtExpr')
|
||||
|
||||
Loading…
Reference in New Issue
Block a user