Skip to content

Implement support for case statements in Ada #171

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Merged
merged 5 commits into from
Mar 27, 2019
Merged
Changes from 1 commit
Commits
File filter

Filter by extension

Filter by extension

Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
57 changes: 56 additions & 1 deletion gnat2goto/driver/tree_walk.adb
Original file line number Diff line number Diff line change
Expand Up @@ -146,6 +146,10 @@ package body Tree_Walk is
with Pre => Nkind (N) = N_Loop_Statement,
Post => Kind (Do_Loop_Statement'Result) in Class_Code;

function Do_Case_Statement (N : Node_Id) return Irep
with Pre => Nkind (N) = N_Case_Statement,
Post => Kind (Do_Case_Statement'Result) = I_Code_Block;

function Do_N_Block_Statement (N : Node_Id) return Irep
with Pre => Nkind (N) = N_Block_Statement,
Post => Kind (Do_N_Block_Statement'Result) = I_Code_Block;
Expand Down Expand Up @@ -1764,6 +1768,57 @@ package body Tree_Walk is
Do_Type_Declaration (New_Type, Typedef);
end Do_Itype_Reference;

-----------------------
-- Do_Case_Statement --
-----------------------

function Do_Case_Statement (N : Node_Id) return Irep is
Ret : constant Irep := New_Irep (I_Code_Block);
Value : constant Irep := Do_Expression (Expression (N));

-- Auxiliary function to create a single test case
-- to emplace in a condition from a list of alternative
-- values.
function Make_Single_Test (Alt : Node_Id) return Irep;
function Make_Single_Test (Alt : Node_Id) return Irep is
Ret : constant Irep := New_Irep (I_Op_Eq);
Rhs : constant Irep := Do_Expression (Alt);
begin
Set_Lhs (Ret, Value);
Set_Rhs (Ret, Rhs);
Set_Type (Ret, New_Irep (I_Bool_Type));
return Ret;
end Make_Single_Test;

This_Alt : Node_Id := First (Alternatives (N));
begin
-- Do-while loop because there must be at least one alternative.
Copy link
Collaborator

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Maybe I am just old and paranoid BUT ... if you are assuming something it is best to make it an assert rather than a comment; even if it is 'obvious'.

Copy link
Contributor

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Definitely worth asserting, but the grammar does indeed guarantee this is true for now (but again, worth checking anyway, who knows what's going to happen in Ada 2023)
https://www.adaic.org/resources/add_content/standards/05rm/html/RM-3-8-1.html#S0073

Copy link
Contributor

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Parent link of one Hannes posted (case statements)
https://www.adaic.org/resources/add_content/standards/05rm/html/RM-5-4.html

loop
declare
This_Stmt : constant Irep :=
Process_Statements (Statements (This_Alt));
This_Alt_Copy : constant Node_Id := This_Alt;
This_Test : Irep;
begin
Next (This_Alt);
if not Present (This_Alt) then
-- Omit test, this is either `others`
-- or the last case of complete coverage
This_Test := This_Stmt;
else
This_Test := New_Irep (I_Code_Ifthenelse);
Set_Cond (This_Test,
Make_Single_Test
(First (Discrete_Choices (This_Alt_Copy))));
Set_Then_Case (This_Test, This_Stmt);
Append_Op (Ret, This_Test);
Copy link
Contributor

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I guess this line (and 1829) could be moved after the if-then-else block.

end if;
end;
exit when not Present (This_Alt);
end loop;
return Ret;
end Do_Case_Statement;

-----------------------
-- Do_Loop_Statement --
-----------------------
Expand Down Expand Up @@ -4031,7 +4086,7 @@ package body Tree_Walk is
Append_Op (Block, Do_If_Statement (N));

when N_Case_Statement =>
Warn_Unhandled_Construct (Statement, "case");
Append_Op (Block, Do_Case_Statement (N));

when N_Loop_Statement =>
Append_Op (Block, Do_Loop_Statement (N));
Expand Down