Compare commits

...

12 Commits

4 changed files with 72 additions and 35 deletions

View File

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

View File

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

View File

@ -72,7 +72,7 @@ tokens :-
-- end keywords -- end keywords
$JavaLetter$JavaLetterOrDigit* { \s -> IDENTIFIER s } $JavaLetter$JavaLetterOrDigit* { \s -> IDENTIFIER s }
-- Literals -- 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) } "'"."'" { \s -> case (s) of _ : c : _ -> CHARLITERAL c; _ -> error ("failed to parse CHARLITERAL " ++ s) }
-- separators -- separators
"(" { \_ -> LBRACE } "(" { \_ -> LBRACE }

View File

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