diff options
Diffstat (limited to 'src/Language/Fiddle/Compiler')
| -rw-r--r-- | src/Language/Fiddle/Compiler/ConsistencyCheck.hs | 7 | ||||
| -rw-r--r-- | src/Language/Fiddle/Compiler/Expansion.hs | 45 | ||||
| -rw-r--r-- | src/Language/Fiddle/Compiler/Qualification.hs | 4 |
3 files changed, 51 insertions, 5 deletions
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 |