diff options
Diffstat (limited to 'src/Language/Fiddle/Compiler/Backend/C.hs')
| -rw-r--r-- | src/Language/Fiddle/Compiler/Backend/C.hs | 481 |
1 files changed, 364 insertions, 117 deletions
diff --git a/src/Language/Fiddle/Compiler/Backend/C.hs b/src/Language/Fiddle/Compiler/Backend/C.hs index 71344c5..26ea065 100644 --- a/src/Language/Fiddle/Compiler/Backend/C.hs +++ b/src/Language/Fiddle/Compiler/Backend/C.hs @@ -7,16 +7,18 @@ module Language.Fiddle.Compiler.Backend.C (cBackend) where import Control.Arrow -import Control.Monad (unless) +import Control.Monad (forM, unless) import Control.Monad.RWS +import Control.Monad.Trans.Writer hiding (tell) import qualified Data.Bits import Data.Char (isSpace) import Data.Data (Typeable, cast) import Data.Foldable (forM_) import Data.Kind (Type) +import qualified Data.List import Data.Map (Map) import qualified Data.Map as Map -import Data.Maybe (mapMaybe) +import Data.Maybe (fromMaybe, mapMaybe) import Data.Set (Set) import qualified Data.Set as Set import Data.Text (Text) @@ -34,17 +36,80 @@ import Numeric (showHex) import Options.Applicative import Text.Printf (printf) -data ImplementationInHeader = ImplementationInHeader +newtype CBackendFlags = CBackendFlags + { cHeaderOut :: FilePath + } -data CBackendFlags = CBackendFlags - { cSourceOut :: Either ImplementationInHeader FilePath, - cHeaderOut :: FilePath +data SIntfF + = SIntfF + { sIntfFValue :: Text, + sIntfFComemnts :: FormattedWriter () } --- data StructureInterface = Leaf String String +newtype SIntf + = SIntf + ( Map String (Either SIntfF SIntf) + ) + +instance Monoid SIntf where + mempty = SIntf mempty + +instance Semigroup SIntf where + (<>) (SIntf m1) (SIntf m2) = + SIntf $ + Map.unionWith + ( \a b -> case (a, b) of + (Right a, Right b) -> Right (a <> b) + (Left _, Left b) -> Left b + (Right a, Left _) -> Right a + (_, Right a) -> Right a + ) + m1 + m2 + +class SIntfSingleton a where + sIntfSingleton :: String -> a -> SIntf + +instance SIntfSingleton SIntfF where + sIntfSingleton s = SIntf . Map.singleton s . Left + +instance SIntfSingleton SIntf where + sIntfSingleton s = SIntf . Map.singleton s . Right type StructName = Text +sIntfToC :: SIntf -> M () +sIntfToC (SIntf m) = do + text "struct " + body $ + forM_ (Map.toList m) $ \(k, v) -> do + case v of + Left (SIntfF txt emitCom) -> do + textM emitCom + text $ "typeof(" <> txt <> ")* " <> Text.pack k <> ";\n" + Right sub -> do + sIntfToC sub + text " " + text $ Text.pack k + text ";\n" + +sIntfToRVal :: SIntf -> M () +sIntfToRVal (SIntf m) = do + body $ do + sequence_ $ + Data.List.intersperse (text ",\n") $ + map + ( \(k, v) -> do + case v of + Left (SIntfF txt _) -> + text $ "." <> Text.pack k <> " = " <> txt + Right sub -> do + text $ "." <> Text.pack k <> " = " + sIntfToRVal sub + ) + (Map.toList m) + text "\n" + -- | Header fragment. The top. Starts which include guards and has include -- statements. hF :: FileFragment @@ -66,6 +131,10 @@ aF = ("HEADER", FragTree.below (snd sF)) fF :: FileFragment fF = ("HEADER", FragTree.below FragTree.center) +-- | Interface fragment. This is wehre interfaces are stored. +intfF :: FileFragment +intfF = ("HEADER", FragTree.above (snd fF)) + type A = Commented SourceSpan type I = Identity @@ -92,20 +161,7 @@ cBackend = { backendName = "C", backendOptionsParser = CBackendFlags - <$> ( Right - <$> strOption - ( long "c-source-out" - <> short 'o' - <> help "Output file for the C source file." - <> metavar "OUTPUT" - ) - <|> flag' - (Left ImplementationInHeader) - ( long "impl-in-header" - <> help "Put the whole implementation as static inline functions in the header." - ) - ) - <*> strOption + <$> strOption ( long "c-header-out" <> short 'h' <> help "Output file for the C header file." @@ -122,8 +178,7 @@ transpile :: TranspileResult transpile CBackendFlags - { cHeaderOut = headerFile, - cSourceOut = sourceFile + { cHeaderOut = headerFile } () fiddleUnit = toTranspileResult $ fst $ runFilesM execFormattedWriter () (CFileState mempty) hF run @@ -133,7 +188,6 @@ transpile TranspileResult $ Map.mapKeys ( \case - "SOURCE" | Right sourceFile' <- sourceFile -> sourceFile' "HEADER" -> headerFile k -> k ) @@ -149,11 +203,11 @@ transpile -- Pad out the implementation checkout iF $ text "\n" - walk (transpileWalk sourceFile headerFile) fiddleUnit () + walk (transpileWalk headerFile) fiddleUnit () checkout hF $ textM $ do - tell "\nstatic_assert(true); // https://github.com/clangd/clangd/issues/1167\n" + tell "\n_Static_assert(1); // https://github.com/clangd/clangd/issues/1167\n" checkout fF $ text headerFinal @@ -187,7 +241,7 @@ writeStaticAssert structName regname off = do text $ Text.pack $ printf - "\n_Static_assert(offsetof(%s, %s) == 0x%x, \"Offset wrong\");\n" + "\n_Static_assert(offsetof(struct %s, %s) == 0x%x, \"Offset wrong\");\n" structName regname off @@ -208,7 +262,7 @@ selectByModifier mod (getter, setter) = (ModifierKeyword Wo _) -> [setter] (ModifierKeyword Pr _) -> [] -writeRegGet :: StructName -> QRegMetadata True -> M () +writeRegGet :: StructName -> QRegMetadata True -> A -> M SIntf writeRegGet structType ( QRegMetadata @@ -219,7 +273,7 @@ writeRegGet }, regFullPath = fullPath } - ) = do + ) docComms = do let fnName = qualifiedPathToIdentifier fullPath <> "__get" returnType = sizeToType size fieldName = basenamePart fullPath @@ -229,7 +283,7 @@ writeRegGet textM $ do tell $ Text.pack $ - printf "static inline %s %s(const %s* o) {\n" rt fnName structType + printf "static inline %s %s(const struct %s* o) {\n" rt fnName structType tell $ Text.pack $ printf " return o->%s;\n" fieldName tell "}\n\n" Nothing -> @@ -246,7 +300,9 @@ writeRegGet tell $ Text.pack $ printf " out[%d] = o->%s[%d];\n" i fieldName i tell "}\n\n" -writeRegSet :: StructName -> QRegMetadata True -> M () + return $ sIntfSingleton "get" (SIntfF fnName (emitDocComments docComms)) + +writeRegSet :: StructName -> QRegMetadata True -> A -> M SIntf writeRegSet structType ( QRegMetadata @@ -257,7 +313,7 @@ writeRegSet }, regFullPath = fullPath } - ) = do + ) docComs = do let fnName = qualifiedPathToIdentifier fullPath <> "__set" setType = sizeToType size fieldName = basenamePart fullPath @@ -284,14 +340,17 @@ writeRegSet tell $ Text.pack $ printf " o->%s[%d] = in[%d];\n" fieldName i i tell "}\n\n" + return $ sIntfSingleton "set" (SIntfF fnName (emitDocComments docComs)) + pattern DefinedBitsP :: Modifier f a -> String -> QualifiedPath String -> N Bits -> - RegisterBitsTypeRef Checked f a -> - RegisterBitsDecl Checked f a -pattern DefinedBitsP modifier bitsName bitsFullPath offset typeRef <- + RegisterBitsTypeRef Checked f A -> + A -> + RegisterBitsDecl Checked f A +pattern DefinedBitsP modifier bitsName bitsFullPath offset typeRef annot <- ( DefinedBits { qBitsMetadata = Present @@ -304,7 +363,8 @@ pattern DefinedBitsP modifier bitsName bitsFullPath offset typeRef <- bitsFullPath = (basenamePart &&& id -> (bitsName, bitsFullPath)) }, definedBitsTypeRef = typeRef, - definedBitsModifier = (Guaranteed modifier) + definedBitsModifier = (Guaranteed modifier), + definedBitsAnnot = annot } ) @@ -314,20 +374,115 @@ writeBitsGet :: QualifiedPath String -> N Bits -> RegisterBitsTypeRef 'Checked I A -> - M () -writeBitsGet _ _ _ _ _ = return () + A -> + M SIntf +writeBitsGet structName regName fullPath offset typeRef docComms = do + let fnName = qualifiedPathToIdentifier fullPath <> "__get" + bitsName = basenamePart fullPath + retType = typeRefBaseType typeRef + + text $ "inline static " <> retType <> " " + text fnName + text "(\n struct " + text structName + text " *o" + + let shiftArguments = + zipWith + (\a b -> if b == 1 then a else a <> " * " <> s b) + (tail setterArgumentNames) + (snd $ offsetCoefficients typeRef) + ++ [s offset | offset /= 0] + + unless (null shiftArguments) $ + text ", " + + text $ Text.intercalate ", " $ zipWith (\f _ -> "int " <> f) (tail setterArgumentNames) shiftArguments + + text ") {\n" + + withIndent $ do + if null shiftArguments + then do + text "unsigned shift_ = 0" + else do + text "unsigned shift_ = " + text $ Text.intercalate " + " shiftArguments + text ";\n" + + text "unsigned mask_ = " + text $ typeRefToGetMask typeRef + text " << shift_;\n" + + text $ retType <> " ret = (" <> retType <> ")((o->" <> Text.pack regName <> " & mask_) >> shift_);\n" + text "return ret;\n" + text "}\n\n" + return $ + sIntfSingleton bitsName $ + sIntfSingleton "get" (SIntfF fnName (emitDocComments docComms)) + 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 + + typeRefToGetMask :: RegisterBitsTypeRef Checked I a -> Text + typeRefToGetMask RegisterBitsArray {bitsArrayTypeRef = ref} = typeRefToGetMask ref + typeRefToGetMask + RegisterBitsJustBits + { justBitsExpr = fromIntegral . trueValue -> sz + } = "0x" <> Text.pack (showHex (((1 :: Int) `Data.Bits.shiftL` (sz :: Int)) - 1) "") + typeRefToGetMask + RegisterBitsReference + { bitsRefQualificationMetadata = + Identity + ( Present + ( ExportedBitsDecl + { exportedBitsDeclSizeBits = sz + } + ) + ) + } = + let num :: Int + num = (1 `Data.Bits.shiftL` fromIntegral sz) - 1 + in "0x" <> Text.pack (showHex num "") writeBitsSet :: + Bool -> StructName -> String -> QualifiedPath String -> N Bits -> RegisterBitsTypeRef 'Checked I A -> - M () -writeBitsSet structName bitsName fullPath offset typeRef = do + A -> + M SIntf +writeBitsSet writeOnly structName regName fullPath offset typeRef docComms = do + let fnName = qualifiedPathToIdentifier fullPath <> "__set" + bitsName = basenamePart fullPath + text "inline static void " - text (qualifiedPathToIdentifier fullPath) - text "__set(\n struct " + text fnName + text "(\n struct " text structName text " *o,\n " typeRefToArgs typeRef @@ -341,17 +496,30 @@ writeBitsSet structName bitsName fullPath offset typeRef = do ++ [s offset | offset /= 0] withIndent $ do - text $ maskValue typeRef - - text "int to_set = value" + let mask = typeRefToMask typeRef + text $ "unsigned mask_ = " <> mask <> ";\n" unless (null shiftArguments) $ do - text " << " - text $ Text.intercalate " + " shiftArguments + text $ + "unsigned shift_ = " <> Text.intercalate " + " shiftArguments <> ";\n" + text "mask_ <<= shift_;\n" + text "int to_set_ = value" + + unless (null shiftArguments) $ do + text " << shift_" text ";\n" - text $ "o->" <> Text.pack bitsName <> " = to_set;\n" + text "to_set_ &= mask_;\n" + + unless writeOnly $ do + text $ "unsigned current_ = o->" <> Text.pack regName <> ";\n" + text "to_set_ = current_ ^ (current_ & mask_) ^ to_set_;\n" + + text $ "o->" <> Text.pack regName <> " = to_set_;\n" text "}\n\n" + return $ + sIntfSingleton bitsName $ + sIntfSingleton "set" (SIntfF fnName (emitDocComments docComms)) where offsetCoefficients :: RegisterBitsTypeRef Checked I A -> (Int, [Int]) offsetCoefficients @@ -378,15 +546,12 @@ writeBitsSet structName bitsName fullPath offset typeRef = do 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" + } = "0x" <> Text.pack (showHex (((1 :: Int) `Data.Bits.shiftL` (sz :: Int)) - 1) "") typeRefToMask RegisterBitsReference { bitsRefQualificationMetadata = @@ -400,33 +565,26 @@ writeBitsSet structName bitsName fullPath offset typeRef = do } = let num :: Int num = (1 `Data.Bits.shiftL` fromIntegral sz) - 1 - in "value = (typeof(value))(value & 0x" <> Text.pack (showHex num "") <> ");\n" + in "0x" <> Text.pack (showHex num "") -typeRefToArgs :: RegisterBitsTypeRef 'Checked I A -> M () -typeRefToArgs reg = - text - $ Text.intercalate ",\n " - $ zipWith - (\n t -> t <> " " <> n) - setterArgumentNames - $ typeRefToArgs' reg +typeRefBaseType :: RegisterBitsTypeRef 'Checked I A -> Text +typeRefBaseType = typeRefBaseType' where - typeRefToArgs' + typeRefBaseType' ( RegisterBitsJustBits { justBitsExpr = ConstExpression (LeftV v) _ } - ) = [typeForBits v] - typeRefToArgs' + ) = typeForBits v + typeRefBaseType' ( RegisterBitsReference { bitsRefQualificationMetadata = (Identity (Present md)) } ) = - [ "enum " - <> qualifiedPathToIdentifier - (metadataFullyQualifiedPath $ getMetadata md) - ] - typeRefToArgs' (RegisterBitsArray tr (ConstExpression (LeftV _) _) _) = - typeRefToArgs' tr ++ ["int"] + "enum " + <> qualifiedPathToIdentifier + (metadataFullyQualifiedPath $ getMetadata md) + typeRefBaseType' (RegisterBitsArray tr (ConstExpression (LeftV _) _) _) = + typeRefBaseType' tr typeForBits = \case 64 -> "uint64_t" @@ -435,26 +593,48 @@ typeRefToArgs reg = 8 -> "uint8_t" _ -> "unsigned" +typeRefToArgs :: RegisterBitsTypeRef 'Checked I A -> M () +typeRefToArgs reg = + text + $ Text.intercalate ",\n " + $ zipWith + (\n t -> t <> " " <> n) + setterArgumentNames + $ typeRefToArgs' reg + where + typeRefToArgs' (RegisterBitsArray tr (ConstExpression (LeftV _) _) _) = + typeRefToArgs' tr ++ ["int"] + typeRefToArgs' x = [typeRefBaseType x] + -- | 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 +writeRegisterBody :: + StructName -> QRegMetadata True -> RegisterBody Checked I A -> M SIntf +writeRegisterBody structName regmeta = execWriterT . walk_ registerWalk where regName = basenamePart (regFullPath regmeta) - registerWalk :: forall t. (Walk t, Typeable t) => t I A -> M () + registerWalk :: + forall t. + (Walk t, Typeable t) => + t I A -> + WriterT SIntf (FilesM () FormattedWriter CFileState) () registerWalk t = case () of () - | (Just (DefinedBitsP modifier _ fullPath offset typeRef)) <- castTS t -> do - sequence_ $ - selectByModifier - modifier - ( writeBitsGet structName regName fullPath offset typeRef, - writeBitsSet structName regName fullPath offset typeRef - ) - + | (Just (DefinedBitsP modifier _ fullPath offset typeRef annot)) <- castTS t -> + let isWo = case modifier of + ModifierKeyword Wo _ -> True + _ -> False + in do + lift $ textM $ emitDocComments annot + sequence_ $ + selectByModifier + modifier + ( tell =<< lift (writeBitsGet structName regName fullPath offset typeRef annot), + tell =<< lift (writeBitsSet isWo structName regName fullPath offset typeRef annot) + ) -- text $ -- Text.pack $ -- printf @@ -480,20 +660,30 @@ writeImplementation :: QRegMetadata True -> Modifier f a -> Maybe (RegisterBody Checked I A) -> - M () + A -> + M SIntf -- | Register is just padding, don't emit anything -writeImplementation _ (regIsPadding -> True) _ _ = return () -writeImplementation structName qMeta mod bod = do - unless (regIsUnnamed qMeta) $ - sequence_ $ - selectByModifier mod (writeRegGet structName qMeta, writeRegSet structName qMeta) - - mapM_ (writeRegisterBody structName qMeta) bod - -structBody :: StructName -> ObjTypeBody Checked I A -> M () +writeImplementation _ (regIsPadding -> True) _ _ _ = return mempty +writeImplementation structName qMeta mod bod regAnnot = do + si1 <- + if regIsUnnamed qMeta + then return mempty + else do + l <- + sequence $ + selectByModifier + mod + (writeRegGet structName qMeta regAnnot, writeRegSet structName qMeta regAnnot) + return $ mconcat l + + si2 <- mapM (writeRegisterBody structName qMeta) bod + + return $ si1 <> fromMaybe mempty si2 + +structBody :: StructName -> ObjTypeBody Checked I A -> M SIntf structBody structName (ObjTypeBody _ decls _) = do - forM_ decls $ \(Directed _ decl _) -> + fmap mconcat $ forM decls $ \(Directed _ decl _) -> case decl of RegisterDecl { qRegMeta = Present regMetadata, @@ -513,7 +703,8 @@ structBody structName (ObjTypeBody _ decls _) = do writeStaticAssert structName i off checkout iF $ - writeImplementation structName regMetadata mod bod + (if regIsUnnamed regMetadata then id else sIntfSingleton i) + <$> writeImplementation structName regMetadata mod bod ann TypeSubStructure { subStructureBody = Identity bod, subStructureName = mname @@ -523,13 +714,15 @@ structBody structName (ObjTypeBody _ decls _) = do Union {} -> "union " Struct {} -> "struct " - body $ structBody structName bod + sintf <- body $ structBody structName bod textM $ do forM_ mname $ \name -> tell (Text.pack $ identToString name) tell ";\n" + + return sintf where sizeToField (Text.pack -> f) = \case 1 -> "volatile uint8_t " <> f @@ -538,21 +731,23 @@ structBody structName (ObjTypeBody _ decls _) = do 8 -> "volatile uint64_t " <> f n -> "volatile uint8_t " <> f <> "[" <> Text.pack (show n) <> "]" -union :: Text -> M () -> M () +union :: Text -> M a -> M a union identifier fn = do text "#pragma pack(push, 1)\n" text $ "union " <> identifier <> " " - body fn + a <- body fn text ";\n" text "#pragma pack(pop)\n" + return a -struct :: Text -> M () -> M () +struct :: Text -> M a -> M a struct identifier fn = do text "#pragma pack(push, 1)\n" text $ "struct " <> identifier <> " " - body fn + a <- body fn text ";\n" text "#pragma pack(pop)\n" + return a body :: M a -> M a body f = text "{\n" *> withIndent f <* textM (ensureNL >> tell "}") @@ -560,18 +755,24 @@ body f = text "{\n" *> withIndent f <* textM (ensureNL >> tell "}") withIndent :: M a -> M a withIndent = block incIndent decIndent +withCMacroMode :: M a -> M a +withCMacroMode = block cMacroModeStart cMacroModeStop + identifierFor :: (ExportableDecl d) => d -> Text identifierFor = qualifiedPathToIdentifier . metadataFullyQualifiedPath . getMetadata emitDocComments :: A -> FormattedWriter () emitDocComments (Commented comments _) = do - mapM_ (\t -> tellLn $ "// " <> t) $ - mapMaybe - ( \case - (DocComment t) -> Just (trimDocComment t) - _ -> Nothing - ) - comments + mapM_ (\t -> tellLn $ "// " <> trimDocComment t) $ + filter (not . Text.all isSpace) $ + Text.lines $ + mconcat $ + mapMaybe + ( \case + (DocComment t) -> Just t + _ -> Nothing + ) + comments ensureNL where trimDocComment = @@ -586,12 +787,12 @@ emitDocComments (Commented comments _) = do then Text.tail t else t -getEnumConstants :: [EnumConstantDecl Checked I a] -> [(String, N Unitless)] +getEnumConstants :: [Directed EnumConstantDecl Checked I a] -> [(String, N Unitless, [Directive I a])] getEnumConstants = mapMaybe $ \case - EnumConstantDecl (identToString -> str) (trueValue -> val) _ -> Just (str, val) + Directed dirs (EnumConstantDecl (identToString -> str) (trueValue -> val) _) _ -> Just (str, val, dirs) _ -> Nothing -pattern EnumPattern :: QualifiedPath String -> [(String, N Unitless)] -> FiddleDecl Checked I a +pattern EnumPattern :: QualifiedPath String -> [(String, N Unitless, [Directive I a])] -> FiddleDecl Checked I a pattern EnumPattern qualifiedPath consts <- BitsDecl { bitsQualificationMetadata = @@ -610,26 +811,50 @@ pattern EnumPattern qualifiedPath consts <- { enumBitBody = Identity ( EnumBody - { enumConsts = getEnumConstants . map undirected -> consts + { enumConsts = getEnumConstants -> consts } ) } } -emitEnum :: QualifiedPath String -> [(String, N Unitless)] -> M () +emitEnum :: QualifiedPath String -> [(String, N Unitless, [Directive I A])] -> 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" + forM_ consts $ \(name, val, dirs) -> do + if isUnqualified dirs + then + text $ Text.pack name <> " = " <> Text.pack (show val) <> ",\n" + else + text $ + ident <> "__" <> Text.pack name <> " = " <> Text.pack (show val) <> ",\n" text ";\n\n" + where + isUnqualified = + any + ( any + ( \case + (DirectiveElementKey {directiveKey = identToString -> "unqualified"}) -> True + _ -> False + ) + . allElements + ) + + allElements + ( Directive + { directiveBody = + Identity + ( DirectiveBody + { directiveElements = elts + } + ) + } + ) = elts transpileWalk :: - Either ImplementationInHeader FilePath -> FilePath -> (forall t. (Walk t, Typeable t) => t I A -> () -> M (WalkContinuation ())) -transpileWalk _ headerFile t _ = case () of +transpileWalk headerFile t _ = case () of () | Just ( ObjTypeDecl @@ -647,15 +872,16 @@ transpileWalk _ headerFile t _ = case () of pad $ do textM $ emitDocComments a let structName = identifierFor (unwrap metadata) - structureType structName $ do + sh <- structureType structName $ do structBody structName objTypeBody + writeSIntf (metadataFullyQualifiedPath $ getMetadata (unwrap metadata)) sh return Stop () | Just (getExportedObjectDecl -> Just e) <- castTS t -> do let qname = qualifiedPathToIdentifier (metadataFullyQualifiedPath (getMetadata e)) checkout fF $ do text "#define " text qname - text $ Text.pack $ printf " ((%s*)0x%08x)\n" (toLiteralTypeName (exportedObjectDeclType e)) (exportedObjectDeclLocation e) + text $ Text.pack $ printf " ((struct %s*)0x%08x)\n" (toLiteralTypeName (exportedObjectDeclType e)) (exportedObjectDeclLocation e) return Stop () | Just (EnumPattern path consts) <- castTS t -> do @@ -683,6 +909,27 @@ transpileWalk _ headerFile t _ = case () of Maybe (t Checked f a) castTS = cast + writeSIntf :: QualifiedPath String -> SIntf -> M () + writeSIntf qp si = do + let typename = qualifiedPathToIdentifier qp <> "__intf" + + checkout intfF $ do + text "typedef " + sIntfToC si + text $ " " <> typename <> ";\n\n" + + withCMacroMode $ do + text $ + "#define " + <> Text.toUpper (qualifiedPathToIdentifier qp) + <> "_INTF ((" + <> typename + <> ")" + sIntfToRVal si + text ")" + + text "\n\n" + getExportedObjectDecl :: FiddleDecl Checked I A -> Maybe ExportedObjectDecl getExportedObjectDecl (ObjectDecl {objectQualificationMetadata = Identity (Present decl)}) = Just decl getExportedObjectDecl _ = Nothing |