Added a test for genCase on the C and C++ backends
This commit is contained in:
parent
38fb0baa4e
commit
bc7e1b1433
|
@ -89,6 +89,7 @@ data GenOps = GenOps {
|
||||||
genAssign :: GenOps -> Meta -> [A.Variable] -> A.ExpressionList -> CGen (),
|
genAssign :: GenOps -> Meta -> [A.Variable] -> A.ExpressionList -> CGen (),
|
||||||
genBytesIn :: GenOps -> A.Type -> Maybe A.Variable -> CGen (),
|
genBytesIn :: GenOps -> A.Type -> Maybe A.Variable -> CGen (),
|
||||||
genBytesIn' :: GenOps -> A.Type -> Maybe A.Variable -> CGen (Maybe Int),
|
genBytesIn' :: GenOps -> A.Type -> Maybe A.Variable -> CGen (Maybe Int),
|
||||||
|
-- | Generates a case statement over the given expression with the structured as the body.
|
||||||
genCase :: GenOps -> Meta -> A.Expression -> A.Structured -> CGen (),
|
genCase :: GenOps -> Meta -> A.Expression -> A.Structured -> CGen (),
|
||||||
genCheckedConversion :: GenOps -> Meta -> A.Type -> A.Type -> CGen () -> CGen (),
|
genCheckedConversion :: GenOps -> Meta -> A.Type -> A.Type -> CGen () -> CGen (),
|
||||||
genConversion :: GenOps -> Meta -> A.ConversionMode -> A.Type -> A.Expression -> CGen (),
|
genConversion :: GenOps -> Meta -> A.ConversionMode -> A.Type -> A.Expression -> CGen (),
|
||||||
|
@ -1629,33 +1630,32 @@ cgenIf ops m s
|
||||||
--{{{ case
|
--{{{ case
|
||||||
cgenCase :: GenOps -> Meta -> A.Expression -> A.Structured -> CGen ()
|
cgenCase :: GenOps -> Meta -> A.Expression -> A.Structured -> CGen ()
|
||||||
cgenCase ops m e s
|
cgenCase ops m e s
|
||||||
= do tell ["switch ("]
|
= do tell ["switch("]
|
||||||
call genExpression ops e
|
call genExpression ops e
|
||||||
tell [") {\n"]
|
tell ["){"]
|
||||||
seenDefault <- genCaseBody (return ()) s
|
seenDefault <- genCaseBody (return ()) s
|
||||||
when (not seenDefault) $
|
when (not seenDefault) $
|
||||||
do tell ["default:\n"]
|
do tell ["default:"]
|
||||||
call genStop ops m "no option matched in CASE process"
|
call genStop ops m "no option matched in CASE process"
|
||||||
tell ["}\n"]
|
tell ["}"]
|
||||||
where
|
where
|
||||||
-- FIXME -- can this be made common with genInputCaseBody above?
|
-- FIXME -- can this be made common with genInputCaseBody above?
|
||||||
genCaseBody :: CGen () -> A.Structured -> CGen Bool
|
genCaseBody :: CGen () -> A.Structured -> CGen Bool
|
||||||
genCaseBody coll (A.Spec _ spec s)
|
genCaseBody coll (A.Spec _ spec s)
|
||||||
= genCaseBody (call genSpec ops spec coll) s
|
= genCaseBody (call genSpec ops spec coll) s
|
||||||
genCaseBody coll (A.OnlyO _ (A.Option _ es p))
|
genCaseBody coll (A.OnlyO _ (A.Option _ es p))
|
||||||
= do sequence_ [tell ["case "] >> call genExpression ops e >> tell [":\n"] | e <- es]
|
= do sequence_ [tell ["case "] >> call genExpression ops e >> tell [":"] | e <- es]
|
||||||
tell ["{\n"]
|
tell ["{"]
|
||||||
coll
|
coll
|
||||||
call genProcess ops p
|
call genProcess ops p
|
||||||
tell ["break;\n"]
|
tell ["}break;"]
|
||||||
tell ["}\n"]
|
|
||||||
return False
|
return False
|
||||||
genCaseBody coll (A.OnlyO _ (A.Else _ p))
|
genCaseBody coll (A.OnlyO _ (A.Else _ p))
|
||||||
= do tell ["default:\n"]
|
= do tell ["default:"]
|
||||||
tell ["{\n"]
|
tell ["{"]
|
||||||
coll
|
coll
|
||||||
call genProcess ops p
|
call genProcess ops p
|
||||||
tell ["}\n"]
|
tell ["}break;"]
|
||||||
return True
|
return True
|
||||||
genCaseBody coll (A.Several _ ss)
|
genCaseBody coll (A.Several _ ss)
|
||||||
= do seens <- mapM (genCaseBody coll) ss
|
= do seens <- mapM (genCaseBody coll) ss
|
||||||
|
|
|
@ -58,6 +58,9 @@ dollar = tell ["$"]
|
||||||
caret :: CGen ()
|
caret :: CGen ()
|
||||||
caret = tell ["^"]
|
caret = tell ["^"]
|
||||||
|
|
||||||
|
hash :: CGen ()
|
||||||
|
hash = tell ["#"]
|
||||||
|
|
||||||
foo :: A.Name
|
foo :: A.Name
|
||||||
foo = simpleName "foo"
|
foo = simpleName "foo"
|
||||||
|
|
||||||
|
@ -523,6 +526,28 @@ testAssign = TestList
|
||||||
state t = defineName (simpleName "foo") $ simpleDefDecl "foo" t
|
state t = defineName (simpleName "foo") $ simpleDefDecl "foo" t
|
||||||
over ops = ops {genVariable = override1 at, genExpression = override1 dollar}
|
over 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.OnlyO emptyMeta $ A.Else emptyMeta p)) . over)
|
||||||
|
,testBothSame "testCase 2" "switch($){default:{#@}break;}" ((tcall3 genCase emptyMeta e (spec $ A.OnlyO emptyMeta $ A.Else emptyMeta p)) . over)
|
||||||
|
|
||||||
|
,testBothSame "testCase 10" "switch($){case $:{@}break;default:^}" ((tcall3 genCase emptyMeta e (A.OnlyO emptyMeta $ A.Option emptyMeta [intLiteral 0] p)) . over)
|
||||||
|
|
||||||
|
,testBothSame "testCase 20" "switch($){case $:case $:{#@}break;default:{@}break;case $:{@}break;}" ((tcall3 genCase emptyMeta e $ A.Several emptyMeta
|
||||||
|
[spec $ A.OnlyO emptyMeta $ A.Option emptyMeta [e, e] p
|
||||||
|
,A.OnlyO emptyMeta $ A.Else emptyMeta p
|
||||||
|
,A.OnlyO emptyMeta $ A.Option emptyMeta [e] p]
|
||||||
|
) . over)
|
||||||
|
]
|
||||||
|
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 = A.Spec emptyMeta undefined
|
||||||
|
over ops = ops {genExpression = override1 dollar, genProcess = override1 at, genStop = override2 caret, genSpec = override2 hash}
|
||||||
|
|
||||||
---Returns the list of tests:
|
---Returns the list of tests:
|
||||||
tests :: Test
|
tests :: Test
|
||||||
tests = TestList
|
tests = TestList
|
||||||
|
@ -531,6 +556,7 @@ tests = TestList
|
||||||
,testArraySizes
|
,testArraySizes
|
||||||
,testArraySubscript
|
,testArraySubscript
|
||||||
,testAssign
|
,testAssign
|
||||||
|
,testCase
|
||||||
,testDeclaration
|
,testDeclaration
|
||||||
,testDeclareInitFree
|
,testDeclareInitFree
|
||||||
,testGenType
|
,testGenType
|
||||||
|
|
Loading…
Reference in New Issue
Block a user