Make Specification a proper data type
This commit is contained in:
Adam Sampson
parent
23f656eb2b
commit
4c6cda3226
|
|
@ -181,7 +181,10 @@ data AbbrevMode =
|
|||
| ValAbbrev
|
||||
deriving (Show, Eq, Typeable, Data)
|
||||
|
||||
type Specification = (Name, SpecType)
|
||||
data Specification =
|
||||
Specification Name SpecType
|
||||
deriving (Show, Eq, Typeable, Data)
|
||||
|
||||
data SpecType =
|
||||
Place Meta Expression
|
||||
| Declaration Meta Type
|
||||
|
|
|
|||
|
|
@ -685,7 +685,7 @@ CHAN OF INT c IS d: Channel *c = d;
|
|||
const int *ds_sizes = cs_sizes;
|
||||
-}
|
||||
introduceSpec :: A.Specification -> CGen ()
|
||||
introduceSpec (n, A.Declaration m t)
|
||||
introduceSpec (A.Specification n (A.Declaration m t))
|
||||
= do genDeclaration t n
|
||||
case t of
|
||||
A.Array ds _ -> declareArraySizes ds (genName n)
|
||||
|
|
@ -693,27 +693,27 @@ introduceSpec (n, A.Declaration m t)
|
|||
case declareInit t (genName n) (return ()) of
|
||||
Just p -> p
|
||||
Nothing -> return ()
|
||||
introduceSpec (n, A.Is m am t v)
|
||||
introduceSpec (A.Specification n (A.Is m am t v))
|
||||
= do let (rhs, rhsSizes) = abbrevVariable am t v
|
||||
genDecl am t n
|
||||
tell [" = "]
|
||||
rhs
|
||||
tell [";\n"]
|
||||
rhsSizes n
|
||||
introduceSpec (n, A.IsExpr m am t e)
|
||||
introduceSpec (A.Specification n (A.IsExpr m am t e))
|
||||
= do let (rhs, rhsSizes) = abbrevExpression am t e
|
||||
genDecl am t n
|
||||
tell [" = "]
|
||||
rhs
|
||||
tell [";\n"]
|
||||
rhsSizes n
|
||||
introduceSpec (n, A.IsChannelArray m t cs)
|
||||
introduceSpec (A.Specification n (A.IsChannelArray m t cs))
|
||||
= do genDecl A.Abbrev t n
|
||||
tell [" = {"]
|
||||
sequence_ $ intersperse genComma (map genVariable cs)
|
||||
tell ["};\n"]
|
||||
--introduceSpec (n, A.DataType m t)
|
||||
introduceSpec (n, A.DataTypeRecord _ b fs)
|
||||
--introduceSpec (A.Specification n (A.DataType m t))
|
||||
introduceSpec (A.Specification n (A.DataTypeRecord _ b fs))
|
||||
= do tell ["typedef struct {\n"]
|
||||
sequence_ [case t of
|
||||
_ ->
|
||||
|
|
@ -726,8 +726,8 @@ introduceSpec (n, A.DataTypeRecord _ b fs)
|
|||
when b $ tell ["occam_struct_packed "]
|
||||
genName n
|
||||
tell [";\n"]
|
||||
introduceSpec (n, A.Protocol _ _) = return ()
|
||||
introduceSpec (n, A.ProtocolCase _ ts)
|
||||
introduceSpec (A.Specification n (A.Protocol _ _)) = return ()
|
||||
introduceSpec (A.Specification n (A.ProtocolCase _ ts))
|
||||
= do tell ["typedef enum {\n"]
|
||||
sequence_ $ intersperse genComma [genName tag >> tell ["_"] >> genName n
|
||||
| (tag, _) <- ts]
|
||||
|
|
@ -735,7 +735,7 @@ introduceSpec (n, A.ProtocolCase _ ts)
|
|||
tell ["} "]
|
||||
genName n
|
||||
tell [";\n"]
|
||||
introduceSpec (n, A.Proc m fs p)
|
||||
introduceSpec (A.Specification n (A.Proc m fs p))
|
||||
= do tell ["void "]
|
||||
genName n
|
||||
tell [" (Process *me"]
|
||||
|
|
@ -743,13 +743,13 @@ introduceSpec (n, A.Proc m fs p)
|
|||
tell [") {\n"]
|
||||
genProcess p
|
||||
tell ["}\n"]
|
||||
introduceSpec (n, A.Function _ _ _ _) = missing "introduceSpec function"
|
||||
--introduceSpec (n, A.Retypes m am t v)
|
||||
--introduceSpec (n, A.RetypesExpr m am t e)
|
||||
introduceSpec (n, t) = missing $ "introduceSpec " ++ show t
|
||||
introduceSpec (A.Specification n (A.Function _ _ _ _)) = missing "introduceSpec function"
|
||||
--introduceSpec (A.Specification n (A.Retypes m am t v))
|
||||
--introduceSpec (A.Specification n (A.RetypesExpr m am t e))
|
||||
introduceSpec (A.Specification n t) = missing $ "introduceSpec " ++ show t
|
||||
|
||||
removeSpec :: A.Specification -> CGen ()
|
||||
removeSpec (n, A.Declaration m t)
|
||||
removeSpec (A.Specification n (A.Declaration m t))
|
||||
= case t of
|
||||
A.Array _ t' -> overArray (genName n) t (declareFree t' (genName n))
|
||||
_ ->
|
||||
|
|
|
|||
|
|
@ -252,6 +252,9 @@ tryXVV a b c = try (do { a; bv <- b; cv <- c; return (bv, cv) })
|
|||
tryXVX :: OccParser a -> OccParser b -> OccParser c -> OccParser b
|
||||
tryXVX a b c = try (do { a; bv <- b; c; return bv })
|
||||
|
||||
tryVXV :: OccParser a -> OccParser b -> OccParser c -> OccParser (a, c)
|
||||
tryVXV a b c = try (do { av <- a; b; cv <- c; return (av, cv) })
|
||||
|
||||
maybeSubscripted :: String -> OccParser a -> (Meta -> A.Subscript -> a -> a) -> (a -> OccParser A.Type) -> OccParser a
|
||||
maybeSubscripted prodName inner subscripter typer
|
||||
= do m <- md
|
||||
|
|
@ -424,20 +427,20 @@ scopeOut n@(A.Name m nt s)
|
|||
|
||||
-- FIXME: Do these with generics? (going carefully to avoid nested code blocks)
|
||||
scopeInRep :: A.Replicator -> OccParser A.Replicator
|
||||
scopeInRep r@(A.For m n b c)
|
||||
scopeInRep (A.For m n b c)
|
||||
= do n' <- scopeIn n (A.Declaration m A.Int) A.ValAbbrev
|
||||
return $ A.For m n' b c
|
||||
|
||||
scopeOutRep :: A.Replicator -> OccParser ()
|
||||
scopeOutRep r@(A.For m n b c) = scopeOut n
|
||||
scopeOutRep (A.For m n b c) = scopeOut n
|
||||
|
||||
scopeInSpec :: A.Specification -> OccParser A.Specification
|
||||
scopeInSpec s@(n, st)
|
||||
scopeInSpec (A.Specification n st)
|
||||
= do n' <- scopeIn n st (abbrevModeOfSpec st)
|
||||
return (n', st)
|
||||
return $ A.Specification n' st
|
||||
|
||||
scopeOutSpec :: A.Specification -> OccParser ()
|
||||
scopeOutSpec s@(n, st) = scopeOut n
|
||||
scopeOutSpec (A.Specification n st) = scopeOut n
|
||||
|
||||
scopeInFormal :: A.Formal -> OccParser A.Formal
|
||||
scopeInFormal (A.Formal am t n)
|
||||
|
|
@ -814,12 +817,12 @@ replicator
|
|||
--{{{ specifications, declarations, allocations
|
||||
allocation :: OccParser [A.Specification]
|
||||
allocation
|
||||
= do { m <- md; sPLACE; n <- variableName; sAT; e <- intExpr; sColon; eol; return [(n, A.Place m e)] }
|
||||
= do { m <- md; sPLACE; n <- variableName; sAT; e <- intExpr; sColon; eol; return [A.Specification n (A.Place m e)] }
|
||||
<?> "allocation"
|
||||
|
||||
specification :: OccParser [A.Specification]
|
||||
specification
|
||||
= try (do { (ns, d) <- declaration; return [(n, d) | n <- ns] })
|
||||
= try (do { (ns, d) <- declaration; return [A.Specification n d | n <- ns] })
|
||||
<|> try (do { a <- abbreviation; return [a] })
|
||||
<|> do { d <- definition; return [d] }
|
||||
<?> "specification"
|
||||
|
|
@ -835,37 +838,37 @@ declaration
|
|||
abbreviation :: OccParser A.Specification
|
||||
abbreviation
|
||||
= do m <- md
|
||||
(do { (n, v) <- try (do { n <- newVariableName; sIS; v <- variable; return (n, v) }); sColon; eol; t <- pTypeOfVariable v; return (n, A.Is m A.Abbrev t v) }
|
||||
<|> do { (s, n, v) <- try (do { s <- specifier; n <- newVariableName; sIS; v <- variable; return (s, n, v) }); sColon; eol; t <- pTypeOfVariable v; matchType s t; return (n, A.Is m A.Abbrev s v) }
|
||||
(do { (n, v) <- tryVXV newVariableName sIS variable; sColon; eol; t <- pTypeOfVariable v; return $ A.Specification n $ A.Is m A.Abbrev t v }
|
||||
<|> do { (s, n, v) <- try (do { s <- specifier; n <- newVariableName; sIS; v <- variable; return (s, n, v) }); sColon; eol; t <- pTypeOfVariable v; matchType s t; return $ A.Specification n $ A.Is m A.Abbrev s v }
|
||||
<|> do { sVAL ;
|
||||
do { (n, e) <- try (do { n <- newVariableName; sIS; e <- expression; return (n, e) }); sColon; eol; t <- pTypeOfExpression e; return (n, A.IsExpr m A.ValAbbrev t e) }
|
||||
<|> do { s <- specifier; n <- newVariableName; sIS; e <- expression; sColon; eol; t <- pTypeOfExpression e; matchType s t; return (n, A.IsExpr m A.ValAbbrev s e) } }
|
||||
<|> try (do { n <- newChannelName; sIS; c <- channel; sColon; eol; t <- pTypeOfVariable c; return (n, A.Is m A.Abbrev t c) })
|
||||
<|> try (do { n <- newTimerName; sIS; c <- timer; sColon; eol; t <- pTypeOfVariable c; return (n, A.Is m A.Abbrev t c) })
|
||||
<|> try (do { n <- newPortName; sIS; c <- port; sColon; eol; t <- pTypeOfVariable c; return (n, A.Is m A.Abbrev t c) })
|
||||
<|> try (do { s <- specifier; n <- newChannelName; sIS; c <- channel; sColon; eol; t <- pTypeOfVariable c; matchType s t; return (n, A.Is m A.Abbrev s c) })
|
||||
<|> try (do { s <- specifier; n <- newTimerName; sIS; c <- timer; sColon; eol; t <- pTypeOfVariable c; matchType s t; return (n, A.Is m A.Abbrev s c) })
|
||||
<|> try (do { s <- specifier; n <- newPortName; sIS; c <- port; sColon; eol; t <- pTypeOfVariable c; matchType s t; return (n, A.Is m A.Abbrev s c) })
|
||||
<|> try (do { n <- newChannelName; sIS; sLeft; cs <- sepBy1 channel sComma; sRight; sColon; eol; ts <- mapM pTypeOfVariable cs; t <- listType m ts; return (n, A.IsChannelArray m t cs) })
|
||||
<|> try (do { s <- specifier; n <- newChannelName; sIS; sLeft; cs <- sepBy1 channel sComma; sRight; sColon; eol; ts <- mapM pTypeOfVariable cs; t <- listType m ts; matchType s t; return (n, A.IsChannelArray m s cs) }))
|
||||
do { (n, e) <- try (do { n <- newVariableName; sIS; e <- expression; return (n, e) }); sColon; eol; t <- pTypeOfExpression e; return $ A.Specification n $ A.IsExpr m A.ValAbbrev t e }
|
||||
<|> do { s <- specifier; n <- newVariableName; sIS; e <- expression; sColon; eol; t <- pTypeOfExpression e; matchType s t; return $ A.Specification n $ A.IsExpr m A.ValAbbrev s e } }
|
||||
<|> try (do { n <- newChannelName; sIS; c <- channel; sColon; eol; t <- pTypeOfVariable c; return $ A.Specification n $ A.Is m A.Abbrev t c })
|
||||
<|> try (do { n <- newTimerName; sIS; c <- timer; sColon; eol; t <- pTypeOfVariable c; return $ A.Specification n $ A.Is m A.Abbrev t c })
|
||||
<|> try (do { n <- newPortName; sIS; c <- port; sColon; eol; t <- pTypeOfVariable c; return $ A.Specification n $ A.Is m A.Abbrev t c })
|
||||
<|> try (do { s <- specifier; n <- newChannelName; sIS; c <- channel; sColon; eol; t <- pTypeOfVariable c; matchType s t; return $ A.Specification n $ A.Is m A.Abbrev s c })
|
||||
<|> try (do { s <- specifier; n <- newTimerName; sIS; c <- timer; sColon; eol; t <- pTypeOfVariable c; matchType s t; return $ A.Specification n $ A.Is m A.Abbrev s c })
|
||||
<|> try (do { s <- specifier; n <- newPortName; sIS; c <- port; sColon; eol; t <- pTypeOfVariable c; matchType s t; return $ A.Specification n $ A.Is m A.Abbrev s c })
|
||||
<|> try (do { n <- newChannelName; sIS; sLeft; cs <- sepBy1 channel sComma; sRight; sColon; eol; ts <- mapM pTypeOfVariable cs; t <- listType m ts; return $ A.Specification n $ A.IsChannelArray m t cs })
|
||||
<|> try (do { s <- specifier; n <- newChannelName; sIS; sLeft; cs <- sepBy1 channel sComma; sRight; sColon; eol; ts <- mapM pTypeOfVariable cs; t <- listType m ts; matchType s t; return $ A.Specification n $ A.IsChannelArray m s cs }))
|
||||
<?> "abbreviation"
|
||||
|
||||
definition :: OccParser A.Specification
|
||||
definition
|
||||
= do { m <- md; sDATA; sTYPE; n <- newDataTypeName ;
|
||||
do {sIS; t <- dataType; sColon; eol; return (n, A.DataType m t) }
|
||||
<|> do { eol; indent; rec <- structuredType; outdent; sColon; eol; return (n, rec) } }
|
||||
do {sIS; t <- dataType; sColon; eol; return $ A.Specification n (A.DataType m t) }
|
||||
<|> do { eol; indent; rec <- structuredType; outdent; sColon; eol; return $ A.Specification n rec } }
|
||||
<|> do { m <- md; sPROTOCOL; n <- newProtocolName ;
|
||||
do { sIS; p <- sequentialProtocol; sColon; eol; return (n, A.Protocol m p) }
|
||||
<|> do { eol; indent; sCASE; eol; indent; ps <- many1 taggedProtocol; outdent; outdent; sColon; eol; return (n, A.ProtocolCase m ps) } }
|
||||
<|> do { m <- md; sPROC; n <- newProcName; fs <- formalList; eol; indent; fs' <- scopeInFormals fs; p <- process; scopeOutFormals fs'; outdent; sColon; eol; return (n, A.Proc m fs' p) }
|
||||
do { sIS; p <- sequentialProtocol; sColon; eol; return $ A.Specification n $ A.Protocol m p }
|
||||
<|> do { eol; indent; sCASE; eol; indent; ps <- many1 taggedProtocol; outdent; outdent; sColon; eol; return $ A.Specification n $ A.ProtocolCase m ps } }
|
||||
<|> do { m <- md; sPROC; n <- newProcName; fs <- formalList; eol; indent; fs' <- scopeInFormals fs; p <- process; scopeOutFormals fs'; outdent; sColon; eol; return $ A.Specification n $ A.Proc m fs' p }
|
||||
<|> try (do { m <- md; rs <- sepBy1 dataType sComma; (n, fs) <- functionHeader ;
|
||||
do { sIS; fs' <- scopeInFormals fs; el <- expressionList; scopeOutFormals fs'; sColon; eol; return (n, A.Function m rs fs' (A.ValOf m (A.Skip m) el)) }
|
||||
<|> do { eol; indent; fs' <- scopeInFormals fs; vp <- valueProcess; scopeOutFormals fs'; outdent; sColon; eol; return (n, A.Function m rs fs' vp) } })
|
||||
do { sIS; fs' <- scopeInFormals fs; el <- expressionList; scopeOutFormals fs'; sColon; eol; return $ A.Specification n $ A.Function m rs fs' (A.ValOf m (A.Skip m) el) }
|
||||
<|> do { eol; indent; fs' <- scopeInFormals fs; vp <- valueProcess; scopeOutFormals fs'; outdent; sColon; eol; return $ A.Specification n $ A.Function m rs fs' vp } })
|
||||
<|> try (do { m <- md; s <- specifier; n <- newVariableName ;
|
||||
sRETYPES <|> sRESHAPES; v <- variable; sColon; eol; return (n, A.Retypes m A.Abbrev s v) })
|
||||
sRETYPES <|> sRESHAPES; v <- variable; sColon; eol; return $ A.Specification n $ A.Retypes m A.Abbrev s v })
|
||||
<|> try (do { m <- md; sVAL; s <- specifier; n <- newVariableName ;
|
||||
sRETYPES <|> sRESHAPES; e <- expression; sColon; eol; return (n, A.RetypesExpr m A.ValAbbrev s e) })
|
||||
sRETYPES <|> sRESHAPES; e <- expression; sColon; eol; return $ A.Specification n $ A.RetypesExpr m A.ValAbbrev s e })
|
||||
<?> "definition"
|
||||
|
||||
dataSpecifier :: OccParser A.Type
|
||||
|
|
|
|||
|
|
@ -76,7 +76,7 @@ defineNonce m s st nt am
|
|||
A.ndAbbrevMode = am
|
||||
}
|
||||
modify $ psDefineName n nd
|
||||
return (n, st)
|
||||
return $ A.Specification n st
|
||||
|
||||
-- | Generate and define a no-arg wrapper PROC around a process.
|
||||
makeNonceProc :: MonadState ParseState m => Meta -> A.Process -> m A.Specification
|
||||
|
|
|
|||
|
|
@ -52,7 +52,7 @@ pullUp = doGeneric `extM` doProcess `extM` doExpression `extM` doActual
|
|||
pull t e
|
||||
= do -- FIXME Should get Meta from somewhere...
|
||||
let m = []
|
||||
spec@(n, _) <- makeNonceIsExpr "array_expr" m t e
|
||||
spec@(A.Specification n _) <- makeNonceIsExpr "array_expr" m t e
|
||||
addPulled $ A.ProcSpec m spec
|
||||
return $ A.ExprVariable m (A.Variable m n)
|
||||
|
||||
|
|
@ -76,7 +76,7 @@ pullUp = doGeneric `extM` doProcess `extM` doExpression `extM` doActual
|
|||
where
|
||||
pull :: Meta -> A.AbbrevMode -> A.Type -> A.Variable -> PassM A.Variable
|
||||
pull m am t v
|
||||
= do spec@(n, _) <- makeNonceIs "subscript_actual" m t am v
|
||||
= do spec@(A.Specification n _) <- makeNonceIs "subscript_actual" m t am v
|
||||
addPulled $ A.ProcSpec m spec
|
||||
return $ A.Variable m n
|
||||
doActual a = doGeneric a
|
||||
|
|
|
|||
|
|
@ -26,12 +26,12 @@ parsToProcs = doGeneric `extM` doProcess
|
|||
doProcess (A.Par m pm ps)
|
||||
= do ps' <- mapM parsToProcs ps
|
||||
procs <- mapM (makeNonceProc m) ps'
|
||||
let calls = [A.ProcSpec m s (A.ProcCall m n []) | s@(n, _) <- procs]
|
||||
let calls = [A.ProcSpec m s (A.ProcCall m n []) | s@(A.Specification n _) <- procs]
|
||||
return $ A.Par m pm calls
|
||||
doProcess (A.ParRep m pm rep p)
|
||||
= do p' <- parsToProcs p
|
||||
rep' <- parsToProcs rep
|
||||
s@(n, _) <- makeNonceProc m p'
|
||||
s@(A.Specification n _) <- makeNonceProc m p'
|
||||
let call = A.ProcSpec m s (A.ProcCall m n [])
|
||||
return $ A.ParRep m pm rep' call
|
||||
doProcess p = doGeneric p
|
||||
|
|
@ -65,7 +65,7 @@ freeNamesIn = doGeneric `extQ` doName `extQ` doProcess `extQ` doStructured `extQ
|
|||
doValueProcess vp = doGeneric vp
|
||||
|
||||
doSpec :: Data t => A.Specification -> t -> NameMap
|
||||
doSpec (n, st) child
|
||||
doSpec (A.Specification n st) child
|
||||
= Map.union fns $ Map.delete (A.nameName n) $ freeNamesIn child
|
||||
where
|
||||
fns = freeNamesIn st
|
||||
|
|
@ -129,7 +129,7 @@ removeFreeNames = doGeneric `extM` doProcess `extM` doStructured `extM` doValueP
|
|||
|
||||
doSpec :: Data t => Meta -> A.Specification -> t -> PassM (A.Specification, t)
|
||||
doSpec m spec child = case spec of
|
||||
(n, st@(A.Proc m fs p)) ->
|
||||
A.Specification n st@(A.Proc m fs p) ->
|
||||
do
|
||||
-- Figure out the free names
|
||||
let allFreeNames = Map.elems $ freeNamesIn st
|
||||
|
|
@ -156,7 +156,7 @@ removeFreeNames = doGeneric `extM` doProcess `extM` doStructured `extM` doValueP
|
|||
let newFs = [A.Formal am t n | (am, t, n) <- zip3 ams types newNames]
|
||||
p' <- removeFreeNames $ replaceNames (zip freeNames newNames) p
|
||||
let st' = A.Proc m (fs ++ newFs) p'
|
||||
let spec' = (n, st')
|
||||
let spec' = A.Specification n st'
|
||||
-- Update the definition of the proc
|
||||
let nameDef = fromJust $ psLookupName ps n
|
||||
modify $ psDefineName n (nameDef { A.ndType = st' })
|
||||
|
|
@ -197,7 +197,7 @@ removeNesting p
|
|||
doValueProcess vp = doGeneric vp
|
||||
|
||||
doSpec :: Data t => t -> Meta -> A.Specification -> t -> PassM t
|
||||
doSpec orig m spec@(_, st) child
|
||||
doSpec orig m spec@(A.Specification _ st) child
|
||||
= if canPull st then
|
||||
do spec' <- pullSpecs spec
|
||||
addPulled $ A.ProcSpec m spec'
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user