diff --git a/backends/GenerateC.hs b/backends/GenerateC.hs index 6ff7ef5..623d616 100644 --- a/backends/GenerateC.hs +++ b/backends/GenerateC.hs @@ -17,7 +17,7 @@ with this program. If not, see . -} -- | Generate C code from the mangled AST. -module GenerateC (call, CGen, cgenOps, cintroduceSpec, genComma, genCPasses, generate, generateC, genLeftB, genMeta, genName, genRightB, GenOps(..), indexOfFreeDimensions, seqComma, SubscripterFunction, withIf ) where +module GenerateC (call, CGen, CGen', cgenOps, cintroduceSpec, fget, genComma, genCPasses, generate, generateC, genLeftB, genMeta, genName, genRightB, GenOps(..), indexOfFreeDimensions, seqComma, SubscripterFunction, withIf ) where import Data.Char import Data.Generics @@ -25,6 +25,7 @@ import Data.List import Data.Maybe import qualified Data.Set as Set import Control.Monad.Error +import Control.Monad.Reader import Control.Monad.State import Control.Monad.Writer import Text.Printf @@ -52,7 +53,8 @@ genCPasses = --}}} --{{{ monad definition -type CGen = WriterT [String] PassM +type CGen' = WriterT [String] PassM +type CGen = ReaderT GenOps CGen' instance Die CGen where dieReport = throwError @@ -175,8 +177,50 @@ data GenOps = GenOps { } -- | Call an operation in GenOps. +{- call :: (GenOps -> GenOps -> t) -> GenOps -> t call f ops = f ops ops +-} + +class CGenCall a where + call :: (GenOps -> GenOps -> a) -> GenOps -> a + +instance CGenCall (a -> CGen z) where +-- call :: (GenOps -> GenOps -> a -> CGen b) -> a -> CGen b + call f _ x0 = do ops <- ask + f ops ops x0 + +instance CGenCall (a -> b -> CGen z) where + call f _ x0 x1 + = do ops <- ask + f ops ops x0 x1 + +instance CGenCall (a -> b -> c -> CGen z) where + call f _ x0 x1 x2 + = do ops <- ask + f ops ops x0 x1 x2 + +instance CGenCall (a -> b -> c -> d -> CGen z) where + call f _ x0 x1 x2 x3 + = do ops <- ask + f ops ops x0 x1 x2 x3 + +instance CGenCall (a -> b -> c -> d -> e -> CGen z) where + call f _ x0 x1 x2 x3 x4 + = do ops <- ask + f ops ops x0 x1 x2 x3 x4 + +-- A bit of a mind-boggler, but this is essentially for genSlice +instance CGenCall (a -> b -> c -> d -> (CGen x, y -> CGen z)) where + call f _ x0 x1 x2 x3 + = (do ops <- ask + fst $ f ops ops x0 x1 x2 x3 + ,\y -> do ops <- ask + (snd $ f ops ops x0 x1 x2 x3) y + ) + +fget :: (GenOps -> a) -> CGen a +fget = asks -- | Operations for the C backend. cgenOps :: GenOps @@ -264,9 +308,7 @@ cgenOps = GenOps { --{{{ top-level generate :: GenOps -> A.AST -> PassM String -generate ops ast - = do (a, out) <- runWriterT (call genTopLevel ops ast) - return $ concat out +generate ops ast = execWriterT (runReaderT (call genTopLevel undefined ast) ops) >>* concat generateC :: A.AST -> PassM String generateC = generate cgenOps @@ -415,7 +457,8 @@ cgenType _ (A.Chan _ _ t) = tell ["Channel*"] cgenType ops t@(A.List {}) = tell [subRegex (mkRegex "[^A-Za-z0-9]") (show t) ""] cgenType ops t - = case call getScalarType ops t of + = do f <- fget getScalarType + case f ops t of Just s -> tell [s] Nothing -> call genMissingC ops $ formatCode "genType %" t @@ -456,9 +499,10 @@ cgenBytesIn ops m t v call genType ops t tell [")"] genBytesIn' ops t - = case call getScalarType ops t of - Just s -> tell ["sizeof(", s, ")"] - Nothing -> diePC m $ formatCode "genBytesIn' %" t + = do f <- fget getScalarType + case f ops t of + Just s -> tell ["sizeof(", s, ")"] + Nothing -> diePC m $ formatCode "genBytesIn' %" t genBytesInArrayDim :: (A.Dimension,Int) -> CGen () genBytesInArrayDim (A.Dimension n, _) = tell [show n, "*"] @@ -886,7 +930,8 @@ cgenSizeSuffix _ dim = tell ["_sizes[", dim, "]"] cgenTypeSymbol :: GenOps -> String -> A.Type -> CGen () cgenTypeSymbol ops s t - = case call getScalarType ops t of + = do f <- fget getScalarType + case f ops t of Just ct -> tell ["occam_", s, "_", ct] Nothing -> call genMissingC ops $ formatCode "genTypeSymbol %" t @@ -1297,7 +1342,8 @@ cdeclareInit ops m t@(A.Array ds t') var _ sequence_ $ intersperse (tell ["*"]) [case dim of A.Dimension d -> tell [show d] | dim <- ds] tell [");"] _ -> return () - init <- return (\sub -> call declareInit ops m t' (sub var) Nothing) + fdeclareInit <- fget declareInit + init <- return (\sub -> fdeclareInit ops m t' (sub var) Nothing) call genOverArray ops m var init cdeclareInit ops m rt@(A.Record _) var _ = Just $ do fs <- recordFields m rt @@ -1311,8 +1357,10 @@ cdeclareInit ops m rt@(A.Record _) var _ call genSizeSuffix ops (show i) tell ["=", show n, ";"] | (i, A.Dimension n) <- zip [0..(length ds - 1)] ds] - doMaybe $ call declareInit ops m t v Nothing - initField t v = doMaybe $ call declareInit ops m t v Nothing + fdeclareInit <- fget declareInit + doMaybe $ fdeclareInit ops m t v Nothing + initField t v = do fdeclareInit <- fget declareInit + doMaybe $ fdeclareInit ops m t v Nothing cdeclareInit ops m _ v (Just e) = Just $ call genAssign ops m [v] $ A.ExpressionList m [e] cdeclareInit _ _ _ _ _ = Nothing @@ -1339,7 +1387,8 @@ CHAN OF INT c IS d: Channel *c = d; cintroduceSpec :: GenOps -> A.Specification -> CGen () cintroduceSpec ops (A.Specification m n (A.Declaration _ t init)) = do call genDeclaration ops t n False - case call declareInit ops m t (A.Variable m n) init of + fdeclareInit <- fget declareInit + case fdeclareInit ops m t (A.Variable m n) init of Just p -> p Nothing -> return () cintroduceSpec ops (A.Specification _ n (A.Is _ am t v)) @@ -1452,7 +1501,8 @@ cgenForwardDeclaration _ _ = return () cremoveSpec :: GenOps -> A.Specification -> CGen () cremoveSpec ops (A.Specification m n (A.Declaration _ t _)) - = case call declareFree ops m t var of + = do fdeclareFree <- fget declareFree + case fdeclareFree ops m t var of Just p -> p Nothing -> return () where @@ -1537,7 +1587,8 @@ cgenProcess ops p = case p of cgenAssign :: GenOps -> Meta -> [A.Variable] -> A.ExpressionList -> CGen () cgenAssign ops m [v] (A.ExpressionList _ [e]) = do t <- typeOfVariable v - case call getScalarType ops t of + f <- fget getScalarType + case f ops t of Just _ -> doAssign v e Nothing -> case t of -- Assignment of channel-ends, but not channels, is possible (at least in Rain): diff --git a/backends/GenerateCPPCSP.hs b/backends/GenerateCPPCSP.hs index 081a6df..9cef7eb 100644 --- a/backends/GenerateCPPCSP.hs +++ b/backends/GenerateCPPCSP.hs @@ -584,7 +584,8 @@ cppgenArraySizesLiteral ops n t@(A.Array ds _) = -- | Changed because we initialise channels and arrays differently in C++ cppdeclareInit :: GenOps -> Meta -> A.Type -> A.Variable -> Maybe A.Expression -> Maybe (CGen ()) cppdeclareInit ops m t@(A.Array ds t') var _ - = Just $ do init <- return (\sub -> call declareInit ops m t' (sub var) Nothing) + = Just $ do fdeclareInit <- fget declareInit + init <- return (\sub -> fdeclareInit ops m t' (sub var) Nothing) call genOverArray ops m var init case t' of A.Chan A.DirUnknown _ _ -> @@ -610,8 +611,10 @@ cppdeclareInit ops m rt@(A.Record _) var _ tell ["_actual,tockDims("] infixComma [tell [show n] | (A.Dimension n) <- ds] tell ["));"] - doMaybe $ call declareInit ops m t v Nothing - initField t v = doMaybe $ call declareInit ops m t v Nothing + fdeclareInit <- fget declareInit + doMaybe $ fdeclareInit ops m t v Nothing + initField t v = do fdeclareInit <- fget declareInit + doMaybe $ fdeclareInit ops m t v Nothing cppdeclareInit ops m _ v (Just e) = Just $ call genAssign ops m [v] $ A.ExpressionList m [e] cppdeclareInit _ _ _ _ _ = Nothing @@ -623,7 +626,8 @@ cppdeclareFree _ _ _ _ = Nothing -- | Changed to work properly with declareFree to free channel arrays. cppremoveSpec :: GenOps -> A.Specification -> CGen () cppremoveSpec ops (A.Specification m n (A.Declaration _ t _)) - = do case call declareFree ops m t var of + = do fdeclareFree <- fget declareFree + case fdeclareFree ops m t var of Just p -> p Nothing -> return () where @@ -916,7 +920,8 @@ cppgenType ops (A.Mobile t@(A.List {})) = call genType ops t cppgenType ops (A.Mobile t) = call genType ops t >> tell ["*"] cppgenType ops (A.List t) = tell ["tockList<"] >> call genType ops t >> tell [">/**/"] cppgenType ops t - = case call getScalarType ops t of + = do fgetScalarType <- fget getScalarType + case fgetScalarType ops t of Just s -> tell [s] Nothing -> call genMissingC ops $ formatCode "genType %" t diff --git a/backends/GenerateCTest.hs b/backends/GenerateCTest.hs index c9ac2ef..63d5e48 100644 --- a/backends/GenerateCTest.hs +++ b/backends/GenerateCTest.hs @@ -33,6 +33,7 @@ module GenerateCTest (tests) where import Control.Monad.Error import Control.Monad.State +import Control.Monad.Reader import Control.Monad.Writer import Data.Generics import Data.List (isInfixOf, intersperse) @@ -102,31 +103,37 @@ assertGenFail n act 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 = evalStateT (runErrorT $ execWriterT $ runReaderT act ops) state + +evalCGen' :: CGen' () -> CompState -> IO (Either Errors.ErrorReport [String]) +evalCGen' act state = evalStateT (runErrorT $ execWriterT act) state + -- | 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 - -> (GenOps -> CGen ()) -- ^ Actual + -> CGen () -- ^ Actual -> (State CompState ()) -- ^ State transformation -> Test testBothS testName expC expCPP act startState = TestList - [TestCase $ assertGen (testName ++ "/C") expC $ (evalStateT (runErrorT (execWriterT $ act cgenOps)) state) - ,TestCase $ assertGen (testName ++ "/C++") expCPP $ (evalStateT (runErrorT (execWriterT $ act cppgenOps)) state) ] + [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 -> (GenOps -> CGen ()) -> (State CompState ()) -> Test +testBothFailS :: String -> CGen () -> (State CompState ()) -> Test testBothFailS testName act startState = TestList - [TestCase $ assertGenFail (testName ++ "/C") (evalStateT (runErrorT (execWriterT $ act cgenOps)) state) - ,TestCase $ assertGenFail (testName ++ "/C++") (evalStateT (runErrorT (execWriterT $ act cppgenOps)) state) ] + [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 :: String -> String -> CGen' () -> State CompState () -> IO [String] testRS testName exp act startState = assertGenR testName exp (evalStateT (runErrorT (execWriterT act)) state) where state = execState startState emptyState @@ -135,7 +142,7 @@ testRS testName exp act startState = assertGenR testName exp (evalStateT (runErr testBothSameS :: String -- ^ Test Name -> String -- ^ C and C++ expected - -> (GenOps -> CGen ()) -- ^ Actual + -> CGen () -- ^ Actual -> (State CompState ()) -- ^ State transformation -> Test testBothSameS n e a s = testBothS n e e a s @@ -145,29 +152,32 @@ testBothR :: String -- ^ Test Name -> String -- ^ C expected -> String -- ^ C++ expected - -> (GenOps -> CGen ()) -- ^ Actual + -> CGen () -- ^ Actual -> Test -testBothR n eC eCPP a = TestList [TestCase $ (testRS n eC (a cgenOps) (return ())) >> return (), TestCase $ (testRS n eCPP (a cppgenOps) (return ())) >> (return ())] +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 -> (GenOps -> CGen ()) -> Test +testBothSameR :: String -> String -> CGen () -> Test testBothSameR n e a = testBothR n e e a -- | Like testBothFailS, but with the default beginning state. -testBothFail :: String -> (GenOps -> CGen ()) -> Test +testBothFail :: String -> CGen () -> Test testBothFail a b = testBothFailS a b (return ()) -- | Like testBothS, but with the default beginning state. -testBoth :: String -> String -> String -> (GenOps -> CGen ()) -> Test +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 -> (GenOps -> CGen ()) -> Test +testBothSame :: String -> String -> CGen () -> Test testBothSame a b c = testBothSameS a b c (return ()) -- | These functions are all helper functions that are like call, but turn the call -- into a function suitable to pass to all the test functions; i.e. a function -- parameterised solely by the GenOps. +{- tcall :: (GenOps -> GenOps -> a -> b) -> a -> (GenOps -> b) tcall f x = (\o -> f o o x) @@ -182,6 +192,13 @@ tcall4 f a b c d = (\o -> f o o a b c d) tcall5 :: (GenOps -> GenOps -> a0 -> a1 -> a2 -> a3 -> a4 -> b) -> a0 -> a1 -> a2 -> a3 -> a4 -> (GenOps -> b) tcall5 func a b c d e = (\o -> func o o a b c d e) +-} +tcall f = call f undefined +tcall2 f = call f undefined +tcall3 f = call f undefined +tcall4 f = call f undefined +tcall5 f = call f undefined + -- | Overrides a specified function in GenOps to return the given value override1 :: @@ -291,29 +308,30 @@ testArraySizes = TestList ,testBothFail "genArraySizesLiteral 2" (tcall2 genArraySizesLiteral foo $ A.Array [A.Dimension 6, A.UnknownDimension] A.Int) ,testBothSame "genArraySize 0" "const int*foo_sizes=@;" (tcall3 genArraySize True at foo) ,testBothSame "genArraySize 1" "const int foo_sizes[]=@;" (tcall3 genArraySize False at foo) - ,testBothSame "genArrayLiteralElems 0" "$" $ (tcall genArrayLiteralElems [A.ArrayElemExpr undefined]) . unfolded - ,testBothSame "genArrayLiteralElems 1" "$,$,$" $ (tcall genArrayLiteralElems [A.ArrayElemExpr undefined, A.ArrayElemExpr undefined, A.ArrayElemExpr undefined]) . unfolded - ,testBothSame "genArrayLiteralElems 2" "$,$,$" $ (tcall genArrayLiteralElems [A.ArrayElemExpr undefined, A.ArrayElemArray [A.ArrayElemExpr undefined, A.ArrayElemExpr undefined]]) . unfolded + ,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 = (\ops -> ops {genUnfoldedExpression = override1 dollar}) + 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" ",@,@" "@,@" $ (tcall genActuals [undefined, undefined]) . (\ops -> ops {genActual = override1 at}) + testBoth "genActuals 0" ",@,@" "@,@" $ overActual (tcall genActuals [undefined, undefined]) ,testBothSame "genActuals 1" "" $ (tcall genActuals []) --For expressions, genExpression should be called: - ,testBothSame "genActual 0" "$" $ (tcall genActual $ A.ActualExpression A.Bool (A.True undefined)) . over + ,testBothSame "genActual 0" "$" $ over (tcall genActual $ A.ActualExpression A.Bool (A.True undefined)) --For abbreviating arrays, C++ should call genExpression/genVariable, whereas C should do its foo,foo_sizes thing: - ,testBoth "genActual 1" "@,@_sizes" "$" $ (tcall genActual $ A.ActualExpression (A.Array undefined undefined) (A.ExprVariable undefined $ A.Variable undefined foo)) . over - ,testBoth "genActual 2" "@,@_sizes" "@" $ (tcall genActual $ A.ActualVariable A.Abbrev (A.Array undefined undefined) (A.Variable undefined foo)) . over + ,testBoth "genActual 1" "@,@_sizes" "$" $ over (tcall genActual $ A.ActualExpression (A.Array undefined undefined) (A.ExprVariable undefined $ A.Variable undefined foo)) + ,testBoth "genActual 2" "@,@_sizes" "@" $ over (tcall genActual $ A.ActualVariable A.Abbrev (A.Array undefined undefined) (A.Variable undefined foo)) ] where - over = (\ops -> ops {genVariable = override1 at, genExpression = override1 dollar}) + overActual = local (\ops -> ops {genActual = override1 at}) + over = local (\ops -> ops {genVariable = override1 at, genExpression = override1 dollar}) testArraySubscript :: Test testArraySubscript = TestList @@ -361,7 +379,7 @@ testArraySlice = TestList testSlice :: Int -> (String,String) -> String -> String -> Integer -> Integer -> [A.Dimension] -> Test testSlice index eC eCPP nm start count ds = testBothS ("genSlice " ++ show index) (smerge eC) (smerge (eCPP,"")) - (merge . tcall4 genSlice + (merge $ tcall4 genSlice (A.SubscriptedVariable undefined (A.SubscriptFromFor undefined (intLiteral start) (intLiteral count)) (variable nm)) (intLiteral start) (intLiteral count) ds) (defineName (simpleName nm) $ simpleDefDecl nm (A.Array ds A.Int)) @@ -374,8 +392,8 @@ testArraySlice = TestList testOverArray :: Test testOverArray = TestList $ map testOverArray' - [(cSize,cIndex,"",cgenOps) - ,((\n -> "\\.extent\\(" ++ show n ++ "\\)"),cppIndex,"\\.access\\(\\)",cppgenOps) + [(cSize,cIndex,"", cgenOps) + ,((\n -> "\\.extent\\(" ++ show n ++ "\\)"),cppIndex,"\\.access\\(\\)", cppgenOps) ] where cSize n = "_sizes\\[" ++ show n ++ "\\]" @@ -388,13 +406,13 @@ testOverArray = TestList $ map testOverArray' 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' :: ((Int -> String),[(String,[Int])] -> String,String, GenOps) -> Test testOverArray' (sz,f',suff,ops) = TestCase $ - do testRS "testOverArray'" rx1 (tcall3 genOverArray emptyMeta (A.Variable emptyMeta foo) func ops) state1 - testRS "testOverArray'" rx3 (tcall3 genOverArray emptyMeta (A.Variable emptyMeta foo) func ops) state3 + do testRS "testOverArray'" rx1 (flip runReaderT ops $ tcall3 genOverArray emptyMeta (A.Variable emptyMeta foo) func) state1 + testRS "testOverArray'" rx3 (flip runReaderT ops $ tcall3 genOverArray emptyMeta (A.Variable emptyMeta foo) func) state3 return () where - func f = Just $ call genVariableUnchecked ops (f $ A.Variable emptyMeta foo) >> tell [";"] + func f = Just $ call genVariableUnchecked undefined (f $ A.Variable emptyMeta foo) >> tell [";"] rx1 = "^for\\(int ([[:alnum:]_]+)=0;\\1 (String,String) -> (String,String) -> A.Type -> State CompState () -> Maybe A.Expression -> Test testAll' n (iC,fC) (iCPP,fCPP) t state init = TestList [ - testBothS ("testDeclareInitFree/a" ++ show n) ("@" ++ iC) ("@" ++ iCPP) ((tcall introduceSpec $ A.Specification emptyMeta foo (A.Declaration emptyMeta t init)) . over) state - ,testBothS ("testDeclareInitFree/b" ++ show n) iC iCPP ((fromMaybe (return ())) . (tcall4 declareInit emptyMeta t (A.Variable emptyMeta foo) init) . over) state - ,testBothS ("testDeclareInitFree/c" ++ show n) fC fCPP ((tcall removeSpec $ A.Specification emptyMeta foo (A.Declaration emptyMeta t Nothing)) . over) state - ,testBothS ("testDeclareInitFree/d" ++ show n) fC fCPP ((fromMaybe (return ())) . (tcall3 declareFree emptyMeta t (A.Variable emptyMeta foo)) . over) state + testBothS ("testDeclareInitFree/a" ++ show n) ("@" ++ iC) ("@" ++ iCPP) (over (tcall introduceSpec $ A.Specification emptyMeta foo (A.Declaration emptyMeta t init))) state + ,testBothS ("testDeclareInitFree/b" ++ show n) iC iCPP (over $ ask >>= \ops -> (fromMaybe (return ())) (declareInit ops ops emptyMeta t (A.Variable emptyMeta foo) init)) state + ,testBothS ("testDeclareInitFree/c" ++ show n) fC fCPP (over (tcall removeSpec $ A.Specification emptyMeta foo (A.Declaration emptyMeta t Nothing))) state + ,testBothS ("testDeclareInitFree/d" ++ show n) fC fCPP (over $ ask >>= \ops -> (fromMaybe (return ())) (declareFree ops ops emptyMeta t (A.Variable emptyMeta foo))) state ] where overArray _ _ v f = case f (\v -> A.SubscriptedVariable emptyMeta (A.Subscript emptyMeta $ intLiteral 0) v) of Just p -> caret >> p >> caret Nothing -> return () - over ops = ops {genDeclaration = override3 at, genOverArray = overArray} + 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 @@ -659,8 +677,8 @@ testSpec = TestList 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 ((tcall introduceSpec $ A.Specification emptyMeta foo spec) . overFunc) st - ,testBothS ("testSpec " ++ show n) eCR eCPPR ((tcall removeSpec $ A.Specification emptyMeta foo spec) . overFunc) st + 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 @@ -699,7 +717,7 @@ testRetypeSizes = TestList where test :: Int -> String -> String -> A.Type -> A.Type -> Test test n eC eCPP destT srcT = testBoth ("testRetypeSizes " ++ show n) (repAll eC) (repAll eCPP) - ((tcall5 genRetypeSizes emptyMeta destT undefined srcT undefined) . over) + (over (tcall5 genRetypeSizes emptyMeta destT undefined srcT undefined)) where repAll = (rep "#S" ("$(" ++ show srcT ++ " Right)")) . (rep "#D" ("$(" ++ show destT ++ " Left True)")) . @@ -710,7 +728,7 @@ testRetypeSizes = TestList showBytesInParams _ _ t (Right _) = tell ["$(" ++ show t ++ " Right)"] showBytesInParams _ _ t v = tell ["$(" ++ show t ++ " " ++ show v ++ ")"] showArrSize _ _ sz _ = tell ["^("] >> sz >> tell [")"] - over ops = ops {genBytesIn = showBytesInParams, genStop = override2 at, genArraySize = showArrSize} + over = local $ \ops -> ops {genBytesIn = showBytesInParams, genStop = override2 at, genArraySize = showArrSize} 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 @@ -776,13 +794,13 @@ testGenVariable = TestList 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 ((tcall genVariable $ sub $ A.Variable emptyMeta foo) . over) state - ,testBothS ("testGenVariable/unchecked" ++ show n) eUC eUCPP ((tcall genVariableUnchecked $ sub $ A.Variable emptyMeta foo) . over) state + 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 Nothing) am A.Unplaced defRecord "bar" "x" $ A.Array [A.Dimension 7] A.Int - over ops = ops {genArraySubscript = (\_ b _ subs -> at >> (tell [if b then "C" else "U"]) >> (seqComma $ map (call genExpression ops) subs)) + over = local $ \ops -> ops {genArraySubscript = (\_ b _ subs -> at >> (tell [if b then "C" else "U"]) >> (seqComma $ map (call genExpression ops) subs)) ,genDirectedVariable = (\_ cg _ -> dollar >> cg >> dollar)} testA :: Int -> (String,String) -> (String,String) -> (A.Variable -> A.Variable) -> A.Type -> Test @@ -808,9 +826,9 @@ testGenVariable = TestList testAssign :: Test testAssign = TestList [ - testBothSameS "testAssign 0" "@=$;" ((tcall3 genAssign emptyMeta [A.Variable emptyMeta foo] (A.ExpressionList emptyMeta [e])) . over) (state A.Int) - ,testBothSameS "testAssign 1" "@=$;" ((tcall3 genAssign emptyMeta [A.Variable emptyMeta foo] (A.ExpressionList emptyMeta [e])) . over) (state A.Time) - ,testBothSameS "testAssign 2" "@=$;" ((tcall3 genAssign emptyMeta [A.Variable emptyMeta foo] (A.ExpressionList emptyMeta [e])) . over) + 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: @@ -819,31 +837,31 @@ testAssign = TestList ,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" ((tcall3 genAssign emptyMeta [A.Variable emptyMeta foo] (A.ExpressionList emptyMeta [e])) . over) + ,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" ((tcall3 genAssign emptyMeta [A.Variable emptyMeta foo] (A.ExpressionList emptyMeta [e])) . over) + ,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 ops = ops {genVariable = override1 at, genExpression = override1 dollar} + over = local $ \ops -> ops {genVariable = override1 at, genExpression = override1 dollar} testCase :: Test testCase = TestList [ - testBothSame "testCase 0" "switch($){default:^}" ((tcall3 genCase emptyMeta e (A.Several emptyMeta [])) . over) - ,testBothSame "testCase 1" "switch($){default:{@}break;}" ((tcall3 genCase emptyMeta e (A.Only emptyMeta $ A.Else emptyMeta p)) . over) - ,testBothSame "testCase 2" "switch($){default:{#@}break;}" ((tcall3 genCase emptyMeta e (spec $ A.Only emptyMeta $ A.Else emptyMeta p)) . over) + 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:^}" ((tcall3 genCase emptyMeta e (A.Only emptyMeta $ A.Option emptyMeta [intLiteral 0] p)) . over) + ,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;}" ((tcall3 genCase emptyMeta e $ A.Several emptyMeta + ,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] - ) . over) + )) ] where --The expression and process won't be used so we can use what we like: @@ -851,50 +869,50 @@ testCase = TestList p = A.Skip emptyMeta spec :: Data a => A.Structured a -> A.Structured a spec = A.Spec emptyMeta undefined - over ops = ops {genExpression = override1 dollar, genProcess = override1 at, genStop = override2 caret, genSpec = override2 hash} + over = local $ \ops -> ops {genExpression = override1 dollar, genProcess = override1 at, genStop = override2 caret, genSpec = override2 hash} testGetTime :: Test -testGetTime = testBoth "testGetTime 0" "ProcTime(&@);" "csp::CurrentTime(&@);" ((tcall2 genGetTime emptyMeta undefined) . over) +testGetTime = testBoth "testGetTime 0" "ProcTime(&@);" "csp::CurrentTime(&@);" (over (tcall2 genGetTime emptyMeta undefined)) where - over ops = ops {genVariable = override1 at} + over = local $ \ops -> ops {genVariable = override1 at} testWait :: Test testWait = TestList [ - testBoth "testWait 0" "ProcTimeAfter($);" "csp::SleepUntil($);" ((tcall2 genWait A.WaitUntil undefined) . over) - ,testBoth "testWait 1" "ProcAfter($);" "csp::SleepFor($);" ((tcall2 genWait A.WaitFor undefined) . over) + testBoth "testWait 0" "ProcTimeAfter($);" "csp::SleepUntil($);" (over (tcall2 genWait A.WaitUntil undefined)) + ,testBoth "testWait 1" "ProcAfter($);" "csp::SleepFor($);" (over (tcall2 genWait A.WaitFor undefined)) ] where - over ops = ops {genExpression = override1 dollar} + over = local $ \ops -> ops {genExpression = override1 dollar} testIf :: Test testIf = TestList [ testBothR "testIf 0" "/\\*([[:alnum:]_]+)\\*/\\^\\1:;" "class ([[:alnum:]_]+)\\{\\};try\\{\\^\\}catch\\(\\1\\)\\{\\}" - ((tcall2 genIf emptyMeta (A.Several emptyMeta [])) . over) + (over (tcall2 genIf emptyMeta (A.Several emptyMeta []))) ,testBothR "testIf 1" "/\\*([[:alnum:]_]+)\\*/if\\(\\$\\)\\{@goto \\1;\\}\\^\\1:;" "class ([[:alnum:]_]+)\\{\\};try\\{if\\(\\$\\)\\{@throw \\1\\(\\);\\}\\^\\}catch\\(\\1\\)\\{\\}" - ((tcall2 genIf emptyMeta (A.Only emptyMeta $ A.Choice emptyMeta e p)) . over) + (over (tcall2 genIf emptyMeta (A.Only emptyMeta $ A.Choice emptyMeta e p))) ] where e :: A.Expression e = undefined p :: A.Process p = undefined - over ops = ops {genExpression = override1 dollar, genProcess = override1 at, genStop = override2 caret, genSpec = override2 hash} + over = local $ \ops -> ops {genExpression = override1 dollar, genProcess = override1 at, genStop = override2 caret, genSpec = override2 hash} testWhile :: Test -testWhile = testBothSame "testWhile 0" "while($){@}" ((tcall2 genWhile undefined undefined) . over) +testWhile = testBothSame "testWhile 0" "while($){@}" (over (tcall2 genWhile undefined undefined)) where - over ops = ops {genExpression = override1 dollar, genProcess = override1 at} + 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" "" ((tcall2 genInput undefined $ A.InputSimple undefined []) . overInputItemCase) - ,testBothSame "testInput 1" "^" ((tcall2 genInput undefined $ A.InputSimple undefined [undefined]) . overInputItemCase) - ,testBothSame "testInput 2" "^^^" ((tcall2 genInput undefined $ A.InputSimple undefined [undefined, undefined, undefined]) . overInputItemCase) + 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(#,&x);" "#>>x;" (A.InVariable emptyMeta $ variable "x") A.Int @@ -950,8 +968,8 @@ testInput = TestList 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) ((tcall2 genInputItem (A.Variable emptyMeta $ simpleName "c") ii) . over) (state A.DirUnknown) - ,testBothS ("testInput [in] " ++ show n) (hashIs "c" eC) (hashIs "c" eCPP) ((tcall2 genInputItem (A.Variable emptyMeta $ simpleName "c") ii) . over) (state A.DirInput) + 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 @@ -970,18 +988,18 @@ testInput = TestList -- 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 ops = ops {genInputItem = override2 caret} - over ops = ops {genBytesIn = (\_ _ t _ -> tell ["^(",show t,")"]) , genArraySubscript = override3 dollar} + overInputItemCase = local $ \ops -> ops {genInputItem = override2 caret} + over = local $ \ops -> ops {genBytesIn = (\_ _ t _ -> tell ["^(",show t,")"]) , genArraySubscript = override3 dollar} testOutput :: Test testOutput = TestList [ - testBothSame "testOutput 0" "" ((tcall2 genOutput undefined []) . overOutputItem) - ,testBothSame "testOutput 1" "^" ((tcall2 genOutput undefined [undefined]) . overOutputItem) - ,testBothSame "testOutput 2" "^^^" ((tcall2 genOutput undefined [undefined,undefined,undefined]) . overOutputItem) + 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((&c),bar_foo);^" "tockSendInt((&c)->writer(),bar_foo);^" ((tcall3 genOutputCase (A.Variable emptyMeta chan) bar []) . overOutput) state - ,testBothS "testOutput 101" "ChanOutInt(cOut,bar_foo);^" "tockSendInt(cOut,bar_foo);^" ((tcall3 genOutputCase (A.Variable emptyMeta chanOut) bar []) . overOutput) state + ,testBothS "testOutput 100" "ChanOutInt((&c),bar_foo);^" "tockSendInt((&c)->writer(),bar_foo);^" (overOutput (tcall3 genOutputCase (A.Variable emptyMeta chan) bar [])) state + ,testBothS "testOutput 101" "ChanOutInt(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(#,x);" "#< 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) ((tcall2 genOutputItem (A.Variable emptyMeta $ simpleName "c") oi) . over) (state A.DirUnknown) - ,testBothS ("testOutput [out] " ++ show n) (hashIs "c" eC) (hashIs "c" eCPP) ((tcall2 genOutputItem (A.Variable emptyMeta $ simpleName "c") oi) . over) (state A.DirOutput) + 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 @@ -1054,9 +1072,9 @@ testOutput = TestList 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 ops = ops {genOutput = override2 caret} - overOutputItem ops = ops {genOutputItem = override2 caret} - over ops = ops {genBytesIn = override3 caret} + 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 @@ -1073,7 +1091,7 @@ testBytesIn = TestList --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)" ((tcall3 genBytesIn undefined (A.Array [A.UnknownDimension] A.Int) (Right undefined)) . over) + ,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 [A.Dimension 5,A.Dimension 6, A.Dimension 7] A.Int) (Left False)) @@ -1082,20 +1100,20 @@ testBytesIn = TestList --single unknown dimension, no variable, free dimension allowed: ,testBothSame "testBytesIn 201b" "6*5*sizeof(int)" (tcall3 genBytesIn undefined (A.Array [A.Dimension 5,A.Dimension 6,A.UnknownDimension] A.Int) (Left True)) --single unknown dimension, with variable: - ,testBothSame "testBytesIn 202" "$(@2)*6*5*sizeof(int)" ((tcall3 genBytesIn undefined (A.Array [A.Dimension 5,A.Dimension 6,A.UnknownDimension] A.Int) (Right undefined)) . over) + ,testBothSame "testBytesIn 202" "$(@2)*6*5*sizeof(int)" (over (tcall3 genBytesIn undefined (A.Array [A.Dimension 5,A.Dimension 6,A.UnknownDimension] A.Int) (Right undefined))) ] where - over ops = ops {genVariable = override1 dollar, genSizeSuffix = (\_ n -> tell["(@",n,")"])} + over = local $ \ops -> ops {genVariable = override1 dollar, genSizeSuffix = (\_ n -> tell["(@",n,")"])} testMobile :: Test testMobile = TestList [ - testBoth "testMobile 0" "malloc(#(Int Left False))" "new Int" ((tcall3 genAllocMobile emptyMeta (A.Mobile A.Int) Nothing) . over) - ,TestCase $ assertGen "testMobile 1/C++" "new Int($)" $ (evalStateT (runErrorT (execWriterT $ call genAllocMobile (over cppgenOps) emptyMeta (A.Mobile A.Int) (Just undefined))) emptyState) + 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($)" $ (evalStateT (runErrorT (execWriterT $ flip runReaderT (over cppgenOps) $ call genAllocMobile undefined emptyMeta (A.Mobile A.Int) (Just undefined))) emptyState) ,testBoth "testMobile 100" "if(@!=NULL){free(@);@=NULL;}" "if(@!=NULL){delete @;@=NULL;}" - ((tcall2 genClearMobile emptyMeta undefined) . over) + (local over (tcall2 genClearMobile emptyMeta undefined)) ] where showBytesInParams _ _ t (Right _) = tell ["#(" ++ show t ++ " Right)"]