suzanne.soy/tock-mirror
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Removed the die function (that has no source position) and as far as possible replaced all its uses with dieP and a valid position

Browse Source
This commit is contained in:
Neil Brown 2008-01-28 17:21:13 +00:00
parent d94f10ef77
commit edc3a7e910
17 changed files with 149 additions and 151 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
Main.hs
View File

@ -158,7 +158,7 @@ instance Die (StateT [FilePath] PassM) where
compileFull :: String -> StateT [FilePath] PassM ()
compileFull fn = do optsPS <- lift get
destBin <- case csOutputFile optsPS of
"-" -> die "Must specify an output file when using full-compile mode"
"-" -> dieReport (Nothing, "Must specify an output file when using full-compile mode")
file -> return file
-- First, compile the code into C/C++:
@ -213,7 +213,7 @@ compileFull fn = do optsPS <- lift get
exitCode <- liftIO $ waitForProcess p
case exitCode of
ExitSuccess -> return ()
ExitFailure n -> die $ "Command \"" ++ cmd ++ "\" failed, exiting with code: " ++ show n
ExitFailure n -> dieReport (Nothing, "Command \"" ++ cmd ++ "\" failed, exiting with code: " ++ show n)
-- | Picks out the handle from the options and passes it to the function:
useOutputOptions :: (Handle -> PassM ()) -> PassM ()

38
backends/GenerateC.hs
View File

@ -91,7 +91,7 @@ data GenOps = GenOps {
-- | Generates the number of bytes in a fixed size type, fails if a free dimension is present and is not allowed.
-- The Either parameter is either an array variable (to use the _sizes array of) or a boolean specifying
-- wheter or not one free dimension is allowed (True <=> allowed).
genBytesIn :: GenOps -> A.Type -> Either Bool A.Variable -> CGen (),
genBytesIn :: GenOps -> Meta -> A.Type -> Either Bool A.Variable -> CGen (),
-- | Generates a case statement over the given expression with the structured as the body.
genCase :: GenOps -> Meta -> A.Expression -> A.Structured -> CGen (),
genCheckedConversion :: GenOps -> Meta -> A.Type -> A.Type -> CGen () -> CGen (),
@ -428,15 +428,15 @@ indexOfFreeDimensions = (mapMaybe indexOfFreeDimensions') . (zip [0..])
-- | Generate the number of bytes in a type.
cgenBytesIn :: GenOps -> A.Type -> Either Bool A.Variable -> CGen ()
cgenBytesIn ops t v
cgenBytesIn :: GenOps -> Meta -> A.Type -> Either Bool A.Variable -> CGen ()
cgenBytesIn ops m t v
= do case (t, v) of
(A.Array ds _, Left freeDimensionAllowed) ->
case (length (indexOfFreeDimensions ds), freeDimensionAllowed) of
(0,_) -> return ()
(1,False) -> die "genBytesIn type with unknown dimension, when unknown dimensions are not allowed"
(1,False) -> dieP m "genBytesIn type with unknown dimension, when unknown dimensions are not allowed"
(1,True) -> return ()
(_,_) -> die "genBytesIn type with more than one free dimension"
(_,_) -> dieP m "genBytesIn type with more than one free dimension"
_ -> return ()
genBytesIn' ops t
where
@ -458,7 +458,7 @@ cgenBytesIn ops t v
genBytesIn' ops t
= case call getScalarType ops t of
Just s -> tell ["sizeof(", s, ")"]
Nothing -> dieC $ formatCode "genBytesIn' %" t
Nothing -> diePC m $ formatCode "genBytesIn' %" t
genBytesInArrayDim :: (A.Dimension,Int) -> CGen ()
genBytesInArrayDim (A.Dimension n, _) = tell [show n, "*"]
@ -875,7 +875,7 @@ cgenExpression _ (A.False m) = tell ["false"]
cgenExpression ops (A.IntrinsicFunctionCall m s es) = call genIntrinsicFunction ops m s es
--cgenExpression ops (A.SubscriptedExpr m s e)
--cgenExpression ops (A.BytesInExpr m e)
cgenExpression ops (A.BytesInType m t) = call genBytesIn ops t (Left False)
cgenExpression ops (A.BytesInType m t) = call genBytesIn ops m t (Left False)
--cgenExpression ops (A.OffsetOf m t n)
--cgenExpression ops (A.ExprConstr {})
cgenExpression ops (A.AllocMobile m t me) = call genAllocMobile ops m t me
@ -975,10 +975,10 @@ cgenInputItem ops c (A.InCounted m cv av)
tell [","]
fst $ abbrevVariable ops A.Abbrev t av
tell [","]
subT <- trivialSubscriptType t
subT <- trivialSubscriptType m t
call genVariable ops cv
tell ["*"]
call genBytesIn ops subT (Right av)
call genBytesIn ops m subT (Right av)
tell [");"]
cgenInputItem ops c (A.InVariable m v)
= do t <- typeOfVariable v
@ -996,7 +996,7 @@ cgenInputItem ops c (A.InVariable m v)
tell [","]
rhs
tell [","]
call genBytesIn ops t (Right v)
call genBytesIn ops m t (Right v)
tell [");"]
cgenOutputItem :: GenOps -> A.Variable -> A.OutputItem -> CGen ()
@ -1010,10 +1010,10 @@ cgenOutputItem ops c (A.OutCounted m ce ae)
tell [","]
fst $ abbrevVariable ops A.Abbrev t v
tell [","]
subT <- trivialSubscriptType t
subT <- trivialSubscriptType m t
call genExpression ops ce
tell ["*"]
call genBytesIn ops subT (Right v)
call genBytesIn ops m subT (Right v)
tell [");"]
cgenOutputItem ops c (A.OutExpression m e)
= do t <- typeOfExpression e
@ -1030,7 +1030,7 @@ cgenOutputItem ops c (A.OutExpression m e)
tell [","]
fst $ abbrevVariable ops A.Abbrev t v
tell [","]
call genBytesIn ops t (Right v)
call genBytesIn ops m t (Right v)
tell [");"]
--}}}
@ -1162,9 +1162,9 @@ cgenRetypeSizes :: GenOps -> Meta -> A.Type -> A.Name -> A.Type -> A.Variable ->
cgenRetypeSizes _ _ (A.Chan {}) _ (A.Chan {}) _ = return ()
cgenRetypeSizes ops m destT destN srcT srcV
= let size = do tell ["occam_check_retype("]
call genBytesIn ops srcT (Right srcV)
call genBytesIn ops m srcT (Right srcV)
tell [","]
call genBytesIn ops destT (Left True)
call genBytesIn ops m destT (Left True)
tell [","]
genMeta m
tell [")"] in
@ -1188,7 +1188,7 @@ cgenRetypeSizes ops m destT destN srcT srcV
case free of
Just _ -> size
Nothing ->
die "genRetypeSizes expecting free dimension"
dieP m "genRetypeSizes expecting free dimension"
A.Dimension n -> tell [show n]
| d <- destDS]
call genArraySize ops False (genLeftB >> seqComma dims >> genRightB) destN
@ -1271,13 +1271,13 @@ cdeclareArraySizes ops t name
-- | Generate a C literal to initialise an _sizes array with, where all the
-- dimensions are fixed.
cgenArraySizesLiteral :: GenOps -> A.Name -> A.Type -> CGen ()
cgenArraySizesLiteral ops _ (A.Array ds _)
cgenArraySizesLiteral ops n (A.Array ds _)
= genLeftB >> seqComma dims >> genRightB
where
dims :: [CGen ()]
dims = [case d of
A.Dimension n -> tell [show n]
_ -> die "unknown dimension in array type"
_ -> dieP (findMeta n) "unknown dimension in array type"
| d <- ds]
-- | Initialise an item being declared.
@ -1858,7 +1858,7 @@ cgenAssert ops m e
--{{{ mobiles
cgenAllocMobile :: GenOps -> Meta -> A.Type -> Maybe A.Expression -> CGen()
cgenAllocMobile ops m (A.Mobile t) Nothing = tell ["malloc("] >> call genBytesIn ops t (Left False) >> tell [")"]
cgenAllocMobile ops m (A.Mobile t) Nothing = tell ["malloc("] >> call genBytesIn ops m t (Left False) >> tell [")"]
--TODO add a pass, just for C, that pulls out the initialisation expressions for mobiles
-- into a subsequent assignment
cgenAllocMobile ops _ _ _ = call genMissing ops "Mobile allocation with initialising-expression"

12
backends/GenerateCPPCSP.hs
View File

@ -314,14 +314,14 @@ cppgenInputItem ops c dest
do call genVariable ops cv
tell ["*"]
t <- typeOfVariable av
subT <- trivialSubscriptType t
call genBytesIn ops subT (Right av)
subT <- trivialSubscriptType m t
call genBytesIn ops m subT (Right av)
)
(A.InVariable m v) ->
do ct <- typeOfVariable c
t <- typeOfVariable v
case (byteArrayChan ct,t) of
(True,_)-> recvBytes v (call genBytesIn ops t (Right v))
(True,_)-> recvBytes v (call genBytesIn ops m t (Right v))
(False,A.Array {}) -> do tell ["tockRecvArray("]
chan'
tell [","]
@ -578,7 +578,7 @@ cppgenArraySizesLiteral ops n t@(A.Array ds _) =
dims :: [CGen ()]
dims = [case d of
A.Dimension n -> tell [show n]
_ -> die "unknown dimension in array type"
_ -> dieP (findMeta n) "unknown dimension in array type"
| d <- ds]
-- | Changed because we initialise channels and arrays differently in C++
@ -1093,9 +1093,9 @@ cppgenRetypeSizes _ _ (A.Chan {}) _ (A.Chan {}) _ = return ()
cppgenRetypeSizes ops m destT destN srcT srcV
= let checkSize
= do tell ["if(occam_check_retype("]
call genBytesIn ops srcT (Right srcV)
call genBytesIn ops m srcT (Right srcV)
tell [","]
call genBytesIn ops destT (Left True)
call genBytesIn ops m destT (Left True)
tell [","]
genMeta m
tell [")!=1){"]

36
backends/GenerateCTest.hs
View File

@ -706,8 +706,8 @@ testRetypeSizes = TestList
rep search replace str = subRegex (mkRegex search) str replace
showBytesInParams _ t (Right _) = tell ["$(" ++ show t ++ " Right)"]
showBytesInParams _ t v = tell ["$(" ++ show t ++ " " ++ show v ++ ")"]
showBytesInParams _ _ t (Right _) = tell ["$(" ++ show t ++ " Right)"]
showBytesInParams _ _ t v = tell ["$(" ++ show t ++ " " ++ show v ++ ")"]
showArrSize _ _ sz _ = tell ["^("] >> sz >> tell [")"]
over ops = ops {genBytesIn = showBytesInParams, genStop = override2 at, genArraySize = showArrSize}
@ -969,7 +969,7 @@ testInput = TestList
-- defineName chanOut $ simpleDefDecl "cIn" (A.Chan A.DirInput (A.ChanAttributes False False) $ A.UserProtocol foo)
overInputItemCase ops = ops {genInputItem = override2 caret}
over ops = ops {genBytesIn = (\_ t _ -> tell ["^(",show t,")"]) , genArraySubscript = override3 dollar}
over ops = ops {genBytesIn = (\_ _ t _ -> tell ["^(",show t,")"]) , genArraySubscript = override3 dollar}
testOutput :: Test
testOutput = TestList
@ -1054,33 +1054,33 @@ testOutput = TestList
defineName chanOut $ simpleDefDecl "cOut" (A.Chan A.DirOutput (A.ChanAttributes False False) $ A.UserProtocol foo)
overOutput ops = ops {genOutput = override2 caret}
overOutputItem ops = ops {genOutputItem = override2 caret}
over ops = ops {genBytesIn = override2 caret}
over ops = ops {genBytesIn = override3 caret}
testBytesIn :: Test
testBytesIn = TestList
[
testBothSame "testBytesIn 0" "sizeof(int)" (tcall2 genBytesIn A.Int undefined)
,testBothSame "testBytesIn 1" "sizeof(foo)" (tcall2 genBytesIn (A.Record foo) undefined)
,testBoth "testBytesIn 2" "sizeof(Channel)" "sizeof(csp::One2OneChannel<int>)" (tcall2 genBytesIn (A.Chan A.DirUnknown (A.ChanAttributes False False) A.Int) undefined)
,testBoth "testBytesIn 3" "sizeof(Channel*)" "sizeof(csp::Chanin<int>)" (tcall2 genBytesIn (A.Chan A.DirInput (A.ChanAttributes False False) A.Int) undefined)
testBothSame "testBytesIn 0" "sizeof(int)" (tcall3 genBytesIn undefined A.Int undefined)
,testBothSame "testBytesIn 1" "sizeof(foo)" (tcall3 genBytesIn undefined (A.Record foo) undefined)
,testBoth "testBytesIn 2" "sizeof(Channel)" "sizeof(csp::One2OneChannel<int>)" (tcall3 genBytesIn undefined (A.Chan A.DirUnknown (A.ChanAttributes False False) A.Int) undefined)
,testBoth "testBytesIn 3" "sizeof(Channel*)" "sizeof(csp::Chanin<int>)" (tcall3 genBytesIn undefined (A.Chan A.DirInput (A.ChanAttributes False False) A.Int) undefined)
--Array with a single known dimension:
,testBothSame "testBytesIn 100" "5*sizeof(int)" (tcall2 genBytesIn (A.Array [A.Dimension 5] A.Int) (Left False))
,testBothSame "testBytesIn 100" "5*sizeof(int)" (tcall3 genBytesIn undefined (A.Array [A.Dimension 5] A.Int) (Left False))
--single unknown dimension, no variable, no free dimension allowed:
,testBothFail "testBytesIn 101a" (tcall2 genBytesIn (A.Array [A.UnknownDimension] A.Int) (Left False))
,testBothFail "testBytesIn 101a" (tcall3 genBytesIn undefined (A.Array [A.UnknownDimension] A.Int) (Left False))
--single unknown dimension, no variable, free dimension allowed:
,testBothSame "testBytesIn 101b" "sizeof(int)" (tcall2 genBytesIn (A.Array [A.UnknownDimension] A.Int) (Left True))
,testBothSame "testBytesIn 101b" "sizeof(int)" (tcall3 genBytesIn undefined (A.Array [A.UnknownDimension] A.Int) (Left True))
--single unknown dimension, with variable:
,testBothSame "testBytesIn 102" "$(@0)*sizeof(int)" ((tcall2 genBytesIn (A.Array [A.UnknownDimension] A.Int) (Right undefined)) . over)
,testBothSame "testBytesIn 102" "$(@0)*sizeof(int)" ((tcall3 genBytesIn undefined (A.Array [A.UnknownDimension] A.Int) (Right undefined)) . over)
--Array with all known dimensions:
,testBothSame "testBytesIn 200" "7*6*5*sizeof(int)" (tcall2 genBytesIn (A.Array [A.Dimension 5,A.Dimension 6, A.Dimension 7] A.Int) (Left False))
,testBothSame "testBytesIn 200" "7*6*5*sizeof(int)" (tcall3 genBytesIn undefined (A.Array [A.Dimension 5,A.Dimension 6, A.Dimension 7] A.Int) (Left False))
--single unknown dimension, no variable, no free dimension allowed:
,testBothFail "testBytesIn 201a" (tcall2 genBytesIn (A.Array [A.Dimension 5,A.Dimension 6,A.UnknownDimension] A.Int) (Left False))
,testBothFail "testBytesIn 201a" (tcall3 genBytesIn undefined (A.Array [A.Dimension 5,A.Dimension 6,A.UnknownDimension] A.Int) (Left False))
--single unknown dimension, no variable, free dimension allowed:
,testBothSame "testBytesIn 201b" "6*5*sizeof(int)" (tcall2 genBytesIn (A.Array [A.Dimension 5,A.Dimension 6,A.UnknownDimension] A.Int) (Left True))
,testBothSame "testBytesIn 201b" "6*5*sizeof(int)" (tcall3 genBytesIn undefined (A.Array [A.Dimension 5,A.Dimension 6,A.UnknownDimension] A.Int) (Left True))
--single unknown dimension, with variable:
,testBothSame "testBytesIn 202" "$(@2)*6*5*sizeof(int)" ((tcall2 genBytesIn (A.Array [A.Dimension 5,A.Dimension 6,A.UnknownDimension] A.Int) (Right undefined)) . over)
,testBothSame "testBytesIn 202" "$(@2)*6*5*sizeof(int)" ((tcall3 genBytesIn undefined (A.Array [A.Dimension 5,A.Dimension 6,A.UnknownDimension] A.Int) (Right undefined)) . over)
]
where
@ -1096,8 +1096,8 @@ testMobile = TestList
((tcall2 genClearMobile emptyMeta undefined) . over)
]
where
showBytesInParams _ t (Right _) = tell ["#(" ++ show t ++ " Right)"]
showBytesInParams _ t v = tell ["#(" ++ show t ++ " " ++ show v ++ ")"]
showBytesInParams _ _ t (Right _) = tell ["#(" ++ show t ++ " Right)"]
showBytesInParams _ _ t v = tell ["#(" ++ show t ++ " " ++ show v ++ ")"]
over ops = ops {genBytesIn = showBytesInParams, genType = (\_ t -> tell [show t]), genExpression = override1 dollar, genVariable = override1 at}
---Returns the list of tests:

25
backends/TLP.hs
View File

@ -27,6 +27,7 @@ import Data.Maybe
import qualified AST as A
import CompState
import Errors
import Metadata
import Types
data TLPChannel = TLPIn | TLPOut | TLPError
@ -37,28 +38,28 @@ data TLPChannel = TLPIn | TLPOut | TLPError
tlpInterface :: (CSM m, Die m) => m ( A.Name, [(A.Direction, TLPChannel)] )
tlpInterface
= do ps <- get
when (null $ csMainLocals ps) (die "No main process found")
when (null $ csMainLocals ps) (dieReport (Nothing,"No main process found"))
let mainName = snd $ head $ csMainLocals ps
st <- specTypeOfName mainName
formals <- case st of
A.Proc _ _ fs _ -> return fs
_ -> die "Last definition is not a PROC"
chans <- mapM tlpChannel formals
when ((nub (map snd chans)) /= (map snd chans)) $ die "Channels used more than once in TLP"
(m,formals) <- case st of
A.Proc m _ fs _ -> return (m,fs)
_ -> dieP (findMeta mainName) "Last definition is not a PROC"
chans <- mapM (tlpChannel m) formals
when ((nub (map snd chans)) /= (map snd chans)) $ dieP (findMeta mainName) "Channels used more than once in TLP"
return (mainName, chans)
where
tlpChannel :: (CSM m, Die m) => A.Formal -> m (A.Direction, TLPChannel)
tlpChannel (A.Formal _ (A.Chan dir _ _) n)
tlpChannel :: (CSM m, Die m) => Meta -> A.Formal -> m (A.Direction, TLPChannel)
tlpChannel m (A.Formal _ (A.Chan dir _ _) n)
= do def <- lookupName n
let origN = A.ndOrigName def
case lookup origN tlpChanNames of
Just c ->
if (dir == A.DirUnknown || dir == (tlpDir c))
then return (dir,c)
else die $ "TLP formal " ++ show n ++ " has wrong direction for its name"
_ -> die $ "TLP formal " ++ show n ++ " has unrecognised name"
tlpChannel (A.Formal _ _ n)
= die $ "TLP formal " ++ show n ++ " has unrecognised type"
else dieP m $ "TLP formal " ++ show n ++ " has wrong direction for its name"
_ -> dieP m $ "TLP formal " ++ show n ++ " has unrecognised name"
tlpChannel m (A.Formal _ _ n)
= dieP m $ "TLP formal " ++ show n ++ " has unrecognised type"
tlpDir :: TLPChannel -> A.Direction
tlpDir TLPIn = A.DirInput

8
checks/Check.hs
View File

@ -43,7 +43,7 @@ import UsageCheckUtils
usageCheckPass :: Pass
usageCheckPass t = do g' <- buildFlowGraph labelFunctions t
g <- case g' of
Left err -> die err
Left err -> dieP (findMeta t) err
Right g -> return g
sequence_ $ checkPar checkArrayUsage g
return t
@ -186,10 +186,10 @@ showCodeExSet (NormalSet s)
return $ "{" ++ concat (intersperse ", " ss) ++ "}"
-- | Checks that no variable is used uninitialised. That is, it checks that every variable is written to before it is read.
checkInitVar :: forall m. (Monad m, Die m, CSM m) => FlowGraph m (Maybe Decl, Vars) -> Node -> m ()
checkInitVar graph startNode
checkInitVar :: forall m. (Monad m, Die m, CSM m) => Meta -> FlowGraph m (Maybe Decl, Vars) -> Node -> m ()
checkInitVar m graph startNode
= do vwb <- case flowAlgorithm graphFuncs (nodes graph) startNode of
Left err -> die $ "Error building control-flow graph: " ++ err
Left err -> dieP m $ "Error building control-flow graph: " ++ err
Right x -> return x
-- vwb is a map from Node to a set of Vars that have been written by that point
-- Now we check that for every variable read in each node, it has already been written to by then

6
common/CompState.hs
View File

@ -124,7 +124,7 @@ defineName n nd
-- | Find the definition of a name.
lookupName :: (CSM m, Die m) => A.Name -> m A.NameDef
lookupName n = lookupNameOrError n (die $ "cannot find name " ++ A.nameName n)
lookupName n = lookupNameOrError n (dieP (findMeta n) $ "cannot find name " ++ A.nameName n)
lookupNameOrError :: CSM m => A.Name -> m A.NameDef -> m A.NameDef
lookupNameOrError n err
@ -253,8 +253,8 @@ makeNonceVariable s m t nt am
diePC :: (CSM m, Die m) => Meta -> m String -> m a
diePC m str = str >>= (dieP m)
dieC :: (CSM m, Die m) => m String -> m a
dieC str = str >>= die
--dieC :: (CSM m, Die m) => m String -> m a
--dieC str = str >>= die
throwErrorC :: (CSM m,MonadError ErrorReport m) => (Maybe Meta,m String) -> m a
throwErrorC (m,str) = str >>= ((curry throwError) m)

10
common/Errors.hs
View File

@ -17,7 +17,7 @@ with this program. If not, see <http://www.gnu.org/licenses/>.
-}
-- | Error handling and reporting.
module Errors where
module Errors (checkJust, Die, dieInternal, dieIO, dieP, dieReport, ErrorReport) where
import Control.Monad.Error
import Control.Monad.Trans
@ -35,10 +35,6 @@ instance Error ErrorReport where
class Monad m => Die m where
dieReport :: ErrorReport -> m a
-- | Fail, giving an error message.
die :: String -> m a
die s = dieReport (Nothing, s)
-- | Fail, giving a position and an error message.
dieP :: Die m => Meta -> String -> m a
dieP m s = dieReport (Just m,s)
@ -90,6 +86,6 @@ dieInternal :: Monad m => ErrorReport -> m a
dieInternal (m,s) = error $ "\n\n" ++ (maybe "" show m) ++ "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 :: Die m => ErrorReport -> Maybe t -> m t
checkJust _ (Just v) = return v
checkJust err _ = die err
checkJust err _ = dieReport err

8
common/EvalConstants.hs
View File

@ -136,7 +136,7 @@ evalExpression (A.MostNeg _ A.Int32) = return $ OccInt32 minBound
evalExpression (A.MostPos _ A.Int64) = return $ OccInt64 maxBound
evalExpression (A.MostNeg _ A.Int64) = return $ OccInt64 minBound
evalExpression (A.SizeExpr m e)
= do t <- typeOfExpression e >>= underlyingType
= do t <- typeOfExpression e >>= underlyingType m
case t of
A.Array (A.Dimension n:_) _ -> return $ OccInt (fromIntegral n)
_ ->
@ -145,7 +145,7 @@ evalExpression (A.SizeExpr m e)
OccArray vs -> return $ OccInt (fromIntegral $ length vs)
_ -> throwError (Just m, "size of non-constant expression " ++ show e ++ " used")
evalExpression (A.SizeVariable m v)
= do t <- typeOfVariable v >>= underlyingType
= do t <- typeOfVariable v >>= underlyingType m
case t of
A.Array (A.Dimension n:_) _ -> return $ OccInt (fromIntegral n)
_ -> throwError (Just m, "size of non-fixed-size variable " ++ show v ++ " used")
@ -155,12 +155,12 @@ evalExpression (A.True _) = return $ OccBool True
evalExpression (A.False _) = return $ OccBool False
evalExpression (A.SubscriptedExpr _ sub e) = evalExpression e >>= evalSubscript sub
evalExpression (A.BytesInExpr m e)
= do b <- typeOfExpression e >>= underlyingType >>= bytesInType
= do b <- typeOfExpression e >>= underlyingType m >>= bytesInType
case b of
BIJust n -> return $ OccInt (fromIntegral $ n)
_ -> throwError (Just m, "BYTESIN non-constant-size expression " ++ show e ++ " used")
evalExpression (A.BytesInType m t)
= do b <- underlyingType t >>= bytesInType
= do b <- underlyingType m t >>= bytesInType
case b of
BIJust n -> return $ OccInt (fromIntegral $ n)
_ -> throwErrorC (Just m, formatCode "BYTESIN non-constant-size type % used" t)

2
common/EvalLiterals.hs
View File

@ -82,7 +82,7 @@ evalIntExpression e
case runEvaluator ps (evalSimpleExpression e) of
Left (m,err) -> dieReport (m,"cannot evaluate expression: " ++ err)
Right (OccInt val) -> return $ fromIntegral val
Right _ -> die "expression is not of INT type"
Right _ -> dieP (findMeta e) "expression is not of INT type"
-- | Evaluate a byte literal.
evalByte :: (CSM m, Die m) => String -> m Char

48
common/Types.hs
View File

@ -65,7 +65,7 @@ typeOfName n
t <- typeOfSpec st
case t of
Just t' -> return t'
Nothing -> die $ "cannot type name " ++ show st
Nothing -> dieP (findMeta n) $ "cannot type name " ++ show st
typeOfSpec :: (CSM m, Die m) => A.SpecType -> m (Maybe A.Type)
typeOfSpec st
@ -113,7 +113,7 @@ recordFields m _ = dieP m "not record type"
typeOfRecordField :: (CSM m, Die m) => Meta -> A.Type -> A.Name -> m A.Type
typeOfRecordField m t field
= do fs <- recordFields m t
checkJust "unknown record field" $ lookup field fs
checkJust (Just m, "unknown record field") $ lookup field fs
-- | Apply a plain subscript to a type.
plainSubscriptType :: (CSM m, Die m) => Meta -> A.Expression -> A.Type -> m A.Type
@ -135,7 +135,7 @@ plainSubscriptType m _ t = diePC m $ formatCode "subscript of non-array type: %"
-- subscripted.
subscriptType :: (CSM m, Die m) => A.Subscript -> A.Type -> m A.Type
subscriptType sub t@(A.UserDataType _)
= resolveUserType t >>= subscriptType sub
= resolveUserType (findMeta sub) t >>= subscriptType sub
subscriptType (A.SubscriptFromFor m base count) t
= sliceType m base count t
subscriptType (A.SubscriptFrom m base) (A.Array (d:ds) t)
@ -161,8 +161,8 @@ unsubscriptType (A.SubscriptFrom _ _) t
= return $ removeFixedDimension t
unsubscriptType (A.SubscriptFor _ _) t
= return $ removeFixedDimension t
unsubscriptType (A.SubscriptField _ _) t
= die $ "unsubscript of record type (but we can't tell which one)"
unsubscriptType (A.SubscriptField m _) t
= dieP m $ "unsubscript of record type (but we can't tell which one)"
unsubscriptType (A.Subscript _ sub) t
= return $ addDimensions [A.UnknownDimension] t
@ -170,10 +170,10 @@ unsubscriptType (A.Subscript _ sub) t
-- subscriptType with constant 0 as a subscript, but without the checking.
-- This is used for the couple of cases where we know it's safe and don't want
-- the usage check.
trivialSubscriptType :: (CSM m, Die m) => A.Type -> m A.Type
trivialSubscriptType (A.Array [d] t) = return t
trivialSubscriptType (A.Array (d:ds) t) = return $ A.Array ds t
trivialSubscriptType t = dieC $ formatCode "not plain array type: %" t
trivialSubscriptType :: (CSM m, Die m) => Meta -> A.Type -> m A.Type
trivialSubscriptType _ (A.Array [d] t) = return t
trivialSubscriptType _ (A.Array (d:ds) t) = return $ A.Array ds t
trivialSubscriptType m t = diePC m $ formatCode "not plain array type: %" t
-- | Gets the 'A.Type' of a 'A.Variable' by looking at the types recorded in the 'CompState'.
typeOfVariable :: (CSM m, Die m) => A.Variable -> m A.Type
@ -184,12 +184,12 @@ typeOfVariable (A.DerefVariable m v)
= do t <- typeOfVariable v
case t of
(A.Mobile innerT) -> return innerT
_ -> die $ "Tried to dereference a non-mobile variable: " ++ show v
_ -> dieP m $ "Tried to dereference a non-mobile variable: " ++ show v
typeOfVariable (A.DirectedVariable m dir v)
= do t <- typeOfVariable v
case t of
(A.Chan A.DirUnknown attr innerT) -> return (A.Chan dir attr innerT)
_ -> die $ "Used specifier on something that was not a directionless channel: " ++ show v
_ -> dieP m $ "Used specifier on something that was not a directionless channel: " ++ show v
-- | Get the abbreviation mode of a variable.
abbrevModeOfVariable :: (CSM m, Die m) => A.Variable -> m A.AbbrevMode
@ -245,7 +245,7 @@ typeOfExpression e
A.True m -> return A.Bool
A.False m -> return A.Bool
A.FunctionCall m n es -> liftM head $ returnTypesOfFunction n
A.IntrinsicFunctionCall _ s _ -> liftM head $ returnTypesOfIntrinsic s
A.IntrinsicFunctionCall m s _ -> liftM head $ returnTypesOfIntrinsic m s
A.SubscriptedExpr m s e ->
typeOfExpression e >>= subscriptType s
A.BytesInExpr m e -> return A.Int
@ -274,14 +274,14 @@ returnTypesOfFunction n
-- 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" $
checkJust (Just $ findMeta n, "not defined as a function") $
Map.lookup (A.nameName n) (csFunctionReturns ps)
returnTypesOfIntrinsic :: (CSM m, Die m) => String -> m [A.Type]
returnTypesOfIntrinsic s
returnTypesOfIntrinsic :: (CSM m, Die m) => Meta -> String -> m [A.Type]
returnTypesOfIntrinsic m s
= case lookup s intrinsicFunctions of
Just (rts, _) -> return rts
Nothing -> die $ "unknown intrinsic function " ++ s
Nothing -> dieP m $ "unknown intrinsic function " ++ s
-- | Get the items in a channel's protocol (for typechecking).
-- Returns Left if it's a simple protocol, Right if it's tagged.
@ -309,25 +309,25 @@ abbrevModeOfSpec s
-- | Resolve a datatype into its underlying type -- i.e. if it's a named data
-- type, then return the underlying real type. This will recurse.
underlyingType :: (CSM m, Die m) => A.Type -> m A.Type
underlyingType = everywhereM (mkM underlyingType')
underlyingType :: (CSM m, Die m) => Meta -> A.Type -> m A.Type
underlyingType m = everywhereM (mkM underlyingType')
where
underlyingType' :: (CSM m, Die m) => A.Type -> m A.Type
underlyingType' t@(A.UserDataType _)
= resolveUserType t >>= underlyingType
= resolveUserType m t >>= underlyingType m
underlyingType' (A.Array ds t) = return $ addDimensions ds t
underlyingType' t = return t
-- | Like underlyingType, but only do the "outer layer": if you give this a
-- user type that's an array of user types, then you'll get back an array of
-- user types.
resolveUserType :: (CSM m, Die m) => A.Type -> m A.Type
resolveUserType (A.UserDataType n)
resolveUserType :: (CSM m, Die m) => Meta -> A.Type -> m A.Type
resolveUserType m (A.UserDataType n)
= do st <- specTypeOfName n
case st of
A.DataType _ t -> resolveUserType t
_ -> die $ "not a type name " ++ show n
resolveUserType t = return t
A.DataType _ t -> resolveUserType m t
_ -> dieP m $ "not a type name " ++ show n
resolveUserType _ t = return t
-- | Add array dimensions to a type; if it's already an array it'll just add
-- the new dimensions to the existing array.

88
frontends/ParseOccam.hs
View File

@ -252,7 +252,7 @@ postSubscripts t
postSubscript :: A.Type -> OccParser A.Subscript
postSubscript t
= do m <- md
t' <- resolveUserType t
t' <- resolveUserType m t
case t' of
A.Record _ ->
do f <- tryXV sLeft fieldName
@ -269,7 +269,7 @@ maybeSliced inner subscripter typer
= do m <- md
(v, ff1) <- tryXVV sLeft inner fromOrFor
t <- typer v >>= underlyingType
t <- typer v >>= underlyingType m
case t of
(A.Array _ _) -> return ()
_ -> dieP m $ "slice of non-array type " ++ showOccam t
@ -361,22 +361,22 @@ areValidDimensions (d1:ds1) (d2:ds2)
areValidDimensions _ _ = False
-- | Check that a type we've inferred matches the type we expected.
matchType :: A.Type -> A.Type -> OccParser ()
matchType et rt
matchType :: Meta -> A.Type -> A.Type -> OccParser ()
matchType m et rt
= case (et, rt) of
((A.Array ds t), (A.Array ds' t')) ->
if areValidDimensions ds ds'
then matchType t t'
then matchType m t t'
else bad
_ -> if rt == et then return () else bad
where
bad :: OccParser ()
bad = die $ "type mismatch (got " ++ showOccam rt ++ "; expected " ++ showOccam et ++ ")"
bad = dieP m $ "type mismatch (got " ++ showOccam rt ++ "; expected " ++ showOccam et ++ ")"
-- | Check that two lists of types match (for example, for parallel assignment).
matchTypes :: [A.Type] -> [A.Type] -> OccParser ()
matchTypes ets rts
= sequence_ [matchType et rt | (et, rt) <- zip ets rts]
matchTypes :: Meta -> [A.Type] -> [A.Type] -> OccParser ()
matchTypes m ets rts
= sequence_ [matchType m et rt | (et, rt) <- zip ets rts]
-- | Parse a production inside a particular type context.
inTypeContext :: Maybe A.Type -> OccParser a -> OccParser a
@ -589,7 +589,7 @@ portType
-- | Can a literal of type rawT be used as a value of type wantT?
isValidLiteralType :: Meta -> A.Type -> A.Type -> OccParser Bool
isValidLiteralType m rawT wantT
= do underT <- resolveUserType wantT
= do underT <- resolveUserType m wantT
case (rawT, underT) of
-- We don't yet know what type we want -- so assume it's OK for now.
(_, A.Any) -> return True
@ -606,8 +606,8 @@ isValidLiteralType m rawT wantT
-- We can't just look at all the dimensions because this
-- might be an array of a record type, or similar.
if isValidDimension d2 d1
then do rawT' <- trivialSubscriptType rawT
underT' <- trivialSubscriptType underT
then do rawT' <- trivialSubscriptType m rawT
underT' <- trivialSubscriptType m underT
isValidLiteralType m rawT' underT'
else return False
_ -> return $ rawT == wantT
@ -629,14 +629,14 @@ applyDimensions _ t = t
-- | Convert a raw array element literal into its real form.
makeArrayElem :: A.Type -> A.ArrayElem -> OccParser A.ArrayElem
makeArrayElem t@(A.Array _ _) (A.ArrayElemArray aes)
= do elemT <- trivialSubscriptType t
= do elemT <- trivialSubscriptType (findMeta aes) t
liftM A.ArrayElemArray $ mapM (makeArrayElem elemT) aes
makeArrayElem _ (A.ArrayElemArray _)
= die $ "unexpected nested array literal"
makeArrayElem _ (A.ArrayElemArray es)
= dieP (findMeta es) $ "unexpected nested array literal"
-- A nested array literal that's still of array type (i.e. it's not a
-- record inside the array) -- collapse it.
makeArrayElem t@(A.Array _ _) (A.ArrayElemExpr (A.Literal _ _ (A.ArrayLiteral _ aes)))
= do elemT <- trivialSubscriptType t
makeArrayElem t@(A.Array _ _) (A.ArrayElemExpr (A.Literal _ _ (A.ArrayLiteral m aes)))
= do elemT <- trivialSubscriptType m t
liftM A.ArrayElemArray $ mapM (makeArrayElem elemT) aes
makeArrayElem t (A.ArrayElemExpr e)
= liftM A.ArrayElemExpr $ makeLiteral e t
@ -647,7 +647,7 @@ makeArrayElem t (A.ArrayElemExpr e)
makeLiteral :: A.Expression -> A.Type -> OccParser A.Expression
-- A literal.
makeLiteral x@(A.Literal m t lr) wantT
= do underT <- resolveUserType wantT
= do underT <- resolveUserType m wantT
typesOK <- isValidLiteralType m t wantT
when (not typesOK) $
@ -656,7 +656,7 @@ makeLiteral x@(A.Literal m t lr) wantT
case (underT, lr) of
-- An array literal.
(A.Array _ _, A.ArrayLiteral ml aes) ->
do elemT <- trivialSubscriptType underT
do elemT <- trivialSubscriptType ml underT
aes' <- mapM (makeArrayElem elemT) aes
return $ A.Literal m (applyDimensions t wantT) (A.ArrayLiteral ml aes')
-- A record literal -- which we need to convert from the raw
@ -681,7 +681,7 @@ makeLiteral (A.SubscriptedExpr m sub e) wantT
-- check it's the right type.
makeLiteral e wantT
= do t <- typeOfExpression e
matchType wantT t
matchType (findMeta e) wantT t
return e
--}}}
@ -876,7 +876,7 @@ associativeOpExpression
tl <- typeOfExpression l
r <- associativeOpExpression <|> operand
tr <- typeOfExpression r
matchType tl tr
matchType m tl tr
return $ A.Dyadic m o l r
<?> "associative operator expression"
@ -896,7 +896,7 @@ expressionOfType :: A.Type -> OccParser A.Expression
expressionOfType wantT
= do e <- inTypeContext (Just wantT) expression
t <- typeOfExpression e
matchType wantT t
matchType (findMeta e) wantT t
return e
intExpr = expressionOfType A.Int <?> "integer expression"
@ -916,7 +916,7 @@ operandOfType :: A.Type -> OccParser A.Expression
operandOfType wantT
= do o <- inTypeContext (Just wantT) operand
t <- typeOfExpression o
matchType wantT t
matchType (findMeta o) wantT t
return o
--}}}
--{{{ functions
@ -955,7 +955,7 @@ functionMulti types
as <- functionActuals fs
sRightR
rts <- returnTypesOfFunction n
matchTypes types rts
matchTypes m types rts
return $ A.FunctionCallList m n as
<?> "multi-valued function call"
--}}}
@ -1041,10 +1041,10 @@ conversion :: OccParser A.Expression
conversion
= do m <- md
t <- dataType
baseT <- underlyingType t
baseT <- underlyingType m t
(c, o) <- conversionMode
ot <- typeOfExpression o
baseOT <- underlyingType ot
baseOT <- underlyingType m ot
c <- case (isPreciseConversion baseOT baseT, c) of
(False, A.DefaultConversion) ->
dieP m "imprecise conversion must specify ROUND or TRUNC"
@ -1102,7 +1102,7 @@ variableOfType :: A.Type -> OccParser A.Variable
variableOfType wantT
= do v <- variable
t <- typeOfVariable v
matchType wantT t
matchType (findMeta v) wantT t
return v
channel :: OccParser A.Variable
@ -1120,7 +1120,7 @@ channelOfType :: A.Type -> OccParser A.Variable
channelOfType wantT
= do c <- channel
t <- typeOfVariable c
matchType wantT t
matchType (findMeta c) wantT t
return c
timer :: OccParser A.Variable
@ -1149,7 +1149,7 @@ portOfType :: A.Type -> OccParser A.Variable
portOfType wantT
= do p <- port
t <- typeOfVariable p
matchType wantT t
matchType (findMeta p) wantT t
return p
--}}}
--{{{ protocols
@ -1269,7 +1269,7 @@ isAbbrev newName oldVar
sColon
eol
t <- typeOfVariable v
matchType s t
matchType m s t
return $ A.Specification m n $ A.Is m A.Abbrev s v
<?> "IS abbreviation"
@ -1291,7 +1291,7 @@ chanArrayAbbrev
n <- newChannelName
sIS
sLeft
ct <- trivialSubscriptType s
ct <- trivialSubscriptType m s
case ct of
A.Chan {} -> return (ct, s, n)
_ -> pzero)
@ -1356,7 +1356,7 @@ retypesAbbrev
sColon
eol
origT <- typeOfVariable v
checkRetypes origT s
checkRetypes m origT s
return $ A.Specification m n $ A.Retypes m A.Abbrev s v
<|> do m <- md
(s, n) <- tryVVX channelSpecifier newChannelName retypesReshapes
@ -1364,7 +1364,7 @@ retypesAbbrev
sColon
eol
origT <- typeOfVariable c
checkRetypes origT s
checkRetypes m origT s
return $ A.Specification m n $ A.Retypes m A.Abbrev s c
<|> do m <- md
(s, n) <- tryXVVX sVAL dataSpecifier newVariableName retypesReshapes
@ -1372,24 +1372,24 @@ retypesAbbrev
sColon
eol
origT <- typeOfExpression e
checkRetypes origT s
checkRetypes m origT s
return $ A.Specification m n $ A.RetypesExpr m A.ValAbbrev s e
<?> "RETYPES/RESHAPES abbreviation"
-- | Check that a RETYPES\/RESHAPES is safe.
checkRetypes :: A.Type -> A.Type -> OccParser ()
checkRetypes :: Meta -> A.Type -> A.Type -> OccParser ()
-- Retyping channels is always "safe".
checkRetypes (A.Chan {}) (A.Chan {}) = return ()
checkRetypes fromT toT
checkRetypes _ (A.Chan {}) (A.Chan {}) = return ()
checkRetypes m fromT toT
= do bf <- bytesInType fromT
bt <- bytesInType toT
case (bf, bt) of
(BIJust a, BIJust b) ->
when (a /= b) $ die "size mismatch in RETYPES"
when (a /= b) $ dieP m "size mismatch in RETYPES"
(BIJust a, BIOneFree b _) ->
when (not ((b <= a) && (a `mod` b == 0))) $ die "size mismatch in RETYPES"
when (not ((b <= a) && (a `mod` b == 0))) $ dieP m "size mismatch in RETYPES"
(_, BIManyFree) ->
die "multiple free dimensions in RETYPES/RESHAPES type"
dieP m "multiple free dimensions in RETYPES/RESHAPES type"
-- Otherwise we have to do a runtime check.
_ -> return ()
@ -1600,7 +1600,7 @@ taggedList :: [(A.Name, [A.Type])] -> OccParser (A.Process -> A.Variant)
taggedList nts
= do m <- md
tag <- tagName
ts <- checkJust "unknown tag in protocol" $ lookup tag nts
ts <- checkJust (Just m, "unknown tag in protocol") $ lookup tag nts
is <- sequence [sSemi >> inputItem t | t <- ts]
return $ A.Variant m tag is
<?> "tagged list"
@ -1679,7 +1679,7 @@ channelOutput
return $ A.Output m c os
Right nts ->
do tag <- tagName
ts <- checkJust "unknown tag in protocol" $ lookup tag nts
ts <- checkJust (Just m, "unknown tag in protocol") $ lookup tag nts
os <- sequence [sSemi >> outputItem t | t <- ts]
eol
return $ A.OutputCase m c tag os
@ -1755,7 +1755,7 @@ caseProcess
sCASE
sel <- expression
t <- typeOfExpression sel
t' <- underlyingType t
t' <- underlyingType m t
when (not $ isCaseableType t') $ dieP m "case selector has non-CASEable type"
eol
os <- maybeIndentedList m "empty CASE" (caseOption t)
@ -1972,7 +1972,7 @@ sourceFile
runTockParser :: [Token] -> OccParser t -> CompState -> PassM t
runTockParser toks prod cs
= do case runParser prod cs "" toks of
Left err -> die $ "Parse error: " ++ show err
Left err -> dieReport (Nothing, "Parse error: " ++ show err)
Right r -> return r
-- | Parse an occam program.

4
frontends/RainPasses.hs
View File

@ -167,7 +167,7 @@ transformEachRange :: Data t => t -> PassM t
transformEachRange = everywhereM (mkM transformEachRange')
where
transformEachRange' :: A.Structured -> PassM A.Structured
transformEachRange' s@(A.Rep {})
transformEachRange' s@(A.Rep m _ _)
= case getMatchedItems patt s of
Left _ -> return s --Doesn't match, return the original
Right items ->
@ -192,7 +192,7 @@ transformEachRange = everywhereM (mkM transformEachRange')
castOrDie :: (Typeable b) => String -> Items -> PassM b
castOrDie key items = case castADI (Map.lookup key items) of
Just y -> return y
Nothing -> die "Internal error in transformEachRange"
Nothing -> dieP m "Internal error in transformEachRange"
transformEachRange' s = return s
-- | A pass that changes all the 'A.ForEach' replicators in the AST into 'A.For' replicators.

4
transformations/SimplifyExprs.hs
View File

@ -114,8 +114,8 @@ expandArrayLiterals = doGeneric `extM` doArrayElem
expand :: [A.Dimension] -> A.Expression -> PassM A.ArrayElem
expand [] e = return $ A.ArrayElemExpr e
expand (A.UnknownDimension:_) _
= die "array literal containing non-literal array of unknown size"
expand (A.UnknownDimension:_) e
= dieP (findMeta e) "array literal containing non-literal array of unknown size"
expand (A.Dimension n:ds) e
= liftM A.ArrayElemArray $ sequence [expand ds (A.SubscriptedExpr m (A.Subscript m $ makeConstant m i) e) | i <- [0 .. (n - 1)]]
where m = findMeta e

2
transformations/SimplifyProcs.hs
View File

@ -127,7 +127,7 @@ flattenAssign = doGeneric `extM` doProcess
let zero = A.Literal m A.Int $ A.IntLiteral m "0"
let rep = A.For m counter zero
(A.SizeVariable m srcV)
itemT <- trivialSubscriptType t
itemT <- trivialSubscriptType m t
let sub = A.Subscript m (A.ExprVariable m
(A.Variable m counter))
inner <- assign m itemT

3
transformations/SimplifyTypes.hs
View File

@ -23,6 +23,7 @@ import Control.Monad.State
import Data.Generics
import qualified AST as A
import Metadata
import Pass
import Types
@ -43,7 +44,7 @@ resolveNamedTypes = doGeneric `extM` doType
doGeneric = makeGeneric resolveNamedTypes
doType :: A.Type -> PassM A.Type
doType t@(A.UserDataType _) = underlyingType t
doType t@(A.UserDataType _) = underlyingType emptyMeta t
doType t = doGeneric t
-- | Resolve named types in CompState.

2
transformations/Unnest.hs
View File

@ -112,7 +112,7 @@ removeFreeNames = doGeneric `extM` doSpecification `extM` doProcess
-- we know it's not going to be moved by removeNesting, so anything
-- that it had in scope originally will still be in scope.
ps <- get
when (null $ csMainLocals ps) (die "No main process found")
when (null $ csMainLocals ps) (dieReport (Nothing,"No main process found"))
let isTLP = (snd $ head $ csMainLocals ps) == n
-- Figure out the free names.