Implement bitfield arrays.

1 files changed, 130 insertions, 6 deletions

diff --git a/src/Language/Fiddle/Compiler/Backend/C.hs b/src/Language/Fiddle/Compiler/Backend/C.hs
index 79c81b1..a10839a 100644
--- a/src/Language/Fiddle/Compiler/Backend/C.hs
+++ b/src/Language/Fiddle/Compiler/Backend/C.hs
@@ -11,6 +11,7 @@ import Control.Monad (unless)
 import Control.Monad.RWS
 import Control.Monad.State
 import Control.Monad.Trans.Writer (Writer, execWriter)
+import qualified Data.Bits
 import Data.Char (isSpace)
 import Data.Data (Typeable, cast)
 import Data.Foldable (forM_, toList)
@@ -24,6 +25,7 @@ import qualified Data.Set as Set
 import Data.String (IsString)
 import Data.Text (Text)
 import qualified Data.Text as Text
+import Data.Word
 import Language.Fiddle.Ast
 import Language.Fiddle.Compiler.Backend
 import Language.Fiddle.Compiler.Backend.Internal
@@ -33,6 +35,7 @@ import Language.Fiddle.Compiler.Backend.Internal.Writer
 import Language.Fiddle.Internal.UnitInterface
 import Language.Fiddle.Internal.UnitNumbers
 import Language.Fiddle.Types
+import Numeric (showHex)
 import Options.Applicative
 import Text.Printf (printf)
 
@@ -324,7 +327,7 @@ writeBitsSet ::
   N Bits ->
   RegisterBitsTypeRef 'Checked I A ->
   M ()
-writeBitsSet structName bitsNam fullPath offset typeRef = do
+writeBitsSet structName bitsName fullPath offset typeRef = do
   text "inline static void "
   text (qualifiedPathToIdentifier fullPath)
   text "__set(\n    struct "
@@ -332,7 +335,75 @@ writeBitsSet structName bitsNam fullPath offset typeRef = do
   text " *o,\n    "
   typeRefToArgs typeRef
   text ") {\n"
+
+  let shiftArguments =
+        zipWith
+          (\a b -> if b == 1 then a else a <> " * " <> s b)
+          (tail setterArgumentNames)
+          (snd $ offsetCoefficients typeRef)
+          ++ [s offset | offset /= 0]
+
+  withIndent $ do
+    text $ maskValue typeRef
+
+    text "int to_set = value"
+
+    unless (null shiftArguments) $ do
+      text " << "
+      text $ Text.intercalate " + " shiftArguments
+
+    text ";\n"
+    text $ "o->" <> Text.pack bitsName <> " = to_set;\n"
   text "}\n\n"
+  where
+    offsetCoefficients :: RegisterBitsTypeRef Checked I A -> (Int, [Int])
+    offsetCoefficients
+      RegisterBitsJustBits
+        { justBitsExpr = fromIntegral . trueValue -> sz
+        } = (sz, [])
+    offsetCoefficients
+      RegisterBitsReference
+        { bitsRefQualificationMetadata =
+            Identity
+              ( Present
+                  ( ExportedBitsDecl
+                      { exportedBitsDeclSizeBits = sz
+                      }
+                    )
+                )
+        } = (fromIntegral sz, [])
+    offsetCoefficients (RegisterBitsArray tr n _) =
+      let (recsz, rest) = offsetCoefficients tr
+       in ( recsz * fromIntegral (trueValue n),
+            rest ++ [recsz]
+          )
+
+    s :: (Show a) => a -> Text
+    s = Text.pack . show
+
+    maskValue ref = do
+      typeRefToMask ref
+
+    typeRefToMask :: RegisterBitsTypeRef Checked I a -> Text
+    typeRefToMask RegisterBitsArray {bitsArrayTypeRef = ref} = typeRefToMask ref
+    typeRefToMask
+      RegisterBitsJustBits
+        { justBitsExpr = fromIntegral . trueValue -> sz
+        } = "value &= 0x" <> Text.pack (showHex (((1 :: Int) `Data.Bits.shiftL` (sz :: Int)) - 1) "") <> ";\n"
+    typeRefToMask
+      RegisterBitsReference
+        { bitsRefQualificationMetadata =
+            Identity
+              ( Present
+                  ( ExportedBitsDecl
+                      { exportedBitsDeclSizeBits = sz
+                      }
+                    )
+                )
+        } =
+        let num :: Int
+            num = (1 `Data.Bits.shiftL` fromIntegral sz) - 1
+         in "value = (typeof(value))(value & 0x" <> Text.pack (showHex num "") <> ");\n"
 
 typeRefToArgs :: RegisterBitsTypeRef 'Checked I A -> M ()
 typeRefToArgs reg =
@@ -352,7 +423,11 @@ typeRefToArgs reg =
       ( RegisterBitsReference
           { bitsRefQualificationMetadata = (Identity (Present md))
           }
-        ) = [qualifiedPathToIdentifier $ metadataFullyQualifiedPath $ getMetadata md]
+        ) =
+        [ "enum "
+            <> qualifiedPathToIdentifier
+              (metadataFullyQualifiedPath $ getMetadata md)
+        ]
     typeRefToArgs' (RegisterBitsArray tr (ConstExpression (LeftV _) _) _) =
       typeRefToArgs' tr ++ ["int"]
 
@@ -361,7 +436,7 @@ typeRefToArgs reg =
       32 -> "uint32_t"
       16 -> "uint16_t"
       8 -> "uint8_t"
-      _ -> "unsigend"
+      _ -> "unsigned"
 
 -- | Decomposes a type ref into a type name (String) and a list of dimensions
 -- (in the case of being an array)
@@ -370,15 +445,17 @@ typeRefToArgs reg =
 writeRegisterBody :: StructName -> QRegMetadata True -> RegisterBody Checked I A -> M ()
 writeRegisterBody structName regmeta = walk_ registerWalk
   where
+    regName = basenamePart (regFullPath regmeta)
+
     registerWalk :: forall t. (Walk t, Typeable t) => t I A -> M ()
     registerWalk t = case () of
       ()
-        | (Just (DefinedBitsP modifier bitsName fullPath offset typeRef)) <- castTS t -> do
+        | (Just (DefinedBitsP modifier _ fullPath offset typeRef)) <- castTS t -> do
             sequence_ $
               selectByModifier
                 modifier
-                ( writeBitsGet structName bitsName fullPath offset typeRef,
-                  writeBitsSet structName bitsName fullPath offset typeRef
+                ( writeBitsGet structName regName fullPath offset typeRef,
+                  writeBitsSet structName regName fullPath offset typeRef
                 )
 
       -- text $
@@ -512,6 +589,45 @@ emitDocComments (Commented comments _) = do
         then Text.tail t
         else t
 
+getEnumConstants :: [EnumConstantDecl Checked I a] -> [(String, N Unitless)]
+getEnumConstants = mapMaybe $ \case
+  EnumConstantDecl (identToString -> str) (trueValue -> val) _ -> Just (str, val)
+  _ -> Nothing
+
+pattern EnumPattern :: QualifiedPath String -> [(String, N Unitless)] -> FiddleDecl Checked I a
+pattern EnumPattern qualifiedPath consts <-
+  BitsDecl
+    { bitsQualificationMetadata =
+        Identity
+          ( Present
+              ( ExportedBitsDecl
+                  { exportedBitsDeclMetadata =
+                      Metadata
+                        { metadataFullyQualifiedPath = qualifiedPath
+                        }
+                  }
+                )
+            ),
+      bitsType =
+        EnumBitType
+          { enumBitBody =
+              Identity
+                ( EnumBody
+                    { enumConsts = getEnumConstants . map undirected -> consts
+                    }
+                  )
+          }
+    }
+
+emitEnum :: QualifiedPath String -> [(String, N Unitless)] -> M ()
+emitEnum (qualifiedPathToIdentifier -> ident) consts = do
+  text $ "enum " <> ident <> " "
+  body $ do
+    forM_ consts $ \(name, val) -> do
+      text $
+        ident <> "__" <> Text.pack name <> " = " <> Text.pack (show val) <> ",\n"
+  text ";\n\n"
+
 transpileWalk ::
   Either ImplementationInHeader FilePath ->
   FilePath ->
@@ -545,6 +661,14 @@ transpileWalk _ headerFile t _ = case () of
       text $ Text.pack $ printf " ((%s*)0x%08x)\n" (toLiteralTypeName (exportedObjectDeclType e)) (exportedObjectDeclLocation e)
 
     return Stop
+  () | Just (EnumPattern path consts) <- castTS t -> do
+    checkout sF $ emitEnum path consts
+    return Stop
+  () | Just (ImportStatement {importPath = path}) <- castTS t -> do
+    let header = fst (Text.breakOnEnd "." path) <> "h"
+     in checkout hF $ do
+          text $ Text.pack $ printf "#include \"%s\"\n" header
+          return Stop
   _ -> return (Continue ())
   where
     toLiteralTypeName :: ReferencedObjectType -> Text