b1416bb0cf
This touches an awful lot of code, but cgtest07/17 (arrays and retyping) pass. This is useful because there are going to be places in the future where we'll want to represent dimensions that are known at runtime but not at compile time -- for example, mobile allocations, or dynamically-sized arrays. It simplifies the code in a number of places. However, we do now need to be careful that expressions containing variables do not leak into the State, since they won't be affected by later passes. Two caveats (marked as FIXMEs in the source): - Retypes checking in the occam parser is disabled, since the plan is to move it out to a pass anyway. - There's some (now very obvious) duplication, particularly in the backend, of bits of code that construct expressions for the total size of an array (either in bytes or elements); this should be moved to a couple of helper functions that everything can use.
1182 lines
67 KiB
Haskell
1182 lines
67 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/>.
|
|
-}
|
|
|
|
-- #ignore-exports
|
|
|
|
-- | Tests for the C and C++ backends
|
|
--
|
|
-- The testing strategy is as follows. The way we have implemented the C and C++ backends is
|
|
-- to have a dictionary of functions 'GenerateC.GenOps' that is used for (mutually) recursive
|
|
-- calls. We can take advantage of this during testing. For example, we have a test that
|
|
-- tests genArraySubscript directly. When we test genVariableChecked, we don't want to have
|
|
-- to effectively check parts of genArraySubscript again. So we can \"override\" the
|
|
-- genArraySubscript to return a dummy value, and then we are effectively testing
|
|
-- that genVariableChecked calls genArraySubscript at the appropriate point. This is similar
|
|
-- to a testing technique in OOP where one might take a class and override some methods to
|
|
-- do a similar trick.
|
|
module GenerateCTest (tests) where
|
|
|
|
import Control.Monad.State
|
|
import Control.Monad.Reader
|
|
import Data.Generics
|
|
import Data.List (isInfixOf, intersperse)
|
|
import Data.Maybe (fromMaybe)
|
|
import Test.HUnit hiding (State)
|
|
import Text.Regex
|
|
|
|
import qualified AST as A
|
|
import CompState
|
|
import Errors
|
|
import GenerateC
|
|
import GenerateCBased
|
|
import GenerateCPPCSP
|
|
import Metadata
|
|
import Pass
|
|
import TestUtils
|
|
import Utils
|
|
|
|
-- | A few helper functions for writing certain characters (that won't appear in our generated C/C++ source)
|
|
-- to the WriterT monad. Useful as simple placeholders/special values during testers.
|
|
at :: CGen ()
|
|
at = tell ["@"]
|
|
|
|
dollar :: CGen ()
|
|
dollar = tell ["$"]
|
|
|
|
caret :: CGen ()
|
|
caret = tell ["^"]
|
|
|
|
hash :: CGen ()
|
|
hash = tell ["#"]
|
|
|
|
-- | A few easy helpers for name variables for testing.
|
|
foo :: A.Name
|
|
foo = simpleName "foo"
|
|
|
|
bar:: A.Name
|
|
bar = simpleName "bar"
|
|
|
|
bar2 :: A.Name
|
|
bar2 = simpleName "bar2"
|
|
|
|
-- | Asserts that the given output of a CGen pass matches the expected value.
|
|
assertGen :: String -> String -> IO (Either Errors.ErrorReport [String]) -> Assertion
|
|
assertGen n exp act
|
|
= do r <- act
|
|
case r of
|
|
Left (_,err) -> assertFailure $ n ++ " pass failed, error: " ++ err
|
|
Right ss -> assertEqual n exp (subRegex (mkRegex "/\\*\\*/") (concat ss) "")
|
|
|
|
-- | Asserts that the given output of a CGen pass matches the expected regex, and returns the matched groups.
|
|
assertGenR :: String -> String -> IO (Either Errors.ErrorReport [String]) -> IO [String]
|
|
assertGenR n exp act
|
|
= do r <- act
|
|
case r of
|
|
Left (_,err) -> (assertFailure $ n ++ " pass failed, error: " ++ err) >> return []
|
|
Right ss ->
|
|
case matchRegex (mkRegex exp) (subRegex (mkRegex "/\\*\\*/") (concat ss) "") of
|
|
Just matches -> return matches
|
|
Nothing -> (assertFailure $ n ++ " regex match failed, regex: \"" ++ exp ++ "\" text: " ++ (concat ss)) >> return []
|
|
|
|
|
|
-- | Asserts that the given output of a CGen pass is a failure
|
|
assertGenFail :: String -> IO (Either Errors.ErrorReport [String]) -> Assertion
|
|
assertGenFail n act
|
|
= do r <- act
|
|
case r of
|
|
Left _ -> return ()
|
|
Right ss -> if isInfixOf "#error" (concat ss)
|
|
then return ()
|
|
else assertFailure $ n ++ " pass succeeded when expected to fail, output: " ++ (subRegex (mkRegex "/\\*\\*/") (concat ss) "")
|
|
|
|
evalCGen :: CGen () -> GenOps -> CompState -> IO (Either Errors.ErrorReport [String])
|
|
evalCGen act ops state = evalCGen' (runReaderT act ops) state
|
|
|
|
evalCGen' :: CGen' () -> CompState -> IO (Either Errors.ErrorReport [String])
|
|
evalCGen' act state = runPassM (execStateT act (Left []) >>* (\(Left x) -> x)) state >>* transformEither id (\(x,_,_) -> x)
|
|
|
|
-- | Checks that running the test for the C and C++ backends produces the right output for each.
|
|
testBothS ::
|
|
String -- ^ Test Name
|
|
-> String -- ^ C expected
|
|
-> String -- ^ C++ expected
|
|
-> CGen () -- ^ Actual
|
|
-> (State CompState ()) -- ^ State transformation
|
|
-> Test
|
|
|
|
testBothS testName expC expCPP act startState = TestList
|
|
[TestCase $ assertGen (testName ++ "/C") expC $ evalCGen act cgenOps state
|
|
,TestCase $ assertGen (testName ++ "/C++") expCPP $ evalCGen act cppgenOps state]
|
|
where
|
|
state = execState startState emptyState
|
|
|
|
-- | Checks that both the C and C++ backends fail on the given input.
|
|
testBothFailS :: String -> CGen () -> (State CompState ()) -> Test
|
|
testBothFailS testName act startState = TestList
|
|
[TestCase $ assertGenFail (testName ++ "/C") (evalCGen act cgenOps state)
|
|
,TestCase $ assertGenFail (testName ++ "/C++") (evalCGen act cppgenOps state) ]
|
|
where
|
|
state = execState startState emptyState
|
|
|
|
-- | Checks that the given output of a backend satisfies the given regex, and returns the matched groups.
|
|
testRS :: String -> String -> CGen' () -> State CompState () -> IO [String]
|
|
testRS testName exp act startState = assertGenR testName exp (evalCGen' act state)
|
|
where
|
|
state = execState startState emptyState
|
|
|
|
-- | Like testBothS, but with the output of the C and C++ backends the same.
|
|
testBothSameS ::
|
|
String -- ^ Test Name
|
|
-> String -- ^ C and C++ expected
|
|
-> CGen () -- ^ Actual
|
|
-> (State CompState ()) -- ^ State transformation
|
|
-> Test
|
|
testBothSameS n e a s = testBothS n e e a s
|
|
|
|
-- | Checks that the output of the test matches the given regexes for C and C++
|
|
testBothR ::
|
|
String -- ^ Test Name
|
|
-> String -- ^ C expected
|
|
-> String -- ^ C++ expected
|
|
-> CGen () -- ^ Actual
|
|
-> Test
|
|
testBothR n eC eCPP a = TestList
|
|
[TestCase $ (testRS n eC (runReaderT a cgenOps) (return ())) >> return ()
|
|
,TestCase $ (testRS n eCPP (runReaderT a cppgenOps) (return ())) >> (return ())]
|
|
|
|
-- | Like testBothR, but where the output of the C and C++ passes is expected to be the same.
|
|
testBothSameR :: String -> String -> CGen () -> Test
|
|
testBothSameR n e a = testBothR n e e a
|
|
|
|
-- | Like testBothFailS, but with the default beginning state.
|
|
testBothFail :: String -> CGen () -> Test
|
|
testBothFail a b = testBothFailS a b (return ())
|
|
|
|
-- | Like testBothS, but with the default beginning state.
|
|
testBoth :: String -> String -> String -> CGen () -> Test
|
|
testBoth a b c d = testBothS a b c d (return ())
|
|
|
|
-- | Like testBothSameS, but with the default beginning state.
|
|
testBothSame :: String -> String -> CGen () -> Test
|
|
testBothSame a b c = testBothSameS a b c (return ())
|
|
|
|
-- | These functions are here for a historical reason, and are all defined
|
|
-- to be call.
|
|
tcall, tcall2, tcall3, tcall4, tcall5 :: CGenCall a => (GenOps -> a) -> a
|
|
tcall = call
|
|
tcall2 = call
|
|
tcall3 = call
|
|
tcall4 = call
|
|
tcall5 = call
|
|
|
|
type Override = CGen () -> CGen ()
|
|
|
|
-- | Overrides a specified function in GenOps to return the given value
|
|
override1 ::
|
|
b -- ^ The value to return for the overridden function
|
|
-> (a -> b) -- ^ The resulting overriden function
|
|
override1 val = (\_ -> val)
|
|
|
|
override2 :: b -> (a0 -> a1 -> b)
|
|
override2 val = (\_ _ -> val)
|
|
|
|
override3 :: b -> (a0 -> a1 -> a2 -> b)
|
|
override3 val = (\_ _ _ -> val)
|
|
|
|
override4 :: b -> (a0 -> a1 -> a2 -> a3 -> b)
|
|
override4 val = (\_ _ _ _ -> val)
|
|
|
|
override5 :: b -> (a0 -> a1 -> a2 -> a3 -> a4 -> b)
|
|
override5 val = (\_ _ _ _ _ -> val)
|
|
|
|
testGenType :: Test
|
|
testGenType = TestList
|
|
[
|
|
testBothSame "GenType 0" "uint8_t" (tcall genType A.Byte)
|
|
,testBothSame "GenType 1" "uint16_t" (tcall genType A.UInt16)
|
|
,testBothSame "GenType 2" "uint32_t" (tcall genType A.UInt32)
|
|
,testBothSame "GenType 3" "uint64_t" (tcall genType A.UInt64)
|
|
,testBothSame "GenType 4" "int8_t" (tcall genType A.Int8)
|
|
,testBothSame "GenType 5" "int16_t" (tcall genType A.Int16)
|
|
,testBothSame "GenType 6" "int32_t" (tcall genType A.Int32)
|
|
,testBothSame "GenType 7" "int64_t" (tcall genType A.Int64)
|
|
,testBothSame "GenType 8" "int" (tcall genType A.Int)
|
|
,testBothSame "GenType 9" "bool" (tcall genType A.Bool)
|
|
,testBothSame "GenType 10" "float" (tcall genType A.Real32)
|
|
,testBothSame "GenType 11" "double" (tcall genType A.Real64)
|
|
|
|
,testBothSame "GenType 20" "uint8_t*" (tcall genType $ A.Mobile A.Byte)
|
|
,testBothSame "GenType 21" "bool*" (tcall genType $ A.Mobile A.Bool)
|
|
,testBothSame "GenType 22" "float*" (tcall genType $ A.Mobile A.Real32)
|
|
|
|
|
|
,testBothSame "GenType 100" "int*" (tcall genType $ A.Array [dimension 5] A.Int)
|
|
,testBothSame "GenType 101" "int*" (tcall genType $ A.Array [dimension 5, dimension 2, dimension 9] A.Int)
|
|
,testBothSame "GenType 102" "int*" (tcall genType $ A.Array [dimension 5, A.UnknownDimension] A.Int)
|
|
,testBothSame "GenType 103" "foo" (tcall genType $ A.Record (simpleName "foo"))
|
|
,testBoth "GenType 200" "Time" "csp::Time" (tcall genType A.Time)
|
|
,testBoth "GenType 201" "Time" "csp::Time" (tcall genType A.Timer)
|
|
|
|
,testBothSame "GenType 250" "int*" (tcall genType $ A.Mobile $ A.Array [dimension 5, dimension 2, dimension 9] A.Int)
|
|
,testBothSame "GenType 251" "int*" (tcall genType $ A.Mobile $ A.Array [dimension 5, A.UnknownDimension] A.Int)
|
|
,testBothSame "GenType 251" "int*" (tcall genType $ A.Mobile $ A.Array [A.UnknownDimension] A.Int)
|
|
,testBothSame "GenType 252" "foo*" (tcall genType $ A.Mobile $ A.Record (simpleName "foo"))
|
|
,testBoth "GenType 253" "Time*" "csp::Time*" (tcall genType $ A.Mobile A.Time)
|
|
|
|
,testBoth "GenType 300" "Channel" "csp::One2OneChannel<int>" (tcall genType $ A.Chan A.DirUnknown (A.ChanAttributes False False) A.Int)
|
|
,testBoth "GenType 301" "Channel" "csp::One2AnyChannel<int>" (tcall genType $ A.Chan A.DirUnknown (A.ChanAttributes False True) A.Int)
|
|
,testBoth "GenType 302" "Channel" "csp::Any2OneChannel<int>" (tcall genType $ A.Chan A.DirUnknown (A.ChanAttributes True False) A.Int)
|
|
,testBoth "GenType 303" "Channel" "csp::Any2AnyChannel<int>" (tcall genType $ A.Chan A.DirUnknown (A.ChanAttributes True True) A.Int)
|
|
|
|
,testBoth "GenType 310" "Channel" "csp::One2OneChannel<int*>" (tcall genType $ A.Chan A.DirUnknown (A.ChanAttributes False False) (A.Mobile A.Int))
|
|
|
|
,testBoth "GenType 400" "Channel*" "csp::Chanin<int>" (tcall genType $ A.Chan A.DirInput (A.ChanAttributes False False) A.Int)
|
|
,testBoth "GenType 401" "Channel*" "csp::Chanin<int>" (tcall genType $ A.Chan A.DirInput (A.ChanAttributes False True) A.Int)
|
|
|
|
,testBoth "GenType 402" "Channel*" "csp::Chanout<int>" (tcall genType $ A.Chan A.DirOutput (A.ChanAttributes False False) A.Int)
|
|
,testBoth "GenType 403" "Channel*" "csp::Chanout<int>" (tcall genType $ A.Chan A.DirOutput (A.ChanAttributes True False) A.Int)
|
|
|
|
--ANY and protocols cannot occur outside channels in C++ or C, they are tested here:
|
|
,testBothFail "GenType 500" (tcall genType $ A.Any)
|
|
,testBothFail "GenType 600" (tcall genType $ A.UserProtocol (simpleName "foo"))
|
|
,testBothFail "GenType 650" (tcall genType $ A.Counted A.Int A.Int)
|
|
|
|
,testBoth "GenType 700" "Channel**" "csp::One2OneChannel<int>**" (tcall genType $ A.Array [dimension 5] $ A.Chan A.DirUnknown (A.ChanAttributes False False) A.Int)
|
|
,testBoth "GenType 701" "Channel**" "csp::Chanin<int>*" (tcall genType $ A.Array [dimension 5] $ A.Chan A.DirInput (A.ChanAttributes False False) A.Int)
|
|
|
|
--Test types that can only occur inside channels:
|
|
--ANY:
|
|
,testBoth "GenType 800" "Channel" "csp::One2OneChannel<tockSendableArrayOfBytes>" (tcall genType $ A.Chan A.DirUnknown (A.ChanAttributes False False) A.Any)
|
|
--Protocol:
|
|
,testBoth "GenType 900" "Channel" "csp::One2OneChannel<tockSendableArrayOfBytes>" (tcall genType $ A.Chan A.DirUnknown (A.ChanAttributes False False) $ A.UserProtocol (simpleName "foo"))
|
|
--Counted:
|
|
,testBoth "GenType 1000" "Channel" "csp::One2OneChannel<tockSendableArrayOfBytes>" (tcall genType $ A.Chan A.DirUnknown (A.ChanAttributes False False) $ A.Counted A.Int A.Int)
|
|
|
|
--Channels of arrays are special in C++:
|
|
,testBoth "GenType 1100" "Channel" "csp::One2OneChannel<tockSendableArray<int,6>>"
|
|
(tcall genType $ A.Chan A.DirUnknown (A.ChanAttributes False False) $ A.Array [dimension 6] A.Int)
|
|
,testBoth "GenType 1101" "Channel" "csp::One2OneChannel<tockSendableArray<int,6*7*8>>"
|
|
(tcall genType $ A.Chan A.DirUnknown (A.ChanAttributes False False) $ A.Array [dimension 6,dimension 7,dimension 8] A.Int)
|
|
|
|
|
|
-- List types:
|
|
,testBothS "GenType 2000" "ListInt16" "tockList<int16_t>" (tcall genType $ A.List A.Int16) markRainTest
|
|
,testBothS "GenType 2001" "ListListInt16" "tockList<tockList<int16_t>>" (tcall genType $ A.List $ A.List A.Int16) markRainTest
|
|
,testBothS "GenType 2010" "ListInt16*" "tockList<int16_t>" (tcall genType $ A.Mobile $ A.List A.Int16) markRainTest
|
|
,testBothS "GenType 2011" "ListListInt16*" "tockList<tockList<int16_t>>" (tcall genType $ A.Mobile $ A.List $ A.List A.Int16) markRainTest
|
|
,testBothS "GenType 2012" "ListMobileListInt16*" "tockList<tockList<int16_t>>" (tcall genType $ A.Mobile $ A.List $ A.Mobile $ A.List A.Int16) markRainTest
|
|
]
|
|
|
|
testStop :: Test
|
|
testStop =
|
|
testBoth "Stop" "occam_stop(\"foo:4:9\",1,\"bar\");" "throw StopException(\"foo:4:9\" \"bar\");" (tcall2 genStop (Meta (Just "foo") 4 9) "bar")
|
|
|
|
testArraySizes :: Test
|
|
testArraySizes = TestList
|
|
[
|
|
testBothSame "genArrayLiteralElems 0" "$" $ unfolded (tcall genArrayLiteralElems [A.ArrayElemExpr undefined])
|
|
,testBothSame "genArrayLiteralElems 1" "$,$,$" $ unfolded (tcall genArrayLiteralElems [A.ArrayElemExpr undefined, A.ArrayElemExpr undefined, A.ArrayElemExpr undefined])
|
|
,testBothSame "genArrayLiteralElems 2" "$,$,$" $ unfolded (tcall genArrayLiteralElems [A.ArrayElemExpr undefined, A.ArrayElemArray [A.ArrayElemExpr undefined, A.ArrayElemExpr undefined]])
|
|
]
|
|
where
|
|
unfolded :: Override
|
|
unfolded = local (\ops -> ops {genUnfoldedExpression = override1 dollar})
|
|
|
|
testActuals :: Test
|
|
testActuals = TestList
|
|
[
|
|
-- C adds a prefix comma (to follow Process* me) but C++ does not:
|
|
testBoth "genActuals 0" ",@,@" "@,@" $ overActual (tcall genActuals [undefined, undefined])
|
|
,testBothSame "genActuals 1" "" $ (tcall genActuals [])
|
|
|
|
--For expressions, genExpression should be called:
|
|
,testBothSame "genActual 0" "$" $ over (tcall genActual $ A.ActualExpression A.Bool (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)))
|
|
(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)))
|
|
(defineName foo $ simpleDefDecl "foo" A.Int)
|
|
]
|
|
where
|
|
overActual :: Override
|
|
overActual = local (\ops -> ops {genActual = override1 at})
|
|
over :: Override
|
|
over = local (\ops -> ops {genVariable = override1 at, genExpression = override1 dollar})
|
|
|
|
-- TODO test the other two array checking methods
|
|
testArraySubscript :: Test
|
|
testArraySubscript = TestList
|
|
[
|
|
testBothSameS "genArraySubscript 0" "[5*foo_sizes[1]*foo_sizes[2]]"
|
|
(tcall3 genArraySubscript A.NoCheck (A.Variable emptyMeta foo) [lit 5]) stateTrans
|
|
,testBothSameS "genArraySubscript 1" "[5*foo_sizes[1]*foo_sizes[2]+6*foo_sizes[2]]"
|
|
(tcall3 genArraySubscript A.NoCheck (A.Variable emptyMeta foo) [lit 5, lit 6]) stateTrans
|
|
,testBothSameS "genArraySubscript 2" "[5*foo_sizes[1]*foo_sizes[2]+6*foo_sizes[2]+7]"
|
|
(tcall3 genArraySubscript A.NoCheck (A.Variable emptyMeta foo) [lit 5, lit 6, lit 7]) stateTrans
|
|
|
|
,testBothSameS "genArraySubscript 3" ("[occam_check_index(5,foo_sizes[0]," ++ m ++ ")*foo_sizes[1]*foo_sizes[2]]")
|
|
(tcall3 genArraySubscript A.CheckBoth (A.Variable emptyMeta foo) [lit 5]) stateTrans
|
|
,testBothSameS "genArraySubscript 4"
|
|
("[occam_check_index(5,foo_sizes[0]," ++ m ++ ")*foo_sizes[1]*foo_sizes[2]+occam_check_index(6,foo_sizes[1]," ++ m ++ ")*foo_sizes[2]]")
|
|
(tcall3 genArraySubscript A.CheckBoth (A.Variable emptyMeta foo) [lit 5, lit 6]) stateTrans
|
|
,testBothSameS "genArraySubscript 5"
|
|
("[occam_check_index(5,foo_sizes[0]," ++ m ++ ")*foo_sizes[1]*foo_sizes[2]+occam_check_index(6,foo_sizes[1]," ++ m ++ ")*foo_sizes[2]+occam_check_index(7,foo_sizes[2]," ++ m ++ ")]")
|
|
(tcall3 genArraySubscript A.CheckBoth (A.Variable emptyMeta foo) [lit 5, lit 6, lit 7]) stateTrans
|
|
|
|
]
|
|
where
|
|
stateTrans :: CSM m => m ()
|
|
stateTrans = defineName (simpleName "foo") $ simpleDefDecl "foo" (A.Array [dimension 7,dimension 8,dimension 8] A.Int)
|
|
m = "\"" ++ show emptyMeta ++ "\""
|
|
|
|
lit :: Int -> (Meta, CGen ())
|
|
lit n = (emptyMeta, tell [show n])
|
|
|
|
testArraySlice :: Test
|
|
testArraySlice = TestList
|
|
[
|
|
-- Slice from a one-dimensional array:
|
|
testSlice 0 ("(&arr[" ++ checkSlice "4" "5" "12" ++ "])") "arr" 4 5 [dimension 12]
|
|
|
|
-- Slice from a two-dimensional array:
|
|
,testSlice 1 ("(&arr[" ++ checkSlice "4" "5" "12" ++ "*arr_sizes[1]])") "arr" 4 5 [dimension 12,dimension 12]
|
|
|
|
-- Slice from a three-dimensional array:
|
|
,testSlice 2 ("(&arr[" ++ checkSlice "4" "5" "12" ++ "*arr_sizes[1]*arr_sizes[2]])") "arr" 4 5 [dimension 12,dimension 12,dimension 12]
|
|
|
|
-- TODO test with unknown dimensions
|
|
]
|
|
where
|
|
testSlice :: Int -> String -> String -> Integer -> Integer -> [A.Dimension] -> Test
|
|
testSlice index exp nm start count ds
|
|
= testBothSameS ("genSlice " ++ show index) exp
|
|
(tcall genVariable
|
|
(A.SubscriptedVariable emptyMeta (A.SubscriptFromFor emptyMeta (intLiteral start) (intLiteral count)) (variable nm))
|
|
)
|
|
(defineName (simpleName nm) $ simpleDefDecl nm (A.Array ds A.Int))
|
|
|
|
m = "\"" ++ show emptyMeta ++ "\""
|
|
|
|
checkSlice s e sub = "occam_check_slice(" ++ s ++ "," ++ e ++ "," ++ sub ++ "," ++ m ++ ")"
|
|
|
|
-- TODO fix this test so that it tests fixed dimensions properly
|
|
testOverArray :: Test
|
|
testOverArray = TestList $ map testOverArray'
|
|
[(cSize,cIndex,"", cgenOps)
|
|
,(cSize,cIndex,"", cppgenOps)
|
|
]
|
|
where
|
|
cSize n = "_sizes\\[" ++ show n ++ "\\]"
|
|
|
|
cIndex x = "\\[" ++ concat (intersperse "\\+" $ map cIndex' x) ++ "\\]"
|
|
cIndex' :: (String,[Int]) -> String
|
|
cIndex' (s,ns) = s ++ concat (map (\n -> "\\*foo" ++ cSize n) ns)
|
|
|
|
testOverArray' :: ((Int -> String),[(String,[Int])] -> String,String, GenOps) -> Test
|
|
testOverArray' (sz,f',suff,ops) = TestCase $
|
|
do testRS "testOverArray'" rx1Static (flip runReaderT ops $ tcall3 genOverArray emptyMeta (A.Variable emptyMeta foo) func) state1Static
|
|
testRS "testOverArray'" rx1Dynamic (flip runReaderT ops $ tcall3 genOverArray emptyMeta (A.Variable emptyMeta foo) func) state1Dynamic
|
|
testRS "testOverArray'" rx3Static (flip runReaderT ops $ tcall3 genOverArray emptyMeta (A.Variable emptyMeta foo) func) state3Static
|
|
testRS "testOverArray'" rx3Dynamic (flip runReaderT ops $ tcall3 genOverArray emptyMeta (A.Variable emptyMeta foo) func) state3Dynamic
|
|
return ()
|
|
where
|
|
func f = Just $ call genVariableUnchecked (f $ A.Variable emptyMeta foo) >> tell [";"]
|
|
rx1Static = "^for\\(int ([[:alnum:]_]+)=0;\\1<7;\\1\\+\\+)\\{foo\\[\\1\\]" ++ suff ++ ";\\}$"
|
|
rx1Dynamic = "^for\\(int ([[:alnum:]_]+)=0;\\1<foo" ++ sz 0 ++ ";\\1\\+\\+)\\{foo\\[\\1\\]" ++ suff ++ ";\\}$"
|
|
rx3Static
|
|
= "^for\\(int ([[:alnum:]_]+)=0;\\1<7;\\1\\+\\+)\\{" ++
|
|
"for\\(int ([[:alnum:]_]+)=0;\\2<8;\\2\\+\\+)\\{" ++
|
|
"for\\(int ([[:alnum:]_]+)=0;\\3<9;\\3\\+\\+)\\{" ++
|
|
"foo" ++ (f' [("\\1",[1,2]),("\\2",[2]),("\\3",[])]) ++ suff ++ ";\\}\\}\\}$"
|
|
rx3Dynamic
|
|
= "^for\\(int ([[:alnum:]_]+)=0;\\1<foo" ++ sz 0 ++ ";\\1\\+\\+)\\{" ++
|
|
"for\\(int ([[:alnum:]_]+)=0;\\2<8;\\2\\+\\+)\\{" ++
|
|
"for\\(int ([[:alnum:]_]+)=0;\\3<foo" ++ sz 2 ++ ";\\3\\+\\+)\\{" ++
|
|
"foo" ++ (f' [("\\1",[1,2]),("\\2",[2]),("\\3",[])]) ++ suff ++ ";\\}\\}\\}$"
|
|
state1Static :: CSM m => m ()
|
|
state1Static = defineName (simpleName "foo") $ simpleDefDecl "foo" (A.Array [dimension 7] A.Int)
|
|
state1Dynamic :: CSM m => m ()
|
|
state1Dynamic = defineName (simpleName "foo") $ simpleDefDecl "foo" (A.Array [A.UnknownDimension] A.Int)
|
|
state3Static :: CSM m => m ()
|
|
state3Static = defineName (simpleName "foo") $ simpleDefDecl "foo" (A.Array [dimension 7, dimension 8, dimension 9] A.Int)
|
|
state3Dynamic :: CSM m => m ()
|
|
state3Dynamic = defineName (simpleName "foo") $ simpleDefDecl "foo" (A.Array [A.UnknownDimension, dimension 8, A.UnknownDimension] A.Int)
|
|
|
|
testReplicator :: Test
|
|
testReplicator = TestList
|
|
[
|
|
testBothSame "testReplicator 0" "for(int foo=0;foo<10;foo++){@}" (tcall2 genReplicator (A.For emptyMeta foo (intLiteral 0) (intLiteral 10)) at)
|
|
,testBothSameR "testReplicator 1" "for\\(int ([[:alnum:]_]+)=10,foo=1;\\1>0;\\1--,foo\\+\\+\\)\\{@\\}" (tcall2 genReplicator (A.For emptyMeta foo (intLiteral 1) (intLiteral 10)) at)
|
|
]
|
|
|
|
testDeclaration :: Test
|
|
testDeclaration = TestList
|
|
[
|
|
--Simple:
|
|
testBothSame "genDeclaration 0" "int foo;" (tcall3 genDeclaration A.Int foo False)
|
|
|
|
--Channels and channel-ends:
|
|
,testBoth "genDeclaration 1" "Channel foo;" "csp::One2OneChannel<int> foo;" (tcall3 genDeclaration (A.Chan A.DirUnknown (A.ChanAttributes False False) A.Int) foo False)
|
|
,testBoth "genDeclaration 2" "Channel foo;" "csp::Any2OneChannel<int> foo;" (tcall3 genDeclaration (A.Chan A.DirUnknown (A.ChanAttributes True False) A.Int) foo False)
|
|
,testBoth "genDeclaration 3" "Channel foo;" "csp::One2AnyChannel<int> foo;" (tcall3 genDeclaration (A.Chan A.DirUnknown (A.ChanAttributes False True) A.Int) foo False)
|
|
,testBoth "genDeclaration 4" "Channel foo;" "csp::Any2AnyChannel<int> foo;" (tcall3 genDeclaration (A.Chan A.DirUnknown (A.ChanAttributes True True) A.Int) foo False)
|
|
,testBoth "genDeclaration 5" "Channel* foo;" "csp::Chanin<int> foo;" (tcall3 genDeclaration (A.Chan A.DirInput (A.ChanAttributes False False) A.Int) foo False)
|
|
,testBoth "genDeclaration 6" "Channel* foo;" "csp::Chanin<int> foo;" (tcall3 genDeclaration (A.Chan A.DirInput (A.ChanAttributes False True) A.Int) foo False)
|
|
,testBoth "genDeclaration 7" "Channel* foo;" "csp::Chanout<int> foo;" (tcall3 genDeclaration (A.Chan A.DirOutput (A.ChanAttributes False False) A.Int) foo False)
|
|
,testBoth "genDeclaration 8" "Channel* foo;" "csp::Chanout<int> foo;" (tcall3 genDeclaration (A.Chan A.DirOutput (A.ChanAttributes True False) A.Int) foo False)
|
|
|
|
--Arrays (of simple):
|
|
,testBothSame "genDeclaration 100" "int foo[8];"
|
|
(tcall3 genDeclaration (A.Array [dimension 8] A.Int) foo False)
|
|
,testBothSame "genDeclaration 101" "int foo[8*9];"
|
|
(tcall3 genDeclaration (A.Array [dimension 8,dimension 9] A.Int) foo False)
|
|
,testBothSame "genDeclaration 102" "int foo[8*9*10];"
|
|
(tcall3 genDeclaration (A.Array [dimension 8,dimension 9,dimension 10] A.Int) foo False)
|
|
|
|
--Arrays (of simple) inside records:
|
|
,testBothSame "genDeclaration 110" "int foo[8];"
|
|
(tcall3 genDeclaration (A.Array [dimension 8] A.Int) foo True)
|
|
,testBothSame "genDeclaration 111" "int foo[8*9];"
|
|
(tcall3 genDeclaration (A.Array [dimension 8,dimension 9] A.Int) foo True)
|
|
,testBothSame "genDeclaration 112" "int foo[8*9*10];"
|
|
(tcall3 genDeclaration (A.Array [dimension 8,dimension 9,dimension 10] A.Int) foo True)
|
|
|
|
--Arrays of channels and channel-ends:
|
|
,testBoth "genDeclaration 200" "Channel foo_storage[8];Channel* foo[8];"
|
|
"csp::One2OneChannel<int> foo_storage[8];csp::One2OneChannel<int>* foo[8];"
|
|
(tcall3 genDeclaration (A.Array [dimension 8] $ A.Chan A.DirUnknown (A.ChanAttributes False False) A.Int) foo False)
|
|
|
|
,testBoth "genDeclaration 201" "Channel foo_storage[8*9];Channel* foo[8*9];"
|
|
"csp::One2OneChannel<int> foo_storage[8*9];csp::One2OneChannel<int>* foo[8*9];"
|
|
(tcall3 genDeclaration (A.Array [dimension 8, dimension 9] $ A.Chan A.DirUnknown (A.ChanAttributes False False) A.Int) foo False)
|
|
|
|
,testBoth "genDeclaration 202" "Channel* foo[8];"
|
|
"csp::Chanin<int> foo[8];"
|
|
(tcall3 genDeclaration (A.Array [dimension 8] $ A.Chan A.DirInput (A.ChanAttributes False False) A.Int) foo False)
|
|
|
|
,testBoth "genDeclaration 203" "Channel* foo[8*9];"
|
|
"csp::Chanout<int> foo[8*9];"
|
|
(tcall3 genDeclaration (A.Array [dimension 8, dimension 9] $ A.Chan A.DirOutput (A.ChanAttributes False False) A.Int) foo False)
|
|
|
|
|
|
--Records of simple:
|
|
,testBothSameS "genDeclaration 300" "REC foo;" (tcall3 genDeclaration (A.Record $ simpleName "REC") foo False) (stateR A.Int)
|
|
|
|
--Records of arrays of int (the sizes are set by declareInit):
|
|
,testBothSameS "genDeclaration 400" "REC foo;" (tcall3 genDeclaration (A.Record $ simpleName "REC") foo False) (stateR $ A.Array [dimension 8] A.Int)
|
|
|
|
--Timers:
|
|
,testBoth "genDeclaration 500" "Time foo;" "csp::Time foo;"
|
|
(tcall3 genDeclaration A.Timer foo False)
|
|
,testBoth "genDeclaration 501" "Time foo[20];" "csp::Time foo[20];"
|
|
(tcall3 genDeclaration (A.Array [dimension 20] A.Timer) foo False)
|
|
]
|
|
where
|
|
stateR t = defRecord "REC" "bar" t
|
|
|
|
testDeclareInitFree :: Test
|
|
testDeclareInitFree = TestLabel "testDeclareInitFree" $ TestList
|
|
[
|
|
-- Plain type:
|
|
testAllSame 0 ("","") A.Int
|
|
|
|
-- Channel types:
|
|
,testAll 1 ("ChanInit(wptr,(&foo));","") ("","") $ A.Chan A.DirUnknown (A.ChanAttributes False False) A.Int
|
|
,testAllSame 2 ("","") $ A.Chan A.DirInput (A.ChanAttributes False False) A.Int
|
|
|
|
-- Plain arrays:
|
|
,testAllSame 3 ("","") $ A.Array [dimension 4] A.Int
|
|
|
|
-- Channel arrays:
|
|
,testAll 4 ("tock_init_chan_array(foo_storage,foo,4);^ChanInit(wptr,foo[0]);^","") ("tockInitChanArray(foo_storage,foo,4);","") $ A.Array [dimension 4] $ A.Chan A.DirUnknown (A.ChanAttributes False False) A.Int
|
|
,testAllSame 6 ("","") $ A.Array [dimension 4] $ A.Chan A.DirInput (A.ChanAttributes False False) A.Int
|
|
|
|
-- Plain records:
|
|
,testAllR 100 ("","") ("","") A.Int id
|
|
-- Records containing an array:
|
|
,testAllR 101 ("","") ("","") (A.Array [dimension 4,dimension 5] A.Int) id
|
|
-- Arrays of records containing an array:
|
|
,testAllRA 200 ("^^","") ("","") (A.Array [dimension 4,dimension 5] A.Int) id
|
|
|
|
-- Mobile versions
|
|
,testAllSame 1003 ("","") $ A.Mobile $ A.Array [dimension 4] A.Int
|
|
,testAllSame 1004 ("","") $ A.Mobile $ A.Array [dimension 4] $ A.Chan A.DirUnknown (A.ChanAttributes False False) A.Int
|
|
,testAllR 1100 ("","") ("","") A.Int A.Mobile
|
|
-- Records containing an array:
|
|
,testAllR 1101 ("","") ("","") (A.Array [dimension 4,dimension 5] A.Int) A.Mobile
|
|
-- Arrays of records containing an array:
|
|
,testAllRA 1200 ("","") ("","") (A.Array [dimension 4,dimension 5] A.Int) A.Mobile
|
|
|
|
|
|
]
|
|
where
|
|
testAll :: Int -> (String,String) -> (String,String) -> A.Type -> Test
|
|
testAll n eC eCPP t = testAll' n eC eCPP t (defineName (simpleName "foo") $ simpleDefDecl "foo" t)
|
|
|
|
testAllR :: Int -> (String,String) -> (String,String) -> A.Type -> (A.Type -> A.Type) -> Test
|
|
testAllR n eC eCPP t f = testAll' n eC eCPP (f $ A.Record $ simpleName "REC") ((defRecord "REC" "bar" t) >> (defineName (simpleName "foo") $ simpleDefDecl "foo" $ A.Record (simpleName "REC")))
|
|
|
|
testAllRA :: Int -> (String,String) -> (String,String) -> A.Type -> (A.Type -> A.Type) -> Test
|
|
testAllRA n eC eCPP t f = testAll' n eC eCPP (A.Array [dimension 5] $ f $ A.Record $ simpleName "REC") ((defRecord "REC" "bar" t) >> (defineName (simpleName "foo") $ simpleDefDecl "foo" $ A.Array [dimension 5] $ A.Record (simpleName "REC")))
|
|
|
|
testAll' :: Int -> (String,String) -> (String,String) -> A.Type -> State CompState () -> Test
|
|
testAll' n (iC,fC) (iCPP,fCPP) t state = TestList
|
|
[
|
|
testBothS ("testDeclareInitFree/a" ++ show n) ("@" ++ iC) ("@" ++ iCPP) (over (tcall introduceSpec $ A.Specification emptyMeta foo (A.Declaration emptyMeta t))) state
|
|
,testBothS ("testDeclareInitFree/b" ++ show n) iC iCPP (over $ ask >>= \ops -> (fromMaybe (return ())) (declareInit ops emptyMeta t (A.Variable emptyMeta foo))) state
|
|
,testBothS ("testDeclareInitFree/c" ++ show n) fC fCPP (over (tcall removeSpec $ A.Specification emptyMeta foo (A.Declaration emptyMeta t))) state
|
|
,testBothS ("testDeclareInitFree/d" ++ show n) fC fCPP (over $ ask >>= \ops -> (fromMaybe (return ())) (declareFree ops emptyMeta t (A.Variable emptyMeta foo))) state
|
|
]
|
|
where
|
|
overArray _ v f = case f (\v -> A.SubscriptedVariable emptyMeta (A.Subscript emptyMeta A.NoCheck $ intLiteral 0) v) of
|
|
Just p -> caret >> p >> caret
|
|
Nothing -> return ()
|
|
over :: Override
|
|
over = local $ \ops -> ops {genDeclaration = override3 at, genOverArray = overArray}
|
|
|
|
testAllSame :: Int -> (String,String) -> A.Type -> Test
|
|
testAllSame n e t = testAll n e e t
|
|
|
|
testRecord :: Test
|
|
testRecord = TestList
|
|
[
|
|
--Record types:
|
|
testAllSame 400 ("typedef struct{#ATION_True}foo;","") foo False [(bar,A.Int)]
|
|
,testAllSame 401 ("typedef struct{#ATION_True#ATION_True} occam_struct_packed foo;","") foo True [(bar,A.Int),(bar,A.Int)]
|
|
,testAllSame 402 ("typedef struct{#ATION_True}foo;","") foo False [(bar,A.Array [dimension 6, dimension 7] A.Int)]
|
|
]
|
|
where
|
|
testAll :: Int -> (String,String) -> (String,String) -> A.Name -> Bool -> [(A.Name, A.Type)] -> Test
|
|
testAll a b c0 c1 c2 d = testAllS a b c0 c1 c2 d (return ()) over
|
|
|
|
testAllS :: Int -> (String,String) -> (String,String) -> A.Name -> Bool -> [(A.Name, A.Type)] -> State CompState () -> (GenOps -> GenOps) -> Test
|
|
testAllS n (eCI,eCR) (eCPPI,eCPPR) rn rb rts st overFunc
|
|
= testBothS ("testRecord " ++ show n) eCI eCPPI (local overFunc (tcall genRecordTypeSpec rn rb rts)) st
|
|
testAllSame n e s0 s1 s2 = testAll n e e s0 s1 s2
|
|
over ops = ops {genDeclaration = override2 (tell . (\x -> ["#ATION_",show x]))
|
|
,declareInit = (override3 (Just $ tell ["#INIT"])), declareFree = override3 (Just $ tell ["#FREE"])
|
|
,genType = (\x -> tell ["$(",show x,")"])
|
|
,genVariable = override1 at
|
|
}
|
|
|
|
testSpec :: Test
|
|
testSpec = TestList
|
|
[
|
|
--Declaration:
|
|
testAllSame 0 ("#ATION_False#INIT","#FREE") $ A.Declaration emptyMeta A.Int
|
|
,testAllSame 1 ("#ATION_False#INIT","#FREE") $ A.Declaration emptyMeta (A.Chan A.DirUnknown (A.ChanAttributes False False) A.Int)
|
|
,testAllSame 2 ("#ATION_False#INIT","#FREE") $ A.Declaration emptyMeta (A.Array [dimension 3] A.Int)
|
|
,testAllSame 3 ("#ATION_False#INIT","#FREE") $ A.Declaration emptyMeta (A.Array [dimension 3] $ A.Chan A.DirUnknown (A.ChanAttributes False False) A.Int)
|
|
|
|
-- TODO test declarations with initialisers
|
|
|
|
--Empty/failure cases:
|
|
,testAllSame 100 ("","") $ A.DataType undefined undefined
|
|
,testBothFail "testAllSame 200" (tcall introduceSpec $ A.Specification emptyMeta foo $ A.RetypesExpr emptyMeta A.Original A.Int (A.True emptyMeta))
|
|
,testBothFail "testAllSame 300" (tcall introduceSpec $ A.Specification emptyMeta foo $ A.Place emptyMeta (A.True emptyMeta))
|
|
,testAllSame 350 ("","") $ A.Protocol emptyMeta undefined
|
|
|
|
--IsChannelArray:
|
|
,testAllSame 500
|
|
("$(" ++ show chanInt ++ ")*foo[]={@,@};","")
|
|
$ A.IsChannelArray emptyMeta (A.Array [dimension 2] $ chanInt)
|
|
[A.Variable undefined undefined,A.Variable undefined undefined]
|
|
|
|
--Is:
|
|
|
|
-- Plain types require you to take an address to get the pointer:
|
|
,testAllSameForTypes 600 (\t -> ("$(" ++ show t ++ ")*const foo=&bar;","")) (\t -> A.Is emptyMeta A.Abbrev t (variable "bar")) [A.Int,A.Time]
|
|
,testAllSameForTypes 610 (\t -> ("$(" ++ show t ++ ")*const foo=(&bar);","")) (\t -> A.Is emptyMeta A.Abbrev t (variable "bar")) [chanInt,A.Record foo]
|
|
--Abbreviations of channel-ends in C++ should just copy the channel-end, rather than trying to take the address of the temporary returned by writer()/reader()
|
|
--C abbreviations will be of type Channel*, so they can just copy the channel address.
|
|
,testAllForTypes 620 (\t -> ("$(" ++ show t ++ ") foo=&bar;","")) (\t -> ("$(" ++ show t ++ ") foo=bar;",""))
|
|
(\t -> A.Is emptyMeta A.Abbrev t (variable "bar")) [chanIntIn,chanIntOut]
|
|
|
|
,testAllSameForTypes 700 (\t -> ("const $(" ++ show t ++ ") foo=bar;","")) (\t -> A.Is emptyMeta A.ValAbbrev t (variable "bar")) [A.Int,A.Time]
|
|
,testAllSameForTypes 710 (\t -> ("const $(" ++ show t ++ ")*const foo=(&bar);","")) (\t -> A.Is emptyMeta A.ValAbbrev t (variable "bar")) [A.Record foo]
|
|
-- I don't think ValAbbrev of channels/channel-ends makes much sense (occam doesn't support it, certainly) so they are not tested here.
|
|
|
|
--TODO test Is more (involving subscripts, arrays and slices)
|
|
|
|
--ProtocolCase:
|
|
,testAllSame 800 ("typedef enum{empty_protocol_foo}foo;","") $ A.ProtocolCase emptyMeta []
|
|
,testAllSame 801 ("typedef enum{bar_foo}foo;","") $ A.ProtocolCase emptyMeta [(bar,[])]
|
|
,testAllSame 802 ("typedef enum{bar_foo,wibble_foo}foo;","") $ A.ProtocolCase emptyMeta [(bar,[]),(simpleName "wibble",[])]
|
|
|
|
--Retypes:
|
|
-- Normal abbreviation:
|
|
,testAllSameS 900 ("int*const foo=(int*const)&y;@","") (A.Retypes emptyMeta A.Abbrev A.Int (variable "y"))
|
|
(defineName (simpleName "y") (simpleDefDecl "y" A.Int32)) (\ops -> ops {genRetypeSizes = override5 at})
|
|
-- Val abbreviation:
|
|
,testAllSameS 901 ("const int foo=*(const int*)&y;@","") (A.Retypes emptyMeta A.ValAbbrev A.Int (variable "y"))
|
|
(defineName (simpleName "y") (simpleDefDecl "y" A.Int32)) (\ops -> ops {genRetypeSizes = override5 at})
|
|
--Abbreviations of records as records:
|
|
,testAllSameS 910 ("bar*const foo=(bar*const)(&y);@","") (A.Retypes emptyMeta A.Abbrev (A.Record bar) (variable "y"))
|
|
(defineName (simpleName "y") (simpleDefDecl "y" (A.Record bar2))) (\ops -> ops {genRetypeSizes = override5 at})
|
|
-- Val abbreviation of records as records:
|
|
,testAllSameS 911 ("const bar*const foo=(const bar*const)(&y);@","") (A.Retypes emptyMeta A.ValAbbrev (A.Record bar) (variable "y"))
|
|
(defineName (simpleName "y") (simpleDefDecl "y" (A.Record bar2))) (\ops -> ops {genRetypeSizes = override5 at})
|
|
|
|
-- Channel retyping doesn't require size checking:
|
|
,testAllS 1000 ("Channel*const foo=(Channel*const)(&y);","") ("csp::One2OneChannel<tockSendableArrayOfBytes>*const foo=(csp::One2OneChannel<tockSendableArrayOfBytes>*const)(&y);","")
|
|
(A.Retypes emptyMeta A.Abbrev (A.Chan A.DirUnknown (A.ChanAttributes False False) A.Any) (variable "y"))
|
|
(defineName (simpleName "y") (simpleDefDecl "y" (A.Chan A.DirUnknown (A.ChanAttributes False False) A.Any))) id
|
|
|
|
-- Plain-to-array retyping:
|
|
-- single (unknown) dimension:
|
|
,testAllSameS 1100 ("uint8_t* foo=(uint8_t*)&y;@","")
|
|
(A.Retypes emptyMeta A.Abbrev (A.Array [A.UnknownDimension] A.Byte) (variable "y"))
|
|
(defineName (simpleName "y") (simpleDefDecl "y" A.Int32)) (\ops -> ops {genRetypeSizes = override5 at})
|
|
-- single (known) dimension:
|
|
,testAllSameS 1101 ("uint8_t* foo=(uint8_t*)&y;@","")
|
|
(A.Retypes emptyMeta A.Abbrev (A.Array [dimension 4] A.Byte) (variable "y"))
|
|
(defineName (simpleName "y") (simpleDefDecl "y" A.Int32)) (\ops -> ops {genRetypeSizes = override5 at})
|
|
-- single (unknown) dimension, VAL:
|
|
,testAllSameS 1102 ("const uint8_t* foo=(const uint8_t*)&y;@","")
|
|
(A.Retypes emptyMeta A.ValAbbrev (A.Array [A.UnknownDimension] A.Byte) (variable "y"))
|
|
(defineName (simpleName "y") (simpleDefDecl "y" A.Int32)) (\ops -> ops {genRetypeSizes = override5 at})
|
|
-- single (known) dimension, VAL:
|
|
,testAllSameS 1103 ("const uint8_t* foo=(const uint8_t*)&y;@","")
|
|
(A.Retypes emptyMeta A.ValAbbrev (A.Array [dimension 4] A.Byte) (variable "y"))
|
|
(defineName (simpleName "y") (simpleDefDecl "y" A.Int32)) (\ops -> ops {genRetypeSizes = override5 at})
|
|
-- TODO test multiple dimensions plain-to-array (mainly for C++)
|
|
|
|
-- Array-to-plain retyping:
|
|
,testAllSameS 1200 ("int32_t*const foo=(int32_t*const)y;@","")
|
|
(A.Retypes emptyMeta A.Abbrev A.Int32 (variable "y"))
|
|
(defineName (simpleName "y") (simpleDefDecl "y" (A.Array [A.UnknownDimension] A.Byte))) (\ops -> ops {genRetypeSizes = override5 at})
|
|
,testAllSameS 1201 ("const int32_t foo=*(const int32_t*)y;@","")
|
|
(A.Retypes emptyMeta A.ValAbbrev A.Int32 (variable "y"))
|
|
(defineName (simpleName "y") (simpleDefDecl "y" (A.Array [A.UnknownDimension] A.Byte))) (\ops -> ops {genRetypeSizes = override5 at})
|
|
|
|
--TODO test array-to-array retyping
|
|
|
|
--TODO IsExpr
|
|
--TODO Proc
|
|
]
|
|
where
|
|
testAllSameForTypes :: Int -> (A.Type -> (String, String)) -> (A.Type -> A.SpecType) -> [A.Type] -> Test
|
|
testAllSameForTypes n te spec ts = testAllForTypes n te te spec ts
|
|
|
|
testAllForTypes :: Int -> (A.Type -> (String, String)) -> (A.Type -> (String, String)) -> (A.Type -> A.SpecType) -> [A.Type] -> Test
|
|
testAllForTypes n teC teCPP spec ts = TestList [testAllS (n+i) (teC t) (teCPP t) (spec t) (defineName (simpleName "bar") $ simpleDefDecl "bar" t) over' | (i,t) <- zip [0..] ts]
|
|
|
|
chanInt = A.Chan A.DirUnknown (A.ChanAttributes False False) A.Int
|
|
chanIntIn = A.Chan A.DirInput (A.ChanAttributes False False) A.Int
|
|
chanIntOut = A.Chan A.DirOutput (A.ChanAttributes False False) A.Int
|
|
|
|
testAll :: Int -> (String,String) -> (String,String) -> A.SpecType -> Test
|
|
testAll a b c d = testAllS a b c d (return ()) over
|
|
|
|
testAllS :: Int -> (String,String) -> (String,String) -> A.SpecType -> State CompState () -> (GenOps -> GenOps) -> Test
|
|
testAllS n (eCI,eCR) (eCPPI,eCPPR) spec st overFunc = TestList
|
|
[
|
|
testBothS ("testSpec " ++ show n) eCI eCPPI (local overFunc (tcall introduceSpec $ A.Specification emptyMeta foo spec)) st
|
|
,testBothS ("testSpec " ++ show n) eCR eCPPR (local overFunc (tcall removeSpec $ A.Specification emptyMeta foo spec)) st
|
|
]
|
|
testAllSame n e s = testAll n e e s
|
|
testAllSameS n e s st o = testAllS n e e s st o
|
|
over' ops = ops {genDeclaration = override2 (tell . (\x -> ["#ATION_",show x]))
|
|
,declareInit = (override3 (Just $ tell ["#INIT"])), declareFree = override3 (Just $ tell ["#FREE"])
|
|
,genType = (\x -> tell ["$(",show x,")"])
|
|
}
|
|
over ops = (over' ops) { genVariable = override1 at }
|
|
testRetypeSizes :: Test
|
|
testRetypeSizes = TestList
|
|
[
|
|
-- Channel retyping doesn't need size check:
|
|
test 0 "" (A.Chan undefined undefined undefined) (A.Chan undefined undefined undefined)
|
|
|
|
-- Plain types just need to check the return of occam_check_retype:
|
|
,test 1 "if(occam_check_retype(#S,#D,#M)!=1){@}"
|
|
A.Int A.Int32
|
|
,test 2 "if(occam_check_retype(#S,#D,#M)!=1){@}"
|
|
(A.Record foo) (A.Record bar)
|
|
|
|
-- Array types where both sizes are fixed should act like the plain types:
|
|
,test 3 "if(occam_check_retype(#S,#D,#M)!=1){@}"
|
|
(A.Array [dimension 2] A.Int) (A.Array [dimension 8] A.Byte)
|
|
,test 4 "if(occam_check_retype(#S,#D,#M)!=1){@}"
|
|
(A.Array [dimension 2,dimension 3,dimension 4] A.Int) (A.Array [A.UnknownDimension] A.Byte)
|
|
|
|
-- Array types with a free dimension should not check the return:
|
|
,test 100 "occam_check_retype(#S,#D,#M);"
|
|
(A.Array [A.UnknownDimension] A.Int) (A.Array [dimension 8] A.Byte)
|
|
,test 101 "occam_check_retype(#S,#D,#M);"
|
|
(A.Array [dimension 2,A.UnknownDimension,dimension 4] A.Int) (A.Array [A.UnknownDimension] A.Byte)
|
|
]
|
|
where
|
|
test :: Int -> String -> A.Type -> A.Type -> Test
|
|
test n exp destT srcT = testBothSame ("testRetypeSizes " ++ show n) (repAll exp)
|
|
(over (tcall5 genRetypeSizes emptyMeta destT undefined srcT undefined))
|
|
where
|
|
repAll = (rep "#S" ("$(" ++ show srcT ++ " Right)")) .
|
|
(rep "#D" ("$(" ++ show destT ++ " Left True)")) .
|
|
(rep "#M" ("\"" ++ show emptyMeta ++ "\""))
|
|
|
|
rep search replace str = subRegex (mkRegex search) str replace
|
|
|
|
showBytesInParams _ t (Right _) = tell ["$(" ++ show t ++ " Right)"]
|
|
showBytesInParams _ t v = tell ["$(" ++ show t ++ " " ++ show v ++ ")"]
|
|
over :: Override
|
|
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
|
|
|
|
testGenVariable :: Test
|
|
testGenVariable = TestList
|
|
[
|
|
-- Various types, unsubscripted:
|
|
testSameA 0 ("foo","(*foo)","foo") id A.Int
|
|
,testSameA 10 ("(&foo)","foo","foo") id (A.Record bar)
|
|
,testSameA2 20 ("(&foo)","foo") id (A.Chan A.DirUnknown (A.ChanAttributes False False) A.Int)
|
|
,testSameA2 30 ("foo","foo") id (A.Chan A.DirInput (A.ChanAttributes False False) A.Int)
|
|
|
|
-- Mobile versions of the above:
|
|
,testSameA2 40 ("foo","(*foo)") id (A.Mobile A.Int)
|
|
,testSameA2 45 ("(*foo)","(**foo)") deref (A.Mobile A.Int)
|
|
,testSameA2 50 ("foo","(*foo)") id (A.Mobile $ A.Record bar)
|
|
,testSameA2 55 ("foo","(*foo)") deref (A.Mobile $ A.Record bar)
|
|
|
|
-- Arrays of the previous types, unsubscripted:
|
|
,testSameA 100 ("foo","foo","foo") id (A.Array [dimension 8] A.Int)
|
|
,testSameA 110 ("foo","foo","foo") id (A.Array [dimension 8] $ A.Record bar)
|
|
,testSameA2 120 ("foo","foo") id (A.Array [dimension 8] $ A.Chan A.DirUnknown (A.ChanAttributes False False) A.Int)
|
|
,testSameA2 130 ("foo","foo") id (A.Array [dimension 8] $ A.Chan A.DirInput (A.ChanAttributes False False) A.Int)
|
|
|
|
-- Mobile arrays of the previous types:
|
|
,testSameA2 140 ("foo","(*foo)") id (A.Mobile $ A.Array [dimension 8] A.Int)
|
|
,testSameA2 145 ("foo","(*foo)") deref (A.Mobile $ A.Array [dimension 8] A.Int)
|
|
,testSameA2 150 ("foo","(*foo)") id (A.Mobile $ A.Array [dimension 8] $ A.Record bar)
|
|
,testSameA2 155 ("foo","(*foo)") deref (A.Mobile $ A.Array [dimension 8] $ A.Record bar)
|
|
|
|
-- Subscripted record:
|
|
,testSameA 200 ("(&foo)->x","foo->x","foo->x") fieldX (A.Record bar)
|
|
,testSameA2 210 ("foo->x","(*foo)->x") (fieldX . deref) (A.Mobile $ A.Record bar)
|
|
|
|
,testSameA 220 ("(&(&foo)->y)","(&foo->y)","(&foo->y)") fieldY (A.Record $ simpleName "barbar")
|
|
,testSameA 230 ("(&(&foo)->y)->x","(&foo->y)->x","(&foo->y)->x") (fieldX . fieldY) (A.Record $ simpleName "barbar")
|
|
|
|
-- Fully subscripted array:
|
|
,testAC 300 ("foo@C4","foo@U4") (sub 4) (A.Array [dimension 8] A.Int)
|
|
,testAC 305 ("foo@C4,5,6","foo@U4,5,6") ((sub 6) . (sub 5) . (sub 4)) (A.Array [dimension 8,dimension 9,dimension 10] A.Int)
|
|
,testAC 310 ("(&foo@C4)","(&foo@U4)") (sub 4) (A.Array [dimension 8] $ A.Record bar)
|
|
-- Original channel arrays are Channel*[], abbreviated channel arrays are Channel*[]:
|
|
,testAC2 320 ("foo@C4","foo@U4") ("foo@C4","foo@U4") (sub 4) (A.Array [dimension 8] $ A.Chan A.DirUnknown (A.ChanAttributes False False) A.Int)
|
|
,testAC 330 ("foo@C4","foo@U4") (sub 4) (A.Array [dimension 8] $ A.Chan A.DirInput (A.ChanAttributes False False) A.Int)
|
|
|
|
-- Fully subscripted array, and record field reference:
|
|
,testAC 400 ("(&foo@C4)->x","(&foo@U4)->x") (fieldX . (sub 4)) (A.Array [dimension 8] $ A.Record bar)
|
|
-- As above, but then with an index too:
|
|
,testAC 410 ("(&foo@C4)->x@C4","(&foo@U4)->x@U4") ((sub 4) . fieldX . (sub 4)) (A.Array [dimension 8] $ A.Record bar)
|
|
|
|
--TODO come back to slices later
|
|
|
|
-- Directed variables (incl. members of arrays, deref mobiles):
|
|
,testSameA2 500 ("$(&foo)$","$foo$") dir (A.Chan A.DirUnknown (A.ChanAttributes False False) A.Int)
|
|
-- Test for mobile channels (in future)
|
|
--,testSameA2 510 ("$foo$","$(*foo)$") (dir . deref) (A.Mobile $ A.Chan A.DirUnknown (A.ChanAttributes False False) A.Int)
|
|
,testAC2 520 ("$foo@C4$","$foo@U4$") ("$foo@C4$","$foo@U4$") (dir . (sub 4)) (A.Array [dimension 8] $ A.Chan A.DirUnknown (A.ChanAttributes False False) A.Int)
|
|
]
|
|
where
|
|
deref = A.DerefVariable emptyMeta
|
|
dir = A.DirectedVariable emptyMeta A.DirInput
|
|
fieldX = A.SubscriptedVariable emptyMeta (A.SubscriptField emptyMeta $ simpleName "x")
|
|
fieldY = A.SubscriptedVariable emptyMeta (A.SubscriptField emptyMeta $ simpleName "y")
|
|
sub n = A.SubscriptedVariable emptyMeta (A.Subscript emptyMeta A.CheckBoth $ intLiteral n)
|
|
|
|
test :: Int -> (String,String) -> (String,String) -> (A.Variable -> A.Variable) -> A.AbbrevMode -> A.Type -> Test
|
|
test n (eC,eUC) (eCPP,eUCPP) sub am t = TestList
|
|
[
|
|
testBothS ("testGenVariable/checked" ++ show n) eC eCPP (over (tcall genVariable $ sub $ A.Variable emptyMeta foo)) state
|
|
,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
|
|
defRecord "bar" "x" $ A.Array [dimension 7] A.Int
|
|
defRecord "barbar" "y" $ A.Record bar
|
|
over :: Override
|
|
over = local $ \ops -> ops {genArraySubscript = (\c _ subs -> at >> (tell [if c /= A.NoCheck then "C" else "U"]) >> (seqComma $ map snd subs))
|
|
,genDirectedVariable = (\cg _ -> dollar >> cg >> dollar)}
|
|
|
|
testA :: Int -> (String,String) -> (String,String) -> (A.Variable -> A.Variable) -> A.Type -> Test
|
|
testA n eC eCPP sub t = TestList [test n eC eCPP sub A.Original t, test (n+1) eC eCPP sub A.Abbrev t, test (n+2) eC eCPP sub A.ValAbbrev t]
|
|
|
|
-- | Tests that the given (checked,unchecked) expected values occur in both C and C++
|
|
testAC :: Int -> (String,String) -> (A.Variable -> A.Variable) -> A.Type -> Test
|
|
testAC n e sub t = testA n e e sub t
|
|
|
|
-- | Tests that the given (checked,unchecked) expected values (for Original and Abbrev modes) occur in both C and C++
|
|
testAC2 :: Int -> (String,String) -> (String,String) -> (A.Variable -> A.Variable) -> A.Type -> Test
|
|
testAC2 n e e' sub t = TestList [test n e e sub A.Original t, test (n+1) e' e' sub A.Abbrev t]
|
|
|
|
testSame :: Int -> String -> (A.Variable -> A.Variable) -> A.AbbrevMode -> A.Type -> Test
|
|
testSame n e sub am t = test n (e,e) (e,e) sub am t
|
|
|
|
testSameA :: Int -> (String,String,String) -> (A.Variable -> A.Variable) -> A.Type -> Test
|
|
testSameA n (eO,eA,eVA) sub t = TestList [testSame n eO sub A.Original t,testSame (n+1) eA sub A.Abbrev t,testSame (n+2) eVA sub A.ValAbbrev t]
|
|
|
|
testSameA2 :: Int -> (String,String) -> (A.Variable -> A.Variable) -> A.Type -> Test
|
|
testSameA2 n (eO,eA) sub t = TestList [testSame n eO sub A.Original t,testSame (n+1) eA sub A.Abbrev t]
|
|
|
|
testAssign :: Test
|
|
testAssign = TestList
|
|
[
|
|
testBothSameS "testAssign 0" "@=$;" (over (tcall3 genAssign emptyMeta [A.Variable emptyMeta foo] (A.ExpressionList emptyMeta [e]))) (state A.Int)
|
|
,testBothSameS "testAssign 1" "@=$;" (over (tcall3 genAssign emptyMeta [A.Variable emptyMeta foo] (A.ExpressionList emptyMeta [e]))) (state A.Time)
|
|
,testBothSameS "testAssign 2" "@=$;" (over (tcall3 genAssign emptyMeta [A.Variable emptyMeta foo] (A.ExpressionList emptyMeta [e])))
|
|
(state $ A.Chan A.DirInput (A.ChanAttributes False False) A.Int)
|
|
|
|
-- Fail because genAssign only handles one destination and one source:
|
|
,testBothFail "testAssign 100" (tcall3 genAssign emptyMeta [A.Variable emptyMeta foo,A.Variable emptyMeta foo] (A.ExpressionList emptyMeta [e]))
|
|
,testBothFail "testAssign 101" (tcall3 genAssign emptyMeta [A.Variable emptyMeta foo] (A.ExpressionList emptyMeta [e,e]))
|
|
,testBothFail "testAssign 102" (tcall3 genAssign emptyMeta [A.Variable emptyMeta foo,A.Variable emptyMeta foo] (A.ExpressionList emptyMeta [e, e]))
|
|
|
|
-- Fail because assignment can't be done with these types (should have already been transformed away):
|
|
,testBothFailS "testAssign 200" (over (tcall3 genAssign emptyMeta [A.Variable emptyMeta foo] (A.ExpressionList emptyMeta [e])))
|
|
(state $ A.Chan A.DirUnknown (A.ChanAttributes False False) A.Int)
|
|
,testBothFailS "testAssign 201" (over (tcall3 genAssign emptyMeta [A.Variable emptyMeta foo] (A.ExpressionList emptyMeta [e])))
|
|
(state $ A.Record bar)
|
|
]
|
|
where
|
|
--The expression won't be examined so we can use what we like:
|
|
e = A.True emptyMeta
|
|
state t = defineName (simpleName "foo") $ simpleDefDecl "foo" t
|
|
over :: Override
|
|
over = local $ \ops -> ops {genVariable = override1 at, genExpression = override1 dollar}
|
|
|
|
testCase :: Test
|
|
testCase = TestList
|
|
[
|
|
testBothSame "testCase 0" "switch($){default:^}" (over (tcall3 genCase emptyMeta e (A.Several emptyMeta [])))
|
|
,testBothSame "testCase 1" "switch($){default:{@}break;}" (over (tcall3 genCase emptyMeta e (A.Only emptyMeta $ A.Else emptyMeta p)))
|
|
,testBothSame "testCase 2" "switch($){default:{#@}break;}" (over (tcall3 genCase emptyMeta e (spec $ A.Only emptyMeta $ A.Else emptyMeta p)))
|
|
|
|
,testBothSame "testCase 10" "switch($){case $:{@}break;default:^}" (over (tcall3 genCase emptyMeta e (A.Only emptyMeta $ A.Option emptyMeta [intLiteral 0] p)))
|
|
|
|
,testBothSame "testCase 20" "switch($){case $:case $:{#@}break;default:{@}break;case $:{@}break;}" (over (tcall3 genCase emptyMeta e $ A.Several emptyMeta
|
|
[spec $ A.Only emptyMeta $ A.Option emptyMeta [e, e] p
|
|
,A.Only emptyMeta $ A.Else emptyMeta p
|
|
,A.Only emptyMeta $ A.Option emptyMeta [e] p]
|
|
))
|
|
]
|
|
where
|
|
--The expression and process won't be used so we can use what we like:
|
|
e = A.True emptyMeta
|
|
p = A.Skip emptyMeta
|
|
spec :: Data a => A.Structured a -> A.Structured a
|
|
spec = A.Spec emptyMeta undefined
|
|
over :: Override
|
|
over = local $ \ops -> ops {genExpression = override1 dollar, genProcess = override1 at, genStop = override2 caret, genSpec = override2 hash}
|
|
|
|
testGetTime :: Test
|
|
testGetTime = testBoth "testGetTime 0" "@ = TimerRead(wptr);" "csp::CurrentTime(&@);" (over (tcall genGetTime undefined))
|
|
where
|
|
over :: Override
|
|
over = local $ \ops -> ops {genVariable = override1 at}
|
|
|
|
testWait :: Test
|
|
testWait = TestList
|
|
[
|
|
testBoth "testWait 0" "TimerWait(wptr,$);" "csp::SleepUntil($);" (over (tcall2 genWait A.WaitUntil undefined))
|
|
,testBoth "testWait 1" "TimerDelay(wptr,$);" "csp::SleepFor($);" (over (tcall2 genWait A.WaitFor undefined))
|
|
]
|
|
where
|
|
over :: Override
|
|
over = local $ \ops -> ops {genExpression = override1 dollar}
|
|
|
|
testIf :: Test
|
|
testIf = TestList
|
|
[
|
|
testBothR "testIf 0" "/\\*([[:alnum:]_]+)\\*/\\^\\1:;" "class ([[:alnum:]_]+)\\{\\};try\\{\\^\\}catch\\(\\1\\)\\{\\}"
|
|
(over (tcall2 genIf emptyMeta (A.Several emptyMeta [])))
|
|
,testBothR "testIf 1" "/\\*([[:alnum:]_]+)\\*/if\\(\\$\\)\\{@goto \\1;\\}\\^\\1:;"
|
|
"class ([[:alnum:]_]+)\\{\\};try\\{if\\(\\$\\)\\{@throw \\1\\(\\);\\}\\^\\}catch\\(\\1\\)\\{\\}"
|
|
(over (tcall2 genIf emptyMeta (A.Only emptyMeta $ A.Choice emptyMeta e p)))
|
|
]
|
|
where
|
|
e :: A.Expression
|
|
e = undefined
|
|
p :: A.Process
|
|
p = undefined
|
|
over :: Override
|
|
over = local $ \ops -> ops {genExpression = override1 dollar, genProcess = override1 at, genStop = override2 caret, genSpec = override2 hash}
|
|
|
|
testWhile :: Test
|
|
testWhile = testBothSame "testWhile 0" "while($){@}" (over (tcall2 genWhile undefined undefined))
|
|
where
|
|
over :: Override
|
|
over = local $ \ops -> ops {genExpression = override1 dollar, genProcess = override1 at}
|
|
|
|
testInput :: Test
|
|
testInput = TestList
|
|
[
|
|
-- Test that genInput passes on the calls properly:
|
|
testBothSame "testInput 0" "" (overInputItemCase (tcall2 genInput undefined $ A.InputSimple undefined []))
|
|
,testBothSame "testInput 1" "^" (overInputItemCase (tcall2 genInput undefined $ A.InputSimple undefined [undefined]))
|
|
,testBothSame "testInput 2" "^^^" (overInputItemCase (tcall2 genInput undefined $ A.InputSimple undefined [undefined, undefined, undefined]))
|
|
|
|
-- Reading an integer (special case in the C backend):
|
|
,testInputItem 100 "ChanInInt(wptr,#,&x);" "#>>x;" (A.InVariable emptyMeta $ variable "x") A.Int
|
|
-- Reading a other plain types:
|
|
,testInputItem 101 "ChanIn(wptr,#,&x,^(Int8));" "#>>x;" (A.InVariable emptyMeta $ variable "x") A.Int8
|
|
,testInputItem 102 ("ChanIn(wptr,#,(&x),^(" ++ show (A.Record foo) ++ "));") "#>>*(&x);" (A.InVariable emptyMeta $ variable "x") (A.Record foo)
|
|
-- Reading into a fixed size array:
|
|
,testInputItem 103 "ChanIn(wptr,#,x,^(Array [Dimension 8] Int));" "tockRecvArray(#,x);" (A.InVariable emptyMeta $ variable "x") $ A.Array [dimension 8] A.Int
|
|
|
|
-- Reading into subscripted variables:
|
|
,testInputItem 110 "ChanInInt(wptr,#,&xs$);" "#>>xs$;" (A.InVariable emptyMeta $ sub0 $ variable "xs") A.Int
|
|
-- Reading a other plain types:
|
|
,testInputItem 111 "ChanIn(wptr,#,&xs$,^(Int8));" "#>>xs$;" (A.InVariable emptyMeta $ sub0 $ variable "xs") A.Int8
|
|
,testInputItem 112 ("ChanIn(wptr,#,(&xs$),^(" ++ show (A.Record foo) ++ "));") "#>>*(&xs$);" (A.InVariable emptyMeta $ sub0 $ variable "xs") (A.Record foo)
|
|
|
|
-- A counted array of Int:
|
|
,testInputItem 200 "ChanInInt(wptr,#,&x);ChanIn(wptr,#,xs,x*^(Int));"
|
|
"tockRecvArrayOfBytes(#,tockSendableArrayOfBytes(^(Int),&x));tockRecvArrayOfBytes(#,tockSendableArrayOfBytes(x*^(Int),xs));"
|
|
(A.InCounted emptyMeta (variable "x") (variable "xs")) (A.Counted A.Int A.Int)
|
|
-- A counted array, counted by Int8:
|
|
,testInputItem 201 "ChanIn(wptr,#,&x,^(Int8));ChanIn(wptr,#,xs,x*^(Int));"
|
|
"tockRecvArrayOfBytes(#,tockSendableArrayOfBytes(^(Int8),&x));tockRecvArrayOfBytes(#,tockSendableArrayOfBytes(x*^(Int),xs));"
|
|
(A.InCounted emptyMeta (variable "x") (variable "xs")) (A.Counted A.Int8 A.Int)
|
|
|
|
-- TODO reading in a counted/fixed-size array into an array of arrays (or will that have already been sliced?)
|
|
|
|
-- inputs as part of protocols/any:
|
|
,testInputItemProt 300 "ChanInInt(wptr,#,&x);" "tockRecvArrayOfBytes(#,tockSendableArrayOfBytes(^(Int),&x));"
|
|
(A.InVariable emptyMeta $ variable "x") A.Int
|
|
,testInputItemProt 301 "ChanIn(wptr,#,&x,^(Int8));" "tockRecvArrayOfBytes(#,tockSendableArrayOfBytes(^(Int8),&x));"
|
|
(A.InVariable emptyMeta $ variable "x") A.Int8
|
|
,testInputItemProt 302 ("ChanIn(wptr,#,(&x),^(" ++ show (A.Record foo) ++ "));") ("tockRecvArrayOfBytes(#,tockSendableArrayOfBytes(^(" ++ show (A.Record foo) ++ "),(&x)));")
|
|
(A.InVariable emptyMeta $ variable "x") (A.Record foo)
|
|
,testInputItemProt 303 "ChanIn(wptr,#,x,^(Array [Dimension 8] Int));" "tockRecvArrayOfBytes(#,tockSendableArrayOfBytes(^(Array [Dimension 8] Int),x));"
|
|
(A.InVariable emptyMeta $ variable "x") $ A.Array [dimension 8] A.Int
|
|
,testInputItemProt 400 "ChanInInt(wptr,#,&x);ChanIn(wptr,#,xs,x*^(Int));"
|
|
"tockRecvArrayOfBytes(#,tockSendableArrayOfBytes(^(Int),&x));tockRecvArrayOfBytes(#,tockSendableArrayOfBytes(x*^(Int),xs));"
|
|
(A.InCounted emptyMeta (variable "x") (variable "xs")) (A.Counted A.Int A.Int)
|
|
,testInputItemProt 401 "ChanIn(wptr,#,&x,^(Int8));ChanIn(wptr,#,xs,x*^(Int8));"
|
|
"tockRecvArrayOfBytes(#,tockSendableArrayOfBytes(^(Int8),&x));tockRecvArrayOfBytes(#,tockSendableArrayOfBytes(x*^(Int8),xs));"
|
|
(A.InCounted emptyMeta (variable "x") (variable "xs")) (A.Counted A.Int8 A.Int8)
|
|
|
|
]
|
|
where
|
|
sub0 = A.SubscriptedVariable emptyMeta (A.Subscript emptyMeta A.NoCheck (intLiteral 0))
|
|
|
|
testInputItem :: Int -> String -> String -> A.InputItem -> A.Type -> Test
|
|
testInputItem n eC eCPP oi t = testInputItem' n eC eCPP oi t t
|
|
-- Tests sending things over channels of protocol or ANY
|
|
testInputItemProt :: Int -> String -> String -> A.InputItem -> A.Type -> Test
|
|
testInputItemProt n eC eCPP oi t = TestList [testInputItem' n eC eCPP oi t (A.UserProtocol foo),testInputItem' n eC eCPP oi t A.Any]
|
|
|
|
testInputItem' :: Int -> String -> String -> A.InputItem -> A.Type -> A.Type -> Test
|
|
testInputItem' n eC eCPP ii t ct = TestList
|
|
[
|
|
testBothS ("testInput " ++ show n) (hashIs "(&c)" eC) (hashIs "(&c)->reader()" eCPP) (over (tcall2 genInputItem (A.Variable emptyMeta $ simpleName "c") ii)) (state A.DirUnknown)
|
|
,testBothS ("testInput [in] " ++ show n) (hashIs "c" eC) (hashIs "c" eCPP) (over (tcall2 genInputItem (A.Variable emptyMeta $ simpleName "c") ii)) (state A.DirInput)
|
|
]
|
|
where
|
|
hashIs x y = subRegex (mkRegex "#") y x
|
|
|
|
state dir = do defineName (simpleName "c") $ simpleDefDecl "c" (A.Chan dir (A.ChanAttributes False False) ct)
|
|
case t of
|
|
A.Counted t t' -> do defineName (simpleName "x") $ simpleDefDecl "x" t
|
|
defineName (simpleName "xs") $ simpleDefDecl "xs" (mkArray t')
|
|
_ -> do defineName (simpleName "x") $ simpleDefDecl "x" t
|
|
defineName (simpleName "xs") $ simpleDefDecl "xs" (mkArray t)
|
|
mkArray (A.Array ds t) = A.Array (dimension 6:ds) t
|
|
mkArray t = A.Array [dimension 6] t
|
|
|
|
-- chan = simpleName "c"
|
|
-- chanIn = simpleName "cIn"
|
|
-- state = do defineName chan $ simpleDefDecl "c" (A.Chan A.DirUnknown (A.ChanAttributes False False) $ A.UserProtocol foo)
|
|
-- defineName chanOut $ simpleDefDecl "cIn" (A.Chan A.DirInput (A.ChanAttributes False False) $ A.UserProtocol foo)
|
|
|
|
overInputItemCase, over :: Override
|
|
overInputItemCase = local $ \ops -> ops {genInputItem = override2 caret}
|
|
over = local $ \ops -> ops {genBytesIn = (\_ t _ -> tell ["^(", showSimplerType t, ")"]) , genArraySubscript = override3 dollar}
|
|
|
|
-- | Show a type, simplifying how Dimensions are show.
|
|
showSimplerType :: A.Type -> String
|
|
showSimplerType t = subRegex re (show t) "Dimension \\1"
|
|
where re = mkRegex "Dimension [^\"]*\"([^\"]*)\"\\)\\)"
|
|
|
|
testOutput :: Test
|
|
testOutput = TestList
|
|
[
|
|
testBothSame "testOutput 0" "" (overOutputItem (tcall2 genOutput undefined []))
|
|
,testBothSame "testOutput 1" "^" (overOutputItem (tcall2 genOutput undefined [undefined]))
|
|
,testBothSame "testOutput 2" "^^^" (overOutputItem (tcall2 genOutput undefined [undefined,undefined,undefined]))
|
|
|
|
,testBothS "testOutput 100" "ChanOutInt(wptr,(&c),bar_foo);^" "tockSendInt((&c)->writer(),bar_foo);^" (overOutput (tcall3 genOutputCase (A.Variable emptyMeta chan) bar [])) state
|
|
,testBothS "testOutput 101" "ChanOutInt(wptr,cOut,bar_foo);^" "tockSendInt(cOut,bar_foo);^" (overOutput (tcall3 genOutputCase (A.Variable emptyMeta chanOut) bar [])) state
|
|
|
|
--Integers are a special case in the C backend:
|
|
,testOutputItem 201 "ChanOutInt(wptr,#,x);" "#<<x;" (A.OutExpression emptyMeta $ exprVariable "x") A.Int
|
|
--A plain type on the channel of the right type:
|
|
,testOutputItem 202 "ChanOut(wptr,#,&x,^);" "#<<x;" (A.OutExpression emptyMeta $ exprVariable "x") A.Int64
|
|
--A record type on the channel of the right type (because records are always referenced by pointer):
|
|
,testOutputItem 203 "ChanOut(wptr,#,(&x),^);" "#<<*(&x);" (A.OutExpression emptyMeta $ exprVariable "x") (A.Record foo)
|
|
--A fixed size array on the channel of the right type:
|
|
,testOutputItem 204 "ChanOut(wptr,#,x,^);" "tockSendArray(#,x);" (A.OutExpression emptyMeta $ exprVariable "x") (A.Array [dimension 6] A.Int)
|
|
,testOutputItem 205 "ChanOut(wptr,#,x,^);" "tockSendArray(#,x);" (A.OutExpression emptyMeta $ exprVariable "x") (A.Array [dimension 6, dimension 7, dimension 8] A.Int)
|
|
|
|
--A counted array:
|
|
,testOutputItem 206 "ChanOutInt(wptr,#,x);ChanOut(wptr,#,xs,x*^);" "#<<tockSendableArrayOfBytes(&x);#<<tockSendableArrayOfBytes(xs);"
|
|
(A.OutCounted emptyMeta (exprVariable "x") (exprVariable "xs")) (A.Counted A.Int A.Int)
|
|
--A counted array of arrays:
|
|
,testOutputItem 207 "ChanOutInt(wptr,#,x);ChanOut(wptr,#,xs,x*^);" "#<<tockSendableArrayOfBytes(&x);#<<tockSendableArrayOfBytes(xs);"
|
|
(A.OutCounted emptyMeta (exprVariable "x") (exprVariable "xs")) (A.Counted A.Int (A.Array [dimension 5] A.Int))
|
|
,testOutputItem 208 "ChanOutInt(wptr,#,x);ChanOut(wptr,#,xs,x*^);" "#<<tockSendableArrayOfBytes(&x);#<<tockSendableArrayOfBytes(xs);"
|
|
(A.OutCounted emptyMeta (exprVariable "x") (exprVariable "xs")) (A.Counted A.Int (A.Array [dimension 4,dimension 5] A.Int))
|
|
|
|
-- Test counted arrays that do not have Int as the count type:
|
|
,testOutputItem 209 "ChanOut(wptr,#,&x,^);ChanOut(wptr,#,xs,x*^);" "#<<tockSendableArrayOfBytes(&x);#<<tockSendableArrayOfBytes(xs);"
|
|
(A.OutCounted emptyMeta (exprVariable "x") (exprVariable "xs")) (A.Counted A.Int8 A.Int8)
|
|
|
|
|
|
--TODO add a pass that makes sure all outputs are variables. Including count for counted items
|
|
|
|
--Test sending things that are part of protocols (this will require different code in the C++ backend)
|
|
,testOutputItemProt 301 "ChanOutInt(wptr,#,x);" "#<<tockSendableArrayOfBytes(&x);" (A.OutExpression emptyMeta $ exprVariable "x") A.Int
|
|
,testOutputItemProt 302 "ChanOut(wptr,#,&x,^);" "#<<tockSendableArrayOfBytes(&x);" (A.OutExpression emptyMeta $ exprVariable "x") A.Int64
|
|
,testOutputItemProt 303 "ChanOut(wptr,#,(&x),^);" "#<<tockSendableArrayOfBytes((&x));" (A.OutExpression emptyMeta $ exprVariable "x") (A.Record foo)
|
|
,testOutputItemProt 304 "ChanOut(wptr,#,x,^);" "#<<tockSendableArrayOfBytes(x);" (A.OutExpression emptyMeta $ exprVariable "x") (A.Array [dimension 6] A.Int)
|
|
,testOutputItemProt 305 "ChanOut(wptr,#,x,^);" "#<<tockSendableArrayOfBytes(x);" (A.OutExpression emptyMeta $ exprVariable "x") (A.Array [dimension 6, dimension 7, dimension 8] A.Int)
|
|
,testOutputItemProt 306 "ChanOutInt(wptr,#,x);ChanOut(wptr,#,xs,x*^);" "#<<tockSendableArrayOfBytes(&x);#<<tockSendableArrayOfBytes(xs);"
|
|
(A.OutCounted emptyMeta (exprVariable "x") (exprVariable "xs")) (A.Counted A.Int A.Int)
|
|
,testOutputItemProt 307 "ChanOutInt(wptr,#,x);ChanOut(wptr,#,xs,x*^);" "#<<tockSendableArrayOfBytes(&x);#<<tockSendableArrayOfBytes(xs);"
|
|
(A.OutCounted emptyMeta (exprVariable "x") (exprVariable "xs")) (A.Counted A.Int (A.Array [dimension 5] A.Int))
|
|
,testOutputItemProt 308 "ChanOutInt(wptr,#,x);ChanOut(wptr,#,xs,x*^);" "#<<tockSendableArrayOfBytes(&x);#<<tockSendableArrayOfBytes(xs);"
|
|
(A.OutCounted emptyMeta (exprVariable "x") (exprVariable "xs")) (A.Counted A.Int (A.Array [dimension 4,dimension 5] A.Int))
|
|
|
|
|
|
--TODO add tests for sending on channels that are part of (normal, and abbreviated) channel arrays.
|
|
]
|
|
where
|
|
testOutputItem :: Int -> String -> String -> A.OutputItem -> A.Type -> Test
|
|
testOutputItem n eC eCPP oi t = testOutputItem' n eC eCPP oi t t
|
|
-- Tests sending things over channels of protocol or ANY
|
|
testOutputItemProt :: Int -> String -> String -> A.OutputItem -> A.Type -> Test
|
|
testOutputItemProt n eC eCPP oi t = TestList [testOutputItem' n eC eCPP oi t (A.UserProtocol foo),testOutputItem' n eC eCPP oi t A.Any]
|
|
|
|
testOutputItem' :: Int -> String -> String -> A.OutputItem -> A.Type -> A.Type -> Test
|
|
testOutputItem' n eC eCPP oi t ct = TestList
|
|
[
|
|
testBothS ("testOutput " ++ show n) (hashIs "(&c)" eC) (hashIs "(&c)->writer()" eCPP) (over (tcall2 genOutputItem (A.Variable emptyMeta $ simpleName "c") oi)) (state A.DirUnknown)
|
|
,testBothS ("testOutput [out] " ++ show n) (hashIs "c" eC) (hashIs "c" eCPP) (over (tcall2 genOutputItem (A.Variable emptyMeta $ simpleName "c") oi)) (state A.DirOutput)
|
|
]
|
|
where
|
|
hashIs x y = subRegex (mkRegex "#") y x
|
|
|
|
state dir = do defineName (simpleName "c") $ simpleDefDecl "c" (A.Chan dir (A.ChanAttributes False False) ct)
|
|
case t of
|
|
A.Counted t t' -> do defineName (simpleName "x") $ simpleDefDecl "x" t
|
|
defineName (simpleName "xs") $ simpleDefDecl "xs" (mkArray t')
|
|
_ -> defineName (simpleName "x") $ simpleDefDecl "x" t
|
|
mkArray (A.Array ds t) = A.Array (dimension 6:ds) t
|
|
mkArray t = A.Array [dimension 6] t
|
|
|
|
chan = simpleName "c"
|
|
chanOut = simpleName "cOut"
|
|
state :: CSM m => m ()
|
|
state = do defineName chan $ simpleDefDecl "c" (A.Chan A.DirUnknown (A.ChanAttributes False False) $ A.UserProtocol foo)
|
|
defineName chanOut $ simpleDefDecl "cOut" (A.Chan A.DirOutput (A.ChanAttributes False False) $ A.UserProtocol foo)
|
|
overOutput, overOutputItem, over :: Override
|
|
overOutput = local $ \ops -> ops {genOutput = override2 caret}
|
|
overOutputItem = local $ \ops -> ops {genOutputItem = override2 caret}
|
|
over = local $ \ops -> ops {genBytesIn = override3 caret}
|
|
|
|
testBytesIn :: Test
|
|
testBytesIn = TestList
|
|
[
|
|
testBothSame "testBytesIn 0" "sizeof(int)" (tcall3 genBytesIn undefined A.Int undefined)
|
|
,testBothSame "testBytesIn 1" "sizeof(foo)" (tcall3 genBytesIn undefined (A.Record foo) undefined)
|
|
,testBoth "testBytesIn 2" "sizeof(Channel)" "sizeof(csp::One2OneChannel<int>)" (tcall3 genBytesIn undefined (A.Chan A.DirUnknown (A.ChanAttributes False False) A.Int) undefined)
|
|
,testBoth "testBytesIn 3" "sizeof(Channel*)" "sizeof(csp::Chanin<int>)" (tcall3 genBytesIn undefined (A.Chan A.DirInput (A.ChanAttributes False False) A.Int) undefined)
|
|
|
|
--Array with a single known dimension:
|
|
,testBothSame "testBytesIn 100" "5*sizeof(int)" (tcall3 genBytesIn undefined (A.Array [dimension 5] A.Int) (Left False))
|
|
--single unknown dimension, no variable, no free dimension allowed:
|
|
,testBothFail "testBytesIn 101a" (tcall3 genBytesIn undefined (A.Array [A.UnknownDimension] A.Int) (Left False))
|
|
--single unknown dimension, no variable, free dimension allowed:
|
|
,testBothSame "testBytesIn 101b" "sizeof(int)" (tcall3 genBytesIn undefined (A.Array [A.UnknownDimension] A.Int) (Left True))
|
|
--single unknown dimension, with variable:
|
|
,testBothSame "testBytesIn 102" "$(@0)*sizeof(int)" (over (tcall3 genBytesIn undefined (A.Array [A.UnknownDimension] A.Int) (Right undefined)))
|
|
|
|
--Array with all known dimensions:
|
|
,testBothSame "testBytesIn 200" "7*6*5*sizeof(int)" (tcall3 genBytesIn undefined (A.Array [dimension 5,dimension 6, dimension 7] A.Int) (Left False))
|
|
--single unknown dimension, no variable, no free dimension allowed:
|
|
,testBothFail "testBytesIn 201a" (tcall3 genBytesIn undefined (A.Array [dimension 5,dimension 6,A.UnknownDimension] A.Int) (Left False))
|
|
--single unknown dimension, no variable, free dimension allowed:
|
|
,testBothSame "testBytesIn 201b" "6*5*sizeof(int)" (tcall3 genBytesIn undefined (A.Array [dimension 5,dimension 6,A.UnknownDimension] A.Int) (Left True))
|
|
--single unknown dimension, with variable:
|
|
,testBothSame "testBytesIn 202" "$(@2)*6*5*sizeof(int)" (over (tcall3 genBytesIn undefined (A.Array [dimension 5,dimension 6,A.UnknownDimension] A.Int) (Right undefined)))
|
|
|
|
]
|
|
where
|
|
over :: Override
|
|
over = local $ \ops -> ops {genVariable = override1 dollar, genSizeSuffix = (\n -> tell["(@",n,")"])}
|
|
|
|
testMobile :: Test
|
|
testMobile = TestList
|
|
[
|
|
testBoth "testMobile 0" "malloc(#(Int Left False))" "new Int" (local over (tcall3 genAllocMobile emptyMeta (A.Mobile A.Int) Nothing))
|
|
,TestCase $ assertGen "testMobile 1/C++" "new Int($)" $ (evalCGen (call genAllocMobile emptyMeta (A.Mobile A.Int) (Just undefined)) (over cppgenOps) emptyState)
|
|
|
|
,testBoth "testMobile 100" "if(@!=NULL){free(@);@=NULL;}" "if(@!=NULL){delete @;@=NULL;}"
|
|
(local over (tcall2 genClearMobile emptyMeta undefined))
|
|
]
|
|
where
|
|
showBytesInParams _ t (Right _) = tell ["#(" ++ show t ++ " Right)"]
|
|
showBytesInParams _ t v = tell ["#(" ++ show t ++ " " ++ show v ++ ")"]
|
|
over ops = ops {genBytesIn = showBytesInParams, genType = (\t -> tell [show t]), genExpression = override1 dollar, genVariable = override1 at}
|
|
|
|
---Returns the list of tests:
|
|
tests :: Test
|
|
tests = TestLabel "GenerateCTest" $ TestList
|
|
[
|
|
testActuals
|
|
,testArraySizes
|
|
,testArraySlice
|
|
,testArraySubscript
|
|
,testAssign
|
|
,testBytesIn
|
|
,testCase
|
|
,testDeclaration
|
|
,testDeclareInitFree
|
|
,testGenType
|
|
,testGenVariable
|
|
,testGetTime
|
|
,testIf
|
|
,testInput
|
|
,testMobile
|
|
,testOutput
|
|
,testOverArray
|
|
,testRecord
|
|
,testReplicator
|
|
,testRetypeSizes
|
|
,testSpec
|
|
,testStop
|
|
,testWait
|
|
,testWhile
|
|
]
|