From 36e7353ee79b7a2947f17531ffefdc2ac9b4beab Mon Sep 17 00:00:00 2001 From: Adam Sampson Date: Mon, 2 Jun 2008 10:13:14 +0000 Subject: [PATCH] Take NameType out of NameDef. 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. --- backends/BackendPasses.hs | 6 +- backends/BackendPassesTest.hs | 15 +- backends/GenerateC.hs | 2 +- backends/GenerateCTest.hs | 4 +- backends/TLP.hs | 23 +-- checks/ArrayUsageCheck.hs | 4 +- common/TestUtils.hs | 64 ++++----- data/AST.hs | 19 +-- data/CompState.hs | 51 ++++--- frontends/OccamTypes.hs | 12 +- frontends/ParseOccam.hs | 238 ++++++++++++++++--------------- frontends/ParseRain.hs | 13 +- frontends/ParseRainTest.hs | 2 +- frontends/RainPasses.hs | 34 +++-- frontends/RainPassesTest.hs | 50 +++---- frontends/RainTypes.hs | 9 +- pass/PassList.hs | 12 +- transformations/PassTest.hs | 30 ++-- transformations/SimplifyComms.hs | 6 +- transformations/SimplifyExprs.hs | 7 +- transformations/SimplifyProcs.hs | 6 +- transformations/Unnest.hs | 41 ++++-- 22 files changed, 342 insertions(+), 306 deletions(-) diff --git a/backends/BackendPasses.hs b/backends/BackendPasses.hs index 8b7616a..b3c6567 100644 --- a/backends/BackendPasses.hs +++ b/backends/BackendPasses.hs @@ -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} diff --git a/backends/BackendPassesTest.hs b/backends/BackendPassesTest.hs index 692552f..fb8de90 100644 --- a/backends/BackendPassesTest.hs +++ b/backends/BackendPassesTest.hs @@ -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 diff --git a/backends/GenerateC.hs b/backends/GenerateC.hs index 81a090f..6ad8c00 100644 --- a/backends/GenerateC.hs +++ b/backends/GenerateC.hs @@ -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]) diff --git a/backends/GenerateCTest.hs b/backends/GenerateCTest.hs index 0ee1170..2e9daa8 100644 --- a/backends/GenerateCTest.hs +++ b/backends/GenerateCTest.hs @@ -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 diff --git a/backends/TLP.hs b/backends/TLP.hs index 7dd6179..207abdf 100644 --- a/backends/TLP.hs +++ b/backends/TLP.hs @@ -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) diff --git a/checks/ArrayUsageCheck.hs b/checks/ArrayUsageCheck.hs index 3681fe4..cc206e0 100644 --- a/checks/ArrayUsageCheck.hs +++ b/checks/ArrayUsageCheck.hs @@ -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: diff --git a/common/TestUtils.hs b/common/TestUtils.hs index 30e7a48..8d0d972 100644 --- a/common/TestUtils.hs +++ b/common/TestUtils.hs @@ -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 ( diff --git a/data/AST.hs b/data/AST.hs index eccbdeb..b0a0fb7 100644 --- a/data/AST.hs +++ b/data/AST.hs @@ -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. diff --git a/data/CompState.hs b/data/CompState.hs index 23e4804..7e550d7 100644 --- a/data/CompState.hs +++ b/data/CompState.hs @@ -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 \ No newline at end of file + return n diff --git a/frontends/OccamTypes.hs b/frontends/OccamTypes.hs index ec2372f..380734a 100644 --- a/frontends/OccamTypes.hs +++ b/frontends/OccamTypes.hs @@ -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 diff --git a/frontends/ParseOccam.hs b/frontends/ParseOccam.hs index e69ceff..3fb8a44 100644 --- a/frontends/ParseOccam.hs +++ b/frontends/ParseOccam.hs @@ -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 diff --git a/frontends/ParseRain.hs b/frontends/ParseRain.hs index 10580b6..aa82368 100644 --- a/frontends/ParseRain.hs +++ b/frontends/ParseRain.hs @@ -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 diff --git a/frontends/ParseRainTest.hs b/frontends/ParseRainTest.hs index 8a515eb..7584954 100644 --- a/frontends/ParseRainTest.hs +++ b/frontends/ParseRainTest.hs @@ -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) diff --git a/frontends/RainPasses.hs b/frontends/RainPasses.hs index ced852b..f9f7bba 100644 --- a/frontends/RainPasses.hs +++ b/frontends/RainPasses.hs @@ -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) diff --git a/frontends/RainPassesTest.hs b/frontends/RainPassesTest.hs index ec7f233..f61c668 100644 --- a/frontends/RainPassesTest.hs +++ b/frontends/RainPassesTest.hs @@ -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 diff --git a/frontends/RainTypes.hs b/frontends/RainTypes.hs index 1612c81..01c40b5 100644 --- a/frontends/RainTypes.hs +++ b/frontends/RainTypes.hs @@ -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 () diff --git a/pass/PassList.hs b/pass/PassList.hs index 8b7fb5d..720bf16 100644 --- a/pass/PassList.hs +++ b/pass/PassList.hs @@ -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 diff --git a/transformations/PassTest.hs b/transformations/PassTest.hs index 9bf43fe..c6f0363 100644 --- a/transformations/PassTest.hs +++ b/transformations/PassTest.hs @@ -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 () diff --git a/transformations/SimplifyComms.hs b/transformations/SimplifyComms.hs index f51894f..24afd17 100644 --- a/transformations/SimplifyComms.hs +++ b/transformations/SimplifyComms.hs @@ -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)]) $ diff --git a/transformations/SimplifyExprs.hs b/transformations/SimplifyExprs.hs index 030fbe8..47d3bb9 100644 --- a/transformations/SimplifyExprs.hs +++ b/transformations/SimplifyExprs.hs @@ -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] diff --git a/transformations/SimplifyProcs.hs b/transformations/SimplifyProcs.hs index feade04..81b0610 100644 --- a/transformations/SimplifyProcs.hs +++ b/transformations/SimplifyProcs.hs @@ -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 diff --git a/transformations/Unnest.hs b/transformations/Unnest.hs index abf1b36..43a67ce 100644 --- a/transformations/Unnest.hs +++ b/transformations/Unnest.hs @@ -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)