SDCC generation WIP

3 files changed, 93 insertions, 26 deletions

diff --git a/src/Micro/Asm/Sdcc.hs b/src/Micro/Asm/Sdcc.hs
index 916fa3e..ef655d4 100644
--- a/src/Micro/Asm/Sdcc.hs
+++ b/src/Micro/Asm/Sdcc.hs
@@ -1,7 +1,66 @@
 module Micro.Asm.Sdcc where
 
+import qualified Data.Map as Map
 import qualified Micro.Ast as A
-import Micro.Env (SymMap)
+import Micro.Env (Sym (..), SymMap)
+
+toIdent :: A.Ident -> Bool -> String
+toIdent id False = "_" ++ id
+toIdent id True = id
+
+toLabel :: A.Ident -> Bool -> String
+toLabel id False = toIdent id False ++ "::"
+toLabel id True = id ++ ":"
+
+toData :: A.Type -> String
+toData (A.Type t)
+  | t == "bool" || t == "u8" || t == "s8" = ".ds 1"
+  | t == "u16" || t == "s16" = ".ds 2"
+  | otherwise = ".ds 2"
+toData (A.FuncType _ _) = ".ds 2"
+
+toInit :: A.Type -> String
+toInit (A.Type t)
+  | t == "bool" || t == "u8" || t == "s8" = ".db"
+  | t == "u16" || t == "s16" = ".dw"
+  | otherwise = ".dw"
+toInit (A.FuncType _ _) = ".dw"
+
+onlyData :: SymMap -> [Sym]
+onlyData symm =
+  filter (\sym -> symRef sym) $
+    Map.elems symm
+
+header :: [String]
+header = [";", "; File created by $$$ v?.?.? (SDCC)", ";"]
+
+module' :: A.Expr -> [String]
+module' (A.Module name _) = ["\t.module " ++ name, "\t.optsdcc -mz80"]
+module' _ = ["\t.module main"] -- won't happen
+
+exports :: SymMap -> [String]
+exports symm =
+  [""]
+    ++ ( map (\sym -> "\t.globl " ++ toIdent (symId sym) False) $
+           Map.elems $ Map.filter (\sym -> not $ symPriv sym) symm
+       )
+
+dataVars :: SymMap -> [String]
+dataVars symm =
+  ["\n\t.area _DATA", "\t.area _INITIALIZED"]
+    ++ ( map (\sym -> toLabel (symId sym) (symPriv sym) ++ "\n\t" ++ toData (symType sym)) $
+           onlyData symm
+       )
+
+initVars :: SymMap -> [String]
+initVars symm =
+  ["\n\t.area _INITIALIZER"]
+    ++ ( map (\sym -> "__xinit_" ++ toLabel (symId sym) True ++ "\n\t" ++ toInit (symType sym) ++ " FIXME") $ onlyData symm
+       )
+    ++ ["\n\t.area _GSINIT", "\t.area _GSFINAL"]
+
+code :: [String]
+code = ["\n\t.area _CODE"]
 
 generate :: SymMap -> [A.Expr] -> String
-generate sym ast = "OUTPUT"
+generate symm ast = unlines $ header ++ module' (head ast) ++ exports symm ++ dataVars symm ++ code ++ initVars symm
diff --git a/src/Micro/Compiler.hs b/src/Micro/Compiler.hs
index f7ae71f..b765c16 100644
--- a/src/Micro/Compiler.hs
+++ b/src/Micro/Compiler.hs
@@ -148,15 +148,15 @@ compile x = do
       (ev, errs) <- return $ (ev, (verifyFuncType ident params ret pos) ++ errs)
       -- updated with the function
       (ev, errs) <-
-        return $ case addSymUniq ev (ident, ftype, priv, pos) of
+        return $ case addSymUniq ev (newSym ident ftype priv False pos) of
           Left err -> (ev, err : errs)
           Right ev -> (ev, errs)
       -- lambdas can only access local variables (closures aren't supported)
       fev <- return $ if anon then emptyEnv else ev
       -- with parameters
-      (nev, errs) <- return $ foldlEither addSymUniq (addEnv fev, errs) params
+      (nev, errs) <- return $ foldlEither addSymUniq (addEnv fev, errs) $ map (toSym True) params
       -- helper for return
-      nev <- return $ addSym nev ("$fn$", ftype, True, pos)
+      nev <- return $ addSym nev $ newSym "$fn$" ftype True True pos
       put (nev, errs)
       _ <- compileAll body
       (_, errs) <- get
@@ -176,7 +176,7 @@ compile x = do
         _ -> 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)]
+      (ev, errs) <- return $ foldlEither addSymUniq (ev, errs) [newSym ident typ priv True pos]
       errs <-
         return $
           if not (definedType typ)
@@ -190,7 +190,7 @@ compile x = do
     (A.Return value pos) -> do
       (ev, _) <- get
       case getSyml ev "$fn$" of
-        Just (_, A.FuncType _ rtyp, _, _) -> do
+        Just Sym {symType = A.FuncType _ rtyp} -> do
           r <- typecheckReturn value rtyp
           case r of
             Just err -> addError $ Error TypeError err pos
@@ -199,17 +199,13 @@ compile x = do
     (A.Variable ident pos) -> do
       (ev, _) <- get
       case getSym ev ident of
-        Just (_, t, _, _) -> return $ typeResult $ Just t
+        Just Sym {symType = t} -> return $ typeResult $ Just t
         Nothing -> addError $ Error Undefined ("undefined \"" ++ ident ++ "\"") pos
 
 compileAll :: [A.Expr] -> State CompState CompResult
-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
+compileAll ast = do
+  _ <- traverse compile ast
+  ((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 7259deb..9de7248 100644
--- a/src/Micro/Env.hs
+++ b/src/Micro/Env.hs
@@ -6,7 +6,21 @@ import qualified Micro.Ast as A
 import Micro.Error
 import Text.Parsec (SourcePos)
 
-type Sym = (A.Ident, A.Type, Bool, SourcePos)
+data Sym = Sym
+  { symId :: A.Ident,
+    symType :: A.Type,
+    symPriv :: Bool,
+    symRef :: Bool,
+    symPos :: SourcePos
+  }
+  deriving (Show)
+
+newSym :: A.Ident -> A.Type -> Bool -> Bool -> SourcePos -> Sym
+newSym a b c d e = Sym {symId = a, symType = b, symPriv = c, symRef = d, symPos = e}
+
+-- XXX: this name is not good
+toSym :: Bool -> A.FuncParam -> Sym
+toSym ref (a, b, c, d) = newSym a b c ref d
 
 type SymMap = Map.Map A.Ident Sym
 
@@ -45,9 +59,9 @@ existsSyml env sym = isJust $ getSyml env sym
 -- environment. It will create a new enviroment if the symbol already exists
 -- (shadowing).
 addSym :: Env -> Sym -> Env
-addSym env@(Env m parent) sym@(id, _, _, _) = case getSym env id of
-  Nothing -> Env (Map.insert id sym m) parent
-  Just _ -> Env (Map.singleton id sym) $ Just env
+addSym env@(Env m parent) sym = case getSym env (symId sym) of
+  Nothing -> Env (Map.insert (symId sym) sym m) parent
+  Just _ -> Env (Map.singleton (symId sym) sym) $ Just env
 
 -- | @addEnv e@ adds a new local environment using @e@ as parent.
 addEnv :: Env -> Env
@@ -56,8 +70,6 @@ addEnv env = Env Map.empty $ Just env
 -- | @addSymUniq e s@ adds a local symbol @s@ to the enviroment @e@ if it
 -- doesn't exist.
 addSymUniq :: Env -> Sym -> Either Error Env
-addSymUniq ev (id, typ, priv, pos) = case getSyml ev id of
+addSymUniq ev sym = case getSyml ev (symId sym) of
   Nothing -> Right $ addSym ev sym
-  Just (_, _, _, p) -> Left $ Error AlreadyDefined ("\"" ++ id ++ "\" already defined in " ++ show p) pos
-  where
-    sym = (id, typ, priv, pos)
+  Just other -> Left $ Error AlreadyDefined ("\"" ++ symId sym ++ "\" already defined in " ++ show (symPos other)) $ symPos sym