diff options
| -rw-r--r-- | goal.fiddle | 25 | ||||
| -rw-r--r-- | src/Language/Fiddle/Ast.hs | 21 | ||||
| -rw-r--r-- | src/Language/Fiddle/Compiler/Stage1.hs | 20 | ||||
| -rw-r--r-- | src/Language/Fiddle/Compiler/Stage2.hs | 143 | ||||
| -rw-r--r-- | src/Language/Fiddle/GenericTree.hs | 2 | ||||
| -rw-r--r-- | src/Language/Fiddle/Parser.hs | 35 | ||||
| -rw-r--r-- | src/Language/Fiddle/Tokenizer.hs | 5 | ||||
| -rw-r--r-- | vim/syntax/fiddle.vim | 9 |
8 files changed, 204 insertions, 56 deletions
diff --git a/goal.fiddle b/goal.fiddle index c35e172..708a44d 100644 --- a/goal.fiddle +++ b/goal.fiddle @@ -4,27 +4,31 @@ option processor arm_cortex_m4; option align 32; import "./types.fdl" (data_t); - -[[ search = ".local/fiddle/libs" ]] import "./stm32l432.fdl"; +package fiddle.lang { + bits data_t : enum(1) { + high = 0b1, + low = 0b0, + }; +}; + [[ cpp: namespace = "stm32l432::gpio" ]] [[ rust: package = "Stm32l432.Gpio" ]] [[ zig: package = "stm32l432.gpio" ]] [[ c: prefix = "stm32l432_gpio_" ]] -package gpio { - +package stm32l4.gpio { location gpio_a_base = 0x4800_0000; location gpio_b_base = 0x4800_0400; location gpio_c_base = 0x4800_0800; - bits data_t : enum(1) { - high = 0b1, - low = 0b0, - }; + using stm32l432; /** * Structure of the GPIO port on an stm32l432 + */ + type gpio_t : struct { + assert_pos(0); reg (32) : struct { /** The mode for each pin. */ @@ -122,7 +126,7 @@ package gpio { union { assert_pos(0x10); ro reg (32) : struct { - id_r : data_t[16]; + id_r : fiddle.lang.data_t[16]; reserved(16); }; @@ -149,7 +153,7 @@ package gpio { assert_pos(0x14); wo reg (32) : struct { union { - rw od_r : data_t[16]; + rw od_r : fiddle.lang.data_t[16]; struct { rw osp_v : (15); @@ -215,6 +219,7 @@ package gpio { reg(32) : struct { asc_r : (16); + [[ export_as = "ascr_upper" ]] reserved (16); }; }; diff --git a/src/Language/Fiddle/Ast.hs b/src/Language/Fiddle/Ast.hs index bb6605e..8680790 100644 --- a/src/Language/Fiddle/Ast.hs +++ b/src/Language/Fiddle/Ast.hs @@ -11,6 +11,7 @@ module Language.Fiddle.Ast where import Data.Functor.Identity import Data.Kind (Type) +import Data.List.NonEmpty import Data.Proxy import Data.Text (Text) import Data.Traversable @@ -47,6 +48,16 @@ type family ImportType (stage :: Stage) :: SynTreeKind where ImportType Stage2 = ImportStatement ImportType Stage3 = ImportStatement +-- Type-level constraint to determine if a stage is less than some natural +-- ordinal. Used to bound parts of the AST in multiple stages. +type StageLessThan stage (n :: Natural) = (CmpNat (StageNumber stage) n ~ LT) + +-- A Name is multiple identifiers separated by dots. It's the way of namespaces +-- to different packages. +data Name f a where + Name :: NonEmpty (Identifier f a) -> a -> Name f a + deriving (Generic, Annotated, Alter, Typeable) + -- [[packed, rust: name="field_name"]] data Directive f a where Directive :: f (DirectiveBody f a) -> a -> Directive f a @@ -146,9 +157,11 @@ data FiddleDecl (stage :: Stage) (f :: Type -> Type) a where ImportType stage f a -> a -> FiddleDecl stage f a + UsingDecl :: + Name f a -> a -> FiddleDecl stage f a {- Package Statement. Package Name, Package body -} PackageDecl :: - Identifier f a -> + Name f a -> f (PackageBody stage f a) -> a -> FiddleDecl stage f a @@ -197,11 +210,9 @@ data ObjType stage f a where -- <type>[<expr>] ArrayObjType :: ObjType stage f a -> Expression stage f a -> a -> ObjType stage f a -- <identifier> - ReferencedObjType :: Identifier f a -> a -> ObjType stage f a + ReferencedObjType :: Name f a -> a -> ObjType stage f a deriving (Typeable) -type StageLessThan stage (n :: Natural) = (CmpNat (StageNumber stage) n ~ LT) - data ObjTypeDecl stage f a where {- assert_pos(<expr>) -} AssertPosStatement :: @@ -278,7 +289,7 @@ data RegisterBitsTypeRef stage f a where a -> RegisterBitsTypeRef stage f a {- Reference to a type. -} - RegisterBitsReference :: Identifier f a -> a -> RegisterBitsTypeRef stage f a + RegisterBitsReference :: Name f a -> a -> RegisterBitsTypeRef stage f a {- enum(<expr>) { <body> } Anonymous types are only allowed in stage1. Stage2 should de-anonymize these type. -} diff --git a/src/Language/Fiddle/Compiler/Stage1.hs b/src/Language/Fiddle/Compiler/Stage1.hs index 2e3acbc..a17afa1 100644 --- a/src/Language/Fiddle/Compiler/Stage1.hs +++ b/src/Language/Fiddle/Compiler/Stage1.hs @@ -5,6 +5,7 @@ module Language.Fiddle.Compiler.Stage1 (toStage2) where +import qualified Data.List.NonEmpty as NonEmpty import Control.Monad.Identity (Identity (..)) import Control.Monad.State (get, gets, modify, put) import qualified Data.Char as Char @@ -94,13 +95,17 @@ reconfigureFiddleDecls p decls = do pushId :: Identifier f a -> Path -> Path pushId (Identifier str _) (Path lst) = Path (PathExpression (Text.unpack str) : lst) +pushName :: Name f a -> Path -> Path +pushName (Name idents _) path = + foldl (flip pushId) path idents fiddleDeclToStage2 :: Path -> FiddleDecl Stage1 I Annot -> M Annot (FiddleDecl Stage2 I Annot) fiddleDeclToStage2 path decl = do case decl of (OptionDecl i1 i2 a) -> return $ OptionDecl i1 i2 a - (PackageDecl i (Identity body) a) -> do - (PackageDecl i . Identity <$> packageBodyToStage2 (pushId i path) body) <*> pure a + (PackageDecl n (Identity body) a) -> do + (PackageDecl n . Identity <$> packageBodyToStage2 (pushName n path) body) <*> pure a + (UsingDecl n a) -> return $ UsingDecl n a (LocationDecl i expr a) -> LocationDecl i <$> toStage2Expr expr <*> pure a (BitsDecl i typ a) -> BitsDecl i <$> bitsTypeToStage2 (pushId i path) typ <*> pure a (ObjTypeDecl i body a) -> ObjTypeDecl i <$> mapM (objTypeBodyToStage2 (pushId i path)) body <*> pure a @@ -178,11 +183,14 @@ registerBitsTypeRefToStage2 path = \case <$> registerBitsTypeRefToStage2 path typeref <*> toStage2Expr expr <*> pure annot - RegisterBitsReference ident annot -> return (RegisterBitsReference ident annot) + RegisterBitsReference name annot -> return (RegisterBitsReference name annot) RegisterBitsJustBits expr annot -> RegisterBitsJustBits <$> toStage2Expr expr <*> pure annot RegisterBitsAnonymousType anonType annot -> do ident <- internAnonymousBitsType path =<< anonymousBitsTypeToStage2 path anonType - return $ RegisterBitsReference ident annot + return $ RegisterBitsReference (identToName ident) annot + +identToName :: Identifier I a -> Name I a +identToName ident = Name (NonEmpty.singleton ident) (annot ident) anonymousBitsTypeToStage2 :: Path -> AnonymousBitsType Stage1 I Annot -> M Annot (AnonymousBitsType Stage2 I Annot) anonymousBitsTypeToStage2 path = \case @@ -197,8 +205,8 @@ objectTypeToStage2 path = \case (AnonymousObjType (Identity body) annot) -> do body' <- objTypeBodyToStage2 path body identifier <- internObjType path body' - return (ReferencedObjType identifier annot) - (ReferencedObjType ident annot) -> return $ ReferencedObjType ident annot + return (ReferencedObjType (identToName identifier) annot) + (ReferencedObjType name annot) -> return $ ReferencedObjType name annot (ArrayObjType objType expr a) -> ArrayObjType <$> objectTypeToStage2 path objType <*> toStage2Expr expr <*> pure a diff --git a/src/Language/Fiddle/Compiler/Stage2.hs b/src/Language/Fiddle/Compiler/Stage2.hs index 431fc76..57b0b55 100644 --- a/src/Language/Fiddle/Compiler/Stage2.hs +++ b/src/Language/Fiddle/Compiler/Stage2.hs @@ -7,15 +7,18 @@ -- statements and checks that they are consistent with the calculations. module Language.Fiddle.Compiler.Stage2 where -import Control.Monad (forM_, unless, when) -import Control.Monad.RWS (MonadWriter (tell), gets, modify') -import Data.Foldable (foldlM) +import Control.Monad (forM, forM_, unless, when) +import Control.Monad.RWS (MonadState (get), MonadWriter (tell), gets, modify') +import Data.Foldable (foldlM, Foldable (toList)) import Data.Functor.Identity import qualified Data.IntMap as IntMap import Data.Kind (Type) -import Data.List (intercalate) +import Data.List (inits, intercalate) +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as NonEmpty import Data.Map (Map) import qualified Data.Map as Map +import Data.Maybe (fromMaybe) import qualified Data.Set as Set import qualified Data.Text as Text import Data.Word @@ -33,29 +36,101 @@ type SizeBits = Word32 type SizeBytes = Word32 +data Scope t + = Scope + { subScopes :: Map String (Scope t), + scopeValues :: Map String t + } + +instance Semigroup (Scope t) where + (Scope a1 b1) <> (Scope a2 b2) = Scope (a1 <> a2) (b1 <> b2) + +instance Monoid (Scope t) where + mempty = Scope mempty mempty + +data ScopePath = ScopePath + { currentScope :: [String], + usingPaths :: [[String]] + } + +instance Semigroup ScopePath where + (ScopePath a1 b1) <> (ScopePath a2 b2) = ScopePath (a1 <> a2) (b1 <> b2) + +instance Monoid ScopePath where + mempty = ScopePath mempty mempty + +emptyScope :: Scope t +emptyScope = Scope mempty mempty + +insertScope :: NonEmpty String -> t -> Scope t -> Scope t +insertScope (s :| []) v (Scope ss sv) = Scope ss (Map.insert s v sv) +insertScope (s :| (a : as)) v (Scope ss sv) = + Scope + ( Map.alter + ( \case + (fromMaybe emptyScope -> mp) -> Just (insertScope (a :| as) v mp) + ) + s + ss + ) + sv + +lookupScope :: NonEmpty String -> Scope t -> Maybe t +lookupScope (s :| []) (Scope _ sv) = Map.lookup s sv +lookupScope (s :| (a : as)) (Scope ss _) = do + subscope <- Map.lookup s ss + lookupScope (a :| as) subscope + +lookupScopeWithPath :: ScopePath -> NonEmpty String -> Scope t -> Maybe t +lookupScopeWithPath (ScopePath current others) key scope = + let all = reverse (inits current) ++ others + e = forM all $ \prefix -> do + case lookupScope (NonEmpty.prependList prefix key) scope of + Just s -> Left s + Nothing -> Right () + in case e of + Left v -> Just v + Right _ -> Nothing + data Stage3State = Stage3State - { typeSizes :: Map String SizeBits, - objectSizes :: Map String SizeBytes, - cursorBytes :: Word32, - cursorBits :: Word32 + { inScope :: Scope (Either SizeBits SizeBytes), + scopePath :: ScopePath } -addTypeSize :: Identifier f a -> SizeBits -> Compile Stage3State () -addTypeSize (Identifier s _) size = do +insertTypeSize :: Identifier f a -> SizeBits -> Compile Stage3State () +insertTypeSize (Identifier s _) size = do modify' $ \stage3State -> - stage3State {typeSizes = Map.insert (Text.unpack s) size (typeSizes stage3State)} - -lookupTypeSize :: Identifier I Annot -> Compile Stage3State SizeBits -lookupTypeSize (Identifier s a) = do - mSize <- gets $ Map.lookup (Text.unpack s) . typeSizes + let fullName = + NonEmpty.prependList + ((currentScope . scopePath) stage3State) + (NonEmpty.singleton (Text.unpack s)) + in stage3State + { inScope = + insertScope fullName (Right size) (inScope stage3State) + } + +-- addTypeSize :: Identifier f a -> SizeBits -> Compile Stage3State () +-- addTypeSize (Identifier s _) size = do +-- modify' $ +-- \stage3State -> +-- stage3State {typeSizes = Map.insert (Text.unpack s) size (typeSizes stage3State)} + +lookupTypeSize :: Name I Annot -> Compile Stage3State SizeBits +lookupTypeSize (Name idents a) = do + let path = fmap (\(Identifier s _) -> Text.unpack s) idents + scopePath <- gets scopePath + mSize <- gets $ lookupScopeWithPath scopePath path . inScope case mSize of - Just sz -> return sz - Nothing -> do + Just (Right sz) -> return sz + _ -> do tell [ Diagnostic Error - (printf "%s is not declared" s) + ( printf + "Cannot resolve %s" + (intercalate "." $ NonEmpty.toList path) + ) (unCommented a) ] compilationFailure @@ -65,7 +140,7 @@ expressionToStage3 = \case LitNum n a -> LitNum n a Var i a -> Var i a -emptyState = Stage3State mempty mempty 0 0 +emptyState = Stage3State mempty mempty toStage3 :: FiddleUnit Stage2 I Annot -> Compile () (FiddleUnit Stage3 I Annot) toStage3 (FiddleUnit decls a) = @@ -126,14 +201,36 @@ getTypeSize (EnumBitType expr (Identity (EnumBody constants _)) ann) = do return declaredSize +addCurrentScope :: [String] -> Compile Stage3State () +addCurrentScope s = do + modify' $ \st@(Stage3State {scopePath = (ScopePath current others)}) -> + st {scopePath = ScopePath (current ++ s) others} + fiddleDeclToStage3 :: FiddleDecl Stage2 I Annot -> Compile Stage3State (FiddleDecl Stage3 I Annot) fiddleDeclToStage3 = \case OptionDecl i1 i2 a -> return $ OptionDecl i1 i2 a - PackageDecl id body a -> PackageDecl id <$> mapM packageBodyToStage3 body <*> pure a + PackageDecl n@(Name idents _) body a -> do + let strs = map (\(Identifier (Text.unpack -> s) _) -> s) (toList idents) + Stage3State {scopePath = savedScopePath} <- get + addCurrentScope strs + PackageDecl n + <$> mapM packageBodyToStage3 body + <*> pure a + <* modify' (\st -> st {scopePath = savedScopePath}) + UsingDecl n@(Name idents _) a -> do + let strs = map (\(Identifier t _) -> Text.unpack t) (toList idents) + modify' + ( \st -> + let (ScopePath cur using) = scopePath st + in st + { scopePath = ScopePath cur (strs : using) + } + ) + return $ UsingDecl n a LocationDecl id expr a -> return $ LocationDecl id (expressionToStage3 expr) a BitsDecl id typ a -> do typeSize <- getTypeSize typ - addTypeSize id typeSize + insertTypeSize id typeSize BitsDecl id <$> bitTypeToStage3 typ <*> pure a ObjTypeDecl ident body a -> ObjTypeDecl ident <$> mapM (\bt -> fst <$> objTypeBodyToStage3 bt 0) body <*> pure a @@ -250,8 +347,8 @@ registerBitsTypeRefToStage3 = \case ( RegisterBitsArray ref' (expressionToStage3 expr) a, size * fromIntegral multiplier ) - RegisterBitsReference ident a -> - (RegisterBitsReference ident a,) <$> lookupTypeSize ident + RegisterBitsReference name a -> + (RegisterBitsReference name a,) <$> lookupTypeSize name RegisterBitsJustBits expr a -> (RegisterBitsJustBits (expressionToStage3 expr) a,) . fromIntegral diff --git a/src/Language/Fiddle/GenericTree.hs b/src/Language/Fiddle/GenericTree.hs index 46c0594..598336a 100644 --- a/src/Language/Fiddle/GenericTree.hs +++ b/src/Language/Fiddle/GenericTree.hs @@ -179,6 +179,8 @@ instance (GToGenericSyntaxTree r f a) => (GToGenericSyntaxTree (M1 i c r) f a) w deriving instance (ToGenericSyntaxTree Identifier) +deriving instance (ToGenericSyntaxTree Name) + deriving instance (ToGenericSyntaxTree BodyType) deriving instance (ToGenericSyntaxTree Directive) diff --git a/src/Language/Fiddle/Parser.hs b/src/Language/Fiddle/Parser.hs index f3ad744..b44a9a1 100644 --- a/src/Language/Fiddle/Parser.hs +++ b/src/Language/Fiddle/Parser.hs @@ -10,6 +10,7 @@ where import Control.Monad (void) import Data.Functor.Identity import Data.Kind (Type) +import Data.List.NonEmpty (NonEmpty (..)) import Data.Text (Text) import qualified Data.Text import Debug.Trace @@ -107,19 +108,24 @@ fiddleUnit = do <* many comment stringToken :: P Text -stringToken = token (\case - (TokString str) -> Just str - _ -> Nothing) +stringToken = + token + ( \case + (TokString str) -> Just str + _ -> Nothing + ) importList :: PaS ImportList importList = withMeta $ do tok TokLParen - ImportList <$> many (ident <* (tok TokComma <|> lookAhead (tok TokRParen))) - <* tok TokRParen + ImportList + <$> many (ident <* (tok TokComma <|> lookAhead (tok TokRParen))) + <* tok TokRParen importStatement :: PaS ImportStatement -importStatement = withMeta $ - ImportStatement <$> stringToken <*> optionMaybe importList +importStatement = + withMeta $ + ImportStatement <$> stringToken <*> optionMaybe importList fiddleDecl :: Pa FiddleDecl fiddleDecl = do @@ -129,8 +135,9 @@ fiddleDecl = do KWOption -> OptionDecl <$> nextText <*> nextText KWPackage -> PackageDecl - <$> ident + <$> name <*> defer body packageBody + KWUsing -> UsingDecl <$> name KWLocation -> LocationDecl <$> ident <*> (tok TokEq >> expression) KWBits -> BitsDecl <$> ident <*> (tok TokColon >> bitType) KWImport -> ImportDecl <$> importStatement @@ -185,7 +192,7 @@ objType = do baseObj :: P (A -> ObjType Stage1 F A) baseObj = - (ReferencedObjType <$> ident) + (ReferencedObjType <$> name) <|> ( do t <- bodyType AnonymousObjType <$> defer body (objTypeBody t) @@ -285,7 +292,7 @@ registerBitsTypeRef = do withMeta $ (RegisterBitsJustBits <$> exprInParen) <|> (RegisterBitsAnonymousType <$> anonymousBitsType) - <|> (RegisterBitsReference <$> ident) + <|> (RegisterBitsReference <$> name) anonymousBitsType :: Pa AnonymousBitsType anonymousBitsType = withMeta $ do @@ -390,6 +397,14 @@ ident = (TokIdent id) -> Just (Identifier id) _ -> Nothing +name :: PaS Name +name = withMeta $ do + i <- ident + is <- many $ do + tok TokDot + ident + return $ Name (i :| is) + -- Takes a some parsable thing p and automatically parses the comments before -- and after and sets the positions and adds it to the annotation. withMeta :: P (Commented SourceSpan -> b) -> P b diff --git a/src/Language/Fiddle/Tokenizer.hs b/src/Language/Fiddle/Tokenizer.hs index 87f119f..007009f 100644 --- a/src/Language/Fiddle/Tokenizer.hs +++ b/src/Language/Fiddle/Tokenizer.hs @@ -28,8 +28,10 @@ data T | KWUnion | KWWo | KWImport + | KWUsing | TokColon | TokComma + | TokDot | TokComment !Text | TokDocComment !Text | TokEq @@ -67,6 +69,7 @@ textOf t = do KWUnion -> Just "union" KWWo -> Just "wo" KWImport -> Just "import" + KWUsing -> Just "using" TokIdent i -> Just i TokLitNum n -> Just n _ -> Nothing @@ -101,6 +104,7 @@ parseToken = spaces *> tok parseToken' <* spaces "rw" -> KWRw "reserved" -> KWReserved "union" -> KWUnion + "using" -> KWUsing "struct" -> KWStruct "assert_pos" -> KWAssertPos (Data.Text.head -> h) | isDigit h -> TokLitNum str @@ -137,6 +141,7 @@ parseToken = spaces *> tok parseToken' <* spaces try (string "]]" $> TokDirectiveEnd), char ':' $> TokColon, char ',' $> TokComma, + char '.' $> TokDot, char '=' $> TokEq, char '{' $> TokLBrace, char '[' $> TokLBracket, diff --git a/vim/syntax/fiddle.vim b/vim/syntax/fiddle.vim index 70a3f26..416b4a7 100644 --- a/vim/syntax/fiddle.vim +++ b/vim/syntax/fiddle.vim @@ -1,4 +1,4 @@ -syn keyword FiddlePackage option package nextgroup=FiddleIdent skipwhite +syn keyword FiddlePackage option package nextgroup=FiddleName skipwhite syn keyword FiddleDecl reg instance at location reserved nextgroup=FiddleIdent skipwhite syn keyword FiddleTypeDecl type regtype bits nextgroup=FiddleIdent skipwhite syn keyword FiddleEnum enum @@ -6,8 +6,11 @@ syn keyword FiddleBuiltin assert_pos syn keyword FiddleModifier wo ro rw syn keyword FiddleStorageClass struct union bitstruct bitunion +syn match FiddleUsing +using+ nextgroup=FiddleName skipwhite + syn match FiddleColon +:+ skipwhite nextgroup=FiddleContainedType -syn match FiddleContainedType +[a-zA-Z0-9_]\++ contained +syn match FiddleContainedType +[a-zA-Z0-9_.]\++ contained +syn match FiddleName +\<[a-zA-Z0-9_.]\+\>+ contained syn match FiddleIdent +[A-Za-z0-9_]\++ contained @@ -33,6 +36,7 @@ hi! link FiddleString String hi! link FiddleDirective PreProc hi! link FiddleContainedType Type hi! link FiddleModifier StorageClass +hi! link FiddleUsing StorageClass hi! link FiddleBuiltin Function hi! link FiddleEnum StorageClass hi! link FiddleStorageClass FiddleEnum @@ -43,3 +47,4 @@ hi! link FiddleComment Comment hi! link FiddlePackage Include hi! link FiddleTypeDecl StorageClass hi! link FiddleIdent Identifier +hi! link FiddleName Identifier |