summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Language/Fiddle/Ast/Internal/SyntaxTree.hs7
-rw-r--r--src/Language/Fiddle/Compiler/ConsistencyCheck.hs7
-rw-r--r--src/Language/Fiddle/Compiler/Expansion.hs45
-rw-r--r--src/Language/Fiddle/Compiler/Qualification.hs4
-rw-r--r--src/Language/Fiddle/Parser.hs15
-rw-r--r--src/Language/Fiddle/Tokenizer.hs4
6 files changed, 71 insertions, 11 deletions
diff --git a/src/Language/Fiddle/Ast/Internal/SyntaxTree.hs b/src/Language/Fiddle/Ast/Internal/SyntaxTree.hs
index a4f98e3..0e4894e 100644
--- a/src/Language/Fiddle/Ast/Internal/SyntaxTree.hs
+++ b/src/Language/Fiddle/Ast/Internal/SyntaxTree.hs
@@ -50,6 +50,7 @@ module Language.Fiddle.Ast.Internal.SyntaxTree
EnumBody (..),
EnumConstantDecl (..),
PackageBody (..),
+ RegisterPosition(..),
-- Helper Functions
regSzToBits,
mapDirected,
@@ -507,6 +508,9 @@ data ObjType stage f a where
ObjType stage f a
deriving (Typeable, Generic, Alter, Annotated, Typeable, Walk)
+newtype RegisterPosition = RegisterPosition (Maybe Text)
+ deriving newtype (Eq, Ord, Show, Generic, FromJSON, ToJSON)
+
-- | Represents a declaration inside an object type, such as a register, an
-- assertion, or a substructure.
data ObjTypeDecl stage f a where
@@ -557,6 +561,9 @@ data ObjTypeDecl stage f a where
regIdent :: Guaranteed (stage .>= Qualified) (Identifier f a),
-- | Size of the register.
regSize :: Variant (stage .>= Qualified) RegSz (Expression Bits stage f a),
+ -- | Declared register position. This gets turned into a "skip-to"
+ -- statement during expansion.
+ regPos :: When (stage .< Expanded) RegisterPosition,
-- | Optional register body.
regBody :: Maybe (RegisterBody stage f a),
-- | Annotation for the register declaration.
diff --git a/src/Language/Fiddle/Compiler/ConsistencyCheck.hs b/src/Language/Fiddle/Compiler/ConsistencyCheck.hs
index c4924da..369aa02 100644
--- a/src/Language/Fiddle/Compiler/ConsistencyCheck.hs
+++ b/src/Language/Fiddle/Compiler/ConsistencyCheck.hs
@@ -194,15 +194,15 @@ advanceObjTypeBody (ObjTypeBody us decls a) startOffset = do
span = Present (FieldSpan offset size)
qmeta' = fmap (\q -> q {regSpan = span}) qmeta
doReturn (BufferDecl qmeta' (Guaranteed ident) sz' a) size
- (RegisterDecl qmeta mod ident size Nothing a) -> do
+ (RegisterDecl qmeta mod ident size Vacant Nothing a) -> do
let declaredSize = regSzToBits (getLeft size)
reifiedSizeBytes <- checkBitsSizeMod8 a declaredSize
let span = Present (FieldSpan offset reifiedSizeBytes)
qmeta' = fmap (\q -> q {regSpan = span}) qmeta
- doReturn (RegisterDecl qmeta' mod ident (changeRight size) Nothing a)
+ doReturn (RegisterDecl qmeta' mod ident (changeRight size) Vacant Nothing a)
=<< checkBitsSizeMod8 a declaredSize
- (RegisterDecl qmeta mod ident size (Just body) a) -> do
+ (RegisterDecl qmeta mod ident size Vacant (Just body) a) -> do
let declaredSize = regSzToBits (getLeft size)
(actualSize, body') <- advanceRegisterBody 0 body
@@ -218,6 +218,7 @@ advanceObjTypeBody (ObjTypeBody us decls a) startOffset = do
mod
ident
(changeRight size)
+ Vacant
(Just body')
a
)
diff --git a/src/Language/Fiddle/Compiler/Expansion.hs b/src/Language/Fiddle/Compiler/Expansion.hs
index 94042a2..71e7fd2 100644
--- a/src/Language/Fiddle/Compiler/Expansion.hs
+++ b/src/Language/Fiddle/Compiler/Expansion.hs
@@ -50,7 +50,42 @@ instance CompilationStage CurrentStage where
type StageFunctor CurrentStage = Identity
type StageAnnotation CurrentStage = Annot
-deriving instance AdvanceStage CurrentStage ObjTypeBody
+instance AdvanceStage CurrentStage ObjTypeBody where
+ advanceStage path (ObjTypeBody typ decls ann) =
+ ObjTypeBody typ
+ <$> fmap
+ concat
+ ( mapM
+ ( \case
+ decl@( undirected ->
+ RegisterDecl
+ { regPos = Present (RegisterPosition (Just pos)),
+ regAnnot = ann
+ }
+ ) -> do
+ sequence
+ [ do
+ nu <- parseNum (unCommented ann) pos
+ return
+ ( asDirected $
+ SkipToStatement
+ Witness
+ Vacant
+ ( ConstExpression
+ ( RightV
+ (LitNum (RightV nu) ann)
+ )
+ ann
+ )
+ ann
+ ),
+ advanceStage path decl
+ ]
+ decl -> sequence [advanceStage path decl]
+ )
+ decls
+ )
+ <*> pure ann
deriving instance AdvanceStage CurrentStage DeferredRegisterBody
@@ -81,6 +116,14 @@ instance AdvanceStage CurrentStage PackageBody where
advanceStage p (PackageBody decls a) =
PackageBody <$> reconfigureFiddleDecls p decls <*> pure a
+instance
+ StageConvertible
+ ImportsResolved
+ (When True RegisterPosition)
+ (When False RegisterPosition)
+ where
+ convertInStage _ _ _ _ = return Vacant
+
instance AdvanceStage CurrentStage ObjTypeDecl where
modifyState t =
return
diff --git a/src/Language/Fiddle/Compiler/Qualification.hs b/src/Language/Fiddle/Compiler/Qualification.hs
index ac99f48..4f3d380 100644
--- a/src/Language/Fiddle/Compiler/Qualification.hs
+++ b/src/Language/Fiddle/Compiler/Qualification.hs
@@ -239,7 +239,7 @@ instance AdvanceStage S ObjTypeDecl where
ident'
<$> advanceStage localState'' sz
<*> pure ann
- RegisterDecl _ mod ident size bod ann -> do
+ RegisterDecl _ mod ident size Vacant bod ann -> do
ident' <- guaranteeM (uniqueIdentifier "reg" ann) ident
let (qualified, localState') =
@@ -261,6 +261,7 @@ instance AdvanceStage S ObjTypeDecl where
(guarantee (ModifierKeyword Rw ann) mod)
ident'
<$> progressBackM getProperRegSize size
+ <*> pure Vacant
<*> mapM (advanceStage localState'') bod
<*> pure ann
ReservedDecl _ expr ann -> do
@@ -281,6 +282,7 @@ instance AdvanceStage S ObjTypeDecl where
(Guaranteed $ ModifierKeyword Pr ann)
(Guaranteed ident)
<$> fmap LeftV (getProperRegSize expr)
+ <*> pure Vacant
<*> pure Nothing
<*> pure ann
TypeSubStructure bod name an -> do
diff --git a/src/Language/Fiddle/Parser.hs b/src/Language/Fiddle/Parser.hs
index e91fa41..b2bb6f7 100644
--- a/src/Language/Fiddle/Parser.hs
+++ b/src/Language/Fiddle/Parser.hs
@@ -238,6 +238,7 @@ objTypeDeclP =
RegisterDecl Vacant modifier . Perhaps
<$> optionMaybe ident
<*> fmap RightV exprInParenP
+ <*> (Present . RegisterPosition <$> optionMaybe (tok TokAtSign >> litNumP))
<*> optionMaybe (tok TokColon *> registerBodyP)
)
@@ -338,14 +339,18 @@ enumConstantDeclP =
constExpressionP :: Pa (ConstExpression u)
constExpressionP = withMeta $ ConstExpression . RightV <$> expressionP
+litNumP :: P Text
+litNumP =
+ token
+ ( \case
+ (TokLitNum num) -> Just num
+ _ -> Nothing
+ )
+
expressionP :: Pa (Expression u)
expressionP =
withMeta $
- token
- ( \case
- (TokLitNum num) -> Just (LitNum $ LeftV num)
- _ -> Nothing
- )
+ (LitNum . LeftV <$> litNumP)
<|> (Var <$> name)
body :: P [Token SourceSpan]
diff --git a/src/Language/Fiddle/Tokenizer.hs b/src/Language/Fiddle/Tokenizer.hs
index 4590ed0..c4b53d2 100644
--- a/src/Language/Fiddle/Tokenizer.hs
+++ b/src/Language/Fiddle/Tokenizer.hs
@@ -48,6 +48,7 @@ data T
| TokString !Text
| TokDirectiveStart -- [[
| TokDirectiveEnd -- ]]
+ | TokAtSign
deriving (Eq, Ord, Show, Read)
textOf :: T -> Maybe Text
@@ -154,7 +155,8 @@ parseToken = spaces *> tok parseToken' <* spaces
char '}' $> TokRBrace,
char ']' $> TokRBracket,
char ')' $> TokRParen,
- char ';' $> TokSemi
+ char ';' $> TokSemi,
+ char '@' $> TokAtSign
]
where
a $> b = a >> return b
generated by cgit (git 2.34.1) at 2025-04-28 14:45:46 +0000