From 3283b7db41d5e41221ef0a0a222d667a8f1bb57b Mon Sep 17 00:00:00 2001 From: Adam Sampson Date: Wed, 26 Mar 2008 18:16:09 +0000 Subject: [PATCH] Remove the Type/AbbrevMode information from Actual*. It's redundant, since you can always compute them from the variable, and it makes the code that deals with actuals rather cleaner. On the other hand, it slightly complicates some of the tests, because any names you use in an Actual need to be defined... --- backends/BackendPasses.hs | 29 +++++++++-------- backends/BackendPassesTest.hs | 6 ++-- backends/GenerateC.hs | 9 +++--- backends/GenerateCTest.hs | 13 ++++---- checks/Check.hs | 10 +++--- checks/UsageCheckTest.hs | 18 ++++++++++- checks/UsageCheckUtils.hs | 55 ++++++++++++++++++++++---------- common/ShowCode.hs | 4 +-- common/TestUtils.hs | 6 ++++ data/AST.hs | 6 ++-- frontends/OccamTypes.hs | 19 ++++------- frontends/OccamTypesTest.hs | 20 ++++++------ frontends/ParseOccam.hs | 4 +-- frontends/ParseRain.hs | 4 +-- frontends/ParseRainTest.hs | 4 +-- frontends/RainPassesTest.hs | 30 ++++++++--------- frontends/RainTypes.hs | 10 +++--- transformations/SimplifyExprs.hs | 2 +- transformations/SimplifyProcs.hs | 2 +- transformations/Unnest.hs | 6 ++-- 20 files changed, 150 insertions(+), 107 deletions(-) diff --git a/backends/BackendPasses.hs b/backends/BackendPasses.hs index 0cca14c..618764c 100644 --- a/backends/BackendPasses.hs +++ b/backends/BackendPasses.hs @@ -288,20 +288,21 @@ addSizesActualParameters = doGeneric `extM` doProcess doProcess p = doGeneric p transformActual :: A.Actual -> PassM [A.Actual] - transformActual a@(A.ActualVariable am (A.Array ds _) (A.Variable m n)) - = do let a_sizes = A.Variable m (append_sizes n) - let sizeType = A.Array [makeDimension m $ length ds] A.Int - return [a, A.ActualVariable A.ValAbbrev sizeType a_sizes] - transformActual a@(A.ActualExpression (A.Array ds _) (A.ExprVariable _ (A.Variable m n))) - = do let a_sizes = A.Variable m (append_sizes n) - let sizeType = A.Array [makeDimension m $ length ds] A.Int - return [a, A.ActualVariable A.ValAbbrev sizeType a_sizes] - transformActual a = let t = case a of - A.ActualVariable _ t _ -> t - A.ActualExpression t _ -> t - in case t of - A.Array {} -> dieP (findMeta a) "Untransformed actual parameter of type array: " - _ -> return [a] + transformActual a@(A.ActualVariable v) + = transformActualVariable a v + transformActual a@(A.ActualExpression (A.ExprVariable _ v)) + = transformActualVariable a v + transformActual a = return [a] + + transformActualVariable :: A.Actual -> A.Variable -> PassM [A.Actual] + transformActualVariable a v@(A.Variable m n) + = do t <- typeOfVariable v + case t of + A.Array ds _ -> + return [a, A.ActualVariable a_sizes] + _ -> return [a] + where + a_sizes = A.Variable m (append_sizes n) -- | Transforms all slices into the FromFor form. simplifySlices :: Data t => t -> PassM t diff --git a/backends/BackendPassesTest.hs b/backends/BackendPassesTest.hs index 3120876..e422646 100644 --- a/backends/BackendPassesTest.hs +++ b/backends/BackendPassesTest.hs @@ -355,7 +355,9 @@ qcTestSizeParameters = testActual ts = testPassWithStateCheck "qcTestSizeParameters Actual" (procCall "p" argsWithSizes) (addSizesActualParameters $ procCall "p" args) - (return ()) (const $ return ()) + (do recordProcDef args + recordProcFormals args) + (const $ return ()) where args = [("x" ++ show n, t, A.Abbrev) | (n, t) <- zip [(0::Integer)..] ts] argsWithSizes = concat [ @@ -401,7 +403,7 @@ qcTestSizeParameters = wrapSpec n spec = A.Spec emptyMeta (A.Specification emptyMeta (simpleName n) spec) (A.Only emptyMeta ()) procCall :: String -> [(String, A.Type, A.AbbrevMode)] -> A.Process - procCall p nts = A.ProcCall emptyMeta (simpleName p) [A.ActualVariable am t (variable n) | (n, t, am) <- nts] + procCall p nts = A.ProcCall emptyMeta (simpleName p) [A.ActualVariable (variable n) | (n, _, _) <- nts] ---Returns the list of tests: qcTests :: (Test, [LabelledQuickCheckTest]) diff --git a/backends/GenerateC.hs b/backends/GenerateC.hs index 345facd..6d7a181 100644 --- a/backends/GenerateC.hs +++ b/backends/GenerateC.hs @@ -1367,10 +1367,11 @@ cgenActual actual = seqComma $ realActuals actual -- | Return generators for all the real actuals corresponding to a single -- actual. realActuals :: A.Actual -> [CGen ()] -realActuals (A.ActualExpression t e) +realActuals (A.ActualExpression e) = [call genExpression e] -realActuals (A.ActualVariable am t v) - = [call genVariableAM v am] +realActuals (A.ActualVariable v) + = [do am <- abbrevModeOfVariable v + call genVariableAM v am] -- | Return (type, name) generator pairs for all the real formals corresponding -- to a single formal. @@ -1751,7 +1752,7 @@ cgenProcCall n as --}}} --{{{ intrinsic procs cgenIntrinsicProc :: Meta -> String -> [A.Actual] -> CGen () -cgenIntrinsicProc m "ASSERT" [A.ActualExpression A.Bool e] = call genAssert m e +cgenIntrinsicProc m "ASSERT" [A.ActualExpression e] = call genAssert m e cgenIntrinsicProc _ "RESCHEDULE" [] = tell ["Reschedule (wptr);\n"] cgenIntrinsicProc _ s _ = call genMissing $ "intrinsic PROC " ++ s diff --git a/backends/GenerateCTest.hs b/backends/GenerateCTest.hs index d5c6523..add73bd 100644 --- a/backends/GenerateCTest.hs +++ b/backends/GenerateCTest.hs @@ -305,15 +305,16 @@ testActuals = TestList ,testBothSame "genActuals 1" "" $ (tcall genActuals []) --For expressions, genExpression should be called: - ,testBothSame "genActual 0" "$" $ over (tcall genActual $ A.ActualExpression A.Bool (A.True undefined)) + ,testBothSame "genActual 0" "$" $ over (tcall genActual $ A.ActualExpression (A.True undefined)) --For abbreviating arrays, nothing special should happen any more: - ,testBothSame "genActual 1" "$" $ over (tcall genActual $ A.ActualExpression (A.Array undefined undefined) (A.Literal undefined undefined undefined)) - ,testBothSameS "genActual 2" "@" (over (tcall genActual $ A.ActualVariable A.Original (A.Array undefined undefined) (A.Variable undefined foo))) + ,testBothSame "genActual 1" "$" $ over (tcall genActual $ A.ActualExpression (A.Literal undefined undefined undefined)) + ,testBothSameS "genActual 2" "@" (over (tcall genActual $ A.ActualVariable (A.Variable undefined foo))) (defineName foo $ simpleDefDecl "foo" A.Int) - ,testBothSameS "genActual 3" "&@" (over (tcall genActual $ A.ActualVariable A.Abbrev (A.Array undefined undefined) (A.Variable undefined foo))) - (defineName foo $ simpleDefDecl "foo" A.Int) - ,testBothSameS "genActual 4" "@" (over (tcall genActual $ A.ActualVariable A.ValAbbrev (A.Array undefined undefined) (A.Variable undefined foo))) + ,testBothSameS "genActual 3" "&@" (over (tcall genActual $ A.ActualVariable (A.Variable undefined foo))) + (do defineName foo $ simpleDefDecl "bar" A.Int + defineIs "foo" A.Int (variable "bar")) + ,testBothSameS "genActual 4" "@" (over (tcall genActual $ A.ActualVariable (A.Variable undefined foo))) (defineName foo $ simpleDefDecl "foo" A.Int) ] where diff --git a/checks/Check.hs b/checks/Check.hs index b965be7..79fb5d5 100644 --- a/checks/Check.hs +++ b/checks/Check.hs @@ -224,9 +224,9 @@ checkProcCallArgsUsage = mapM_ checkArgs . listify isProcCall -- | Need to check that all the destinations in a parallel assignment -- are distinct. So we check plain variables, and array variables checkArgs :: A.Process -> m () - checkArgs (A.ProcCall m _ params) - = do checkPlainVarUsage (m, mockedupParItems) + checkArgs p@(A.ProcCall m _ _) + = do vars <- getVarProcCall p + let mockedupParItems = ParItems [SeqItems [Usage Nothing Nothing v] + | v <- vars] + checkPlainVarUsage (m, mockedupParItems) checkArrayUsage (m, mockedupParItems) - where - mockedupParItems :: ParItems UsageLabel - mockedupParItems = ParItems [SeqItems [Usage Nothing Nothing v] | v <- map getVarActual params] diff --git a/checks/UsageCheckTest.hs b/checks/UsageCheckTest.hs index af90bf1..30ffb6a 100644 --- a/checks/UsageCheckTest.hs +++ b/checks/UsageCheckTest.hs @@ -32,6 +32,7 @@ import CompState import Errors import FlowGraph import Metadata +import TestFramework import TestUtils hiding (Var) import UsageCheckAlgorithms import UsageCheckUtils @@ -102,8 +103,23 @@ testGetVarProc = TestList (map doTest tests) ,(502,[],[tvA,tvB],[tvC],A.Input emptyMeta vC (A.InputSimple emptyMeta [A.InCounted emptyMeta vA vB])) ] + + -- This is a custom test because there's no instance of Data for Vars. + -- If we need to do this elsewhere, this could become a helper function in + -- TestUtils. doTest :: (Int,[Var],[Var],[Var],A.Process) -> Test - doTest (index,r,w,u,proc) = TestCase $ assertEqual ("testGetVarProc-" ++ (show index)) (vars r w u) (getVarProc proc) + doTest (index, r, w, u, proc) + = TestCase $ do result <- runPass (getVarProc proc) startState + case result of + Left err -> + testFailure $ name ++ " failed: " ++ show err + Right (_, result) -> + assertEqual name (vars r w u) result + where + name = "testGetVarProc" ++ show index + + startState :: CompState + startState = emptyState --TODO test declarations being recorded, when I've decided how to record them diff --git a/checks/UsageCheckUtils.hs b/checks/UsageCheckUtils.hs index 2f91294..ea42752 100644 --- a/checks/UsageCheckUtils.hs +++ b/checks/UsageCheckUtils.hs @@ -16,7 +16,7 @@ You should have received a copy of the GNU General Public License along with this program. If not, see . -} -module UsageCheckUtils (Decl(..), emptyVars, flattenParItems, foldUnionVars, getVarActual, getVarProc, labelFunctions, mapUnionVars, ParItems(..), processVarW, transformParItems, UsageLabel(..), Var(..), Vars(..), vars) where +module UsageCheckUtils (Decl(..), emptyVars, flattenParItems, foldUnionVars, getVarProcCall, getVarProc, labelFunctions, mapUnionVars, ParItems(..), processVarW, transformParItems, UsageLabel(..), Var(..), Vars(..), vars) where import Control.Monad.Writer (tell) import Data.Generics hiding (GT) @@ -25,11 +25,14 @@ import Data.Maybe import qualified Data.Set as Set import qualified AST as A +import CompState import Errors import FlowGraph import Metadata import OrdAST() import ShowCode +import Types +import Utils newtype Var = Var A.Variable deriving (Data, Show, Typeable) @@ -118,31 +121,48 @@ mapUnionVars f = foldUnionVars . (map f) --For subscripted variables used as Lvalues , e.g. a[b] it should return a[b] as written-to and b as read --For subscripted variables used as expressions, e.g. a[b] it should return a[b],b as read (with no written-to) -getVarProc :: A.Process -> Vars +getVarProc :: (Die m, CSMR m) => A.Process -> m Vars getVarProc (A.Assign _ vars expList) --Join together: - = unionVars + = return $ unionVars --The written-to variables on the LHS: (mapUnionVars processVarW vars) --All variables read on the RHS: (getVarExpList expList) -getVarProc (A.Output _ chanVar outItems) = (processVarUsed chanVar) `unionVars` (mapUnionVars getVarOutputItem outItems) +getVarProc (A.Output _ chanVar outItems) + = return $ (processVarUsed chanVar) + `unionVars` (mapUnionVars getVarOutputItem outItems) where getVarOutputItem :: A.OutputItem -> Vars getVarOutputItem (A.OutExpression _ e) = getVarExp e getVarOutputItem (A.OutCounted _ ce ae) = (getVarExp ce) `unionVars` (getVarExp ae) -getVarProc (A.Input _ chanVar (A.InputSimple _ iis)) = (processVarUsed chanVar) `unionVars` (mapUnionVars getVarInputItem iis) +getVarProc (A.Input _ chanVar (A.InputSimple _ iis)) + = return $ (processVarUsed chanVar) + `unionVars` (mapUnionVars getVarInputItem iis) where getVarInputItem :: A.InputItem -> Vars - getVarInputItem (A.InCounted _ cv av) = mkWrittenVars [variableToVar cv,variableToVar av] - getVarInputItem (A.InVariable _ v) = mkWrittenVars [variableToVar v] -getVarProc (A.ProcCall _ _ params) = mapUnionVars getVarActual params -getVarProc _ = emptyVars + getVarInputItem (A.InCounted _ cv av) + = mkWrittenVars [variableToVar cv,variableToVar av] + getVarInputItem (A.InVariable _ v) + = mkWrittenVars [variableToVar v] +getVarProc p@(A.ProcCall _ _ _) + = getVarProcCall p >>* foldUnionVars +getVarProc _ = return emptyVars -getVarActual :: A.Actual -> Vars -getVarActual (A.ActualExpression _ e) = getVarExp e -getVarActual (A.ActualVariable A.ValAbbrev _ v) = processVarR v -getVarActual (A.ActualVariable _ _ v) = processVarW v +getVarProcCall :: (Die m, CSMR m) => A.Process -> m [Vars] +getVarProcCall (A.ProcCall _ proc as) + = do st <- specTypeOfName proc + let fs = case st of A.Proc _ _ fs _ -> fs + + sequence [getVarActual f a + | (f, a) <- zip fs as] + +getVarActual :: (Die m, CSMR m) => A.Formal -> A.Actual -> m Vars +getVarActual _ (A.ActualExpression e) = return $ getVarExp e +getVarActual (A.Formal am _ _) (A.ActualVariable v) + = case am of + A.ValAbbrev -> return $ processVarR v + _ -> return $ processVarW v {- Near the beginning, this piece of code was too clever for itself and applied processVarW using "everything". @@ -201,13 +221,13 @@ getVarRepExp (A.ForEach _ _ e) = getVarExp e getVarAlternative :: A.Alternative -> Vars getVarAlternative = const emptyVars -- TODO -labelFunctions :: forall m. Die m => GraphLabelFuncs m UsageLabel +labelFunctions :: forall m. (Die m, CSMR m) => GraphLabelFuncs m UsageLabel labelFunctions = GLF { labelExpression = single getVarExp ,labelExpressionList = single getVarExpList ,labelDummy = const (return $ Usage Nothing Nothing emptyVars) - ,labelProcess = single getVarProc + ,labelProcess = singleM getVarProc ,labelAlternative = single getVarAlternative ,labelStartNode = single (uncurry getVarFormals) ,labelReplicator = \x -> return (Usage (Just x) Nothing (getVarRepExp x)) @@ -218,6 +238,9 @@ labelFunctions = GLF where single :: (a -> Vars) -> (a -> m UsageLabel) single f x = return $ Usage Nothing Nothing (f x) - + + singleM :: (a -> m Vars) -> (a -> m UsageLabel) + singleM f x = f x >>* Usage Nothing Nothing + pair :: (a -> Maybe Decl) -> (a -> Vars) -> (a -> m UsageLabel) pair f0 f1 x = return $ Usage Nothing (f0 x) (f1 x) diff --git a/common/ShowCode.hs b/common/ShowCode.hs index 9265d34..1f6819e 100644 --- a/common/ShowCode.hs +++ b/common/ShowCode.hs @@ -456,8 +456,8 @@ instance ShowOccam A.Variant where >> occamIndent >> showOccamM p >> occamOutdent instance ShowOccam A.Actual where - showOccamM (A.ActualVariable _ _ v) = showOccamM v - showOccamM (A.ActualExpression _ e) = showOccamM e + showOccamM (A.ActualVariable v) = showOccamM v + showOccamM (A.ActualExpression e) = showOccamM e instance ShowOccam A.OutputItem where showOccamM (A.OutExpression _ e) = showOccamM e diff --git a/common/TestUtils.hs b/common/TestUtils.hs index c3c2c12..b9fb631 100644 --- a/common/TestUtils.hs +++ b/common/TestUtils.hs @@ -328,6 +328,11 @@ defineConst s t e = defineThing s A.VariableName (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 + -- | Define a variable. defineVariable :: String -> A.Type -> State CompState () defineVariable s t @@ -482,6 +487,7 @@ testPassGetItems testName expected actualPass startStateTrans = prefixErr :: String -> String prefixErr err = testName ++ ": " ++ err + -- | Runs a given AST pass and returns the subsequent state, along with either an error or the result. This function is primarily intended for internal use by this module. runPass :: TestMonad m r => PassM b -- ^ The actual pass. diff --git a/data/AST.hs b/data/AST.hs index ab56ee9..2cbc22c 100644 --- a/data/AST.hs +++ b/data/AST.hs @@ -522,11 +522,9 @@ data Formal = -- | Actual parameters for @PROC@s and @FUNCTION@s. data Actual = -- | A variable used as a parameter. - -- 'AbbrevMode' and 'Type' are here for parity with 'Formal'; they can be - -- figured out from the variable. - ActualVariable AbbrevMode Type Variable + ActualVariable Variable -- | An expression used as a parameter. - | ActualExpression Type Expression + | ActualExpression Expression deriving (Show, Eq, Typeable, Data) -- | The mode in which a @PAR@ operates. diff --git a/frontends/OccamTypes.hs b/frontends/OccamTypes.hs index 19d1dfb..ad0c0ba 100644 --- a/frontends/OccamTypes.hs +++ b/frontends/OccamTypes.hs @@ -312,12 +312,12 @@ checkActuals m n fs as checkActual :: A.Formal -> A.Actual -> PassM () checkActual (A.Formal newAM et _) a = do rt <- case a of - A.ActualVariable _ _ v -> typeOfVariable v - A.ActualExpression _ e -> typeOfExpression e + A.ActualVariable v -> typeOfVariable v + A.ActualExpression e -> typeOfExpression e checkType (findMeta a) et rt origAM <- case a of - A.ActualVariable _ _ v -> abbrevModeOfVariable v - A.ActualExpression _ _ -> return A.ValAbbrev + A.ActualVariable v -> abbrevModeOfVariable v + A.ActualExpression _ -> return A.ValAbbrev checkAbbrev (findMeta a) origAM newAM -- | Check a function call. @@ -326,10 +326,7 @@ checkFunctionCall m n es = do st <- specTypeOfName n case st of A.Function _ _ rs fs _ -> - do as <- sequence [do t <- typeOfExpression e - return $ A.ActualExpression t e - | e <- es] - checkActuals m n fs as + do checkActuals m n fs (map A.ActualExpression es) return rs _ -> diePC m $ formatCode "% is not a function" n @@ -340,12 +337,10 @@ 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" - as <- sequence [do t <- typeOfExpression e - return $ A.ActualExpression t e - | e <- es] let fs = [A.Formal A.ValAbbrev t (A.Name m A.VariableName s) | (t, s) <- args] - checkActuals m (A.Name m A.ProcName n) fs as + checkActuals m (A.Name m A.ProcName n) + fs (map A.ActualExpression es) Nothing -> dieP m $ n ++ " is not an intrinsic function" -- | Check a mobile allocation. diff --git a/frontends/OccamTypesTest.hs b/frontends/OccamTypesTest.hs index a0dd3f1..f281723 100644 --- a/frontends/OccamTypesTest.hs +++ b/frontends/OccamTypesTest.hs @@ -344,13 +344,13 @@ testOccamTypes = TestList -- Proc calls , testOK 1600 $ proccall "proc0" [] - , testOK 1601 $ proccall "proc1" [A.ActualExpression A.Int intE] - , testOK 1602 $ proccall "proc2" [A.ActualExpression A.Int intE, - A.ActualVariable A.Original A.Int intV] - , testFail 1603 $ proccall "proc0" [A.ActualExpression A.Int intE] - , testFail 1604 $ proccall "proc1" [A.ActualExpression A.Real32 realE] - , testFail 1605 $ proccall "proc1" [A.ActualExpression A.Int intE, - A.ActualExpression A.Int intE] + , testOK 1601 $ proccall "proc1" [A.ActualExpression intE] + , testOK 1602 $ proccall "proc2" [A.ActualExpression intE, + A.ActualVariable intV] + , testFail 1603 $ proccall "proc0" [A.ActualExpression intE] + , testFail 1604 $ proccall "proc1" [A.ActualExpression realE] + , testFail 1605 $ proccall "proc1" [A.ActualExpression intE, + A.ActualExpression intE] , testFail 1606 $ proccall "herring" [] -- Miscellaneous processes @@ -365,12 +365,12 @@ testOccamTypes = TestList , testFail 1908 $ A.Processor m realE skip , testOK 1909 $ A.IntrinsicProcCall m "RESCHEDULE" [] , testOK 1910 $ A.IntrinsicProcCall m "ASSERT" - [A.ActualExpression A.Bool boolE] + [A.ActualExpression boolE] , testFail 1911 $ A.IntrinsicProcCall m "ASSERT" - [A.ActualExpression A.Int intE] + [A.ActualExpression intE] , testFail 1912 $ A.IntrinsicProcCall m "ASSERT" [] , testFail 1913 $ A.IntrinsicProcCall m "RESCHEDULE" - [A.ActualExpression A.Bool boolE] + [A.ActualExpression boolE] , testFail 1914 $ A.IntrinsicProcCall m "HERRING" [] --}}} diff --git a/frontends/ParseOccam.hs b/frontends/ParseOccam.hs index 3300e98..72aa3f1 100644 --- a/frontends/ParseOccam.hs +++ b/frontends/ParseOccam.hs @@ -1965,7 +1965,7 @@ actual (A.Formal am t n) = do case am of A.ValAbbrev -> do e <- expressionOfType t - return $ A.ActualExpression t e + return $ A.ActualExpression e _ -> case stripArrayType t of A.Chan {} -> var (channelOfType t) @@ -1974,7 +1974,7 @@ actual (A.Formal am t n) _ -> var (variableOfType t) "actual of type " ++ showOccam t ++ " for " ++ show n where - var inner = liftM (A.ActualVariable am t) inner + var inner = liftM A.ActualVariable inner --}}} --{{{ intrinsic PROC call intrinsicProcName :: OccParser (String, [A.Formal]) diff --git a/frontends/ParseRain.hs b/frontends/ParseRain.hs index 692dea4..9b82a87 100644 --- a/frontends/ParseRain.hs +++ b/frontends/ParseRain.hs @@ -411,8 +411,8 @@ runProcess = do m <- sRun return $ A.ProcCall m A.Name {A.nameName = processName, A.nameMeta = mProcess, A.nameType = A.ProcName} (map convertItem items) where convertItem :: A.Expression -> A.Actual - convertItem (A.ExprVariable _ v) = A.ActualVariable A.Original A.Any v - convertItem e = A.ActualExpression A.Any e + convertItem (A.ExprVariable _ v) = A.ActualVariable v + convertItem e = A.ActualExpression e waitStatement :: Bool -> RainParser (Meta, A.InputMode) waitStatement isAlt diff --git a/frontends/ParseRainTest.hs b/frontends/ParseRainTest.hs index 380d4ce..81ea8fb 100644 --- a/frontends/ParseRainTest.hs +++ b/frontends/ParseRainTest.hs @@ -677,9 +677,9 @@ testRun = [ pass ("run foo();",RP.statement,assertPatternMatch "testRun 1" $ tag3 A.ProcCall DontCare (procNamePattern "foo") ([] :: [A.Actual])) ,pass ("run foo(c);",RP.statement,assertPatternMatch "testRun 2" $ tag3 A.ProcCall DontCare (procNamePattern "foo") - [tag3 A.ActualVariable A.Original A.Any (variablePattern "c")]) + [tag1 A.ActualVariable (variablePattern "c")]) ,pass ("run foo(c,0+x);",RP.statement,assertPatternMatch "testRun 3" $ tag3 A.ProcCall DontCare (procNamePattern "foo") - [tag3 A.ActualVariable A.Original A.Any (variablePattern "c"),tag2 A.ActualExpression A.Any $ tag4 A.Dyadic DontCare A.Plus (intLiteralPattern 0) (exprVariablePattern "x")]) + [tag1 A.ActualVariable (variablePattern "c"),tag1 A.ActualExpression $ tag4 A.Dyadic DontCare A.Plus (intLiteralPattern 0) (exprVariablePattern "x")]) ,fail ("run",RP.statement) ,fail ("run;",RP.statement) ,fail ("run ();",RP.statement) diff --git a/frontends/RainPassesTest.hs b/frontends/RainPassesTest.hs index c143d88..5a072fa 100644 --- a/frontends/RainPassesTest.hs +++ b/frontends/RainPassesTest.hs @@ -180,7 +180,7 @@ testUnique4 :: Test testUnique4 = TestCase $ testPassWithItemsStateCheck "testUnique4" exp (uniquifyAndResolveVars orig) (return ()) check where orig = A.Spec m (A.Specification m (procName "foo") $ A.Proc m A.PlainSpec [A.Formal A.ValAbbrev A.Byte $ simpleName "c"] $ - A.ProcCall m (procName "foo") [A.ActualExpression A.Byte $ exprVariable "c"]) (skipP) + A.ProcCall m (procName "foo") [A.ActualExpression $ exprVariable "c"]) (skipP) exp = mSpecP (tag3 A.Specification DontCare (procNamePattern "foo") $ tag4 A.Proc DontCare A.PlainSpec [tag3 A.Formal A.ValAbbrev A.Byte newc] @@ -188,7 +188,7 @@ testUnique4 = TestCase $ testPassWithItemsStateCheck "testUnique4" exp (uniquify ) skipP bodyPattern n = (tag3 A.ProcCall DontCare (procNamePattern "foo") - [tag2 A.ActualExpression A.Byte $ tag2 A.ExprVariable DontCare $ tag2 A.Variable DontCare n] + [tag1 A.ActualExpression $ tag2 A.ExprVariable DontCare $ tag2 A.Variable DontCare n] ) newc = Named "newc" DontCare @@ -318,8 +318,8 @@ testParamPass testName formals params transParams deActualise :: [A.Actual] -> [A.Expression] deActualise = map deActualise' deActualise' :: A.Actual -> A.Expression - deActualise' (A.ActualVariable _ _ v) = A.ExprVariable m v - deActualise' (A.ActualExpression _ e) = e + deActualise' (A.ActualVariable v) = A.ExprVariable m v + deActualise' (A.ActualExpression e) = e -- | Test no-params: testParamPass0 :: Test @@ -329,31 +329,31 @@ testParamPass0 = testParamPass "testParamPass0" (Just []) [] (Just []) testParamPass1 :: Test testParamPass1 = testParamPass "testParamPass1" (Just [A.Formal A.ValAbbrev A.UInt16 (simpleName "p0")]) - [A.ActualVariable A.Original A.Any (variable "x")] - (Just [A.ActualVariable A.ValAbbrev A.UInt16 (variable "x")]) + [A.ActualVariable (variable "x")] + (Just [A.ActualVariable (variable "x")]) -- | Test up-casts: testParamPass2 :: Test testParamPass2 = testParamPass "testParamPass2" (Just [A.Formal A.ValAbbrev A.Int32 (simpleName "p0"),A.Formal A.ValAbbrev A.UInt32 (simpleName "p1")]) - [A.ActualVariable A.Original A.Any (variable "x"),A.ActualVariable A.Original A.Any (variable "x")] - (Just [A.ActualExpression A.Int32 $ A.Conversion m A.DefaultConversion A.Int32 (exprVariable "x"), - A.ActualExpression A.UInt32 $ A.Conversion m A.DefaultConversion A.UInt32 (exprVariable "x")]) + [A.ActualVariable (variable "x"),A.ActualVariable (variable "x")] + (Just [A.ActualExpression $ A.Conversion m A.DefaultConversion A.Int32 (exprVariable "x"), + A.ActualExpression $ A.Conversion m A.DefaultConversion A.UInt32 (exprVariable "x")]) -- | Test invalid implicit down-cast: testParamPass3 :: Test testParamPass3 = testParamPass "testParamPass3" (Just [A.Formal A.ValAbbrev A.Int8 (simpleName "p0"),A.Formal A.ValAbbrev A.UInt32 (simpleName "p1")]) - [A.ActualVariable A.Original A.Any (variable "x"),A.ActualVariable A.Original A.Any (variable "x")] + [A.ActualVariable (variable "x"),A.ActualVariable (variable "x")] Nothing -- | Test explicit down-cast: testParamPass4 :: Test testParamPass4 = testParamPass "testParamPass4" (Just [A.Formal A.ValAbbrev A.Int8 (simpleName "p0"),A.Formal A.ValAbbrev A.UInt16 (simpleName "p1")]) - [A.ActualExpression A.Int8 $ A.Conversion m A.DefaultConversion A.Int8 (exprVariable "x"),A.ActualVariable A.Original A.Any (variable "x")] - (Just [A.ActualExpression A.Int8 $ A.Conversion m A.DefaultConversion A.Int8 (exprVariable "x"), - A.ActualVariable A.ValAbbrev A.UInt16 (variable "x")]) + [A.ActualExpression $ A.Conversion m A.DefaultConversion A.Int8 (exprVariable "x"),A.ActualVariable (variable "x")] + (Just [A.ActualExpression $ A.Conversion m A.DefaultConversion A.Int8 (exprVariable "x"), + A.ActualVariable (variable "x")]) -- | Test too few parameters: testParamPass5 :: Test @@ -366,14 +366,14 @@ testParamPass5 = testParamPass "testParamPass5" testParamPass6 :: Test testParamPass6 = testParamPass "testParamPass6" (Just [A.Formal A.ValAbbrev A.UInt16 (simpleName "p0")]) - [A.ActualVariable A.Original A.Any (variable "x"),A.ActualVariable A.Original A.Any (variable "x")] + [A.ActualVariable (variable "x"),A.ActualVariable (variable "x")] Nothing -- | Test unknown process: testParamPass7 :: Test testParamPass7 = testParamPass "testParamPass7" Nothing - [A.ActualVariable A.Original A.Any (variable "x"),A.ActualVariable A.Original A.Any (variable "x")] + [A.ActualVariable (variable "x"),A.ActualVariable (variable "x")] Nothing -- | Test calling something that is not a process: diff --git a/frontends/RainTypes.hs b/frontends/RainTypes.hs index be75499..95c674b 100644 --- a/frontends/RainTypes.hs +++ b/frontends/RainTypes.hs @@ -159,13 +159,13 @@ matchParamPass = everywhereM ((mkM matchParamPassProc) `extM` matchParamPassFunc --Checks the type of a parameter (A.Actual), and inserts a cast if it is safe to do so doParam :: Meta -> String -> (Int,A.Formal, A.Actual) -> PassM A.Actual - doParam m n (index, A.Formal formalAbbrev formalType formalName, A.ActualVariable _ _ v) + doParam m n (index, A.Formal formalAbbrev formalType formalName, A.ActualVariable v) = do actualType <- typeOfVariable v if (actualType == formalType) - then return $ A.ActualVariable formalAbbrev formalType v - else (liftM $ A.ActualExpression formalType) $ doCast index formalType actualType (A.ExprVariable (findMeta v) v ) - doParam m n (index, for@(A.Formal _ formalType _), A.ActualExpression _ e) - = (liftM $ A.ActualExpression formalType) $ doExpParam m n (index, for, e) + then return $ A.ActualVariable v + else (liftM A.ActualExpression) $ doCast index formalType actualType (A.ExprVariable (findMeta v) v ) + doParam m n (index, for@(A.Formal _ formalType _), A.ActualExpression e) + = (liftM A.ActualExpression) $ doExpParam m n (index, for, e) --Checks the type of a parameter (A.Expression), and inserts a cast if it is safe to do so doExpParam :: Meta -> String -> (Int, A.Formal, A.Expression) -> PassM A.Expression diff --git a/transformations/SimplifyExprs.hs b/transformations/SimplifyExprs.hs index e60ba32..5e82879 100644 --- a/transformations/SimplifyExprs.hs +++ b/transformations/SimplifyExprs.hs @@ -384,7 +384,7 @@ pullUp pullUpArraysInsideRecords let names = [n | A.Specification _ n _ <- specs] let vars = [A.Variable m n | n <- names] - let call = A.ProcCall m n ([A.ActualExpression t e | (t, e) <- zip ets es'] ++ [A.ActualVariable A.Abbrev t v | (t, v) <- zip rts vars]) + let call = A.ProcCall m n (map A.ActualExpression es' ++ map A.ActualVariable vars) addPulled $ (m, Right call) return vars diff --git a/transformations/SimplifyProcs.hs b/transformations/SimplifyProcs.hs index 5c9d96f..3a816a1 100644 --- a/transformations/SimplifyProcs.hs +++ b/transformations/SimplifyProcs.hs @@ -145,7 +145,7 @@ flattenAssign = doGeneric `extM` doProcess `ext1M` doStructured return $ A.Rep m rep $ A.Only m inner A.Record n -> return $ A.Only m $ A.ProcCall m (n {A.nameName = "copy_" ++ A.nameName n}) - [A.ActualVariable A.Abbrev t destV, A.ActualVariable A.ValAbbrev t srcV] + [A.ActualVariable destV, A.ActualVariable srcV] return $ A.Seq m $ A.Spec m src $ A.Spec m dest body diff --git a/transformations/Unnest.hs b/transformations/Unnest.hs index 57d75f4..fde0b80 100644 --- a/transformations/Unnest.hs +++ b/transformations/Unnest.hs @@ -155,9 +155,9 @@ removeFreeNames = doGeneric `extM` doSpecification `extM` doProcess -- Note that we should add extra arguments to calls of this proc -- when we find them let newAs = [case am of - A.Abbrev -> A.ActualVariable am t (A.Variable m n) - _ -> A.ActualExpression t (A.ExprVariable m (A.Variable m n)) - | (am, n, t) <- zip3 ams freeNames types] + A.Abbrev -> A.ActualVariable (A.Variable m n) + _ -> A.ActualExpression (A.ExprVariable m (A.Variable m n)) + | (am, n) <- zip ams freeNames] debug $ "removeFreeNames: " ++ show n ++ " has new args " ++ show newAs when (newAs /= []) $ modify $ (\ps -> ps { csAdditionalArgs = Map.insert (A.nameName n) newAs (csAdditionalArgs ps) })