diff options
| -rw-r--r-- | goal.fiddle | 92 | ||||
| -rw-r--r-- | package.yaml | 1 | ||||
| -rw-r--r-- | src/Language/Fiddle/Ast.hs | 35 | ||||
| -rw-r--r-- | src/Language/Fiddle/Compiler/Stage1.hs | 18 | ||||
| -rw-r--r-- | src/Language/Fiddle/Compiler/Stage2.hs | 202 | ||||
| -rw-r--r-- | src/Language/Fiddle/GenericTree.hs | 16 | ||||
| -rw-r--r-- | src/Language/Fiddle/Parser.hs | 51 | ||||
| -rw-r--r-- | src/Language/Fiddle/Tokenizer.hs | 22 | ||||
| -rw-r--r-- | vim/syntax/fiddle.vim | 8 |
9 files changed, 354 insertions, 91 deletions
diff --git a/goal.fiddle b/goal.fiddle index b87f0e9..b59acb4 100644 --- a/goal.fiddle +++ b/goal.fiddle @@ -1,6 +1,7 @@ option endian little; // package for the GPIO system. + package gpio { location gpio_a_base = 0x4800_0000; @@ -16,9 +17,9 @@ package gpio { /** * Structure of the GPIO port on an stm32l432 */ - objtype gpio_t : { + type gpio_t : struct { assert_pos(0); - reg (32) : { + reg (32) : struct { /** The mode for each pin. */ mode_r : enum(2) { /** The GPIO pin is used for input. */ @@ -44,7 +45,7 @@ package gpio { * The output type. */ assert_pos(0x04); - reg ocfg_reg(32) : { + reg ocfg_reg(32) : struct { otype_r : enum(1) { /** * The GPIO pin is capable of sinking to ground (for LOW) or providing @@ -66,7 +67,7 @@ package gpio { * Sets the speed of the provided GPIO pin. */ assert_pos(0x08); - reg (32) : { + reg (32) : struct { ospeed_r : enum(2) { low = 0, medium = 1, @@ -79,16 +80,26 @@ package gpio { * Pullup/Pulldown type */ assert_pos(0x0c); - wo reg (32) : { - pupd_r : enum(2) { - none = 0b0, - // Compiles to Gpio::PupdR::PullUp - pull_up = 0b1, - // Compiles to Gpio::PupdR::PullDown - pull_down = 0b10, - // Not used, but has to be included to fill out the enum. - reserved = 0b11, - } [16]; + wo reg (32) : struct { + union { + pupd_r : enum(2) { + none = 0b0, + // Compiles to Gpio::PupdR::PullUp + pull_up = 0b1, + // Compiles to Gpio::PupdR::PullDown + pull_down = 0b10, + // Not used, but has to be included to fill out the enum. + reserved = 0b11, + } [16]; + + struct { + alternate : enum(1) { + enabled = 0, + disabled = 1, + } [16]; + reserved(16); + }; + }; }; /** @@ -97,11 +108,26 @@ package gpio { * Reading form the provided pin will yield high if the pin is on, or low if * the pin is low. */ - assert_pos(0x10); - ro reg (32) : { - id_r : data_t[16]; - reserved(16); + union { + assert_pos(0x10); + ro reg (32) : struct { + id_r : data_t[16]; + reserved(16); + }; + + // Additinoal values . + assert_pos(0x10); + struct { + assert_pos(0x10); + wo reg alt_r1(16); + + assert_pos(0x12); + wo reg alt_r2(8); + reserved(8); + }; }; + assert_pos(0x14); + /** * Output data register. @@ -109,8 +135,18 @@ package gpio { * Writing to this register sets the appropriate register to low/high. */ assert_pos(0x14); - wo reg (32) : { - rw od_r : data_t[16]; + wo reg (32) : struct { + union { + rw od_r : data_t[16]; + + struct { + rw osp_v : (15); + // Without the reserved bit, the compiler will complain about jagged + // unions. + reserved(1); + }; + }; + reserved(16); }; @@ -118,7 +154,7 @@ package gpio { * The GPIO port bit set/reset register. */ assert_pos(0x18); - reg bsr_r(32) : { + reg bsr_r(32) : struct { /** * Sets the pins associated with the bits. Like od_r, but can be used to * turn on multiple pins at once. @@ -132,7 +168,7 @@ package gpio { }; assert_pos(0x1c); - reg(32) : { + reg(32) : struct { lock : enum(1) { unlocked = 0, locked = 1, @@ -148,7 +184,7 @@ package gpio { * Each nybble refers to a pin. */ assert_pos(0x20); - reg(64) : { + reg(64) : struct { afn : (4)[16]; }; @@ -156,7 +192,7 @@ package gpio { * The bit reset register. */ assert_pos(0x28); - reg(32) : { + reg(32) : struct { wo br_r : (16); reserved (16); }; @@ -164,13 +200,13 @@ package gpio { /** * Analog switch control for the pin. */ - reg(32) : { + reg(32) : struct { asc_r : (16); reserved (16); }; }; - object gpio_a at gpio_a_base : gpio_t; - object gpio_b at gpio_b_base : gpio_t; - object gpio_c at gpio_c_base : gpio_t; + instance gpio_a at gpio_a_base : gpio_t; + instance gpio_b at gpio_b_base : gpio_t; + instance gpio_c at gpio_c_base : gpio_t; }; diff --git a/package.yaml b/package.yaml index f2394a7..56f6ffd 100644 --- a/package.yaml +++ b/package.yaml @@ -35,3 +35,4 @@ dependencies: - data-default - transformers - containers + - optparse-applicative diff --git a/src/Language/Fiddle/Ast.hs b/src/Language/Fiddle/Ast.hs index d440a44..8352975 100644 --- a/src/Language/Fiddle/Ast.hs +++ b/src/Language/Fiddle/Ast.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} @@ -5,7 +6,6 @@ {-# LANGUAGE IncoherentInstances #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE ConstraintKinds #-} module Language.Fiddle.Ast where @@ -18,6 +18,8 @@ import Data.Typeable import GHC.Generics import GHC.TypeLits +-- The type of a number at each stage in compilation. Numbers should be parsed +-- in Stage2. type family NumberType (a :: Stage) where NumberType Stage1 = Text NumberType Stage2 = Integer @@ -88,7 +90,7 @@ data FiddleDecl (stage :: Stage) (f :: Type -> Type) a where deriving (Generic, Annotated, Alter, Typeable) data ObjTypeBody (stage :: Stage) (f :: Type -> Type) a where - ObjTypeBody :: [ObjTypeDecl stage f a] -> a -> ObjTypeBody stage f a + ObjTypeBody :: BodyType f a -> [ObjTypeDecl stage f a] -> a -> ObjTypeBody stage f a deriving (Generic, Annotated, Alter, Typeable) data ObjType stage f a where @@ -119,6 +121,14 @@ data ObjTypeDecl stage f a where Maybe (RegisterBody stage f a) -> a -> ObjTypeDecl stage f a + {- reserved(n); -} + ReservedDecl :: Expression stage f a -> a -> ObjTypeDecl stage f a + {- <struct|union> { subfields } <name>; -} + TypeSubStructure :: + f (ObjTypeBody stage f a) -> + Maybe (Identifier f a) -> + a -> + ObjTypeDecl stage f a deriving (Typeable) data Modifier f a where @@ -134,8 +144,13 @@ data DeferredRegisterBody stage f a where DeferredRegisterBody stage f a deriving (Generic, Annotated, Alter, Typeable) +data BodyType (f :: Type -> Type) a where + Union :: a -> BodyType f a + Struct :: a -> BodyType f a + deriving (Generic, Annotated, Alter, Typeable) + data RegisterBody stage f a where - RegisterBody :: f (DeferredRegisterBody stage f a) -> a -> RegisterBody stage f a + RegisterBody :: BodyType f a -> f (DeferredRegisterBody stage f a) -> a -> RegisterBody stage f a deriving (Generic, Annotated, Alter, Typeable) data RegisterBitsDecl stage f a where @@ -148,6 +163,11 @@ data RegisterBitsDecl stage f a where RegisterBitsTypeRef stage f a -> a -> RegisterBitsDecl stage f a + BitsSubStructure :: + RegisterBody stage f a -> + Maybe (Identifier f a) -> + a -> + RegisterBitsDecl stage f a deriving (Generic, Annotated, Alter, Typeable) data RegisterBitsTypeRef stage f a where @@ -195,6 +215,15 @@ instance Alter (ObjTypeDecl stage) where <*> alter ffn fn expr <*> mapM (alter ffn fn) mBody <*> fn a + (TypeSubStructure mBody mIdent a) -> + TypeSubStructure + <$> (ffn =<< mapM (alter ffn fn) mBody) + <*> mapM (alter ffn fn) mIdent + <*> fn a + (ReservedDecl expr a) -> + ReservedDecl + <$> alter ffn fn expr + <*> fn a instance Annotated (ObjTypeDecl stage) where annot = \case diff --git a/src/Language/Fiddle/Compiler/Stage1.hs b/src/Language/Fiddle/Compiler/Stage1.hs index 3a97757..25ee66b 100644 --- a/src/Language/Fiddle/Compiler/Stage1.hs +++ b/src/Language/Fiddle/Compiler/Stage1.hs @@ -123,11 +123,20 @@ enumConstantToStage2 path = \case EnumConstantReserved e a -> EnumConstantReserved <$> toStage2Expr e <*> pure a objTypeBodyToStage2 :: Path -> ObjTypeBody Stage1 I Annot -> M Annot (ObjTypeBody Stage2 I Annot) -objTypeBodyToStage2 path (ObjTypeBody decls annot) = ObjTypeBody <$> mapM (objTypeDeclToStage2 path) decls <*> pure annot +objTypeBodyToStage2 path (ObjTypeBody bodyType decls annot) = + ObjTypeBody bodyType <$> mapM (objTypeDeclToStage2 path) decls <*> pure annot objTypeDeclToStage2 :: Path -> ObjTypeDecl Stage1 I Annot -> M Annot (ObjTypeDecl Stage2 I Annot) objTypeDeclToStage2 path = \case (AssertPosStatement expr annot) -> AssertPosStatement <$> toStage2Expr expr <*> pure annot + (TypeSubStructure (Identity deferredBody) maybeIdent annot) -> + let path' = maybe path (`pushId` path) maybeIdent + in TypeSubStructure . Identity + <$> objTypeBodyToStage2 path' deferredBody + <*> pure maybeIdent + <*> pure annot + (ReservedDecl expr a) -> + ReservedDecl <$> toStage2Expr expr <*> pure a (RegisterDecl maybeModifier maybeIdentifier expression maybeBody annot) -> let path' = maybe path (`pushId` path) maybeIdentifier in RegisterDecl @@ -138,8 +147,8 @@ objTypeDeclToStage2 path = \case <*> pure annot registerBodyToStage2 :: Path -> RegisterBody Stage1 I Annot -> M Annot (RegisterBody Stage2 I Annot) -registerBodyToStage2 path (RegisterBody (Identity (DeferredRegisterBody registerBitsDecl a1)) a2) = - RegisterBody . Identity +registerBodyToStage2 path (RegisterBody bodyType (Identity (DeferredRegisterBody registerBitsDecl a1)) a2) = + RegisterBody bodyType . Identity <$> ( DeferredRegisterBody <$> mapM (registerBitsDeclToStage2 path) registerBitsDecl <*> pure a1 @@ -149,6 +158,9 @@ registerBodyToStage2 path (RegisterBody (Identity (DeferredRegisterBody register registerBitsDeclToStage2 :: Path -> RegisterBitsDecl Stage1 I Annot -> M Annot (RegisterBitsDecl Stage2 I Annot) registerBitsDeclToStage2 path = \case ReservedBits expr a -> ReservedBits <$> toStage2Expr expr <*> pure a + BitsSubStructure registerBody maybeIdent annot -> + let path' = maybe path (`pushId` path) maybeIdent + in BitsSubStructure <$> registerBodyToStage2 path' registerBody <*> pure maybeIdent <*> pure annot DefinedBits maybeModifier identifier registerBitsTyperef annot -> let path' = pushId identifier path in ( DefinedBits diff --git a/src/Language/Fiddle/Compiler/Stage2.hs b/src/Language/Fiddle/Compiler/Stage2.hs index baa61e3..727f153 100644 --- a/src/Language/Fiddle/Compiler/Stage2.hs +++ b/src/Language/Fiddle/Compiler/Stage2.hs @@ -117,8 +117,8 @@ getTypeSize (EnumBitType expr (Identity (EnumBody constants _)) ann) = do [ Diagnostic Warning ( printf - "Missing enum constants %s. Please fully pack a small enum.\ - \ Use 'reserved' if needed." + "Missing enum constants %s. Small enums should be fully \ + \ populated. Use 'reserved' if needed." (intercalate ", " (map show missing)) ) (unCommented ann) @@ -136,7 +136,7 @@ fiddleDeclToStage3 = \case addTypeSize id typeSize BitsDecl id <$> bitTypeToStage3 typ <*> pure a ObjTypeDecl ident body a -> - ObjTypeDecl ident <$> mapM objTypeBodyToStage3 body <*> pure a + ObjTypeDecl ident <$> mapM (\bt -> fst <$> objTypeBodyToStage3 bt 0) body <*> pure a ObjectDecl ident expr typ a -> ObjectDecl ident (expressionToStage3 expr) <$> objTypeToStage3 typ <*> pure a @@ -152,7 +152,11 @@ objTypeToStage3 = \case registerBodyToStage3 :: RegisterBody Stage2 I Annot -> Compile Stage3State (RegisterBody Stage3 I Annot, Word32) -registerBodyToStage3 (RegisterBody (Identity deferredRegisterBody) a') = +registerBodyToStage3 (RegisterBody bodyType (Identity deferredRegisterBody) a') = do + let isUnion = case bodyType of + Union {} -> True + _ -> False + case deferredRegisterBody of DeferredRegisterBody decls a -> do (cur, returned) <- @@ -160,17 +164,79 @@ registerBodyToStage3 (RegisterBody (Identity deferredRegisterBody) a') = ( \(cursor, returned) decl -> case decl of ReservedBits expr a -> do - size <- exprToSize expr + size <- fromIntegral <$> exprToSize expr let s3 = ReservedBits (expressionToStage3 expr) a - return (cursor + fromIntegral size, s3 : returned) + if isUnion + then checkUnion cursor size (s3 : returned) a + else + return (cursor + size, s3 : returned) + BitsSubStructure registerBody maybeIdent annot -> do + checkBitsSubStructure registerBody maybeIdent annot + + (newBody, subsize) <- registerBodyToStage3 registerBody + let s3 = BitsSubStructure newBody maybeIdent annot + + if isUnion + then checkUnion cursor subsize (s3 : returned) a + else + return (cursor + subsize, s3 : returned) DefinedBits modifier identifier typeref a -> do (s3TypeRef, size) <- registerBitsTypeRefToStage3 typeref - return (cursor + size, DefinedBits modifier identifier s3TypeRef a : returned) + let s3 = DefinedBits modifier identifier s3TypeRef a + + if isUnion + then checkUnion cursor size (s3 : returned) a + else + return (cursor + size, s3 : returned) ) (0, []) decls - return (RegisterBody (Identity (DeferredRegisterBody (reverse returned) a)) a', cur) + return (RegisterBody bodyType (Identity (DeferredRegisterBody (reverse returned) a)) a', cur) + where + checkBitsSubStructure + (RegisterBody bodyType (Identity (DeferredRegisterBody decls _)) _) + maybeIdent + annot = + let emitWarning s = tell [Diagnostic Warning s (unCommented annot)] + in case () of + () + | [_] <- decls, + (Union {}) <- bodyType -> + emitWarning "Union with a single field. Should this be a struct?" + () + | [_] <- decls, + (Struct {}) <- bodyType, + Nothing <- maybeIdent -> + emitWarning "Anonymous sub-struct with single field is superfluous." + () + | [] <- decls -> + emitWarning + ( printf + "Empty sub-%s is superfluous." + ( case bodyType of + Union {} -> "union" + Struct {} -> "struct" + ) + ) + _ -> return () + +checkUnion :: Word32 -> Word32 -> b -> Commented SourceSpan -> Compile Stage3State (Word32, b) +checkUnion cursor subsize ret a = do + when (cursor /= 0 && subsize /= cursor) $ do + tell + [ Diagnostic + Warning + ( printf + "Jagged union found. Found size %d, expected %d.\n \ + \ Please wrap smaller fields in a struct with padding so all \ + \ fields are the same size?" + subsize + cursor + ) + (unCommented a) + ] + return (max cursor subsize, ret) registerBitsTypeRefToStage3 :: RegisterBitsTypeRef Stage2 I Annot -> @@ -191,8 +257,11 @@ registerBitsTypeRefToStage3 = \case <$> exprToSize expr objTypeBodyToStage3 :: - ObjTypeBody Stage2 I Annot -> Compile Stage3State (ObjTypeBody Stage3 I Annot) -objTypeBodyToStage3 (ObjTypeBody decls a) = do + ObjTypeBody Stage2 I Annot -> Word32 -> Compile Stage3State (ObjTypeBody Stage3 I Annot, Word32) +objTypeBodyToStage3 (ObjTypeBody bodyType decls a) startOff = do + let isUnion = case bodyType of + Union {} -> True + _ -> False (cur, returned) <- foldlM ( \(cursor, returned) decl -> @@ -209,7 +278,7 @@ objTypeBodyToStage3 (ObjTypeBody decls a) = do s3RegisterBody a - declaredSizeBits <- exprToSize expr + declaredSizeBits <- fromIntegral <$> exprToSize expr when ((declaredSizeBits `mod` 8) /= 0) $ tell @@ -222,45 +291,108 @@ objTypeBodyToStage3 (ObjTypeBody decls a) = do forM_ mCalculatedSize $ \(fromIntegral -> calculatedSize) -> unless (calculatedSize == declaredSizeBits) $ let helpful = - if calculatedSize < declaredSizeBits then - printf "\nPerhaps you should add 'reserved(%d)' to the end of your register declaration?" - (declaredSizeBits - calculatedSize) - else "" - in - - tell - [ Diagnostic - Error - ( printf - "Calculated size %d does not match declared size %d.%s" - calculatedSize - declaredSizeBits - helpful - ) - (unCommented a) - ] - - return (cursor + declaredSizeBits `div` 8, s3 : returned) + if calculatedSize < declaredSizeBits + then + printf + "\nPerhaps you should add 'reserved(%d)' to the end of your register declaration?" + (declaredSizeBits - calculatedSize) + else "" + in tell + [ Diagnostic + Error + ( printf + "Calculated size %d does not match declared size %d.%s" + calculatedSize + declaredSizeBits + helpful + ) + (unCommented a) + ] + + if isUnion + then + checkUnion cursor (declaredSizeBits `div` 8) (s3 : returned) a + else + return (cursor + declaredSizeBits `div` 8, s3 : returned) + TypeSubStructure (Identity subBody) maybeIdent annot -> do + (newBody, size) <- + objTypeBodyToStage3 + subBody + ( if isUnion then startOff else cursor + ) + let s3 = TypeSubStructure (Identity newBody) maybeIdent annot + + checkTypesSubStructure subBody maybeIdent annot + if isUnion + then + checkUnion cursor size (s3 : returned) a + else + return (cursor + size, s3 : returned) + ReservedDecl expr annot -> do + size' <- fromIntegral <$> exprToSize expr + when ((size' `mod` 8) /= 0) $ + tell + [ Diagnostic + Error + "Can only reserve a multiple of 8 bits in this context." + (unCommented a) + ] + let size = size' `div` 8 + let s3 = ReservedDecl (expressionToStage3 expr) annot + if isUnion + then + checkUnion cursor size (s3 : returned) a + else + return (cursor + size, s3 : returned) AssertPosStatement expr a -> do - declaredPos <- exprToSize expr - when (cursor /= declaredPos) $ do + declaredPos <- fromIntegral <$> exprToSize expr + + let expectedPos = if isUnion then startOff else cursor + startOff + + when (expectedPos /= declaredPos) $ do tell [ Diagnostic Error ( printf "Position assertion failed. Asserted 0x%x, calculated 0x%x" declaredPos - cursor + expectedPos ) (unCommented a) ] return (cursor, returned) ) - (0 :: Integer, []) + (0, []) decls - return $ ObjTypeBody (reverse returned) a + return (ObjTypeBody bodyType (reverse returned) a, cur) where + checkTypesSubStructure + (ObjTypeBody bodyType decls _) + maybeIdent + annot = + let emitWarning s = tell [Diagnostic Warning s (unCommented annot)] + in case () of + () + | [_] <- decls, + (Union {}) <- bodyType -> + emitWarning "Union with a single field. Should this be a struct?" + () + | [_] <- decls, + (Struct {}) <- bodyType, + Nothing <- maybeIdent -> + emitWarning "Anonymous sub-struct with single field is superfluous." + () + | [] <- decls -> + emitWarning + ( printf + "Empty sub-%s is superfluous." + ( case bodyType of + Union {} -> "union" + Struct {} -> "struct" + ) + ) + _ -> return () fUnzip xs = (fst <$> xs, snd <$> xs) pushApply :: Maybe (a, b) -> (Maybe a, Maybe b) pushApply (Just (a, b)) = (Just a, Just b) diff --git a/src/Language/Fiddle/GenericTree.hs b/src/Language/Fiddle/GenericTree.hs index 668c290..00824ed 100644 --- a/src/Language/Fiddle/GenericTree.hs +++ b/src/Language/Fiddle/GenericTree.hs @@ -174,6 +174,8 @@ instance (GToGenericSyntaxTree r f a) => (GToGenericSyntaxTree (M1 i c r) f a) w deriving instance (ToGenericSyntaxTree Identifier) +deriving instance (ToGenericSyntaxTree BodyType) + deriving instance (Context stage) => (ToGenericSyntaxTree (FiddleUnit stage)) deriving instance (Context stage) => (ToGenericSyntaxTree (FiddleDecl stage)) @@ -206,6 +208,20 @@ instance (Context stage) => (ToGenericSyntaxTree (ObjTypeDecl stage)) where toGenericSyntaxTree t = case t of (AssertPosStatement expr a) -> SyntaxTreeObject "AssertPosStatement" [toGenericSyntaxTree expr] a t + (TypeSubStructure body mIdent a) -> + SyntaxTreeObject + "TypeSubStructure" + ( Data.Foldable.toList (toGenericSyntaxTree <$> body) + ++ Data.Foldable.toList (toGenericSyntaxTree <$> mIdent) + ) + a + t + (ReservedDecl expr a) -> + SyntaxTreeObject + "ReservedDecl" + [toGenericSyntaxTree expr] + a + t (RegisterDecl mMod mIdent expr mBody a) -> SyntaxTreeObject "RegisterDecl" diff --git a/src/Language/Fiddle/Parser.hs b/src/Language/Fiddle/Parser.hs index 37ef34e..7eed0f2 100644 --- a/src/Language/Fiddle/Parser.hs +++ b/src/Language/Fiddle/Parser.hs @@ -7,8 +7,8 @@ module Language.Fiddle.Parser ) where -import Data.Kind (Type) import Data.Functor.Identity +import Data.Kind (Type) import Data.Text (Text) import qualified Data.Text import Debug.Trace @@ -28,6 +28,7 @@ type P = ParsecT S () Identity type A = Commented SourceSpan type Pa (a :: Stage -> (Type -> Type) -> Type -> Type) = P (a 'Stage1 F (Commented SourceSpan)) + type PaS (a :: (Type -> Type) -> Type -> Type) = P (a F (Commented SourceSpan)) comment :: P Comment @@ -68,9 +69,15 @@ fiddleDecl = do <*> defer body packageBody KWLocation -> LocationDecl <$> ident <*> (tok TokEq >> expression) KWBits -> BitsDecl <$> ident <*> (tok TokColon >> bitType) - KWObjtype -> - ObjTypeDecl <$> ident <*> (tok TokColon >> defer body objTypeBody) - KWObject -> + KWType -> + ObjTypeDecl + <$> ident + <*> ( do + tok TokColon + bt <- bodyType + defer body (objTypeBody bt) + ) + KWInstance -> ObjectDecl <$> ident <*> (tok KWAt *> expression) @@ -114,15 +121,18 @@ objType = do baseObj :: P (A -> ObjType Stage1 F A) baseObj = (ReferencedObjType <$> ident) - <|> (AnonymousObjType <$> defer body objTypeBody) + <|> ( do + t <- bodyType + AnonymousObjType <$> defer body (objTypeBody t) + ) exprInParen :: Pa Expression exprInParen = tok TokLParen *> expression <* tok TokRParen -objTypeBody :: Pa ObjTypeBody -objTypeBody = +objTypeBody :: BodyType F (Commented SourceSpan) -> Pa ObjTypeBody +objTypeBody bt = withMeta $ - ObjTypeBody <$> many (objTypeDecl <* tok TokSemi) + ObjTypeBody bt <$> many (objTypeDecl <* tok TokSemi) objTypeDecl :: Pa ObjTypeDecl objTypeDecl = @@ -132,6 +142,14 @@ objTypeDecl = AssertPosStatement <$> exprInParen ) <|> ( do + tok KWReserved + ReservedDecl <$> exprInParen + ) + <|> ( do + bt <- bodyType + TypeSubStructure <$> defer body (objTypeBody bt) <*> optionMaybe ident + ) + <|> ( do mod <- optionMaybe modifier tok KWReg RegisterDecl mod @@ -150,8 +168,19 @@ modifier = tok KWWo >> return Wo ] +bitBodyType :: PaS BodyType +bitBodyType = + withMeta $ + (tok KWStruct >> return Struct) + <|> (tok KWUnion >> return Union) + +bodyType :: PaS BodyType +bodyType = + withMeta $ + (tok KWStruct >> return Struct) <|> (tok KWUnion >> return Union) + registerBody :: Pa RegisterBody -registerBody = withMeta $ RegisterBody <$> defer body deferredRegisterBody +registerBody = withMeta $ RegisterBody <$> bitBodyType <*> defer body deferredRegisterBody deferredRegisterBody :: Pa DeferredRegisterBody deferredRegisterBody = @@ -164,7 +193,9 @@ registerBitsDecl = ( do tok KWReserved >> ReservedBits <$> exprInParen ) - <|> ( DefinedBits <$> optionMaybe modifier + <|> (BitsSubStructure <$> registerBody <*> optionMaybe ident) + <|> ( DefinedBits + <$> optionMaybe modifier <*> ident <*> (tok TokColon >> registerBitsTypeRef) ) diff --git a/src/Language/Fiddle/Tokenizer.hs b/src/Language/Fiddle/Tokenizer.hs index 4e06b92..08f5649 100644 --- a/src/Language/Fiddle/Tokenizer.hs +++ b/src/Language/Fiddle/Tokenizer.hs @@ -12,29 +12,31 @@ import qualified Text.Parsec data T = KWAssertPos - | TokIdent !Text | KWAt | KWBits | KWEnum - | TokComment !Text - | TokDocComment !Text + | KWInstance | KWLocation - | KWObject - | KWObjtype | KWOption | KWPackage | KWReg | KWReserved | KWRo - | KWWo | KWRw - | TokLitNum !Text + | KWStruct + | KWType + | KWUnion + | KWWo | TokColon | TokComma + | TokComment !Text + | TokDocComment !Text | TokEq + | TokIdent !Text | TokLBrace | TokLBracket | TokLParen + | TokLitNum !Text | TokRBrace | TokRBracket | TokRParen @@ -60,8 +62,8 @@ parseToken = spaces *> tok parseToken' <* spaces "bits" -> KWBits "enum" -> KWEnum "location" -> KWLocation - "object" -> KWObject - "objtype" -> KWObjtype + "instance" -> KWInstance + "type" -> KWType "option" -> KWOption "package" -> KWPackage "reg" -> KWReg @@ -69,6 +71,8 @@ parseToken = spaces *> tok parseToken' <* spaces "wo" -> KWWo "rw" -> KWRw "reserved" -> KWReserved + "union" -> KWUnion + "struct" -> KWStruct "assert_pos" -> KWAssertPos (Data.Text.head -> h) | isDigit h -> TokLitNum str ident -> TokIdent ident diff --git a/vim/syntax/fiddle.vim b/vim/syntax/fiddle.vim index 22341a5..7d36e93 100644 --- a/vim/syntax/fiddle.vim +++ b/vim/syntax/fiddle.vim @@ -1,9 +1,10 @@ syn keyword FiddlePackage option package nextgroup=FiddleIdent skipwhite -syn keyword FiddleDecl reg object at location reserved nextgroup=FiddleIdent skipwhite -syn keyword FiddleTypeDecl objtype regtype bits nextgroup=FiddleIdent 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 syn keyword FiddleBuiltin assert_pos syn keyword FiddleModifier wo ro rw +syn keyword FiddleStorageClass struct union bitstruct bitunion syn match FiddleColon +:+ skipwhite nextgroup=FiddleContainedType syn match FiddleContainedType +[a-zA-Z0-9_]\++ contained @@ -13,12 +14,13 @@ syn match FiddleIdent +[A-Za-z0-9_]\++ contained syn match FiddleComment +\/\/.*$+ syn region FiddleDocComment start=+/\*\*+ end=+*/+ -syn match FiddleNumber +[0-9_]\+\([xb]\)\@!\|0x[0-9A-Fa-f][0-9A-Fa-f_]*\|0b[01]\++ +syn match FiddleNumber +\<[0-9_]\+\([xb]\)\@!\|0x[0-9A-Fa-f][0-9A-Fa-f_]*\|0b[01]\+\>+ hi! link FiddleContainedType Type hi! link FiddleModifier StorageClass hi! link FiddleBuiltin Function hi! link FiddleEnum StorageClass +hi! link FiddleStorageClass FiddleEnum hi! link FiddleDecl Type hi! link FiddleNumber Number hi! link FiddleDocComment Comment |