Make all the Types functions monadic; make Errors useful
This commit is contained in:
Adam Sampson
parent
7d2013d3f1
commit
2383345f88
|
|
@ -4,12 +4,24 @@ module Errors where
|
|||
import qualified AST as A
|
||||
import Metadata
|
||||
|
||||
die :: String -> a
|
||||
die s = error $ "\n\nError:\n" ++ s
|
||||
-- | Class of monads that can fail.
|
||||
class Monad m => Die m where
|
||||
-- | Fail, giving an error message.
|
||||
die :: String -> m a
|
||||
|
||||
-- | Fail, giving a position and an error message.
|
||||
dieP :: Die m => Meta -> String -> m a
|
||||
dieP m s = die $ show m ++ ": " ++ s
|
||||
|
||||
-- | Wrapper around error that gives nicer formatting.
|
||||
dieIO :: Monad m => String -> m a
|
||||
dieIO s = error $ "\n\nError: " ++ s ++ "\n"
|
||||
|
||||
-- | Fail after an internal error.
|
||||
dieInternal :: Monad m => String -> m a
|
||||
dieInternal s = die $ "Internal error: " ++ s
|
||||
|
||||
dieP :: Monad m => Meta -> String -> m a
|
||||
dieP m s = die $ show m ++ ": " ++ s
|
||||
dieInternal s = dieIO $ "Internal error: " ++ s
|
||||
|
||||
-- | Extract a value from a Maybe type, dying with the given error if it's Nothing.
|
||||
checkJust :: Die m => String -> Maybe t -> m t
|
||||
checkJust _ (Just v) = return v
|
||||
checkJust err _ = die err
|
||||
|
|
|
|||
|
|
@ -17,7 +17,10 @@ import TLP
|
|||
import Types
|
||||
|
||||
--{{{ monad definition
|
||||
type CGen a = WriterT [String] (ErrorT String (StateT ParseState IO)) a
|
||||
type CGen = WriterT [String] (ErrorT String (StateT ParseState IO))
|
||||
|
||||
instance Die CGen where
|
||||
die = throwError
|
||||
--}}}
|
||||
|
||||
--{{{ top-level
|
||||
|
|
@ -25,7 +28,7 @@ generateC :: ParseState -> A.Process -> IO String
|
|||
generateC st ast
|
||||
= do v <- evalStateT (runErrorT (runWriterT (genTopLevel ast))) st
|
||||
case v of
|
||||
Left e -> die e
|
||||
Left e -> dieIO e
|
||||
Right (_, ss) -> return $ concat ss
|
||||
|
||||
genTLPChannel :: TLPChannel -> CGen ()
|
||||
|
|
@ -53,11 +56,6 @@ missing s = tell ["\n#error Unimplemented: ", s, "\n"]
|
|||
genComma :: CGen ()
|
||||
genComma = tell [", "]
|
||||
|
||||
withPS :: (ParseState -> a) -> CGen a
|
||||
withPS f
|
||||
= do st <- get
|
||||
return $ f st
|
||||
|
||||
checkJust :: MonadError String m => Maybe t -> m t
|
||||
checkJust (Just v) = return v
|
||||
checkJust Nothing = throwError "checkJust failed"
|
||||
|
|
@ -66,8 +64,7 @@ type SubscripterFunction = A.Variable -> A.Variable
|
|||
|
||||
overArray :: A.Variable -> (SubscripterFunction -> Maybe (CGen ())) -> CGen ()
|
||||
overArray var func
|
||||
= do ps <- get
|
||||
let A.Array ds _ = fromJust $ typeOfVariable ps var
|
||||
= do A.Array ds _ <- typeOfVariable var
|
||||
let m = emptyMeta
|
||||
specs <- sequence [makeNonceVariable "i" m A.Int A.VariableName A.Original | _ <- ds]
|
||||
let indices = [A.Variable m n | A.Specification _ n _ <- specs]
|
||||
|
|
@ -100,8 +97,7 @@ data InputType = ITTimerRead | ITTimerAfter | ITOther
|
|||
|
||||
inputType :: A.Variable -> A.InputMode -> CGen InputType
|
||||
inputType c im
|
||||
= do ps <- get
|
||||
t <- checkJust $ typeOfVariable ps c
|
||||
= do t <- typeOfVariable c
|
||||
return $ case t of
|
||||
A.Timer ->
|
||||
case im of
|
||||
|
|
@ -187,8 +183,7 @@ genConversion m A.DefaultConversion t e
|
|||
= do tell ["(("]
|
||||
genType t
|
||||
tell [") "]
|
||||
ps <- get
|
||||
let origT = fromJust $ typeOfExpression ps e
|
||||
origT <- typeOfExpression e
|
||||
if isSafeConversion origT t
|
||||
then genExpression e
|
||||
else do genTypeSymbol "range_check" origT
|
||||
|
|
@ -287,9 +282,8 @@ the above table this isn't too horrible...
|
|||
-}
|
||||
genVariable :: A.Variable -> CGen ()
|
||||
genVariable v
|
||||
= do ps <- get
|
||||
am <- checkJust $ abbrevModeOfVariable ps v
|
||||
t <- checkJust $ typeOfVariable ps v
|
||||
= do am <- abbrevModeOfVariable v
|
||||
t <- typeOfVariable v
|
||||
let isSub = case v of
|
||||
A.Variable _ _ -> False
|
||||
A.SubscriptedVariable _ _ _ -> True
|
||||
|
|
@ -334,8 +328,7 @@ genVariable v
|
|||
|
||||
genArraySubscript :: A.Variable -> [A.Expression] -> CGen ()
|
||||
genArraySubscript v es
|
||||
= do ps <- get
|
||||
t <- checkJust $ typeOfVariable ps v
|
||||
= do t <- typeOfVariable v
|
||||
let numDims = case t of A.Array ds _ -> length ds
|
||||
tell ["["]
|
||||
sequence_ $ intersperse (tell [" + "]) $ genPlainSub v es [0..(numDims - 1)]
|
||||
|
|
@ -416,8 +409,7 @@ genSimpleDyadic s e f
|
|||
|
||||
genFuncDyadic :: Meta -> String -> A.Expression -> A.Expression -> CGen ()
|
||||
genFuncDyadic m s e f
|
||||
= do ps <- get
|
||||
let t = fromJust $ typeOfExpression ps e
|
||||
= do t <- typeOfExpression e
|
||||
genTypeSymbol s t
|
||||
tell [" ("]
|
||||
genExpression e
|
||||
|
|
@ -454,21 +446,19 @@ genDyadic m A.After e f = genFuncDyadic m "after" e f
|
|||
genInputItem :: A.Variable -> A.InputItem -> CGen ()
|
||||
genInputItem c (A.InCounted m cv av)
|
||||
= do genInputItem c (A.InVariable m cv)
|
||||
ps <- get
|
||||
t <- checkJust $ typeOfVariable ps av
|
||||
t <- typeOfVariable av
|
||||
tell ["ChanIn ("]
|
||||
genVariable c
|
||||
tell [", "]
|
||||
fst $ abbrevVariable A.Abbrev t av
|
||||
tell [", "]
|
||||
let subT = fromJust $ subscriptType ps (A.Subscript m $ makeConstant m 0) t
|
||||
subT <- subscriptType (A.Subscript m $ makeConstant m 0) t
|
||||
genVariable cv
|
||||
tell [" * "]
|
||||
genBytesInType subT
|
||||
tell [");\n"]
|
||||
genInputItem c (A.InVariable m v)
|
||||
= do ps <- get
|
||||
t <- checkJust $ typeOfVariable ps v
|
||||
= do t <- typeOfVariable v
|
||||
let rhs = fst $ abbrevVariable A.Abbrev t v
|
||||
case t of
|
||||
A.Int ->
|
||||
|
|
@ -489,8 +479,7 @@ genInputItem c (A.InVariable m v)
|
|||
genOutputItem :: A.Variable -> A.OutputItem -> CGen ()
|
||||
genOutputItem c (A.OutCounted m ce ae)
|
||||
= do genOutputItem c (A.OutExpression m ce)
|
||||
ps <- get
|
||||
t <- checkJust $ typeOfExpression ps ae
|
||||
t <- typeOfExpression ae
|
||||
case ae of
|
||||
A.ExprVariable m v ->
|
||||
do tell ["ChanOut ("]
|
||||
|
|
@ -498,14 +487,13 @@ genOutputItem c (A.OutCounted m ce ae)
|
|||
tell [", "]
|
||||
fst $ abbrevVariable A.Abbrev t v
|
||||
tell [", "]
|
||||
let subT = fromJust $ subscriptType ps (A.Subscript m $ makeConstant m 0) t
|
||||
subT <- subscriptType (A.Subscript m $ makeConstant m 0) t
|
||||
genExpression ce
|
||||
tell [" * "]
|
||||
genBytesInType subT
|
||||
tell [");\n"]
|
||||
genOutputItem c (A.OutExpression m e)
|
||||
= do ps <- get
|
||||
t <- checkJust $ typeOfExpression ps e
|
||||
= do t <- typeOfExpression e
|
||||
case (t, e) of
|
||||
(A.Int, _) ->
|
||||
do tell ["ChanOutInt ("]
|
||||
|
|
@ -935,8 +923,7 @@ genAssign [v] el
|
|||
= case el of
|
||||
A.FunctionCallList m n es -> missing "function call"
|
||||
A.ExpressionList m [e] ->
|
||||
do ps <- get
|
||||
let t = fromJust $ typeOfVariable ps v
|
||||
do t <- typeOfVariable v
|
||||
doAssign t v e
|
||||
where
|
||||
doAssign :: A.Type -> A.Variable -> A.Expression -> CGen ()
|
||||
|
|
@ -954,8 +941,7 @@ genAssign [v] el
|
|||
--{{{ input
|
||||
genInput :: A.Variable -> A.InputMode -> CGen ()
|
||||
genInput c im
|
||||
= do ps <- get
|
||||
t <- checkJust $ typeOfVariable ps c
|
||||
= do t <- typeOfVariable c
|
||||
case t of
|
||||
A.Timer -> case im of
|
||||
A.InputSimple m [A.InVariable m' v] -> genTimerRead c v
|
||||
|
|
@ -967,8 +953,7 @@ genInput c im
|
|||
|
||||
genInputCase :: Meta -> A.Variable -> A.Structured -> CGen ()
|
||||
genInputCase m c s
|
||||
= do ps <- get
|
||||
t <- checkJust $ typeOfVariable ps c
|
||||
= do t <- typeOfVariable c
|
||||
let proto = case t of A.Chan (A.UserProtocol n) -> n
|
||||
tag <- makeNonce "case_tag"
|
||||
genName proto
|
||||
|
|
@ -1023,8 +1008,7 @@ genOutput c ois = sequence_ $ map (genOutputItem c) ois
|
|||
|
||||
genOutputCase :: A.Variable -> A.Name -> [A.OutputItem] -> CGen ()
|
||||
genOutputCase c tag ois
|
||||
= do ps <- get
|
||||
t <- checkJust $ typeOfVariable ps c
|
||||
= do t <- typeOfVariable c
|
||||
let proto = case t of A.Chan (A.UserProtocol n) -> n
|
||||
tell ["ChanOutInt ("]
|
||||
genVariable c
|
||||
|
|
|
|||
|
|
@ -22,7 +22,7 @@ sources = \
|
|||
Utils.hs
|
||||
|
||||
$(targets): $(sources)
|
||||
ghc -fglasgow-exts -o fco --make Main
|
||||
ghc -fglasgow-exts -fallow-undecidable-instances -o fco --make Main
|
||||
|
||||
CFLAGS = -g -std=gnu99 -Wall `kroc --cflags` `kroc --ccincpath`
|
||||
|
||||
|
|
|
|||
124
fco2/Parse.hs
124
fco2/Parse.hs
|
|
@ -1,7 +1,9 @@
|
|||
-- | Parse occam code into an AST.
|
||||
module Parse where
|
||||
|
||||
import Control.Monad.State (StateT, execStateT, liftIO, modify, get)
|
||||
import Control.Monad (liftM)
|
||||
import Control.Monad.Error (runErrorT)
|
||||
import Control.Monad.State (MonadState, StateT, execStateT, liftIO, modify, get, put)
|
||||
import Data.List
|
||||
import Data.Maybe
|
||||
import qualified IO
|
||||
|
|
@ -24,6 +26,16 @@ import Utils
|
|||
--{{{ setup stuff for Parsec
|
||||
type OccParser = GenParser Char ParseState
|
||||
|
||||
-- | Make MonadState functions work in the parser monad.
|
||||
-- This came from http://hackage.haskell.org/trac/ghc/ticket/1274 -- which means
|
||||
-- it'll probably be in a future GHC release anyway.
|
||||
instance MonadState st (GenParser tok st) where
|
||||
get = getState
|
||||
put = setState
|
||||
|
||||
instance Die (GenParser tok st) where
|
||||
die = fail
|
||||
|
||||
occamStyle
|
||||
= emptyDef
|
||||
{ P.commentLine = "--"
|
||||
|
|
@ -271,7 +283,7 @@ maybeSubscripted prodName inner subscripter typer
|
|||
postSubscripts :: A.Type -> OccParser [A.Subscript]
|
||||
postSubscripts t
|
||||
= (do sub <- postSubscript t
|
||||
t' <- pSubscriptType sub t
|
||||
t' <- subscriptType sub t
|
||||
rest <- postSubscripts t'
|
||||
return $ sub : rest)
|
||||
<|> return []
|
||||
|
|
@ -368,27 +380,6 @@ matchType et rt
|
|||
_ -> if rt == et then return () else bad
|
||||
where
|
||||
bad = fail $ "type mismatch (got " ++ show rt ++ "; expected " ++ show et ++ ")"
|
||||
|
||||
checkMaybe :: String -> Maybe a -> OccParser a
|
||||
checkMaybe msg op
|
||||
= case op of
|
||||
Just t -> return t
|
||||
Nothing -> fail msg
|
||||
|
||||
pTypeOf :: (ParseState -> a -> Maybe b) -> a -> OccParser b
|
||||
pTypeOf f item
|
||||
= do st <- getState
|
||||
checkMaybe "cannot compute type" $ f st item
|
||||
|
||||
pTypeOfVariable = pTypeOf typeOfVariable
|
||||
pTypeOfLiteral = pTypeOf typeOfLiteral
|
||||
pTypeOfExpression = pTypeOf typeOfExpression
|
||||
pSpecTypeOfName = pTypeOf specTypeOfName
|
||||
|
||||
pSubscriptType :: A.Subscript -> A.Type -> OccParser A.Type
|
||||
pSubscriptType sub t
|
||||
= do st <- getState
|
||||
checkMaybe "cannot subscript type" $ subscriptType st sub t
|
||||
--}}}
|
||||
|
||||
--{{{ name scoping
|
||||
|
|
@ -415,10 +406,11 @@ scopeIn n@(A.Name m nt s) t am
|
|||
A.ndType = t,
|
||||
A.ndAbbrevMode = am
|
||||
}
|
||||
setState $ psDefineName n' nd $ st {
|
||||
psNameCounter = (psNameCounter st) + 1,
|
||||
psLocalNames = (s, n') : (psLocalNames st)
|
||||
}
|
||||
defineName n' nd
|
||||
modify $ (\st -> st {
|
||||
psNameCounter = (psNameCounter st) + 1,
|
||||
psLocalNames = (s, n') : (psLocalNames st)
|
||||
})
|
||||
return n'
|
||||
|
||||
scopeOut :: A.Name -> OccParser ()
|
||||
|
|
@ -602,7 +594,7 @@ byte
|
|||
-- i.e. array literal
|
||||
table :: OccParser A.Literal
|
||||
table
|
||||
= maybeSubscripted "table" table' A.SubscriptedLiteral pTypeOfLiteral
|
||||
= maybeSubscripted "table" table' A.SubscriptedLiteral typeOfLiteral
|
||||
|
||||
table' :: OccParser A.Literal
|
||||
table'
|
||||
|
|
@ -611,11 +603,10 @@ table'
|
|||
<|> try (do { m <- md; (s, dim) <- stringLiteral; return $ A.Literal m (A.Array [dim] A.Byte) s })
|
||||
<|> do m <- md
|
||||
es <- tryXVX sLeft (sepBy1 expression sComma) sRight
|
||||
ps <- getState
|
||||
ets <- mapM (\e -> checkMaybe "can't type expression" $ typeOfExpression ps e) es
|
||||
ets <- mapM typeOfExpression es
|
||||
t <- listType m ets
|
||||
return $ A.Literal m t (A.ArrayLiteral m es)
|
||||
<|> maybeSliced table A.SubscriptedLiteral pTypeOfLiteral
|
||||
<|> maybeSliced table A.SubscriptedLiteral typeOfLiteral
|
||||
<?> "table'"
|
||||
|
||||
stringLiteral :: OccParser (A.LiteralRepr, A.Dimension)
|
||||
|
|
@ -638,7 +629,7 @@ character
|
|||
--{{{ expressions
|
||||
functionNameSingle :: OccParser A.Name
|
||||
= do n <- functionName
|
||||
rts <- (pTypeOf returnTypesOfFunction) n
|
||||
rts <- returnTypesOfFunction n
|
||||
case rts of
|
||||
[_] -> return n
|
||||
_ -> pzero
|
||||
|
|
@ -646,7 +637,7 @@ functionNameSingle :: OccParser A.Name
|
|||
|
||||
functionNameMulti :: OccParser A.Name
|
||||
= do n <- functionName
|
||||
rts <- (pTypeOf returnTypesOfFunction) n
|
||||
rts <- returnTypesOfFunction n
|
||||
case rts of
|
||||
[_] -> pzero
|
||||
_ -> return n
|
||||
|
|
@ -684,7 +675,7 @@ sizeExpr
|
|||
exprOfType :: A.Type -> OccParser A.Expression
|
||||
exprOfType wantT
|
||||
= do e <- expression
|
||||
t <- pTypeOfExpression e
|
||||
t <- typeOfExpression e
|
||||
matchType wantT t
|
||||
return e
|
||||
|
||||
|
|
@ -752,7 +743,7 @@ conversionMode
|
|||
--{{{ operands
|
||||
operand :: OccParser A.Expression
|
||||
operand
|
||||
= maybeSubscripted "operand" operand' A.SubscriptedExpr pTypeOfExpression
|
||||
= maybeSubscripted "operand" operand' A.SubscriptedExpr typeOfExpression
|
||||
|
||||
operand' :: OccParser A.Expression
|
||||
operand'
|
||||
|
|
@ -762,7 +753,7 @@ operand'
|
|||
|
||||
operandNotTable :: OccParser A.Expression
|
||||
operandNotTable
|
||||
= maybeSubscripted "operandNotTable" operandNotTable' A.SubscriptedExpr pTypeOfExpression
|
||||
= maybeSubscripted "operandNotTable" operandNotTable' A.SubscriptedExpr typeOfExpression
|
||||
|
||||
operandNotTable' :: OccParser A.Expression
|
||||
operandNotTable'
|
||||
|
|
@ -779,45 +770,45 @@ operandNotTable'
|
|||
--{{{ variables, channels, timers, ports
|
||||
variable :: OccParser A.Variable
|
||||
variable
|
||||
= maybeSubscripted "variable" variable' A.SubscriptedVariable pTypeOfVariable
|
||||
= maybeSubscripted "variable" variable' A.SubscriptedVariable typeOfVariable
|
||||
|
||||
variable' :: OccParser A.Variable
|
||||
variable'
|
||||
= try (do { m <- md; n <- variableName; return $ A.Variable m n })
|
||||
<|> try (maybeSliced variable A.SubscriptedVariable pTypeOfVariable)
|
||||
<|> try (maybeSliced variable A.SubscriptedVariable typeOfVariable)
|
||||
<?> "variable'"
|
||||
|
||||
channel :: OccParser A.Variable
|
||||
channel
|
||||
= maybeSubscripted "channel" channel' A.SubscriptedVariable pTypeOfVariable
|
||||
= maybeSubscripted "channel" channel' A.SubscriptedVariable typeOfVariable
|
||||
<?> "channel"
|
||||
|
||||
channel' :: OccParser A.Variable
|
||||
channel'
|
||||
= try (do { m <- md; n <- channelName; return $ A.Variable m n })
|
||||
<|> try (maybeSliced channel A.SubscriptedVariable pTypeOfVariable)
|
||||
<|> try (maybeSliced channel A.SubscriptedVariable typeOfVariable)
|
||||
<?> "channel'"
|
||||
|
||||
timer :: OccParser A.Variable
|
||||
timer
|
||||
= maybeSubscripted "timer" timer' A.SubscriptedVariable pTypeOfVariable
|
||||
= maybeSubscripted "timer" timer' A.SubscriptedVariable typeOfVariable
|
||||
<?> "timer"
|
||||
|
||||
timer' :: OccParser A.Variable
|
||||
timer'
|
||||
= try (do { m <- md; n <- timerName; return $ A.Variable m n })
|
||||
<|> try (maybeSliced timer A.SubscriptedVariable pTypeOfVariable)
|
||||
<|> try (maybeSliced timer A.SubscriptedVariable typeOfVariable)
|
||||
<?> "timer'"
|
||||
|
||||
port :: OccParser A.Variable
|
||||
port
|
||||
= maybeSubscripted "port" port' A.SubscriptedVariable pTypeOfVariable
|
||||
= maybeSubscripted "port" port' A.SubscriptedVariable typeOfVariable
|
||||
<?> "port"
|
||||
|
||||
port' :: OccParser A.Variable
|
||||
port'
|
||||
= try (do { m <- md; n <- portName; return $ A.Variable m n })
|
||||
<|> try (maybeSliced port A.SubscriptedVariable pTypeOfVariable)
|
||||
<|> try (maybeSliced port A.SubscriptedVariable typeOfVariable)
|
||||
<?> "port'"
|
||||
--}}}
|
||||
--{{{ protocols
|
||||
|
|
@ -880,25 +871,25 @@ declaration
|
|||
abbreviation :: OccParser A.Specification
|
||||
abbreviation
|
||||
= do m <- md
|
||||
(do { (n, v) <- tryVXV newVariableName sIS variable; sColon; eol; t <- pTypeOfVariable v; return $ A.Specification m 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 m n $ A.Is m A.Abbrev s v }
|
||||
(do { (n, v) <- tryVXV newVariableName sIS variable; sColon; eol; t <- typeOfVariable v; return $ A.Specification m 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 <- typeOfVariable v; matchType s t; return $ A.Specification m n $ A.Is m A.Abbrev s v }
|
||||
<|> valIsAbbrev
|
||||
<|> try (do { n <- newChannelName; sIS; c <- channel; sColon; eol; t <- pTypeOfVariable c; return $ A.Specification m n $ A.Is m A.Abbrev t c })
|
||||
<|> try (do { n <- newTimerName; sIS; c <- timer; sColon; eol; t <- pTypeOfVariable c; return $ A.Specification m n $ A.Is m A.Abbrev t c })
|
||||
<|> try (do { n <- newPortName; sIS; c <- port; sColon; eol; t <- pTypeOfVariable c; return $ A.Specification m 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 m 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 m 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 m 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 m 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 m n $ A.IsChannelArray m s cs }))
|
||||
<|> try (do { n <- newChannelName; sIS; c <- channel; sColon; eol; t <- typeOfVariable c; return $ A.Specification m n $ A.Is m A.Abbrev t c })
|
||||
<|> try (do { n <- newTimerName; sIS; c <- timer; sColon; eol; t <- typeOfVariable c; return $ A.Specification m n $ A.Is m A.Abbrev t c })
|
||||
<|> try (do { n <- newPortName; sIS; c <- port; sColon; eol; t <- typeOfVariable c; return $ A.Specification m n $ A.Is m A.Abbrev t c })
|
||||
<|> try (do { s <- specifier; n <- newChannelName; sIS; c <- channel; sColon; eol; t <- typeOfVariable c; matchType s t; return $ A.Specification m n $ A.Is m A.Abbrev s c })
|
||||
<|> try (do { s <- specifier; n <- newTimerName; sIS; c <- timer; sColon; eol; t <- typeOfVariable c; matchType s t; return $ A.Specification m n $ A.Is m A.Abbrev s c })
|
||||
<|> try (do { s <- specifier; n <- newPortName; sIS; c <- port; sColon; eol; t <- typeOfVariable c; matchType s t; return $ A.Specification m n $ A.Is m A.Abbrev s c })
|
||||
<|> try (do { n <- newChannelName; sIS; sLeft; cs <- sepBy1 channel sComma; sRight; sColon; eol; ts <- mapM typeOfVariable cs; t <- listType m ts; return $ A.Specification m n $ A.IsChannelArray m t cs })
|
||||
<|> try (do { s <- specifier; n <- newChannelName; sIS; sLeft; cs <- sepBy1 channel sComma; sRight; sColon; eol; ts <- mapM typeOfVariable cs; t <- listType m ts; matchType s t; return $ A.Specification m n $ A.IsChannelArray m s cs }))
|
||||
<?> "abbreviation"
|
||||
|
||||
valIsAbbrev :: OccParser A.Specification
|
||||
valIsAbbrev
|
||||
= do m <- md
|
||||
sVAL
|
||||
(n, t, e) <- do { (n, e) <- tryVXV newVariableName sIS expression; sColon; eol; t <- pTypeOfExpression e; return (n, t, e) }
|
||||
<|> do { s <- specifier; n <- newVariableName; sIS; e <- expression; sColon; eol; t <- pTypeOfExpression e; matchType s t; return (n, t, e) }
|
||||
(n, t, e) <- do { (n, e) <- tryVXV newVariableName sIS expression; sColon; eol; t <- typeOfExpression e; return (n, t, e) }
|
||||
<|> do { s <- specifier; n <- newVariableName; sIS; e <- expression; sColon; eol; t <- typeOfExpression e; matchType s t; return (n, t, e) }
|
||||
return $ A.Specification m n $ A.IsExpr m A.ValAbbrev t e
|
||||
<?> "VAL IS abbreviation"
|
||||
|
||||
|
|
@ -1097,10 +1088,7 @@ channelOutput
|
|||
c <- tryVX channel sBang
|
||||
-- This is an ambiguity in the occam grammar; you can't tell in "a ! b"
|
||||
-- whether b is a variable or a tag, without knowing the type of a.
|
||||
st <- getState
|
||||
isCase <- case typeOfVariable st c of
|
||||
Just t -> return $ isCaseProtocolType st t
|
||||
Nothing -> fail $ "cannot figure out the type of " ++ show c
|
||||
isCase <- typeOfVariable c >>= isCaseProtocolType
|
||||
if isCase
|
||||
then
|
||||
(try (do { t <- tagName; sSemi; os <- sepBy1 outputItem sSemi; eol; return $ A.OutputCase m c t os })
|
||||
|
|
@ -1303,7 +1291,7 @@ procInstance :: OccParser A.Process
|
|||
procInstance
|
||||
= do m <- md
|
||||
n <- tryVX procName sLeftR
|
||||
st <- pSpecTypeOfName n
|
||||
st <- specTypeOfName n
|
||||
let fs = case st of A.Proc _ fs _ -> fs
|
||||
as <- actuals fs
|
||||
sRightR
|
||||
|
|
@ -1317,10 +1305,10 @@ actuals fs = intersperseP (map actual fs) sComma
|
|||
actual :: A.Formal -> OccParser A.Actual
|
||||
actual (A.Formal am t n)
|
||||
= do case am of
|
||||
A.ValAbbrev -> do { e <- expression; et <- pTypeOfExpression e; matchType t et; return $ A.ActualExpression t e } <?> "actual expression for " ++ an
|
||||
A.ValAbbrev -> do { e <- expression; et <- typeOfExpression e; matchType t et; return $ A.ActualExpression t e } <?> "actual expression for " ++ an
|
||||
_ -> if isChannelType t
|
||||
then do { c <- channel; ct <- pTypeOfVariable c; matchType t ct; return $ A.ActualVariable am t c } <?> "actual channel for " ++ an
|
||||
else do { v <- variable; vt <- pTypeOfVariable v; matchType t vt; return $ A.ActualVariable am t v } <?> "actual variable for " ++ an
|
||||
then do { c <- channel; ct <- typeOfVariable c; matchType t ct; return $ A.ActualVariable am t c } <?> "actual channel for " ++ an
|
||||
else do { v <- variable; vt <- typeOfVariable v; matchType t vt; return $ A.ActualVariable am t v } <?> "actual variable for " ++ an
|
||||
where
|
||||
an = A.nameName n
|
||||
--}}}
|
||||
|
|
@ -1417,16 +1405,14 @@ mangleModName mod
|
|||
then mod
|
||||
else mod ++ ".occ"
|
||||
|
||||
type LoaderM a = StateT ParseState IO a
|
||||
|
||||
-- | Load all the source files necessary for a program.
|
||||
-- We have to do this now, before entering the parser, because the parser
|
||||
-- doesn't run in the IO monad. If there were a monad transformer version of
|
||||
-- Parsec then we could just open files as we need them.
|
||||
loadSource :: String -> ParseState -> IO ParseState
|
||||
loadSource file ps = execStateT (load file file) ps
|
||||
loadSource file ps = execStateT (runErrorT (load file file)) ps
|
||||
where
|
||||
load :: String -> String -> LoaderM ()
|
||||
load :: String -> String -> PassM ()
|
||||
load file realName
|
||||
= do ps <- get
|
||||
case lookup file (psSourceFiles ps) of
|
||||
|
|
@ -1453,7 +1439,7 @@ parseFile file ps
|
|||
= do let source = fromJust $ lookup file (psSourceFiles ps)
|
||||
let ps' = ps { psLoadedFiles = file : psLoadedFiles ps }
|
||||
case runParser sourceFile ps' file source of
|
||||
Left err -> die $ "Parse error: " ++ show err
|
||||
Left err -> dieIO $ "Parse error: " ++ show err
|
||||
Right (p, ps'') -> return (replaceMain p, ps'')
|
||||
where
|
||||
replaceMain :: A.Process -> A.Process -> A.Process
|
||||
|
|
|
|||
|
|
@ -5,6 +5,7 @@ import Data.Generics
|
|||
import Control.Monad.State
|
||||
|
||||
import qualified AST as A
|
||||
import Errors
|
||||
import Metadata
|
||||
|
||||
data Flag = ParseOnly | Verbose | Debug
|
||||
|
|
@ -56,16 +57,28 @@ emptyState = ParseState {
|
|||
psAdditionalArgs = []
|
||||
}
|
||||
|
||||
-- | Class of monads which keep a ParseState.
|
||||
-- (This is just shorthand for the equivalent MonadState constraint.)
|
||||
class MonadState ParseState m => PSM m
|
||||
instance MonadState ParseState m => PSM m
|
||||
|
||||
-- | Add the definition of a name.
|
||||
psDefineName :: A.Name -> A.NameDef -> ParseState -> ParseState
|
||||
psDefineName n nd ps = ps { psNames = (A.nameName n, nd) : psNames ps }
|
||||
defineName :: PSM m => A.Name -> A.NameDef -> m ()
|
||||
defineName n nd = modify $ (\ps -> ps { psNames = (A.nameName n, nd) : psNames ps })
|
||||
|
||||
-- | Find the definition of a name.
|
||||
psLookupName :: ParseState -> A.Name -> Maybe A.NameDef
|
||||
psLookupName ps n = lookup (A.nameName n) (psNames ps)
|
||||
|
||||
lookupName :: (PSM m, Die m) => A.Name -> m A.NameDef
|
||||
lookupName n
|
||||
= do ps <- get
|
||||
case lookup (A.nameName n) (psNames ps) of
|
||||
Just nd -> return nd
|
||||
Nothing -> die $ "cannot find name " ++ A.nameName n
|
||||
|
||||
-- | Generate a throwaway unique name.
|
||||
makeNonce :: MonadState ParseState m => String -> m String
|
||||
makeNonce :: PSM m => String -> m String
|
||||
makeNonce s
|
||||
= do ps <- get
|
||||
let i = psNonceCounter ps
|
||||
|
|
@ -73,13 +86,13 @@ makeNonce s
|
|||
return $ s ++ "_n" ++ show i
|
||||
|
||||
-- | Add a pulled item to the collection.
|
||||
addPulled :: MonadState ParseState m => (A.Process -> A.Process) -> m ()
|
||||
addPulled :: PSM m => (A.Process -> A.Process) -> m ()
|
||||
addPulled item
|
||||
= do ps <- get
|
||||
put $ ps { psPulledItems = item : psPulledItems ps }
|
||||
|
||||
-- | Apply pulled items to a Process.
|
||||
applyPulled :: MonadState ParseState m => A.Process -> m A.Process
|
||||
applyPulled :: PSM m => A.Process -> m A.Process
|
||||
applyPulled ast
|
||||
= do ps <- get
|
||||
let ast' = foldl (\p f -> f p) ast (psPulledItems ps)
|
||||
|
|
@ -87,7 +100,7 @@ applyPulled ast
|
|||
return ast'
|
||||
|
||||
-- | Generate and define a nonce specification.
|
||||
defineNonce :: MonadState ParseState m => Meta -> String -> A.SpecType -> A.NameType -> A.AbbrevMode -> m A.Specification
|
||||
defineNonce :: PSM m => Meta -> String -> A.SpecType -> A.NameType -> A.AbbrevMode -> m A.Specification
|
||||
defineNonce m s st nt am
|
||||
= do ns <- makeNonce s
|
||||
let n = A.Name m A.ProcName ns
|
||||
|
|
@ -99,33 +112,34 @@ defineNonce m s st nt am
|
|||
A.ndType = st,
|
||||
A.ndAbbrevMode = am
|
||||
}
|
||||
modify $ psDefineName n nd
|
||||
defineName n nd
|
||||
return $ A.Specification m n st
|
||||
|
||||
-- | Generate and define a no-arg wrapper PROC around a process.
|
||||
makeNonceProc :: MonadState ParseState m => Meta -> A.Process -> m A.Specification
|
||||
makeNonceProc :: PSM m => Meta -> A.Process -> m A.Specification
|
||||
makeNonceProc m p
|
||||
= defineNonce m "wrapper_proc" (A.Proc m [] p) A.ProcName A.Abbrev
|
||||
|
||||
-- | Generate and define a variable abbreviation.
|
||||
makeNonceIs :: MonadState ParseState m => String -> Meta -> A.Type -> A.AbbrevMode -> A.Variable -> m A.Specification
|
||||
makeNonceIs :: PSM m => String -> Meta -> A.Type -> A.AbbrevMode -> A.Variable -> m A.Specification
|
||||
makeNonceIs s m t am v
|
||||
= defineNonce m s (A.Is m am t v) A.VariableName am
|
||||
|
||||
-- | Generate and define an expression abbreviation.
|
||||
makeNonceIsExpr :: MonadState ParseState m => String -> Meta -> A.Type -> A.Expression -> m A.Specification
|
||||
makeNonceIsExpr :: PSM m => String -> Meta -> A.Type -> A.Expression -> m A.Specification
|
||||
makeNonceIsExpr s m t e
|
||||
= defineNonce m s (A.IsExpr m A.ValAbbrev t e) A.VariableName A.ValAbbrev
|
||||
|
||||
-- | Generate and define a variable.
|
||||
makeNonceVariable :: MonadState ParseState m => String -> Meta -> A.Type -> A.NameType -> A.AbbrevMode -> m A.Specification
|
||||
makeNonceVariable :: PSM m => String -> Meta -> A.Type -> A.NameType -> A.AbbrevMode -> m A.Specification
|
||||
makeNonceVariable s m t nt am
|
||||
= defineNonce m s (A.Declaration m t) nt am
|
||||
|
||||
-- | Is a name on the list of constants?
|
||||
isConstantName :: ParseState -> A.Name -> Bool
|
||||
isConstantName ps n
|
||||
= case lookup (A.nameName n) (psConstants ps) of
|
||||
Just _ -> True
|
||||
Nothing -> False
|
||||
isConstantName :: PSM m => A.Name -> m Bool
|
||||
isConstantName n
|
||||
= do ps <- get
|
||||
case lookup (A.nameName n) (psConstants ps) of
|
||||
Just _ -> return True
|
||||
Nothing -> return False
|
||||
|
||||
|
|
|
|||
32
fco2/Pass.hs
32
fco2/Pass.hs
|
|
@ -6,16 +6,28 @@ import Control.Monad.State
|
|||
import System.IO
|
||||
|
||||
import qualified AST as A
|
||||
import Errors
|
||||
import ParseState
|
||||
import PrettyShow
|
||||
|
||||
type PassM a = StateT ParseState IO a
|
||||
-- | The monad in which AST-mangling passes operate.
|
||||
type PassM = ErrorT String (StateT ParseState IO)
|
||||
|
||||
instance Die PassM where
|
||||
die = throwError
|
||||
|
||||
-- | The type of an AST-mangling pass.
|
||||
type Pass = A.Process -> PassM A.Process
|
||||
|
||||
-- | Run a pass, dying with the appropriate error if it fails.
|
||||
runPass :: Pass -> A.Process -> ParseState -> IO (A.Process, ParseState)
|
||||
runPass pass ast st = runStateT (pass ast) st
|
||||
runPass pass ast st
|
||||
= do (v, ps) <- runStateT (runErrorT (pass ast)) st
|
||||
case v of
|
||||
Left e -> dieIO e
|
||||
Right r -> return (r, ps)
|
||||
|
||||
-- | Compose a list of passes into a single pass.
|
||||
runPasses :: [(String, Pass)] -> A.Process -> PassM A.Process
|
||||
runPasses [] ast = return ast
|
||||
runPasses ((s, p):ps) ast
|
||||
|
|
@ -26,22 +38,33 @@ runPasses ((s, p):ps) ast
|
|||
debug $ "}}}"
|
||||
runPasses ps ast'
|
||||
|
||||
-- | Print a progress message if appropriate.
|
||||
progress :: String -> PassM ()
|
||||
progress s
|
||||
= do ps <- get
|
||||
liftIO $ progressIO ps s
|
||||
|
||||
-- | Print a progress message if appropriate (in the IO monad).
|
||||
progressIO :: ParseState -> String -> IO ()
|
||||
progressIO ps s = when (Verbose `elem` psFlags ps) $ hPutStrLn stderr s
|
||||
|
||||
-- | Print a debugging message if appropriate.
|
||||
debug :: String -> PassM ()
|
||||
debug s
|
||||
= do ps <- get
|
||||
liftIO $ debugIO ps s
|
||||
|
||||
-- | Print a debugging message if appropriate (in the IO monad).
|
||||
debugIO :: ParseState -> String -> IO ()
|
||||
debugIO ps s = when (Debug `elem` psFlags ps) $ hPutStrLn stderr s
|
||||
|
||||
-- | Dump the AST and parse state if appropriate.
|
||||
debugAST :: A.Process -> PassM ()
|
||||
debugAST p
|
||||
= do ps <- get
|
||||
liftIO $ debugASTIO ps p
|
||||
|
||||
-- | Dump the AST and parse state if appropriate (in the IO monad).
|
||||
debugASTIO :: ParseState -> A.Process -> IO ()
|
||||
debugASTIO ps p
|
||||
= do debugIO ps $ "{{{ AST"
|
||||
|
|
@ -51,8 +74,3 @@ debugASTIO ps p
|
|||
debugIO ps $ pshow ps
|
||||
debugIO ps $ "}}}"
|
||||
|
||||
debugAST :: A.Process -> PassM ()
|
||||
debugAST p
|
||||
= do ps <- get
|
||||
liftIO $ debugASTIO ps p
|
||||
|
||||
|
|
|
|||
|
|
@ -46,7 +46,7 @@ functionsToProcs = doGeneric `extM` doSpecification
|
|||
A.ndType = st,
|
||||
A.ndAbbrevMode = A.Original
|
||||
}
|
||||
modify $ psDefineName n nd
|
||||
defineName n nd
|
||||
doGeneric spec
|
||||
doSpecification s = doGeneric s
|
||||
|
||||
|
|
@ -89,8 +89,7 @@ pullUp = doGeneric `extM` doProcess `extM` doSpecification `extM` doExpression `
|
|||
doExpression :: A.Expression -> PassM A.Expression
|
||||
doExpression e
|
||||
= do e' <- doExpressionFunc e
|
||||
ps <- get
|
||||
let t = fromJust $ typeOfExpression ps e'
|
||||
t <- typeOfExpression e'
|
||||
case t of
|
||||
A.Array _ _ ->
|
||||
case e' of
|
||||
|
|
@ -109,13 +108,11 @@ pullUp = doGeneric `extM` doProcess `extM` doSpecification `extM` doExpression `
|
|||
doVariable :: A.Variable -> PassM A.Variable
|
||||
doVariable v@(A.SubscriptedVariable m _ _)
|
||||
= do v' <- doGeneric v
|
||||
ps <- get
|
||||
let t = fromJust $ typeOfVariable ps v'
|
||||
t <- typeOfVariable v'
|
||||
case t of
|
||||
A.Array _ _ ->
|
||||
do let am = case fromJust $ abbrevModeOfVariable ps v' of
|
||||
A.Original -> A.Abbrev
|
||||
t -> t
|
||||
do origAM <- abbrevModeOfVariable v'
|
||||
let am = makeAbbrevAM origAM
|
||||
spec@(A.Specification _ n _) <- makeNonceIs "array_slice" m t am v'
|
||||
addPulled $ A.ProcSpec m spec
|
||||
return $ A.Variable m n
|
||||
|
|
@ -126,9 +123,9 @@ pullUp = doGeneric `extM` doProcess `extM` doSpecification `extM` doExpression `
|
|||
convertFuncCall :: Meta -> A.Name -> [A.Expression] -> PassM [A.Variable]
|
||||
convertFuncCall m n es
|
||||
= do es' <- pullUp es
|
||||
ps <- get
|
||||
let ets = [fromJust $ typeOfExpression ps e | e <- es']
|
||||
ets <- sequence [typeOfExpression e | e <- es']
|
||||
|
||||
ps <- get
|
||||
let rts = fromJust $ lookup (A.nameName n) (psFunctionReturns ps)
|
||||
specs <- sequence [makeNonceVariable "return_actual" m t A.VariableName A.Original | t <- rts]
|
||||
sequence_ [addPulled $ A.ProcSpec m spec | spec <- specs]
|
||||
|
|
|
|||
|
|
@ -50,8 +50,7 @@ removeParAssign = doGeneric `extM` doProcess
|
|||
|
||||
doProcess :: A.Process -> PassM A.Process
|
||||
doProcess (A.Assign m vs@(_:_:_) (A.ExpressionList _ es))
|
||||
= do ps <- get
|
||||
let ts = [fromJust $ typeOfVariable ps v | v <- vs]
|
||||
= do ts <- mapM typeOfVariable vs
|
||||
specs <- sequence [makeNonceVariable "assign_temp" m t A.VariableName A.Original | t <- ts]
|
||||
let temps = [A.Variable m n | A.Specification _ n _ <- specs]
|
||||
let first = [A.Assign m [v] (A.ExpressionList m [e]) | (v, e) <- zip temps es]
|
||||
|
|
|
|||
20
fco2/TLP.hs
20
fco2/TLP.hs
|
|
@ -8,6 +8,7 @@ import Data.List
|
|||
import Data.Maybe
|
||||
|
||||
import qualified AST as A
|
||||
import Errors
|
||||
import Metadata
|
||||
import ParseState
|
||||
import Types
|
||||
|
|
@ -17,26 +18,27 @@ data TLPChannel = TLPIn | TLPOut | TLPError
|
|||
|
||||
-- | Get the name of the TLP and the channels it uses.
|
||||
-- Fail if the process isn't using a valid interface.
|
||||
tlpInterface :: (MonadState ParseState m, MonadError String m) => m (A.Name, [TLPChannel])
|
||||
tlpInterface :: (PSM m, Die m) => m (A.Name, [TLPChannel])
|
||||
tlpInterface
|
||||
= do ps <- get
|
||||
let mainName = snd $ head $ psMainLocals ps
|
||||
formals <- case fromJust $ specTypeOfName ps mainName of
|
||||
st <- specTypeOfName mainName
|
||||
formals <- case st of
|
||||
A.Proc _ fs _ -> return fs
|
||||
_ -> throwError "Last definition is not a PROC"
|
||||
_ -> die "Last definition is not a PROC"
|
||||
chans <- mapM tlpChannel formals
|
||||
when ((nub chans) /= chans) $ throwError "Channels used more than once in TLP"
|
||||
when ((nub chans) /= chans) $ die "Channels used more than once in TLP"
|
||||
return (mainName, chans)
|
||||
where
|
||||
tlpChannel :: (MonadState ParseState m, MonadError String m) => A.Formal -> m TLPChannel
|
||||
tlpChannel :: (PSM m, Die m) => A.Formal -> m TLPChannel
|
||||
tlpChannel (A.Formal _ (A.Chan A.Byte) n)
|
||||
= do ps <- get
|
||||
let origN = A.ndOrigName $ fromJust $ psLookupName ps n
|
||||
= do def <- lookupName n
|
||||
let origN = A.ndOrigName def
|
||||
case lookup origN tlpChanNames of
|
||||
Just c -> return c
|
||||
_ -> throwError $ "TLP formal " ++ show n ++ " has unrecognised name"
|
||||
_ -> die $ "TLP formal " ++ show n ++ " has unrecognised name"
|
||||
tlpChannel (A.Formal _ _ n)
|
||||
= throwError $ "TLP formal " ++ show n ++ " has unrecognised type"
|
||||
= die $ "TLP formal " ++ show n ++ " has unrecognised type"
|
||||
|
||||
tlpChanNames :: [(String, TLPChannel)]
|
||||
tlpChanNames
|
||||
|
|
|
|||
|
|
@ -19,14 +19,6 @@ nothing to do with parsing.
|
|||
|
||||
Types needs cleaning up and Haddocking.
|
||||
|
||||
Types should provide versions of the functions that work in a state monad.
|
||||
If we can make them work in the parser monad (by providing an instance of
|
||||
MonadState for it?), that'd be even better.
|
||||
See: http://hackage.haskell.org/trac/ghc/ticket/1274
|
||||
|
||||
Errors is nearly useless, because none of our monads really fail in sensible
|
||||
ways.
|
||||
|
||||
## Driver
|
||||
|
||||
Add an option for whether to compile out overflow/bounds checks.
|
||||
|
|
|
|||
166
fco2/Types.hs
166
fco2/Types.hs
|
|
@ -4,62 +4,62 @@ module Types where
|
|||
-- FIXME: This module is a mess -- sort it and document the functions.
|
||||
|
||||
import Control.Monad
|
||||
import Control.Monad.State
|
||||
import Data.Generics
|
||||
import Data.Maybe
|
||||
|
||||
import qualified AST as A
|
||||
import Errors
|
||||
import ParseState
|
||||
import Metadata
|
||||
|
||||
perhaps :: Maybe a -> (a -> b) -> Maybe b
|
||||
perhaps m f = m >>= (Just . f)
|
||||
specTypeOfName :: (PSM m, Die m) => A.Name -> m A.SpecType
|
||||
specTypeOfName n
|
||||
= liftM A.ndType (lookupName n)
|
||||
|
||||
specTypeOfName :: ParseState -> A.Name -> Maybe A.SpecType
|
||||
specTypeOfName ps n
|
||||
= (psLookupName ps n) `perhaps` A.ndType
|
||||
abbrevModeOfName :: (PSM m, Die m) => A.Name -> m A.AbbrevMode
|
||||
abbrevModeOfName n
|
||||
= liftM A.ndAbbrevMode (lookupName n)
|
||||
|
||||
abbrevModeOfName :: ParseState -> A.Name -> Maybe A.AbbrevMode
|
||||
abbrevModeOfName ps n
|
||||
= (psLookupName ps n) `perhaps` A.ndAbbrevMode
|
||||
|
||||
typeOfName :: ParseState -> A.Name -> Maybe A.Type
|
||||
typeOfName ps n
|
||||
= case specTypeOfName ps n of
|
||||
Just (A.Declaration m t) -> Just t
|
||||
Just (A.Is m am t v) -> typeOfVariable ps v
|
||||
Just (A.IsExpr m am t e) -> typeOfExpression ps e
|
||||
Just (A.IsChannelArray m t (c:_)) -> typeOfVariable ps c `perhaps` A.Array [A.UnknownDimension]
|
||||
Just (A.Retypes m am t v) -> Just t
|
||||
Just (A.RetypesExpr m am t e) -> Just t
|
||||
_ -> Nothing
|
||||
typeOfName :: (PSM m, Die m) => A.Name -> m A.Type
|
||||
typeOfName n
|
||||
= do st <- specTypeOfName n
|
||||
case st of
|
||||
A.Declaration _ t -> return t
|
||||
A.Is _ _ _ v -> typeOfVariable v
|
||||
A.IsExpr _ _ _ e -> typeOfExpression e
|
||||
A.IsChannelArray _ _ (c:_) -> liftM (A.Array [A.UnknownDimension]) $ typeOfVariable c
|
||||
A.Retypes _ _ t _ -> return t
|
||||
A.RetypesExpr _ _ t _ -> return t
|
||||
_ -> die $ "cannot type name " ++ show st
|
||||
|
||||
--{{{ identifying types
|
||||
typeOfRecordField :: ParseState -> A.Type -> A.Name -> Maybe A.Type
|
||||
typeOfRecordField ps (A.UserDataType rec) field
|
||||
= do st <- specTypeOfName ps rec
|
||||
typeOfRecordField :: (PSM m, Die m) => A.Type -> A.Name -> m A.Type
|
||||
typeOfRecordField (A.UserDataType rec) field
|
||||
= do st <- specTypeOfName rec
|
||||
case st of
|
||||
A.DataTypeRecord _ _ fs -> lookup field fs
|
||||
_ -> Nothing
|
||||
typeOfRecordField _ _ _ = Nothing
|
||||
A.DataTypeRecord _ _ fs -> checkJust "unknown record field" $ lookup field fs
|
||||
_ -> die "not record type"
|
||||
typeOfRecordField _ _ = die "not record type"
|
||||
|
||||
subscriptType :: ParseState -> A.Subscript -> A.Type -> Maybe A.Type
|
||||
subscriptType _ (A.SubscriptFromFor _ _ _) t = Just t
|
||||
subscriptType _ (A.SubscriptFrom _ _) t = Just t
|
||||
subscriptType _ (A.SubscriptFor _ _) t = Just t
|
||||
subscriptType ps (A.SubscriptField _ tag) t = typeOfRecordField ps t tag
|
||||
subscriptType _ (A.Subscript _ _) (A.Array [_] t) = Just t
|
||||
subscriptType _ (A.Subscript _ _) (A.Array (_:ds) t) = Just $ A.Array ds t
|
||||
subscriptType _ _ _ = Nothing
|
||||
subscriptType :: (PSM m, Die m) => A.Subscript -> A.Type -> m A.Type
|
||||
subscriptType (A.SubscriptFromFor _ _ _) t = return t
|
||||
subscriptType (A.SubscriptFrom _ _) t = return t
|
||||
subscriptType (A.SubscriptFor _ _) t = return t
|
||||
subscriptType (A.SubscriptField _ tag) t = typeOfRecordField t tag
|
||||
subscriptType (A.Subscript _ _) (A.Array [_] t) = return t
|
||||
subscriptType (A.Subscript _ _) (A.Array (_:ds) t) = return $ A.Array ds t
|
||||
subscriptType _ _ = die "unsubscriptable type"
|
||||
|
||||
typeOfVariable :: ParseState -> A.Variable -> Maybe A.Type
|
||||
typeOfVariable ps (A.Variable m n) = typeOfName ps n
|
||||
typeOfVariable ps (A.SubscriptedVariable m s v)
|
||||
= typeOfVariable ps v >>= subscriptType ps s
|
||||
typeOfVariable :: (PSM m, Die m) => A.Variable -> m A.Type
|
||||
typeOfVariable (A.Variable m n) = typeOfName n
|
||||
typeOfVariable (A.SubscriptedVariable m s v)
|
||||
= typeOfVariable v >>= subscriptType s
|
||||
|
||||
abbrevModeOfVariable :: ParseState -> A.Variable -> Maybe A.AbbrevMode
|
||||
abbrevModeOfVariable ps (A.Variable _ n) = abbrevModeOfName ps n
|
||||
abbrevModeOfVariable ps (A.SubscriptedVariable _ sub v)
|
||||
= do am <- abbrevModeOfVariable ps v
|
||||
abbrevModeOfVariable :: (PSM m, Die m) => A.Variable -> m A.AbbrevMode
|
||||
abbrevModeOfVariable (A.Variable _ n) = abbrevModeOfName n
|
||||
abbrevModeOfVariable (A.SubscriptedVariable _ sub v)
|
||||
= do am <- abbrevModeOfVariable v
|
||||
return $ case (am, sub) of
|
||||
(A.ValAbbrev, A.Subscript _ _) -> A.ValAbbrev
|
||||
(_, A.Subscript _ _) -> A.Original
|
||||
|
|
@ -77,51 +77,53 @@ dyadicIsBoolean A.MoreEq = True
|
|||
dyadicIsBoolean A.After = True
|
||||
dyadicIsBoolean _ = False
|
||||
|
||||
typeOfExpression :: ParseState -> A.Expression -> Maybe A.Type
|
||||
typeOfExpression ps e
|
||||
typeOfExpression :: (PSM m, Die m) => A.Expression -> m A.Type
|
||||
typeOfExpression e
|
||||
= case e of
|
||||
A.Monadic m op e -> typeOfExpression ps e
|
||||
A.Monadic m op e -> typeOfExpression e
|
||||
A.Dyadic m op e f ->
|
||||
if dyadicIsBoolean op then Just A.Bool else typeOfExpression ps e
|
||||
A.MostPos m t -> Just t
|
||||
A.MostNeg m t -> Just t
|
||||
A.SizeType m t -> Just A.Int
|
||||
A.SizeExpr m t -> Just A.Int
|
||||
A.SizeVariable m t -> Just A.Int
|
||||
A.Conversion m cm t e -> Just t
|
||||
A.ExprVariable m v -> typeOfVariable ps v
|
||||
A.ExprLiteral m l -> typeOfLiteral ps l
|
||||
A.True m -> Just A.Bool
|
||||
A.False m -> Just A.Bool
|
||||
A.FunctionCall m n es ->
|
||||
case returnTypesOfFunction ps n of
|
||||
Just [t] -> Just t
|
||||
_ -> Nothing
|
||||
if dyadicIsBoolean op then return A.Bool else typeOfExpression e
|
||||
A.MostPos m t -> return t
|
||||
A.MostNeg m t -> return t
|
||||
A.SizeType m t -> return A.Int
|
||||
A.SizeExpr m t -> return A.Int
|
||||
A.SizeVariable m t -> return A.Int
|
||||
A.Conversion m cm t e -> return t
|
||||
A.ExprVariable m v -> typeOfVariable v
|
||||
A.ExprLiteral m l -> typeOfLiteral l
|
||||
A.True m -> return A.Bool
|
||||
A.False m -> return A.Bool
|
||||
A.FunctionCall m n es -> liftM head $ returnTypesOfFunction n
|
||||
A.SubscriptedExpr m s e ->
|
||||
typeOfExpression ps e >>= subscriptType ps s
|
||||
A.BytesInExpr m e -> Just A.Int
|
||||
A.BytesInType m t -> Just A.Int
|
||||
A.OffsetOf m t n -> Just A.Int
|
||||
typeOfExpression e >>= subscriptType s
|
||||
A.BytesInExpr m e -> return A.Int
|
||||
A.BytesInType m t -> return A.Int
|
||||
A.OffsetOf m t n -> return A.Int
|
||||
|
||||
typeOfLiteral :: ParseState -> A.Literal -> Maybe A.Type
|
||||
typeOfLiteral ps (A.Literal m t lr) = Just t
|
||||
typeOfLiteral ps (A.SubscriptedLiteral m s l)
|
||||
= typeOfLiteral ps l >>= subscriptType ps s
|
||||
typeOfLiteral :: (PSM m, Die m) => A.Literal -> m A.Type
|
||||
typeOfLiteral (A.Literal m t lr) = return t
|
||||
typeOfLiteral (A.SubscriptedLiteral m s l)
|
||||
= typeOfLiteral l >>= subscriptType s
|
||||
--}}}
|
||||
|
||||
returnTypesOfFunction :: ParseState -> A.Name -> Maybe [A.Type]
|
||||
returnTypesOfFunction ps n
|
||||
= case specTypeOfName ps n of
|
||||
Just (A.Function m rs fs vp) -> Just rs
|
||||
-- If it's not defined as a function, it might have been converted to a proc.
|
||||
_ -> lookup (A.nameName n) (psFunctionReturns ps)
|
||||
returnTypesOfFunction :: (PSM m, Die m) => A.Name -> m [A.Type]
|
||||
returnTypesOfFunction n
|
||||
= do st <- specTypeOfName n
|
||||
case st of
|
||||
A.Function m rs fs vp -> return rs
|
||||
-- If it's not defined as a function, it might have been converted to a proc.
|
||||
_ ->
|
||||
do ps <- get
|
||||
checkJust "not defined as a function" $
|
||||
lookup (A.nameName n) (psFunctionReturns ps)
|
||||
|
||||
isCaseProtocolType :: ParseState -> A.Type -> Bool
|
||||
isCaseProtocolType ps (A.Chan (A.UserProtocol pr))
|
||||
= case specTypeOfName ps pr of
|
||||
Just (A.ProtocolCase _ _) -> True
|
||||
_ -> False
|
||||
isCaseProtocolType ps _ = False
|
||||
isCaseProtocolType :: (PSM m, Die m) => A.Type -> m Bool
|
||||
isCaseProtocolType (A.Chan (A.UserProtocol pr))
|
||||
= do st <- specTypeOfName pr
|
||||
case st of
|
||||
A.ProtocolCase _ _ -> return True
|
||||
_ -> return False
|
||||
isCaseProtocolType _ = return False
|
||||
|
||||
abbrevModeOfSpec :: A.SpecType -> A.AbbrevMode
|
||||
abbrevModeOfSpec s
|
||||
|
|
@ -148,6 +150,12 @@ stripArrayType :: A.Type -> A.Type
|
|||
stripArrayType (A.Array _ t) = stripArrayType t
|
||||
stripArrayType t = t
|
||||
|
||||
-- | Given the abbreviation mode of something, return what the abbreviation
|
||||
-- mode of something that abbreviated it would be.
|
||||
makeAbbrevAM :: A.AbbrevMode -> A.AbbrevMode
|
||||
makeAbbrevAM A.Original = A.Abbrev
|
||||
makeAbbrevAM am = am
|
||||
|
||||
-- | Generate a constant expression from an integer -- for array sizes and the like.
|
||||
makeConstant :: Meta -> Int -> A.Expression
|
||||
makeConstant m n = A.ExprLiteral m $ A.Literal m A.Int $ A.IntLiteral m (show n)
|
||||
|
|
|
|||
|
|
@ -89,37 +89,34 @@ removeFreeNames = doGeneric `extM` doSpecification `extM` doProcess
|
|||
doSpecification spec = case spec of
|
||||
A.Specification m n st@(A.Proc _ fs p) ->
|
||||
do
|
||||
ps <- get
|
||||
-- Figure out the free names. We only want to do this for channels
|
||||
-- and variables, and we don't want to do it for constants because
|
||||
-- they'll get pulled to the top level anyway.
|
||||
let allFreeNames = Map.elems $ freeNamesIn st
|
||||
let freeNames = [n | n <- allFreeNames,
|
||||
case A.nameType n of
|
||||
A.ChannelName -> True
|
||||
A.VariableName -> True
|
||||
_ -> False,
|
||||
not $ isConstantName ps n]
|
||||
let types = [fromJust $ typeOfName ps n | n <- freeNames]
|
||||
let ams = [case fromJust $ abbrevModeOfName ps n of
|
||||
A.Original -> A.Abbrev
|
||||
t -> t
|
||||
| n <- freeNames]
|
||||
let freeNames' = Map.elems $ freeNamesIn st
|
||||
let freeNames'' = [n | n <- freeNames',
|
||||
case A.nameType n of
|
||||
A.ChannelName -> True
|
||||
A.VariableName -> True
|
||||
_ -> False]
|
||||
freeNames <- filterM isConstantName freeNames''
|
||||
types <- mapM typeOfName freeNames
|
||||
origAMs <- mapM abbrevModeOfName freeNames
|
||||
let ams = map makeAbbrevAM origAMs
|
||||
-- Generate and define new names to replace them with
|
||||
newNamesS <- sequence [makeNonce (A.nameName n) | n <- freeNames]
|
||||
let newNames = [on { A.nameName = nn } | (on, nn) <- zip freeNames newNamesS]
|
||||
sequence_ [let ond = fromJust $ psLookupName ps on
|
||||
in modify $ psDefineName nn (ond { A.ndName = A.nameName nn,
|
||||
A.ndAbbrevMode = am })
|
||||
| (on, nn, am) <- zip3 freeNames newNames ams]
|
||||
onds <- mapM lookupName freeNames
|
||||
sequence_ [defineName nn (ond { A.ndName = A.nameName nn,
|
||||
A.ndAbbrevMode = am })
|
||||
| (ond, nn, am) <- zip3 onds newNames ams]
|
||||
-- Add formals for each of the free names
|
||||
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' = A.Specification m n st'
|
||||
-- Update the definition of the proc
|
||||
let nameDef = fromJust $ psLookupName ps n
|
||||
modify $ psDefineName n (nameDef { A.ndType = st' })
|
||||
nameDef <- lookupName n
|
||||
defineName n (nameDef { A.ndType = st' })
|
||||
-- Note that we should add extra arguments to calls of this proc
|
||||
-- when we find them
|
||||
let newAs = [case am of
|
||||
|
|
@ -155,20 +152,20 @@ removeNesting p
|
|||
|
||||
doSpecification :: A.Specification -> PassM A.Specification
|
||||
doSpecification spec@(A.Specification m n st)
|
||||
= do ps <- get
|
||||
if isConstantName ps n || canPull ps st then
|
||||
= do isConst <- isConstantName n
|
||||
if isConst || canPull st then
|
||||
do spec' <- doGeneric spec
|
||||
addPulled $ A.ProcSpec m spec'
|
||||
return A.NoSpecification
|
||||
else doGeneric spec
|
||||
|
||||
canPull :: ParseState -> A.SpecType -> Bool
|
||||
canPull _ (A.Proc _ _ _) = True
|
||||
canPull _ (A.DataType _ _) = True
|
||||
canPull _ (A.DataTypeRecord _ _ _) = True
|
||||
canPull _ (A.Protocol _ _) = True
|
||||
canPull _ (A.ProtocolCase _ _) = True
|
||||
canPull _ _ = False
|
||||
canPull :: A.SpecType -> Bool
|
||||
canPull (A.Proc _ _ _) = True
|
||||
canPull (A.DataType _ _) = True
|
||||
canPull (A.DataTypeRecord _ _ _) = True
|
||||
canPull (A.Protocol _ _) = True
|
||||
canPull (A.ProtocolCase _ _) = True
|
||||
canPull _ = False
|
||||
|
||||
-- | Remove specifications that have been turned into NoSpecifications.
|
||||
removeNoSpecs :: Data t => t -> PassM t
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user