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

Take NameType out of NameDef.

Browse Source 
NameType is only really needed in the parser, so this takes it out of
NameDef, meaning that later passes defining names no longer need to
set an arbitrary NameType for them. The parser gets slightly more
complicated (because some productions now have to return a SpecType
and a NameType too), but lots of other code gets simpler.

The code that removed free names was the only thing outside the parser
using NameType, and it now makes a more sensible decision based on the
SpecType. Since unscoped names previously didn't have a SpecType at
all, I've added an Unscoped constructor to it and arranged matters
such that unscoped names now get a proper entry in csNames.

Fixes #61.
This commit is contained in:
Adam Sampson 2008-06-02 10:13:14 +00:00
parent 77a718f078
commit 36e7353ee7
22 changed files with 342 additions and 306 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
backends/BackendPasses.hs
View File

@ -63,7 +63,7 @@ transformWaitFor = applyDepthM doAlt
doWaitFor m'' a@(A.Alternative m cond tim (A.InputTimerFor m' e) p) doWaitFor m'' a@(A.Alternative m cond tim (A.InputTimerFor m' e) p)
= do (specs, init) <- get = do (specs, init) <- get
id <- lift $ makeNonce "waitFor" id <- lift $ makeNonce "waitFor"
let n = (A.Name m A.VariableName id) let n = A.Name m id
let var = A.Variable m n let var = A.Variable m n
put (specs ++ [A.Spec m (A.Specification m n (A.Declaration m A.Time))], put (specs ++ [A.Spec m (A.Specification m n (A.Declaration m A.Time))],
init ++ [A.Only m $ A.Input m tim init ++ [A.Only m $ A.Input m tim
@ -87,7 +87,6 @@ declareSizesArray = applyDepthSM doStructured
= defineName n $ A.NameDef { A.ndMeta = m = defineName n $ A.NameDef { A.ndMeta = m
, A.ndName = A.nameName n , A.ndName = A.nameName n
, A.ndOrigName = A.nameName n , A.ndOrigName = A.nameName n
, A.ndNameType = A.VariableName
, A.ndSpecType = spec , A.ndSpecType = spec
, A.ndAbbrevMode = A.ValAbbrev , A.ndAbbrevMode = A.ValAbbrev
, A.ndPlacement = A.Unplaced , A.ndPlacement = A.Unplaced
@ -157,7 +156,7 @@ declareSizesArray = applyDepthSM doStructured
A.Variable _ srcN -> return (A.Variable m $ append_sizes srcN) A.Variable _ srcN -> return (A.Variable m $ append_sizes srcN)
A.SubscriptedVariable _ (A.SubscriptField _ fieldName) recordV -> A.SubscriptedVariable _ (A.SubscriptField _ fieldName) recordV ->
do A.Record recordName <- astTypeOf recordV do A.Record recordName <- astTypeOf recordV
return (A.Variable m $ A.Name m A.VariableName $ A.nameName recordName ++ A.nameName fieldName ++ "_sizes") return (A.Variable m $ A.Name m $ A.nameName recordName ++ A.nameName fieldName ++ "_sizes")
-- Get the dimensions of the source variable: -- Get the dimensions of the source variable:
(A.Array srcDs _) <- astTypeOf innerV (A.Array srcDs _) <- astTypeOf innerV
-- Calculate the correct subscript into the source _sizes variable to get to the dimensions for the destination: -- Calculate the correct subscript into the source _sizes variable to get to the dimensions for the destination:
@ -248,7 +247,6 @@ addSizesFormalParameters = applyDepthM doSpecification
A.ndMeta = m A.ndMeta = m
,A.ndName = A.nameName n ,A.ndName = A.nameName n
,A.ndOrigName = A.nameName n ,A.ndOrigName = A.nameName n
,A.ndNameType = A.VariableName
,A.ndSpecType = A.Declaration m t ,A.ndSpecType = A.Declaration m t
,A.ndAbbrevMode = A.ValAbbrev ,A.ndAbbrevMode = A.ValAbbrev
,A.ndPlacement = A.Unplaced} ,A.ndPlacement = A.Unplaced}

15
backends/BackendPassesTest.hs
View File

@ -78,7 +78,7 @@ testTransformWaitFor1 = TestCase $ testPass "testTransformWaitFor1" exp (transfo
,mOnlyP $ tag3 A.Assign DontCare [var] $ tag2 A.ExpressionList DontCare [tag4 A.Dyadic DontCare A.Plus evar (exprVariablePattern "t")] ,mOnlyP $ tag3 A.Assign DontCare [var] $ tag2 A.ExpressionList DontCare [tag4 A.Dyadic DontCare A.Plus evar (exprVariablePattern "t")]
,mOnlyP $ tag3 A.Alt DontCare True $ mOnlyA $ mWaitUntil evar (A.Skip m) ,mOnlyP $ tag3 A.Alt DontCare True $ mOnlyA $ mWaitUntil evar (A.Skip m)
] ]
varName = (tag3 A.Name DontCare A.VariableName $ Named "nowt" DontCare) varName = (tag2 A.Name DontCare $ Named "nowt" DontCare)
var = tag2 A.Variable DontCare varName var = tag2 A.Variable DontCare varName
evar = tag2 A.ExprVariable DontCare var evar = tag2 A.ExprVariable DontCare var
@ -100,10 +100,10 @@ testTransformWaitFor2 = TestCase $ testPass "testTransformWaitFor2" exp (transfo
[mOnlyA $ mWaitUntil evar0 (A.Skip m) [mOnlyA $ mWaitUntil evar0 (A.Skip m)
,mOnlyA $ mWaitUntil evar1 (A.Skip m)] ,mOnlyA $ mWaitUntil evar1 (A.Skip m)]
] ]
varName0 = (tag3 A.Name DontCare A.VariableName $ Named "nowt0" DontCare) varName0 = (tag2 A.Name DontCare $ Named "nowt0" DontCare)
var0 = tag2 A.Variable DontCare varName0 var0 = tag2 A.Variable DontCare varName0
evar0 = tag2 A.ExprVariable DontCare var0 evar0 = tag2 A.ExprVariable DontCare var0
varName1 = (tag3 A.Name DontCare A.VariableName $ Named "nowt1" DontCare) varName1 = (tag2 A.Name DontCare $ Named "nowt1" DontCare)
var1 = tag2 A.Variable DontCare varName1 var1 = tag2 A.Variable DontCare varName1
evar1 = tag2 A.ExprVariable DontCare var1 evar1 = tag2 A.ExprVariable DontCare var1
@ -120,7 +120,7 @@ testTransformWaitFor3 = TestCase $ testPass "testTransformWaitFor3" exp (transfo
(A.Dyadic m A.Plus (exprVariable "t0") (exprVariable "t1"))] (A.Dyadic m A.Plus (exprVariable "t0") (exprVariable "t1"))]
,mOnlyP $ tag3 A.Alt DontCare True $ mOnlyA $ mWaitUntil evar (A.Skip m) ,mOnlyP $ tag3 A.Alt DontCare True $ mOnlyA $ mWaitUntil evar (A.Skip m)
] ]
varName = (tag3 A.Name DontCare A.VariableName $ Named "nowt" DontCare) varName = (tag2 A.Name DontCare $ Named "nowt" DontCare)
var = tag2 A.Variable DontCare varName var = tag2 A.Variable DontCare varName
evar = tag2 A.ExprVariable DontCare var evar = tag2 A.ExprVariable DontCare var
@ -137,7 +137,7 @@ testTransformWaitFor4 = TestCase $ testPass "testTransformWaitFor4" exp (transfo
,mOnlyP $ tag3 A.Alt DontCare True $ mSeveralA ,mOnlyP $ tag3 A.Alt DontCare True $ mSeveralA
[mOnlyA $ mWaitUntil evar (A.Skip m)] [mOnlyA $ mWaitUntil evar (A.Skip m)]
] ]
varName = (tag3 A.Name DontCare A.VariableName $ Named "nowt" DontCare) varName = (tag2 A.Name DontCare $ Named "nowt" DontCare)
var = tag2 A.Variable DontCare varName var = tag2 A.Variable DontCare varName
evar = tag2 A.ExprVariable DontCare var evar = tag2 A.ExprVariable DontCare var
@ -159,10 +159,10 @@ testTransformWaitFor5 = TestCase $ testPass "testTransformWaitFor5" exp (transfo
[mOnlyA $ mWaitUntil evar0 (A.Skip m) [mOnlyA $ mWaitUntil evar0 (A.Skip m)
,mOnlyA $ mWaitUntil evar1 (A.Skip m)] ,mOnlyA $ mWaitUntil evar1 (A.Skip m)]
] ]
varName0 = (tag3 A.Name DontCare A.VariableName $ Named "nowt0" DontCare) varName0 = (tag2 A.Name DontCare $ Named "nowt0" DontCare)
var0 = tag2 A.Variable DontCare varName0 var0 = tag2 A.Variable DontCare varName0
evar0 = tag2 A.ExprVariable DontCare var0 evar0 = tag2 A.ExprVariable DontCare var0
varName1 = (tag3 A.Name DontCare A.VariableName $ Named "nowt1" DontCare) varName1 = (tag2 A.Name DontCare $ Named "nowt1" DontCare)
var1 = tag2 A.Variable DontCare varName1 var1 = tag2 A.Variable DontCare varName1
evar1 = tag2 A.ExprVariable DontCare var1 evar1 = tag2 A.ExprVariable DontCare var1
@ -325,7 +325,6 @@ defineTestName n sp am
A.ndMeta = emptyMeta A.ndMeta = emptyMeta
,A.ndName = n ,A.ndName = n
,A.ndOrigName = n ,A.ndOrigName = n
,A.ndNameType = A.VariableName
,A.ndSpecType = sp ,A.ndSpecType = sp
,A.ndAbbrevMode = am ,A.ndAbbrevMode = am
,A.ndPlacement = A.Unplaced ,A.ndPlacement = A.Unplaced

2
backends/GenerateC.hs
View File

@ -258,7 +258,7 @@ genRightB = tell ["}"]
cgenOverArray :: Meta -> A.Variable -> (SubscripterFunction -> Maybe (CGen ())) -> CGen () cgenOverArray :: Meta -> A.Variable -> (SubscripterFunction -> Maybe (CGen ())) -> CGen ()
cgenOverArray m var func cgenOverArray m var func
= do A.Array ds _ <- astTypeOf var = do A.Array ds _ <- astTypeOf var
specs <- sequence [csmLift $ makeNonceVariable "i" m A.Int A.VariableName A.Original | _ <- ds] specs <- sequence [csmLift $ makeNonceVariable "i" m A.Int A.Original | _ <- ds]
let indices = [A.Variable m n | A.Specification _ n _ <- specs] let indices = [A.Variable m n | A.Specification _ n _ <- specs]
let arg = (\var -> foldl (\v s -> A.SubscriptedVariable m s v) var [A.Subscript m A.NoCheck $ A.ExprVariable m i | i <- indices]) let arg = (\var -> foldl (\v s -> A.SubscriptedVariable m s v) var [A.Subscript m A.NoCheck $ A.ExprVariable m i | i <- indices])

4
backends/GenerateCTest.hs
View File

@ -754,7 +754,7 @@ testRetypeSizes = TestList
over = local $ \ops -> ops {genBytesIn = showBytesInParams, genStop = override2 at} over = local $ \ops -> ops {genBytesIn = showBytesInParams, genStop = override2 at}
defRecord :: String -> String -> A.Type -> State CompState () defRecord :: String -> String -> A.Type -> State CompState ()
defRecord rec mem t = defineName (simpleName rec) $ A.NameDef emptyMeta rec rec A.RecordName (A.RecordType emptyMeta False [(simpleName mem,t)]) A.Original A.Unplaced defRecord rec mem t = defineName (simpleName rec) $ A.NameDef emptyMeta rec rec (A.RecordType emptyMeta False [(simpleName mem,t)]) A.Original A.Unplaced
testGenVariable :: Test testGenVariable :: Test
testGenVariable = TestList testGenVariable = TestList
@ -825,7 +825,7 @@ testGenVariable = TestList
,testBothS ("testGenVariable/unchecked" ++ show n) eUC eUCPP (over (tcall genVariableUnchecked $ sub $ A.Variable emptyMeta foo)) state ,testBothS ("testGenVariable/unchecked" ++ show n) eUC eUCPP (over (tcall genVariableUnchecked $ sub $ A.Variable emptyMeta foo)) state
] ]
where where
state = do defineName (simpleName "foo") $ A.NameDef emptyMeta "foo" "foo" A.VariableName (A.Declaration emptyMeta t) am A.Unplaced state = do defineName (simpleName "foo") $ A.NameDef emptyMeta "foo" "foo" (A.Declaration emptyMeta t) am A.Unplaced
defRecord "bar" "x" $ A.Array [dimension 7] A.Int defRecord "bar" "x" $ A.Array [dimension 7] A.Int
defRecord "barbar" "y" $ A.Record bar defRecord "barbar" "y" $ A.Record bar
over :: Override over :: Override

23
backends/TLP.hs
View File

@ -29,23 +29,28 @@ import CompState
import Errors import Errors
import Metadata import Metadata
import Types import Types
import Utils
data TLPChannel = TLPIn | TLPOut | TLPError data TLPChannel = TLPIn | TLPOut | TLPError
deriving (Show, Eq, Typeable, Data) deriving (Show, Eq, Typeable, Data)
-- | Get the name of the TLP and the channels it uses. -- | Get the name of the TLP and the channels it uses.
-- Fail if the process isn't using a valid interface. -- Fail if the process isn't using a valid interface.
tlpInterface :: (CSMR m, Die m) => m ( A.Name, [(A.Direction, TLPChannel)] ) tlpInterface :: (CSMR m, Die m) => m (A.Name, [(A.Direction, TLPChannel)])
tlpInterface tlpInterface
= do ps <- getCompState = do mainLocals <- getCompState >>* csMainLocals
when (null $ csMainLocals ps) (dieReport (Nothing,"No main process found")) when (null mainLocals) $
let mainName = snd $ head $ csMainLocals ps dieReport (Nothing, "No main process found")
let (_, (mainName, _)) = head mainLocals
st <- specTypeOfName mainName st <- specTypeOfName mainName
(m,formals) <- case st of (m, formals) <-
A.Proc m _ fs _ -> return (m,fs) case st of
_ -> dieP (findMeta mainName) "Last definition is not a PROC" A.Proc m _ fs _ -> return (m, fs)
_ -> dieP (findMeta mainName) "Last definition is not a PROC"
chans <- mapM (tlpChannel m) formals chans <- mapM (tlpChannel m) formals
when ((nub (map snd chans)) /= (map snd chans)) $ dieP (findMeta mainName) "Channels used more than once in TLP" let chanIds = map snd chans
when (nub chanIds /= chanIds) $
dieP (findMeta mainName) "Channels used more than once in TLP"
return (mainName, chans) return (mainName, chans)
where where
tlpChannel :: (CSMR m, Die m) => Meta -> A.Formal -> m (A.Direction, TLPChannel) tlpChannel :: (CSMR m, Die m) => Meta -> A.Formal -> m (A.Direction, TLPChannel)
@ -55,7 +60,7 @@ tlpInterface
case lookup origN tlpChanNames of case lookup origN tlpChanNames of
Just c -> Just c ->
if (dir == A.DirUnknown || dir == (tlpDir c)) if (dir == A.DirUnknown || dir == (tlpDir c))
then return (dir,c) then return (dir, c)
else dieP m $ "TLP formal " ++ show n ++ " has wrong direction for its name" else dieP m $ "TLP formal " ++ show n ++ " has wrong direction for its name"
_ -> dieP m $ "TLP formal " ++ show n ++ " has unrecognised name" _ -> dieP m $ "TLP formal " ++ show n ++ " has unrecognised name"
tlpChannel m (A.Formal _ _ n) tlpChannel m (A.Formal _ _ n)

4
checks/ArrayUsageCheck.hs
View File

@ -81,8 +81,8 @@ checkArrayUsage (m,p) = mapM_ (checkIndexes m) $ Map.toList $
-- String (array-name) and Meta are only used for printing out error messages -- String (array-name) and Meta are only used for printing out error messages
checkIndexes :: Meta -> (String,ParItems ([A.Expression],[A.Expression])) -> m () checkIndexes :: Meta -> (String,ParItems ([A.Expression],[A.Expression])) -> m ()
checkIndexes m (arrName, indexes) checkIndexes m (arrName, indexes)
= do userArrName <- getRealName (A.Name undefined undefined arrName) = do userArrName <- getRealName (A.Name undefined arrName)
arrType <- astTypeOf (A.Name undefined undefined arrName) arrType <- astTypeOf (A.Name undefined arrName)
arrLength <- case arrType of arrLength <- case arrType of
A.Array (A.Dimension d:_) _ -> return d A.Array (A.Dimension d:_) _ -> return d
-- Unknown dimension, use the maximum value for a (assumed 32-bit for INT) integer: -- Unknown dimension, use the maximum value for a (assumed 32-bit for INT) integer:

64
common/TestUtils.hs
View File

@ -114,33 +114,33 @@ testCheck config property =
dimension :: Int -> A.Dimension dimension :: Int -> A.Dimension
dimension n = makeDimension emptyMeta n dimension n = makeDimension emptyMeta n
-- | Creates a 'A.Name' object with the given 'String' as 'A.nameName', and 'A.nameType' as 'A.VariableName'. -- | Creates a 'A.Name' object with the given 'String' as 'A.nameName'.
simpleName :: String -> A.Name simpleName :: String -> A.Name
simpleName s = A.Name { A.nameName = s , A.nameMeta = emptyMeta , A.nameType = A.VariableName } simpleName s = A.Name { A.nameName = s, A.nameMeta = emptyMeta }
-- | Creates a 'A.Name' object with the given 'String' as 'A.nameName', and 'A.nameType' as 'A.ProcName'. -- | Creates a 'A.Name' object with the given 'String' as 'A.nameName'.
procName :: String -> A.Name procName :: String -> A.Name
procName s = A.Name { A.nameName = s , A.nameMeta = emptyMeta , A.nameType = A.ProcName } procName = simpleName
-- | Creates a 'A.Name' object with the given 'String' as 'A.nameName', and 'A.nameType' as 'A.DataTypeName'. -- | Creates a 'A.Name' object with the given 'String' as 'A.nameName'.
typeName :: String -> A.Name typeName :: String -> A.Name
typeName s = A.Name { A.nameName = s , A.nameMeta = emptyMeta , A.nameType = A.DataTypeName } typeName = simpleName
-- | Creates a 'A.Name' object with the given 'String' as 'A.nameName', and 'A.nameType' as 'A.FunctionName'. -- | Creates a 'A.Name' object with the given 'String' as 'A.nameName'.
funcName :: String -> A.Name funcName :: String -> A.Name
funcName s = A.Name { A.nameName = s , A.nameMeta = emptyMeta , A.nameType = A.FunctionName } funcName = simpleName
-- | Creates a 'Pattern' to match a 'A.Name' instance. -- | Creates a 'Pattern' to match a 'A.Name' instance.
-- @'assertPatternMatch' ('simpleNamePattern' x) ('simpleName' x)@ will always succeed. -- @'assertPatternMatch' ('simpleNamePattern' x) ('simpleName' x)@ will always succeed.
-- All meta tags are ignored. -- All meta tags are ignored.
simpleNamePattern :: String -> Pattern simpleNamePattern :: String -> Pattern
simpleNamePattern s = tag3 A.Name DontCare A.VariableName s simpleNamePattern s = tag2 A.Name DontCare s
-- | Creates a 'Pattern' to match a 'A.Name' instance. -- | Creates a 'Pattern' to match a 'A.Name' instance.
-- @'assertPatternMatch' ('procNamePattern' x) ('procName' x)@ will always succeed. -- @'assertPatternMatch' ('procNamePattern' x) ('procName' x)@ will always succeed.
-- All meta tags are ignored. -- All meta tags are ignored.
procNamePattern :: String -> Pattern procNamePattern :: String -> Pattern
procNamePattern s = tag3 A.Name DontCare A.ProcName s procNamePattern s = tag2 A.Name DontCare s
-- | Creates a 'A.Variable' with the given 'String' as the name. -- | Creates a 'A.Variable' with the given 'String' as the name.
variable :: String -> A.Variable variable :: String -> A.Variable
@ -284,12 +284,11 @@ buildExpr (Lit e) = e
buildExpr EHTrue = A.True emptyMeta buildExpr EHTrue = A.True emptyMeta
buildExpr (Range t begin end) = A.ExprConstr emptyMeta $ A.RangeConstr emptyMeta t buildExpr (Range t begin end) = A.ExprConstr emptyMeta $ A.RangeConstr emptyMeta t
(buildExpr begin) (buildExpr end) (buildExpr begin) (buildExpr end)
buildExpr (Func f es) = A.FunctionCall emptyMeta ((simpleName f) {A.nameType buildExpr (Func f es) = A.FunctionCall emptyMeta (simpleName f) (map buildExpr es)
= A.FunctionName}) (map buildExpr es)
-- | A simple definition of a variable -- | A simple definition of a variable
simpleDef :: String -> A.SpecType -> A.NameDef simpleDef :: String -> A.SpecType -> A.NameDef
simpleDef n sp = A.NameDef {A.ndMeta = emptyMeta, A.ndName = n, A.ndOrigName = n, A.ndNameType = A.VariableName, simpleDef n sp = A.NameDef {A.ndMeta = emptyMeta, A.ndName = n, A.ndOrigName = n,
A.ndSpecType = sp, A.ndAbbrevMode = A.Original, A.ndPlacement = A.Unplaced} A.ndSpecType = sp, A.ndAbbrevMode = A.Original, A.ndPlacement = A.Unplaced}
-- | A simple definition of a declared variable -- | A simple definition of a declared variable
@ -298,20 +297,19 @@ simpleDefDecl n t = simpleDef n (A.Declaration emptyMeta t)
-- | A pattern that will match simpleDef, with a different abbreviation mode -- | A pattern that will match simpleDef, with a different abbreviation mode
simpleDefPattern :: String -> A.AbbrevMode -> Pattern -> Pattern simpleDefPattern :: String -> A.AbbrevMode -> Pattern -> Pattern
simpleDefPattern n am sp = tag7 A.NameDef DontCare n n A.VariableName sp am A.Unplaced simpleDefPattern n am sp = tag6 A.NameDef DontCare n n sp am A.Unplaced
--}}} --}}}
--{{{ defining things --{{{ defining things
-- | Define something in the initial state. -- | Define something in the initial state.
defineThing :: String -> A.NameType -> A.SpecType -> A.AbbrevMode defineThing :: String -> A.SpecType -> A.AbbrevMode
-> State CompState () -> State CompState ()
defineThing s nt st am = defineName (simpleName s) $ defineThing s st am = defineName (simpleName s) $
A.NameDef { A.NameDef {
A.ndMeta = emptyMeta, A.ndMeta = emptyMeta,
A.ndName = s, A.ndName = s,
A.ndOrigName = s, A.ndOrigName = s,
A.ndNameType = nt,
A.ndSpecType = st, A.ndSpecType = st,
A.ndAbbrevMode = am, A.ndAbbrevMode = am,
A.ndPlacement = A.Unplaced A.ndPlacement = A.Unplaced
@ -320,39 +318,41 @@ defineThing s nt st am = defineName (simpleName s) $
-- | Define a @VAL IS@ constant. -- | Define a @VAL IS@ constant.
defineConst :: String -> A.Type -> A.Expression -> State CompState () defineConst :: String -> A.Type -> A.Expression -> State CompState ()
defineConst s t e defineConst s t e
= defineThing s A.VariableName (A.IsExpr emptyMeta A.ValAbbrev t e) = defineThing s (A.IsExpr emptyMeta A.ValAbbrev t e)
A.ValAbbrev A.ValAbbrev
-- | Define an @IS@ abbreviation. -- | Define an @IS@ abbreviation.
defineIs :: String -> A.Type -> A.Variable -> State CompState () defineIs :: String -> A.Type -> A.Variable -> State CompState ()
defineIs s t v defineIs s t v
= defineThing s A.VariableName (A.Is emptyMeta A.Abbrev t v) A.Abbrev = defineThing s (A.Is emptyMeta A.Abbrev t v) A.Abbrev
-- | Define something original.
defineOriginal :: String -> A.Type -> State CompState ()
defineOriginal s t
= defineThing s (A.Declaration emptyMeta t) A.Original
-- | Define a variable. -- | Define a variable.
defineVariable :: String -> A.Type -> State CompState () defineVariable :: String -> A.Type -> State CompState ()
defineVariable s t defineVariable = defineOriginal
= defineThing s A.VariableName (A.Declaration emptyMeta t) A.Original
-- | Define a channel. -- | Define a channel.
defineChannel :: String -> A.Type -> State CompState () defineChannel :: String -> A.Type -> State CompState ()
defineChannel s t defineChannel = defineOriginal
= defineThing s A.ChannelName (A.Declaration emptyMeta t) A.Original
-- | Define a timer. -- | Define a timer.
defineTimer :: String -> A.Type -> State CompState () defineTimer :: String -> A.Type -> State CompState ()
defineTimer s t defineTimer = defineOriginal
= defineThing s A.TimerName (A.Declaration emptyMeta t) A.Original
-- | Define a user data type. -- | Define a user data type.
defineUserDataType :: String -> A.Type -> State CompState () defineUserDataType :: String -> A.Type -> State CompState ()
defineUserDataType s t defineUserDataType s t
= defineThing s A.DataTypeName (A.DataType emptyMeta t) A.Original = defineThing s (A.DataType emptyMeta t) A.Original
-- | Define a record type. -- | Define a record type.
-- (The fields are unscoped names, and thus don't need defining.) -- (The fields are unscoped names, and thus don't need defining.)
defineRecordType :: String -> [(String, A.Type)] -> State CompState () defineRecordType :: String -> [(String, A.Type)] -> State CompState ()
defineRecordType s fs defineRecordType s fs
= defineThing s A.RecordName st A.Original = defineThing s st A.Original
where where
st = A.RecordType emptyMeta False [(simpleName s, t) | (s, t) <- fs] st = A.RecordType emptyMeta False [(simpleName s, t) | (s, t) <- fs]
@ -360,7 +360,7 @@ defineRecordType s fs
defineFunction :: String -> [A.Type] -> [(String, A.Type)] defineFunction :: String -> [A.Type] -> [(String, A.Type)]
-> State CompState () -> State CompState ()
defineFunction s rs as defineFunction s rs as
= defineThing s A.FunctionName st A.Original = defineThing s st A.Original
where where
st = A.Function emptyMeta A.PlainSpec rs fs (Right $ A.Skip emptyMeta) st = A.Function emptyMeta A.PlainSpec rs fs (Right $ A.Skip emptyMeta)
fs = [A.Formal A.ValAbbrev t (simpleName s) | (s, t) <- as] fs = [A.Formal A.ValAbbrev t (simpleName s) | (s, t) <- as]
@ -368,7 +368,7 @@ defineFunction s rs as
-- | Define a proc. -- | Define a proc.
defineProc :: String -> [(String, A.AbbrevMode, A.Type)] -> State CompState () defineProc :: String -> [(String, A.AbbrevMode, A.Type)] -> State CompState ()
defineProc s as defineProc s as
= defineThing s A.ProcName st A.Original = defineThing s st A.Original
where where
st = A.Proc emptyMeta A.PlainSpec fs $ A.Skip emptyMeta st = A.Proc emptyMeta A.PlainSpec fs $ A.Skip emptyMeta
fs = [A.Formal am t (simpleName s) | (s, am, t) <- as] fs = [A.Formal am t (simpleName s) | (s, am, t) <- as]
@ -376,12 +376,12 @@ defineProc s as
-- | Define a protocol. -- | Define a protocol.
defineProtocol :: String -> [A.Type] -> State CompState () defineProtocol :: String -> [A.Type] -> State CompState ()
defineProtocol s ts defineProtocol s ts
= defineThing s A.ProtocolName (A.Protocol emptyMeta ts) A.Original = defineThing s (A.Protocol emptyMeta ts) A.Original
-- | Define a variant protocol. -- | Define a variant protocol.
defineProtocolCase :: String -> [(A.Name, [A.Type])] -> State CompState () defineProtocolCase :: String -> [(A.Name, [A.Type])] -> State CompState ()
defineProtocolCase s ntss defineProtocolCase s ntss
= defineThing s A.ProtocolName (A.ProtocolCase emptyMeta ntss) A.Original = defineThing s (A.ProtocolCase emptyMeta ntss) A.Original
--}}} --}}}
--{{{ custom assertions --{{{ custom assertions
@ -437,7 +437,7 @@ checkTempVarTypes testName vars is = mapM_ (checkTempVarType testName is) vars
where where
checkTempVarType :: String -> (Items, CompState) -> (String, A.Type) -> Assertion checkTempVarType :: String -> (Items, CompState) -> (String, A.Type) -> Assertion
checkTempVarType testName (items, state) (key, t) checkTempVarType testName (items, state) (key, t)
= do (A.Name _ _ nm) <- castOrFail testName key items = do (A.Name _ nm) <- castOrFail testName key items
case Map.lookup nm (csNames state) of case Map.lookup nm (csNames state) of
Nothing -> assertFailure (testName ++ ": item with key \"" ++ key ++ "\" was not recorded in the state") Nothing -> assertFailure (testName ++ ": item with key \"" ++ key ++ "\" was not recorded in the state")
Just nd -> evalStateT ( Just nd -> evalStateT (

19
data/AST.hs
View File

@ -30,22 +30,10 @@ import Data.Generics
import Metadata import Metadata
-- | The general type of a name.
-- This is used by the parser to indicate what sort of name it's expecting in a
-- particular context; in later passes you can look at how the name is actually
-- defined, which is more useful.
data NameType =
ChannelName | DataTypeName | FunctionName | FieldName | PortName
| ProcName | ProtocolName | RecordName | TagName | TimerName | VariableName
deriving (Show, Eq, Typeable, Data)
-- | An identifier defined in the source code. -- | An identifier defined in the source code.
-- This can be any of the 'NameType' types.
data Name = Name { data Name = Name {
-- | Metadata. -- | Metadata.
nameMeta :: Meta, nameMeta :: Meta,
-- | The general type of the name.
nameType :: NameType,
-- | The internal version of the name. -- | The internal version of the name.
-- This isn't necessary the same as it appeared in the source code; if -- This isn't necessary the same as it appeared in the source code; if
-- you're displaying it to the user in an error message, you should -- you're displaying it to the user in an error message, you should
@ -62,15 +50,13 @@ instance Eq Name where
-- | The definition of a name. -- | The definition of a name.
data NameDef = NameDef { data NameDef = NameDef {
-- | Metadata. -- | Metadata for where the name was originally defined.
ndMeta :: Meta, ndMeta :: Meta,
-- | The internal version of the name. -- | The internal version of the name.
ndName :: String, ndName :: String,
-- | The name as it appeared in the source code. -- | The name as it appeared in the source code.
-- This can be used for error reporting. -- This can be used for error reporting.
ndOrigName :: String, ndOrigName :: String,
-- | The general type of the name.
ndNameType :: NameType,
-- | The specification type of the name's definition (see 'SpecType'). -- | The specification type of the name's definition (see 'SpecType').
ndSpecType :: SpecType, ndSpecType :: SpecType,
-- | The abbreviation mode of the name's definition (see 'AbbrevMode'). -- | The abbreviation mode of the name's definition (see 'AbbrevMode').
@ -510,6 +496,9 @@ data SpecType =
| Retypes Meta AbbrevMode Type Variable | Retypes Meta AbbrevMode Type Variable
-- | Declare a retyping abbreviation of an expression. -- | Declare a retyping abbreviation of an expression.
| RetypesExpr Meta AbbrevMode Type Expression | RetypesExpr Meta AbbrevMode Type Expression
-- | A fake declaration of an unscoped name, such as a protocol tag.
-- This allows 'SpecType' to be used to describe any identifier.
| Unscoped Meta
deriving (Show, Eq, Typeable, Data) deriving (Show, Eq, Typeable, Data)
-- | Specification mode for @PROC@s and @FUNCTION@s. -- | Specification mode for @PROC@s and @FUNCTION@s.

51
data/CompState.hs
View File

@ -55,6 +55,15 @@ data PreprocDef =
| PreprocString String | PreprocString String
deriving (Show, Data, Typeable, Eq) deriving (Show, Data, Typeable, Eq)
-- | The general type of a name.
-- This is used by the parser to indicate what sort of name it's expecting in a
-- particular context; in later passes you can look at how the name is actually
-- defined, which is more useful.
data NameType =
ChannelName | DataTypeName | FunctionName | FieldName | PortName
| ProcName | ProtocolName | RecordName | TagName | TimerName | VariableName
deriving (Show, Eq, Typeable, Data)
-- | An item that has been pulled up. -- | An item that has been pulled up.
type PulledItem = (Meta, Either A.Specification A.Process) -- Either Spec or ProcThen type PulledItem = (Meta, Either A.Specification A.Process) -- Either Spec or ProcThen
@ -98,8 +107,8 @@ data CompState = CompState {
csDefinitions :: Map String PreprocDef, csDefinitions :: Map String PreprocDef,
-- Set by Parse -- Set by Parse
csLocalNames :: [(String, A.Name)], csLocalNames :: [(String, (A.Name, NameType))],
csMainLocals :: [(String, A.Name)], csMainLocals :: [(String, (A.Name, NameType))],
csNames :: Map String A.NameDef, csNames :: Map String A.NameDef,
csUnscopedNames :: Map String String, csUnscopedNames :: Map String String,
csNameCounter :: Int, csNameCounter :: Int,
@ -220,14 +229,23 @@ makeUniqueName s
-- | Find an unscoped name -- or define a new one if it doesn't already exist. -- | Find an unscoped name -- or define a new one if it doesn't already exist.
findUnscopedName :: CSM m => A.Name -> m A.Name findUnscopedName :: CSM m => A.Name -> m A.Name
findUnscopedName n@(A.Name m nt s) findUnscopedName n@(A.Name m s)
= do st <- get = do st <- get
case Map.lookup s (csUnscopedNames st) of case Map.lookup s (csUnscopedNames st) of
Just s' -> return $ A.Name m nt s' Just s' -> return $ A.Name m s'
Nothing -> Nothing ->
do s' <- makeUniqueName s do s' <- makeUniqueName s
modify (\st -> st { csUnscopedNames = Map.insert s s' (csUnscopedNames st) }) modify (\st -> st { csUnscopedNames = Map.insert s s' (csUnscopedNames st) })
return $ A.Name m nt s' let n = A.Name m s'
let nd = A.NameDef { A.ndMeta = m
, A.ndName = s'
, A.ndOrigName = s
, A.ndSpecType = A.Unscoped m
, A.ndAbbrevMode = A.Original
, A.ndPlacement = A.Unplaced
}
defineName n nd
return n
--}}} --}}}
--{{{ pulled items --{{{ pulled items
@ -297,15 +315,14 @@ makeNonce s
return $ s ++ "_n" ++ show i return $ s ++ "_n" ++ show i
-- | Generate and define a nonce specification. -- | Generate and define a nonce specification.
defineNonce :: CSM m => Meta -> String -> A.SpecType -> A.NameType -> A.AbbrevMode -> m A.Specification defineNonce :: CSM m => Meta -> String -> A.SpecType -> A.AbbrevMode -> m A.Specification
defineNonce m s st nt am defineNonce m s st am
= do ns <- makeNonce s = do ns <- makeNonce s
let n = A.Name m nt ns let n = A.Name m ns
let nd = A.NameDef { let nd = A.NameDef {
A.ndMeta = m, A.ndMeta = m,
A.ndName = ns, A.ndName = ns,
A.ndOrigName = ns, A.ndOrigName = ns,
A.ndNameType = nt,
A.ndSpecType = st, A.ndSpecType = st,
A.ndAbbrevMode = am, A.ndAbbrevMode = am,
A.ndPlacement = A.Unplaced A.ndPlacement = A.Unplaced
@ -316,28 +333,28 @@ defineNonce m s st nt am
-- | Generate and define a no-arg wrapper PROC around a process. -- | Generate and define a no-arg wrapper PROC around a process.
makeNonceProc :: CSM m => Meta -> A.Process -> m A.Specification makeNonceProc :: CSM m => Meta -> A.Process -> m A.Specification
makeNonceProc m p makeNonceProc m p
= defineNonce m "wrapper_proc" (A.Proc m A.PlainSpec [] p) A.ProcName A.Abbrev = defineNonce m "wrapper_proc" (A.Proc m A.PlainSpec [] p) A.Abbrev
-- | Generate and define a counter for a replicator. -- | Generate and define a counter for a replicator.
makeNonceCounter :: CSM m => String -> Meta -> m A.Name makeNonceCounter :: CSM m => String -> Meta -> m A.Name
makeNonceCounter s m makeNonceCounter s m
= do (A.Specification _ n _) <- defineNonce m s (A.Declaration m A.Int) A.VariableName A.ValAbbrev = do (A.Specification _ n _) <- defineNonce m s (A.Declaration m A.Int) A.ValAbbrev
return n return n
-- | Generate and define a variable abbreviation. -- | Generate and define a variable abbreviation.
makeNonceIs :: CSM m => String -> Meta -> A.Type -> A.AbbrevMode -> A.Variable -> m A.Specification makeNonceIs :: CSM m => String -> Meta -> A.Type -> A.AbbrevMode -> A.Variable -> m A.Specification
makeNonceIs s m t am v makeNonceIs s m t am v
= defineNonce m s (A.Is m am t v) A.VariableName am = defineNonce m s (A.Is m am t v) am
-- | Generate and define an expression abbreviation. -- | Generate and define an expression abbreviation.
makeNonceIsExpr :: CSM m => String -> Meta -> A.Type -> A.Expression -> m A.Specification makeNonceIsExpr :: CSM m => String -> Meta -> A.Type -> A.Expression -> m A.Specification
makeNonceIsExpr s m t e makeNonceIsExpr s m t e
= defineNonce m s (A.IsExpr m A.ValAbbrev t e) A.VariableName A.ValAbbrev = defineNonce m s (A.IsExpr m A.ValAbbrev t e) A.ValAbbrev
-- | Generate and define a variable. -- | Generate and define a variable.
makeNonceVariable :: CSM m => String -> Meta -> A.Type -> A.NameType -> A.AbbrevMode -> m A.Specification makeNonceVariable :: CSM m => String -> Meta -> A.Type -> A.AbbrevMode -> m A.Specification
makeNonceVariable s m t nt am makeNonceVariable s m t am
= defineNonce m s (A.Declaration m t) nt am = defineNonce m s (A.Declaration m t) am
--}}} --}}}
diePC :: (CSMR m, Die m) => Meta -> m String -> m a diePC :: (CSMR m, Die m) => Meta -> m String -> m a
@ -376,4 +393,4 @@ getUniqueIdentifer :: CSM m => m Int
getUniqueIdentifer = do st <- get getUniqueIdentifer = do st <- get
let n = csUnifyId st let n = csUnifyId st
put st {csUnifyId = n + 1} put st {csUnifyId = n + 1}
return n return n

12
frontends/OccamTypes.hs
View File

@ -376,9 +376,9 @@ checkIntrinsicFunctionCall m n es
Just (rs, args) -> Just (rs, args) ->
do when (length rs /= 1) $ do when (length rs /= 1) $
dieP m $ "Function " ++ n ++ " used in an expression returns more than one value" dieP m $ "Function " ++ n ++ " used in an expression returns more than one value"
let fs = [A.Formal A.ValAbbrev t (A.Name m A.VariableName s) let fs = [A.Formal A.ValAbbrev t (A.Name m s)
| (t, s) <- args] | (t, s) <- args]
checkActuals m (A.Name m A.ProcName n) checkActuals m (A.Name m n)
fs (map A.ActualExpression es) fs (map A.ActualExpression es)
Nothing -> dieP m $ n ++ " is not an intrinsic function" Nothing -> dieP m $ n ++ " is not an intrinsic function"
@ -889,9 +889,9 @@ inferTypes = recurse
-- | Given a name that should really have been a tag, make it one. -- | Given a name that should really have been a tag, make it one.
nameToUnscoped :: A.Name -> PassM A.Name nameToUnscoped :: A.Name -> PassM A.Name
nameToUnscoped n@(A.Name m nt _) nameToUnscoped n@(A.Name m _)
= do nd <- lookupName n = do nd <- lookupName n
findUnscopedName (A.Name m A.FieldName (A.ndOrigName nd)) findUnscopedName (A.Name m (A.ndOrigName nd))
-- | Process a 'LiteralRepr', taking the type it's meant to represent or -- | Process a 'LiteralRepr', taking the type it's meant to represent or
-- 'Infer', and returning the type it really is. -- 'Infer', and returning the type it really is.
@ -1203,9 +1203,9 @@ checkProcesses = checkDepthM doProcess
doProcess (A.IntrinsicProcCall m n as) doProcess (A.IntrinsicProcCall m n as)
= case lookup n intrinsicProcs of = case lookup n intrinsicProcs of
Just args -> Just args ->
do let fs = [A.Formal am t (A.Name m A.VariableName s) do let fs = [A.Formal am t (A.Name m s)
| (am, t, s) <- args] | (am, t, s) <- args]
checkActuals m (A.Name m A.ProcName n) fs as checkActuals m (A.Name m n) fs as
Nothing -> dieP m $ n ++ " is not an intrinsic procedure" Nothing -> dieP m $ n ++ " is not an intrinsic procedure"
doAlternative :: Check A.Alternative doAlternative :: Check A.Alternative

238
frontends/ParseOccam.hs
View File

@ -315,7 +315,7 @@ maybeIndentedList m msg inner
<|> do addWarning m msg <|> do addWarning m msg
return [] return []
handleSpecs :: OccParser [A.Specification] -> OccParser a -> (Meta -> A.Specification -> a -> a) -> OccParser a handleSpecs :: OccParser [NameSpec] -> OccParser a -> (Meta -> A.Specification -> a -> a) -> OccParser a
handleSpecs specs inner specMarker handleSpecs specs inner specMarker
= do m <- md = do m <- md
ss <- specs ss <- specs
@ -341,66 +341,69 @@ intersperseP (f:fs) sep
--}}} --}}}
--{{{ name scoping --{{{ name scoping
findName :: A.Name -> OccParser A.Name findName :: A.Name -> NameType -> OccParser A.Name
findName thisN findName thisN thisNT
= do st <- get = do st <- get
origN <- case lookup (A.nameName thisN) (csLocalNames st) of (origN, origNT) <-
Nothing -> dieP (A.nameMeta thisN) $ "name " ++ A.nameName thisN ++ " not defined" case lookup (A.nameName thisN) (csLocalNames st) of
Just n -> return n Nothing -> dieP (A.nameMeta thisN) $ "name " ++ A.nameName thisN ++ " not defined"
if A.nameType thisN /= A.nameType origN Just def -> return def
then dieP (A.nameMeta thisN) $ "expected " ++ show (A.nameType thisN) ++ " (" ++ A.nameName origN ++ " is " ++ show (A.nameType origN) ++ ")" if thisNT /= origNT
then dieP (A.nameMeta thisN) $ "expected " ++ show thisNT ++ " (" ++ A.nameName origN ++ " is " ++ show origNT ++ ")"
else return $ thisN { A.nameName = A.nameName origN } else return $ thisN { A.nameName = A.nameName origN }
scopeIn :: A.Name -> A.SpecType -> A.AbbrevMode -> OccParser A.Name scopeIn :: A.Name -> NameType -> A.SpecType -> A.AbbrevMode -> OccParser A.Name
scopeIn n@(A.Name m nt s) specType am scopeIn n@(A.Name m s) nt specType am
= do st <- getState = do s' <- makeUniqueName s
s' <- makeUniqueName s
let n' = n { A.nameName = s' } let n' = n { A.nameName = s' }
let nd = A.NameDef { let nd = A.NameDef {
A.ndMeta = m, A.ndMeta = m,
A.ndName = s', A.ndName = s',
A.ndOrigName = s, A.ndOrigName = s,
A.ndNameType = A.nameType n',
A.ndSpecType = specType, A.ndSpecType = specType,
A.ndAbbrevMode = am, A.ndAbbrevMode = am,
A.ndPlacement = A.Unplaced A.ndPlacement = A.Unplaced
} }
defineName n' nd defineName n' nd
modify $ (\st -> st { st <- get
csLocalNames = (s, n') : (csLocalNames st) put $ st { csLocalNames = (s, (n', nt)) : (csLocalNames st) }
})
return n' return n'
scopeOut :: A.Name -> OccParser () scopeOut :: A.Name -> OccParser ()
scopeOut n@(A.Name m nt s) scopeOut n@(A.Name m _)
= do st <- get = do st <- get
let lns' = case csLocalNames st of case csLocalNames st of
(s, _):ns -> ns (_:rest) -> put $ st { csLocalNames = rest }
otherwise -> dieInternal (Just m, "scopeOut trying to scope out the wrong name") _ -> dieInternal (Just m, "scoping out name when stack is empty")
put $ st { csLocalNames = lns' }
scopeInRep :: A.Replicator -> OccParser A.Replicator scopeInRep :: A.Replicator -> OccParser A.Replicator
scopeInRep (A.For m n b c) scopeInRep (A.For m n b c)
= do n' <- scopeIn n (A.Declaration m A.Int) A.ValAbbrev = do n' <- scopeIn n VariableName (A.Declaration m A.Int) A.ValAbbrev
return $ A.For m n' b c return $ A.For m n' b c
scopeOutRep :: A.Replicator -> OccParser () scopeOutRep :: A.Replicator -> OccParser ()
scopeOutRep (A.For m n b c) = scopeOut n scopeOutRep (A.For m n b c) = scopeOut n
scopeInSpec :: A.Specification -> OccParser A.Specification -- | A specification, along with the 'NameType' of the name it defines.
scopeInSpec (A.Specification m n st) type NameSpec = (A.Specification, NameType)
= do n' <- scopeIn n st (abbrevModeOfSpec st)
scopeInSpec :: NameSpec -> OccParser A.Specification
scopeInSpec (A.Specification m n st, nt)
= do n' <- scopeIn n nt st (abbrevModeOfSpec st)
return $ A.Specification m n' st return $ A.Specification m n' st
scopeOutSpec :: A.Specification -> OccParser () scopeOutSpec :: A.Specification -> OccParser ()
scopeOutSpec (A.Specification _ n _) = scopeOut n scopeOutSpec (A.Specification _ n _) = scopeOut n
scopeInFormal :: A.Formal -> OccParser A.Formal -- | A formal, along with the 'NameType' of the name it defines.
scopeInFormal (A.Formal am t n) type NameFormal = (A.Formal, NameType)
= do n' <- scopeIn n (A.Declaration (A.nameMeta n) t) am
scopeInFormal :: NameFormal -> OccParser A.Formal
scopeInFormal (A.Formal am t n, nt)
= do n' <- scopeIn n nt (A.Declaration (A.nameMeta n) t) am
return (A.Formal am t n') return (A.Formal am t n')
scopeInFormals :: [A.Formal] -> OccParser [A.Formal] scopeInFormals :: [NameFormal] -> OccParser [A.Formal]
scopeInFormals fs = mapM scopeInFormal fs scopeInFormals fs = mapM scopeInFormal fs
scopeOutFormals :: [A.Formal] -> OccParser () scopeOutFormals :: [A.Formal] -> OccParser ()
@ -419,55 +422,56 @@ scopeOutFormals fs = sequence_ [scopeOut n | (A.Formal am t n) <- fs]
-- ambiguities will be resolved later. -- ambiguities will be resolved later.
--{{{ names --{{{ names
anyName :: A.NameType -> OccParser A.Name anyName :: NameType -> OccParser A.Name
anyName nt anyName nt
= do m <- md = do m <- md
s <- identifier s <- identifier
return $ A.Name m nt s return $ A.Name m s
<?> show nt <?> show nt
name :: A.NameType -> OccParser A.Name name :: NameType -> OccParser A.Name
name nt name nt
= do n <- anyName nt = do n <- anyName nt
findName n findName n nt
newName :: A.NameType -> OccParser A.Name newName :: NameType -> OccParser A.Name
newName nt = anyName nt newName nt = anyName nt
channelName, dataTypeName, functionName, portName, procName, protocolName, channelName, dataTypeName, functionName, portName, procName, protocolName,
recordName, timerName, variableName recordName, timerName, variableName
:: OccParser A.Name :: OccParser A.Name
channelName = name A.ChannelName channelName = name ChannelName
dataTypeName = name A.DataTypeName dataTypeName = name DataTypeName
functionName = name A.FunctionName functionName = name FunctionName
portName = name A.PortName portName = name PortName
procName = name A.ProcName procName = name ProcName
protocolName = name A.ProtocolName protocolName = name ProtocolName
recordName = name A.RecordName recordName = name RecordName
timerName = name A.TimerName timerName = name TimerName
variableName = name A.VariableName variableName = name VariableName
newChannelName, newDataTypeName, newFunctionName, newPortName, newProcName, newProtocolName, newChannelName, newDataTypeName, newFunctionName, newPortName,
newRecordName, newTimerName, newVariableName newProcName, newProtocolName, newRecordName, newTimerName,
newVariableName
:: OccParser A.Name :: OccParser A.Name
newChannelName = newName A.ChannelName newChannelName = newName ChannelName
newDataTypeName = newName A.DataTypeName newDataTypeName = newName DataTypeName
newFunctionName = newName A.FunctionName newFunctionName = newName FunctionName
newPortName = newName A.PortName newPortName = newName PortName
newProcName = newName A.ProcName newProcName = newName ProcName
newProtocolName = newName A.ProtocolName newProtocolName = newName ProtocolName
newRecordName = newName A.RecordName newRecordName = newName RecordName
newTimerName = newName A.TimerName newTimerName = newName TimerName
newVariableName = newName A.VariableName newVariableName = newName VariableName
-- | A name that isn't scoped. -- | A name that isn't scoped.
-- This is for things like record fields: we don't need to track their scope -- This is for things like record fields: we don't need to track their scope
-- because they're only valid with the particular record they're defined in, -- because they're only valid with the particular record they're defined in,
-- but we do need to add a unique suffix so that they don't collide with -- but we do need to add a unique suffix so that they don't collide with
-- keywords in the target language -- keywords in the target language
unscopedName :: A.NameType -> OccParser A.Name unscopedName :: NameType -> OccParser A.Name
unscopedName nt unscopedName nt
= do n <- anyName nt = do n <- anyName nt
findUnscopedName n findUnscopedName n
@ -475,10 +479,10 @@ unscopedName nt
fieldName, tagName, newFieldName, newTagName :: OccParser A.Name fieldName, tagName, newFieldName, newTagName :: OccParser A.Name
fieldName = unscopedName A.FieldName fieldName = unscopedName FieldName
tagName = unscopedName A.TagName tagName = unscopedName TagName
newFieldName = unscopedName A.FieldName newFieldName = unscopedName FieldName
newTagName = unscopedName A.TagName newTagName = unscopedName TagName
--}}} --}}}
--{{{ types --{{{ types
-- | A sized array of a production. -- | A sized array of a production.
@ -732,7 +736,7 @@ functionCall
where where
intrinsicFunctionName :: OccParser String intrinsicFunctionName :: OccParser String
intrinsicFunctionName intrinsicFunctionName
= do s <- anyName A.FunctionName >>* A.nameName = do s <- anyName FunctionName >>* A.nameName
case lookup s intrinsicFunctions of case lookup s intrinsicFunctions of
Just _ -> return s Just _ -> return s
Nothing -> pzero Nothing -> pzero
@ -896,7 +900,7 @@ replicator
<?> "replicator" <?> "replicator"
--}}} --}}}
--{{{ specifications, declarations, allocations --{{{ specifications, declarations, allocations
allocation :: OccParser [A.Specification] allocation :: OccParser [NameSpec]
allocation allocation
= do m <- md = do m <- md
sPLACE sPLACE
@ -919,86 +923,88 @@ placement
return $ A.PlaceInVecspace return $ A.PlaceInVecspace
<?> "placement" <?> "placement"
specification :: OccParser [A.Specification] specification :: OccParser [NameSpec]
specification specification
= do { m <- md; (ns, d) <- declaration; return [A.Specification m n d | n <- ns] } = do m <- md
(ns, d, nt) <- declaration
return [(A.Specification m n d, nt) | n <- ns]
<|> do { a <- abbreviation; return [a] } <|> do { a <- abbreviation; return [a] }
<|> do { d <- definition; return [d] } <|> do { d <- definition; return [d] }
<?> "specification" <?> "specification"
declaration :: OccParser ([A.Name], A.SpecType) declaration :: OccParser ([A.Name], A.SpecType, NameType)
declaration declaration
= declOf dataType newVariableName = declOf dataType VariableName
<|> declOf channelType newChannelName <|> declOf channelType ChannelName
<|> declOf timerType newTimerName <|> declOf timerType TimerName
<|> declOf portType newPortName <|> declOf portType PortName
<?> "declaration" <?> "declaration"
declOf :: OccParser A.Type -> OccParser A.Name -> OccParser ([A.Name], A.SpecType) declOf :: OccParser A.Type -> NameType -> OccParser ([A.Name], A.SpecType, NameType)
declOf spec newName declOf spec nt
= do m <- md = do m <- md
(d, ns) <- tryVVX spec (sepBy1 newName sComma) sColon (d, ns) <- tryVVX spec (sepBy1 (newName nt) sComma) sColon
eol eol
return (ns, A.Declaration m d) return (ns, A.Declaration m d, nt)
abbreviation :: OccParser A.Specification abbreviation :: OccParser NameSpec
abbreviation abbreviation
= valIsAbbrev = valIsAbbrev
<|> initialIsAbbrev <|> initialIsAbbrev
<|> isAbbrev newVariableName variable <|> isAbbrev variable VariableName
<|> isAbbrev newChannelName channel <|> isAbbrev channel ChannelName
<|> chanArrayAbbrev <|> chanArrayAbbrev
<|> isAbbrev newTimerName timer <|> isAbbrev timer TimerName
<|> isAbbrev newPortName port <|> isAbbrev port PortName
<?> "abbreviation" <?> "abbreviation"
valIsAbbrev :: OccParser A.Specification valIsAbbrev :: OccParser NameSpec
valIsAbbrev valIsAbbrev
= do m <- md = do m <- md
(n, t, e) <- do { n <- tryXVX sVAL newVariableName sIS; e <- expression; sColon; eol; return (n, A.Infer, e) } (n, t, e) <- do { n <- tryXVX sVAL newVariableName sIS; e <- expression; sColon; eol; return (n, A.Infer, e) }
<|> do { (s, n) <- tryXVVX sVAL dataSpecifier newVariableName sIS; e <- expression; sColon; eol; return (n, s, e) } <|> do { (s, n) <- tryXVVX sVAL dataSpecifier newVariableName sIS; e <- expression; sColon; eol; return (n, s, e) }
return $ A.Specification m n $ A.IsExpr m A.ValAbbrev t e return (A.Specification m n $ A.IsExpr m A.ValAbbrev t e, VariableName)
<?> "VAL IS abbreviation" <?> "VAL IS abbreviation"
initialIsAbbrev :: OccParser A.Specification initialIsAbbrev :: OccParser NameSpec
initialIsAbbrev initialIsAbbrev
= do m <- md = do m <- md
(t, n) <- tryXVVX sINITIAL dataSpecifier newVariableName sIS (t, n) <- tryXVVX sINITIAL dataSpecifier newVariableName sIS
e <- expression e <- expression
sColon sColon
eol eol
return $ A.Specification m n $ A.IsExpr m A.Original t e return (A.Specification m n $ A.IsExpr m A.Original t e, VariableName)
<?> "INITIAL IS abbreviation" <?> "INITIAL IS abbreviation"
isAbbrev :: OccParser A.Name -> OccParser A.Variable -> OccParser A.Specification isAbbrev :: OccParser A.Variable -> NameType -> OccParser NameSpec
isAbbrev newName oldVar isAbbrev oldVar nt
= do m <- md = do m <- md
(n, v) <- tryVXV newName sIS oldVar (n, v) <- tryVXV (newName nt) sIS oldVar
sColon sColon
eol eol
return $ A.Specification m n $ A.Is m A.Abbrev A.Infer v return (A.Specification m n $ A.Is m A.Abbrev A.Infer v, nt)
<|> do m <- md <|> do m <- md
(s, n, v) <- tryVVXV specifier newName sIS oldVar (s, n, v) <- tryVVXV specifier (newName nt) sIS oldVar
sColon sColon
eol eol
return $ A.Specification m n $ A.Is m A.Abbrev s v return (A.Specification m n $ A.Is m A.Abbrev s v, nt)
<?> "IS abbreviation" <?> "IS abbreviation"
chanArrayAbbrev :: OccParser A.Specification chanArrayAbbrev :: OccParser NameSpec
chanArrayAbbrev chanArrayAbbrev
= do m <- md = do m <- md
(n, cs) <- tryVXXV newChannelName sIS sLeft (sepBy1 channel sComma) (n, cs) <- tryVXXV newChannelName sIS sLeft (sepBy1 channel sComma)
sRight sRight
sColon sColon
eol eol
return $ A.Specification m n $ A.IsChannelArray m A.Infer cs return (A.Specification m n $ A.IsChannelArray m A.Infer cs, ChannelName)
<|> do m <- md <|> do m <- md
(s, n) <- tryVVXX channelSpecifier newChannelName sIS sLeft (s, n) <- tryVVXX channelSpecifier newChannelName sIS sLeft
cs <- sepBy1 channel sComma cs <- sepBy1 channel sComma
sRight sRight
sColon sColon
eol eol
return $ A.Specification m n $ A.IsChannelArray m s cs return (A.Specification m n $ A.IsChannelArray m s cs, ChannelName)
<?> "channel array abbreviation" <?> "channel array abbreviation"
specMode :: OccParser () -> OccParser A.SpecMode specMode :: OccParser () -> OccParser A.SpecMode
@ -1009,18 +1015,18 @@ specMode keyword
return A.PlainSpec return A.PlainSpec
<?> "specification mode" <?> "specification mode"
definition :: OccParser A.Specification definition :: OccParser NameSpec
definition definition
= do m <- md = do m <- md
sDATA sDATA
sTYPE sTYPE
do { n <- tryVX newDataTypeName sIS; t <- dataType; sColon; eol; return $ A.Specification m n (A.DataType m t) } do { n <- tryVX newDataTypeName sIS; t <- dataType; sColon; eol; return (A.Specification m n (A.DataType m t), DataTypeName) }
<|> do { n <- newRecordName; eol; indent; rec <- structuredType; outdent; sColon; eol; return $ A.Specification m n rec } <|> do { n <- newRecordName; eol; indent; rec <- structuredType; outdent; sColon; eol; return (A.Specification m n rec, DataTypeName) }
<|> do m <- md <|> do m <- md
sPROTOCOL sPROTOCOL
n <- newProtocolName n <- newProtocolName
do { sIS; p <- sequentialProtocol; sColon; eol; return $ A.Specification m n $ A.Protocol m p } do { sIS; p <- sequentialProtocol; sColon; eol; return (A.Specification m n $ A.Protocol m p, ProtocolName) }
<|> do { eol; indent; sCASE; eol; ps <- maybeIndentedList m "empty CASE protocol" taggedProtocol; outdent; sColon; eol; return $ A.Specification m n $ A.ProtocolCase m ps } <|> do { eol; indent; sCASE; eol; ps <- maybeIndentedList m "empty CASE protocol" taggedProtocol; outdent; sColon; eol; return (A.Specification m n $ A.ProtocolCase m ps, ProtocolName) }
<|> do m <- md <|> do m <- md
sm <- specMode sPROC sm <- specMode sPROC
n <- newProcName n <- newProcName
@ -1033,13 +1039,13 @@ definition
outdent outdent
sColon sColon
eol eol
return $ A.Specification m n $ A.Proc m sm fs' p return (A.Specification m n $ A.Proc m sm fs' p, ProcName)
<|> do m <- md <|> do m <- md
(rs, sm) <- tryVV (sepBy1 dataType sComma) (specMode sFUNCTION) (rs, sm) <- tryVV (sepBy1 dataType sComma) (specMode sFUNCTION)
n <- newFunctionName n <- newFunctionName
fs <- formalList fs <- formalList
do { sIS; fs' <- scopeInFormals fs; el <- expressionList; scopeOutFormals fs'; sColon; eol; return $ A.Specification m n $ A.Function m sm rs fs' (Left $ A.Only m el) } do { sIS; fs' <- scopeInFormals fs; el <- expressionList; scopeOutFormals fs'; sColon; eol; return (A.Specification m n $ A.Function m sm rs fs' (Left $ A.Only m el), FunctionName) }
<|> do { eol; indent; fs' <- scopeInFormals fs; vp <- valueProcess; scopeOutFormals fs'; outdent; sColon; eol; return $ A.Specification m n $ A.Function m sm rs fs' (Left vp) } <|> do { eol; indent; fs' <- scopeInFormals fs; vp <- valueProcess; scopeOutFormals fs'; outdent; sColon; eol; return (A.Specification m n $ A.Function m sm rs fs' (Left vp), FunctionName) }
<|> retypesAbbrev <|> retypesAbbrev
<?> "definition" <?> "definition"
@ -1047,26 +1053,26 @@ retypesReshapes :: OccParser ()
retypesReshapes retypesReshapes
= sRETYPES <|> sRESHAPES = sRETYPES <|> sRESHAPES
retypesAbbrev :: OccParser A.Specification retypesAbbrev :: OccParser NameSpec
retypesAbbrev retypesAbbrev
= do m <- md = do m <- md
(s, n) <- tryVVX dataSpecifier newVariableName retypesReshapes (s, n) <- tryVVX dataSpecifier newVariableName retypesReshapes
v <- variable v <- variable
sColon sColon
eol eol
return $ A.Specification m n $ A.Retypes m A.Abbrev s v return (A.Specification m n $ A.Retypes m A.Abbrev s v, VariableName)
<|> do m <- md <|> do m <- md
(s, n) <- tryVVX channelSpecifier newChannelName retypesReshapes (s, n) <- tryVVX channelSpecifier newChannelName retypesReshapes
c <- channel c <- channel
sColon sColon
eol eol
return $ A.Specification m n $ A.Retypes m A.Abbrev s c return (A.Specification m n $ A.Retypes m A.Abbrev s c, ChannelName)
<|> do m <- md <|> do m <- md
(s, n) <- tryXVVX sVAL dataSpecifier newVariableName retypesReshapes (s, n) <- tryXVVX sVAL dataSpecifier newVariableName retypesReshapes
e <- expression e <- expression
sColon sColon
eol eol
return $ A.Specification m n $ A.RetypesExpr m A.ValAbbrev s e return (A.Specification m n $ A.RetypesExpr m A.ValAbbrev s e, VariableName)
<?> "RETYPES/RESHAPES abbreviation" <?> "RETYPES/RESHAPES abbreviation"
dataSpecifier :: OccParser A.Type dataSpecifier :: OccParser A.Type
@ -1103,7 +1109,7 @@ specifier
<?> "specifier" <?> "specifier"
--{{{ PROCs and FUNCTIONs --{{{ PROCs and FUNCTIONs
formalList :: OccParser [A.Formal] formalList :: OccParser [NameFormal]
formalList formalList
= do m <- md = do m <- md
sLeftR sLeftR
@ -1112,18 +1118,18 @@ formalList
return fs return fs
<?> "formal list" <?> "formal list"
formalItem :: OccParser (A.AbbrevMode, A.Type) -> OccParser A.Name -> OccParser [A.Formal] formalItem :: OccParser (A.AbbrevMode, A.Type) -> NameType -> OccParser [NameFormal]
formalItem spec name formalItem spec nt
= do (am, t) <- spec = do (am, t) <- spec
names am t names am t
where where
names :: A.AbbrevMode -> A.Type -> OccParser [A.Formal] names :: A.AbbrevMode -> A.Type -> OccParser [NameFormal]
names am t names am t
= do n <- name = do n <- newName nt
fs <- tail am t fs <- tail am t
return $ (A.Formal am t n) : fs return $ (A.Formal am t n, nt) : fs
tail :: A.AbbrevMode -> A.Type -> OccParser [A.Formal] tail :: A.AbbrevMode -> A.Type -> OccParser [NameFormal]
tail am t tail am t
= do sComma = do sComma
-- We must try formalArgSet first here, so that we don't -- We must try formalArgSet first here, so that we don't
@ -1133,12 +1139,12 @@ formalItem spec name
<|> return [] <|> return []
-- | Parse a set of formal arguments. -- | Parse a set of formal arguments.
formalArgSet :: OccParser [A.Formal] formalArgSet :: OccParser [NameFormal]
formalArgSet formalArgSet
= formalItem formalVariableType newVariableName = formalItem formalVariableType VariableName
<|> formalItem (aa channelSpecifier) newChannelName <|> formalItem (aa channelSpecifier) ChannelName
<|> formalItem (aa timerSpecifier) newTimerName <|> formalItem (aa timerSpecifier) TimerName
<|> formalItem (aa portSpecifier) newPortName <|> formalItem (aa portSpecifier) PortName
where where
aa :: OccParser A.Type -> OccParser (A.AbbrevMode, A.Type) aa :: OccParser A.Type -> OccParser (A.AbbrevMode, A.Type)
aa = liftM (\t -> (A.Abbrev, t)) aa = liftM (\t -> (A.Abbrev, t))
@ -1562,10 +1568,10 @@ actual (A.Formal am t n)
--{{{ intrinsic PROC call --{{{ intrinsic PROC call
intrinsicProcName :: OccParser (String, [A.Formal]) intrinsicProcName :: OccParser (String, [A.Formal])
intrinsicProcName intrinsicProcName
= do n <- anyName A.ProcName = do n <- anyName ProcName
let s = A.nameName n let s = A.nameName n
case lookup s intrinsicProcs of case lookup s intrinsicProcs of
Just atns -> return (s, [A.Formal am t (A.Name emptyMeta A.VariableName n) Just atns -> return (s, [A.Formal am t (A.Name emptyMeta n)
| (am, t, n) <- atns]) | (am, t, n) <- atns])
Nothing -> pzero Nothing -> pzero

13
frontends/ParseRain.hs
View File

@ -149,7 +149,7 @@ reserved word
name :: RainParser A.Name name :: RainParser A.Name
name name
= do (m,s) <- identifier = do (m,s) <- identifier
return $ A.Name m (A.VariableName) s --A.VariableName is a placeholder until a later pass return $ A.Name m s
<?> "name" <?> "name"
@ -170,7 +170,7 @@ dataType
<|> do {sIn ; inner <- dataType ; return $ A.Chan A.DirInput (A.ChanAttributes {A.caWritingShared = False, A.caReadingShared = False}) inner} <|> do {sIn ; inner <- dataType ; return $ A.Chan A.DirInput (A.ChanAttributes {A.caWritingShared = False, A.caReadingShared = False}) inner}
<|> do {sOut ; inner <- dataType ; return $ A.Chan A.DirOutput (A.ChanAttributes {A.caWritingShared = False, A.caReadingShared = False}) inner} <|> do {sOut ; inner <- dataType ; return $ A.Chan A.DirOutput (A.ChanAttributes {A.caWritingShared = False, A.caReadingShared = False}) inner}
<|> do {sLeftQ ; inner <- dataType ; sRightQ ; return $ A.List inner} <|> do {sLeftQ ; inner <- dataType ; sRightQ ; return $ A.List inner}
<|> do {(m,n) <- identifier ; return $ A.UserDataType A.Name {A.nameMeta = m, A.nameName = n, A.nameType = A.DataTypeName}} <|> do {(m,n) <- identifier ; return $ A.UserDataType A.Name {A.nameMeta = m, A.nameName = n}}
<?> "data type" <?> "data type"
variable :: RainParser A.Variable variable :: RainParser A.Variable
@ -313,8 +313,7 @@ functionCall = do funcName <- name
Just _ -> return $ A.IntrinsicFunctionCall (A.nameMeta Just _ -> return $ A.IntrinsicFunctionCall (A.nameMeta
funcName) (A.nameName funcName) es funcName) (A.nameName funcName) es
Nothing -> return $ Nothing -> return $
A.FunctionCall (A.nameMeta funcName) A.FunctionCall (A.nameMeta funcName) funcName es
(funcName {A.nameType = A.FunctionName}) es
data InnerBlockLineState = Decls | NoMoreDecls | Mixed deriving (Eq) data InnerBlockLineState = Decls | NoMoreDecls | Mixed deriving (Eq)
@ -427,7 +426,7 @@ runProcess :: RainParser A.Process
runProcess = do (mProcess,processName) <- identifier runProcess = do (mProcess,processName) <- identifier
items <- tuple items <- tuple
sSemiColon sSemiColon
return $ A.ProcCall mProcess A.Name {A.nameName = processName, A.nameMeta = mProcess, A.nameType = A.ProcName} (map convertItem items) return $ A.ProcCall mProcess A.Name {A.nameName = processName, A.nameMeta = mProcess} (map convertItem items)
where where
convertItem :: A.Expression -> A.Actual convertItem :: A.Expression -> A.Actual
convertItem (A.ExprVariable _ v) = A.ActualVariable v convertItem (A.ExprVariable _ v) = A.ActualVariable v
@ -513,7 +512,7 @@ rainSourceFile
rainTimerName :: A.Name rainTimerName :: A.Name
rainTimerName = A.Name {A.nameName = ghostVarPrefix ++ "raintimer" ++ ghostVarSuffix, rainTimerName = A.Name {A.nameName = ghostVarPrefix ++ "raintimer" ++ ghostVarSuffix,
A.nameMeta = emptyMeta, A.nameType = A.TimerName} A.nameMeta = emptyMeta}
-- | Parse Rain source text (with filename for error messages) -- | Parse Rain source text (with filename for error messages)
parseRainProgram :: FilePath -> String -> PassM A.AST parseRainProgram :: FilePath -> String -> PassM A.AST
@ -525,7 +524,7 @@ parseRainProgram filename source
do defineName rainTimerName $ A.NameDef {A.ndMeta = emptyMeta, do defineName rainTimerName $ A.NameDef {A.ndMeta = emptyMeta,
A.ndName = A.nameName rainTimerName, A.ndName = A.nameName rainTimerName,
A.ndOrigName = A.nameName rainTimerName, A.ndOrigName = A.nameName rainTimerName,
A.ndNameType = A.TimerName, A.ndSpecType = A.Declaration emptyMeta A.ndSpecType = A.Declaration emptyMeta
(A.Timer A.RainTimer), (A.Timer A.RainTimer),
A.ndAbbrevMode = A.Original, A.ndPlacement = A.Unplaced} A.ndAbbrevMode = A.Original, A.ndPlacement = A.Unplaced}
cs <- get cs <- get

2
frontends/ParseRainTest.hs
View File

@ -582,7 +582,7 @@ testDecl =
passd ("bool: b;",0,pat $ A.Specification m (simpleName "b") $ A.Declaration m A.Bool) passd ("bool: b;",0,pat $ A.Specification m (simpleName "b") $ A.Declaration m A.Bool)
,passd ("uint8: x;",1,pat $ A.Specification m (simpleName "x") $ A.Declaration m A.Byte) ,passd ("uint8: x;",1,pat $ A.Specification m (simpleName "x") $ A.Declaration m A.Byte)
,passd ("?bool: bc;",2,pat $ A.Specification m (simpleName "bc") $ A.Declaration m (A.Chan A.DirInput nonShared A.Bool)) ,passd ("?bool: bc;",2,pat $ A.Specification m (simpleName "bc") $ A.Declaration m (A.Chan A.DirInput nonShared A.Bool))
,passd ("a: b;",3,pat $ A.Specification m (simpleName "b") $ A.Declaration m (A.UserDataType $ A.Name m A.DataTypeName "a")) ,passd ("a: b;",3,pat $ A.Specification m (simpleName "b") $ A.Declaration m (A.UserDataType $ A.Name m "a"))
,passd2 ("bool: b0,b1;",100,pat $ A.Specification m (simpleName "b0") $ A.Declaration m A.Bool, ,passd2 ("bool: b0,b1;",100,pat $ A.Specification m (simpleName "b0") $ A.Declaration m A.Bool,
pat $ A.Specification m (simpleName "b1") $ A.Declaration m A.Bool) pat $ A.Specification m (simpleName "b1") $ A.Declaration m A.Bool)

34
frontends/RainPasses.hs
View File

@ -28,7 +28,6 @@ import Data.Maybe
import qualified AST as A import qualified AST as A
import CompState import CompState
import Errors import Errors
import ImplicitMobility
import Pass import Pass
import qualified Properties as Prop import qualified Properties as Prop
import RainTypes import RainTypes
@ -101,7 +100,7 @@ uniquifyAndResolveVars = applyDepthSM uniquifyAndResolveVars'
uniquifyAndResolveVars' (A.Spec m (A.Specification m' n decl@(A.Declaration {})) scope) uniquifyAndResolveVars' (A.Spec m (A.Specification m' n decl@(A.Declaration {})) scope)
= do n' <- makeNonce $ A.nameName n = do n' <- makeNonce $ A.nameName n
defineName (n {A.nameName = n'}) A.NameDef {A.ndMeta = m', A.ndName = n', A.ndOrigName = A.nameName n, defineName (n {A.nameName = n'}) A.NameDef {A.ndMeta = m', A.ndName = n', A.ndOrigName = A.nameName n,
A.ndNameType = A.VariableName, A.ndSpecType = decl, A.ndSpecType = decl,
A.ndAbbrevMode = A.Original, A.ndPlacement = A.Unplaced} A.ndAbbrevMode = A.Original, A.ndPlacement = A.Unplaced}
let scope' = everywhere (mkT $ replaceNameName (A.nameName n) n') scope let scope' = everywhere (mkT $ replaceNameName (A.nameName n) n') scope
return $ A.Spec m (A.Specification m' n {A.nameName = n'} decl) scope' return $ A.Spec m (A.Specification m' n {A.nameName = n'} decl) scope'
@ -111,7 +110,7 @@ uniquifyAndResolveVars = applyDepthSM uniquifyAndResolveVars'
= do (params',procBody') <- doFormals params procBody = do (params',procBody') <- doFormals params procBody
let newProc = (A.Proc m'' procMode params' procBody') let newProc = (A.Proc m'' procMode params' procBody')
defineName n A.NameDef {A.ndMeta = m', A.ndName = A.nameName n, A.ndOrigName = A.nameName n, defineName n A.NameDef {A.ndMeta = m', A.ndName = A.nameName n, A.ndOrigName = A.nameName n,
A.ndNameType = A.ProcName, A.ndSpecType = newProc, A.ndSpecType = newProc,
A.ndAbbrevMode = A.Original, A.ndPlacement = A.Unplaced} A.ndAbbrevMode = A.Original, A.ndPlacement = A.Unplaced}
return $ A.Spec m (A.Specification m' n newProc) scope return $ A.Spec m (A.Specification m' n newProc) scope
-- Functions: -- Functions:
@ -120,7 +119,7 @@ uniquifyAndResolveVars = applyDepthSM uniquifyAndResolveVars'
= do (params', funcBody') <- doFormals params funcBody = do (params', funcBody') <- doFormals params funcBody
let newFunc = (A.Function m'' funcMode retTypes params' funcBody') let newFunc = (A.Function m'' funcMode retTypes params' funcBody')
defineName n A.NameDef {A.ndMeta = m', A.ndName = A.nameName n, A.ndOrigName = A.nameName n, defineName n A.NameDef {A.ndMeta = m', A.ndName = A.nameName n, A.ndOrigName = A.nameName n,
A.ndNameType = A.FunctionName, A.ndSpecType = newFunc, A.ndSpecType = newFunc,
A.ndAbbrevMode = A.Original, A.ndPlacement = A.Unplaced} A.ndAbbrevMode = A.Original, A.ndPlacement = A.Unplaced}
return $ A.Spec m (A.Specification m' n newFunc) scope return $ A.Spec m (A.Specification m' n newFunc) scope
@ -147,7 +146,7 @@ uniquifyAndResolveVars = applyDepthSM uniquifyAndResolveVars'
let newName = (n {A.nameName = n'}) let newName = (n {A.nameName = n'})
let m = A.nameMeta n let m = A.nameMeta n
defineName newName A.NameDef {A.ndMeta = m, A.ndName = n', A.ndOrigName = A.nameName n, defineName newName A.NameDef {A.ndMeta = m, A.ndName = n', A.ndOrigName = A.nameName n,
A.ndNameType = A.VariableName, A.ndSpecType = (A.Declaration m t), A.ndSpecType = (A.Declaration m t),
A.ndAbbrevMode = am, A.ndPlacement = A.Unplaced} A.ndAbbrevMode = am, A.ndPlacement = A.Unplaced}
let scope' = everywhere (mkT $ replaceNameName (A.nameName n) n') scope let scope' = everywhere (mkT $ replaceNameName (A.nameName n) n') scope
return (A.Formal am t newName, scope') return (A.Formal am t newName, scope')
@ -170,15 +169,24 @@ findMain x = do newMainName <- makeNonce "main_"
applyDepthM (return . (replaceNameName "main" newMainName)) x applyDepthM (return . (replaceNameName "main" newMainName)) x
where where
--We have to mangle the main name because otherwise it will cause problems on some backends (including C and C++) --We have to mangle the main name because otherwise it will cause problems on some backends (including C and C++)
findMain' :: String -> CompState -> CompState findMain' :: String -> CompState -> CompState
findMain' newn st = case (Map.lookup "main" (csNames st)) of findMain' newn st = case Map.lookup "main" (csNames st) of
Just n -> st {csNames = changeMainName newn (csNames st) , csMainLocals = [(newn,A.Name {A.nameName = newn, A.nameMeta = A.ndMeta n, A.nameType = A.ndNameType n})]} Just n -> st { csNames = changeMainName newn (csNames st)
Nothing -> st , csMainLocals = makeMainLocals (findMeta n) newn
}
Nothing -> st
changeMainName :: String -> Map.Map String A.NameDef -> Map.Map String A.NameDef changeMainName :: String -> Map.Map String A.NameDef -> Map.Map String A.NameDef
changeMainName n m = case (Map.lookup "main" m) of changeMainName newn m = case Map.lookup "main" m of
Just nd -> Map.insert newn (nd {A.ndName = newn}) $
Map.delete "main" m
Nothing -> m Nothing -> m
Just nd -> ((Map.insert n (nd {A.ndName = n})) . (Map.delete "main")) m
-- The Rain parser doesn't set csMainLocals, so this pass constructs it
-- from scratch.
makeMainLocals :: Meta -> String -> [(String, (A.Name, NameType))]
makeMainLocals m newn = [(newn, (A.Name m newn, ProcName))]
checkIntegral :: A.LiteralRepr -> Maybe Integer checkIntegral :: A.LiteralRepr -> Maybe Integer
checkIntegral (A.IntLiteral _ s) = Just $ read s checkIntegral (A.IntLiteral _ s) = Just $ read s
checkIntegral (A.HexLiteral _ s) = Nothing -- TODO support hex literals checkIntegral (A.HexLiteral _ s) = Nothing -- TODO support hex literals
@ -207,7 +215,7 @@ transformRangeRep = applyDepthM doExpression
where where
doExpression :: A.Expression -> PassM A.Expression doExpression :: A.Expression -> PassM A.Expression
doExpression (A.ExprConstr _ (A.RangeConstr m t begin end)) doExpression (A.ExprConstr _ (A.RangeConstr m t begin end))
= do A.Specification _ rep _ <- makeNonceVariable "rep_constr" m A.Int A.VariableName A.ValAbbrev = do A.Specification _ rep _ <- makeNonceVariable "rep_constr" m A.Int A.ValAbbrev
let count = addOne $ subExprs end begin let count = addOne $ subExprs end begin
return $ A.ExprConstr m $ A.RepConstr m t return $ A.ExprConstr m $ A.RepConstr m t
(A.For m rep begin count) (A.For m rep begin count)

50
frontends/RainPassesTest.hs
View File

@ -120,7 +120,7 @@ testUnique0 = TestCase $ testPassWithItemsStateCheck "testUnique0" exp (uniquify
= do newcName <- castAssertADI (Map.lookup "newc" items) = do newcName <- castAssertADI (Map.lookup "newc" items)
assertNotEqual "testUnique0: Variable was not made unique" "c" (A.nameName newcName) assertNotEqual "testUnique0: Variable was not made unique" "c" (A.nameName newcName)
assertVarDef "testUnique0: Variable was not recorded" state (A.nameName newcName) assertVarDef "testUnique0: Variable was not recorded" state (A.nameName newcName)
(tag7 A.NameDef DontCare (A.nameName newcName) "c" A.VariableName (A.Declaration m A.Byte) A.Original A.Unplaced) (tag6 A.NameDef DontCare (A.nameName newcName) "c" (A.Declaration m A.Byte) A.Original A.Unplaced)
-- | Tests that two declarations of a variable with the same name are indeed made unique: -- | Tests that two declarations of a variable with the same name are indeed made unique:
testUnique1 :: Test testUnique1 :: Test
@ -137,9 +137,9 @@ testUnique1 = TestCase $ testPassWithItemsStateCheck "testUnique1" exp (uniquify
assertNotEqual "testUnique1: Variable was not made unique" "c" (A.nameName newc1Name) assertNotEqual "testUnique1: Variable was not made unique" "c" (A.nameName newc1Name)
assertNotEqual "testUnique1: Variables were not made unique" (A.nameName newc0Name) (A.nameName newc1Name) assertNotEqual "testUnique1: Variables were not made unique" (A.nameName newc0Name) (A.nameName newc1Name)
assertVarDef "testUnique1: Variable was not recorded" state (A.nameName newc0Name) assertVarDef "testUnique1: Variable was not recorded" state (A.nameName newc0Name)
(tag7 A.NameDef DontCare (A.nameName newc0Name) "c" A.VariableName (A.Declaration m A.Byte ) A.Original A.Unplaced) (tag6 A.NameDef DontCare (A.nameName newc0Name) "c" (A.Declaration m A.Byte ) A.Original A.Unplaced)
assertVarDef "testUnique1: Variable was not recorded" state (A.nameName newc1Name) assertVarDef "testUnique1: Variable was not recorded" state (A.nameName newc1Name)
(tag7 A.NameDef DontCare (A.nameName newc1Name) "c" A.VariableName (A.Declaration m A.Int64 ) A.Original A.Unplaced) (tag6 A.NameDef DontCare (A.nameName newc1Name) "c" (A.Declaration m A.Int64 ) A.Original A.Unplaced)
-- | Tests that the unique pass does resolve the variables that are in scope -- | Tests that the unique pass does resolve the variables that are in scope
testUnique2 :: Test testUnique2 :: Test
@ -173,7 +173,7 @@ testUnique3 = TestCase $ testPassWithItemsStateCheck "testUnique3" exp (uniquify
orig = A.Spec m (A.Specification m (procName "foo") $ A.Proc m A.PlainSpec [] $ A.Skip m) (A.Only m $ A.ProcCall m (procName "foo") []) orig = A.Spec m (A.Specification m (procName "foo") $ A.Proc m A.PlainSpec [] $ A.Skip m) (A.Only m $ A.ProcCall m (procName "foo") [])
exp = orig exp = orig
check (items,state) = assertVarDef "testUnique3: Variable was not recorded" state "foo" check (items,state) = assertVarDef "testUnique3: Variable was not recorded" state "foo"
(tag7 A.NameDef DontCare "foo" "foo" A.ProcName (A.Proc m A.PlainSpec [] $ A.Skip m) A.Original A.Unplaced) (tag6 A.NameDef DontCare "foo" "foo" (A.Proc m A.PlainSpec [] $ A.Skip m) A.Original A.Unplaced)
-- | Tests that parameters are uniquified and resolved: -- | Tests that parameters are uniquified and resolved:
testUnique4 :: Test testUnique4 :: Test
@ -196,9 +196,9 @@ testUnique4 = TestCase $ testPassWithItemsStateCheck "testUnique4" exp (uniquify
= do newcName <- castAssertADI (Map.lookup "newc" items) = do newcName <- castAssertADI (Map.lookup "newc" items)
assertNotEqual "testUnique4: Variable was not made unique" "c" (A.nameName newcName) assertNotEqual "testUnique4: Variable was not made unique" "c" (A.nameName newcName)
assertVarDef "testUnique4: Variable was not recorded" state (A.nameName newcName) assertVarDef "testUnique4: Variable was not recorded" state (A.nameName newcName)
(tag7 A.NameDef DontCare (A.nameName newcName) "c" A.VariableName (A.Declaration m A.Byte ) A.ValAbbrev A.Unplaced) (tag6 A.NameDef DontCare (A.nameName newcName) "c" (A.Declaration m A.Byte ) A.ValAbbrev A.Unplaced)
assertVarDef "testUnique4: Variable was not recorded" state "foo" assertVarDef "testUnique4: Variable was not recorded" state "foo"
(tag7 A.NameDef DontCare "foo" "foo" A.ProcName (tag4 A.Proc DontCare A.PlainSpec (tag6 A.NameDef DontCare "foo" "foo" (tag4 A.Proc DontCare A.PlainSpec
[tag3 A.Formal A.ValAbbrev A.Byte newcName] (bodyPattern newcName)) A.Original A.Unplaced) [tag3 A.Formal A.ValAbbrev A.Byte newcName] (bodyPattern newcName)) A.Original A.Unplaced)
-- TODO check that doing {int : c; { int: c; } } does give an error -- TODO check that doing {int : c; { int: c; } } does give an error
@ -212,8 +212,7 @@ testRecordInfNames0 = TestCase $ testPassWithStateCheck "testRecordInfNames0" ex
orig = (A.Rep m (A.ForEach m (simpleName "c") (makeLiteralStringRain "hello")) skipP) orig = (A.Rep m (A.ForEach m (simpleName "c") (makeLiteralStringRain "hello")) skipP)
exp = orig exp = orig
check state = assertVarDef "testRecordInfNames0" state "c" check state = assertVarDef "testRecordInfNames0" state "c"
(tag7 A.NameDef DontCare "c" "c" A.VariableName (tag7 A.NameDef DontCare "c" "c" A.VariableName (A.Declaration m A.Byte ) A.Abbrev A.Unplaced)
(A.Declaration m $ A.UnknownVarType $ Left $ simpleName "c") A.Abbrev A.Unplaced)
-- | checks that c's type is recorded in: ***each (c : str) {}, where str is known to be of type string -- | checks that c's type is recorded in: ***each (c : str) {}, where str is known to be of type string
testRecordInfNames1 :: Test testRecordInfNames1 :: Test
@ -224,8 +223,7 @@ testRecordInfNames1 = TestCase $ testPassWithStateCheck "testRecordInfNames1" ex
orig = (A.Rep m (A.ForEach m (simpleName "c") (exprVariable "str")) skipP) orig = (A.Rep m (A.ForEach m (simpleName "c") (exprVariable "str")) skipP)
exp = orig exp = orig
check state = assertVarDef "testRecordInfNames1" state "c" check state = assertVarDef "testRecordInfNames1" state "c"
(tag7 A.NameDef DontCare "c" "c" A.VariableName (tag7 A.NameDef DontCare "c" "c" A.VariableName (A.Declaration m A.Byte ) A.Abbrev A.Unplaced)
(A.Declaration m $ A.UnknownVarType $ Left $ simpleName "c") A.Abbrev A.Unplaced)
-- | checks that c's and d's type are recorded in: ***each (c : multi) { seqeach (d : c) {} } where multi is known to be of type [string] -- | checks that c's and d's type are recorded in: ***each (c : multi) { seqeach (d : c) {} } where multi is known to be of type [string]
testRecordInfNames2 :: Test testRecordInfNames2 :: Test
@ -237,13 +235,15 @@ testRecordInfNames2 = TestCase $ testPassWithStateCheck "testRecordInfNames2" ex
A.Only m $ A.Seq m $ A.Rep m (A.ForEach m (simpleName "d") (exprVariable "c")) skipP A.Only m $ A.Seq m $ A.Rep m (A.ForEach m (simpleName "d") (exprVariable "c")) skipP
exp = orig exp = orig
check state = do assertVarDef "testRecordInfNames2" state "c" check state = do assertVarDef "testRecordInfNames2" state "c"
(tag7 A.NameDef DontCare "c" "c" A.VariableName (tag7 A.NameDef DontCare "c" "c" A.VariableName (A.Declaration m (A.List A.Byte) ) A.Abbrev A.Unplaced)
(A.Declaration m $ A.UnknownVarType $ Left $ simpleName
"c") A.Abbrev A.Unplaced)
assertVarDef "testRecordInfNames2" state "d" assertVarDef "testRecordInfNames2" state "d"
(tag7 A.NameDef DontCare "d" "d" A.VariableName (tag7 A.NameDef DontCare "d" "d" A.VariableName (A.Declaration m A.Byte ) A.Abbrev A.Unplaced)
(A.Declaration m $ A.UnknownVarType $ Left $ simpleName
"d") A.Abbrev A.Unplaced) -- | checks that doing a foreach over a non-array type is barred:
testRecordInfNames3 :: Test
testRecordInfNames3 = TestCase $ testPassShouldFail "testRecordInfNames3" (recordInfNameTypes orig) (return ())
where
orig = A.Rep m (A.ForEach m (simpleName "c") (intLiteral 0)) skipP
--Easy way to string two passes together; creates a pass-like function that applies the left-hand pass then the right-hand pass. Associative. --Easy way to string two passes together; creates a pass-like function that applies the left-hand pass then the right-hand pass. Associative.
(>>>) :: Monad m => (a -> m b) -> (b -> m c) -> a -> m c (>>>) :: Monad m => (a -> m b) -> (b -> m c) -> a -> m c
@ -257,35 +257,35 @@ testRecordInfNames2 = TestCase $ testPassWithStateCheck "testRecordInfNames2" ex
testFindMain0 :: Test testFindMain0 :: Test
testFindMain0 = TestCase $ testPassWithItemsStateCheck "testFindMain0" exp ((uniquifyAndResolveVars >>> findMain) orig) (return ()) check testFindMain0 = TestCase $ testPassWithItemsStateCheck "testFindMain0" exp ((uniquifyAndResolveVars >>> findMain) orig) (return ()) check
where where
orig = A.Spec m (A.Specification m (A.Name m A.ProcName "main") $ A.Proc m A.PlainSpec [] (A.Skip m)) $ A.Several m [] :: A.AST orig = A.Spec m (A.Specification m (A.Name m "main") $ A.Proc m A.PlainSpec [] (A.Skip m)) $ A.Several m [] :: A.AST
exp = mSpecAST (tag3 A.Specification DontCare (tag3 A.Name DontCare A.ProcName ("main"@@DontCare)) $ exp = mSpecAST (tag3 A.Specification DontCare (tag2 A.Name DontCare ("main"@@DontCare)) $
tag4 A.Proc DontCare A.PlainSpec ([] :: [A.Formal]) (tag1 A.Skip DontCare)) $ mSeveralAST ([] :: [A.AST]) tag4 A.Proc DontCare A.PlainSpec ([] :: [A.Formal]) (tag1 A.Skip DontCare)) $ mSeveralAST ([] :: [A.AST])
check (items,state) check (items,state)
= do mainName <- castAssertADI (Map.lookup "main" items) = do mainName <- castAssertADI (Map.lookup "main" items)
assertNotEqual "testFindMain0 A" "main" mainName assertNotEqual "testFindMain0 A" "main" mainName
assertEqual "testFindMain0 B" [(mainName,(A.Name m A.ProcName mainName))] (csMainLocals state) assertEqual "testFindMain0 B" [(mainName, (A.Name m mainName, ProcName))] (csMainLocals state)
assertVarDef "testFindMain0 C" state mainName assertVarDef "testFindMain0 C" state mainName
(tag7 A.NameDef DontCare mainName "main" A.ProcName DontCare A.Original A.Unplaced) (tag6 A.NameDef DontCare mainName "main" DontCare A.Original A.Unplaced)
testFindMain1 :: Test testFindMain1 :: Test
testFindMain1 = TestCase $ testPassWithStateCheck "testFindMain1" orig ((uniquifyAndResolveVars >>> findMain) orig) (return ()) check testFindMain1 = TestCase $ testPassWithStateCheck "testFindMain1" orig ((uniquifyAndResolveVars >>> findMain) orig) (return ()) check
where where
orig = A.Spec m (A.Specification m (A.Name m A.ProcName "foo") $ A.Proc m A.PlainSpec [] (A.Skip m)) $ A.Several m ([] :: [A.AST]) orig = A.Spec m (A.Specification m (A.Name m "foo") $ A.Proc m A.PlainSpec [] (A.Skip m)) $ A.Several m ([] :: [A.AST])
check state = assertEqual "testFindMain1" [] (csMainLocals state) check state = assertEqual "testFindMain1" [] (csMainLocals state)
testFindMain2 :: Test testFindMain2 :: Test
testFindMain2 = TestCase $ testPassWithItemsStateCheck "testFindMain2" exp ((uniquifyAndResolveVars >>> findMain) orig) (return ()) check testFindMain2 = TestCase $ testPassWithItemsStateCheck "testFindMain2" exp ((uniquifyAndResolveVars >>> findMain) orig) (return ()) check
where where
inner = A.Spec m (A.Specification m (A.Name m A.ProcName "foo") $ A.Proc m A.PlainSpec [] (A.Skip m)) $ inner = A.Spec m (A.Specification m (A.Name m "foo") $ A.Proc m A.PlainSpec [] (A.Skip m)) $
A.Several m ([] :: [A.AST]) A.Several m ([] :: [A.AST])
orig = A.Spec m (A.Specification m (A.Name m A.ProcName "main") $ A.Proc m A.PlainSpec [] (A.Skip m)) inner orig = A.Spec m (A.Specification m (A.Name m "main") $ A.Proc m A.PlainSpec [] (A.Skip m)) inner
exp = mSpecAST (tag3 A.Specification DontCare (tag3 A.Name DontCare A.ProcName ("main"@@DontCare)) $ exp = mSpecAST (tag3 A.Specification DontCare (tag2 A.Name DontCare ("main"@@DontCare)) $
tag4 A.Proc DontCare A.PlainSpec ([] :: [A.Formal]) (tag1 A.Skip DontCare)) (stopCaringPattern m $ mkPattern inner) tag4 A.Proc DontCare A.PlainSpec ([] :: [A.Formal]) (tag1 A.Skip DontCare)) (stopCaringPattern m $ mkPattern inner)
check (items,state) check (items,state)
= do mainName <- castAssertADI (Map.lookup "main" items) = do mainName <- castAssertADI (Map.lookup "main" items)
assertNotEqual "testFindMain2 A" "main" mainName assertNotEqual "testFindMain2 A" "main" mainName
assertEqual "testFindMain2 B" [(mainName,(A.Name m A.ProcName mainName))] (csMainLocals state) assertEqual "testFindMain2 B" [(mainName, (A.Name m mainName, ProcName))] (csMainLocals state)
testParamPass :: testParamPass ::
String -- ^ The test name String -- ^ The test name

9
frontends/RainTypes.hs
View File

@ -119,8 +119,7 @@ performTypeUnification x
Just t -> do te <- typeToTypeExp (A.ndMeta d) t Just t -> do te <- typeToTypeExp (A.ndMeta d) t
return $ Just (UnifyIndex (A.ndMeta d, Right name), te) return $ Just (UnifyIndex (A.ndMeta d, Right name), te)
where where
name = A.Name {A.nameName = rawName, A.nameMeta = A.ndMeta d, A.nameType name = A.Name {A.nameName = rawName, A.nameMeta = A.ndMeta d}
= A.ndNameType d}
substituteUnknownTypes :: Map.Map UnifyIndex A.Type -> PassType substituteUnknownTypes :: Map.Map UnifyIndex A.Type -> PassType
substituteUnknownTypes mt = applyDepthM sub substituteUnknownTypes mt = applyDepthM sub
@ -142,9 +141,9 @@ recordInfNameTypes = checkDepthM recordInfNameTypes'
where where
recordInfNameTypes' :: Check A.Replicator recordInfNameTypes' :: Check A.Replicator
recordInfNameTypes' input@(A.ForEach m n e) recordInfNameTypes' input@(A.ForEach m n e)
= let innerT = A.UnknownVarType $ Left n in = do let innerT = A.UnknownVarType $ Left n
defineName n A.NameDef {A.ndMeta = m, A.ndName = A.nameName n, A.ndOrigName = A.nameName n, defineName n A.NameDef {A.ndMeta = m, A.ndName = A.nameName n, A.ndOrigName = A.nameName n,
A.ndNameType = A.VariableName, A.ndSpecType = A.Declaration m innerT, A.ndNameType = A.VariableName, A.ndSpecType = (A.Declaration m innerT),
A.ndAbbrevMode = A.Abbrev, A.ndPlacement = A.Unplaced} A.ndAbbrevMode = A.Abbrev, A.ndPlacement = A.Unplaced}
recordInfNameTypes' _ = return () recordInfNameTypes' _ = return ()

12
pass/PassList.hs
View File

@ -73,12 +73,12 @@ nullStateBodies = Pass
,passEnabled = const True} ,passEnabled = const True}
where where
nullProcFuncDefs :: A.NameDef -> A.NameDef nullProcFuncDefs :: A.NameDef -> A.NameDef
nullProcFuncDefs (A.NameDef m n on nt (A.Proc m' sm fs _) am pl) nullProcFuncDefs (A.NameDef m n on (A.Proc m' sm fs _) am pl)
= (A.NameDef m n on nt (A.Proc m' sm fs (A.Skip m')) am pl) = (A.NameDef m n on (A.Proc m' sm fs (A.Skip m')) am pl)
nullProcFuncDefs (A.NameDef m n on nt (A.Function m' sm ts fs (Left _)) am pl) nullProcFuncDefs (A.NameDef m n on (A.Function m' sm ts fs (Left _)) am pl)
= (A.NameDef m n on nt (A.Function m' sm ts fs (Left $ A.Several m' [])) am pl) = (A.NameDef m n on (A.Function m' sm ts fs (Left $ A.Several m' [])) am pl)
nullProcFuncDefs (A.NameDef m n on nt (A.Function m' sm ts fs (Right _)) am pl) nullProcFuncDefs (A.NameDef m n on (A.Function m' sm ts fs (Right _)) am pl)
= (A.NameDef m n on nt (A.Function m' sm ts fs (Right $ A.Skip m')) am pl) = (A.NameDef m n on (A.Function m' sm ts fs (Right $ A.Skip m')) am pl)
nullProcFuncDefs x = x nullProcFuncDefs x = x

30
transformations/PassTest.hs
View File

@ -82,10 +82,10 @@ testFunctionsToProcs0 = TestCase $ testPassWithItemsStateCheck "testFunctionsToP
--check return parameters were defined: --check return parameters were defined:
check (items,state) = do ret0 <- ((assertGetItemCast "ret0" items) :: IO A.Name) check (items,state) = do ret0 <- ((assertGetItemCast "ret0" items) :: IO A.Name)
assertVarDef "testFunctionsToProcs0" state (A.nameName ret0) $ assertVarDef "testFunctionsToProcs0" state (A.nameName ret0) $
tag7 A.NameDef DontCare (A.nameName ret0) (A.nameName ret0) A.VariableName (A.Declaration m A.Int) A.Abbrev A.Unplaced tag6 A.NameDef DontCare (A.nameName ret0) (A.nameName ret0) (A.Declaration m A.Int) A.Abbrev A.Unplaced
--check proc was defined: --check proc was defined:
assertVarDef "testFunctionsToProcs0" state "foo" $ assertVarDef "testFunctionsToProcs0" state "foo" $
tag7 A.NameDef DontCare ("foo") ("foo") A.ProcName procSpec A.Original A.Unplaced tag6 A.NameDef DontCare ("foo") ("foo") procSpec A.Original A.Unplaced
--check csFunctionReturns was changed: --check csFunctionReturns was changed:
assertEqual "testFunctionsToProcs0" (Just [A.Int]) (Map.lookup "foo" (csFunctionReturns state)) assertEqual "testFunctionsToProcs0" (Just [A.Int]) (Map.lookup "foo" (csFunctionReturns state))
@ -108,12 +108,12 @@ testFunctionsToProcs1 = TestCase $ testPassWithItemsStateCheck "testFunctionsToP
check (items,state) = do ret0 <- ((assertGetItemCast "ret0" items) :: IO A.Name) check (items,state) = do ret0 <- ((assertGetItemCast "ret0" items) :: IO A.Name)
ret1 <- ((assertGetItemCast "ret1" items) :: IO A.Name) ret1 <- ((assertGetItemCast "ret1" items) :: IO A.Name)
assertVarDef "testFunctionsToProcs1 B" state (A.nameName ret0) $ assertVarDef "testFunctionsToProcs1 B" state (A.nameName ret0) $
tag7 A.NameDef DontCare (A.nameName ret0) (A.nameName ret0) A.VariableName (A.Declaration m A.Int) A.Abbrev A.Unplaced tag6 A.NameDef DontCare (A.nameName ret0) (A.nameName ret0) (A.Declaration m A.Int) A.Abbrev A.Unplaced
assertVarDef "testFunctionsToProcs1 C" state (A.nameName ret1) $ assertVarDef "testFunctionsToProcs1 C" state (A.nameName ret1) $
tag7 A.NameDef DontCare (A.nameName ret1) (A.nameName ret1) A.VariableName (A.Declaration m A.Real32) A.Abbrev A.Unplaced tag6 A.NameDef DontCare (A.nameName ret1) (A.nameName ret1) (A.Declaration m A.Real32) A.Abbrev A.Unplaced
--check proc was defined: --check proc was defined:
assertVarDef "testFunctionsToProcs1 D" state "foo" $ assertVarDef "testFunctionsToProcs1 D" state "foo" $
tag7 A.NameDef DontCare ("foo") ("foo") A.ProcName procBody A.Original A.Unplaced tag6 A.NameDef DontCare ("foo") ("foo") procBody A.Original A.Unplaced
--check csFunctionReturns was changed: --check csFunctionReturns was changed:
assertEqual "testFunctionsToProcs1 E" (Just [A.Int,A.Real32]) (Map.lookup "foo" (csFunctionReturns state)) assertEqual "testFunctionsToProcs1 E" (Just [A.Int,A.Real32]) (Map.lookup "foo" (csFunctionReturns state))
@ -138,14 +138,14 @@ testFunctionsToProcs2 = TestCase $ testPassWithItemsStateCheck "testFunctionsToP
check (items,state) = do retOuter0 <- ((assertGetItemCast "retOuter0" items) :: IO A.Name) check (items,state) = do retOuter0 <- ((assertGetItemCast "retOuter0" items) :: IO A.Name)
ret0 <- ((assertGetItemCast "ret0" items) :: IO A.Name) ret0 <- ((assertGetItemCast "ret0" items) :: IO A.Name)
assertVarDef "testFunctionsToProcs2 B" state (A.nameName ret0) $ assertVarDef "testFunctionsToProcs2 B" state (A.nameName ret0) $
tag7 A.NameDef DontCare (A.nameName ret0) (A.nameName ret0) A.VariableName (A.Declaration m A.Int) A.Abbrev A.Unplaced tag6 A.NameDef DontCare (A.nameName ret0) (A.nameName ret0) (A.Declaration m A.Int) A.Abbrev A.Unplaced
assertVarDef "testFunctionsToProcs2 C" state (A.nameName retOuter0) $ assertVarDef "testFunctionsToProcs2 C" state (A.nameName retOuter0) $
tag7 A.NameDef DontCare (A.nameName retOuter0) (A.nameName retOuter0) A.VariableName (A.Declaration m A.Int) A.Abbrev A.Unplaced tag6 A.NameDef DontCare (A.nameName retOuter0) (A.nameName retOuter0) (A.Declaration m A.Int) A.Abbrev A.Unplaced
--check proc was defined: --check proc was defined:
assertVarDef "testFunctionsToProcs2 D" state "foo" $ assertVarDef "testFunctionsToProcs2 D" state "foo" $
tag7 A.NameDef DontCare ("foo") ("foo") A.ProcName (singleParamSpecExp DontCare) A.Original A.Unplaced tag6 A.NameDef DontCare ("foo") ("foo") (singleParamSpecExp DontCare) A.Original A.Unplaced
assertVarDef "testFunctionsToProcs2 E" state "fooOuter" $ assertVarDef "testFunctionsToProcs2 E" state "fooOuter" $
tag7 A.NameDef DontCare ("fooOuter") ("fooOuter") A.ProcName (procHeader DontCare) A.Original A.Unplaced tag6 A.NameDef DontCare ("fooOuter") ("fooOuter") (procHeader DontCare) A.Original A.Unplaced
--check csFunctionReturns was changed: --check csFunctionReturns was changed:
assertEqual "testFunctionsToProcs2 F" (Just [A.Int]) (Map.lookup "foo" (csFunctionReturns state)) assertEqual "testFunctionsToProcs2 F" (Just [A.Int]) (Map.lookup "foo" (csFunctionReturns state))
assertEqual "testFunctionsToProcs2 G" (Just [A.Int]) (Map.lookup "fooOuter" (csFunctionReturns state)) assertEqual "testFunctionsToProcs2 G" (Just [A.Int]) (Map.lookup "fooOuter" (csFunctionReturns state))
@ -160,10 +160,10 @@ testFunctionsToProcs3 = TestCase $ testPassWithItemsStateCheck "testFunctionsToP
--check return parameters were defined: --check return parameters were defined:
check (items,state) = do ret0 <- ((assertGetItemCast "ret0" items) :: IO A.Name) check (items,state) = do ret0 <- ((assertGetItemCast "ret0" items) :: IO A.Name)
assertVarDef "testFunctionsToProcs3" state (A.nameName ret0) $ assertVarDef "testFunctionsToProcs3" state (A.nameName ret0) $
tag7 A.NameDef DontCare (A.nameName ret0) (A.nameName ret0) A.VariableName (A.Declaration m A.Int) A.Abbrev A.Unplaced tag6 A.NameDef DontCare (A.nameName ret0) (A.nameName ret0) (A.Declaration m A.Int) A.Abbrev A.Unplaced
--check proc was defined: --check proc was defined:
assertVarDef "testFunctionsToProcs3" state "foo" $ assertVarDef "testFunctionsToProcs3" state "foo" $
tag7 A.NameDef DontCare ("foo") ("foo") A.ProcName procSpec A.Original A.Unplaced tag6 A.NameDef DontCare ("foo") ("foo") procSpec A.Original A.Unplaced
--check csFunctionReturns was changed: --check csFunctionReturns was changed:
assertEqual "testFunctionsToProcs3" (Just [A.Int]) (Map.lookup "foo" (csFunctionReturns state)) assertEqual "testFunctionsToProcs3" (Just [A.Int]) (Map.lookup "foo" (csFunctionReturns state))
@ -187,12 +187,12 @@ testFunctionsToProcs4 = TestCase $ testPassWithItemsStateCheck "testFunctionsToP
check (items,state) = do ret0 <- ((assertGetItemCast "ret0" items) :: IO A.Name) check (items,state) = do ret0 <- ((assertGetItemCast "ret0" items) :: IO A.Name)
ret1 <- ((assertGetItemCast "ret1" items) :: IO A.Name) ret1 <- ((assertGetItemCast "ret1" items) :: IO A.Name)
assertVarDef "testFunctionsToProcs4 B" state (A.nameName ret0) $ assertVarDef "testFunctionsToProcs4 B" state (A.nameName ret0) $
tag7 A.NameDef DontCare (A.nameName ret0) (A.nameName ret0) A.VariableName (A.Declaration m A.Int) A.Abbrev A.Unplaced tag6 A.NameDef DontCare (A.nameName ret0) (A.nameName ret0) (A.Declaration m A.Int) A.Abbrev A.Unplaced
assertVarDef "testFunctionsToProcs4 C" state (A.nameName ret1) $ assertVarDef "testFunctionsToProcs4 C" state (A.nameName ret1) $
tag7 A.NameDef DontCare (A.nameName ret1) (A.nameName ret1) A.VariableName (A.Declaration m A.Real32) A.Abbrev A.Unplaced tag6 A.NameDef DontCare (A.nameName ret1) (A.nameName ret1) (A.Declaration m A.Real32) A.Abbrev A.Unplaced
--check proc was defined: --check proc was defined:
assertVarDef "testFunctionsToProcs4 D" state "foo" $ assertVarDef "testFunctionsToProcs4 D" state "foo" $
tag7 A.NameDef DontCare ("foo") ("foo") A.ProcName procBody A.Original A.Unplaced tag6 A.NameDef DontCare ("foo") ("foo") procBody A.Original A.Unplaced
--check csFunctionReturns was changed: --check csFunctionReturns was changed:
assertEqual "testFunctionsToProcs4 E" (Just [A.Int,A.Real32]) (Map.lookup "foo" (csFunctionReturns state)) assertEqual "testFunctionsToProcs4 E" (Just [A.Int,A.Real32]) (Map.lookup "foo" (csFunctionReturns state))
@ -515,7 +515,7 @@ testInputCase = TestList
b2 = simpleName "b2" b2 = simpleName "b2"
c1 = simpleName "c1" c1 = simpleName "c1"
defineMyProtocol :: CSM m => m () defineMyProtocol :: CSM m => m ()
defineMyProtocol = defineName (simpleName "prot") $ A.NameDef emptyMeta "prot" "prot" A.ProtocolName defineMyProtocol = defineName (simpleName "prot") $ A.NameDef emptyMeta "prot" "prot"
(A.ProtocolCase emptyMeta [(a0,[]),(b2,[A.Int,A.Int]),(c1,[A.Int])]) (A.ProtocolCase emptyMeta [(a0,[]),(b2,[A.Int,A.Int]),(c1,[A.Int])])
A.Original A.Unplaced A.Original A.Unplaced
defineC :: CSM m => m () defineC :: CSM m => m ()

6
transformations/SimplifyComms.hs
View File

@ -67,7 +67,7 @@ outExprs = applyDepthM doProcess
abbrevExpr :: Meta -> A.Expression -> PassM (A.Name, A.Structured A.Process -> A.Structured A.Process) abbrevExpr :: Meta -> A.Expression -> PassM (A.Name, A.Structured A.Process -> A.Structured A.Process)
abbrevExpr m e = do t <- astTypeOf e abbrevExpr m e = do t <- astTypeOf e
specification@(A.Specification _ nm _) <- defineNonce m "output_var" (A.IsExpr m A.ValAbbrev t e) A.VariableName A.ValAbbrev specification@(A.Specification _ nm _) <- defineNonce m "output_var" (A.IsExpr m A.ValAbbrev t e) A.ValAbbrev
return (nm, A.Spec m specification) return (nm, A.Spec m specification)
{- The explanation for this pass is taken from my (Neil's) mailing list post "Case protocols" on tock-discuss, dated 10th October 2007: {- The explanation for this pass is taken from my (Neil's) mailing list post "Case protocols" on tock-discuss, dated 10th October 2007:
@ -135,7 +135,7 @@ transformInputCase = applyDepthM doProcess
where where
doProcess :: A.Process -> PassM A.Process doProcess :: A.Process -> PassM A.Process
doProcess (A.Input m v (A.InputCase m' s)) doProcess (A.Input m v (A.InputCase m' s))
= do spec@(A.Specification _ n _) <- defineNonce m "input_tag" (A.Declaration m' A.Int) A.VariableName A.Original = do spec@(A.Specification _ n _) <- defineNonce m "input_tag" (A.Declaration m' A.Int) A.Original
s' <- doStructuredV v s s' <- doStructuredV v s
return $ A.Seq m $ A.Spec m' spec $ A.Several m' return $ A.Seq m $ A.Spec m' spec $ A.Several m'
[A.Only m $ A.Input m v (A.InputSimple m [A.InVariable m (A.Variable m n)]) [A.Only m $ A.Input m v (A.InputSimple m [A.InVariable m (A.Variable m n)])
@ -166,7 +166,7 @@ transformInputCase = applyDepthM doProcess
-- The processes that are the body of input-case guards are always -- The processes that are the body of input-case guards are always
-- skip, so we can discard them. -- skip, so we can discard them.
doAlternative m (A.Alternative m' e v (A.InputCase m'' s) _) doAlternative m (A.Alternative m' e v (A.InputCase m'' s) _)
= do spec@(A.Specification _ n _) <- defineNonce m "input_tag" (A.Declaration m' A.Int) A.VariableName A.Original = do spec@(A.Specification _ n _) <- defineNonce m "input_tag" (A.Declaration m' A.Int) A.Original
s' <- doStructuredV v s s' <- doStructuredV v s
return $ A.Spec m' spec $ A.Only m $ return $ A.Spec m' spec $ A.Only m $
A.Alternative m' e v (A.InputSimple m [A.InVariable m (A.Variable m n)]) $ A.Alternative m' e v (A.InputSimple m [A.InVariable m (A.Variable m n)]) $

7
transformations/SimplifyExprs.hs
View File

@ -55,7 +55,7 @@ functionsToProcs = applyDepthM doSpecification
doSpecification :: A.Specification -> PassM A.Specification doSpecification :: A.Specification -> PassM A.Specification
doSpecification (A.Specification m n (A.Function mf sm rts fs evp)) doSpecification (A.Specification m n (A.Function mf sm rts fs evp))
= do -- Create new names for the return values. = do -- Create new names for the return values.
specs <- sequence [makeNonceVariable "return_formal" mf t A.VariableName A.Abbrev | t <- rts] specs <- sequence [makeNonceVariable "return_formal" mf t A.Abbrev | t <- rts]
let names = [n | A.Specification mf n _ <- specs] let names = [n | A.Specification mf n _ <- specs]
-- Note the return types so we can fix calls later. -- Note the return types so we can fix calls later.
modify $ (\ps -> ps { csFunctionReturns = Map.insert (A.nameName n) rts (csFunctionReturns ps) }) modify $ (\ps -> ps { csFunctionReturns = Map.insert (A.nameName n) rts (csFunctionReturns ps) })
@ -68,7 +68,6 @@ functionsToProcs = applyDepthM doSpecification
A.ndMeta = mf, A.ndMeta = mf,
A.ndName = A.nameName n, A.ndName = A.nameName n,
A.ndOrigName = A.nameName n, A.ndOrigName = A.nameName n,
A.ndNameType = A.ProcName,
A.ndSpecType = st, A.ndSpecType = st,
A.ndAbbrevMode = A.Original, A.ndAbbrevMode = A.Original,
A.ndPlacement = A.Unplaced A.ndPlacement = A.Unplaced
@ -202,7 +201,7 @@ transformConstr = applyDepthSM doStructured
doStructured (A.Spec m (A.Specification m' n (A.IsExpr _ _ _ expr@(A.ExprConstr m'' (A.RepConstr _ t rep exp)))) scope) doStructured (A.Spec m (A.Specification m' n (A.IsExpr _ _ _ expr@(A.ExprConstr m'' (A.RepConstr _ t rep exp)))) scope)
= do case t of = do case t of
A.Array {} -> A.Array {} ->
do indexVarSpec@(A.Specification _ indexName _) <- makeNonceVariable "array_constr_index" m'' A.Int A.VariableName A.Original do indexVarSpec@(A.Specification _ indexName _) <- makeNonceVariable "array_constr_index" m'' A.Int A.Original
let indexVar = A.Variable m'' indexName let indexVar = A.Variable m'' indexName
return $ declDest $ A.ProcThen m'' return $ declDest $ A.ProcThen m''
@ -367,7 +366,7 @@ pullUp pullUpArraysInsideRecords = recurse
ps <- get ps <- get
rts <- Map.lookup (A.nameName n) (csFunctionReturns ps) rts <- Map.lookup (A.nameName n) (csFunctionReturns ps)
specs <- sequence [makeNonceVariable "return_actual" m t A.VariableName A.Original | t <- rts] specs <- sequence [makeNonceVariable "return_actual" m t A.Original | t <- rts]
sequence_ [addPulled $ (m, Left spec) | spec <- specs] sequence_ [addPulled $ (m, Left spec) | spec <- specs]
let names = [n | A.Specification _ n _ <- specs] let names = [n | A.Specification _ n _ <- specs]

6
transformations/SimplifyProcs.hs
View File

@ -64,7 +64,7 @@ removeParAssign = applyDepthM doProcess
doProcess :: A.Process -> PassM A.Process doProcess :: A.Process -> PassM A.Process
doProcess (A.Assign m vs@(_:_:_) (A.ExpressionList _ es)) doProcess (A.Assign m vs@(_:_:_) (A.ExpressionList _ es))
= do ts <- mapM astTypeOf vs = do ts <- mapM astTypeOf vs
specs <- sequence [makeNonceVariable "assign_temp" m t A.VariableName A.Original | t <- ts] specs <- sequence [makeNonceVariable "assign_temp" m t A.Original | t <- ts]
let temps = [A.Variable m n | A.Specification _ n _ <- specs] 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] let first = [A.Assign m [v] (A.ExpressionList m [e]) | (v, e) <- zip temps es]
let second = [A.Assign m [v] (A.ExpressionList m [A.ExprVariable m v']) | (v, v') <- zip vs temps] let second = [A.Assign m [v] (A.ExpressionList m [A.ExprVariable m v']) | (v, v') <- zip vs temps]
@ -136,9 +136,9 @@ flattenAssign = makeRecurse ops
-- Record assignments become a sequence of -- Record assignments become a sequence of
-- assignments, one for each field. -- assignments, one for each field.
= do let t = A.Record n = do let t = A.Record n
(A.Specification _ nonceLHS _) <- makeNonceVariable "record_copy_arg" m t A.VariableName A.Abbrev (A.Specification _ nonceLHS _) <- makeNonceVariable "record_copy_arg" m t A.Abbrev
let destV = A.Variable m nonceLHS let destV = A.Variable m nonceLHS
(A.Specification _ nonceRHS _) <- makeNonceVariable "record_copy_arg" m t A.VariableName A.Abbrev (A.Specification _ nonceRHS _) <- makeNonceVariable "record_copy_arg" m t A.Abbrev
let srcV = A.Variable m nonceRHS let srcV = A.Variable m nonceRHS
assigns <- assigns <-
sequence [do let sub = A.SubscriptField m fName sequence [do let sub = A.SubscriptField m fName

41
transformations/Unnest.hs
View File

@ -107,20 +107,13 @@ removeFreeNames = applyDepthM2 doSpecification doProcess
-- that it had in scope originally will still be in scope. -- that it had in scope originally will still be in scope.
ps <- get ps <- get
when (null $ csMainLocals ps) (dieReport (Nothing,"No main process found")) when (null $ csMainLocals ps) (dieReport (Nothing,"No main process found"))
let isTLP = (snd $ head $ csMainLocals ps) == n let isTLP = (fst $ snd $ head $ csMainLocals ps) == n
-- Figure out the free names. -- Figure out the free names.
let freeNames' = if isTLP then [] else Map.elems $ freeNamesIn st freeNames <- if isTLP
let freeNames'' = [n | n <- freeNames', then return []
case A.nameType n of else filterM isFreeName
A.ChannelName -> True (Map.elems $ freeNamesIn st)
A.PortName -> True
A.TimerName -> True
A.VariableName -> True
_ -> False]
-- Don't bother with constants -- they get pulled up anyway.
freeNames <- filterM (liftM not . isConstantName) freeNames''
types <- mapM astTypeOf freeNames types <- mapM astTypeOf freeNames
origAMs <- mapM abbrevModeOfName freeNames origAMs <- mapM abbrevModeOfName freeNames
let ams = map makeAbbrevAM origAMs let ams = map makeAbbrevAM origAMs
@ -155,6 +148,30 @@ removeFreeNames = applyDepthM2 doSpecification doProcess
return spec' return spec'
_ -> return spec _ -> return spec
-- | Return whether a 'Name' could be considered a free name.
--
-- Unscoped names aren't.
-- Things like data types and PROCs aren't, because they'll be the same
-- for all instances of a PROC.
-- Constants aren't, because they'll be pulled up anyway.
isFreeName :: A.Name -> PassM Bool
isFreeName n
= do st <- specTypeOfName n
isConst <- isConstantName n
return $ isFreeST st && not isConst
where
isFreeST :: A.SpecType -> Bool
isFreeST st
= case st of
-- Declaration also covers PROC formals.
A.Declaration {} -> True
A.Is {} -> True
A.IsExpr {} -> True
A.IsChannelArray {} -> True
A.Retypes {} -> True
A.RetypesExpr {} -> True
_ -> False
-- | Add the extra arguments we recorded when we saw the definition. -- | Add the extra arguments we recorded when we saw the definition.
doProcess :: A.Process -> PassM A.Process doProcess :: A.Process -> PassM A.Process
doProcess p@(A.ProcCall m n as) doProcess p@(A.ProcCall m n as)