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)
= do (specs, init) <- get
id <- lift $ makeNonce "waitFor"
let n = (A.Name m A.VariableName id)
let n = A.Name m id
let var = A.Variable m n
put (specs ++ [A.Spec m (A.Specification m n (A.Declaration m A.Time))],
init ++ [A.Only m $ A.Input m tim
@ -87,7 +87,6 @@ declareSizesArray = applyDepthSM doStructured
= defineName n $ A.NameDef { A.ndMeta = m
, A.ndName = A.nameName n
, A.ndOrigName = A.nameName n
, A.ndNameType = A.VariableName
, A.ndSpecType = spec
, A.ndAbbrevMode = A.ValAbbrev
, A.ndPlacement = A.Unplaced
@ -157,7 +156,7 @@ declareSizesArray = applyDepthSM doStructured
A.Variable _ srcN -> return (A.Variable m $ append_sizes srcN)
A.SubscriptedVariable _ (A.SubscriptField _ fieldName) 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:
(A.Array srcDs _) <- astTypeOf innerV
-- 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.ndName = A.nameName n
,A.ndOrigName = A.nameName n
,A.ndNameType = A.VariableName
,A.ndSpecType = A.Declaration m t
,A.ndAbbrevMode = A.ValAbbrev
,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.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
evar = tag2 A.ExprVariable DontCare var
@ -100,10 +100,10 @@ testTransformWaitFor2 = TestCase $ testPass "testTransformWaitFor2" exp (transfo
[mOnlyA $ mWaitUntil evar0 (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
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
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"))]
,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
evar = tag2 A.ExprVariable DontCare var
@ -137,7 +137,7 @@ testTransformWaitFor4 = TestCase $ testPass "testTransformWaitFor4" exp (transfo
,mOnlyP $ tag3 A.Alt DontCare True $ mSeveralA
[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
evar = tag2 A.ExprVariable DontCare var
@ -159,10 +159,10 @@ testTransformWaitFor5 = TestCase $ testPass "testTransformWaitFor5" exp (transfo
[mOnlyA $ mWaitUntil evar0 (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
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
evar1 = tag2 A.ExprVariable DontCare var1
@ -325,7 +325,6 @@ defineTestName n sp am
A.ndMeta = emptyMeta
,A.ndName = n
,A.ndOrigName = n
,A.ndNameType = A.VariableName
,A.ndSpecType = sp
,A.ndAbbrevMode = am
,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 m var func
= 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 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}
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 = TestList
@ -825,7 +825,7 @@ testGenVariable = TestList
,testBothS ("testGenVariable/unchecked" ++ show n) eUC eUCPP (over (tcall genVariableUnchecked $ sub $ A.Variable emptyMeta foo)) state
]
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 "barbar" "y" $ A.Record bar
over :: Override

23
backends/TLP.hs
View File

@ -29,23 +29,28 @@ import CompState
import Errors
import Metadata
import Types
import Utils
data TLPChannel = TLPIn | TLPOut | TLPError
deriving (Show, Eq, Typeable, Data)
-- | Get the name of the TLP and the channels it uses.
-- 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
= do ps <- getCompState
when (null $ csMainLocals ps) (dieReport (Nothing,"No main process found"))
let mainName = snd $ head $ csMainLocals ps
= do mainLocals <- getCompState >>* csMainLocals
when (null mainLocals) $
dieReport (Nothing, "No main process found")
let (_, (mainName, _)) = head mainLocals
st <- specTypeOfName mainName
(m,formals) <- case st of
A.Proc m _ fs _ -> return (m,fs)
_ -> dieP (findMeta mainName) "Last definition is not a PROC"
(m, formals) <-
case st of
A.Proc m _ fs _ -> return (m, fs)
_ -> dieP (findMeta mainName) "Last definition is not a PROC"
chans <- mapM (tlpChannel m) formals
when ((nub (map snd chans)) /= (map snd chans)) $ dieP (findMeta mainName) "Channels used more than once in TLP"
let chanIds = map snd chans
when (nub chanIds /= chanIds) $
dieP (findMeta mainName) "Channels used more than once in TLP"
return (mainName, chans)
where
tlpChannel :: (CSMR m, Die m) => Meta -> A.Formal -> m (A.Direction, TLPChannel)
@ -55,7 +60,7 @@ tlpInterface
case lookup origN tlpChanNames of
Just 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"
_ -> dieP m $ "TLP formal " ++ show n ++ " has unrecognised name"
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
checkIndexes :: Meta -> (String,ParItems ([A.Expression],[A.Expression])) -> m ()
checkIndexes m (arrName, indexes)
= do userArrName <- getRealName (A.Name undefined undefined arrName)
arrType <- astTypeOf (A.Name undefined undefined arrName)
= do userArrName <- getRealName (A.Name undefined arrName)
arrType <- astTypeOf (A.Name undefined arrName)
arrLength <- case arrType of
A.Array (A.Dimension d:_) _ -> return d
-- 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 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 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 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 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 s = A.Name { A.nameName = s , A.nameMeta = emptyMeta , A.nameType = A.FunctionName }
funcName = simpleName
-- | Creates a 'Pattern' to match a 'A.Name' instance.
-- @'assertPatternMatch' ('simpleNamePattern' x) ('simpleName' x)@ will always succeed.
-- All meta tags are ignored.
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.
-- @'assertPatternMatch' ('procNamePattern' x) ('procName' x)@ will always succeed.
-- All meta tags are ignored.
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.
variable :: String -> A.Variable
@ -284,12 +284,11 @@ buildExpr (Lit e) = e
buildExpr EHTrue = A.True emptyMeta
buildExpr (Range t begin end) = A.ExprConstr emptyMeta $ A.RangeConstr emptyMeta t
(buildExpr begin) (buildExpr end)
buildExpr (Func f es) = A.FunctionCall emptyMeta ((simpleName f) {A.nameType
= A.FunctionName}) (map buildExpr es)
buildExpr (Func f es) = A.FunctionCall emptyMeta (simpleName f) (map buildExpr es)
-- | A simple definition of a variable
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 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
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
-- | Define something in the initial state.
defineThing :: String -> A.NameType -> A.SpecType -> A.AbbrevMode
defineThing :: String -> A.SpecType -> A.AbbrevMode
-> State CompState ()
defineThing s nt st am = defineName (simpleName s) $
defineThing s st am = defineName (simpleName s) $
A.NameDef {
A.ndMeta = emptyMeta,
A.ndName = s,
A.ndOrigName = s,
A.ndNameType = nt,
A.ndSpecType = st,
A.ndAbbrevMode = am,
A.ndPlacement = A.Unplaced
@ -320,39 +318,41 @@ defineThing s nt st am = defineName (simpleName s) $
-- | Define a @VAL IS@ constant.
defineConst :: String -> A.Type -> A.Expression -> State CompState ()
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
-- | Define an @IS@ abbreviation.
defineIs :: String -> A.Type -> A.Variable -> State CompState ()
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.
defineVariable :: String -> A.Type -> State CompState ()
defineVariable s t
= defineThing s A.VariableName (A.Declaration emptyMeta t) A.Original
defineVariable = defineOriginal
-- | Define a channel.
defineChannel :: String -> A.Type -> State CompState ()
defineChannel s t
= defineThing s A.ChannelName (A.Declaration emptyMeta t) A.Original
defineChannel = defineOriginal
-- | Define a timer.
defineTimer :: String -> A.Type -> State CompState ()
defineTimer s t
= defineThing s A.TimerName (A.Declaration emptyMeta t) A.Original
defineTimer = defineOriginal
-- | Define a user data type.
defineUserDataType :: String -> A.Type -> State CompState ()
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.
-- (The fields are unscoped names, and thus don't need defining.)
defineRecordType :: String -> [(String, A.Type)] -> State CompState ()
defineRecordType s fs
= defineThing s A.RecordName st A.Original
= defineThing s st A.Original
where
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)]
-> State CompState ()
defineFunction s rs as
= defineThing s A.FunctionName st A.Original
= defineThing s st A.Original
where
st = A.Function emptyMeta A.PlainSpec rs fs (Right $ A.Skip emptyMeta)
fs = [A.Formal A.ValAbbrev t (simpleName s) | (s, t) <- as]
@ -368,7 +368,7 @@ defineFunction s rs as
-- | Define a proc.
defineProc :: String -> [(String, A.AbbrevMode, A.Type)] -> State CompState ()
defineProc s as
= defineThing s A.ProcName st A.Original
= defineThing s st A.Original
where
st = A.Proc emptyMeta A.PlainSpec fs $ A.Skip emptyMeta
fs = [A.Formal am t (simpleName s) | (s, am, t) <- as]
@ -376,12 +376,12 @@ defineProc s as
-- | Define a protocol.
defineProtocol :: String -> [A.Type] -> State CompState ()
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.
defineProtocolCase :: String -> [(A.Name, [A.Type])] -> State CompState ()
defineProtocolCase s ntss
= defineThing s A.ProtocolName (A.ProtocolCase emptyMeta ntss) A.Original
= defineThing s (A.ProtocolCase emptyMeta ntss) A.Original
--}}}
--{{{ custom assertions
@ -437,7 +437,7 @@ checkTempVarTypes testName vars is = mapM_ (checkTempVarType testName is) vars
where
checkTempVarType :: String -> (Items, CompState) -> (String, A.Type) -> Assertion
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
Nothing -> assertFailure (testName ++ ": item with key \"" ++ key ++ "\" was not recorded in the state")
Just nd -> evalStateT (

19
data/AST.hs
View File

@ -30,22 +30,10 @@ import Data.Generics
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.
-- This can be any of the 'NameType' types.
data Name = Name {
-- | Metadata.
nameMeta :: Meta,
-- | The general type of the name.
nameType :: NameType,
-- | The internal version of the name.
-- 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
@ -62,15 +50,13 @@ instance Eq Name where
-- | The definition of a name.
data NameDef = NameDef {
-- | Metadata.
-- | Metadata for where the name was originally defined.
ndMeta :: Meta,
-- | The internal version of the name.
ndName :: String,
-- | The name as it appeared in the source code.
-- This can be used for error reporting.
ndOrigName :: String,
-- | The general type of the name.
ndNameType :: NameType,
-- | The specification type of the name's definition (see 'SpecType').
ndSpecType :: SpecType,
-- | The abbreviation mode of the name's definition (see 'AbbrevMode').
@ -510,6 +496,9 @@ data SpecType =
| Retypes Meta AbbrevMode Type Variable
-- | Declare a retyping abbreviation of an 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)
-- | Specification mode for @PROC@s and @FUNCTION@s.

51
data/CompState.hs
View File

@ -55,6 +55,15 @@ data PreprocDef =
| PreprocString String
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.
type PulledItem = (Meta, Either A.Specification A.Process) -- Either Spec or ProcThen
@ -98,8 +107,8 @@ data CompState = CompState {
csDefinitions :: Map String PreprocDef,
-- Set by Parse
csLocalNames :: [(String, A.Name)],
csMainLocals :: [(String, A.Name)],
csLocalNames :: [(String, (A.Name, NameType))],
csMainLocals :: [(String, (A.Name, NameType))],
csNames :: Map String A.NameDef,
csUnscopedNames :: Map String String,
csNameCounter :: Int,
@ -220,14 +229,23 @@ makeUniqueName s
-- | Find an unscoped name -- or define a new one if it doesn't already exist.
findUnscopedName :: CSM m => A.Name -> m A.Name
findUnscopedName n@(A.Name m nt s)
findUnscopedName n@(A.Name m s)
= do st <- get
case Map.lookup s (csUnscopedNames st) of
Just s' -> return $ A.Name m nt s'
Just s' -> return $ A.Name m s'
Nothing ->
do s' <- makeUniqueName s
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
@ -297,15 +315,14 @@ makeNonce s
return $ s ++ "_n" ++ show i
-- | Generate and define a nonce specification.
defineNonce :: CSM m => Meta -> String -> A.SpecType -> A.NameType -> A.AbbrevMode -> m A.Specification
defineNonce m s st nt am
defineNonce :: CSM m => Meta -> String -> A.SpecType -> A.AbbrevMode -> m A.Specification
defineNonce m s st am
= do ns <- makeNonce s
let n = A.Name m nt ns
let n = A.Name m ns
let nd = A.NameDef {
A.ndMeta = m,
A.ndName = ns,
A.ndOrigName = ns,
A.ndNameType = nt,
A.ndSpecType = st,
A.ndAbbrevMode = am,
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.
makeNonceProc :: CSM m => Meta -> A.Process -> m A.Specification
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.
makeNonceCounter :: CSM m => String -> Meta -> m A.Name
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
-- | Generate and define a variable abbreviation.
makeNonceIs :: CSM m => String -> Meta -> A.Type -> A.AbbrevMode -> A.Variable -> m A.Specification
makeNonceIs s m t am v
= defineNonce m s (A.Is m am t v) A.VariableName am
= defineNonce m s (A.Is m am t v) am
-- | Generate and define an expression abbreviation.
makeNonceIsExpr :: CSM m => String -> Meta -> A.Type -> A.Expression -> m A.Specification
makeNonceIsExpr s m t e
= defineNonce m s (A.IsExpr m A.ValAbbrev t e) A.VariableName A.ValAbbrev
= defineNonce m s (A.IsExpr m A.ValAbbrev t e) A.ValAbbrev
-- | Generate and define a variable.
makeNonceVariable :: CSM m => String -> Meta -> A.Type -> A.NameType -> A.AbbrevMode -> m A.Specification
makeNonceVariable s m t nt am
= defineNonce m s (A.Declaration m t) nt am
makeNonceVariable :: CSM m => String -> Meta -> A.Type -> A.AbbrevMode -> m A.Specification
makeNonceVariable s m t am
= defineNonce m s (A.Declaration m t) am
--}}}
diePC :: (CSMR m, Die m) => Meta -> m String -> m a
@ -376,4 +393,4 @@ getUniqueIdentifer :: CSM m => m Int
getUniqueIdentifer = do st <- get
let n = csUnifyId st
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) ->
do when (length rs /= 1) $
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]
checkActuals m (A.Name m A.ProcName n)
checkActuals m (A.Name m n)
fs (map A.ActualExpression es)
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.
nameToUnscoped :: A.Name -> PassM A.Name
nameToUnscoped n@(A.Name m nt _)
nameToUnscoped n@(A.Name m _)
= 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
-- 'Infer', and returning the type it really is.
@ -1203,9 +1203,9 @@ checkProcesses = checkDepthM doProcess
doProcess (A.IntrinsicProcCall m n as)
= case lookup n intrinsicProcs of
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]
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"
doAlternative :: Check A.Alternative

238
frontends/ParseOccam.hs
View File

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

13
frontends/ParseRain.hs
View File

@ -149,7 +149,7 @@ reserved word
name :: RainParser A.Name
name
= 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"
@ -170,7 +170,7 @@ dataType
<|> 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 {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"
variable :: RainParser A.Variable
@ -313,8 +313,7 @@ functionCall = do funcName <- name
Just _ -> return $ A.IntrinsicFunctionCall (A.nameMeta
funcName) (A.nameName funcName) es
Nothing -> return $
A.FunctionCall (A.nameMeta funcName)
(funcName {A.nameType = A.FunctionName}) es
A.FunctionCall (A.nameMeta funcName) funcName es
data InnerBlockLineState = Decls | NoMoreDecls | Mixed deriving (Eq)
@ -427,7 +426,7 @@ runProcess :: RainParser A.Process
runProcess = do (mProcess,processName) <- identifier
items <- tuple
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
convertItem :: A.Expression -> A.Actual
convertItem (A.ExprVariable _ v) = A.ActualVariable v
@ -513,7 +512,7 @@ rainSourceFile
rainTimerName :: A.Name
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)
parseRainProgram :: FilePath -> String -> PassM A.AST
@ -525,7 +524,7 @@ parseRainProgram filename source
do defineName rainTimerName $ A.NameDef {A.ndMeta = emptyMeta,
A.ndName = 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.ndAbbrevMode = A.Original, A.ndPlacement = A.Unplaced}
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 ("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 ("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,
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 CompState
import Errors
import ImplicitMobility
import Pass
import qualified Properties as Prop
import RainTypes
@ -101,7 +100,7 @@ uniquifyAndResolveVars = applyDepthSM uniquifyAndResolveVars'
uniquifyAndResolveVars' (A.Spec m (A.Specification m' n decl@(A.Declaration {})) scope)
= do n' <- makeNonce $ 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}
let scope' = everywhere (mkT $ replaceNameName (A.nameName n) n') 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
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,
A.ndNameType = A.ProcName, A.ndSpecType = newProc,
A.ndSpecType = newProc,
A.ndAbbrevMode = A.Original, A.ndPlacement = A.Unplaced}
return $ A.Spec m (A.Specification m' n newProc) scope
-- Functions:
@ -120,7 +119,7 @@ uniquifyAndResolveVars = applyDepthSM uniquifyAndResolveVars'
= do (params', funcBody') <- doFormals 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,
A.ndNameType = A.FunctionName, A.ndSpecType = newFunc,
A.ndSpecType = newFunc,
A.ndAbbrevMode = A.Original, A.ndPlacement = A.Unplaced}
return $ A.Spec m (A.Specification m' n newFunc) scope
@ -147,7 +146,7 @@ uniquifyAndResolveVars = applyDepthSM uniquifyAndResolveVars'
let newName = (n {A.nameName = n'})
let m = A.nameMeta 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}
let scope' = everywhere (mkT $ replaceNameName (A.nameName n) n') scope
return (A.Formal am t newName, scope')
@ -170,15 +169,24 @@ findMain x = do newMainName <- makeNonce "main_"
applyDepthM (return . (replaceNameName "main" newMainName)) x
where
--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' 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})]}
Nothing -> st
findMain' :: String -> CompState -> CompState
findMain' newn st = case Map.lookup "main" (csNames st) of
Just n -> st { csNames = changeMainName newn (csNames st)
, csMainLocals = makeMainLocals (findMeta n) newn
}
Nothing -> st
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
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.IntLiteral _ s) = Just $ read s
checkIntegral (A.HexLiteral _ s) = Nothing -- TODO support hex literals
@ -207,7 +215,7 @@ transformRangeRep = applyDepthM doExpression
where
doExpression :: A.Expression -> PassM A.Expression
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
return $ A.ExprConstr m $ A.RepConstr m t
(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)
assertNotEqual "testUnique0: Variable was not made unique" "c" (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:
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: Variables were not made unique" (A.nameName newc0Name) (A.nameName newc1Name)
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)
(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
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") [])
exp = orig
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:
testUnique4 :: Test
@ -196,9 +196,9 @@ testUnique4 = TestCase $ testPassWithItemsStateCheck "testUnique4" exp (uniquify
= do newcName <- castAssertADI (Map.lookup "newc" items)
assertNotEqual "testUnique4: Variable was not made unique" "c" (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"
(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)
-- 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)
exp = orig
check state = assertVarDef "testRecordInfNames0" state "c"
(tag7 A.NameDef DontCare "c" "c" A.VariableName
(A.Declaration m $ A.UnknownVarType $ Left $ simpleName "c") A.Abbrev A.Unplaced)
(tag7 A.NameDef DontCare "c" "c" A.VariableName (A.Declaration m A.Byte ) A.Abbrev A.Unplaced)
-- | checks that c's type is recorded in: ***each (c : str) {}, where str is known to be of type string
testRecordInfNames1 :: Test
@ -224,8 +223,7 @@ testRecordInfNames1 = TestCase $ testPassWithStateCheck "testRecordInfNames1" ex
orig = (A.Rep m (A.ForEach m (simpleName "c") (exprVariable "str")) skipP)
exp = orig
check state = assertVarDef "testRecordInfNames1" state "c"
(tag7 A.NameDef DontCare "c" "c" A.VariableName
(A.Declaration m $ A.UnknownVarType $ Left $ simpleName "c") A.Abbrev A.Unplaced)
(tag7 A.NameDef DontCare "c" "c" A.VariableName (A.Declaration m A.Byte ) 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]
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
exp = orig
check state = do assertVarDef "testRecordInfNames2" state "c"
(tag7 A.NameDef DontCare "c" "c" A.VariableName
(A.Declaration m $ A.UnknownVarType $ Left $ simpleName
"c") A.Abbrev A.Unplaced)
(tag7 A.NameDef DontCare "c" "c" A.VariableName (A.Declaration m (A.List A.Byte) ) A.Abbrev A.Unplaced)
assertVarDef "testRecordInfNames2" state "d"
(tag7 A.NameDef DontCare "d" "d" A.VariableName
(A.Declaration m $ A.UnknownVarType $ Left $ simpleName
"d") A.Abbrev A.Unplaced)
(tag7 A.NameDef DontCare "d" "d" A.VariableName (A.Declaration m A.Byte ) 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.
(>>>) :: Monad m => (a -> m b) -> (b -> m c) -> a -> m c
@ -257,35 +257,35 @@ testRecordInfNames2 = TestCase $ testPassWithStateCheck "testRecordInfNames2" ex
testFindMain0 :: Test
testFindMain0 = TestCase $ testPassWithItemsStateCheck "testFindMain0" exp ((uniquifyAndResolveVars >>> findMain) orig) (return ()) check
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
exp = mSpecAST (tag3 A.Specification DontCare (tag3 A.Name DontCare A.ProcName ("main"@@DontCare)) $
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 (tag2 A.Name DontCare ("main"@@DontCare)) $
tag4 A.Proc DontCare A.PlainSpec ([] :: [A.Formal]) (tag1 A.Skip DontCare)) $ mSeveralAST ([] :: [A.AST])
check (items,state)
= do mainName <- castAssertADI (Map.lookup "main" items)
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
(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 = TestCase $ testPassWithStateCheck "testFindMain1" orig ((uniquifyAndResolveVars >>> findMain) orig) (return ()) check
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)
testFindMain2 :: Test
testFindMain2 = TestCase $ testPassWithItemsStateCheck "testFindMain2" exp ((uniquifyAndResolveVars >>> findMain) orig) (return ()) check
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])
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)
check (items,state)
= do mainName <- castAssertADI (Map.lookup "main" items)
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 ::
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
return $ Just (UnifyIndex (A.ndMeta d, Right name), te)
where
name = A.Name {A.nameName = rawName, A.nameMeta = A.ndMeta d, A.nameType
= A.ndNameType d}
name = A.Name {A.nameName = rawName, A.nameMeta = A.ndMeta d}
substituteUnknownTypes :: Map.Map UnifyIndex A.Type -> PassType
substituteUnknownTypes mt = applyDepthM sub
@ -142,9 +141,9 @@ recordInfNameTypes = checkDepthM recordInfNameTypes'
where
recordInfNameTypes' :: Check A.Replicator
recordInfNameTypes' input@(A.ForEach m n e)
= let innerT = A.UnknownVarType $ Left n in
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,
= do let innerT = A.UnknownVarType $ Left 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.ndAbbrevMode = A.Abbrev, A.ndPlacement = A.Unplaced}
recordInfNameTypes' _ = return ()

12
pass/PassList.hs
View File

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

30
transformations/PassTest.hs
View File

@ -82,10 +82,10 @@ testFunctionsToProcs0 = TestCase $ testPassWithItemsStateCheck "testFunctionsToP
--check return parameters were defined:
check (items,state) = do ret0 <- ((assertGetItemCast "ret0" items) :: IO A.Name)
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:
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:
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)
ret1 <- ((assertGetItemCast "ret1" items) :: IO A.Name)
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) $
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:
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:
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)
ret0 <- ((assertGetItemCast "ret0" items) :: IO A.Name)
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) $
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:
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" $
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:
assertEqual "testFunctionsToProcs2 F" (Just [A.Int]) (Map.lookup "foo" (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 (items,state) = do ret0 <- ((assertGetItemCast "ret0" items) :: IO A.Name)
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:
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:
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)
ret1 <- ((assertGetItemCast "ret1" items) :: IO A.Name)
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) $
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:
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:
assertEqual "testFunctionsToProcs4 E" (Just [A.Int,A.Real32]) (Map.lookup "foo" (csFunctionReturns state))
@ -515,7 +515,7 @@ testInputCase = TestList
b2 = simpleName "b2"
c1 = simpleName "c1"
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.Original A.Unplaced
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 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)
{- 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
doProcess :: A.Process -> PassM A.Process
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
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)])
@ -166,7 +166,7 @@ transformInputCase = applyDepthM doProcess
-- The processes that are the body of input-case guards are always
-- skip, so we can discard them.
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
return $ A.Spec m' spec $ A.Only m $
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 m n (A.Function mf sm rts fs evp))
= 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]
-- Note the return types so we can fix calls later.
modify $ (\ps -> ps { csFunctionReturns = Map.insert (A.nameName n) rts (csFunctionReturns ps) })
@ -68,7 +68,6 @@ functionsToProcs = applyDepthM doSpecification
A.ndMeta = mf,
A.ndName = A.nameName n,
A.ndOrigName = A.nameName n,
A.ndNameType = A.ProcName,
A.ndSpecType = st,
A.ndAbbrevMode = A.Original,
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)
= do case t of
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
return $ declDest $ A.ProcThen m''
@ -367,7 +366,7 @@ pullUp pullUpArraysInsideRecords = recurse
ps <- get
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]
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.Assign m vs@(_:_:_) (A.ExpressionList _ es))
= 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 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]
@ -136,9 +136,9 @@ flattenAssign = makeRecurse ops
-- Record assignments become a sequence of
-- assignments, one for each field.
= 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
(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
assigns <-
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.
ps <- get
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.
let freeNames' = if isTLP then [] else Map.elems $ freeNamesIn st
let freeNames'' = [n | n <- freeNames',
case A.nameType n of
A.ChannelName -> True
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''
freeNames <- if isTLP
then return []
else filterM isFreeName
(Map.elems $ freeNamesIn st)
types <- mapM astTypeOf freeNames
origAMs <- mapM abbrevModeOfName freeNames
let ams = map makeAbbrevAM origAMs
@ -155,6 +148,30 @@ removeFreeNames = applyDepthM2 doSpecification doProcess
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.
doProcess :: A.Process -> PassM A.Process
doProcess p@(A.ProcCall m n as)