aboutsummaryrefslogtreecommitdiff
path: root/gcc/ada/sem_ch6.adb
diff options
context:
space:
mode:
Diffstat (limited to 'gcc/ada/sem_ch6.adb')
-rw-r--r--gcc/ada/sem_ch6.adb1180
1 files changed, 278 insertions, 902 deletions
diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb
index 6f71adb..c92e691 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 --
- ---------------------
-
- 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
+ if Is_Thunk (E) and then No (Extra_Formals (Thunk_Target (E))) then
return;
+ end if;
- -- 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
- return;
-
- -- 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.
+ -- Ada 2012 (AI05-234): "the accessibility level of the result of a
+ -- function call is ... determined by the point of call ...".
- declare
- Save_Ada_Version : constant Ada_Version_Type := Ada_Version;
-
- begin
- Ada_Version := Ada_2022;
-
- 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;
- -- No check required if expansion is disabled because extra
- -- formals are only generated when we are generating code.
- -- See Create_Extra_Formals.
+ -- In Ada 2012 case, we will output errors or warnings depending on
+ -- the setting of debug flag -gnatd.E.
- elsif not Expander_Active then
- return True;
+ 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;
- -- 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;
- -- Check attribute Extra_Accessibility_Of_Result
+ -- If the type is a generic actual (sub)type, the operation is not
+ -- primitive either because the base type is declared elsewhere.
- 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;
+ 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));
- -- Check attribute Extra_Formals: If E has extra formals, then this
- -- attribute must point to the first extra formal of E.
+ 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;
- 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);
+ -- The instantiation of a generic on the type
- -- When E has no formals, the first extra formal is available through
- -- the Extra_Formals attribute.
+ elsif Nkind (Decl) in N_Generic_Instantiation
+ and then Is_Actual_Of_Instantiation (Typ, Decl)
+ then
+ Freezing_Point_Warning (Decl, "instantiation");
+ exit;
- elsif Present (Extra_Formals (E)) then
- return No (First_Formal (E));
+ -- 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 --
--------------------