diff options
Diffstat (limited to 'src/Language/Fiddle/Compiler/Backend/C.hs')
-rw-r--r-- | src/Language/Fiddle/Compiler/Backend/C.hs | 58 |
1 files changed, 55 insertions, 3 deletions
diff --git a/src/Language/Fiddle/Compiler/Backend/C.hs b/src/Language/Fiddle/Compiler/Backend/C.hs index 4b4b3ea..1ab22bb 100644 --- a/src/Language/Fiddle/Compiler/Backend/C.hs +++ b/src/Language/Fiddle/Compiler/Backend/C.hs @@ -361,6 +361,33 @@ pattern DefinedBitsP modifier bitsName bitsFullPath offset typeRef annot <- } ) +pattern BitsSubstructureP :: + Modifier f a -> + String -> + QualifiedPath String -> + N Bits -> + N Bits -> + RegisterBody Checked f A -> + A -> + RegisterBitsDecl Checked f A +pattern BitsSubstructureP modifier bitsName bitsFullPath offset size subRegisterBody annot <- + BitsSubStructure + { qBitsMetadata = + Present + QBitsMetadata + { bitsSpan = + Present + FieldSpan + { offset = offset, + size = size + }, + bitsFullPath = (basenamePart &&& id -> (bitsName, bitsFullPath)) + }, + bitsModifier = (Guaranteed modifier), + bitsSubRegBody = subRegisterBody, + bitsSubAnnot = annot + } + writeBitsGet :: StructName -> QRegMetadata True -> @@ -616,13 +643,13 @@ typeRefToArgs reg = -- decomposeBitsTypeRef (RegisterBitsJustBits ) writeRegisterBody :: StructName -> QRegMetadata True -> RegisterBody Checked I A -> M SIntf -writeRegisterBody structName regmeta = execWriterT . walk_ registerWalk +writeRegisterBody structName regmeta t = execWriterT $ walk (\t' () -> registerWalk t') t () where registerWalk :: forall t. (Walk t, Typeable t) => t I A -> - WriterT SIntf (FilesM () FormattedWriter CFileState) () + WriterT SIntf (FilesM () FormattedWriter CFileState) (WalkContinuation ()) registerWalk t = case () of () | (Just (DefinedBitsP modifier _ fullPath offset typeRef annot)) <- castTS t -> @@ -637,6 +664,31 @@ writeRegisterBody structName regmeta = execWriterT . walk_ registerWalk ( tell =<< lift (writeBitsGet structName regmeta fullPath offset typeRef annot), tell =<< lift (writeBitsSet isWo structName regmeta fullPath offset typeRef annot) ) + return Stop + () | (Just (BitsSubstructureP modifier bitsName fullPath offset size subBody annot)) <- castTS t -> do + sIntf <- lift (writeRegisterBody structName regmeta subBody) + let isWo = case modifier of + ModifierKeyword Wo _ -> True + _ -> False + if null bitsName + then tell sIntf + else do + -- Make a typeref here which is defined as "just bitse" + let typeRef = + RegisterBitsJustBits + (ConstExpression (LeftV size) annot) + annot + + tell $ sIntfSingleton bitsName sIntf + lift $ textM $ emitDocComments annot + sequence_ $ + selectByModifier + modifier + ( tell =<< lift (writeBitsGet structName regmeta fullPath offset typeRef annot), + tell =<< lift (writeBitsSet isWo structName regmeta fullPath offset typeRef annot) + ) + + return Stop -- text $ -- Text.pack $ -- printf @@ -644,7 +696,7 @@ writeRegisterBody structName regmeta = execWriterT . walk_ registerWalk -- bitsName -- (qualifiedPathToIdentifier fullPath) -- offset - _ -> return () + _ -> return $ Continue () castTS :: forall (t' :: SynTree) (t :: StagedSynTree) (f :: Type -> Type) (a :: Type). |