public inbox for gcc-cvs@sourceware.org
help / color / mirror / Atom feed
* [gcc r13-2586] [Ada] Revert "Enforce matching of extra formals"
@ 2022-09-12 8:19 Marc Poulhiès
0 siblings, 0 replies; only message in thread
From: Marc Poulhiès @ 2022-09-12 8:19 UTC (permalink / raw)
To: gcc-cvs
https://gcc.gnu.org/g:dad0ebe674d495a7e032a123d2d60c090729ef2c
commit r13-2586-gdad0ebe674d495a7e032a123d2d60c090729ef2c
Author: Javier Miranda <miranda@adacore.com>
Date: Tue Aug 23 11:28:43 2022 +0000
[Ada] Revert "Enforce matching of extra formals"
This reverts commit 51abc0cc8691daecd7cec8372e4988e9f3f1913c.
Diff:
---
gcc/ada/debug.adb | 6 +-
gcc/ada/exp_attr.adb | 41 +-
gcc/ada/exp_ch3.adb | 129 +-----
gcc/ada/exp_ch3.ads | 16 +-
gcc/ada/exp_ch6.adb | 52 +--
gcc/ada/exp_ch6.ads | 12 -
gcc/ada/freeze.adb | 103 ++++-
gcc/ada/sem_ch3.adb | 23 +-
gcc/ada/sem_ch6.adb | 1182 ++++++++++++--------------------------------------
gcc/ada/sem_ch6.ads | 16 -
gcc/ada/sem_eval.adb | 1 -
gcc/ada/sem_util.adb | 7 +-
12 files changed, 439 insertions(+), 1149 deletions(-)
diff --git a/gcc/ada/debug.adb b/gcc/ada/debug.adb
index dce460fc701..b67103a0ff3 100644
--- a/gcc/ada/debug.adb
+++ b/gcc/ada/debug.adb
@@ -189,7 +189,7 @@ package body Debug is
-- d_U Disable prepending messages with "error:".
-- d_V Enable verifications on the expanded tree
-- d_W
- -- d_X Disable assertions to check matching of extra formals
+ -- d_X
-- d_Y
-- d_Z
@@ -1044,10 +1044,6 @@ package body Debug is
-- d_V Enable verification of the expanded code before calling the backend
-- and generate error messages on each inconsistency found.
- -- d_X Disable assertions to check matching of extra formals; switch added
- -- temporarily to disable these checks until this work is complete if
- -- they cause unexpected assertion failures.
-
-- d1 Error messages have node numbers where possible. Normally error
-- messages have only source locations. This option is useful when
-- debugging errors caused by expanded code, where the source location
diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb
index 2d4a4712f9d..4a266715b28 100644
--- a/gcc/ada/exp_attr.adb
+++ b/gcc/ada/exp_attr.adb
@@ -2311,40 +2311,19 @@ package body Exp_Attr is
if Is_Access_Protected_Subprogram_Type (Btyp) then
Expand_Access_To_Protected_Op (N, Pref, Typ);
+ -- If prefix is a subprogram that has class-wide preconditions and
+ -- an indirect-call wrapper (ICW) of such subprogram is available
+ -- then replace the prefix by the ICW.
+
elsif Is_Access_Subprogram_Type (Btyp)
and then Is_Entity_Name (Pref)
+ and then Present (Class_Preconditions (Entity (Pref)))
+ and then Present (Indirect_Call_Wrapper (Entity (Pref)))
then
- -- If prefix is a subprogram that has class-wide preconditions
- -- and an indirect-call wrapper (ICW) of the subprogram is
- -- available then replace the prefix by the ICW.
-
- if Present (Class_Preconditions (Entity (Pref)))
- and then Present (Indirect_Call_Wrapper (Entity (Pref)))
- then
- Rewrite (Pref,
- New_Occurrence_Of
- (Indirect_Call_Wrapper (Entity (Pref)), Loc));
- Analyze_And_Resolve (N, Typ);
- end if;
-
- -- Ensure the availability of the extra formals to check that
- -- they match.
-
- if not Is_Frozen (Entity (Pref))
- or else From_Limited_With (Etype (Entity (Pref)))
- then
- Create_Extra_Formals (Entity (Pref));
- end if;
-
- if not Is_Frozen (Btyp_DDT)
- or else From_Limited_With (Etype (Btyp_DDT))
- then
- Create_Extra_Formals (Btyp_DDT);
- end if;
-
- pragma Assert
- (Extra_Formals_Match_OK
- (E => Entity (Pref), Ref_E => Btyp_DDT));
+ Rewrite (Pref,
+ New_Occurrence_Of
+ (Indirect_Call_Wrapper (Entity (Pref)), Loc));
+ Analyze_And_Resolve (N, Typ);
-- If prefix is a type name, this is a reference to the current
-- instance of the type, within its initialization procedure.
diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb
index 30ec739545f..0d826913f75 100644
--- a/gcc/ada/exp_ch3.adb
+++ b/gcc/ada/exp_ch3.adb
@@ -44,6 +44,7 @@ with Exp_Dist; use Exp_Dist;
with Exp_Put_Image;
with Exp_Smem; use Exp_Smem;
with Exp_Strm; use Exp_Strm;
+with Exp_Tss; use Exp_Tss;
with Exp_Util; use Exp_Util;
with Freeze; use Freeze;
with Ghost; use Ghost;
@@ -407,6 +408,15 @@ package body Exp_Ch3 is
-- Freeze entities of all predefined primitive operations. This is needed
-- because the bodies of these operations do not normally do any freezing.
+ function Stream_Operation_OK
+ (Typ : Entity_Id;
+ Operation : TSS_Name_Type) return Boolean;
+ -- Check whether the named stream operation must be emitted for a given
+ -- type. The rules for inheritance of stream attributes by type extensions
+ -- are enforced by this function. Furthermore, various restrictions prevent
+ -- the generation of these operations, as a useful optimization or for
+ -- certification purposes and to save unnecessary generated code.
+
--------------------------
-- Adjust_Discriminants --
--------------------------
@@ -5369,10 +5379,6 @@ package body Exp_Ch3 is
procedure Register_Dispatch_Table_Wrappers (Typ : Entity_Id);
-- Register dispatch-table wrappers in the dispatch table of Typ
- procedure Validate_Tagged_Type_Extra_Formals (Typ : Entity_Id);
- -- Check extra formals of dispatching primitives of tagged type Typ.
- -- Used in pragma Debug.
-
---------------------------------------
-- Build_Class_Condition_Subprograms --
---------------------------------------
@@ -5502,71 +5508,6 @@ package body Exp_Ch3 is
end loop;
end Register_Dispatch_Table_Wrappers;
- ----------------------------------------
- -- Validate_Tagged_Type_Extra_Formals --
- ----------------------------------------
-
- procedure Validate_Tagged_Type_Extra_Formals (Typ : Entity_Id) is
- Ovr_Subp : Entity_Id;
- Elmt : Elmt_Id;
- Subp : Entity_Id;
-
- begin
- pragma Assert (not Is_Class_Wide_Type (Typ));
-
- -- No check required if expansion is not active since we never
- -- generate extra formals in such case.
-
- if not Expander_Active then
- return;
- end if;
-
- Elmt := First_Elmt (Primitive_Operations (Typ));
- while Present (Elmt) loop
- Subp := Node (Elmt);
-
- -- Extra formals of a primitive must match the extra formals of
- -- its covered interface primitive.
-
- if Present (Interface_Alias (Subp)) then
- pragma Assert
- (Extra_Formals_Match_OK
- (E => Interface_Alias (Subp),
- Ref_E => Alias (Subp)));
-
- elsif Present (Overridden_Operation (Subp)) then
- Ovr_Subp := Overridden_Operation (Subp);
-
- -- Handle controlling function wrapper
-
- if Is_Wrapper (Subp)
- and then Ultimate_Alias (Ovr_Subp) = Subp
- then
- if Present (Overridden_Operation (Ovr_Subp)) then
- pragma Assert
- (Extra_Formals_Match_OK
- (E => Subp,
- Ref_E => Overridden_Operation (Ovr_Subp)));
- end if;
-
- else
- pragma Assert
- (Extra_Formals_Match_OK
- (E => Subp,
- Ref_E => Overridden_Operation (Subp)));
- end if;
-
- elsif Present (Alias (Subp)) then
- pragma Assert
- (Extra_Formals_Match_OK
- (E => Subp,
- Ref_E => Ultimate_Alias (Subp)));
- end if;
-
- Next_Elmt (Elmt);
- end loop;
- end Validate_Tagged_Type_Extra_Formals;
-
-- Local variables
Typ : constant Node_Id := Entity (N);
@@ -5955,58 +5896,28 @@ package body Exp_Ch3 is
-- inherited functions, then add their bodies to the freeze actions.
Append_Freeze_Actions (Typ, Wrapper_Body_List);
- end if;
- -- Create extra formals for the primitive operations of the type.
- -- This must be done before analyzing the body of the initialization
- -- procedure, because a self-referential type might call one of these
- -- primitives in the body of the init_proc itself.
- --
- -- This is not needed:
- -- 1) If expansion is disabled, because extra formals are only added
- -- when we are generating code.
- --
- -- 2) For types with foreign convention since primitives with foreign
- -- convention don't have extra formals and AI-117 requires that all
- -- primitives of a tagged type inherit the convention.
+ -- Create extra formals for the primitive operations of the type.
+ -- This must be done before analyzing the body of the initialization
+ -- procedure, because a self-referential type might call one of these
+ -- primitives in the body of the init_proc itself.
- if Expander_Active
- and then Is_Tagged_Type (Typ)
- and then not Has_Foreign_Convention (Typ)
- then
declare
Elmt : Elmt_Id;
- E : Entity_Id;
+ Subp : Entity_Id;
begin
- -- Add extra formals to primitive operations
-
Elmt := First_Elmt (Primitive_Operations (Typ));
while Present (Elmt) loop
- Create_Extra_Formals (Node (Elmt));
- Next_Elmt (Elmt);
- end loop;
-
- -- Add extra formals to renamings of primitive operations. The
- -- addition of extra formals is done in two steps to minimize
- -- the compile time required for this action; the evaluation of
- -- Find_Dispatching_Type() and Contains() is only done here for
- -- renamings that are not primitive operations.
-
- E := First_Entity (Scope (Typ));
- while Present (E) loop
- if Is_Dispatching_Operation (E)
- and then Present (Alias (E))
- and then Find_Dispatching_Type (E) = Typ
- and then not Contains (Primitive_Operations (Typ), E)
+ Subp := Node (Elmt);
+ if not Has_Foreign_Convention (Subp)
+ and then not Is_Predefined_Dispatching_Operation (Subp)
then
- Create_Extra_Formals (E);
+ Create_Extra_Formals (Subp);
end if;
- Next_Entity (E);
+ Next_Elmt (Elmt);
end loop;
-
- pragma Debug (Validate_Tagged_Type_Extra_Formals (Typ));
end;
end if;
diff --git a/gcc/ada/exp_ch3.ads b/gcc/ada/exp_ch3.ads
index 24e2263296d..f7d43c4aa7e 100644
--- a/gcc/ada/exp_ch3.ads
+++ b/gcc/ada/exp_ch3.ads
@@ -25,10 +25,9 @@
-- Expand routines for chapter 3 constructs
-with Types; use Types;
-with Elists; use Elists;
-with Exp_Tss; use Exp_Tss;
-with Uintp; use Uintp;
+with Types; use Types;
+with Elists; use Elists;
+with Uintp; use Uintp;
package Exp_Ch3 is
@@ -208,13 +207,4 @@ package Exp_Ch3 is
-- Make_Predefined_Primitive_Eq_Spec; see there for description of
-- the Renamed_Eq parameter.
- function Stream_Operation_OK
- (Typ : Entity_Id;
- Operation : TSS_Name_Type) return Boolean;
- -- Check whether the named stream operation must be emitted for a given
- -- type. The rules for inheritance of stream attributes by type extensions
- -- are enforced by this function. Furthermore, various restrictions prevent
- -- the generation of these operations, as a useful optimization or for
- -- certification purposes and to save unnecessary generated code.
-
end Exp_Ch3;
diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb
index 721298faf75..fe3bb5be28d 100644
--- a/gcc/ada/exp_ch6.adb
+++ b/gcc/ada/exp_ch6.adb
@@ -315,6 +315,15 @@ 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_BIP_Extra_Formal
+ (E : Entity_Id;
+ Kind : BIP_Formal_Kind) return Boolean;
+ -- Given a frozen subprogram, subprogram type, entry or entry family,
+ -- return True if E has the BIP extra formal associated with Kind. It must
+ -- be invoked with a frozen entity or a subprogram type of a dispatching
+ -- call since we can only rely on the availability of the extra formals
+ -- on these entities.
+
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.
@@ -3804,7 +3813,7 @@ package body Exp_Ch6 is
and then Thunk_Entity (Current_Scope) = Subp
and then Present (Extra_Formals (Subp))
then
- pragma Assert (Extra_Formals_Match_OK (Current_Scope, Subp));
+ pragma Assert (Present (Extra_Formals (Current_Scope)));
declare
Target_Formal : Entity_Id;
@@ -7185,9 +7194,8 @@ package body Exp_Ch6 is
--------------------------
function Has_BIP_Extra_Formal
- (E : Entity_Id;
- Kind : BIP_Formal_Kind;
- Must_Be_Frozen : Boolean := True) return Boolean
+ (E : Entity_Id;
+ Kind : BIP_Formal_Kind) return Boolean
is
Extra_Formal : Entity_Id := Extra_Formals (E);
@@ -7197,7 +7205,7 @@ package body Exp_Ch6 is
-- extra formals are added when the target subprogram is frozen; see
-- Expand_Dispatching_Call).
- pragma Assert ((Is_Frozen (E) or else not Must_Be_Frozen)
+ pragma Assert (Is_Frozen (E)
or else (Ekind (E) = E_Subprogram_Type
and then Is_Dispatch_Table_Entity (E))
or else (Is_Dispatching_Operation (E)
@@ -7826,7 +7834,7 @@ package body Exp_Ch6 is
or else
(Kind = E_Subprogram_Type and then Typ /= Standard_Void_Type))
and then Is_Build_In_Place_Result_Type (Typ)
- and then not Has_Foreign_Convention (E);
+ and then not (Is_Imported (E) and then Has_Foreign_Convention (E));
end Is_Build_In_Place_Function;
-------------------------------------
@@ -8555,11 +8563,6 @@ package body Exp_Ch6 is
-- initialization expression of the object to Empty, which would be
-- illegal Ada, and would cause gigi to misallocate X.
- Is_OK_Return_Object : constant Boolean :=
- Is_Return_Object (Obj_Def_Id)
- and then
- not Has_Foreign_Convention (Return_Applies_To (Scope (Obj_Def_Id)));
-
-- Start of processing for Make_Build_In_Place_Call_In_Object_Declaration
begin
@@ -8612,7 +8615,7 @@ package body Exp_Ch6 is
-- the result object is in a different (transient) scope, so won't cause
-- freezing.
- if Definite and then not Is_OK_Return_Object then
+ if Definite and then not Is_Return_Object (Obj_Def_Id) then
-- The presence of an address clause complicates the build-in-place
-- expansion because the indicated address must be processed before
@@ -8695,7 +8698,7 @@ package body Exp_Ch6 is
-- really be directly built in place in the aggregate and not in a
-- temporary. ???)
- if Is_OK_Return_Object then
+ if Is_Return_Object (Obj_Def_Id) then
Pass_Caller_Acc := True;
-- When the enclosing function has a BIP_Alloc_Form formal then we
@@ -8880,7 +8883,7 @@ package body Exp_Ch6 is
-- itself the return expression of an enclosing BIP function, then mark
-- the object as having no initialization.
- if Definite and then not Is_OK_Return_Object then
+ if Definite and then not Is_Return_Object (Obj_Def_Id) then
-- The related object declaration is encased in a transient block
-- because the build-in-place function call contains at least one
@@ -9237,7 +9240,7 @@ package body Exp_Ch6 is
and then not No_Run_Time_Mode
and then (Has_Task (Typ)
or else (Is_Class_Wide_Type (Typ)
- and then Is_Limited_Record (Etype (Typ))
+ and then Is_Limited_Record (Typ)
and then not Has_Aspect
(Etype (Typ), Aspect_No_Task_Parts)));
end Might_Have_Tasks;
@@ -9247,6 +9250,7 @@ package body Exp_Ch6 is
----------------------------
function Needs_BIP_Task_Actuals (Func_Id : Entity_Id) return Boolean is
+ pragma Assert (Is_Build_In_Place_Function (Func_Id));
Subp_Id : Entity_Id;
Func_Typ : Entity_Id;
@@ -9271,12 +9275,6 @@ package body Exp_Ch6 is
Func_Typ := Underlying_Type (Etype (Subp_Id));
- -- Functions returning types with foreign convention don't have extra
- -- formals.
-
- if Has_Foreign_Convention (Func_Typ) then
- return False;
-
-- At first sight, for all the following cases, we could add assertions
-- to ensure that if Func_Id is frozen then the computed result matches
-- with the availability of the task master extra formal; unfortunately
@@ -9284,7 +9282,7 @@ package body Exp_Ch6 is
-- (that is, Is_Frozen has been set by Freeze_Entity but it has not
-- completed its work).
- elsif Has_Task (Func_Typ) then
+ if Has_Task (Func_Typ) then
return True;
elsif Ekind (Func_Id) = E_Function then
@@ -9316,6 +9314,8 @@ package body Exp_Ch6 is
Typ : constant Entity_Id := Underlying_Type (Etype (Func_Id));
begin
+ pragma Assert (Is_Build_In_Place_Function (Func_Id));
+
-- A formal giving the finalization master is needed for build-in-place
-- functions whose result type needs finalization or is a tagged type.
-- Tagged primitive build-in-place functions need such a formal because
@@ -9327,8 +9327,7 @@ package body Exp_Ch6 is
-- such build-in-place functions, primitive or not.
return not Restriction_Active (No_Finalization)
- and then (Needs_Finalization (Typ) or else Is_Tagged_Type (Typ))
- and then not Has_Foreign_Convention (Typ);
+ and then (Needs_Finalization (Typ) or else Is_Tagged_Type (Typ));
end Needs_BIP_Finalization_Master;
--------------------------
@@ -9339,6 +9338,8 @@ package body Exp_Ch6 is
Typ : constant Entity_Id := Underlying_Type (Etype (Func_Id));
begin
+ pragma Assert (Is_Build_In_Place_Function (Func_Id));
+
-- A formal giving the allocation method is needed for build-in-place
-- functions whose result type is returned on the secondary stack or
-- is a tagged type. Tagged primitive build-in-place functions need
@@ -9350,8 +9351,7 @@ package body Exp_Ch6 is
-- to be passed to all such build-in-place functions, primitive or not.
return not Restriction_Active (No_Secondary_Stack)
- and then (Needs_Secondary_Stack (Typ) or else Is_Tagged_Type (Typ))
- and then not Has_Foreign_Convention (Typ);
+ and then (Needs_Secondary_Stack (Typ) or else Is_Tagged_Type (Typ));
end Needs_BIP_Alloc_Form;
-------------------------------------
diff --git a/gcc/ada/exp_ch6.ads b/gcc/ada/exp_ch6.ads
index ab547b9fdf3..19d0bc3ff69 100644
--- a/gcc/ada/exp_ch6.ads
+++ b/gcc/ada/exp_ch6.ads
@@ -121,18 +121,6 @@ package Exp_Ch6 is
-- The returned node is the root of the procedure body which will replace
-- the original function body, which is not needed for the C program.
- function Has_BIP_Extra_Formal
- (E : Entity_Id;
- Kind : BIP_Formal_Kind;
- Must_Be_Frozen : Boolean := True) return Boolean;
- -- Given a subprogram, subprogram type, entry or entry family, return True
- -- if E has the BIP extra formal associated with Kind. In general this
- -- subprogram must be invoked with a frozen entity or a subprogram type of
- -- a dispatching call since we can only rely on the availability of extra
- -- formals on these entities; this requirement can be relaxed using the
- -- formal Must_Be_Frozen in scenarios where we know that the entity has
- -- the extra formals.
-
procedure Install_Class_Preconditions_Check (Call_Node : Node_Id);
-- Install check of class-wide preconditions on the caller.
diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb
index 3adc255392f..52858e23b33 100644
--- a/gcc/ada/freeze.adb
+++ b/gcc/ada/freeze.adb
@@ -4979,7 +4979,6 @@ package body Freeze is
and then Convention (Desig) /= Convention_Protected
then
Set_Is_Frozen (Desig);
- Create_Extra_Formals (Desig);
end if;
end Check_Itype;
@@ -8238,7 +8237,7 @@ package body Freeze is
if Present (Nam)
and then Ekind (Nam) = E_Function
and then Nkind (Parent (N)) = N_Function_Call
- and then not Has_Foreign_Convention (Nam)
+ and then Convention (Nam) = Convention_Ada
then
Create_Extra_Formals (Nam);
end if;
@@ -9845,11 +9844,77 @@ package body Freeze is
-----------------------
procedure Freeze_Subprogram (E : Entity_Id) is
+ function Check_Extra_Formals (E : Entity_Id) return Boolean;
+ -- Return True if the decoration of the attributes associated with extra
+ -- formals are properly set.
procedure Set_Profile_Convention (Subp_Id : Entity_Id);
-- Set the conventions of all anonymous access-to-subprogram formals and
-- result subtype of subprogram Subp_Id to the convention of Subp_Id.
+ -------------------------
+ -- Check_Extra_Formals --
+ -------------------------
+
+ function Check_Extra_Formals (E : Entity_Id) return Boolean is
+ Last_Formal : Entity_Id := Empty;
+ Formal : Entity_Id;
+ Has_Extra_Formals : Boolean := False;
+
+ begin
+ -- No check required if expansion is disabled because extra
+ -- formals are only generated when we are generating code.
+ -- See Create_Extra_Formals.
+
+ if not Expander_Active then
+ return True;
+ end if;
+
+ -- Check attribute Extra_Formal: If available, it must be set only
+ -- on the last formal of E.
+
+ Formal := First_Formal (E);
+ while Present (Formal) loop
+ if Present (Extra_Formal (Formal)) then
+ if Has_Extra_Formals then
+ return False;
+ end if;
+
+ Has_Extra_Formals := True;
+ end if;
+
+ Last_Formal := Formal;
+ Next_Formal (Formal);
+ end loop;
+
+ -- Check attribute Extra_Accessibility_Of_Result
+
+ if Ekind (E) in E_Function | E_Subprogram_Type
+ and then Needs_Result_Accessibility_Level (E)
+ and then No (Extra_Accessibility_Of_Result (E))
+ then
+ return False;
+ end if;
+
+ -- Check attribute Extra_Formals: If E has extra formals, then this
+ -- attribute must point to the first extra formal of E.
+
+ if Has_Extra_Formals then
+ return Present (Extra_Formals (E))
+ and then Present (Extra_Formal (Last_Formal))
+ and then Extra_Formal (Last_Formal) = Extra_Formals (E);
+
+ -- When E has no formals, the first extra formal is available through
+ -- the Extra_Formals attribute.
+
+ elsif Present (Extra_Formals (E)) then
+ return No (First_Formal (E));
+
+ else
+ return True;
+ end if;
+ end Check_Extra_Formals;
+
----------------------------
-- Set_Profile_Convention --
----------------------------
@@ -9988,26 +10053,30 @@ package body Freeze is
-- that we know the convention.
if not Has_Foreign_Convention (E) then
+ if No (Extra_Formals (E)) then
- -- Extra formals of dispatching operations are added later by
- -- Expand_Freeze_Record_Type, which also adds extra formals to
- -- internal entities built to handle interface types.
+ -- Extra formals are shared by derived subprograms; therefore, if
+ -- the ultimate alias of E has been frozen before E then the extra
+ -- formals have been added, but the attribute Extra_Formals is
+ -- still unset (and must be set now).
- if not Is_Dispatching_Operation (E) then
- Create_Extra_Formals (E);
+ if Present (Alias (E))
+ and then Is_Frozen (Ultimate_Alias (E))
+ and then Present (Extra_Formals (Ultimate_Alias (E)))
+ and then Last_Formal (Ultimate_Alias (E)) = Last_Formal (E)
+ then
+ Set_Extra_Formals (E, Extra_Formals (Ultimate_Alias (E)));
- pragma Assert
- ((Ekind (E) = E_Subprogram_Type
- and then Extra_Formals_OK (E))
- or else
- (Is_Subprogram (E)
- and then Extra_Formals_OK (E)
- and then
- (No (Overridden_Operation (E))
- or else Extra_Formals_Match_OK (E,
- Ultimate_Alias (Overridden_Operation (E))))));
+ if Ekind (E) = E_Function then
+ Set_Extra_Accessibility_Of_Result (E,
+ Extra_Accessibility_Of_Result (Ultimate_Alias (E)));
+ end if;
+ else
+ Create_Extra_Formals (E);
+ end if;
end if;
+ pragma Assert (Check_Extra_Formals (E));
Set_Mechanisms (E);
-- If this is convention Ada and a Valued_Procedure, that's odd
diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb
index 99e188d1491..00c2e67fa20 100644
--- a/gcc/ada/sem_ch3.adb
+++ b/gcc/ada/sem_ch3.adb
@@ -1318,8 +1318,7 @@ package body Sem_Ch3 is
Check_Restriction (No_Access_Subprograms, T_Def);
- -- Addition of extra formals must be delayed till the freeze point so
- -- that we know the convention.
+ Create_Extra_Formals (Desig_Type);
end Access_Subprogram_Declaration;
----------------------------
@@ -11769,9 +11768,11 @@ package body Sem_Ch3 is
Insert_Before (Typ_Decl, Decl);
Analyze (Decl);
- -- At first sight we could add here the extra formals of an access to
- -- subprogram; however, it must delayed till the freeze point so that
- -- we know the convention.
+ -- If an access to subprogram, create the extra formals
+
+ if Present (Acc_Def) then
+ Create_Extra_Formals (Designated_Type (Anon_Access));
+ end if;
if Nkind (Comp_Def) = N_Component_Definition then
Rewrite (Comp_Def,
@@ -16032,12 +16033,12 @@ package body Sem_Ch3 is
Next_Formal (Formal);
end loop;
- -- Extra formals are shared between the parent subprogram and this
- -- internal entity built by Derive_Subprogram (implicit in the above
- -- copy of formals), unless the parent type is a limited interface type;
- -- hence we must inherit also the reference to the first extra formal.
- -- When the parent type is an interface, the extra formals will be added
- -- when the tagged type is frozen (see Expand_Freeze_Record_Type).
+ -- Extra formals are shared between the parent subprogram and the
+ -- derived subprogram (implicit in the above copy of formals), unless
+ -- the parent type is a limited interface type; hence we must inherit
+ -- also the reference to the first extra formal. When the parent type is
+ -- an interface the extra formals will be added when the subprogram is
+ -- frozen (see Freeze.Freeze_Subprogram).
if not Is_Limited_Interface (Parent_Type) then
Set_Extra_Formals (New_Subp, Extra_Formals (Parent_Subp));
diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb
index 6f71adbe199..c92e69139be 100644
--- a/gcc/ada/sem_ch6.adb
+++ b/gcc/ada/sem_ch6.adb
@@ -34,7 +34,6 @@ with Einfo.Utils; use Einfo.Utils;
with Elists; use Elists;
with Errout; use Errout;
with Expander; use Expander;
-with Exp_Ch3; use Exp_Ch3;
with Exp_Ch6; use Exp_Ch6;
with Exp_Ch9; use Exp_Ch9;
with Exp_Dbug; use Exp_Dbug;
@@ -201,13 +200,6 @@ package body Sem_Ch6 is
-- This procedure makes S, a new overloaded entity, into the first visible
-- entity with that name.
- function Has_Reliable_Extra_Formals (E : Entity_Id) return Boolean;
- -- E is the entity for a subprogram spec. Returns False for abstract
- -- predefined dispatching primitives of Root_Controlled since they
- -- cannot have extra formals (this is required to build the runtime);
- -- it also returns False for predefined stream dispatching operations
- -- not emitted by the frontend. Otherwise returns True.
-
function Is_Non_Overriding_Operation
(Prev_E : Entity_Id;
New_E : Entity_Id) return Boolean;
@@ -3357,8 +3349,7 @@ package body Sem_Ch6 is
or else
(Is_Class_Wide_Type (Designated_Type (Etype (Scop)))
and then
- Is_Limited_Record
- (Etype (Designated_Type (Etype (Scop))))))
+ Is_Limited_Record (Designated_Type (Etype (Scop)))))
and then Expander_Active
then
Decl := Build_Master_Declaration (Loc);
@@ -8477,253 +8468,6 @@ package body Sem_Ch6 is
(New_Id, Old_Id, Type_Conformant, True, Result, Err_Loc);
end Check_Type_Conformant;
- -----------------------------
- -- Check_Untagged_Equality --
- -----------------------------
-
- procedure Check_Untagged_Equality (Eq_Op : Entity_Id) is
- Eq_Decl : constant Node_Id := Unit_Declaration_Node (Eq_Op);
- Typ : constant Entity_Id := Etype (First_Formal (Eq_Op));
-
- procedure Freezing_Point_Warning (N : Node_Id; S : String);
- -- Output a warning about the freezing point N of Typ
-
- function Is_Actual_Of_Instantiation
- (E : Entity_Id;
- Inst : Node_Id) return Boolean;
- -- Return True if E is an actual parameter of instantiation Inst
-
- -----------------------------------
- -- Output_Freezing_Point_Warning --
- -----------------------------------
-
- procedure Freezing_Point_Warning (N : Node_Id; S : String) is
- begin
- Error_Msg_String (1 .. S'Length) := S;
- Error_Msg_Strlen := S'Length;
-
- if Ada_Version >= Ada_2012 then
- Error_Msg_NE ("type& is frozen by ~??", N, Typ);
- Error_Msg_N
- ("\an equality operator cannot be declared after this point??",
- N);
-
- else
- Error_Msg_NE ("type& is frozen by ~ (Ada 2012)?y?", N, Typ);
- Error_Msg_N
- ("\an equality operator cannot be declared after this point"
- & " (Ada 2012)?y?", N);
- end if;
- end Freezing_Point_Warning;
-
- --------------------------------
- -- Is_Actual_Of_Instantiation --
- --------------------------------
-
- function Is_Actual_Of_Instantiation
- (E : Entity_Id;
- Inst : Node_Id) return Boolean
- is
- Assoc : Node_Id;
-
- begin
- if Present (Generic_Associations (Inst)) then
- Assoc := First (Generic_Associations (Inst));
-
- while Present (Assoc) loop
- if Present (Explicit_Generic_Actual_Parameter (Assoc))
- and then
- Is_Entity_Name (Explicit_Generic_Actual_Parameter (Assoc))
- and then
- Entity (Explicit_Generic_Actual_Parameter (Assoc)) = E
- then
- return True;
- end if;
-
- Next (Assoc);
- end loop;
- end if;
-
- return False;
- end Is_Actual_Of_Instantiation;
-
- -- Local variable
-
- Decl : Node_Id;
-
- -- Start of processing for Check_Untagged_Equality
-
- begin
- -- This check applies only if we have a subprogram declaration or a
- -- subprogram body that is not a completion, for an untagged record
- -- type, and that is conformant with the predefined operator.
-
- if (Nkind (Eq_Decl) /= N_Subprogram_Declaration
- and then not (Nkind (Eq_Decl) = N_Subprogram_Body
- and then Acts_As_Spec (Eq_Decl)))
- or else not Is_Record_Type (Typ)
- or else Is_Tagged_Type (Typ)
- or else not Is_User_Defined_Equality (Eq_Op)
- then
- return;
- end if;
-
- -- In Ada 2012 case, we will output errors or warnings depending on
- -- the setting of debug flag -gnatd.E.
-
- if Ada_Version >= Ada_2012 then
- Error_Msg_Warn := Debug_Flag_Dot_EE;
-
- -- In earlier versions of Ada, nothing to do unless we are warning on
- -- Ada 2012 incompatibilities (Warn_On_Ada_2012_Incompatibility set).
-
- else
- if not Warn_On_Ada_2012_Compatibility then
- return;
- end if;
- end if;
-
- -- Cases where the type has already been frozen
-
- if Is_Frozen (Typ) then
-
- -- The check applies to a primitive operation, so check that type
- -- and equality operation are in the same scope.
-
- if Scope (Typ) /= Current_Scope then
- return;
-
- -- If the type is a generic actual (sub)type, the operation is not
- -- primitive either because the base type is declared elsewhere.
-
- elsif Is_Generic_Actual_Type (Typ) then
- return;
-
- -- Here we may have an error of declaration after freezing, but we
- -- must make sure not to flag the equality operator itself causing
- -- the freezing when it is a subprogram body.
-
- else
- Decl := Next (Declaration_Node (Typ));
-
- while Present (Decl) and then Decl /= Eq_Decl loop
-
- -- The declaration of an object of the type
-
- if Nkind (Decl) = N_Object_Declaration
- and then Etype (Defining_Identifier (Decl)) = Typ
- then
- Freezing_Point_Warning (Decl, "declaration");
- exit;
-
- -- The instantiation of a generic on the type
-
- elsif Nkind (Decl) in N_Generic_Instantiation
- and then Is_Actual_Of_Instantiation (Typ, Decl)
- then
- Freezing_Point_Warning (Decl, "instantiation");
- exit;
-
- -- A noninstance proper body, body stub or entry body
-
- elsif Nkind (Decl) in N_Proper_Body
- | N_Body_Stub
- | N_Entry_Body
- and then not Is_Generic_Instance (Defining_Entity (Decl))
- then
- Freezing_Point_Warning (Decl, "body");
- exit;
-
- -- If we have reached the freeze node and immediately after we
- -- have the body or generated code for the body, then it is the
- -- body that caused the freezing and this is legal.
-
- elsif Nkind (Decl) = N_Freeze_Entity
- and then Entity (Decl) = Typ
- and then (Next (Decl) = Eq_Decl
- or else
- Sloc (Next (Decl)) = Sloc (Eq_Decl))
- then
- return;
- end if;
-
- Next (Decl);
- end loop;
-
- -- Here we have a definite error of declaration after freezing
-
- if Ada_Version >= Ada_2012 then
- Error_Msg_NE
- ("equality operator must be declared before type & is "
- & "frozen (RM 4.5.2 (9.8)) (Ada 2012)<<", Eq_Op, Typ);
-
- -- In Ada 2012 mode with error turned to warning, output one
- -- more warning to warn that the equality operation may not
- -- compose. This is the consequence of ignoring the error.
-
- if Error_Msg_Warn then
- Error_Msg_N ("\equality operation may not compose??", Eq_Op);
- end if;
-
- else
- Error_Msg_NE
- ("equality operator must be declared before type& is "
- & "frozen (RM 4.5.2 (9.8)) (Ada 2012)?y?", Eq_Op, Typ);
- end if;
-
- -- If we have found no freezing point and the declaration of the
- -- operator could not be reached from that of the type and we are
- -- in a package body, this must be because the type is declared
- -- in the spec of the package. Add a message tailored to this.
-
- if No (Decl) and then In_Package_Body (Scope (Typ)) then
- if Ada_Version >= Ada_2012 then
- if Nkind (Eq_Decl) = N_Subprogram_Body then
- Error_Msg_N
- ("\put declaration in package spec<<", Eq_Op);
- else
- Error_Msg_N
- ("\move declaration to package spec<<", Eq_Op);
- end if;
-
- else
- if Nkind (Eq_Decl) = N_Subprogram_Body then
- Error_Msg_N
- ("\put declaration in package spec (Ada 2012)?y?",
- Eq_Op);
- else
- Error_Msg_N
- ("\move declaration to package spec (Ada 2012)?y?",
- Eq_Op);
- end if;
- end if;
- end if;
- end if;
-
- -- Now check for AI12-0352: the declaration of a user-defined primitive
- -- equality operation for a record type T is illegal if it occurs after
- -- a type has been derived from T.
-
- else
- Decl := Next (Declaration_Node (Typ));
-
- while Present (Decl) and then Decl /= Eq_Decl loop
- if Nkind (Decl) = N_Full_Type_Declaration
- and then Etype (Defining_Identifier (Decl)) = Typ
- then
- Error_Msg_N
- ("equality operator cannot appear after derivation", Eq_Op);
- Error_Msg_NE
- ("an equality operator for& cannot be declared after "
- & "this point??",
- Decl, Typ);
- end if;
-
- Next (Decl);
- end loop;
- end if;
- end Check_Untagged_Equality;
-
---------------------------
-- Can_Override_Operator --
---------------------------
@@ -9203,29 +8947,6 @@ package body Sem_Ch6 is
-- BIP_xxx denotes an extra formal for a build-in-place function. See
-- the full list in exp_ch6.BIP_Formal_Kind.
- function Has_BIP_Formals (E : Entity_Id) return Boolean;
- -- Determines if a given entity has build-in-place formals
-
- function Has_Extra_Formals (E : Entity_Id) return Boolean;
- -- Determines if E has its extra formals
-
- function Needs_Accessibility_Check_Extra
- (E : Entity_Id;
- Formal : Node_Id) return Boolean;
- -- Determines whether the given formal of E needs an extra formal for
- -- supporting accessibility checking. Returns True for both anonymous
- -- access formals and formals of named access types that are marked as
- -- controlling formals. The latter case can occur when the subprogram
- -- Expand_Dispatching_Call creates a subprogram-type and substitutes
- -- the types of access-to-class-wide actuals for the anonymous access-
- -- to-specific-type of controlling formals.
-
- function Parent_Subprogram (Subp_Id : Entity_Id) return Entity_Id;
- -- Subp_Id is a subprogram of a derived type; return its parent
- -- subprogram if Subp_Id overrides a parent primitive or derives
- -- from a parent primitive, and such parent primitive can have extra
- -- formals. Otherwise return Empty.
-
----------------------
-- Add_Extra_Formal --
----------------------
@@ -9236,7 +8957,10 @@ package body Sem_Ch6 is
Scope : Entity_Id;
Suffix : String) return Entity_Id
is
- EF : Entity_Id;
+ EF : constant Entity_Id :=
+ Make_Defining_Identifier (Sloc (Assoc_Entity),
+ Chars => New_External_Name (Chars (Assoc_Entity),
+ Suffix => Suffix));
begin
-- A little optimization. Never generate an extra formal for the
@@ -9247,10 +8971,6 @@ package body Sem_Ch6 is
return Empty;
end if;
- EF := Make_Defining_Identifier (Sloc (Assoc_Entity),
- Chars => New_External_Name (Chars (Assoc_Entity),
- Suffix => Suffix));
-
Mutate_Ekind (EF, E_In_Parameter);
Set_Actual_Subtype (EF, Typ);
Set_Etype (EF, Typ);
@@ -9272,280 +8992,49 @@ package body Sem_Ch6 is
return EF;
end Add_Extra_Formal;
- ---------------------
- -- Has_BIP_Formals --
- ---------------------
+ -- Local variables
- function Has_BIP_Formals (E : Entity_Id) return Boolean is
- Formal : Entity_Id := First_Formal_With_Extras (E);
-
- begin
- while Present (Formal) loop
- if Is_Build_In_Place_Entity (Formal) then
- return True;
- end if;
-
- Next_Formal_With_Extras (Formal);
- end loop;
-
- return False;
- end Has_BIP_Formals;
-
- -----------------------
- -- Has_Extra_Formals --
- -----------------------
-
- function Has_Extra_Formals (E : Entity_Id) return Boolean is
- begin
- return Present (Extra_Formals (E))
- or else
- (Ekind (E) = E_Function
- and then Present (Extra_Accessibility_Of_Result (E)));
- end Has_Extra_Formals;
-
- -------------------------------------
- -- Needs_Accessibility_Check_Extra --
- -------------------------------------
-
- function Needs_Accessibility_Check_Extra
- (E : Entity_Id;
- Formal : Node_Id) return Boolean is
-
- begin
- -- For dispatching operations this extra formal is not suppressed
- -- since all the derivations must have matching formals.
-
- -- For non-dispatching operations it is suppressed if we specifically
- -- suppress accessibility checks at the package level for either the
- -- subprogram, or the package in which it resides. However, we do
- -- not suppress it simply if the scope has accessibility checks
- -- suppressed, since this could cause trouble when clients are
- -- compiled with a different suppression setting. The explicit checks
- -- at the package level are safe from this point of view.
-
- if not Is_Dispatching_Operation (E)
- and then
- (Explicit_Suppress (E, Accessibility_Check)
- or else Explicit_Suppress (Scope (E), Accessibility_Check))
- then
- return False;
- end if;
-
- -- Base_Type is applied to handle cases where there is a null
- -- exclusion the formal may have an access subtype.
-
- return
- Ekind (Base_Type (Etype (Formal))) = E_Anonymous_Access_Type
- or else
- (Is_Controlling_Formal (Formal)
- and then Is_Access_Type (Base_Type (Etype (Formal))));
- end Needs_Accessibility_Check_Extra;
-
- -----------------------
- -- Parent_Subprogram --
- -----------------------
-
- function Parent_Subprogram (Subp_Id : Entity_Id) return Entity_Id is
- pragma Assert (not Is_Thunk (Subp_Id));
- Ovr_E : Entity_Id := Overridden_Operation (Subp_Id);
- Ovr_Alias : Entity_Id;
-
- begin
- if Present (Ovr_E) then
- Ovr_Alias := Ultimate_Alias (Ovr_E);
-
- -- There is no real overridden subprogram if there is a mutual
- -- reference between the E and its overridden operation. This
- -- weird scenery occurs in the following cases:
-
- -- 1) Controlling function wrappers internally built by
- -- Make_Controlling_Function_Wrappers.
-
- -- 2) Hidden overridden primitives of type extensions or private
- -- extensions (cf. Find_Hidden_Overridden_Primitive). These
- -- hidden primitives have suffix 'P'.
-
- -- 3) Overridding primitives of stub types (see the subprogram
- -- Add_RACW_Primitive_Declarations_And_Bodies).
-
- if Ovr_Alias = Subp_Id then
- pragma Assert
- ((Is_Wrapper (Subp_Id)
- and then Has_Controlling_Result (Subp_Id))
- or else Has_Suffix (Ovr_E, 'P')
- or else Is_RACW_Stub_Type
- (Find_Dispatching_Type (Subp_Id)));
-
- if Present (Overridden_Operation (Ovr_E)) then
- Ovr_E := Overridden_Operation (Ovr_E);
-
- -- Ovr_E is an internal entity built by Derive_Subprogram and
- -- we have no direct way to climb to the corresponding parent
- -- subprogram but this internal entity has the extra formals
- -- (if any) required for the purpose of checking the extra
- -- formals of Subp_Id.
-
- else
- pragma Assert (not Comes_From_Source (Ovr_E));
- end if;
-
- -- Use as our reference entity the ultimate renaming of the
- -- overriddden subprogram.
-
- elsif Present (Alias (Ovr_E)) then
- pragma Assert (No (Overridden_Operation (Ovr_Alias))
- or else Overridden_Operation (Ovr_Alias) /= Ovr_E);
-
- Ovr_E := Ovr_Alias;
- end if;
- end if;
-
- if Present (Ovr_E) and then Has_Reliable_Extra_Formals (Ovr_E) then
- return Ovr_E;
- else
- return Empty;
- end if;
- end Parent_Subprogram;
-
- -- Local variables
-
- Formal_Type : Entity_Id;
- May_Have_Alias : Boolean;
- Alias_Formal : Entity_Id := Empty;
- Alias_Subp : Entity_Id := Empty;
- Parent_Formal : Entity_Id := Empty;
- Parent_Subp : Entity_Id := Empty;
- Ref_E : Entity_Id;
+ Formal_Type : Entity_Id;
+ P_Formal : Entity_Id;
-- Start of processing for Create_Extra_Formals
begin
- pragma Assert (Is_Subprogram_Or_Entry (E)
- or else Ekind (E) in E_Subprogram_Type);
-
-- We never generate extra formals if expansion is not active because we
-- don't need them unless we are generating code.
if not Expander_Active then
return;
-
- -- Enumeration literals have no extra formal; this case occurs when
- -- a function renames it.
-
- elsif Ekind (E) = E_Function
- and then Ekind (Ultimate_Alias (E)) = E_Enumeration_Literal
- then
- return;
+ end if;
-- No need to generate extra formals in thunks whose target has no extra
-- formals, but we can have two of them chained (interface and stack).
- elsif Is_Thunk (E) and then No (Extra_Formals (Thunk_Target (E))) then
- return;
-
- -- If Extra_Formals were already created, don't do it again. This
- -- situation may arise for subprogram types created as part of
- -- dispatching calls (see Expand_Dispatching_Call).
-
- elsif Has_Extra_Formals (E) then
+ if Is_Thunk (E) and then No (Extra_Formals (Thunk_Target (E))) then
return;
+ end if;
- -- Extra formals of renamings of generic actual subprograms and
- -- renamings of instances of generic subprograms are shared. The
- -- check performed on the last formal is required to ensure that
- -- this is the renaming built by Analyze_Instance_And_Renamings
- -- (which shares all the formals); otherwise this would be wrong.
-
- elsif Ekind (E) in E_Function | E_Procedure
- and then Is_Generic_Instance (E)
- and then Present (Alias (E))
- and then Last_Formal (Ultimate_Alias (E)) = Last_Formal (E)
- then
- pragma Assert (Is_Generic_Instance (E)
- = Is_Generic_Instance (Ultimate_Alias (E)));
-
- Create_Extra_Formals (Ultimate_Alias (E));
-
- -- Share the extra formals
-
- Set_Extra_Formals (E, Extra_Formals (Ultimate_Alias (E)));
-
- if Ekind (E) = E_Function then
- Set_Extra_Accessibility_Of_Result (E,
- Extra_Accessibility_Of_Result (Ultimate_Alias (E)));
- end if;
+ -- If this is a derived subprogram then the subtypes of the parent
+ -- subprogram's formal parameters will be used to determine the need
+ -- for extra formals.
- pragma Assert (Extra_Formals_OK (E));
- return;
+ if Is_Overloadable (E) and then Present (Alias (E)) then
+ P_Formal := First_Formal (Alias (E));
+ else
+ P_Formal := Empty;
end if;
- -- Locate the last formal; required by Add_Extra_Formal.
-
Formal := First_Formal (E);
while Present (Formal) loop
Last_Extra := Formal;
Next_Formal (Formal);
end loop;
- -- We rely on three entities to ensure consistency of extra formals of
- -- entity E:
- --
- -- 1. A reference entity (Ref_E). For thunks it is their target
- -- primitive since this ensures that they have exactly the
- -- same extra formals; otherwise it is the identity.
- --
- -- 2. The parent subprogram; only for derived types and references
- -- either the overridden subprogram or the internal entity built
- -- by Derive_Subprogram that has the extra formals of the parent
- -- subprogram; otherwise it is Empty. This entity ensures matching
- -- extra formals in derived types.
- --
- -- 3. For renamings, their ultimate alias; this ensures taking the
- -- same decision in all the renamings (independently of the Ada
- -- mode on which they are compiled). For example:
- --
- -- pragma Ada_2012;
- -- function Id_A (I : access Integer) return access Integer;
- --
- -- pragma Ada_2005;
- -- function Id_B (I : access Integer) return access Integer
- -- renames Id_A;
-
- if Is_Thunk (E) then
- Ref_E := Thunk_Target (E);
- else
- Ref_E := E;
- end if;
-
- if Is_Subprogram (Ref_E) then
- Parent_Subp := Parent_Subprogram (Ref_E);
- end if;
-
- May_Have_Alias :=
- (Is_Subprogram (Ref_E) or else Ekind (Ref_E) = E_Subprogram_Type);
-
- -- If the parent subprogram is available then its ultimate alias of
- -- Ref_E is not needed since it will not be used to check its extra
- -- formals.
-
- if No (Parent_Subp)
- and then May_Have_Alias
- and then Present (Alias (Ref_E))
- and then Has_Reliable_Extra_Formals (Ultimate_Alias (Ref_E))
- then
- Alias_Subp := Ultimate_Alias (Ref_E);
- end if;
-
- -- Cannot add extra formals to subprograms and access types that have
- -- foreign convention nor to subprograms overriding primitives that
- -- have foreign convention since the foreign language does not know
- -- how to handle these extra formals; same for renamings of entities
- -- with foreign convention.
+ -- If Extra_Formals were already created, don't do it again. This
+ -- situation may arise for subprogram types created as part of
+ -- dispatching calls (see Expand_Dispatching_Call).
- if Has_Foreign_Convention (Ref_E)
- or else (Present (Alias_Subp)
- and then Has_Foreign_Convention (Alias_Subp))
- then
+ if Present (Last_Extra) and then Present (Extra_Formal (Last_Extra)) then
return;
end if;
@@ -9560,74 +9049,20 @@ package body Sem_Ch6 is
goto Test_For_Func_Result_Extras;
end if;
- -- Process the formals relying on the formals of our reference entities:
- -- Parent_Formal, Alias_Formal and Formal. Notice that we don't use the
- -- formal of Ref_E; we must use the formal of E which is the entity to
- -- which we are adding the extra formals.
-
- -- If this is a derived subprogram then the subtypes of the parent
- -- subprogram's formal parameters will be used to determine the need
- -- for extra formals.
-
- if Present (Parent_Subp) then
- Parent_Formal := First_Formal (Parent_Subp);
-
- -- For concurrent types, the controlling argument of a dispatching
- -- primitive implementing an interface primitive is implicit. For
- -- example:
- --
- -- type Iface is protected interface;
- -- function Prim
- -- (Obj : Iface;
- -- Value : Integer) return Natural is abstract;
- --
- -- protected type PO is new Iface with
- -- function Prim (Value : Integer) return Natural;
- -- end PO;
-
- if Convention (Ref_E) = Convention_Protected
- and then Is_Abstract_Subprogram (Parent_Subp)
- and then Is_Interface (Find_Dispatching_Type (Parent_Subp))
- then
- Parent_Formal := Next_Formal (Parent_Formal);
-
- -- This is the non-dispatching subprogram of a concurrent type
- -- that overrides the interface primitive; the expander will
- -- create the dispatching primitive (without Convention_Protected)
- -- with all the matching formals (see exp_ch9.Build_Wrapper_Specs)
-
- pragma Assert (not Is_Dispatching_Operation (Ref_E));
- end if;
-
- -- Ensure that the ultimate alias has all its extra formals
-
- elsif Present (Alias_Subp) then
- Create_Extra_Formals (Alias_Subp);
- Alias_Formal := First_Formal (Alias_Subp);
- end if;
-
Formal := First_Formal (E);
while Present (Formal) loop
- -- Here we establish our priority for deciding on the extra
- -- formals: 1) Parent primitive 2) Aliased primitive 3) Identity
-
- if Present (Parent_Formal) then
- Formal_Type := Etype (Parent_Formal);
-
- elsif Present (Alias_Formal) then
- Formal_Type := Etype (Alias_Formal);
-
- else
- Formal_Type := Etype (Formal);
- end if;
-
-- Create extra formal for supporting the attribute 'Constrained.
-- The case of a private type view without discriminants also
-- requires the extra formal if the underlying type has defaulted
-- discriminants.
if Ekind (Formal) /= E_In_Parameter then
+ if Present (P_Formal) then
+ Formal_Type := Etype (P_Formal);
+ else
+ Formal_Type := Etype (Formal);
+ end if;
-- Do not produce extra formals for Unchecked_Union parameters.
-- Jump directly to the end of the loop.
@@ -9672,22 +9107,36 @@ package body Sem_Ch6 is
end if;
end if;
- -- Extra formal for supporting accessibility checking
-
- if Needs_Accessibility_Check_Extra (Ref_E, Formal) then
- pragma Assert (No (Parent_Formal)
- or else Present (Extra_Accessibility (Parent_Formal)));
- pragma Assert (No (Alias_Formal)
- or else Present (Extra_Accessibility (Alias_Formal)));
+ -- Create extra formal for supporting accessibility checking. This
+ -- is done for both anonymous access formals and formals of named
+ -- access types that are marked as controlling formals. The latter
+ -- case can occur when Expand_Dispatching_Call creates a subprogram
+ -- type and substitutes the types of access-to-class-wide actuals
+ -- for the anonymous access-to-specific-type of controlling formals.
+ -- Base_Type is applied because in cases where there is a null
+ -- exclusion the formal may have an access subtype.
+ -- This is suppressed if we specifically suppress accessibility
+ -- checks at the package level for either the subprogram, or the
+ -- package in which it resides. However, we do not suppress it
+ -- simply if the scope has accessibility checks suppressed, since
+ -- this could cause trouble when clients are compiled with a
+ -- different suppression setting. The explicit checks at the
+ -- package level are safe from this point of view.
+
+ if (Ekind (Base_Type (Etype (Formal))) = E_Anonymous_Access_Type
+ or else (Is_Controlling_Formal (Formal)
+ and then Is_Access_Type (Base_Type (Etype (Formal)))))
+ and then not
+ (Explicit_Suppress (E, Accessibility_Check)
+ or else
+ Explicit_Suppress (Scope (E), Accessibility_Check))
+ and then
+ (No (P_Formal)
+ or else Present (Extra_Accessibility (P_Formal)))
+ then
Set_Extra_Accessibility
(Formal, Add_Extra_Formal (Formal, Standard_Natural, E, "L"));
-
- else
- pragma Assert (No (Parent_Formal)
- or else No (Extra_Accessibility (Parent_Formal)));
- pragma Assert (No (Alias_Formal)
- or else No (Extra_Accessibility (Alias_Formal)));
end if;
-- This label is required when skipping extra formal generation for
@@ -9695,12 +9144,8 @@ package body Sem_Ch6 is
<<Skip_Extra_Formal_Generation>>
- if Present (Parent_Formal) then
- Next_Formal (Parent_Formal);
- end if;
-
- if Present (Alias_Formal) then
- Next_Formal (Alias_Formal);
+ if Present (P_Formal) then
+ Next_Formal (P_Formal);
end if;
Next_Formal (Formal);
@@ -9708,47 +9153,20 @@ package body Sem_Ch6 is
<<Test_For_Func_Result_Extras>>
- -- Assume the worse scenery (Ada 2022) to evaluate this extra formal;
- -- required to ensure matching of extra formals between subprograms
- -- and access to subprogram types in projects with mixed Ada dialects.
-
- declare
- Save_Ada_Version : constant Ada_Version_Type := Ada_Version;
-
- begin
- Ada_Version := Ada_2022;
+ -- Ada 2012 (AI05-234): "the accessibility level of the result of a
+ -- function call is ... determined by the point of call ...".
- if Needs_Result_Accessibility_Level (Ref_E) then
- pragma Assert (No (Parent_Subp)
- or else Needs_Result_Accessibility_Level (Parent_Subp));
- pragma Assert (No (Alias_Subp)
- or else Needs_Result_Accessibility_Level (Alias_Subp));
-
- Set_Extra_Accessibility_Of_Result (E,
- Add_Extra_Formal (E, Standard_Natural, E, "L"));
-
- else
- pragma Assert (No (Parent_Subp)
- or else not Needs_Result_Accessibility_Level (Parent_Subp));
- pragma Assert (No (Alias_Subp)
- or else not Needs_Result_Accessibility_Level (Alias_Subp));
- end if;
-
- Ada_Version := Save_Ada_Version;
- end;
+ if Needs_Result_Accessibility_Level (E) then
+ Set_Extra_Accessibility_Of_Result
+ (E, Add_Extra_Formal (E, Standard_Natural, E, "L"));
+ end if;
-- Ada 2005 (AI-318-02): In the case of build-in-place functions, add
-- appropriate extra formals. See type Exp_Ch6.BIP_Formal_Kind.
- if (Present (Parent_Subp) and then Has_BIP_Formals (Parent_Subp))
- or else
- (Present (Alias_Subp) and then Has_BIP_Formals (Alias_Subp))
- or else
- (Is_Build_In_Place_Function (Ref_E)
- and then Has_Reliable_Extra_Formals (Ref_E))
- then
+ if Is_Build_In_Place_Function (E) then
declare
- Result_Subt : constant Entity_Id := Etype (Ref_E);
+ Result_Subt : constant Entity_Id := Etype (E);
Formal_Typ : Entity_Id;
Subp_Decl : Node_Id;
Discard : Entity_Id;
@@ -9766,14 +9184,7 @@ package body Sem_Ch6 is
-- dispatching context and such calls must be handled like calls
-- to a class-wide function.
- if Needs_BIP_Alloc_Form (Ref_E) then
- pragma Assert (No (Parent_Subp)
- or else Has_BIP_Extra_Formal (Parent_Subp, BIP_Alloc_Form,
- Must_Be_Frozen => False));
- pragma Assert (No (Alias_Subp)
- or else Has_BIP_Extra_Formal (Alias_Subp, BIP_Alloc_Form,
- Must_Be_Frozen => False));
-
+ if Needs_BIP_Alloc_Form (E) then
Discard :=
Add_Extra_Formal
(E, Standard_Natural,
@@ -9789,66 +9200,23 @@ package body Sem_Ch6 is
(E, RTE (RE_Root_Storage_Pool_Ptr),
E, BIP_Formal_Suffix (BIP_Storage_Pool));
end if;
-
- else
- pragma Assert (No (Parent_Subp)
- or else not
- Has_BIP_Extra_Formal (Parent_Subp, BIP_Alloc_Form,
- Must_Be_Frozen => False));
- pragma Assert (No (Alias_Subp)
- or else not
- Has_BIP_Extra_Formal (Alias_Subp, BIP_Alloc_Form,
- Must_Be_Frozen => False));
end if;
-- In the case of functions whose result type needs finalization,
-- add an extra formal which represents the finalization master.
- if Needs_BIP_Finalization_Master (Ref_E) then
- pragma Assert (No (Parent_Subp)
- or else Has_BIP_Extra_Formal (Parent_Subp,
- Kind => BIP_Finalization_Master,
- Must_Be_Frozen => False));
- pragma Assert (No (Alias_Subp)
- or else Has_BIP_Extra_Formal (Alias_Subp,
- Kind => BIP_Finalization_Master,
- Must_Be_Frozen => False));
-
+ if Needs_BIP_Finalization_Master (E) then
Discard :=
Add_Extra_Formal
(E, RTE (RE_Finalization_Master_Ptr),
E, BIP_Formal_Suffix (BIP_Finalization_Master));
-
- else
- pragma Assert (No (Parent_Subp)
- or else not
- Has_BIP_Extra_Formal (Parent_Subp,
- Kind => BIP_Finalization_Master,
- Must_Be_Frozen => False));
- pragma Assert (No (Alias_Subp)
- or else not
- Has_BIP_Extra_Formal (Alias_Subp,
- Kind => BIP_Finalization_Master,
- Must_Be_Frozen => False));
end if;
-- When the result type contains tasks, add two extra formals: the
-- master of the tasks to be created, and the caller's activation
-- chain.
- if Needs_BIP_Task_Actuals (Ref_E) then
- pragma Assert (No (Parent_Subp)
- or else Has_BIP_Extra_Formal (Parent_Subp, BIP_Task_Master,
- Must_Be_Frozen => False));
- pragma Assert (No (Alias_Subp)
- or else Has_BIP_Extra_Formal (Alias_Subp, BIP_Task_Master,
- Must_Be_Frozen => False)
- or else
- (Is_Abstract_Subprogram (Ref_E)
- and then Is_Predefined_Dispatching_Operation (Ref_E)
- and then Is_Interface
- (Find_Dispatching_Type (Alias_Subp))));
-
+ if Needs_BIP_Task_Actuals (E) then
Discard :=
Add_Extra_Formal
(E, Standard_Integer,
@@ -9860,16 +9228,6 @@ package body Sem_Ch6 is
Add_Extra_Formal
(E, RTE (RE_Activation_Chain_Access),
E, BIP_Formal_Suffix (BIP_Activation_Chain));
-
- else
- pragma Assert (No (Parent_Subp)
- or else not
- Has_BIP_Extra_Formal (Parent_Subp, BIP_Task_Master,
- Must_Be_Frozen => False));
- pragma Assert (No (Alias_Subp)
- or else not
- Has_BIP_Extra_Formal (Alias_Subp, BIP_Task_Master,
- Must_Be_Frozen => False));
end if;
-- All build-in-place functions get an extra formal that will be
@@ -9935,14 +9293,6 @@ package body Sem_Ch6 is
if Is_Generic_Instance (E) and then Present (Alias (E)) then
Set_Extra_Formals (Alias (E), Extra_Formals (E));
end if;
-
- pragma Assert (No (Alias_Subp)
- or else Extra_Formals_Match_OK (E, Alias_Subp));
-
- pragma Assert (No (Parent_Subp)
- or else Extra_Formals_Match_OK (E, Parent_Subp));
-
- pragma Assert (Extra_Formals_OK (E));
end Create_Extra_Formals;
-----------------------------
@@ -10173,162 +9523,252 @@ package body Sem_Ch6 is
end if;
end Enter_Overloaded_Entity;
- ----------------------------
- -- Extra_Formals_Match_OK --
- ----------------------------
+ -----------------------------
+ -- Check_Untagged_Equality --
+ -----------------------------
- function Extra_Formals_Match_OK
- (E : Entity_Id;
- Ref_E : Entity_Id) return Boolean is
- begin
- pragma Assert (Is_Subprogram (E));
-
- -- Cases were no check can be performed:
- -- 1) When expansion is not active (since we never generate extra
- -- formals if expansion is not active because we don't need them
- -- unless we are generating code).
- -- 2) On abstract predefined dispatching operations of Root_Controlled
- -- and predefined stream operations not emitted by the frontend.
- -- 3) On renamings of abstract predefined dispatching operations of
- -- interface types (since limitedness is not inherited in such
- -- case (AI-419)).
- -- 4) The controlling formal of the non-dispatching subprogram of
- -- a concurrent type that overrides an interface primitive is
- -- implicit and hence we cannot check here if all its extra
- -- formals match; the expander will create the dispatching
- -- primitive (without Convention_Protected) with the matching
- -- formals (see exp_ch9.Build_Wrapper_Specs) which will be
- -- checked later.
-
- if Debug_Flag_Underscore_XX
- or else not Expander_Active
- or else
- (Is_Predefined_Dispatching_Operation (E)
- and then (not Has_Reliable_Extra_Formals (E)
- or else not Has_Reliable_Extra_Formals (Ref_E)))
- or else
- (Is_Predefined_Dispatching_Operation (E)
- and then Is_Abstract_Subprogram (E)
- and then Is_Interface (Find_Dispatching_Type (Ref_E)))
- then
- return True;
+ procedure Check_Untagged_Equality (Eq_Op : Entity_Id) is
+ Eq_Decl : constant Node_Id := Unit_Declaration_Node (Eq_Op);
+ Typ : constant Entity_Id := Etype (First_Formal (Eq_Op));
- elsif Convention (E) = Convention_Protected
- and then not Is_Dispatching_Operation (E)
- and then Is_Abstract_Subprogram (Ref_E)
- and then Is_Interface (Find_Dispatching_Type (Ref_E))
- then
- return True;
- end if;
+ procedure Freezing_Point_Warning (N : Node_Id; S : String);
+ -- Output a warning about the freezing point N of Typ
- -- Perform the checks
+ function Is_Actual_Of_Instantiation
+ (E : Entity_Id;
+ Inst : Node_Id) return Boolean;
+ -- Return True if E is an actual parameter of instantiation Inst
- if No (Extra_Formals (E)) then
- return No (Extra_Formals (Ref_E));
- end if;
+ -----------------------------------
+ -- Output_Freezing_Point_Warning --
+ -----------------------------------
- if Ekind (E) in E_Function | E_Subprogram_Type
- and then Present (Extra_Accessibility_Of_Result (E))
- /= Present (Extra_Accessibility_Of_Result (Ref_E))
- then
- return False;
- end if;
+ procedure Freezing_Point_Warning (N : Node_Id; S : String) is
+ begin
+ Error_Msg_String (1 .. S'Length) := S;
+ Error_Msg_Strlen := S'Length;
- declare
- Formal_1 : Entity_Id := Extra_Formals (E);
- Formal_2 : Entity_Id := Extra_Formals (Ref_E);
+ if Ada_Version >= Ada_2012 then
+ Error_Msg_NE ("type& is frozen by ~??", N, Typ);
+ Error_Msg_N
+ ("\an equality operator cannot be declared after this point??",
+ N);
+
+ else
+ Error_Msg_NE ("type& is frozen by ~ (Ada 2012)?y?", N, Typ);
+ Error_Msg_N
+ ("\an equality operator cannot be declared after this point"
+ & " (Ada 2012)?y?", N);
+ end if;
+ end Freezing_Point_Warning;
+
+ --------------------------------
+ -- Is_Actual_Of_Instantiation --
+ --------------------------------
+
+ function Is_Actual_Of_Instantiation
+ (E : Entity_Id;
+ Inst : Node_Id) return Boolean
+ is
+ Assoc : Node_Id;
begin
- while Present (Formal_1) and then Present (Formal_2) loop
- if Has_Suffix (Formal_1, 'L') then
- if not Has_Suffix (Formal_2, 'L') then
- return False;
- end if;
+ if Present (Generic_Associations (Inst)) then
+ Assoc := First (Generic_Associations (Inst));
- elsif Has_Suffix (Formal_1, 'O') then
- if not Has_Suffix (Formal_2, 'O') then
- return False;
+ while Present (Assoc) loop
+ if Present (Explicit_Generic_Actual_Parameter (Assoc))
+ and then
+ Is_Entity_Name (Explicit_Generic_Actual_Parameter (Assoc))
+ and then
+ Entity (Explicit_Generic_Actual_Parameter (Assoc)) = E
+ then
+ return True;
end if;
- elsif BIP_Suffix_Kind (Formal_1) /= BIP_Suffix_Kind (Formal_2) then
- return False;
- end if;
+ Next (Assoc);
+ end loop;
+ end if;
- Formal_1 := Next_Formal_With_Extras (Formal_1);
- Formal_2 := Next_Formal_With_Extras (Formal_2);
- end loop;
+ return False;
+ end Is_Actual_Of_Instantiation;
- return No (Formal_1) and then No (Formal_2);
- end;
- end Extra_Formals_Match_OK;
+ -- Local variable
- ----------------------
- -- Extra_Formals_OK --
- ----------------------
+ Decl : Node_Id;
- function Extra_Formals_OK (E : Entity_Id) return Boolean is
- Last_Formal : Entity_Id := Empty;
- Formal : Entity_Id;
- Has_Extra_Formals : Boolean := False;
+ -- Start of processing for Check_Untagged_Equality
begin
- -- No check required if explicitly disabled
+ -- This check applies only if we have a subprogram declaration or a
+ -- subprogram body that is not a completion, for an untagged record
+ -- type, and that is conformant with the predefined operator.
- if Debug_Flag_Underscore_XX then
- return True;
+ if (Nkind (Eq_Decl) /= N_Subprogram_Declaration
+ and then not (Nkind (Eq_Decl) = N_Subprogram_Body
+ and then Acts_As_Spec (Eq_Decl)))
+ or else not Is_Record_Type (Typ)
+ or else Is_Tagged_Type (Typ)
+ or else not Is_User_Defined_Equality (Eq_Op)
+ then
+ return;
+ end if;
+
+ -- In Ada 2012 case, we will output errors or warnings depending on
+ -- the setting of debug flag -gnatd.E.
- -- No check required if expansion is disabled because extra
- -- formals are only generated when we are generating code.
- -- See Create_Extra_Formals.
+ if Ada_Version >= Ada_2012 then
+ Error_Msg_Warn := Debug_Flag_Dot_EE;
- elsif not Expander_Active then
- return True;
+ -- In earlier versions of Ada, nothing to do unless we are warning on
+ -- Ada 2012 incompatibilities (Warn_On_Ada_2012_Incompatibility set).
+
+ else
+ if not Warn_On_Ada_2012_Compatibility then
+ return;
+ end if;
end if;
- -- Check attribute Extra_Formal: If available, it must be set only
- -- on the last formal of E.
+ -- Cases where the type has already been frozen
- Formal := First_Formal (E);
- while Present (Formal) loop
- if Present (Extra_Formal (Formal)) then
- if Has_Extra_Formals then
- return False;
- end if;
+ if Is_Frozen (Typ) then
- Has_Extra_Formals := True;
- end if;
+ -- The check applies to a primitive operation, so check that type
+ -- and equality operation are in the same scope.
- Last_Formal := Formal;
- Next_Formal (Formal);
- end loop;
+ if Scope (Typ) /= Current_Scope then
+ return;
+
+ -- If the type is a generic actual (sub)type, the operation is not
+ -- primitive either because the base type is declared elsewhere.
- -- Check attribute Extra_Accessibility_Of_Result
+ elsif Is_Generic_Actual_Type (Typ) then
+ return;
- if Ekind (E) in E_Function | E_Subprogram_Type
- and then Needs_Result_Accessibility_Level (E)
- and then No (Extra_Accessibility_Of_Result (E))
- then
- return False;
- end if;
+ -- Here we may have an error of declaration after freezing, but we
+ -- must make sure not to flag the equality operator itself causing
+ -- the freezing when it is a subprogram body.
- -- Check attribute Extra_Formals: If E has extra formals, then this
- -- attribute must point to the first extra formal of E.
+ else
+ Decl := Next (Declaration_Node (Typ));
- if Has_Extra_Formals then
- return Present (Extra_Formals (E))
- and then Present (Extra_Formal (Last_Formal))
- and then Extra_Formal (Last_Formal) = Extra_Formals (E);
+ while Present (Decl) and then Decl /= Eq_Decl loop
+
+ -- The declaration of an object of the type
- -- When E has no formals, the first extra formal is available through
- -- the Extra_Formals attribute.
+ if Nkind (Decl) = N_Object_Declaration
+ and then Etype (Defining_Identifier (Decl)) = Typ
+ then
+ Freezing_Point_Warning (Decl, "declaration");
+ exit;
- elsif Present (Extra_Formals (E)) then
- return No (First_Formal (E));
+ -- The instantiation of a generic on the type
+
+ elsif Nkind (Decl) in N_Generic_Instantiation
+ and then Is_Actual_Of_Instantiation (Typ, Decl)
+ then
+ Freezing_Point_Warning (Decl, "instantiation");
+ exit;
+
+ -- A noninstance proper body, body stub or entry body
+
+ elsif Nkind (Decl) in N_Proper_Body
+ | N_Body_Stub
+ | N_Entry_Body
+ and then not Is_Generic_Instance (Defining_Entity (Decl))
+ then
+ Freezing_Point_Warning (Decl, "body");
+ exit;
+
+ -- If we have reached the freeze node and immediately after we
+ -- have the body or generated code for the body, then it is the
+ -- body that caused the freezing and this is legal.
+
+ elsif Nkind (Decl) = N_Freeze_Entity
+ and then Entity (Decl) = Typ
+ and then (Next (Decl) = Eq_Decl
+ or else
+ Sloc (Next (Decl)) = Sloc (Eq_Decl))
+ then
+ return;
+ end if;
+
+ Next (Decl);
+ end loop;
+
+ -- Here we have a definite error of declaration after freezing
+
+ if Ada_Version >= Ada_2012 then
+ Error_Msg_NE
+ ("equality operator must be declared before type & is "
+ & "frozen (RM 4.5.2 (9.8)) (Ada 2012)<<", Eq_Op, Typ);
+
+ -- In Ada 2012 mode with error turned to warning, output one
+ -- more warning to warn that the equality operation may not
+ -- compose. This is the consequence of ignoring the error.
+
+ if Error_Msg_Warn then
+ Error_Msg_N ("\equality operation may not compose??", Eq_Op);
+ end if;
+
+ else
+ Error_Msg_NE
+ ("equality operator must be declared before type& is "
+ & "frozen (RM 4.5.2 (9.8)) (Ada 2012)?y?", Eq_Op, Typ);
+ end if;
+
+ -- If we have found no freezing point and the declaration of the
+ -- operator could not be reached from that of the type and we are
+ -- in a package body, this must be because the type is declared
+ -- in the spec of the package. Add a message tailored to this.
+
+ if No (Decl) and then In_Package_Body (Scope (Typ)) then
+ if Ada_Version >= Ada_2012 then
+ if Nkind (Eq_Decl) = N_Subprogram_Body then
+ Error_Msg_N
+ ("\put declaration in package spec<<", Eq_Op);
+ else
+ Error_Msg_N
+ ("\move declaration to package spec<<", Eq_Op);
+ end if;
+
+ else
+ if Nkind (Eq_Decl) = N_Subprogram_Body then
+ Error_Msg_N
+ ("\put declaration in package spec (Ada 2012)?y?",
+ Eq_Op);
+ else
+ Error_Msg_N
+ ("\move declaration to package spec (Ada 2012)?y?",
+ Eq_Op);
+ end if;
+ end if;
+ end if;
+ end if;
+
+ -- Now check for AI12-0352: the declaration of a user-defined primitive
+ -- equality operation for a record type T is illegal if it occurs after
+ -- a type has been derived from T.
else
- return True;
+ Decl := Next (Declaration_Node (Typ));
+
+ while Present (Decl) and then Decl /= Eq_Decl loop
+ if Nkind (Decl) = N_Full_Type_Declaration
+ and then Etype (Defining_Identifier (Decl)) = Typ
+ then
+ Error_Msg_N
+ ("equality operator cannot appear after derivation", Eq_Op);
+ Error_Msg_NE
+ ("an equality operator for& cannot be declared after "
+ & "this point??",
+ Decl, Typ);
+ end if;
+
+ Next (Decl);
+ end loop;
end if;
- end Extra_Formals_OK;
+ end Check_Untagged_Equality;
-----------------------------
-- Find_Corresponding_Spec --
@@ -11213,70 +10653,6 @@ package body Sem_Ch6 is
end if;
end Fully_Conformant_Discrete_Subtypes;
- --------------------------------
- -- Has_Reliable_Extra_Formals --
- --------------------------------
-
- function Has_Reliable_Extra_Formals (E : Entity_Id) return Boolean is
- Alias_E : Entity_Id;
-
- begin
- -- Extra formals are not added if expansion is not active (and hence if
- -- available they are not reliable for extra formals check).
-
- if not Expander_Active then
- return False;
-
- -- Currently the unique cases where extra formals are not reliable
- -- are associated with predefined dispatching operations; otherwise
- -- they are properly added when required.
-
- elsif not Is_Predefined_Dispatching_Operation (E) then
- return True;
- end if;
-
- Alias_E := Ultimate_Alias (E);
-
- -- Abstract predefined primitives of Root_Controlled don't have
- -- extra formals; this is required to build the runtime.
-
- if Ekind (Alias_E) = E_Function
- and then Is_Abstract_Subprogram (Alias_E)
- and then Is_RTE (Underlying_Type (Etype (Alias_E)),
- RE_Root_Controlled)
- then
- return False;
-
- -- Predefined stream dispatching operations that are not emitted by
- -- the frontend; they have a renaming of the corresponding primive
- -- of their parent type and hence they don't have extra formals.
-
- else
- declare
- Typ : constant Entity_Id :=
- Underlying_Type (Find_Dispatching_Type (Alias_E));
-
- begin
- if (Get_TSS_Name (E) = TSS_Stream_Input
- and then not Stream_Operation_OK (Typ, TSS_Stream_Input))
- or else
- (Get_TSS_Name (E) = TSS_Stream_Output
- and then not Stream_Operation_OK (Typ, TSS_Stream_Output))
- or else
- (Get_TSS_Name (E) = TSS_Stream_Read
- and then not Stream_Operation_OK (Typ, TSS_Stream_Read))
- or else
- (Get_TSS_Name (E) = TSS_Stream_Write
- and then not Stream_Operation_OK (Typ, TSS_Stream_Write))
- then
- return False;
- end if;
- end;
- end if;
-
- return True;
- end Has_Reliable_Extra_Formals;
-
--------------------
-- Install_Entity --
--------------------
diff --git a/gcc/ada/sem_ch6.ads b/gcc/ada/sem_ch6.ads
index 6a499bd016c..da56ce6ab72 100644
--- a/gcc/ada/sem_ch6.ads
+++ b/gcc/ada/sem_ch6.ads
@@ -174,22 +174,6 @@ package Sem_Ch6 is
-- the end of Subp's parameter list (with each subsequent extra formal
-- being attached to the preceding extra formal).
- function Extra_Formals_Match_OK
- (E : Entity_Id;
- Ref_E : Entity_Id) return Boolean;
- -- Return True if the extra formals of the given entities match. E is a
- -- subprogram, and Ref_E is the reference entity that will be used to check
- -- the extra formals of E: a subprogram type or another subprogram. For
- -- example, if E is a dispatching primitive of a tagged type then Ref_E
- -- may be the overridden primitive of its parent type or its ultimate
- -- renamed entity; however, if E is a subprogram to which 'Access is
- -- applied then Ref_E is its corresponding subprogram type. Used in
- -- assertions.
-
- function Extra_Formals_OK (E : Entity_Id) return Boolean;
- -- Return True if the decoration of the attributes associated with extra
- -- formals are properly set. Used in assertions.
-
function Find_Corresponding_Spec
(N : Node_Id;
Post_Error : Boolean := True) return Entity_Id;
diff --git a/gcc/ada/sem_eval.adb b/gcc/ada/sem_eval.adb
index 03322324186..2ba46088940 100644
--- a/gcc/ada/sem_eval.adb
+++ b/gcc/ada/sem_eval.adb
@@ -1823,7 +1823,6 @@ package body Sem_Eval is
return False;
elsif Op = Error
- or else Nkind (Op) not in N_Has_Etype
or else Etype (Op) = Any_Type
or else Raises_Constraint_Error (Op)
then
diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
index 5434a061f88..4a12f080bca 100644
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -23226,12 +23226,9 @@ package body Sem_Util is
return Present (Extra_Accessibility_Of_Result (Alias (Func_Id)));
- -- Remaining cases require Ada 2012 mode, unless they are dispatching
- -- operations, since they may be overridden by Ada_2012 primitives.
+ -- Remaining cases require Ada 2012 mode
- elsif Ada_Version < Ada_2012
- and then not Is_Dispatching_Operation (Func_Id)
- then
+ elsif Ada_Version < Ada_2012 then
return False;
-- Handle the situation where a result is an anonymous access type
^ permalink raw reply [flat|nested] only message in thread
only message in thread, other threads:[~2022-09-12 8:19 UTC | newest]
Thread overview: (only message) (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2022-09-12 8:19 [gcc r13-2586] [Ada] Revert "Enforce matching of extra formals" Marc Poulhiès
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).