summaryrefslogtreecommitdiff
path: root/src/Language/Fiddle/Compiler
diff options
context:
space:
mode:
Diffstat (limited to 'src/Language/Fiddle/Compiler')
-rw-r--r--src/Language/Fiddle/Compiler/Backend/C.hs17
-rw-r--r--src/Language/Fiddle/Compiler/ConsistencyCheck.hs5
-rw-r--r--src/Language/Fiddle/Compiler/Expansion.hs2
-rw-r--r--src/Language/Fiddle/Compiler/ImportResolution.hs2
-rw-r--r--src/Language/Fiddle/Compiler/Qualification.hs28
5 files changed, 38 insertions, 16 deletions
diff --git a/src/Language/Fiddle/Compiler/Backend/C.hs b/src/Language/Fiddle/Compiler/Backend/C.hs
index dd79bac..df31c8c 100644
--- a/src/Language/Fiddle/Compiler/Backend/C.hs
+++ b/src/Language/Fiddle/Compiler/Backend/C.hs
@@ -26,8 +26,8 @@ import Data.Text (Text)
import qualified Data.Text as Text
import Language.Fiddle.Ast
import Language.Fiddle.Compiler.Backend
-import qualified Language.Fiddle.Compiler.Backend.Internal.FragTree as FragTree
import Language.Fiddle.Compiler.Backend.Internal.FormattedWriter
+import qualified Language.Fiddle.Compiler.Backend.Internal.FragTree as FragTree
import Language.Fiddle.Compiler.Backend.Internal.Writer
import Language.Fiddle.Internal.UnitInterface
import Language.Fiddle.Internal.UnitNumbers
@@ -77,7 +77,7 @@ newtype CFileState = CFileState
requireInclude :: String -> M ()
requireInclude file = do
- b <- (Set.member file) <$> gets includedFiles
+ b <- gets (Set.member file . includedFiles)
unless b $ do
checkout hF $
text $
@@ -283,8 +283,8 @@ writeRegSet
tell $ Text.pack $ printf " o->%s[%d] = in[%d];\n" fieldName i i
tell "}\n\n"
-pattern DefinedBitsP :: String -> NonEmpty String -> N Bits -> RegisterBitsDecl Checked f a
-pattern DefinedBitsP bitsName bitsFullPath offset <-
+pattern DefinedBitsP :: String -> NonEmpty String -> N Bits -> RegisterBitsTypeRef Checked f a -> RegisterBitsDecl Checked f a
+pattern DefinedBitsP bitsName bitsFullPath offset typeRef <-
( DefinedBits
{ qBitsMetadata =
Present
@@ -295,17 +295,22 @@ pattern DefinedBitsP bitsName bitsFullPath offset <-
{ offset = offset
},
bitsFullPath = (NonEmpty.last &&& id -> (bitsName, bitsFullPath))
- }
+ },
+ definedBitsTypeRef = typeRef
}
)
+-- | Decomposes a type ref into a type name (String) and a list of dimensions
+-- (in the case of being an array)
+-- decomposeBitsTypeRef :: RegisterBitsTypeRef Checked I A -> (String, [N Unitless])
+-- decomposeBitsTypeRef (RegisterBitsJustBits )
writeRegisterBody :: StructName -> QRegMetadata True -> RegisterBody Checked I A -> M ()
writeRegisterBody structName regmeta = walk_ registerWalk
where
registerWalk :: forall t. (Walk t, Typeable t) => t I A -> M ()
registerWalk t = case () of
()
- | (Just (DefinedBitsP bitsName fullPath offset)) <- castTS t ->
+ | (Just (DefinedBitsP bitsName fullPath offset typeRef)) <- castTS t ->
text $
Text.pack $
printf
diff --git a/src/Language/Fiddle/Compiler/ConsistencyCheck.hs b/src/Language/Fiddle/Compiler/ConsistencyCheck.hs
index 3d95ea0..3e81153 100644
--- a/src/Language/Fiddle/Compiler/ConsistencyCheck.hs
+++ b/src/Language/Fiddle/Compiler/ConsistencyCheck.hs
@@ -78,6 +78,8 @@ deriving instance AdvanceStage S PackageBody
deriving instance AdvanceStage S FiddleDecl
+deriving instance AdvanceStage S (ConstExpression u)
+
instance AdvanceStage S FiddleUnit where
advanceStage () fu@(FiddleUnit _ decls a) =
FiddleUnit (Present $ getUnitInterface fu) <$> mapM (advanceStage ()) decls <*> pure a
@@ -256,8 +258,7 @@ advanceDecl offset = \case
bitsTypeSize :: RegisterBitsTypeRef S F A -> M (N Bits)
bitsTypeSize (RegisterBitsArray tr nExpr _) = do
sz <- bitsTypeSize tr
- n <- expressionToIntM nExpr
- return (sz .*. n)
+ return (sz .*. trueValue nExpr)
bitsTypeSize
RegisterBitsReference
{ bitsRefQualificationMetadata =
diff --git a/src/Language/Fiddle/Compiler/Expansion.hs b/src/Language/Fiddle/Compiler/Expansion.hs
index d9bce1e..0443b8d 100644
--- a/src/Language/Fiddle/Compiler/Expansion.hs
+++ b/src/Language/Fiddle/Compiler/Expansion.hs
@@ -71,6 +71,8 @@ deriving instance AdvanceStage CurrentStage BitType
deriving instance AdvanceStage CurrentStage EnumBody
+deriving instance AdvanceStage CurrentStage (ConstExpression u)
+
deriving instance AdvanceStage CurrentStage EnumConstantDecl
deriving instance (AdvanceStage CurrentStage t) => AdvanceStage CurrentStage (Directed t)
diff --git a/src/Language/Fiddle/Compiler/ImportResolution.hs b/src/Language/Fiddle/Compiler/ImportResolution.hs
index a27a1dc..2568025 100644
--- a/src/Language/Fiddle/Compiler/ImportResolution.hs
+++ b/src/Language/Fiddle/Compiler/ImportResolution.hs
@@ -111,6 +111,8 @@ deriving instance AdvanceStage CurrentStage AnonymousBitsType
deriving instance AdvanceStage CurrentStage BitType
+deriving instance AdvanceStage CurrentStage (ConstExpression u)
+
deriving instance AdvanceStage CurrentStage EnumBody
deriving instance AdvanceStage CurrentStage EnumConstantDecl
diff --git a/src/Language/Fiddle/Compiler/Qualification.hs b/src/Language/Fiddle/Compiler/Qualification.hs
index 67d3f29..56f1122 100644
--- a/src/Language/Fiddle/Compiler/Qualification.hs
+++ b/src/Language/Fiddle/Compiler/Qualification.hs
@@ -94,6 +94,14 @@ instance
where
convertInStage _ _ _ _ = Present <$> uniqueString "reserved"
+instance AdvanceStage S (ConstExpression u) where
+ advanceStage ls (ConstExpression (RightV exp) a) =
+ case exp of
+ Var var _ -> do
+ (_, ExportedLocationDecl _ v) <- resolveOrFail =<< resolveName var ls
+ return $ ConstExpression (LeftV $ fromIntegral v) a
+ LitNum (RightV v) _ -> return $ ConstExpression (LeftV v) a
+
deriving instance AdvanceStage S ObjTypeBody
deriving instance AdvanceStage S DeferredRegisterBody
@@ -326,11 +334,11 @@ advanceFiddleDecls localState decls = fmap (reverse . fst) $ do
LocationDecl _ ident expr ann ->
let qualifiedName = qualify (NonEmpty.singleton (identToString ident))
in do
- exprValue <- expressionToIntM expr
+ expr' <- advanceStage localState' expr
let decl =
ExportedLocationDecl
(metadata qualifiedName)
- exprValue
+ (trueValue expr')
insertDecl decl
doReturn
=<< LocationDecl
@@ -355,7 +363,10 @@ 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'
+ localState'' =
+ modifyCurrentScopePath
+ (pushScope (NonEmpty.singleton $ identToString ident))
+ localState'
in do
typeSize <- calculateTypeSize =<< resolveOrFail body
let decl =
@@ -373,7 +384,8 @@ advanceFiddleDecls localState decls = fmap (reverse . fst) $ do
let qualifiedName = qualify (NonEmpty.singleton (identToString ident))
in do
location <- resolveLocationExpression localState' loc
- exportedType <- objTypeToExport localState' typ
+ typ' <- advanceStage localState' typ
+ exportedType <- objTypeToExport localState' typ'
let decl =
ExportedObjectDecl
(metadata qualifiedName)
@@ -385,7 +397,7 @@ advanceFiddleDecls localState decls = fmap (reverse . fst) $ do
(qMd decl)
ident
<$> advanceStage localState' loc
- <*> advanceStage localState' typ
+ <*> pure typ'
<*> pure ann
)
([], localState)
@@ -395,16 +407,16 @@ insertDecl :: (ExportableDecl d) => d -> M ()
insertDecl decl =
modify $ \(GlobalState ui c) -> GlobalState (UnitInterface.insert decl ui) c
-objTypeToExport :: LocalState -> ObjType Expanded F A -> M ReferencedObjectType
+objTypeToExport :: LocalState -> ObjType Qualified F A -> M ReferencedObjectType
objTypeToExport ls = \case
ArrayObjType {arraySize = size, arrayObjType = objType} ->
ArrayObjectType
<$> objTypeToExport ls objType
- <*> expressionToIntM size
+ <*> pure (trueValue size)
ReferencedObjType {refName = n} -> do
(full, _ :: ExportedTypeDecl) <- resolveOrFail =<< resolveName n ls
case full of
- (f:fs) -> return $ ReferencedObjectType (f :| fs)
+ (f : fs) -> return $ ReferencedObjectType (f :| fs)
_ -> compilationFailure
calculateTypeSize :: ObjTypeBody Expanded F A -> M (N Bytes)
generated by cgit (git 2.34.1) at 2025-07-13 18:55:09 +0000