Merge branch 'typedAST' of ssh://gitea.hb.dhbw-stuttgart.de:2222/MisterChaos69/MiniJavaCompiler into bytecode
This commit is contained in:
mrab
commit
93702071fb
@ -22,7 +22,7 @@ data Statement
|
||||
data StatementExpression
|
||||
= Assignment Identifier Expression
|
||||
| ConstructorCall DataType [Expression]
|
||||
| MethodCall Identifier [Expression]
|
||||
| MethodCall Expression Identifier [Expression]
|
||||
| TypedStatementExpression DataType StatementExpression
|
||||
deriving (Show, Eq)
|
||||
|
||||
@ -56,6 +56,8 @@ data Expression
|
||||
| BooleanLiteral Bool
|
||||
| NullLiteral
|
||||
| Reference Identifier
|
||||
| LocalVariable Identifier
|
||||
| FieldVariable Identifier
|
||||
| BinaryOperation BinaryOperator Expression Expression
|
||||
| UnaryOperation UnaryOperator Expression
|
||||
| StatementExpressionExpression StatementExpression
|
||||
|
||||
203
src/Example.hs
203
src/Example.hs
@ -1,50 +1,203 @@
|
||||
module Example where
|
||||
|
||||
import Ast
|
||||
import Typecheck
|
||||
import Control.Exception (catch, evaluate, SomeException, displayException)
|
||||
import Control.Exception.Base
|
||||
import Typecheck
|
||||
import System.IO (stderr, hPutStrLn)
|
||||
import Data.Maybe
|
||||
import Data.List
|
||||
|
||||
green, red, yellow, blue, magenta, cyan, white :: String -> String
|
||||
green str = "\x1b[32m" ++ str ++ "\x1b[0m"
|
||||
red str = "\x1b[31m" ++ str ++ "\x1b[0m"
|
||||
yellow str = "\x1b[33m" ++ str ++ "\x1b[0m"
|
||||
blue str = "\x1b[34m" ++ str ++ "\x1b[0m"
|
||||
magenta str = "\x1b[35m" ++ str ++ "\x1b[0m"
|
||||
cyan str = "\x1b[36m" ++ str ++ "\x1b[0m"
|
||||
white str = "\x1b[37m" ++ str ++ "\x1b[0m"
|
||||
|
||||
printSuccess :: String -> IO ()
|
||||
printSuccess msg = putStrLn $ green "Success:" ++ white msg
|
||||
|
||||
handleError :: SomeException -> IO ()
|
||||
handleError e = hPutStrLn stderr $ red ("Error: " ++ displayException e)
|
||||
|
||||
printResult :: Show a => String -> a -> IO ()
|
||||
printResult title result = do
|
||||
putStrLn $ green title
|
||||
print result
|
||||
|
||||
-- Example classes and their methods and fields
|
||||
sampleClasses :: [Class]
|
||||
sampleClasses = [
|
||||
Class "Person" [
|
||||
MethodDeclaration "void" "setAge" [ParameterDeclaration "Int" "newAge"]
|
||||
MethodDeclaration "void" "setAge" [ParameterDeclaration "int" "newAge"]
|
||||
(Block [
|
||||
LocalVariableDeclaration (VariableDeclaration "Int" "age" (Just (Reference "newAge")))
|
||||
LocalVariableDeclaration (VariableDeclaration "int" "age" (Just (Reference "newAge")))
|
||||
]),
|
||||
MethodDeclaration "Int" "getAge" [] (Return (Just (Reference "age")))
|
||||
MethodDeclaration "int" "getAge" [] (Return (Just (Reference "age"))),
|
||||
MethodDeclaration "Person" "Person" [ParameterDeclaration "int" "initialAge"] (Block [])
|
||||
] [
|
||||
VariableDeclaration "Int" "age" (Just (IntegerLiteral 25)),
|
||||
VariableDeclaration "String" "name" (Just (CharacterLiteral 'A'))
|
||||
VariableDeclaration "int" "age" (Just (IntegerLiteral 25))
|
||||
]
|
||||
]
|
||||
|
||||
-- Symbol table, mapping identifiers to their data types
|
||||
initialSymtab :: [(DataType, Identifier)]
|
||||
initialSymtab = []
|
||||
|
||||
-- An example block of statements to type check
|
||||
exampleBlock :: Statement
|
||||
exampleBlock = Block [
|
||||
LocalVariableDeclaration (VariableDeclaration "Person" "bob" (Just (StatementExpressionExpression (ConstructorCall "Person" [])))),
|
||||
StatementExpressionStatement (MethodCall "setAge" [IntegerLiteral 30]),
|
||||
Return (Just (StatementExpressionExpression (MethodCall "getAge" [])))
|
||||
]
|
||||
|
||||
exampleExpression :: Expression
|
||||
exampleExpression = BinaryOperation NameResolution (Reference "bob") (Reference "age")
|
||||
|
||||
-- Function to perform type checking and handle errors
|
||||
exampleAssignment :: Expression
|
||||
exampleAssignment = StatementExpressionExpression (Assignment "a" (IntegerLiteral 30))
|
||||
|
||||
exampleMethodCall :: Statement
|
||||
exampleMethodCall = StatementExpressionStatement (MethodCall (Reference "this") "setAge" [IntegerLiteral 30])
|
||||
|
||||
exampleConstructorCall :: Statement
|
||||
exampleConstructorCall = LocalVariableDeclaration (VariableDeclaration "Person" "bob" (Just (StatementExpressionExpression (ConstructorCall "Person" [IntegerLiteral 30]))))
|
||||
|
||||
exampleNameResolution :: Expression
|
||||
exampleNameResolution = BinaryOperation NameResolution (Reference "b") (Reference "age")
|
||||
|
||||
exampleBlockResolution :: Statement
|
||||
exampleBlockResolution = Block [
|
||||
LocalVariableDeclaration (VariableDeclaration "Person" "bob" (Just (StatementExpressionExpression (ConstructorCall "Person" [IntegerLiteral 30])))),
|
||||
LocalVariableDeclaration (VariableDeclaration "int" "age" (Just (StatementExpressionExpression (MethodCall (Reference "bob") "getAge" [])))),
|
||||
StatementExpressionStatement (MethodCall (Reference "bob") "setAge" [IntegerLiteral 30])
|
||||
]
|
||||
|
||||
exampleBlockResolutionFail :: Statement
|
||||
exampleBlockResolutionFail = Block [
|
||||
LocalVariableDeclaration (VariableDeclaration "Person" "bob" (Just (StatementExpressionExpression (ConstructorCall "Person" [IntegerLiteral 30])))),
|
||||
LocalVariableDeclaration (VariableDeclaration "bool" "age" (Just (StatementExpressionExpression (MethodCall (Reference "bob") "getAge" [])))),
|
||||
StatementExpressionStatement (MethodCall (Reference "bob") "setAge" [IntegerLiteral 30])
|
||||
]
|
||||
|
||||
exampleMethodCallAndAssignment :: Statement
|
||||
exampleMethodCallAndAssignment = Block [
|
||||
LocalVariableDeclaration (VariableDeclaration "Person" "bob" (Just (StatementExpressionExpression (ConstructorCall "Person" [IntegerLiteral 30])))),
|
||||
LocalVariableDeclaration (VariableDeclaration "int" "age" (Just (StatementExpressionExpression (MethodCall (Reference "bob") "getAge" [])))),
|
||||
StatementExpressionStatement (MethodCall (Reference "bob") "setAge" [IntegerLiteral 30]),
|
||||
LocalVariableDeclaration (VariableDeclaration "int" "a" Nothing),
|
||||
StatementExpressionStatement (Assignment "a" (Reference "age"))
|
||||
]
|
||||
|
||||
|
||||
exampleMethodCallAndAssignmentFail :: Statement
|
||||
exampleMethodCallAndAssignmentFail = Block [
|
||||
LocalVariableDeclaration (VariableDeclaration "Person" "bob" (Just (StatementExpressionExpression (ConstructorCall "Person" [IntegerLiteral 30])))),
|
||||
LocalVariableDeclaration (VariableDeclaration "int" "age" (Just (StatementExpressionExpression (MethodCall (Reference "bob") "getAge" [])))),
|
||||
StatementExpressionStatement (MethodCall (Reference "bob") "setAge" [IntegerLiteral 30]),
|
||||
StatementExpressionStatement (Assignment "a" (Reference "age"))
|
||||
]
|
||||
|
||||
testClasses :: [Class]
|
||||
testClasses = [
|
||||
Class "Person" [
|
||||
MethodDeclaration "Person" "Person" [ParameterDeclaration "int" "initialAge"]
|
||||
(Block [
|
||||
Return (Just (Reference "this"))
|
||||
]),
|
||||
MethodDeclaration "void" "setAge" [ParameterDeclaration "int" "newAge"]
|
||||
(Block [
|
||||
LocalVariableDeclaration (VariableDeclaration "int" "age" (Just (Reference "newAge")))
|
||||
]),
|
||||
MethodDeclaration "int" "getAge" []
|
||||
(Return (Just (Reference "age")))
|
||||
] [
|
||||
VariableDeclaration "int" "age" Nothing -- initially unassigned
|
||||
],
|
||||
Class "Main" [
|
||||
MethodDeclaration "int" "main" []
|
||||
(Block [
|
||||
LocalVariableDeclaration (VariableDeclaration "Person" "bob" (Just (StatementExpressionExpression (ConstructorCall "Person" [IntegerLiteral 25])))),
|
||||
StatementExpressionStatement (MethodCall (Reference "bob") "setAge" [IntegerLiteral 30]),
|
||||
LocalVariableDeclaration (VariableDeclaration "int" "bobAge" (Just (StatementExpressionExpression (MethodCall (Reference "bob") "getAge" [])))),
|
||||
Return (Just (Reference "bobAge"))
|
||||
])
|
||||
] []
|
||||
]
|
||||
|
||||
runTypeCheck :: IO ()
|
||||
runTypeCheck = do
|
||||
-- Evaluate the block of statements
|
||||
--evaluatedBlock <- evaluate (typeCheckStatement exampleBlock initialSymtab sampleClasses)
|
||||
--putStrLn "Type checking of block completed successfully:"
|
||||
--print evaluatedBlock
|
||||
catch (do
|
||||
print "====================================================================================="
|
||||
evaluatedExpression <- evaluate (typeCheckExpression exampleExpression [("bob", "Person")] sampleClasses)
|
||||
printSuccess "Type checking of expression completed successfully"
|
||||
printResult "Result Expression:" evaluatedExpression
|
||||
) handleError
|
||||
|
||||
-- Evaluate the expression
|
||||
evaluatedExpression <- evaluate (typeCheckExpression exampleExpression [("bob", "Person"), ("age", "int")] sampleClasses)
|
||||
putStrLn "Type checking of expression completed successfully:"
|
||||
print evaluatedExpression
|
||||
catch (do
|
||||
print "====================================================================================="
|
||||
evaluatedAssignment <- evaluate (typeCheckExpression exampleAssignment [("a", "int")] sampleClasses)
|
||||
printSuccess "Type checking of assignment completed successfully"
|
||||
printResult "Result Assignment:" evaluatedAssignment
|
||||
) handleError
|
||||
|
||||
catch (do
|
||||
print "====================================================================================="
|
||||
evaluatedMethodCall <- evaluate (typeCheckStatement exampleMethodCall [("this", "Person"), ("setAge", "Person"), ("getAge", "Person")] sampleClasses)
|
||||
printSuccess "Type checking of method call this completed successfully"
|
||||
printResult "Result MethodCall:" evaluatedMethodCall
|
||||
) handleError
|
||||
|
||||
catch (do
|
||||
print "====================================================================================="
|
||||
evaluatedConstructorCall <- evaluate (typeCheckStatement exampleConstructorCall [] sampleClasses)
|
||||
printSuccess "Type checking of constructor call completed successfully"
|
||||
printResult "Result Constructor Call:" evaluatedConstructorCall
|
||||
) handleError
|
||||
|
||||
catch (do
|
||||
print "====================================================================================="
|
||||
evaluatedNameResolution <- evaluate (typeCheckExpression exampleNameResolution [("b", "Person")] sampleClasses)
|
||||
printSuccess "Type checking of name resolution completed successfully"
|
||||
printResult "Result Name Resolution:" evaluatedNameResolution
|
||||
) handleError
|
||||
|
||||
catch (do
|
||||
print "====================================================================================="
|
||||
evaluatedBlockResolution <- evaluate (typeCheckStatement exampleBlockResolution [] sampleClasses)
|
||||
printSuccess "Type checking of block resolution completed successfully"
|
||||
printResult "Result Block Resolution:" evaluatedBlockResolution
|
||||
) handleError
|
||||
|
||||
catch (do
|
||||
print "====================================================================================="
|
||||
evaluatedBlockResolutionFail <- evaluate (typeCheckStatement exampleBlockResolutionFail [] sampleClasses)
|
||||
printSuccess "Type checking of block resolution failed"
|
||||
printResult "Result Block Resolution:" evaluatedBlockResolutionFail
|
||||
) handleError
|
||||
|
||||
catch (do
|
||||
print "====================================================================================="
|
||||
evaluatedMethodCallAndAssignment <- evaluate (typeCheckStatement exampleMethodCallAndAssignment [] sampleClasses)
|
||||
printSuccess "Type checking of method call and assignment completed successfully"
|
||||
printResult "Result Method Call and Assignment:" evaluatedMethodCallAndAssignment
|
||||
) handleError
|
||||
|
||||
catch (do
|
||||
print "====================================================================================="
|
||||
evaluatedMethodCallAndAssignmentFail <- evaluate (typeCheckStatement exampleMethodCallAndAssignmentFail [] sampleClasses)
|
||||
printSuccess "Type checking of method call and assignment failed"
|
||||
printResult "Result Method Call and Assignment:" evaluatedMethodCallAndAssignmentFail
|
||||
) handleError
|
||||
|
||||
catch (do
|
||||
print "====================================================================================="
|
||||
let mainClass = fromJust $ find (\(Class className _ _) -> className == "Main") testClasses
|
||||
case mainClass of
|
||||
Class _ [mainMethod] _ -> do
|
||||
let result = typeCheckMethodDeclaration mainMethod [] testClasses
|
||||
printSuccess "Full program type checking completed successfully."
|
||||
printResult "Main method result:" result
|
||||
) handleError
|
||||
|
||||
catch (do
|
||||
print "====================================================================================="
|
||||
let typedProgram = typeCheckCompilationUnit testClasses
|
||||
printSuccess "Type checking of Program completed successfully"
|
||||
printResult "Typed Program:" typedProgram
|
||||
) handleError
|
||||
|
||||
|
||||
@ -1,5 +1,6 @@
|
||||
module Typecheck where
|
||||
import Data.List (find)
|
||||
import Data.Maybe
|
||||
import Ast
|
||||
|
||||
typeCheckCompilationUnit :: CompilationUnit -> CompilationUnit
|
||||
@ -8,9 +9,11 @@ typeCheckCompilationUnit classes = map (`typeCheckClass` classes) classes
|
||||
typeCheckClass :: Class -> [Class] -> Class
|
||||
typeCheckClass (Class className methods fields) classes =
|
||||
let
|
||||
-- Create a symbol table from class fields
|
||||
-- Create a symbol table from class fields and method entries
|
||||
classFields = [(id, dt) | VariableDeclaration dt id _ <- fields]
|
||||
checkedMethods = map (\method -> typeCheckMethodDeclaration method classFields classes) methods
|
||||
methodEntries = [(methodName, className) | MethodDeclaration _ methodName _ _ <- methods]
|
||||
initalSymTab = ("this", className) : classFields ++ methodEntries
|
||||
checkedMethods = map (\method -> typeCheckMethodDeclaration method initalSymTab classes) methods
|
||||
in Class className checkedMethods fields
|
||||
|
||||
typeCheckMethodDeclaration :: MethodDeclaration -> [(Identifier, DataType)] -> [Class] -> MethodDeclaration
|
||||
@ -18,9 +21,7 @@ typeCheckMethodDeclaration (MethodDeclaration retType name params body) classFie
|
||||
let
|
||||
-- Combine class fields with method parameters to form the initial symbol table for the method
|
||||
methodParams = [(identifier, dataType) | ParameterDeclaration dataType identifier <- params]
|
||||
-- Ensure method parameters shadow class fields if names collide
|
||||
initialSymtab = classFields ++ methodParams
|
||||
-- Type check the body of the method using the combined symbol table
|
||||
checkedBody = typeCheckStatement body initialSymtab classes
|
||||
bodyType = getTypeFromStmt checkedBody
|
||||
-- Check if the type of the body matches the declared return type
|
||||
@ -137,20 +138,17 @@ typeCheckExpression (BinaryOperation op expr1 expr2) symtab classes =
|
||||
NameResolution ->
|
||||
case (expr1', expr2) of
|
||||
(TypedExpression t1 (Reference obj), Reference member) ->
|
||||
-- Lookup the class type of obj from the symbol table
|
||||
let objectType = lookupType obj symtab
|
||||
classDetails = find (\(Class className _ _) -> className == objectType) classes
|
||||
in case classDetails of
|
||||
Just (Class _ methods fields) ->
|
||||
-- Check both fields and methods to find a match for member
|
||||
Just (Class _ _ fields) ->
|
||||
let fieldTypes = [dt | VariableDeclaration dt id _ <- fields, id == member]
|
||||
methodTypes = [dt | MethodDeclaration dt id _ _ <- methods, id == member]
|
||||
in case fieldTypes ++ methodTypes of
|
||||
[resolvedType] -> TypedExpression resolvedType (BinaryOperation op expr1' (TypedExpression resolvedType (Reference member)))
|
||||
[] -> error $ "Member '" ++ member ++ "' not found in class '" ++ objectType ++ "'"
|
||||
_ -> error $ "Ambiguous reference to '" ++ member ++ "' in class '" ++ objectType ++ "'"
|
||||
in case fieldTypes of
|
||||
[resolvedType] -> TypedExpression resolvedType (BinaryOperation NameResolution expr1' (TypedExpression resolvedType expr2))
|
||||
[] -> error $ "Field '" ++ member ++ "' not found in class '" ++ objectType ++ "'"
|
||||
_ -> error $ "Ambiguous reference to field '" ++ member ++ "' in class '" ++ objectType ++ "'"
|
||||
Nothing -> error $ "Object '" ++ obj ++ "' does not correspond to a known class"
|
||||
_ -> error "Name resolution requires object reference and member name"
|
||||
_ -> error "Name resolution requires object reference and field name"
|
||||
|
||||
typeCheckExpression (UnaryOperation op expr) symtab classes =
|
||||
let expr' = typeCheckExpression expr symtab classes
|
||||
@ -174,7 +172,7 @@ typeCheckExpression (StatementExpressionExpression stmtExpr) symtab classes =
|
||||
in TypedExpression (getTypeFromStmtExpr stmtExpr') (StatementExpressionExpression stmtExpr')
|
||||
|
||||
-- ********************************** Type Checking: StatementExpressions **********************************
|
||||
-- TODO: Implement type checking for StatementExpressions
|
||||
|
||||
typeCheckStatementExpression :: StatementExpression -> [(Identifier, DataType)] -> [Class] -> StatementExpression
|
||||
typeCheckStatementExpression (Assignment id expr) symtab classes =
|
||||
let expr' = typeCheckExpression expr symtab classes
|
||||
@ -187,12 +185,54 @@ typeCheckStatementExpression (Assignment id expr) symtab classes =
|
||||
error "Assignment type mismatch"
|
||||
|
||||
typeCheckStatementExpression (ConstructorCall className args) symtab classes =
|
||||
let args' = map (\arg -> typeCheckExpression arg symtab classes) args
|
||||
in TypedStatementExpression className (ConstructorCall className args')
|
||||
case find (\(Class name _ _) -> name == className) classes of
|
||||
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
|
||||
Nothing -> error $ "No valid constructor found for class '" ++ className ++ "'."
|
||||
Just (MethodDeclaration _ _ params _) ->
|
||||
let
|
||||
args' = map (\arg -> typeCheckExpression arg symtab classes) args
|
||||
-- Extract expected parameter types from the constructor's parameters
|
||||
expectedTypes = [dataType | ParameterDeclaration dataType _ <- params]
|
||||
argTypes = map getTypeFromExpr args'
|
||||
-- Check if the types of the provided arguments match the expected types
|
||||
typeMatches = zipWith (\expected actual -> if expected == actual then Nothing else Just (expected, actual)) expectedTypes argTypes
|
||||
mismatchErrors = map (\(exp, act) -> "Expected type '" ++ exp ++ "', found '" ++ act ++ "'.") (catMaybes typeMatches)
|
||||
in
|
||||
if length args /= length params then
|
||||
error $ "Constructor for class '" ++ className ++ "' expects " ++ show (length params) ++ " arguments, but got " ++ show (length args) ++ "."
|
||||
else if not (null mismatchErrors) then
|
||||
error $ unlines $ ("Type mismatch in constructor arguments for class '" ++ className ++ "':") : mismatchErrors
|
||||
else
|
||||
TypedStatementExpression className (ConstructorCall className args')
|
||||
|
||||
typeCheckStatementExpression (MethodCall methodName args) symtab classes =
|
||||
typeCheckStatementExpression (MethodCall expr methodName args) symtab classes =
|
||||
let objExprTyped = typeCheckExpression expr symtab classes
|
||||
in case objExprTyped of
|
||||
TypedExpression objType _ ->
|
||||
case find (\(Class className _ _) -> className == objType) classes of
|
||||
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
|
||||
in TypedStatementExpression "Object" (MethodCall methodName args')
|
||||
expectedTypes = [dataType | ParameterDeclaration dataType _ <- params]
|
||||
argTypes = map getTypeFromExpr args'
|
||||
typeMatches = zipWith (\expType argType -> (expType == argType, 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 ++ "':")
|
||||
: [ "Expected: " ++ expType ++ ", Found: " ++ argType | (_, expType, argType) <- mismatches ]
|
||||
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."
|
||||
|
||||
-- ********************************** Type Checking: Statements **********************************
|
||||
|
||||
@ -264,6 +304,10 @@ typeCheckStatement (Return expr) symtab classes =
|
||||
Just e' -> TypedStatement (getTypeFromExpr e') (Return (Just e'))
|
||||
Nothing -> TypedStatement "Void" (Return Nothing)
|
||||
|
||||
typeCheckStatement (StatementExpressionStatement stmtExpr) symtab classes =
|
||||
let stmtExpr' = typeCheckStatementExpression stmtExpr symtab classes
|
||||
in TypedStatement (getTypeFromStmtExpr stmtExpr') (StatementExpressionStatement stmtExpr')
|
||||
|
||||
-- ********************************** Type Checking: Helpers **********************************
|
||||
|
||||
getTypeFromExpr :: Expression -> DataType
|
||||
|
||||
Loading…
Reference in New Issue
Block a user