bytecode #9

Merged
mrab merged 18 commits from bytecode into master 2024-07-01 15:05:31 +00:00
3 changed files with 82 additions and 41 deletions
Showing only changes of commit fe4ef2614f - Show all commits

View File

@ -0,0 +1,13 @@
public class TestConstructorOverload {
TestConstructorOverload() {
}
TestConstructorOverload(int a) {
}
public void test() {
int a = 3;
TestConstructorOverload test = new TestConstructorOverload(a);
}
}

View File

@ -0,0 +1,15 @@
public class TestSingleton {
TestSingleton instance;
TestSingleton() {
}
public TestSingleton getInstance() {
if (instance == null) {
instance = new TestSingleton();
}
return instance;
}
}

View File

@ -3,18 +3,35 @@ import Data.List (find)
import Data.Maybe import Data.Maybe
import Ast import Ast
typeCheckCompilationUnit :: CompilationUnit -> CompilationUnit typeCheckCompilationUnit :: CompilationUnit -> CompilationUnit
typeCheckCompilationUnit classes = map (`typeCheckClass` classes) classes typeCheckCompilationUnit classes = map (`typeCheckClass` classes) classes
typeCheckClass :: Class -> [Class] -> Class typeCheckClass :: Class -> [Class] -> Class
typeCheckClass (Class className methods fields) classes = typeCheckClass (Class className constructors methods fields) classes =
let let
-- Fields and methods dont need to be added to the symtab because they are looked upon automatically under "this" -- Fields and methods dont need to be added to the symtab because they are looked upon automatically under "this"
-- if its not a declared local variable. Also shadowing wouldnt be possible then. -- if its not a declared local variable. Also shadowing wouldnt be possible then.
initalSymTab = [("this", className)] initalSymTab = [("this", className)]
checkedConstructors = map (\constructor -> typeCheckConstructorDeclaration constructor initalSymTab classes) constructors
checkedMethods = map (\method -> typeCheckMethodDeclaration method initalSymTab classes) methods checkedMethods = map (\method -> typeCheckMethodDeclaration method initalSymTab classes) methods
checkedFields = map (\field -> typeCheckVariableDeclaration field initalSymTab classes) fields checkedFields = map (\field -> typeCheckVariableDeclaration field initalSymTab classes) fields
in Class className checkedMethods checkedFields in Class className checkedConstructors checkedMethods checkedFields
typeCheckConstructorDeclaration :: ConstructorDeclaration -> [(Identifier, DataType)] -> [Class] -> ConstructorDeclaration
typeCheckConstructorDeclaration (ConstructorDeclaration name params body) symtab classes =
let
constructorParams = [(identifier, dataType) | ParameterDeclaration dataType identifier <- params]
initialSymtab = symtab ++ constructorParams
className = fromMaybe (error "Constructor Declaration: 'this' not found in symtab") (lookup "this" symtab)
checkedBody = typeCheckStatement body initialSymtab classes
bodyType = getTypeFromStmt checkedBody
in if name == className
then if bodyType == "void"
then ConstructorDeclaration name params checkedBody
else error $ "Constructor Declaration: Return type mismatch in constructor " ++ name ++ ": expected void, found " ++ bodyType
else error $ "Constructor Declaration: Constructor name " ++ name ++ " does not match class name " ++ className
typeCheckMethodDeclaration :: MethodDeclaration -> [(Identifier, DataType)] -> [Class] -> MethodDeclaration typeCheckMethodDeclaration :: MethodDeclaration -> [(Identifier, DataType)] -> [Class] -> MethodDeclaration
typeCheckMethodDeclaration (MethodDeclaration retType name params body) symtab classes = typeCheckMethodDeclaration (MethodDeclaration retType name params body) symtab classes =
@ -63,9 +80,9 @@ typeCheckExpression (Reference id) symtab classes =
Nothing -> Nothing ->
case lookup "this" symtab of case lookup "this" symtab of
Just className -> Just className ->
let classDetails = find (\(Class name _ _) -> name == className) classes let classDetails = find (\(Class name _ _ _) -> name == className) classes
in case classDetails of in case classDetails of
Just (Class _ _ fields) -> Just (Class _ _ _ fields) ->
let fieldTypes = [dt | VariableDeclaration dt fieldId _ <- fields, fieldId == id] let fieldTypes = [dt | VariableDeclaration dt fieldId _ <- fields, fieldId == id]
-- this case only happens when its a field of its own class so the implicit this will be converted to explicit this -- this case only happens when its a field of its own class so the implicit this will be converted to explicit this
in case fieldTypes of in case fieldTypes of
@ -139,40 +156,36 @@ typeCheckStatementExpression (Assignment ref expr) symtab classes =
typeCheckStatementExpression (ConstructorCall className args) symtab classes = typeCheckStatementExpression (ConstructorCall className args) symtab classes =
case find (\(Class name _ _) -> name == className) classes of case find (\(Class name _ _ _) -> name == className) classes of
Nothing -> error $ "Class '" ++ className ++ "' not found." Nothing -> error $ "Class '" ++ className ++ "' not found."
Just (Class _ methods _) -> Just (Class _ constructors _ _) ->
-- Find constructor matching the class name with void return type let
case find (\(MethodDeclaration _ name params _) -> name == "<init>") methods of matchParams (ParameterDeclaration paramType _) arg =
-- If no constructor is found, assume standard constructor with no parameters
Nothing ->
if null args then
TypedStatementExpression className (ConstructorCall className args)
else
error $ "No valid constructor found for class '" ++ className ++ "', but arguments were provided."
Just (MethodDeclaration _ _ params _) ->
let args' = zipWith
(\arg (ParameterDeclaration paramType _) ->
let argTyped = typeCheckExpression arg symtab classes let argTyped = typeCheckExpression arg symtab classes
in if getTypeFromExpr argTyped == "null" && isObjectType paramType argType = getTypeFromExpr argTyped
then TypedExpression paramType NullLiteral in if argType == "null" && isObjectType paramType
else argTyped then Just (TypedExpression paramType NullLiteral)
) args params else if argType == paramType
expectedTypes = [dataType | ParameterDeclaration dataType _ <- params] then Just argTyped
argTypes = map getTypeFromExpr args' else Nothing
typeMatches = zipWith
(\expType argType -> (expType == argType || (argType == "null" && isObjectType expType), expType, argType)) matchConstructor (ConstructorDeclaration name params _) =
expectedTypes argTypes let matchedArgs = sequence $ zipWith matchParams params args
mismatches = filter (not . fst3) typeMatches in fmap (\checkedArgs -> (params, checkedArgs)) matchedArgs
fst3 (a, _, _) = a
in validConstructors = filter (\(params, _) -> length params == length args) $ mapMaybe matchConstructor constructors
if null mismatches && length args == length params then
TypedStatementExpression className (ConstructorCall className args') expectedSignatures = [ map (\(ParameterDeclaration t _) -> t) params | ConstructorDeclaration _ params _ <- constructors ]
else if not (null mismatches) then actualSignature = map (\arg -> getTypeFromExpr (typeCheckExpression arg symtab classes)) args
error $ unlines $ ("Type mismatch in constructor arguments for class '" ++ className ++ "':") mismatchDetails = "Constructor not found for class '" ++ className ++ "' with given arguments.\n" ++
: [ "Expected: " ++ expType ++ ", Found: " ++ argType | (_, expType, argType) <- mismatches ] "Expected signatures:\n" ++ show expectedSignatures ++
else "\nActual arguments:" ++ show actualSignature
error $ "Incorrect number of arguments for constructor of class '" ++ className ++ "'. Expected " ++ show (length expectedTypes) ++ ", found " ++ show (length args) ++ "."
in case validConstructors of
[(_, checkedArgs)] ->
TypedStatementExpression className (ConstructorCall className checkedArgs)
[] -> error mismatchDetails
_ -> error $ "Multiple matching constructors found for class '" ++ className ++ "' with given arguments."
typeCheckStatementExpression (MethodCall expr methodName args) symtab classes = typeCheckStatementExpression (MethodCall expr methodName args) symtab classes =
let objExprTyped = typeCheckExpression expr symtab classes let objExprTyped = typeCheckExpression expr symtab classes
@ -359,7 +372,7 @@ isSubtype subType superType classes
| otherwise = False | otherwise = False
isUserDefinedClass :: DataType -> [Class] -> Bool isUserDefinedClass :: DataType -> [Class] -> Bool
isUserDefinedClass dt classes = dt `elem` map (\(Class name _ _) -> name) classes 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"
@ -431,8 +444,8 @@ resolveNameResolution :: Expression -> Expression -> [(Identifier, DataType)] ->
resolveNameResolution expr1' (Reference ident2) symtab classes = resolveNameResolution expr1' (Reference ident2) symtab classes =
case getTypeFromExpr expr1' of case getTypeFromExpr expr1' of
objType -> objType ->
case find (\(Class className _ _) -> className == objType) classes of case find (\(Class className _ _ _) -> className == objType) classes of
Just (Class _ _ fields) -> Just (Class _ _ _ fields) ->
let fieldTypes = [dt | VariableDeclaration dt id _ <- fields, id == ident2] let fieldTypes = [dt | VariableDeclaration dt id _ <- fields, id == ident2]
in case fieldTypes of in case fieldTypes of
[resolvedType] -> TypedExpression resolvedType (BinaryOperation NameResolution expr1' (TypedExpression resolvedType (FieldVariable ident2))) [resolvedType] -> TypedExpression resolvedType (BinaryOperation NameResolution expr1' (TypedExpression resolvedType (FieldVariable ident2)))