Start implementing a bunch of the C backend.

Have basic implementations down for coarse registers. Working on getting
bitfields supported.

1 files changed, 95 insertions, 21 deletions

diff --git a/src/Language/Fiddle/Compiler/Qualification.hs b/src/Language/Fiddle/Compiler/Qualification.hs
index ce6250a..67d3f29 100644
--- a/src/Language/Fiddle/Compiler/Qualification.hs
+++ b/src/Language/Fiddle/Compiler/Qualification.hs
@@ -12,11 +12,11 @@ module Language.Fiddle.Compiler.Qualification (qualificationPhase) where
 
 import Control.Monad.RWS (MonadWriter (tell))
 import Control.Monad.State
-import Data.Foldable (foldlM)
+import Data.Foldable (foldlM, toList)
 import Data.List (intercalate)
-import Data.List.NonEmpty (NonEmpty (..), toList)
+import Data.List.NonEmpty (NonEmpty (..))
 import qualified Data.List.NonEmpty as NonEmpty
-import Data.Maybe (mapMaybe)
+import Data.Maybe (isNothing, mapMaybe)
 import qualified Data.Text
 import Data.Word
 import Language.Fiddle.Ast
@@ -52,11 +52,8 @@ uniqueString prefix = do
   modify $ \g -> g {uniqueCounter = cnt + 1}
   return $ "_" ++ prefix ++ show cnt
 
-uniqueIdentifier :: a -> M (Identifier F a)
-uniqueIdentifier a = (\s -> Identifier (Data.Text.pack s) a) <$> uniqueString "ident"
-
-uniqueReservedIdentifier :: a -> M (Identifier F a)
-uniqueReservedIdentifier a = (\s -> Identifier (Data.Text.pack s) a) <$> uniqueString "reserved"
+uniqueIdentifier :: String -> a -> M (Identifier F a)
+uniqueIdentifier prefix a = (\s -> Identifier (Data.Text.pack s) a) <$> uniqueString prefix
 
 instance CompilationStage Expanded where
   type StageAfter Expanded = Qualified
@@ -77,14 +74,17 @@ qualificationPhase =
 
     squeezeDiagnostics raw
 
--- Any non-guaranteed identifiers are given generated identifiers here.
-instance
-  StageConvertible
-    Expanded
-    (Guaranteed False (Identifier F A))
-    (Guaranteed True (Identifier F A))
-  where
-  convertInStage _ ann _ = guaranteeM (uniqueIdentifier ann)
+pushIdent :: Identifier f a -> LocalState -> LocalState
+pushIdent i = pushIdents [i]
+
+pushIdents :: (Foldable t) => t (Identifier f a) -> LocalState -> LocalState
+pushIdents =
+  ( \case
+      [] -> id
+      (i : is) ->
+        modifyCurrentScopePath (pushScope $ fmap identToString (i :| is))
+  )
+    . toList
 
 instance
   StageConvertible
@@ -110,9 +110,80 @@ deriving instance AdvanceStage S EnumBody
 
 deriving instance AdvanceStage S EnumConstantDecl
 
-deriving instance AdvanceStage S RegisterBitsDecl
-
-deriving instance AdvanceStage S ObjTypeDecl
+instance AdvanceStage S RegisterBitsDecl where
+  advanceStage localState = \case
+    ReservedBits expr an -> ReservedBits <$> advanceStage localState expr <*> pure an
+    BitsSubStructure bod name an ->
+      BitsSubStructure
+        <$> advanceStage localState bod
+        <*> pure name
+        <*> pure an
+    DefinedBits _ mod ident typ an -> do
+      let qMeta =
+            QBitsMetadata
+              { bitsSpan = Vacant,
+                bitsFullPath =
+                  qualifyPath
+                    (currentScopePath localState)
+                    (NonEmpty.singleton (identToString ident))
+              }
+      DefinedBits (Present qMeta) mod ident
+        <$> advanceStage localState typ
+        <*> pure an
+
+instance AdvanceStage S ObjTypeDecl where
+  advanceStage localState = \case
+    AssertPosStatement d e a ->
+      AssertPosStatement d <$> advanceStage localState e <*> pure a
+    RegisterDecl _ mod ident size bod ann -> do
+      ident' <- guaranteeM (uniqueIdentifier "reg" ann) ident
+      let localState' = pushIdents ident localState
+
+      let qRegMeta =
+            QRegMetadata
+              { regSpan = Vacant,
+                regIsPadding = False,
+                regIsUnnamed = isNothing (toMaybe ident),
+                regFullPath =
+                  qualifyPath
+                    (currentScopePath localState)
+                    (NonEmpty.singleton (identToString (unwrap ident')))
+              }
+
+      RegisterDecl
+        (Present qRegMeta)
+        (guarantee (ModifierKeyword Rw ann) mod)
+        ident'
+        <$> advanceStage localState' size
+        <*> mapM (advanceStage localState') bod
+        <*> pure ann
+    ReservedDecl _ expr ann -> do
+      ident <- uniqueIdentifier "reserved" ann
+
+      let qRegMeta =
+            QRegMetadata
+              { regSpan = Vacant,
+                regIsPadding = True,
+                regIsUnnamed = True,
+                regFullPath =
+                  qualifyPath
+                    (currentScopePath localState)
+                    (NonEmpty.singleton (identToString ident))
+              }
+
+      RegisterDecl
+        (Present qRegMeta)
+        (Guaranteed $ ModifierKeyword Pr ann)
+        (Guaranteed ident)
+        <$> advanceStage localState expr
+        <*> pure Nothing
+        <*> pure ann
+    TypeSubStructure bod name an -> do
+      let localState' = pushIdents name localState
+      TypeSubStructure
+        <$> mapM (advanceStage localState') bod
+        <*> pure name
+        <*> pure an
 
 deriving instance AdvanceStage S (Expression u)
 
@@ -284,6 +355,7 @@ advanceFiddleDecls localState decls = fmap (reverse . fst) $ do
                               <*> pure ann
                   ObjTypeDecl _ ident body ann ->
                     let qualifiedName = qualify (NonEmpty.singleton (identToString ident))
+                        localState'' = modifyCurrentScopePath (pushScope (NonEmpty.singleton $ identToString ident)) localState'
                      in do
                           typeSize <- calculateTypeSize =<< resolveOrFail body
                           let decl =
@@ -295,7 +367,7 @@ advanceFiddleDecls localState decls = fmap (reverse . fst) $ do
                             =<< ObjTypeDecl
                               (qMd decl)
                               ident
-                              <$> mapM (advanceStage localState') body
+                              <$> mapM (advanceStage localState'') body
                               <*> pure ann
                   ObjectDecl _ ident loc typ ann ->
                     let qualifiedName = qualify (NonEmpty.singleton (identToString ident))
@@ -331,7 +403,9 @@ objTypeToExport ls = \case
       <*> expressionToIntM size
   ReferencedObjType {refName = n} -> do
     (full, _ :: ExportedTypeDecl) <- resolveOrFail =<< resolveName n ls
-    return $ ReferencedObjectType (intercalate "." full)
+    case full of
+      (f:fs) -> return $ ReferencedObjectType (f :| fs)
+      _ -> compilationFailure
 
 calculateTypeSize :: ObjTypeBody Expanded F A -> M (N Bytes)
 calculateTypeSize (ObjTypeBody bodyType decls _) =