From cdf88f13008cd3f6511d466c1078ae7b2f983faf Mon Sep 17 00:00:00 2001 From: "Juan J. Martinez" Date: Fri, 9 Sep 2022 12:41:03 +0100 Subject: Refactored the compiler result to plug in the code generator Also some tweaks in error reporting. --- app/Main.hs | 4 +-- src/Micro/Asm/Sdcc.hs | 6 ++++ src/Micro/Compiler.hs | 93 +++++++++++++++++++++++++++++---------------------- src/Micro/Env.hs | 2 +- test/Language.hs | 2 +- 5 files changed, 63 insertions(+), 44 deletions(-) diff --git a/app/Main.hs b/app/Main.hs index 5a16129..db970d9 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -71,8 +71,8 @@ compileFile filename onlyParse = do Left err -> hPutStrLn stderr (showParserError err) >> exitFailure Right ast -> do res <- return $ evalState (compileAll ast) startState - case res of - Right _ -> if onlyParse then exitSuccess else print ast + case crExit res of + Right out -> if onlyParse then exitSuccess else hPutStrLn stdout out Left errs -> hPutStr stderr (showErrorList errs) >> exitFailure main :: IO () diff --git a/src/Micro/Asm/Sdcc.hs b/src/Micro/Asm/Sdcc.hs index 60a2caf..916fa3e 100644 --- a/src/Micro/Asm/Sdcc.hs +++ b/src/Micro/Asm/Sdcc.hs @@ -1 +1,7 @@ module Micro.Asm.Sdcc where + +import qualified Micro.Ast as A +import Micro.Env (SymMap) + +generate :: SymMap -> [A.Expr] -> String +generate sym ast = "OUTPUT" diff --git a/src/Micro/Compiler.hs b/src/Micro/Compiler.hs index 90e710b..f7ae71f 100644 --- a/src/Micro/Compiler.hs +++ b/src/Micro/Compiler.hs @@ -1,8 +1,8 @@ module Micro.Compiler where import Control.Monad.State -import Data.Either (rights) import Data.Maybe (catMaybes, fromMaybe) +import Micro.Asm.Sdcc (generate) import qualified Micro.Ast as A import Micro.Env import Micro.Error @@ -10,7 +10,21 @@ import Text.Parsec (SourcePos) type CompState = (Env, [Error]) -type CompResult = Either [Error] (Maybe A.Type) +data CompResult = CompResult + { -- last resolved type + crLast :: Maybe A.Type, + -- only in last call + crExit :: Either [Error] String + } + +typeResult :: Maybe A.Type -> CompResult +typeResult t = CompResult {crLast = t, crExit = Left []} + +errorResult :: [Error] -> CompResult +errorResult err = CompResult {crLast = Nothing, crExit = Left err} + +successResult :: String -> CompResult +successResult out = CompResult {crLast = Nothing, crExit = Right out} startState :: CompState startState = (emptyEnv, []) @@ -34,7 +48,7 @@ addError :: Error -> State CompState CompResult addError e = do (ev, errs) <- get put (ev, e : errs) - pure $ Right Nothing + pure $ typeResult Nothing -- | @typecheckCall args params@ resolves @args@ and compares it with @params@, -- returning a string describing an error or Nothing in case of type match. @@ -44,7 +58,8 @@ typecheckCall args params | length params == 0 = pure Nothing | otherwise = do -- resolve all args types - targs <- fmap rights $ traverse compile args + rargs <- traverse compile args + let targs = map crLast rargs case sequence targs of Just t -- after resolution, we could have less "rights" @@ -66,11 +81,10 @@ showMaybet (Just t) = show t typecheckVal :: A.Expr -> Maybe A.Type -> State CompState (Maybe String) typecheckVal value typ = do r <- compile value - case r of - Right r - | r == typ -> pure Nothing - | otherwise -> return $ Just $ "type mismatch\n found: " ++ showMaybet r ++ "\n expected: " ++ showMaybet typ - Left _ -> pure Nothing -- error resolving value + case crLast r of + rt + | rt == typ -> pure Nothing + | otherwise -> return $ Just $ "type mismatch\n found: " ++ showMaybet rt ++ "\n expected: " ++ showMaybet typ -- | @typecheckReturn value fret@ resolves @value@ and compares it with @fret@, -- returning a string decribing an error or Nothing in case of a type match. @@ -84,13 +98,11 @@ typecheckReturn (Just value) fret = typecheckVal value fret typecheckBinOp :: A.Expr -> A.Expr -> SourcePos -> State CompState CompResult typecheckBinOp a b pos = do l <- compile a - case l of - Right tl -> do - tr <- typecheckVal b $ tl - case tr of - Just err -> addError $ Error TypeError err pos - Nothing -> return $ Right $ tl - _ -> return $ Right Nothing -- error resolving left + let tl = crLast l + tr <- typecheckVal b $ tl + case tr of + Just err -> addError $ Error TypeError err pos + Nothing -> return $ typeResult tl -- built-in types types :: [String] @@ -105,9 +117,9 @@ verifyFuncType :: String -> [A.FuncParam] -> Maybe A.Type -> SourcePos -> [Error verifyFuncType ident params ret pos = do ( catMaybes $ map - ( \(id, t, _, pos) -> + ( \(_, t, _, pos) -> if not (definedType t) - then Just $ Error UndefinedType ("undefined type in function declaration \"" ++ id ++ "\"") pos + then Just $ Error UndefinedType ("undefined type in declaration of \"" ++ ident ++ "\"") pos else Nothing ) params @@ -119,9 +131,9 @@ verifyFuncType ident params ret pos = do compile :: A.Expr -> State CompState CompResult compile x = do case x of - (A.Module _ _) -> return $ Right Nothing - (A.Num _ _) -> return $ Right $ Just $ A.Type "u8" -- TODO: placeholder - (A.Bool' _ _) -> return $ Right $ Just $ A.Type "bool" + (A.Module _ _) -> return $ typeResult Nothing + (A.Num _ _) -> return $ typeResult $ Just $ A.Type "u8" -- TODO: placeholder + (A.Bool' _ _) -> return $ typeResult $ Just $ A.Type "bool" (A.BinOp A.Assign pos a@(A.Variable _ _) b) -> typecheckBinOp a b pos (A.BinOp A.Assign pos _ _) -> @@ -150,32 +162,31 @@ compile x = do (_, errs) <- get -- store updated errors and the env with the function put (ev, errs) - return $ Right $ Just ftype + return $ typeResult $ Just ftype where ftype = A.toFuncType params ret (A.Call ident args pos) -> do r <- compile ident - case r of - Right (Just (A.FuncType params rtyp)) -> do + case crLast r of + Just (A.FuncType params rtyp) -> do r <- typecheckCall args params case r of Just err -> addError $ Error TypeError err pos - Nothing -> return $ Right rtyp - Right _ -> addError $ Error NonCallable "non callable value in function call" pos - _ -> pure $ Right Nothing + Nothing -> return $ typeResult rtyp + _ -> addError $ Error NonCallable "non callable value in function call" pos (A.Var ident typ val priv pos) -> do (ev, errs) <- get (ev, errs) <- return $ foldlEither addSymUniq (ev, errs) [(ident, typ, priv, pos)] errs <- return $ if not (definedType typ) - then Error UndefinedType ("undefined type in variable declaration \"" ++ ident ++ "\"") pos : errs + then Error UndefinedType ("undefined type in declaration \"" ++ ident ++ "\"") pos : errs else errs put (ev, errs) vt <- typecheckVal val $ Just typ case vt of Just err -> addError $ Error TypeError err pos - Nothing -> return $ Right $ Just typ + Nothing -> return $ typeResult $ Just typ (A.Return value pos) -> do (ev, _) <- get case getSyml ev "$fn$" of @@ -183,20 +194,22 @@ compile x = do r <- typecheckReturn value rtyp case r of Just err -> addError $ Error TypeError err pos - Nothing -> return $ Right rtyp + Nothing -> return $ typeResult rtyp _ -> addError $ Error UnexpectedReturn "return without function call" pos (A.Variable ident pos) -> do (ev, _) <- get case getSym ev ident of - Just (_, t, _, _) -> return $ Right $ Just t - Nothing -> addError $ Error Undefined ("undefined variable \"" ++ ident ++ "\"") pos + Just (_, t, _, _) -> return $ typeResult $ Just t + Nothing -> addError $ Error Undefined ("undefined \"" ++ ident ++ "\"") pos compileAll :: [A.Expr] -> State CompState CompResult -compileAll (x : xs) = do - _ <- compile x - compileAll xs -compileAll [] = do - (_, errs) <- get - case errs of - [] -> pure $ Right Nothing - _ -> return $ Left errs +compileAll ast = + case ast of + (x : xs) -> do + _ <- compile x + compileAll xs + [] -> do + ((Env sym _), errs) <- get + case errs of + [] -> pure $ successResult $ generate sym ast + _ -> return $ errorResult errs diff --git a/src/Micro/Env.hs b/src/Micro/Env.hs index 4174158..7259deb 100644 --- a/src/Micro/Env.hs +++ b/src/Micro/Env.hs @@ -58,6 +58,6 @@ addEnv env = Env Map.empty $ Just env addSymUniq :: Env -> Sym -> Either Error Env addSymUniq ev (id, typ, priv, pos) = case getSyml ev id of Nothing -> Right $ addSym ev sym - Just (_, _, _, p) -> Left $ Error AlreadyDefined ("symbol \"" ++ id ++ "\" already defined in " ++ show p) pos + Just (_, _, _, p) -> Left $ Error AlreadyDefined ("\"" ++ id ++ "\" already defined in " ++ show p) pos where sym = (id, typ, priv, pos) diff --git a/test/Language.hs b/test/Language.hs index 6680178..9f47008 100644 --- a/test/Language.hs +++ b/test/Language.hs @@ -25,7 +25,7 @@ expectError input etyp = do Left e -> assertFailure $ show e Right ast -> do res <- return $ evalState (compileAll ast) startState - case res of + case crExit res of Left e -> case (find (\(E.Error t _ _) -> t == etyp) e) of Just _ -> return () Nothing -> assertFailure $ "expected " ++ show etyp ++ " didn't happen, got instead:\n" ++ unlines (map (\(E.Error t _ _) -> show t) e) -- cgit v1.2.3