summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Language/Fiddle/Ast/Internal/SyntaxTree.hs28
-rw-r--r--src/Language/Fiddle/Compiler/Backend/C.hs34
-rw-r--r--src/Language/Fiddle/Compiler/ConsistencyCheck.hs39
-rw-r--r--src/Language/Fiddle/Compiler/Expansion.hs7
-rw-r--r--src/Language/Fiddle/Compiler/ImportResolution.hs11
-rw-r--r--src/Language/Fiddle/Compiler/Qualification.hs98
-rw-r--r--src/Language/Fiddle/GenericTree.hs2
-rw-r--r--src/Language/Fiddle/Parser.hs13
-rw-r--r--src/Language/Fiddle/Tokenizer.hs6
9 files changed, 188 insertions, 50 deletions
diff --git a/src/Language/Fiddle/Ast/Internal/SyntaxTree.hs b/src/Language/Fiddle/Ast/Internal/SyntaxTree.hs
index b597a25..2774507 100644
--- a/src/Language/Fiddle/Ast/Internal/SyntaxTree.hs
+++ b/src/Language/Fiddle/Ast/Internal/SyntaxTree.hs
@@ -18,7 +18,7 @@ module Language.Fiddle.Ast.Internal.SyntaxTree
FieldSpan (..),
QRegMetadata (..),
QBitsMetadata (..),
- RegSz(..),
+ RegSz (..),
-- Witness Types
Witness (..),
-- AST Types
@@ -107,7 +107,7 @@ deriving instance
(FromJSON (When s (FieldSpan Bytes))) =>
FromJSON (QRegMetadata s)
-data RegSz = RegSz8 | RegSz16 | RegSz32 | RegSz64
+data RegSz = RegSz8 | RegSz16 | RegSz32 | RegSz64
deriving (Eq, Ord, Show, Enum, Generic, ToJSON, FromJSON)
regSzToBits :: RegSz -> N Bits
@@ -519,6 +519,30 @@ data ObjTypeDecl stage f a where
assertAnnot :: a
} ->
ObjTypeDecl stage f a
+ -- | A character buffer
+ BufferDecl ::
+ { -- | Metadata about this declaration.
+ qRegMeta :: When (stage .>= Qualified) (QRegMetadata (stage .>= Checked)),
+ -- | Identifier for this buffer
+ bufIdent :: Guaranteed (stage .>= Qualified) (Identifier f a),
+ -- | Size of this buffer
+ bufSize :: ConstExpression Bytes stage f a,
+ -- | Annotation for this buf statement.
+ bufAnnot :: a
+ } ->
+ ObjTypeDecl stage f a
+ SkipToStatement ::
+ { -- | Witness that we are in the proper stage. These statements will turn
+ -- into buffer statements during the consistency check.
+ disableSkipToStatementsAfterConsistencyCheck :: Witness (stage .< Checked),
+ -- | Metadata
+ qRegMeta :: When (stage .>= Qualified) (QRegMetadata (stage .>= Checked)),
+ -- | The address to skip to.
+ skipToExpression :: ConstExpression Bytes stage f a,
+ -- | The annotation of the skipToStatement
+ skipToAnnot :: a
+ } ->
+ ObjTypeDecl stage f a
-- | A register declaration.
RegisterDecl ::
{ -- | Offset within the register. Calculated during the consistency check.
diff --git a/src/Language/Fiddle/Compiler/Backend/C.hs b/src/Language/Fiddle/Compiler/Backend/C.hs
index e9989a0..4b4b3ea 100644
--- a/src/Language/Fiddle/Compiler/Backend/C.hs
+++ b/src/Language/Fiddle/Compiler/Backend/C.hs
@@ -42,8 +42,8 @@ newtype CBackendFlags = CBackendFlags
data SIntfF
= SIntfF
- { sIntfFValue :: Text,
- sIntfFComemnts :: FormattedWriter ()
+ { _sIntfFValue :: Text,
+ _sIntfFComemnts :: FormattedWriter ()
}
newtype SIntf
@@ -220,15 +220,6 @@ transpile
Text.replace "/" "_" $
Text.pack headerFile
-class IsText t where
- toText :: t -> Text
-
-instance IsText String where
- toText = Text.pack
-
-instance IsText Text where
- toText = id
-
qualifiedPathToIdentifier :: QualifiedPath String -> Text
qualifiedPathToIdentifier = Text.pack . qualifiedPathToString "__" "_"
@@ -400,8 +391,9 @@ writeBitsGet structName regmeta fullPath offset typeRef docComms = do
unless (null shiftArguments) $
text ", "
- text $ Text.intercalate ", " $
- zipWith (\f _ -> "int " <> f) (tail setterArgumentNames) shiftArguments
+ text $
+ Text.intercalate ", " $
+ zipWith (\f _ -> "int " <> f) (tail setterArgumentNames) shiftArguments
text ") {\n"
@@ -715,6 +707,20 @@ structBody structName (ObjTypeBody _ decls _) = do
checkout iF $
(if regIsUnnamed regMetadata then id else sIntfSingleton i)
<$> writeImplementation structName regMetadata mod bod ann
+ BufferDecl
+ { bufIdent = Guaranteed (identToString -> i),
+ bufSize = (trueValue -> size),
+ bufAnnot = ann
+ } -> do
+ textM $ do
+ emitDocComments ann
+ tell "uint8_t "
+ tell (Text.pack i)
+ tell "["
+ tell $ Text.pack (show size)
+ tell "];\n"
+
+ return mempty
TypeSubStructure
{ subStructureBody = Identity bod,
subStructureName = mname
@@ -864,7 +870,7 @@ emitEnum (qualifiedPathToIdentifier -> ident) consts = do
transpileWalk ::
FilePath ->
(forall t. (Walk t, Typeable t) => t I A -> () -> M (WalkContinuation ()))
-transpileWalk headerFile t _ = case () of
+transpileWalk _headerFile t _ = case () of
()
| Just
( ObjTypeDecl
diff --git a/src/Language/Fiddle/Compiler/ConsistencyCheck.hs b/src/Language/Fiddle/Compiler/ConsistencyCheck.hs
index 00a53dc..c34007f 100644
--- a/src/Language/Fiddle/Compiler/ConsistencyCheck.hs
+++ b/src/Language/Fiddle/Compiler/ConsistencyCheck.hs
@@ -15,6 +15,7 @@ import Data.Functor.Identity
import qualified Data.IntMap as IntMap
import Data.List (intercalate)
import qualified Data.List.NonEmpty as NonEmpty
+import qualified Data.Text as Text
import Data.Typeable
import GHC.TypeError as TypeError
import Language.Fiddle.Ast
@@ -155,6 +156,44 @@ advanceObjTypeBody (ObjTypeBody us decls a) startOffset = do
assertedPos <- expressionToIntM expr
checkPositionAssertion (annot e) assertedPos offset
return (ret, offset)
+ (SkipToStatement _ qmeta expr ann) -> do
+ let pos = trueValue expr
+ sz = if pos < offset then 0 else pos - offset
+ span = Present (FieldSpan offset sz)
+ qmeta' = fmap (\q -> q {regSpan = span}) qmeta
+
+ szExpr = ConstExpression (LeftV sz) (annot expr)
+ in do
+ if pos < offset
+ then do
+ emitDiagnosticError "Skip to backwards" ann
+ return (ret, offset)
+ else
+ if sz == 0
+ then
+ return (ret, offset)
+ else do
+ doReturn
+ ( BufferDecl
+ qmeta'
+ ( Guaranteed
+ ( Identifier
+ ( Text.pack $
+ basenamePart (regFullPath (unwrap qmeta'))
+ )
+ a
+ )
+ )
+ szExpr
+ ann
+ )
+ sz
+ (BufferDecl qmeta (Guaranteed ident) sz a) -> do
+ sz' <- advanceStage () sz
+ let size = trueValue sz'
+ 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
let declaredSize = regSzToBits (getLeft size)
reifiedSizeBytes <- checkBitsSizeMod8 a declaredSize
diff --git a/src/Language/Fiddle/Compiler/Expansion.hs b/src/Language/Fiddle/Compiler/Expansion.hs
index 5e7063e..94042a2 100644
--- a/src/Language/Fiddle/Compiler/Expansion.hs
+++ b/src/Language/Fiddle/Compiler/Expansion.hs
@@ -6,11 +6,8 @@
module Language.Fiddle.Compiler.Expansion (expandAst, expansionPhase) where
-import Control.Monad.Identity (Identity (..))
import Control.Monad.State (get, modify, put)
import qualified Data.Char as Char
-import Data.List (intercalate)
-import Data.List.NonEmpty (NonEmpty, (<|))
import qualified Data.List.NonEmpty as NonEmpty
import Data.Text (Text)
import qualified Data.Text as Text
@@ -209,8 +206,8 @@ reconfigureFiddleDecls p decls = do
(EnumBitType expr body a)
a
-identToName :: Identifier I a -> Name I a
-identToName ident = Name (NonEmpty.singleton ident) (annot ident)
+-- identToName :: Identifier I a -> Name I a
+-- identToName ident = Name (NonEmpty.singleton ident) (annot ident)
internObjType :: Path -> ObjTypeBody Expanded I Annot -> M (Name I Annot)
internObjType [] _ = compilationFailure
diff --git a/src/Language/Fiddle/Compiler/ImportResolution.hs b/src/Language/Fiddle/Compiler/ImportResolution.hs
index a9c4c8e..d4d6a05 100644
--- a/src/Language/Fiddle/Compiler/ImportResolution.hs
+++ b/src/Language/Fiddle/Compiler/ImportResolution.hs
@@ -11,7 +11,6 @@ where
import qualified Codec.Compression.GZip as GZip
import Control.Arrow (Arrow (second))
import Control.Monad (filterM, when)
-import Control.Monad.Identity (Identity)
import Control.Monad.State (put)
import Control.Monad.Trans.Maybe (MaybeT (MaybeT, runMaybeT))
import Control.Monad.Writer.Lazy (MonadTrans (lift), MonadWriter (tell), WriterT (..), execWriterT)
@@ -303,11 +302,11 @@ runCompl c = (\(x, (y, z)) -> (y, z, x)) <$> runWriterT (runMaybeT c)
type Compl a = MaybeT (WriterT ([Diagnostic], [Artifact]) IO) a
-allM :: (Monad m) => (a -> m Bool) -> [a] -> m Bool
-allM _ [] = return True
-allM fn (a : as) = do
- b <- fn a
- if b then allM fn as else return False
+-- allM :: (Monad m) => (a -> m Bool) -> [a] -> m Bool
+-- allM _ [] = return True
+-- allM fn (a : as) = do
+-- b <- fn a
+-- if b then allM fn as else return False
anyM :: (Monad m) => (a -> m Bool) -> [a] -> m Bool
anyM _ [] = return True
diff --git a/src/Language/Fiddle/Compiler/Qualification.hs b/src/Language/Fiddle/Compiler/Qualification.hs
index 103c7a1..8bae2de 100644
--- a/src/Language/Fiddle/Compiler/Qualification.hs
+++ b/src/Language/Fiddle/Compiler/Qualification.hs
@@ -14,11 +14,9 @@ import Control.Monad.RWS (MonadWriter (tell))
import Control.Monad.State
import Data.Foldable (foldlM, toList)
import Data.List (intercalate)
-import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.List.NonEmpty as NonEmpty
import Data.Maybe (isNothing, mapMaybe)
import qualified Data.Text
-import Data.Word
import Language.Fiddle.Ast
import Language.Fiddle.Compiler
import Language.Fiddle.Compiler.ConsistencyCheck ()
@@ -193,6 +191,41 @@ instance AdvanceStage S ObjTypeDecl where
advanceStage localState = \case
AssertPosStatement d e a ->
AssertPosStatement d <$> advanceStage localState e <*> pure a
+ SkipToStatement d _ e a -> do
+ ident' <- uniqueIdentifier "reg" a
+ let (qualified, localState') = pushRegister (identToString ident') localState
+
+ let qRegMeta =
+ QRegMetadata
+ { regSpan = Vacant,
+ regIsPadding = True,
+ regIsUnnamed = True,
+ regFullPath = qualified
+ }
+
+ SkipToStatement d (Present qRegMeta) <$> advanceStage localState' e <*> pure a
+ BufferDecl _ ident sz ann -> do
+ ident' <- guaranteeM (uniqueIdentifier "reg" ann) ident
+
+ let (qualified, localState') =
+ pushRegister (identToString $ unwrap ident') localState
+ -- Avoid pushing the anonymized name onto the stack.
+ localState'' =
+ if isNothing (toMaybe ident) then localState else localState'
+
+ let qRegMeta =
+ QRegMetadata
+ { regSpan = Vacant,
+ regIsPadding = False,
+ regIsUnnamed = isNothing (toMaybe ident),
+ regFullPath = qualified
+ }
+
+ BufferDecl
+ (Present qRegMeta)
+ ident'
+ <$> advanceStage localState'' sz
+ <*> pure ann
RegisterDecl _ mod ident size bod ann -> do
ident' <- guaranteeM (uniqueIdentifier "reg" ann) ident
@@ -430,18 +463,14 @@ advanceFiddleDecls localState decls = fmap (reverse . fst) $ do
(fmap identToString ids)
localState'
in do
- typeSize <- calculateTypeSize =<< resolveOrFail body
+ body' <- mapM (advanceStage localState'') body
+ typeSize <- calculateTypeSize =<< resolveOrFail body'
let decl =
ExportedTypeDecl
(metadata qualifiedName)
typeSize
insertDecl decl
- doReturn
- =<< ObjTypeDecl
- (qMd decl)
- name
- <$> mapM (advanceStage localState'') body
- <*> pure ann
+ doReturn $ ObjTypeDecl (qMd decl) name body' ann
ObjectDecl _ ident loc typ ann ->
let qualifiedName =
fmap
@@ -482,21 +511,44 @@ objTypeToExport ls = \case
(td :: ExportedTypeDecl) <- resolveOrFail =<< resolveName n ls
return $ ReferencedObjectType (metadataFullyQualifiedPath $ getMetadata td)
-calculateTypeSize :: ObjTypeBody Expanded F A -> M (N Bytes)
-calculateTypeSize (ObjTypeBody bodyType decls _) =
- ( case bodyType of
- Union {} -> maximum
- Struct {} -> sum
- )
- <$> mapM calculateDeclSize decls
+calculateTypeSize :: ObjTypeBody Qualified F A -> M (N Bytes)
+calculateTypeSize (ObjTypeBody bodyType decls _) = do
+ (summed, maxxed) <- foldlM f (0, 0) decls
+ return $
+ case bodyType of
+ Union {} -> maxxed
+ Struct {} -> summed
where
- calculateDeclSize :: Directed ObjTypeDecl Expanded F A -> M (N Bytes)
- calculateDeclSize (undirected -> decl) =
- case decl of
- AssertPosStatement {} -> return 0
- RegisterDecl {regSize = size} -> fst . bitsToBytes <$> expressionToIntM (getRight size)
- ReservedDecl {reservedExpr = size} -> fst . bitsToBytes <$> expressionToIntM size
- TypeSubStructure {subStructureBody = b} -> calculateTypeSize =<< resolveOrFail b
+ f :: (N Bytes, N Bytes) -> Directed ObjTypeDecl Qualified F A -> M (N Bytes, N Bytes)
+ f (pos, mx) decl = case undirected decl of
+ AssertPosStatement {} -> return (pos, mx)
+ RegisterDecl {regSize = size} -> do
+ let v = fst $ bitsToBytes $ regSzToBits $ getLeft size
+ return (pos + v, max mx v)
+ SkipToStatement _ _ expr ann -> do
+ let newLoc = getLeft (constExpression expr)
+ sz = newLoc - pos
+ in do
+ if newLoc < pos
+ then do
+ emitDiagnosticError "Skip to location already passed." ann
+ return (pos, mx)
+ else
+ return (pos + sz, max mx sz)
+ BufferDecl {bufSize = expr} ->
+ let v = getLeft (constExpression expr)
+ in return (pos + v, max mx v)
+ TypeSubStructure {subStructureBody = b} -> do
+ v <- calculateTypeSize =<< resolveOrFail b
+ return (pos + v, max mx v)
+
+-- calculateDeclSize :: Directed ObjTypeDecl Qualified F A -> M (N Bytes)
+-- calculateDeclSize (undirected -> decl) =
+-- case decl of
+-- AssertPosStatement {} -> return 0
+-- RegisterDecl {regSize = size} -> fst . bitsToBytes <$> expressionToIntM (getRight size)
+-- ReservedDecl {reservedExpr = size} -> fst . bitsToBytes <$> expressionToIntM size
+-- TypeSubStructure {subStructureBody = b} -> calculateTypeSize =<< resolveOrFail b
getBitTypeDeclaredSize :: BitType Expanded F A -> M (N Bits)
getBitTypeDeclaredSize = \case
diff --git a/src/Language/Fiddle/GenericTree.hs b/src/Language/Fiddle/GenericTree.hs
index 7e8d79b..a713e71 100644
--- a/src/Language/Fiddle/GenericTree.hs
+++ b/src/Language/Fiddle/GenericTree.hs
@@ -278,4 +278,6 @@ deriving instance (Context stage) => (ToGenericSyntaxTree (ConstExpression Addre
deriving instance (Context stage) => (ToGenericSyntaxTree (ConstExpression Bits stage))
+deriving instance (Context stage) => (ToGenericSyntaxTree (ConstExpression Bytes stage))
+
deriving instance (Context stage) => (ToGenericSyntaxTree (Expression u stage))
diff --git a/src/Language/Fiddle/Parser.hs b/src/Language/Fiddle/Parser.hs
index 415852c..c3056bd 100644
--- a/src/Language/Fiddle/Parser.hs
+++ b/src/Language/Fiddle/Parser.hs
@@ -199,6 +199,9 @@ asConstP fn = withMeta $ ConstExpression . RightV <$> fn
exprInParenP :: Pa (Expression u)
exprInParenP = tok TokLParen *> expressionP <* tok TokRParen
+inParenP :: Pa a -> Pa a
+inParenP p = tok TokLParen *> p <* tok TokRParen
+
objTypeBodyP :: BodyType F (Commented SourceSpan) -> Pa ObjTypeBody
objTypeBodyP bt =
withMeta $
@@ -212,6 +215,16 @@ objTypeDeclP =
AssertPosStatement Witness <$> exprInParenP
)
<|> ( do
+ tok_ KWSkipTo
+ SkipToStatement Witness Vacant <$> inParenP constExpressionP
+ )
+ <|> ( do
+ tok_ KWBuffer
+ BufferDecl Vacant . Perhaps
+ <$> optionMaybe ident
+ <*> inParenP constExpressionP
+ )
+ <|> ( do
tok_ KWReserved
ReservedDecl Witness <$> exprInParenP
)
diff --git a/src/Language/Fiddle/Tokenizer.hs b/src/Language/Fiddle/Tokenizer.hs
index d2e5cf8..4590ed0 100644
--- a/src/Language/Fiddle/Tokenizer.hs
+++ b/src/Language/Fiddle/Tokenizer.hs
@@ -28,6 +28,8 @@ data T
| KWWo
| KWImport
| KWUsing
+ | KWSkipTo
+ | KWBuffer
| TokColon
| TokComma
| TokDot
@@ -69,6 +71,8 @@ textOf t = do
KWWo -> Just "wo"
KWImport -> Just "import"
KWUsing -> Just "using"
+ KWBuffer -> Just "buffer"
+ KWSkipTo -> Just "skip_to"
TokIdent i -> Just i
TokLitNum n -> Just n
_ -> Nothing
@@ -106,6 +110,8 @@ parseToken = spaces *> tok parseToken' <* spaces
"using" -> KWUsing
"struct" -> KWStruct
"assert_pos" -> KWAssertPos
+ "skip_to" -> KWSkipTo
+ "buffer" -> KWBuffer
(Data.Text.head -> h) | isDigit h -> TokLitNum str
ident -> TokIdent ident
generated by cgit (git 2.34.1) at 2025-04-28 20:50:49 +0000