c8b724d2be
I also added the import list to all the Data.Generics imports in the tests (as I did for the other modules recently)
713 lines
30 KiB
Haskell
713 lines
30 KiB
Haskell
{-
|
|
Tock: a compiler for parallel languages
|
|
Copyright (C) 2007 University of Kent
|
|
|
|
This program is free software; you can redistribute it and/or modify it
|
|
under the terms of the GNU General Public License as published by the
|
|
Free Software Foundation, either version 2 of the License, or (at your
|
|
option) any later version.
|
|
|
|
This program is distributed in the hope that it will be useful, but
|
|
WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
|
General Public License for more details.
|
|
|
|
You should have received a copy of the GNU General Public License along
|
|
with this program. If not, see <http://www.gnu.org/licenses/>.
|
|
-}
|
|
|
|
-- | Contains test for various shared passes.
|
|
module PassTest (tests) where
|
|
|
|
import Control.Monad.State hiding (guard)
|
|
import Data.Generics (cast, Data, Typeable)
|
|
import qualified Data.Map as Map
|
|
import Test.HUnit hiding (State)
|
|
|
|
import qualified AST as A
|
|
import CompState
|
|
import Metadata
|
|
import OccamEDSL
|
|
import Pattern
|
|
import SimplifyComms
|
|
import SimplifyExprs
|
|
import TagAST
|
|
import TestUtils
|
|
import TreeUtils
|
|
import Types
|
|
import Unnest
|
|
import Utils
|
|
|
|
m :: Meta
|
|
m = emptyMeta
|
|
|
|
-- | An expression list containing a single value of 0.
|
|
valof0 :: A.Structured A.ExpressionList
|
|
valof0 = A.Only m $ A.ExpressionList m [intLiteral 0]
|
|
|
|
-- | An expression list containing variables with the two given names.
|
|
valofTwo :: String -> String -> A.Structured A.ExpressionList
|
|
valofTwo a b = A.Only m $ A.ExpressionList m [exprVariable a,exprVariable b]
|
|
|
|
-- | Looks up an item from the Items, and attempts to cast it. Fails (via assertions) if
|
|
-- either the item is not found, or if the cast is invalid.
|
|
assertGetItemCast :: Typeable t => String -> Items -> IO t
|
|
assertGetItemCast k kv
|
|
= case (Map.lookup k kv) of
|
|
Nothing -> (assertFailure "Internal error; expected item not present") >> return (undefined)
|
|
Just (ADI v) -> case (cast v) of
|
|
Just v' -> return v'
|
|
Nothing -> (assertFailure $ "Wrong type when casting in assertGetItemCast for key: " ++ k) >> return (undefined)
|
|
|
|
-- | Given a body, returns a function spec:
|
|
singleParamFunc :: A.Structured A.ExpressionList -> A.Specification
|
|
singleParamFunc body = A.Specification m (simpleName "foo") (A.Function m (A.PlainSpec,
|
|
A.PlainRec) [A.Int] [A.Formal A.ValAbbrev A.Byte (simpleName "param0")] (Just $ Left body))
|
|
|
|
singleParamFuncProc :: A.Process -> A.Specification
|
|
singleParamFuncProc body = A.Specification m (simpleName "foo") (A.Function m (A.PlainSpec,
|
|
A.PlainRec) [A.Int] [A.Formal A.ValAbbrev A.Byte (simpleName "param0")] (Just $ Right body))
|
|
|
|
-- | Returns the expected body of the single parameter process (when the function had valof0 as a body)
|
|
singleParamBodyExp :: Pattern -- ^ to match: A.Process
|
|
singleParamBodyExp = tag2 A.Seq DontCare $ mOnlyP $
|
|
tag3 A.Assign DontCare [tag2 A.Variable DontCare (Named "ret0" DontCare)] $ tag2 A.ExpressionList DontCare [intLiteral 0]
|
|
|
|
-- | Returns the expected specification type of the single parameter process
|
|
singleParamSpecExp :: Pattern -> Pattern -- ^ to match: A.SpecType
|
|
singleParamSpecExp body = tag4 A.Proc DontCare (A.PlainSpec, A.PlainRec) [tag3 A.Formal A.ValAbbrev A.Byte (simpleName "param0"), tag3 A.Formal A.Abbrev A.Int (Named "ret0" DontCare)] body
|
|
|
|
-- | Tests a function with a single return, and a single parameter.
|
|
testFunctionsToProcs0 :: Test
|
|
testFunctionsToProcs0 = TestCase $ testPassWithItemsStateCheck "testFunctionsToProcs0" exp functionsToProcs orig (return ()) check
|
|
where
|
|
orig = singleParamFunc valof0
|
|
exp = tag3 A.Specification DontCare (simpleName "foo") procSpec
|
|
procSpec = singleParamSpecExp singleParamBodyExp
|
|
--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.Declaration m A.Int) A.Abbrev A.NameNonce A.Unplaced
|
|
--check proc was defined:
|
|
assertVarDef "testFunctionsToProcs0" state "foo" $
|
|
tag7 A.NameDef DontCare ("foo") ("foo")
|
|
procSpec A.Original A.NameUser A.Unplaced
|
|
--check csFunctionReturns was changed:
|
|
assertEqual "testFunctionsToProcs0" (Just [A.Int]) (Map.lookup "foo" (csFunctionReturns state))
|
|
|
|
-- | Tests a function with multiple returns, and multiple parameters.
|
|
testFunctionsToProcs1 :: Test
|
|
testFunctionsToProcs1 = TestCase $ testPassWithItemsStateCheck "testFunctionsToProcs1 A" exp functionsToProcs orig (return ()) check
|
|
where
|
|
orig = A.Specification m (simpleName "foo") (A.Function m (A.PlainSpec, A.Recursive) [A.Int,A.Real32]
|
|
[A.Formal A.ValAbbrev A.Byte (simpleName "param0"),A.Formal A.Abbrev A.Real32 (simpleName "param1")] (Just $ Left $ valofTwo "param0" "param1"))
|
|
exp = tag3 A.Specification DontCare (simpleName "foo") procBody
|
|
procBody = tag4 A.Proc DontCare (A.PlainSpec, A.Recursive)
|
|
[tag3 A.Formal A.ValAbbrev A.Byte (simpleName "param0"),
|
|
tag3 A.Formal A.Abbrev A.Real32 (simpleName "param1"),
|
|
tag3 A.Formal A.Abbrev A.Int (Named "ret0" DontCare),
|
|
tag3 A.Formal A.Abbrev A.Real32 (Named "ret1" DontCare)] $
|
|
tag2 A.Seq DontCare $
|
|
mOnlyP $
|
|
tag3 A.Assign DontCare [tag2 A.Variable DontCare (Named "ret0" DontCare),tag2 A.Variable DontCare (Named "ret1" DontCare)] $
|
|
tag2 A.ExpressionList DontCare [exprVariable "param0",exprVariable "param1"]
|
|
--check return parameters were defined:
|
|
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.Declaration m A.Int) A.Abbrev A.NameNonce A.Unplaced
|
|
assertVarDef "testFunctionsToProcs1 C" state (A.nameName ret1) $
|
|
tag7 A.NameDef DontCare (A.nameName ret1) (A.nameName ret1)
|
|
(A.Declaration m A.Real32) A.Abbrev A.NameNonce A.Unplaced
|
|
--check proc was defined:
|
|
assertVarDef "testFunctionsToProcs1 D" state "foo" $
|
|
tag7 A.NameDef DontCare ("foo") ("foo")
|
|
procBody A.Original A.NameUser A.Unplaced
|
|
--check csFunctionReturns was changed:
|
|
assertEqual "testFunctionsToProcs1 E" (Just [A.Int,A.Real32]) (Map.lookup "foo" (csFunctionReturns state))
|
|
|
|
-- | Tests a function that contains a function.
|
|
-- Currently I have chosen to put DontCare for the body of the function as stored in the NameDef.
|
|
-- This behaviour is not too important, and may change at a later date.
|
|
testFunctionsToProcs2 :: Test
|
|
testFunctionsToProcs2 = TestCase $ testPassWithItemsStateCheck "testFunctionsToProcs2 A" exp functionsToProcs orig (return ()) check
|
|
where
|
|
orig = A.Specification m (simpleName "fooOuter") (A.Function m (A.PlainSpec,
|
|
A.PlainRec) [A.Int] [A.Formal A.ValAbbrev A.Byte (simpleName "paramOuter0")] $ Just $ Left $
|
|
A.Spec m (singleParamFunc valof0) valof0)
|
|
exp = tag3 A.Specification DontCare (simpleName "fooOuter") procBodyOuter
|
|
procHeader body = tag4 A.Proc DontCare (A.PlainSpec, A.PlainRec) [tag3 A.Formal A.ValAbbrev A.Byte (simpleName "paramOuter0"), tag3 A.Formal A.Abbrev A.Int (Named "retOuter0" DontCare)] body
|
|
procBodyOuter = procHeader $
|
|
tag2 A.Seq DontCare $
|
|
mSpecP (tag3 A.Specification DontCare (simpleName "foo") (singleParamSpecExp singleParamBodyExp)) $
|
|
mOnlyP $
|
|
tag3 A.Assign DontCare [tag2 A.Variable DontCare (Named "retOuter0" DontCare)] $ tag2 A.ExpressionList DontCare [intLiteral 0]
|
|
|
|
|
|
--check return parameters were defined:
|
|
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.Declaration m A.Int) A.Abbrev A.NameNonce A.Unplaced
|
|
assertVarDef "testFunctionsToProcs2 C" state (A.nameName retOuter0) $
|
|
tag7 A.NameDef DontCare (A.nameName retOuter0) (A.nameName retOuter0)
|
|
(A.Declaration m A.Int) A.Abbrev A.NameNonce A.Unplaced
|
|
--check proc was defined:
|
|
assertVarDef "testFunctionsToProcs2 D" state "foo" $
|
|
tag7 A.NameDef DontCare ("foo") ("foo") (singleParamSpecExp DontCare)
|
|
A.Original A.NameUser A.Unplaced
|
|
assertVarDef "testFunctionsToProcs2 E" state "fooOuter" $
|
|
tag7 A.NameDef DontCare ("fooOuter") ("fooOuter") (procHeader DontCare)
|
|
A.Original A.NameUser 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))
|
|
|
|
-- | Tests a function with a single return, and a single parameter, with a Process body
|
|
testFunctionsToProcs3 :: Test
|
|
testFunctionsToProcs3 = TestCase $ testPassWithItemsStateCheck "testFunctionsToProcs3" exp functionsToProcs orig (return ()) check
|
|
where
|
|
orig = singleParamFuncProc $ A.Seq m $ A.Only m $ A.Assign m [variable "foo"] $ A.ExpressionList m [intLiteral 0]
|
|
exp = tag3 A.Specification DontCare (simpleName "foo") procSpec
|
|
procSpec = singleParamSpecExp singleParamBodyExp
|
|
--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.Declaration m A.Int) A.Abbrev A.NameNonce A.Unplaced
|
|
--check proc was defined:
|
|
assertVarDef "testFunctionsToProcs3" state "foo" $
|
|
tag7 A.NameDef DontCare ("foo") ("foo")
|
|
procSpec A.Original A.NameUser A.Unplaced
|
|
--check csFunctionReturns was changed:
|
|
assertEqual "testFunctionsToProcs3" (Just [A.Int]) (Map.lookup "foo" (csFunctionReturns state))
|
|
|
|
-- | Tests a function with multiple returns, and multiple parameters.
|
|
testFunctionsToProcs4 :: Test
|
|
testFunctionsToProcs4 = TestCase $ testPassWithItemsStateCheck "testFunctionsToProcs4 A" exp functionsToProcs orig (return ()) check
|
|
where
|
|
orig = A.Specification m (simpleName "foo") (A.Function m (A.PlainSpec, A.PlainRec) [A.Int,A.Real32]
|
|
[A.Formal A.ValAbbrev A.Byte (simpleName "param0"),A.Formal A.Abbrev A.Real32 (simpleName "param1")] $
|
|
Just $ Right $ A.Seq m $ A.Only m $ A.Assign m [variable "foo"] $ A.ExpressionList m [exprVariable "param0", exprVariable "param1"])
|
|
exp = tag3 A.Specification DontCare (simpleName "foo") procBody
|
|
procBody = tag4 A.Proc DontCare (A.PlainSpec, A.PlainRec) [tag3 A.Formal A.ValAbbrev A.Byte (simpleName "param0"),
|
|
tag3 A.Formal A.Abbrev A.Real32 (simpleName "param1"),
|
|
tag3 A.Formal A.Abbrev A.Int (Named "ret0" DontCare),
|
|
tag3 A.Formal A.Abbrev A.Real32 (Named "ret1" DontCare)] $
|
|
tag2 A.Seq DontCare $
|
|
mOnlyP $
|
|
tag3 A.Assign DontCare [tag2 A.Variable DontCare (Named "ret0" DontCare),tag2 A.Variable DontCare (Named "ret1" DontCare)] $
|
|
tag2 A.ExpressionList DontCare [exprVariable "param0",exprVariable "param1"]
|
|
--check return parameters were defined:
|
|
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.Declaration m A.Int) A.Abbrev A.NameNonce A.Unplaced
|
|
assertVarDef "testFunctionsToProcs4 C" state (A.nameName ret1) $
|
|
tag7 A.NameDef DontCare (A.nameName ret1) (A.nameName ret1)
|
|
(A.Declaration m A.Real32) A.Abbrev A.NameNonce A.Unplaced
|
|
--check proc was defined:
|
|
assertVarDef "testFunctionsToProcs4 D" state "foo" $
|
|
tag7 A.NameDef DontCare ("foo") ("foo")
|
|
procBody A.Original A.NameUser A.Unplaced
|
|
--check csFunctionReturns was changed:
|
|
assertEqual "testFunctionsToProcs4 E" (Just [A.Int,A.Real32]) (Map.lookup "foo" (csFunctionReturns state))
|
|
|
|
|
|
skipP :: A.Structured A.Process
|
|
skipP = A.Only m (A.Skip m)
|
|
|
|
-- | Tests that a simple constructor (with no expression, nor function call) gets converted into the appropriate initialisation code
|
|
testTransformConstr0 :: Test
|
|
testTransformConstr0 = TestCase $ testPass "transformConstr0" exp transformConstr orig startState
|
|
where
|
|
startState :: State CompState ()
|
|
startState = defineConst "x" A.Int (intLiteral 42)
|
|
|
|
t = A.Array [dimension 10] A.Int
|
|
|
|
orig = A.Spec m (A.Specification m (simpleName "arr") $
|
|
A.Is m A.ValAbbrev t $ A.ActualExpression $ A.Literal m t $ A.ArrayListLiteral m $
|
|
A.Spec m (A.Specification m (simpleName "x") (A.Rep m (A.For m (intLiteral 0) (intLiteral 10)
|
|
(intLiteral 1))))
|
|
$ (A.Only m $ exprVariable "x")) skipP
|
|
exp = nameAndStopCaringPattern "indexVar" "i" $ mkPattern exp'
|
|
exp' = A.Spec m (A.Specification m (simpleName "arr") (A.Declaration m t)) $
|
|
A.ProcThen m
|
|
(A.Seq m $ A.Spec m (A.Specification m (simpleName "i")
|
|
(A.Declaration m A.Int)) $
|
|
A.Several m [A.Only m $ A.Assign m [variable "i"] $
|
|
A.ExpressionList m [intLiteral 0],
|
|
A.Spec m (A.Specification m (simpleName "x") $ A.Rep m (A.For m (intLiteral 0) (intLiteral 10) (intLiteral 1))) $
|
|
A.Several m
|
|
[A.Only m $ A.Assign m
|
|
[A.SubscriptedVariable m (A.Subscript m A.NoCheck $
|
|
exprVariable "i") (variable "arr")] $
|
|
A.ExpressionList m [exprVariable "x"],
|
|
A.Only m $ A.Assign m [variable "i"] $ A.ExpressionList m
|
|
[addExprsInt (intLiteral 1) (exprVariable "i")]]
|
|
]
|
|
)
|
|
skipP
|
|
|
|
|
|
testOutExprs :: Test
|
|
testOutExprs = TestList
|
|
[
|
|
-- Test outputting from an expression:
|
|
TestCase $ testPassWithItemsStateCheck "testOutExprs 0"
|
|
(tag2 A.Seq DontCare $ (abbr "temp_var" A.Int (eXM 1))
|
|
(mOnlyP $ tag3 A.Output emptyMeta chan
|
|
[tag2 A.OutExpression emptyMeta (tag2 A.ExprVariable DontCare (tag2 A.Variable DontCare (Named "temp_var" DontCare)))])
|
|
)
|
|
outExprs (
|
|
A.Output emptyMeta chan [outXM 1]
|
|
)
|
|
(defineName (xName) $ simpleDefDecl "x" A.Int)
|
|
(checkTempVarTypes "testOutExprs 0" [("temp_var", A.Int)])
|
|
|
|
-- Test outputting from a variable already:
|
|
,TestCase $ testPass "testOutExprs 1"
|
|
(tag2 A.Seq DontCare $
|
|
(mOnlyP $ tag3 A.Output emptyMeta chan
|
|
[outX])
|
|
)
|
|
outExprs (
|
|
A.Output emptyMeta chan [outX]
|
|
)
|
|
(return ())
|
|
|
|
-- Test outputting from multiple output items:
|
|
,TestCase $ testPassWithItemsStateCheck "testOutExprs 2"
|
|
(tag2 A.Seq DontCare $ (abbr "temp_var0" A.Byte (eXM 1)) $ (abbr "temp_var1" A.Int (intLiteral 2))
|
|
(mOnlyP $ tag3 A.Output emptyMeta chan
|
|
[tag2 A.OutExpression emptyMeta (tag2 A.ExprVariable DontCare (tag2 A.Variable DontCare (Named "temp_var0" DontCare)))
|
|
,mkPattern outX
|
|
,tag2 A.OutExpression emptyMeta (tag2 A.ExprVariable DontCare (tag2 A.Variable DontCare (Named "temp_var1" DontCare)))
|
|
]
|
|
)
|
|
)
|
|
outExprs (
|
|
A.Output emptyMeta chan [outXM 1,outX,A.OutExpression emptyMeta $ intLiteral 2]
|
|
)
|
|
(defineName (xName) $ simpleDefDecl "x" A.Byte)
|
|
(checkTempVarTypes "testOutExprs 2" [("temp_var0", A.Byte),("temp_var1", A.Int)])
|
|
|
|
-- Test an OutCounted
|
|
,TestCase $ testPassWithItemsStateCheck "testOutExprs 3"
|
|
(tag2 A.Seq DontCare $ (abbr "temp_var" A.Byte (eXM 1))
|
|
(mOnlyP $ tag3 A.Output emptyMeta chan
|
|
[tag3 A.OutCounted emptyMeta
|
|
(tag2 A.ExprVariable DontCare (tag2 A.Variable DontCare (Named "temp_var0" DontCare)))
|
|
(exprVariable "x")
|
|
]
|
|
)
|
|
)
|
|
outExprs (
|
|
A.Output emptyMeta chan [A.OutCounted emptyMeta (eXM 1) (exprVariable "x")]
|
|
)
|
|
(defineName (xName) $ simpleDefDecl "x" A.Byte)
|
|
(checkTempVarTypes "testOutExprs 3" [("temp_var", A.Byte)])
|
|
|
|
-- Test that OutputCase is also processed:
|
|
,TestCase $ testPassWithItemsStateCheck "testOutExprs 4"
|
|
(tag2 A.Seq DontCare $ (abbr "temp_var" A.Int (eXM 1))
|
|
(mOnlyP $ tag4 A.OutputCase emptyMeta chan (simpleName "foo")
|
|
[tag2 A.OutExpression emptyMeta (tag2 A.ExprVariable DontCare (tag2 A.Variable DontCare (Named "temp_var" DontCare)))])
|
|
)
|
|
outExprs (
|
|
A.OutputCase emptyMeta chan (simpleName "foo") [outXM 1]
|
|
)
|
|
(defineName (xName) $ simpleDefDecl "x" A.Int)
|
|
(checkTempVarTypes "testOutExprs 3" [("temp_var", A.Int)])
|
|
|
|
-- Test that an empty outputcase works okay:
|
|
|
|
,TestCase $ testPass "testOutExprs 5"
|
|
(tag2 A.Seq DontCare $
|
|
(mOnlyP $ A.OutputCase emptyMeta chan (simpleName "foo") [])
|
|
)
|
|
outExprs (
|
|
A.OutputCase emptyMeta chan (simpleName "foo") []
|
|
)
|
|
(return ())
|
|
|
|
]
|
|
where
|
|
outX = A.OutExpression emptyMeta $ exprVariable "x"
|
|
outXM n = A.OutExpression emptyMeta $ eXM n
|
|
eXM n = buildExpr $ Dy (Var "x") "-" (Lit $ intLiteral n)
|
|
|
|
abbr key t e = mSpecP
|
|
(tag3 A.Specification DontCare (Named key DontCare)
|
|
$ mIs A.ValAbbrev t
|
|
$ mActualExpression' e)
|
|
|
|
chan = variable "c"
|
|
xName = simpleName "x"
|
|
|
|
|
|
testInputCase :: Test
|
|
testInputCase = TestList
|
|
[
|
|
-- Input that only involves tags:
|
|
{-
|
|
The idea is to transform:
|
|
c ? CASE
|
|
a0
|
|
--Process p0
|
|
into:
|
|
SEQ
|
|
INT tag:
|
|
SEQ
|
|
c ? tag
|
|
CASE tag
|
|
a0
|
|
--Process p0
|
|
-}
|
|
testOccamPassTransform "testInputCase 0" (nameAndStopCaringPattern "tag" "A") (
|
|
defineProtocolAndC $
|
|
(oC *? oCASEinput
|
|
[inputCaseOption (a0, [], p0)]
|
|
)
|
|
`becomes`
|
|
oSEQ
|
|
[declNonce (return A.Int) oA
|
|
[oC *? oA
|
|
,oCASE oA
|
|
[caseOption ([0 :: Int], p0)]
|
|
]
|
|
]
|
|
) transformInputCase
|
|
|
|
-- Input that involves multiple tags and multiple inputs:
|
|
{-
|
|
The idea is to transform:
|
|
c ? CASE
|
|
a0
|
|
--Process p0
|
|
c1 ; z
|
|
--Process p1
|
|
b2 ; x ; y
|
|
--Process p2
|
|
into:
|
|
SEQ
|
|
INT tag:
|
|
SEQ
|
|
c ? tag
|
|
CASE tag
|
|
a0
|
|
--Process p0
|
|
c1
|
|
SEQ
|
|
c ? z
|
|
--Process p1
|
|
b2
|
|
SEQ
|
|
c ? x ; y
|
|
--Process p2
|
|
-}
|
|
,testOccamPassTransform "testInputCase 1" (nameAndStopCaringPattern "tag" "A") (
|
|
defineProtocolAndC $
|
|
(oC *? oCASEinput
|
|
[inputCaseOption (a0, [], p0)
|
|
,inputCaseOption (c1, [oZ], p1)
|
|
,inputCaseOption (b2, [oX, oY], p2)
|
|
]
|
|
)
|
|
`becomes`
|
|
oSEQ
|
|
[declNonce (return A.Int) oA
|
|
[oC *? oA
|
|
,oCASE oA
|
|
[caseOption ([0 :: Int], p0)
|
|
,caseOption ([2 :: Int], oSEQ
|
|
[oC *? oZ
|
|
,p1])
|
|
,caseOption ([1 :: Int], oSEQ
|
|
[oC *? sequence [oX, oY]
|
|
,p2])
|
|
]
|
|
]
|
|
]
|
|
) transformInputCase
|
|
|
|
-- Input that involves multiple tags and multiple inputs and specs (sheesh!):
|
|
{-
|
|
The idea is to transform:
|
|
c ? CASE
|
|
a0
|
|
--Process p0
|
|
INT z:
|
|
c1 ; z
|
|
--Process p1
|
|
INT x:
|
|
INT y:
|
|
b2 ; x ; y
|
|
--Process p2
|
|
into:
|
|
SEQ
|
|
INT tag:
|
|
SEQ
|
|
c ? tag
|
|
CASE tag
|
|
a0
|
|
--Process p0
|
|
INT z:
|
|
c1
|
|
SEQ
|
|
c ? z
|
|
--Process p1
|
|
INT x:
|
|
INT y:
|
|
b2
|
|
SEQ
|
|
c ? x ; y
|
|
--Process p2
|
|
-}
|
|
,testOccamPassTransform "testInputCase 2" (nameAndStopCaringPattern "tag" "A") (
|
|
defineProtocolAndC $
|
|
(oC *? oCASEinput
|
|
[inputCaseOption (a0, [], p0)
|
|
,decl (return A.Int) oZ [inputCaseOption (c1, [oZ], p1)]
|
|
,decl (return A.Int) oX
|
|
[decl (return A.Int) oY
|
|
[inputCaseOption (b2, [oX, oY], p2)]]
|
|
]
|
|
)
|
|
`becomes`
|
|
oSEQ
|
|
[declNonce (return A.Int) oA
|
|
[oC *? oA
|
|
,oCASE oA
|
|
[caseOption ([0 :: Int], p0)
|
|
,decl (return A.Int) oZ [caseOption ([2 :: Int], oSEQ
|
|
[oC *? oZ
|
|
,p1])]
|
|
,decl (return A.Int) oX
|
|
[decl (return A.Int) oY
|
|
[caseOption ([1 :: Int], oSEQ
|
|
[oC *? sequence [oX, oY]
|
|
,p2])]]
|
|
]
|
|
]
|
|
]
|
|
) transformInputCase
|
|
|
|
-- Input that only involves tags:
|
|
{-
|
|
The idea is to transform:
|
|
ALT
|
|
c ? CASE
|
|
a0
|
|
--Process p0
|
|
into:
|
|
ALT
|
|
INT tag:
|
|
c ? tag
|
|
CASE tag
|
|
a0
|
|
--Process p0
|
|
-}
|
|
,testOccamPassTransform "testInputCase 100" (nameAndStopCaringPattern "tag" "A") (
|
|
defineProtocolAndC $
|
|
(oALT
|
|
[guard (oC *? oCASEinput
|
|
[inputCaseOption (a0, [], p0)], return $ A.Skip emptyMeta)
|
|
]
|
|
)
|
|
`becomes`
|
|
oALT
|
|
[declNonce (return A.Int) oA
|
|
[guard (oC *? oA,
|
|
oCASE oA
|
|
[caseOption ([0 :: Int], p0)])
|
|
]
|
|
]
|
|
) transformInputCase
|
|
]
|
|
where
|
|
a0 = simpleName "a0"
|
|
b2 = simpleName "b2"
|
|
c1 = simpleName "c1"
|
|
|
|
defineProtocolAndC :: Occ (A.Structured A.Process) -> Occ (A.Structured A.Process)
|
|
defineProtocolAndC =
|
|
decl' (simpleName "prot")
|
|
(A.ProtocolCase emptyMeta [(a0,[]),(b2,[A.Int,A.Int]),(c1,[A.Int])])
|
|
A.Original A.NameUser
|
|
. singleton . decl (return $ A.Chan (A.ChanAttributes A.Unshared A.Unshared)
|
|
(A.UserProtocol $ simpleName "prot")) oC . singleton
|
|
|
|
testTransformProtocolInput :: Test
|
|
testTransformProtocolInput = TestList
|
|
[
|
|
TestCase $ testPass "testTransformProtocolInput0"
|
|
(seqItems [ii0])
|
|
transformProtocolInput (seqItems [ii0])
|
|
(return ())
|
|
,TestCase $ testPass "testTransformProtocolInput1"
|
|
(A.Seq emptyMeta $ A.Several emptyMeta $ map onlySingle [ii0, ii1, ii2])
|
|
transformProtocolInput (seqItems [ii0, ii1, ii2])
|
|
(return ())
|
|
|
|
,TestCase $ testPass "testTransformProtocolInput2"
|
|
(A.Alt emptyMeta False $ onlySingleAlt ii0)
|
|
transformProtocolInput (A.Alt emptyMeta False $ onlySingleAlt ii0)
|
|
(return ())
|
|
|
|
,TestCase $ testPass "testTransformProtocolInput3"
|
|
(A.Alt emptyMeta True $ A.Only emptyMeta $ A.Alternative emptyMeta (A.True
|
|
emptyMeta) (variable "c") (A.InputSimple emptyMeta [ii0]) $
|
|
A.Seq emptyMeta $ A.Several emptyMeta $ onlySingle ii1 : [A.Only emptyMeta $ A.Skip emptyMeta])
|
|
transformProtocolInput (A.Alt emptyMeta True $ A.Only emptyMeta $ altItems [ii0, ii1])
|
|
(return ())
|
|
|
|
,TestCase $ testPass "testTransformProtocolInput4"
|
|
(A.Alt emptyMeta False $ A.Only emptyMeta $ A.Alternative emptyMeta (A.True
|
|
emptyMeta) (variable "c") (A.InputSimple emptyMeta [ii0]) $
|
|
A.Seq emptyMeta $ A.Several emptyMeta $ map onlySingle [ii1,ii2] ++ [A.Only emptyMeta $ A.Skip emptyMeta])
|
|
transformProtocolInput (A.Alt emptyMeta False $ A.Only emptyMeta $ altItems [ii0, ii1, ii2])
|
|
(return ())
|
|
]
|
|
where
|
|
ii0 = A.InVariable emptyMeta (variable "x")
|
|
ii1 = A.InCounted emptyMeta (variable "y") (variable "z")
|
|
ii2 = A.InVariable emptyMeta (variable "a")
|
|
|
|
onlySingle = A.Only emptyMeta . A.Input emptyMeta (variable "c") . A.InputSimple emptyMeta . singleton
|
|
onlySingleAlt = A.Only emptyMeta . flip (A.Alternative emptyMeta (A.True
|
|
emptyMeta) (variable "c")) (A.Skip emptyMeta) . A.InputSimple emptyMeta . singleton
|
|
seqItems = A.Input emptyMeta (variable "c") . A.InputSimple emptyMeta
|
|
altItems = flip (A.Alternative emptyMeta (A.True emptyMeta) (variable "c")) (A.Skip emptyMeta) . A.InputSimple emptyMeta
|
|
|
|
|
|
testPullRepCounts :: Test
|
|
testPullRepCounts = TestList
|
|
[
|
|
testUnchanged 4 $ A.If emptyMeta
|
|
|
|
,forAllThree $ \blockType -> testOccamPassTransform "testPullRepCounts 5" (nameAndStopCaringPattern "nonce" "A")
|
|
(blockType
|
|
[decl' (simpleName "X")
|
|
(A.Rep emptyMeta (A.For emptyMeta (intLiteral 0) (intLiteral 6) (intLiteral 1)))
|
|
A.Original A.NameUser []
|
|
]
|
|
`becomes`
|
|
blockType
|
|
[decl' (simpleName "A")
|
|
(A.Is emptyMeta A.ValAbbrev A.Int $ A.ActualExpression $ intLiteral 6) A.ValAbbrev A.NameNonce
|
|
[decl' (simpleName "X")
|
|
(A.Rep emptyMeta (A.For emptyMeta (intLiteral 0) (exprVariable "A") (intLiteral 1)))
|
|
A.Original A.NameUser []
|
|
]
|
|
]
|
|
) pullRepCounts
|
|
|
|
,forAllThree $ \blockType -> testOccamPassTransform "testPullRepCounts 6"
|
|
(nameAndStopCaringPattern "nonce1" "A" . nameAndStopCaringPattern "nonce2" "B")
|
|
(blockType
|
|
[decl' (simpleName "X")
|
|
(A.Rep emptyMeta (A.For emptyMeta (intLiteral 0) (intLiteral 6) (intLiteral 1)))
|
|
A.Original A.NameUser
|
|
[decl' (simpleName "Y")
|
|
(A.Rep emptyMeta (A.For emptyMeta (intLiteral 1) (intLiteral 8) (intLiteral 2)))
|
|
A.Original A.NameUser []
|
|
]
|
|
]
|
|
`becomes`
|
|
blockType
|
|
[decl' (simpleName "A")
|
|
(A.Is emptyMeta A.ValAbbrev A.Int $ A.ActualExpression $ intLiteral 6) A.ValAbbrev A.NameNonce
|
|
[decl' (simpleName "X")
|
|
(A.Rep emptyMeta (A.For emptyMeta (intLiteral 0) (exprVariable "A") (intLiteral 1)))
|
|
A.Original A.NameUser
|
|
[decl' (simpleName "B")
|
|
(A.Is emptyMeta A.ValAbbrev A.Int $ A.ActualExpression $ intLiteral 8) A.ValAbbrev A.NameNonce
|
|
[decl' (simpleName "Y")
|
|
(A.Rep emptyMeta (A.For emptyMeta (intLiteral 1) (exprVariable "B")
|
|
(intLiteral 2)))
|
|
A.Original A.NameUser
|
|
[]
|
|
]
|
|
]
|
|
]
|
|
]
|
|
) pullRepCounts
|
|
]
|
|
where
|
|
-- Not for PAR any more, that gets pulled up further
|
|
forAllThree :: (forall a. Data a => ([Occ (A.Structured a)] -> Occ A.Process) -> Test) -> Test
|
|
forAllThree f = TestList [f oSEQ, f oALT]
|
|
|
|
testUnchanged :: Data a => Int -> (A.Structured a -> A.Process) -> Test
|
|
testUnchanged n f = TestCase $ testPass
|
|
("testPullRepCounts/testUnchanged " ++ show n)
|
|
code
|
|
pullRepCounts code
|
|
(return ())
|
|
where
|
|
code = (f $ A.Spec emptyMeta (A.Specification emptyMeta (simpleName
|
|
"i") $ A.Rep emptyMeta (A.For emptyMeta (intLiteral 0) (intLiteral 5)
|
|
(intLiteral 1))) $ A.Several emptyMeta [])
|
|
|
|
|
|
testRemoveNesting :: Test
|
|
testRemoveNesting = TestList
|
|
[
|
|
test "Blank PROC" $
|
|
oPROC "foo" [] (
|
|
oSKIP
|
|
) oempty
|
|
|
|
, test "Nested PROC" $
|
|
(oPROC "bar" [] (
|
|
oSEQ
|
|
[decl oINT oX []]
|
|
) $
|
|
oPROC "foo" [] (
|
|
oSEQ
|
|
[decl oINT oX $
|
|
[oX *:= return (0::Int)
|
|
,oX *:= return (1::Int)]]
|
|
) oempty)
|
|
`shouldComeFrom`
|
|
oPROC "foo" [] (
|
|
oSEQ
|
|
[oPROC "bar" [] (
|
|
oSEQ
|
|
[decl oINT oX []]
|
|
) $
|
|
decl oINT oX
|
|
[oX *:= return (0::Int)
|
|
,oX *:= return (1::Int)]]
|
|
) oempty
|
|
]
|
|
where
|
|
test :: String -> Occ A.AST -> Test
|
|
test name x = testOccamPass name x removeNesting
|
|
|
|
|
|
--Returns the list of tests:
|
|
tests :: Test
|
|
tests = TestLabel "PassTest" $ TestList
|
|
[
|
|
testFunctionsToProcs0
|
|
,testFunctionsToProcs1
|
|
,testFunctionsToProcs2
|
|
,testFunctionsToProcs3
|
|
,testFunctionsToProcs4
|
|
,testInputCase
|
|
,testOutExprs
|
|
,testPullRepCounts
|
|
,testRemoveNesting
|
|
,testTransformConstr0
|
|
,testTransformProtocolInput
|
|
]
|
|
|
|
|