This patch corrects an issue whereby the compiler would issue incorrect
accessibility errors and checks for objects initialized by functions
returning anonymous access types or type conversions where the operand
is a function returning an anonymous access type.
Tested on x86_64-pc-linux-gnu, committed on trunk
2020-06-10 Justin Squirek <squi...@adacore.com>
gcc/ada/
* exp_ch3.adb (Expand_N_Object_Declaration): Add condition to
handle processing of objects initialized by a call to a function
return an anonymous access type.
* exp_ch6.adb, exp_ch6.ads
(Has_Unconstrained_Access_Discriminants): Moved to sem_util.adb
(Needs_Result_Accessibility_Level): Moved to sem_util.adb
* sem_util.adb, sem_util.ads
(Has_Unconstrained_Access_Discriminants): Moved from exp_ch6.adb
(Needs_Result_Accessibility_Level): Moved from exp_ch6.adb
* sem_res.adb (Valid_Conversion): Add condition for the special
case where the operand of a conversion is the result of an
anonymous access type--- gcc/ada/exp_ch3.adb
+++ gcc/ada/exp_ch3.adb
@@ -7178,21 +7178,32 @@ package body Exp_Ch3 is
Chars =>
New_External_Name (Chars (Def_Id), Suffix => "L"));
- Level_Expr : Node_Id;
Level_Decl : Node_Id;
+ Level_Expr : Node_Id;
begin
Set_Ekind (Level, Ekind (Def_Id));
Set_Etype (Level, Standard_Natural);
Set_Scope (Level, Scope (Def_Id));
- if No (Expr) then
-
- -- Set accessibility level of null
+ -- Set accessibility level of null
+ if No (Expr) then
Level_Expr :=
Make_Integer_Literal (Loc, Scope_Depth (Standard_Standard));
+ -- When the expression of the object is a function which returns
+ -- an anonymous access type the master of the call is the object
+ -- being initialized instead of the type.
+
+ elsif Nkind (Expr) = N_Function_Call
+ and then Ekind (Etype (Name (Expr))) = E_Anonymous_Access_Type
+ then
+ Level_Expr := Make_Integer_Literal (Loc,
+ Object_Access_Level (Def_Id));
+
+ -- General case
+
else
Level_Expr := Dynamic_Accessibility_Level (Expr);
end if;
--- gcc/ada/exp_ch6.adb
+++ gcc/ada/exp_ch6.adb
@@ -244,11 +244,6 @@ package body Exp_Ch6 is
-- Expand simple return from function. In the case where we are returning
-- from a function body this is called by Expand_N_Simple_Return_Statement.
- function Has_Unconstrained_Access_Discriminants
- (Subtyp : Entity_Id) return Boolean;
- -- Returns True if the given subtype is unconstrained and has one or more
- -- access discriminants.
-
procedure Insert_Post_Call_Actions (N : Node_Id; Post_Call : List_Id);
-- Insert the Post_Call list previously produced by routine Expand_Actuals
-- or Expand_Call_Helper into the tree.
@@ -7772,32 +7767,6 @@ package body Exp_Ch6 is
end if;
end Freeze_Subprogram;
- --------------------------------------------
- -- Has_Unconstrained_Access_Discriminants --
- --------------------------------------------
-
- function Has_Unconstrained_Access_Discriminants
- (Subtyp : Entity_Id) return Boolean
- is
- Discr : Entity_Id;
-
- begin
- if Has_Discriminants (Subtyp)
- and then not Is_Constrained (Subtyp)
- then
- Discr := First_Discriminant (Subtyp);
- while Present (Discr) loop
- if Ekind (Etype (Discr)) = E_Anonymous_Access_Type then
- return True;
- end if;
-
- Next_Discriminant (Discr);
- end loop;
- end if;
-
- return False;
- end Has_Unconstrained_Access_Discriminants;
-
------------------------------
-- Insert_Post_Call_Actions --
------------------------------
@@ -9431,144 +9400,6 @@ package body Exp_Ch6 is
return Requires_Transient_Scope (Func_Typ);
end Needs_BIP_Alloc_Form;
- --------------------------------------
- -- Needs_Result_Accessibility_Level --
- --------------------------------------
-
- function Needs_Result_Accessibility_Level
- (Func_Id : Entity_Id) return Boolean
- is
- Func_Typ : constant Entity_Id := Underlying_Type (Etype (Func_Id));
-
- function Has_Unconstrained_Access_Discriminant_Component
- (Comp_Typ : Entity_Id) return Boolean;
- -- Returns True if any component of the type has an unconstrained access
- -- discriminant.
-
- -----------------------------------------------------
- -- Has_Unconstrained_Access_Discriminant_Component --
- -----------------------------------------------------
-
- function Has_Unconstrained_Access_Discriminant_Component
- (Comp_Typ : Entity_Id) return Boolean
- is
- begin
- if not Is_Limited_Type (Comp_Typ) then
- return False;
-
- -- Only limited types can have access discriminants with
- -- defaults.
-
- elsif Has_Unconstrained_Access_Discriminants (Comp_Typ) then
- return True;
-
- elsif Is_Array_Type (Comp_Typ) then
- return Has_Unconstrained_Access_Discriminant_Component
- (Underlying_Type (Component_Type (Comp_Typ)));
-
- elsif Is_Record_Type (Comp_Typ) then
- declare
- Comp : Entity_Id;
-
- begin
- Comp := First_Component (Comp_Typ);
- while Present (Comp) loop
- if Has_Unconstrained_Access_Discriminant_Component
- (Underlying_Type (Etype (Comp)))
- then
- return True;
- end if;
-
- Next_Component (Comp);
- end loop;
- end;
- end if;
-
- return False;
- end Has_Unconstrained_Access_Discriminant_Component;
-
- Disable_Coextension_Cases : constant Boolean := True;
- -- Flag used to temporarily disable a "True" result for types with
- -- access discriminants and related coextension cases.
-
- -- Start of processing for Needs_Result_Accessibility_Level
-
- begin
- -- False if completion unavailable (how does this happen???)
-
- if not Present (Func_Typ) then
- return False;
-
- -- False if not a function, also handle enum-lit renames case
-
- elsif Func_Typ = Standard_Void_Type
- or else Is_Scalar_Type (Func_Typ)
- then
- return False;
-
- -- Handle a corner case, a cross-dialect subp renaming. For example,
- -- an Ada 2012 renaming of an Ada 2005 subprogram. This can occur when
- -- an Ada 2005 (or earlier) unit references predefined run-time units.
-
- elsif Present (Alias (Func_Id)) then
-
- -- Unimplemented: a cross-dialect subp renaming which does not set
- -- the Alias attribute (e.g., a rename of a dereference of an access
- -- to subprogram value). ???
-
- return Present (Extra_Accessibility_Of_Result (Alias (Func_Id)));
-
- -- Remaining cases require Ada 2012 mode
-
- elsif Ada_Version < Ada_2012 then
- return False;
-
- -- Handle the situation where a result is an anonymous access type
- -- RM 3.10.2 (10.3/3).
-
- elsif Ekind (Func_Typ) = E_Anonymous_Access_Type then
- return True;
-
- -- The following cases are related to coextensions and do not fully
- -- cover everything mentioned in RM 3.10.2 (12) ???
-
- -- Temporarily disabled ???
-
- elsif Disable_Coextension_Cases then
- return False;
-
- -- In the case of, say, a null tagged record result type, the need for
- -- this extra parameter might not be obvious so this function returns
- -- True for all tagged types for compatibility reasons.
-
- -- A function with, say, a tagged null controlling result type might
- -- be overridden by a primitive of an extension having an access
- -- discriminant and the overrider and overridden must have compatible
- -- calling conventions (including implicitly declared parameters).
-
- -- Similarly, values of one access-to-subprogram type might designate
- -- both a primitive subprogram of a given type and a function which is,
- -- for example, not a primitive subprogram of any type. Again, this
- -- requires calling convention compatibility. It might be possible to
- -- solve these issues by introducing wrappers, but that is not the
- -- approach that was chosen.
-
- elsif Is_Tagged_Type (Func_Typ) then
- return True;
-
- elsif Has_Unconstrained_Access_Discriminants (Func_Typ) then
- return True;
-
- elsif Has_Unconstrained_Access_Discriminant_Component (Func_Typ) then
- return True;
-
- -- False for all other cases
-
- else
- return False;
- end if;
- end Needs_Result_Accessibility_Level;
-
-------------------------------------
-- Replace_Renaming_Declaration_Id --
-------------------------------------
--- gcc/ada/exp_ch6.ads
+++ gcc/ada/exp_ch6.ads
@@ -247,12 +247,6 @@ package Exp_Ch6 is
function Needs_BIP_Task_Actuals (Func_Id : Entity_Id) return Boolean;
-- Return True if the function returns an object of a type that has tasks.
- function Needs_Result_Accessibility_Level
- (Func_Id : Entity_Id) return Boolean;
- -- Ada 2012 (AI05-0234): Return True if the function needs an implicit
- -- parameter to identify the accessibility level of the function result
- -- "determined by the point of call".
-
function Unqual_BIP_Iface_Function_Call (Expr : Node_Id) return Node_Id;
-- Return the inner BIP function call removing any qualification from Expr
-- including qualified expressions, type conversions, references, unchecked
--- gcc/ada/sem_res.adb
+++ gcc/ada/sem_res.adb
@@ -13086,8 +13086,16 @@ package body Sem_Res is
end if;
end if;
+ -- Check if the operand is deeper than the target type, taking
+ -- care to avoid the case where we are converting a result of a
+ -- function returning an anonymous access type since the "master
+ -- of the call" would be target type of the conversion in all
+ -- cases - see RM 10.3/3.
+
elsif Type_Access_Level (Opnd_Type) >
Deepest_Type_Access_Level (Target_Type)
+ and then not (Nkind (Associated_Node_For_Itype (Opnd_Type)) =
+ N_Function_Specification)
then
-- In an instance, this is a run-time check, but one we know
-- will fail, so generate an appropriate warning. The raise
--- gcc/ada/sem_util.adb
+++ gcc/ada/sem_util.adb
@@ -12326,6 +12326,32 @@ package body Sem_Util is
end if;
end Has_Tagged_Component;
+ --------------------------------------------
+ -- Has_Unconstrained_Access_Discriminants --
+ --------------------------------------------
+
+ function Has_Unconstrained_Access_Discriminants
+ (Subtyp : Entity_Id) return Boolean
+ is
+ Discr : Entity_Id;
+
+ begin
+ if Has_Discriminants (Subtyp)
+ and then not Is_Constrained (Subtyp)
+ then
+ Discr := First_Discriminant (Subtyp);
+ while Present (Discr) loop
+ if Ekind (Etype (Discr)) = E_Anonymous_Access_Type then
+ return True;
+ end if;
+
+ Next_Discriminant (Discr);
+ end loop;
+ end if;
+
+ return False;
+ end Has_Unconstrained_Access_Discriminants;
+
-----------------------------
-- Has_Undefined_Reference --
-----------------------------
@@ -17804,7 +17830,7 @@ package body Sem_Util is
and then Ekind_In (Scop, E_Function,
E_Operator,
E_Subprogram_Type)
- and then Present (Extra_Accessibility_Of_Result (Scop));
+ and then Needs_Result_Accessibility_Level (Scop);
end;
end Is_Special_Aliased_Formal_Access;
@@ -19903,6 +19929,144 @@ package body Sem_Util is
end if;
end Needs_One_Actual;
+ --------------------------------------
+ -- Needs_Result_Accessibility_Level --
+ --------------------------------------
+
+ function Needs_Result_Accessibility_Level
+ (Func_Id : Entity_Id) return Boolean
+ is
+ Func_Typ : constant Entity_Id := Underlying_Type (Etype (Func_Id));
+
+ function Has_Unconstrained_Access_Discriminant_Component
+ (Comp_Typ : Entity_Id) return Boolean;
+ -- Returns True if any component of the type has an unconstrained access
+ -- discriminant.
+
+ -----------------------------------------------------
+ -- Has_Unconstrained_Access_Discriminant_Component --
+ -----------------------------------------------------
+
+ function Has_Unconstrained_Access_Discriminant_Component
+ (Comp_Typ : Entity_Id) return Boolean
+ is
+ begin
+ if not Is_Limited_Type (Comp_Typ) then
+ return False;
+
+ -- Only limited types can have access discriminants with
+ -- defaults.
+
+ elsif Has_Unconstrained_Access_Discriminants (Comp_Typ) then
+ return True;
+
+ elsif Is_Array_Type (Comp_Typ) then
+ return Has_Unconstrained_Access_Discriminant_Component
+ (Underlying_Type (Component_Type (Comp_Typ)));
+
+ elsif Is_Record_Type (Comp_Typ) then
+ declare
+ Comp : Entity_Id;
+
+ begin
+ Comp := First_Component (Comp_Typ);
+ while Present (Comp) loop
+ if Has_Unconstrained_Access_Discriminant_Component
+ (Underlying_Type (Etype (Comp)))
+ then
+ return True;
+ end if;
+
+ Next_Component (Comp);
+ end loop;
+ end;
+ end if;
+
+ return False;
+ end Has_Unconstrained_Access_Discriminant_Component;
+
+ Disable_Coextension_Cases : constant Boolean := True;
+ -- Flag used to temporarily disable a "True" result for types with
+ -- access discriminants and related coextension cases.
+
+ -- Start of processing for Needs_Result_Accessibility_Level
+
+ begin
+ -- False if completion unavailable (how does this happen???)
+
+ if not Present (Func_Typ) then
+ return False;
+
+ -- False if not a function, also handle enum-lit renames case
+
+ elsif Func_Typ = Standard_Void_Type
+ or else Is_Scalar_Type (Func_Typ)
+ then
+ return False;
+
+ -- Handle a corner case, a cross-dialect subp renaming. For example,
+ -- an Ada 2012 renaming of an Ada 2005 subprogram. This can occur when
+ -- an Ada 2005 (or earlier) unit references predefined run-time units.
+
+ elsif Present (Alias (Func_Id)) then
+
+ -- Unimplemented: a cross-dialect subp renaming which does not set
+ -- the Alias attribute (e.g., a rename of a dereference of an access
+ -- to subprogram value). ???
+
+ return Present (Extra_Accessibility_Of_Result (Alias (Func_Id)));
+
+ -- Remaining cases require Ada 2012 mode
+
+ elsif Ada_Version < Ada_2012 then
+ return False;
+
+ -- Handle the situation where a result is an anonymous access type
+ -- RM 3.10.2 (10.3/3).
+
+ elsif Ekind (Func_Typ) = E_Anonymous_Access_Type then
+ return True;
+
+ -- The following cases are related to coextensions and do not fully
+ -- cover everything mentioned in RM 3.10.2 (12) ???
+
+ -- Temporarily disabled ???
+
+ elsif Disable_Coextension_Cases then
+ return False;
+
+ -- In the case of, say, a null tagged record result type, the need for
+ -- this extra parameter might not be obvious so this function returns
+ -- True for all tagged types for compatibility reasons.
+
+ -- A function with, say, a tagged null controlling result type might
+ -- be overridden by a primitive of an extension having an access
+ -- discriminant and the overrider and overridden must have compatible
+ -- calling conventions (including implicitly declared parameters).
+
+ -- Similarly, values of one access-to-subprogram type might designate
+ -- both a primitive subprogram of a given type and a function which is,
+ -- for example, not a primitive subprogram of any type. Again, this
+ -- requires calling convention compatibility. It might be possible to
+ -- solve these issues by introducing wrappers, but that is not the
+ -- approach that was chosen.
+
+ elsif Is_Tagged_Type (Func_Typ) then
+ return True;
+
+ elsif Has_Unconstrained_Access_Discriminants (Func_Typ) then
+ return True;
+
+ elsif Has_Unconstrained_Access_Discriminant_Component (Func_Typ) then
+ return True;
+
+ -- False for all other cases
+
+ else
+ return False;
+ end if;
+ end Needs_Result_Accessibility_Level;
+
---------------------------------
-- Needs_Simple_Initialization --
---------------------------------
--- gcc/ada/sem_util.ads
+++ gcc/ada/sem_util.ads
@@ -1367,6 +1367,11 @@ package Sem_Util is
-- function is used to check if "=" has to be expanded into a bunch
-- component comparisons.
+ function Has_Unconstrained_Access_Discriminants
+ (Subtyp : Entity_Id) return Boolean;
+ -- Returns True if the given subtype is unconstrained and has one or more
+ -- access discriminants.
+
function Has_Undefined_Reference (Expr : Node_Id) return Boolean;
-- Given arbitrary expression Expr, determine whether it contains at
-- least one name whose entity is Any_Id.
@@ -2251,6 +2256,12 @@ package Sem_Util is
-- syntactic ambiguity that results from an indexing of a function call
-- that returns an array, so that Obj.F (X, Y) may mean F (Ob) (X, Y).
+ function Needs_Result_Accessibility_Level
+ (Func_Id : Entity_Id) return Boolean;
+ -- Ada 2012 (AI05-0234): Return True if the function needs an implicit
+ -- parameter to identify the accessibility level of the function result
+ -- "determined by the point of call".
+
function Needs_Simple_Initialization
(Typ : Entity_Id;
Consider_IS : Boolean := True) return Boolean;
@@ -2713,6 +2724,10 @@ package Sem_Util is
-- Establish the entity E as the currently visible definition of its
-- associated name (i.e. the Node_Id associated with its name).
+ procedure Set_Debug_Info_Defining_Id (N : Node_Id);
+ -- Call Set_Debug_Info_Needed on Defining_Identifier (N) if it comes
+ -- from source.
+
procedure Set_Debug_Info_Needed (T : Entity_Id);
-- Sets the Debug_Info_Needed flag on entity T , and also on any entities
-- that are needed by T (for an object, the type of the object is needed,
@@ -2721,10 +2736,6 @@ package Sem_Util is
-- This routine should always be used instead of Set_Needs_Debug_Info to
-- ensure that subsidiary entities are properly handled.
- procedure Set_Debug_Info_Defining_Id (N : Node_Id);
- -- Call Set_Debug_Info_Needed on Defining_Identifier (N) if it comes
- -- from source.
-
procedure Set_Entity_With_Checks (N : Node_Id; Val : Entity_Id);
-- This procedure has the same calling sequence as Set_Entity, but it
-- performs additional checks as follows:
