OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

[Ada] Improve support for casing on types with controlled parts 

gcc/ada/

	* sem_case.adb (Check_Bindings): Provide a second strategy for
	implementing bindings and choose which strategy to use for a
	given binding. The previous approach was to introduce a new
	object and assign the bound value to the object.  The new
	approach is to introduce a renaming of a dereference of an
	access value that references the appropriate subcomponent, so no
	copies are made.  The original strategy is still used if the
	type of the object is elementary.  When the renaming approach is
	used, the initialization of the access value is not generated
	until expansion. Until this missing initialization is added, the
	tree looks like a known-at-compile-time dereference of a null
	access value: Temp : Some_Access_Type; Obj : Designated_Type
	renames Temp.all; This leads to problems, so a bogus initial
	value is provided here and then later deleted during expansion.
	(Check_Composite_Case_Selector): Disallow a case selector
	expression that requires finalization. Note that it is ok if the
	selector's type requires finalization, as long as the expression
	itself doesn't have any "newly constructed" parts.
	* exp_ch5.adb (Pattern_Match): Detect the case where analysis of
	a general (i.e., composite selector type) case statement chose
	to implement a binding as a renaming rather than by making a
	copy. In that case, generate the assignments to initialize the
	access-valued object whose designated value is later renamed
	(and remove the bogus initial value for that object that was
	added during analysis).
	* sem_util.ads, sem_util.adb: Add new function
	Is_Newly_Constructed corresponding to RM 4.4 term.
This commit is contained in:
Steve Baird 2021-11-05 15:22:05 -07:00 committed by Pierre-Marie de Rodat
parent be6bb3fc57
commit bb2fc099e2
4 changed files with 444 additions and 117 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

198
gcc/ada/exp_ch5.adb
View File

@ -3348,6 +3348,13 @@ package body Exp_Ch5 is
Alt : Node_Id;
Suppress_Choice_Index_Update : Boolean := False) return Node_Id
is
procedure Finish_Binding_Object_Declaration
(Component_Assoc : Node_Id; Subobject : Node_Id);
-- Finish the work that was started during analysis to
-- declare a binding object. If we are generating a copy,
-- then initialize it. If we are generating a renaming, then
-- initialize the access value designating the renamed object.
function Update_Choice_Index return Node_Id is (
Make_Assignment_Statement (Loc,
Name =>
@ -3368,6 +3375,130 @@ package body Exp_Ch5 is
function Indexed_Element (Idx : Pos) return Node_Id;
-- Returns the Nth (well, ok, the Idxth) element of Object
---------------------------------------
-- Finish_Binding_Object_Declaration --
---------------------------------------
procedure Finish_Binding_Object_Declaration
(Component_Assoc : Node_Id; Subobject : Node_Id)
is
Decl_Chars : constant Name_Id :=
Binding_Chars (Component_Assoc);
Block_Stmt : constant Node_Id := First (Statements (Alt));
pragma Assert (Nkind (Block_Stmt) = N_Block_Statement);
pragma Assert (No (Next (Block_Stmt)));
Decl : Node_Id := First (Declarations (Block_Stmt));
Def_Id : Node_Id := Empty;
-- Declare_Copy indicates which of the two approaches
-- was chosen during analysis: declare (and initialize)
-- a new variable, or use access values to declare a renaming
-- of the appropriate subcomponent of the selector value.
Declare_Copy : constant Boolean :=
Nkind (Decl) = N_Object_Declaration;
function Make_Conditional (Stmt : Node_Id) return Node_Id;
-- If there is only one choice for this alternative, then
-- simply return the argument. If there is more than one
-- choice, then wrap an if-statement around the argument
-- so that it is only executed if the current choice matches.
----------------------
-- Make_Conditional --
----------------------
function Make_Conditional (Stmt : Node_Id) return Node_Id
is
Condition : Node_Id;
begin
if Present (Choice_Index_Decl) then
Condition :=
Make_Op_Eq (Loc,
New_Occurrence_Of
(Defining_Identifier (Choice_Index_Decl), Loc),
Make_Integer_Literal (Loc, Int (Choice_Index)));
return Make_If_Statement (Loc,
Condition => Condition,
Then_Statements => New_List (Stmt));
else
-- execute Stmt unconditionally
return Stmt;
end if;
end Make_Conditional;
begin
-- find the variable to be modified (and its declaration)
loop
if Nkind (Decl) in N_Object_Declaration
| N_Object_Renaming_Declaration
then
Def_Id := Defining_Identifier (Decl);
exit when Chars (Def_Id) = Decl_Chars;
end if;
Next (Decl);
pragma Assert (Present (Decl));
end loop;
-- For a binding object, we sometimes make a copy and
-- sometimes introduce a renaming. That decision is made
-- elsewhere. The renaming case involves dereferencing an
-- access value because of the possibility of multiple
-- choices (with multiple binding definitions) for a single
-- alternative. In the copy case, we initialize the copy
-- here (conditionally if there are multiple choices); in the
-- renaming case, we initialize (again, maybe conditionally)
-- the access value.
if Declare_Copy then
declare
Assign_Value : constant Node_Id :=
Make_Assignment_Statement (Loc,
Name => New_Occurrence_Of (Def_Id, Loc),
Expression => Subobject);
HSS : constant Node_Id :=
Handled_Statement_Sequence (Block_Stmt);
begin
Prepend (Make_Conditional (Assign_Value),
Statements (HSS));
Set_Analyzed (HSS, False);
end;
else
pragma Assert (Nkind (Name (Decl)) = N_Explicit_Dereference);
declare
Ptr_Obj : constant Entity_Id :=
Entity (Prefix (Name (Decl)));
Ptr_Decl : constant Node_Id := Parent (Ptr_Obj);
Assign_Reference : constant Node_Id :=
Make_Assignment_Statement (Loc,
Name => New_Occurrence_Of (Ptr_Obj, Loc),
Expression =>
Make_Attribute_Reference (Loc,
Prefix => Subobject,
Attribute_Name => Name_Unrestricted_Access));
begin
Insert_After
(After => Ptr_Decl,
Node => Make_Conditional (Assign_Reference));
if Present (Expression (Ptr_Decl)) then
-- Delete bogus initial value built during analysis.
-- Look for "5432" in sem_case.adb.
pragma Assert (Nkind (Expression (Ptr_Decl)) =
N_Unchecked_Type_Conversion);
Set_Expression (Ptr_Decl, Empty);
end if;
end;
end if;
Set_Analyzed (Block_Stmt, False);
end Finish_Binding_Object_Declaration;
---------------------
-- Indexed_Element --
---------------------
@ -3519,70 +3650,9 @@ package body Exp_Ch5 is
if Binding_Chars (Component_Assoc) /= No_Name
then
declare
Decl_Chars : constant Name_Id :=
Binding_Chars (Component_Assoc);
Block_Stmt : constant Node_Id :=
First (Statements (Alt));
pragma Assert
(Nkind (Block_Stmt) = N_Block_Statement);
pragma Assert (No (Next (Block_Stmt)));
Decl : Node_Id
:= First (Declarations (Block_Stmt));
Def_Id : Node_Id := Empty;
Assignment_Stmt : Node_Id;
Condition : Node_Id;
Prepended_Stmt : Node_Id;
begin
-- find the variable to be modified
while No (Def_Id) or else
Chars (Def_Id) /= Decl_Chars
loop
Def_Id := Defining_Identifier (Decl);
Next (Decl);
end loop;
Assignment_Stmt :=
Make_Assignment_Statement (Loc,
Name => New_Occurrence_Of
(Def_Id, Loc),
Expression => Subobject);
-- conditional if multiple choices
if Present (Choice_Index_Decl) then
Condition :=
Make_Op_Eq (Loc,
New_Occurrence_Of
(Defining_Identifier
(Choice_Index_Decl), Loc),
Make_Integer_Literal
(Loc, Int (Choice_Index)));
Prepended_Stmt :=
Make_If_Statement (Loc,
Condition => Condition,
Then_Statements =>
New_List (Assignment_Stmt));
else
-- assignment is unconditional
Prepended_Stmt := Assignment_Stmt;
end if;
declare
HSS : constant Node_Id :=
Handled_Statement_Sequence
(Block_Stmt);
begin
Prepend (Prepended_Stmt,
Statements (HSS));
Set_Analyzed (Block_Stmt, False);
Set_Analyzed (HSS, False);
end;
end;
Finish_Binding_Object_Declaration
(Component_Assoc => Component_Assoc,
Subobject => Subobject);
end if;
Next (Choice);

233
gcc/ada/sem_case.adb
View File

@ -1991,6 +1991,154 @@ package body Sem_Case is
procedure Check_Bindings
is
use Case_Bindings_Table;
function Binding_Subtype (Idx : Binding_Index;
Tab : Table_Type)
return Entity_Id is
(Etype (Nlists.First (Choices (Tab (Idx).Comp_Assoc))));
procedure Declare_Binding_Objects
(Alt_Start : Binding_Index;
Alt : Node_Id;
First_Choice_Bindings : Natural;
Tab : Table_Type);
-- Declare the binding objects for a given alternative
------------------------------
-- Declare_Binding_Objects --
------------------------------
procedure Declare_Binding_Objects
(Alt_Start : Binding_Index;
Alt : Node_Id;
First_Choice_Bindings : Natural;
Tab : Table_Type)
is
Loc : constant Source_Ptr := Sloc (Alt);
Declarations : constant List_Id := New_List;
Decl : Node_Id;
Obj_Type : Entity_Id;
Def_Id : Entity_Id;
begin
for FC_Idx in Alt_Start ..
Alt_Start + Binding_Index (First_Choice_Bindings - 1)
loop
Obj_Type := Binding_Subtype (FC_Idx, Tab);
Def_Id := Make_Defining_Identifier
(Loc,
Binding_Chars (Tab (FC_Idx).Comp_Assoc));
-- Either make a copy or rename the original. At a
-- minimum, we do not want a copy if it would need
-- finalization. Copies may also introduce problems
-- if default init can have side effects (although we
-- could suppress such default initialization).
-- We have to make a copy in any cases where
-- Unrestricted_Access doesn't work.
--
-- This is where the copy-or-rename decision is made.
-- In many cases either way would work and so we have
-- some flexibility here.
if not Is_By_Copy_Type (Obj_Type) then
-- Generate
-- type Ref
-- is access constant Obj_Type;
-- Ptr : Ref := <some bogus value>;
-- Obj : Obj_Type renames Ptr.all;
--
-- Initialization of Ptr will be generated later
-- during expansion.
declare
Ptr_Type : constant Entity_Id :=
Make_Temporary (Loc, 'P');
Ptr_Type_Def : constant Node_Id :=
Make_Access_To_Object_Definition (Loc,
All_Present => True,
Subtype_Indication =>
New_Occurrence_Of (Obj_Type, Loc));
Ptr_Type_Decl : constant Node_Id :=
Make_Full_Type_Declaration (Loc,
Ptr_Type,
Type_Definition => Ptr_Type_Def);
Ptr_Obj : constant Entity_Id :=
Make_Temporary (Loc, 'T');
-- We will generate initialization code for this
-- object later (during expansion) but in the
-- meantime we don't want the dereference that
-- is generated a few lines below here to be
-- transformed into a Raise_C_E. To prevent this,
-- we provide a bogus initial value here; this
-- initial value will be removed later during
-- expansion.
Ptr_Obj_Decl : constant Node_Id :=
Make_Object_Declaration
(Loc, Ptr_Obj,
Object_Definition =>
New_Occurrence_Of (Ptr_Type, Loc),
Expression =>
Unchecked_Convert_To
(Ptr_Type,
Make_Integer_Literal (Loc, 5432)));
begin
Mutate_Ekind (Ptr_Type, E_Access_Type);
-- in effect, Storage_Size => 0
Set_No_Pool_Assigned (Ptr_Type);
Set_Is_Access_Constant (Ptr_Type);
-- We could set Ptr_Type'Alignment here if that
-- ever turns out to be needed for renaming a
-- misaligned subcomponent.
Mutate_Ekind (Ptr_Obj, E_Variable);
Set_Etype (Ptr_Obj, Ptr_Type);
Decl :=
Make_Object_Renaming_Declaration
(Loc, Def_Id,
Subtype_Mark =>
New_Occurrence_Of (Obj_Type, Loc),
Name =>
Make_Explicit_Dereference
(Loc, New_Occurrence_Of (Ptr_Obj, Loc)));
Append_To (Declarations, Ptr_Type_Decl);
Append_To (Declarations, Ptr_Obj_Decl);
end;
else
Decl := Make_Object_Declaration
(Sloc => Loc,
Defining_Identifier => Def_Id,
Object_Definition =>
New_Occurrence_Of (Obj_Type, Loc));
end if;
Append_To (Declarations, Decl);
end loop;
declare
Old_Statements : constant List_Id := Statements (Alt);
New_Statements : constant List_Id := New_List;
Block_Statement : constant Node_Id :=
Make_Block_Statement (Sloc => Loc,
Declarations => Declarations,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements
(Loc, Old_Statements),
Has_Created_Identifier => True);
begin
Append_To (New_Statements, Block_Statement);
Set_Statements (Alt, New_Statements);
end;
end Declare_Binding_Objects;
begin
if Last = 0 then
-- no bindings to check
@ -2005,10 +2153,6 @@ package body Sem_Case is
return Boolean is (
Binding_Chars (Tab (Idx1).Comp_Assoc) =
Binding_Chars (Tab (Idx2).Comp_Assoc));
function Binding_Subtype (Idx : Binding_Index)
return Entity_Id is
(Etype (Nlists.First (Choices (Tab (Idx).Comp_Assoc))));
begin
-- Verify that elements with given choice or alt value
-- are contiguous, and that elements with equal
@ -2172,8 +2316,8 @@ package body Sem_Case is
loop
if Same_Id (Idx2, FC_Idx) then
if not Subtypes_Statically_Match
(Binding_Subtype (Idx2),
Binding_Subtype (FC_Idx))
(Binding_Subtype (Idx2, Tab),
Binding_Subtype (FC_Idx, Tab))
then
Error_Msg_N
("subtype of binding in "
@ -2228,50 +2372,12 @@ package body Sem_Case is
-- the current alternative. Then analyze them.
if First_Choice_Bindings > 0 then
declare
Loc : constant Source_Ptr := Sloc (Alt);
Declarations : constant List_Id := New_List;
Decl : Node_Id;
begin
for FC_Idx in
Alt_Start ..
Alt_Start +
Binding_Index (First_Choice_Bindings - 1)
loop
Decl := Make_Object_Declaration
(Sloc => Loc,
Defining_Identifier =>
Make_Defining_Identifier
(Loc,
Binding_Chars
(Tab (FC_Idx).Comp_Assoc)),
Object_Definition =>
New_Occurrence_Of
(Binding_Subtype (FC_Idx), Loc));
Append_To (Declarations, Decl);
end loop;
declare
Old_Statements : constant List_Id :=
Statements (Alt);
New_Statements : constant List_Id :=
New_List;
Block_Statement : constant Node_Id :=
Make_Block_Statement (Sloc => Loc,
Declarations => Declarations,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements
(Loc, Old_Statements),
Has_Created_Identifier => True);
begin
Append_To
(New_Statements, Block_Statement);
Set_Statements (Alt, New_Statements);
end;
end;
Declare_Binding_Objects
(Alt_Start => Alt_Start,
Alt => Alt,
First_Choice_Bindings =>
First_Choice_Bindings,
Tab => Tab);
end if;
end;
end if;
@ -3361,11 +3467,32 @@ package body Sem_Case is
begin
if not Is_Composite_Type (Subtyp) then
Error_Msg_N
("case selector type neither discrete nor composite", N);
("case selector type must be discrete or composite", N);
elsif Is_Limited_Type (Subtyp) then
Error_Msg_N ("case selector type is limited", N);
Error_Msg_N ("case selector type must not be limited", N);
elsif Is_Class_Wide_Type (Subtyp) then
Error_Msg_N ("case selector type is class-wide", N);
Error_Msg_N ("case selector type must not be class-wide", N);
elsif Needs_Finalization (Subtyp)
and then Is_Newly_Constructed
(Expression (N), Context_Requires_NC => False)
then
-- We could allow this case as long as there are no bindings.
--
-- If there are bindings, then allowing this case will get
-- messy because the selector expression will be finalized
-- before the statements of the selected alternative are
-- executed (unless we add an INOX-specific change to the
-- accessibility rules to prevent this earlier-than-wanted
-- finalization, but adding new INOX-specific accessibility
-- complexity is probably not the direction we want to go).
-- This early selector finalization would be ok if we made
-- copies in this case (so that the bindings would not yield
-- a view of a finalized object), but then we'd have to deal
-- with finalizing those copies (which would necessarily
-- include defining their accessibility level). So it gets
-- messy either way.
Error_Msg_N ("case selector must not require finalization", N);
end if;
end Check_Composite_Case_Selector;

111
gcc/ada/sem_util.adb
View File

@ -18426,6 +18426,117 @@ package body Sem_Util is
end case;
end Is_Name_Reference;
--------------------------
-- Is_Newly_Constructed --
--------------------------
function Is_Newly_Constructed
(Exp : Node_Id; Context_Requires_NC : Boolean) return Boolean
is
Original_Exp : constant Node_Id := Original_Node (Exp);
function Is_NC (Exp : Node_Id) return Boolean is
(Is_Newly_Constructed (Exp, Context_Requires_NC));
-- If the context requires that the expression shall be newly
-- constructed, then "True" is a good result in the sense that the
-- expression satisfies the requirements of the context (and "False"
-- is analogously a bad result). If the context requires that the
-- expression shall *not* be newly constructed, then things are
-- reversed: "False" is the good value and "True" is the bad value.
Good_Result : constant Boolean := Context_Requires_NC;
Bad_Result : constant Boolean := not Good_Result;
begin
case Nkind (Original_Exp) is
when N_Aggregate
| N_Extension_Aggregate
| N_Function_Call
| N_Op
=>
return True;
when N_Identifier =>
return Present (Entity (Original_Exp))
and then Ekind (Entity (Original_Exp)) = E_Function;
when N_Qualified_Expression =>
return Is_NC (Expression (Original_Exp));
when N_Type_Conversion
| N_Unchecked_Type_Conversion
=>
if Is_View_Conversion (Original_Exp) then
return Is_NC (Expression (Original_Exp));
elsif not Comes_From_Source (Exp) then
if Exp /= Original_Exp then
return Is_NC (Original_Exp);
else
return Is_NC (Expression (Original_Exp));
end if;
else
return False;
end if;
when N_Explicit_Dereference
| N_Indexed_Component
| N_Selected_Component
=>
return Nkind (Exp) = N_Function_Call;
-- A use of 'Input is a function call, hence allowed. Normally the
-- attribute will be changed to a call, but the attribute by itself
-- can occur with -gnatc.
when N_Attribute_Reference =>
return Attribute_Name (Original_Exp) = Name_Input;
-- "return raise ..." is OK
when N_Raise_Expression =>
return Good_Result;
-- For a case expression, all dependent expressions must be legal
when N_Case_Expression =>
declare
Alt : Node_Id;
begin
Alt := First (Alternatives (Original_Exp));
while Present (Alt) loop
if Is_NC (Expression (Alt)) = Bad_Result then
return Bad_Result;
end if;
Next (Alt);
end loop;
return Good_Result;
end;
-- For an if expression, all dependent expressions must be legal
when N_If_Expression =>
declare
Then_Expr : constant Node_Id :=
Next (First (Expressions (Original_Exp)));
Else_Expr : constant Node_Id := Next (Then_Expr);
begin
if (Is_NC (Then_Expr) = Bad_Result)
or else (Is_NC (Else_Expr) = Bad_Result)
then
return Bad_Result;
else
return Good_Result;
end if;
end;
when others =>
return False;
end case;
end Is_Newly_Constructed;
------------------------------------
-- Is_Non_Preelaborable_Construct --
------------------------------------

19
gcc/ada/sem_util.ads
View File

@ -1521,6 +1521,25 @@ package Sem_Util is
-- integer for use in compile-time checking. Note: Level is restricted to
-- be non-dynamic.
function Is_Newly_Constructed
(Exp : Node_Id; Context_Requires_NC : Boolean) return Boolean;
-- Indicates whether a given expression is "newly constructed" (RM 4.4).
-- Context_Requires_NC determines the result returned for cases like a
-- raise expression or a conditional expression where some-but-not-all
-- operative constituents are newly constructed. Thus, this is a
-- somewhat unusual predicate in that the result required in order to
-- satisfy whatever legality rule is being checked can influence the
-- result of the predicate. Context_Requires_NC might be True for
-- something like the "newly constructed" rule for a limited expression
-- of a return statement, and False for something like the
-- "newly constructed" rule pertaining to a limited object renaming in a
-- declare expression. Eventually, the code to implement every
-- RM legality rule requiring/prohibiting a "newly constructed" expression
-- should be implemented by calling this function; that's not done yet.
-- The function name doesn't quite match the RM definition of the term if
-- Context_Requires_NC = False; in that case, "Might_Be_Newly_Constructed"
-- might be a more accurate name.
function Is_Prim_Of_Abst_Type_With_Nonstatic_CW_Pre_Post
(Subp : Entity_Id) return Boolean;
-- Return True if Subp is a primitive of an abstract type, where the