Compare commits

..

12 Commits

4 changed files with 72 additions and 35 deletions

View File

@ -200,6 +200,9 @@ testExpressionSimpleFieldAccess = TestCase $
testExpressionFieldSubAccess = TestCase $
assertEqual "expect NameResolution without this" (BinaryOperation NameResolution (Reference "a") (Reference "b")) $
parseExpression [IDENTIFIER "a",DOT,IDENTIFIER "b"]
testExpressionConstructorCall = TestCase $
assertEqual "expect constructor call" (StatementExpressionExpression (ConstructorCall "Foo" [])) $
parseExpression [NEW,IDENTIFIER "Foo",LBRACE,RBRACE]
testStatementIfThen = TestCase $
assertEqual "expect empty ifthen" [If (Reference "a") (Block [Block []]) Nothing] $
@ -217,7 +220,16 @@ testStatementAssign = TestCase $
testStatementMethodCallNoParams = TestCase $
assertEqual "expect methodcall statement no params" [StatementExpressionStatement (MethodCall (Reference "this") "foo" [])] $
parseStatement [IDENTIFIER "foo",LBRACE,RBRACE,SEMICOLON]
testStatementConstructorCall = TestCase $
assertEqual "expect constructor call" [StatementExpressionStatement (ConstructorCall "Foo" [])] $
parseStatement [NEW,IDENTIFIER "Foo",LBRACE,RBRACE,SEMICOLON]
testStatementConstructorCallWithArgs = TestCase $
assertEqual "expect constructor call" [StatementExpressionStatement (ConstructorCall "Foo" [Reference "b"])] $
parseStatement [NEW,IDENTIFIER "Foo",LBRACE,IDENTIFIER "b",RBRACE,SEMICOLON]
testStatementPreIncrement = TestCase $
assertEqual "expect increment" [StatementExpressionStatement $ PostIncrement $ Reference "a"] $
parseStatement [IDENTIFIER "a",INCREMENT,SEMICOLON]
tests = TestList [
@ -279,9 +291,13 @@ tests = TestList [
testExpressionFieldAccess,
testExpressionSimpleFieldAccess,
testExpressionFieldSubAccess,
testExpressionConstructorCall,
testStatementIfThen,
testStatementIfThenElse,
testStatementWhile,
testStatementAssign,
testStatementMethodCallNoParams
testStatementMethodCallNoParams,
testStatementConstructorCall,
testStatementConstructorCallWithArgs,
testStatementPreIncrement
]

View File

@ -117,7 +117,7 @@ modifier : PUBLIC { }
| STATIC { }
| ABSTRACT { }
classtype : classorinterfacetype{ }
classtype : classorinterfacetype { $1 }
classbodydeclaration : classmemberdeclaration { $1 }
| constructordeclaration { $1 }
@ -249,12 +249,12 @@ assignment : lefthandside assignmentoperator assignmentexpression {
statementexpression : assignment { $1 }
-- | preincrementexpression { }
-- | predecrementexpression { }
-- | postincrementexpression { }
-- | postdecrementexpression { }
| preincrementexpression { $1 }
| predecrementexpression { $1 }
| postincrementexpression { $1 }
| postdecrementexpression { $1 }
| methodinvocation { $1 }
-- | classinstancecreationexpression { }
| classinstancecreationexpression { $1 }
ifthenelsestatementnoshortif :IF LBRACE expression RBRACE statementnoshortif
ELSE statementnoshortif { }
@ -292,8 +292,8 @@ methodinvocation : simplename LBRACE RBRACE { MethodCall (Reference "this") $
| primary DOT IDENTIFIER LBRACE RBRACE { MethodCall $1 $3 [] }
| primary DOT IDENTIFIER LBRACE argumentlist RBRACE { MethodCall $1 $3 $5 }
classinstancecreationexpression : NEW classtype LBRACE RBRACE { }
| NEW classtype LBRACE argumentlist RBRACE { }
classinstancecreationexpression : NEW classtype LBRACE RBRACE { ConstructorCall $2 [] }
| NEW classtype LBRACE argumentlist RBRACE { ConstructorCall $2 $4 }
conditionalandexpression : inclusiveorexpression { $1 }
@ -318,7 +318,7 @@ inclusiveorexpression : exclusiveorexpression { $1 }
primarynonewarray : literal { $1 }
| THIS { Reference "this" }
| LBRACE expression RBRACE { $2 }
-- | classinstancecreationexpression { }
| classinstancecreationexpression { StatementExpressionExpression $1 }
| fieldaccess { $1 }
| methodinvocation { StatementExpressionExpression $1 }

View File

@ -72,7 +72,7 @@ tokens :-
-- end keywords
$JavaLetter$JavaLetterOrDigit* { \s -> IDENTIFIER s }
-- Literals
[1-9]([0-9\_]*[0-9])* { \s -> case readMaybe $ filter ((/=) '_') s of Just a -> INTEGERLITERAL a; Nothing -> error ("failed to parse INTLITERAL " ++ s) }
[0-9]([0-9\_]*[0-9])* { \s -> case readMaybe $ filter ((/=) '_') s of Just a -> INTEGERLITERAL a; Nothing -> error ("failed to parse INTLITERAL " ++ s) }
"'"."'" { \s -> case (s) of _ : c : _ -> CHARLITERAL c; _ -> error ("failed to parse CHARLITERAL " ++ s) }
-- separators
"(" { \_ -> LBRACE }

View File

@ -19,15 +19,14 @@ typeCheckClass (Class className methods fields) classes =
typeCheckMethodDeclaration :: MethodDeclaration -> [(Identifier, DataType)] -> [Class] -> MethodDeclaration
typeCheckMethodDeclaration (MethodDeclaration retType name params body) classFields classes =
let
-- Combine class fields with method parameters to form the initial symbol table for the method
methodParams = [(identifier, dataType) | ParameterDeclaration dataType identifier <- params]
initialSymtab = classFields ++ methodParams
initialSymtab = ("thisMeth", retType) : classFields ++ methodParams
checkedBody = typeCheckStatement body initialSymtab classes
bodyType = getTypeFromStmt checkedBody
-- Check if the type of the body matches the declared return type
in if bodyType == retType || (bodyType == "void" && retType == "void") || (bodyType == "null" && isObjectType retType)
in if bodyType == retType || (bodyType == "void" && retType == "void") || (bodyType == "null" && isObjectType retType) || isSubtype bodyType retType classes
then MethodDeclaration retType name params checkedBody
else error $ "Return type mismatch in method " ++ name ++ ": expected " ++ retType ++ ", found " ++ bodyType
else error $ "Method Declaration: Return type mismatch in method " ++ name ++ ": expected " ++ retType ++ ", found " ++ bodyType
-- ********************************** Type Checking: Expressions **********************************
@ -37,6 +36,7 @@ typeCheckExpression (CharacterLiteral c) _ _ = TypedExpression "char" (Character
typeCheckExpression (BooleanLiteral b) _ _ = TypedExpression "boolean" (BooleanLiteral b)
typeCheckExpression NullLiteral _ _ = TypedExpression "null" NullLiteral
typeCheckExpression (Reference id) symtab classes =
-- TODO: maybe maje exception for "this" in first lookup?
case lookup id symtab of
Just t -> TypedExpression t (LocalVariable id)
Nothing ->
@ -118,7 +118,7 @@ typeCheckStatementExpression (ConstructorCall className args) symtab classes =
Nothing -> error $ "Class '" ++ className ++ "' not found."
Just (Class _ methods fields) ->
-- Constructor needs the same name as the class
case find (\(MethodDeclaration retType name params _) -> name == className && retType == className) methods of
case find (\(MethodDeclaration retType name params _) -> name == "<init>" && retType == "void") methods of
Nothing -> error $ "No valid constructor found for class '" ++ className ++ "'."
Just (MethodDeclaration _ _ params _) ->
let
@ -203,16 +203,22 @@ typeCheckStatementExpression (PreDecrement expr) symtab classes =
typeCheckStatement :: Statement -> [(Identifier, DataType)] -> [Class] -> Statement
typeCheckStatement (If cond thenStmt elseStmt) symtab classes =
let cond' = typeCheckExpression cond symtab classes
let
cond' = typeCheckExpression cond symtab classes
thenStmt' = typeCheckStatement thenStmt symtab classes
elseStmt' = case elseStmt of
Just stmt -> Just (typeCheckStatement stmt symtab classes)
Nothing -> Nothing
elseStmt' = fmap (\stmt -> typeCheckStatement stmt symtab classes) elseStmt
thenType = getTypeFromStmt thenStmt'
elseType = maybe "void" getTypeFromStmt elseStmt'
ifType = if thenType == "void" || elseType == "void"
then "void"
else unifyReturnTypes thenType elseType
in if getTypeFromExpr cond' == "boolean"
then
TypedStatement (getTypeFromStmt thenStmt') (If cond' thenStmt' elseStmt')
else
error "If condition must be of type boolean"
then TypedStatement ifType (If cond' thenStmt' elseStmt')
else error "If condition must be of type boolean"
typeCheckStatement (LocalVariableDeclaration (VariableDeclaration dataType identifier maybeExpr)) symtab classes =
-- Check for redefinition in the current scope
@ -267,12 +273,14 @@ typeCheckStatement (Block statements) symtab classes =
in TypedStatement blockType (Block checkedStatements)
typeCheckStatement (Return expr) symtab classes =
let expr' = case expr of
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)
Nothing -> Nothing
in case expr' of
Just e' -> TypedStatement (getTypeFromExpr e') (Return (Just e'))
Nothing -> TypedStatement "void" (Return 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
@ -280,6 +288,17 @@ typeCheckStatement (StatementExpressionStatement stmtExpr) symtab classes =
-- ********************************** Type Checking: Helpers **********************************
isSubtype :: DataType -> DataType -> [Class] -> Bool
isSubtype subType superType classes
| subType == superType = True
| subType == "null" && isObjectType superType = True
| superType == "Object" && isObjectType subType = True
| superType == "Object" && isUserDefinedClass subType classes = True
| otherwise = False
isUserDefinedClass :: DataType -> [Class] -> Bool
isUserDefinedClass dt classes = dt `elem` map (\(Class name _ _) -> name) classes
isObjectType :: DataType -> Bool
isObjectType dt = dt /= "int" && dt /= "boolean" && dt /= "char"
@ -298,6 +317,8 @@ getTypeFromStmtExpr _ = error "Untyped statement expression found where typed wa
unifyReturnTypes :: DataType -> DataType -> DataType
unifyReturnTypes dt1 dt2
| dt1 == dt2 = dt1
| dt1 == "null" = dt2
| dt2 == "null" = dt1
| otherwise = "Object"
resolveResultType :: DataType -> DataType -> DataType
@ -319,7 +340,7 @@ checkBitwiseOperation :: BinaryOperator -> Expression -> Expression -> DataType
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"
| otherwise = error $ "Bitwise operation " ++ show op ++ " requires operands of type int or char"
checkComparisonOperation :: BinaryOperator -> Expression -> Expression -> DataType -> DataType -> Expression
checkComparisonOperation op expr1' expr2' type1 type2