summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--goal.fiddle2
-rw-r--r--src/Language/Fiddle/Ast/Internal/SyntaxTree.hs4
-rw-r--r--src/Language/Fiddle/Compiler/Backend/C.hs136
-rw-r--r--src/Language/Fiddle/Compiler/ConsistencyCheck.hs2
-rw-r--r--src/Language/Fiddle/Compiler/Qualification.hs13
-rw-r--r--src/Language/Fiddle/Parser.hs2
6 files changed, 136 insertions, 23 deletions
diff --git a/goal.fiddle b/goal.fiddle
index bddd3bf..ded2c42 100644
--- a/goal.fiddle
+++ b/goal.fiddle
@@ -88,6 +88,8 @@ package stm32l4.gpio {
[[ noexport ]]
wo reg (32) : struct {
union {
+
+ [[ c: no_qualify ]]
pupd_r : enum(2) {
none = 0b0,
// Compiles to Gpio::PupdR::PullUp
diff --git a/src/Language/Fiddle/Ast/Internal/SyntaxTree.hs b/src/Language/Fiddle/Ast/Internal/SyntaxTree.hs
index c539665..0d0bc32 100644
--- a/src/Language/Fiddle/Ast/Internal/SyntaxTree.hs
+++ b/src/Language/Fiddle/Ast/Internal/SyntaxTree.hs
@@ -703,7 +703,7 @@ data BitType (stage :: Stage) (f :: Type -> Type) a where
EnumBitType ::
{ -- | Expression defining the enum size.
enumBitSize :: Expression Bits stage f a,
- -- | The body of the enum.
+ -- | The body of the enum.set_stm32l4_gpio__bsr_r__set
enumBitBody :: f (EnumBody stage f a),
-- | Annotation for the enumeration.
enumBitAnnot :: a
@@ -737,7 +737,7 @@ data EnumConstantDecl stage f a where
{ -- | Identifier for the constant.
enumConstIdent :: Identifier f a,
-- | Expression defining the constant.
- enumConstExpr :: Expression Unitless stage f a,
+ enumConstExpr :: ConstExpression Unitless stage f a,
-- | Annotation for the constant.
enumConstAnnot :: a
} ->
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
diff --git a/src/Language/Fiddle/Compiler/ConsistencyCheck.hs b/src/Language/Fiddle/Compiler/ConsistencyCheck.hs
index a8d9758..3def59d 100644
--- a/src/Language/Fiddle/Compiler/ConsistencyCheck.hs
+++ b/src/Language/Fiddle/Compiler/ConsistencyCheck.hs
@@ -322,7 +322,7 @@ checkEnumConsistency expr enumBody@(EnumBody {enumConsts = constants}) = do
foldlM
( \imap (undirected -> enumConst) -> do
number <- case enumConst of
- EnumConstantDecl _ expr _ -> expressionToIntM expr
+ EnumConstantDecl _ expr _ -> return $ trueValue expr
EnumConstantReserved expr _ -> expressionToIntM expr
when (number >= 2 ^ declaredSize) $
diff --git a/src/Language/Fiddle/Compiler/Qualification.hs b/src/Language/Fiddle/Compiler/Qualification.hs
index 81e6ac4..e8ab479 100644
--- a/src/Language/Fiddle/Compiler/Qualification.hs
+++ b/src/Language/Fiddle/Compiler/Qualification.hs
@@ -100,19 +100,6 @@ pushObject obj ls =
let q = currentQualifiedPath ls
in q {objectPart = objectPart q ++ h, basenamePart = l}
--- pushObject :: [String] -> LocalState -> (QualifiedPath String, LocalState)
--- pushObject objName ls =
--- let q = currentQualifiedPath ls
--- in ( fmap (const objName) q,
--- ls
--- { currentScopePath = pushScope (NonEmpty.singleton objName) (currentScopePath ls),
--- currentQualifiedPath =
--- q
--- { objectPart = objName
--- }
--- }
--- )
-
pushRegister :: String -> LocalState -> (QualifiedPath String, LocalState)
pushRegister regName ls =
let q = currentQualifiedPath ls
diff --git a/src/Language/Fiddle/Parser.hs b/src/Language/Fiddle/Parser.hs
index ad96724..066fd2e 100644
--- a/src/Language/Fiddle/Parser.hs
+++ b/src/Language/Fiddle/Parser.hs
@@ -315,7 +315,7 @@ enumConstantDeclP :: Pa EnumConstantDecl
enumConstantDeclP =
withMeta $
(tok KWReserved >> EnumConstantReserved <$> (tok TokEq >> expressionP))
- <|> (EnumConstantDecl <$> ident <*> (tok TokEq >> expressionP))
+ <|> (EnumConstantDecl <$> ident <*> (tok TokEq >> constExpressionP))
constExpressionP :: Pa (ConstExpression u)
constExpressionP = withMeta $ ConstExpression . RightV <$> expressionP
generated by cgit (git 2.34.1) at 2025-04-28 19:43:31 +0000