From: Javier Miranda <mira...@adacore.com>
Add support to create the extra formals when the underlying type
of some formal type or return type of a subprogram, subprogram type
or entry is not available when the entity is frozen. For example,
when a function that returns a private type is frozen before the
full-view of its private type is analyzed.
gcc/ada/ChangeLog:
* einfo.ads (Extra_Formals): Complete documentation.
(Has_First_Controlling_Parameter_Aspect): Place it in alphabetical
order.
(Has_Frozen_Extra_Formals): New attribute.
* gen_il-fields.ads (Has_Frozen_Extra_Formals): New entity field.
* gen_il-gen-gen_entities.adb (Has_Frozen_Extra_Formals): Adding new
entity flag to subprograms, subprogram types, and and entries.
* gen_il-internals.adb (Image): Adding Has_Frozen_Extra_Formals.
* exp_ch3.adb (Build_Array_Init_Proc): Freeze its extra formals.
(Build_Init_Procedure): Freeze its extra formals.
(Expand_Freeze_Record_Type): For tagged types with foreign convention
create the extra formals of primitives with convention Ada.
* exp_ch6.ads (Create_Extra_Actuals): New subprogram.
* exp_ch6.adb (Check_BIP_Actuals): Adding assertions.
(Create_Extra_Actuals): New subprogram that factorizes code from
Expand_Call_Helper.
(Expand_Call_Helper): Adding support to defer the addition of extra
actuals. Move the code that adds the extra actuals to a new subprogram.
(Is_Unchecked_Union_Equality): Renamed as Is_Unchecked_Union_Predefined_
Equality_Call.
* exp_ch7.adb (Create_Finalizer): Freeze its extra formals.
(Wrap_Transient_Expression): Link the temporary with its relocated
expression to facilitate locating the expression in the expanded code.
* exp_ch9.ads (Expand_N_Entry_Declaration): Adding one formal.
* exp_ch9.adb (Expand_N_Entry_Declaration): Defer the expansion of
the entry if the extra formals are not available; analyze the built
declarations for the record type that holds all the parameters if
the expansion of the entry declaration was deferred.
* exp_disp.adb (Expand_Dispatching_Call): Handle deferred extra formals.
(Set_CPP_Constructors): Freeze its extra formals.
* freeze.adb (Freeze_Entity): Create the extra actuals of acccess to
subprograms whose designated type is a subprogram type.
(Freeze_Subprogram): Adjust assertion to support deferred extra formals,
and freeze extra formals of non-dispatching subprograms with foreign
convention. Added assertion to check matching of formals in thunks.
* sem_aux.adb (Get_Called_Entity): Adding documentation.
* sem_ch3.adb (Analyze_Full_Type_Declaration): Create the extra formals
of deferred subprograms, subprogram types and entries; create also the
extra actuals of deferred calls.
* sem_ch6.ads (Freeze_Extra_Formals): New subprogram.
(Deferred_Extra_Formals_Support): New package.
* sem_ch6.adb (Analyze_Subprogram_Body_Helper): Create the extra formals
of subprograms without separate spec.
(Add_Extra_Formal): Add documentation.
(Has_Extra_Formals): Removed.
(Parent_Subprogram): Adding documentation.
(Create_Extra_Formals): Defer adding extra formals if the
underlying_type
of some formal type or return type is not available.
(Extra_Formals_Match_OK): Add missing check on the extra formals of
unchecked unions.
(Freeze_Extra_Formals): New subprogram.
(Deferred_Extra_Formals_Support): New package.
* sem_ch9.adb (Analyze_Entry_Declaration): Freeze its extra formals.
* sem_ch13.adb (New_Put_Image_Subprogram): ditto.
* sem_util.ads (Is_Unchecked_Union_Equality): New subprogram.
* sem_util.adb (Is_Unchecked_Union_Equality): ditto.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/einfo.ads | 33 +-
gcc/ada/exp_ch3.adb | 23 +-
gcc/ada/exp_ch6.adb | 1006 +++++++++++++++------------
gcc/ada/exp_ch6.ads | 4 +
gcc/ada/exp_ch7.adb | 12 +-
gcc/ada/exp_ch9.adb | 44 +-
gcc/ada/exp_ch9.ads | 9 +-
gcc/ada/exp_disp.adb | 72 +-
gcc/ada/freeze.adb | 19 +-
gcc/ada/gen_il-fields.ads | 1 +
gcc/ada/gen_il-gen-gen_entities.adb | 4 +
gcc/ada/gen_il-internals.adb | 2 +
gcc/ada/sem_aux.adb | 12 +
gcc/ada/sem_ch13.adb | 2 +
gcc/ada/sem_ch3.adb | 12 +
gcc/ada/sem_ch6.adb | 747 ++++++++++++++++++--
gcc/ada/sem_ch6.ads | 160 +++++
gcc/ada/sem_ch9.adb | 6 +
gcc/ada/sem_util.adb | 12 +
gcc/ada/sem_util.ads | 6 +-
20 files changed, 1622 insertions(+), 564 deletions(-)
diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads
index c4aa98ee4f3..11e3dd0254e 100644
--- a/gcc/ada/einfo.ads
+++ b/gcc/ada/einfo.ads
@@ -1279,9 +1279,10 @@ package Einfo is
-- that represents an activation record pointer is an extra formal.
-- Extra_Formals
--- Applies to subprograms, subprogram types, entries, and entry
--- families. Returns first extra formal of the subprogram or entry.
--- Returns Empty if there are no extra formals.
+-- Applies to subprograms, subprogram types, entries, and entry families.
+-- Returns the first extra formal of the subprogram or entry. An entity
+-- has no extra formals when this attribute is Empty, and its attribute
+-- Extra_Formals_Known is True.
-- Finalization_Collection [root type only]
-- Defined in access-to-controlled or access-to-class-wide types. The
@@ -1640,11 +1641,6 @@ package Einfo is
-- that this does not imply a representation with holes, since the rep
-- clause may merely confirm the default 0..N representation.
--- Has_First_Controlling_Parameter_Aspect
--- Defined in tagged types, concurrent types and concurrent record types.
--- Set to indicate that the type has a First_Controlling_Parameter of
--- True (whether by an aspect_specification, a pragma, or inheritance).
-
-- Has_Exit
-- Defined in loop entities. Set if the loop contains an exit statement.
@@ -1654,6 +1650,12 @@ package Einfo is
-- flag prevents double expansion of a contract when a construct is
-- rewritten into something else and subsequently reanalyzed/expanded.
+-- Has_First_Controlling_Parameter_Aspect
+-- Defined in tagged types, concurrent types, and concurrent record
+-- types. Set to indicate that the type has a First_Controlling_Parameter
+-- of True (whether by an aspect_specification, a pragma, or
+-- inheritance).
+
-- Has_Foreign_Convention (synthesized)
-- Applies to all entities. Determines if the Convention for the entity
-- is a foreign convention, i.e. non-native: other than Convention_Ada,
@@ -1668,6 +1670,12 @@ package Einfo is
-- the instance will conflict with the linear elaboration of front-end
-- inlining.
+-- Extra_Formals_Known
+-- Defined in subprograms, subprogram types, entries, and entry families.
+-- Set when the extra formals have been determined. An entity has no
+-- extra formals when this attribute is True, and its attribute
+-- Extra_Formals is Empty.
+
-- Has_Fully_Qualified_Name
-- Defined in all entities. Set if the name in the Chars field has been
-- replaced by the fully qualified name, as used for debug output. See
@@ -5393,11 +5401,12 @@ package Einfo is
-- Scope_Depth_Value
-- Protection_Object (protected kind)
-- Contract_Wrapper
- -- Extra_Formals
-- Contract
-- SPARK_Pragma (protected kind)
-- Default_Expressions_Processed
-- Entry_Accepted
+ -- Extra_Formals
+ -- Extra_Formals_Known
-- Has_Yield_Aspect
-- Has_Expanded_Contract
-- Ignore_SPARK_Mode_Pragmas
@@ -5519,6 +5528,7 @@ package Einfo is
-- Overridden_Operation
-- Wrapped_Entity (non-generic case only)
-- Extra_Formals
+ -- Extra_Formals_Known (non-generic case only)
-- Anonymous_Collections (non-generic case only)
-- Corresponding_Equality (implicit /= only)
-- Thunk_Entity (thunk case only)
@@ -5723,6 +5733,8 @@ package Einfo is
-- Overridden_Operation
-- Linker_Section_Pragma
-- Contract
+ -- Extra_Formals
+ -- Extra_Formals_Known
-- Import_Pragma
-- LSP_Subprogram
-- SPARK_Pragma
@@ -5877,6 +5889,7 @@ package Einfo is
-- Overridden_Operation (never for init proc)
-- Wrapped_Entity (non-generic case only)
-- Extra_Formals
+ -- Extra_Formals_Known (non-generic case only)
-- Anonymous_Collections (non-generic case only)
-- Static_Initialization (init_proc only)
-- Thunk_Entity (thunk case only)
@@ -6104,6 +6117,7 @@ package Einfo is
-- Last_Entity
-- Scope_Depth_Value
-- Extra_Formals
+ -- Extra_Formals_Known
-- Anonymous_Collections
-- Contract
-- SPARK_Pragma
@@ -6117,6 +6131,7 @@ package Einfo is
-- Extra_Accessibility_Of_Result
-- Directly_Designated_Type
-- Extra_Formals
+ -- Extra_Formals_Known
-- Access_Subprogram_Wrapper
-- First_Formal (synth)
-- First_Formal_With_Extras (synth)
diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb
index 5a47a5a5132..c7dfb0d62ae 100644
--- a/gcc/ada/exp_ch3.adb
+++ b/gcc/ada/exp_ch3.adb
@@ -942,10 +942,11 @@ package body Exp_Ch3 is
Make_Handled_Sequence_Of_Statements (Loc,
Statements => Body_Stmts)));
- Mutate_Ekind (Proc_Id, E_Procedure);
- Set_Is_Public (Proc_Id, Is_Public (A_Type));
- Set_Is_Internal (Proc_Id);
- Set_Has_Completion (Proc_Id);
+ Mutate_Ekind (Proc_Id, E_Procedure);
+ Set_Is_Public (Proc_Id, Is_Public (A_Type));
+ Set_Is_Internal (Proc_Id);
+ Set_Has_Completion (Proc_Id);
+ Freeze_Extra_Formals (Proc_Id);
if not Debug_Generated_Code then
Set_Debug_Info_Off (Proc_Id);
@@ -3204,6 +3205,7 @@ package body Exp_Ch3 is
end if;
Set_Parameter_Specifications (Proc_Spec_Node, Parameters);
+ Freeze_Extra_Formals (Proc_Id);
Set_Specification (Body_Node, Proc_Spec_Node);
Set_Declarations (Body_Node, Decls);
@@ -6570,17 +6572,16 @@ package body Exp_Ch3 is
-- 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.
+ -- This is not needed when 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 AI95-117 requires that
- -- all primitives of a tagged type inherit the convention.
+ -- Notice that for tagged types with foreign convention this is also
+ -- required because (although primitives with foreign convention don't
+ -- have extra formals), a tagged type with foreign convention may have
+ -- primitives with convention Ada.
if Expander_Active
and then Is_Tagged_Type (Typ)
- and then not Has_Foreign_Convention (Typ)
then
declare
Elmt : Elmt_Id;
diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb
index 6ea96d7498a..81686abbad8 100644
--- a/gcc/ada/exp_ch6.adb
+++ b/gcc/ada/exp_ch6.adb
@@ -1155,13 +1155,18 @@ package body Exp_Ch6 is
(Subp_Call : Node_Id;
Subp_Id : Entity_Id) return Boolean
is
- Formal : Entity_Id;
+ use Deferred_Extra_Formals_Support;
+
Actual : Node_Id;
+ Formal : Entity_Id;
begin
pragma Assert (Nkind (Subp_Call) in N_Entry_Call_Statement
| N_Function_Call
| N_Procedure_Call_Statement);
+ pragma Assert (Extra_Formals_Known (Subp_Id)
+ or else not Expander_Active
+ or else Is_Unsupported_Extra_Actuals_Call (Subp_Call, Subp_Id));
-- In CodePeer_Mode, the tree for `'Elab_Spec` procedures will be
-- malformed because GNAT does not perform the usual expansion that
@@ -2866,15 +2871,17 @@ package body Exp_Ch6 is
-----------------
procedure Expand_Call (N : Node_Id) is
- function Is_Unchecked_Union_Equality (N : Node_Id) return Boolean;
+ function Is_Unchecked_Union_Predefined_Equality_Call
+ (N : Node_Id) return Boolean;
-- Return True if N is a call to the predefined equality operator of an
-- unchecked union type, or a renaming thereof.
- ---------------------------------
- -- Is_Unchecked_Union_Equality --
- ---------------------------------
+ -------------------------------------------------
+ -- Is_Unchecked_Union_Predefined_Equality_Call --
+ -------------------------------------------------
- function Is_Unchecked_Union_Equality (N : Node_Id) return Boolean is
+ function Is_Unchecked_Union_Predefined_Equality_Call
+ (N : Node_Id) return Boolean is
begin
if Is_Entity_Name (Name (N))
and then Ekind (Entity (Name (N))) = E_Function
@@ -2899,7 +2906,7 @@ package body Exp_Ch6 is
else
return False;
end if;
- end Is_Unchecked_Union_Equality;
+ end Is_Unchecked_Union_Predefined_Equality_Call;
-- If this is an indirect call through an Access_To_Subprogram
-- with contract specifications, it is rewritten as a call to
@@ -2996,7 +3003,7 @@ package body Exp_Ch6 is
-- Case of a call to the predefined equality operator of an unchecked
-- union type, which requires specific processing.
- elsif Is_Unchecked_Union_Equality (N) then
+ elsif Is_Unchecked_Union_Predefined_Equality_Call (N) then
declare
Eq : constant Entity_Id := Entity (Name (N));
@@ -3020,29 +3027,12 @@ package body Exp_Ch6 is
end if;
end Expand_Call;
- ------------------------
- -- Expand_Call_Helper --
- ------------------------
+ --------------------------
+ -- Create_Extra_Actuals --
+ --------------------------
- -- This procedure handles expansion of function calls and procedure call
- -- statements (i.e. it serves as the body for Expand_N_Function_Call and
- -- Expand_N_Procedure_Call_Statement). Processing for calls includes:
-
- -- Replace call to Raise_Exception by Raise_Exception_Always if possible
- -- Provide values of actuals for all formals in Extra_Formals list
- -- Replace "call" to enumeration literal function by literal itself
- -- Rewrite call to predefined operator as operator
- -- Replace actuals to in-out parameters that are numeric conversions,
- -- with explicit assignment to temporaries before and after the call.
-
- -- Note that the list of actuals has been filled with default expressions
- -- during semantic analysis of the call. Only the extra actuals required
- -- for the 'Constrained attribute and for accessibility checks are added
- -- at this point.
-
- procedure Expand_Call_Helper (N : Node_Id; Post_Call : out List_Id) is
- Loc : constant Source_Ptr := Sloc (N);
- Call_Node : Node_Id := N;
+ procedure Create_Extra_Actuals (Call_Node : Node_Id) is
+ Loc : constant Source_Ptr := Sloc (Call_Node);
Extra_Actuals : List_Id := No_List;
Prev : Node_Id := Empty;
@@ -3072,88 +3062,6 @@ package body Exp_Ch6 is
-- expression for the value of the actual, EF is the entity for the
-- extra formal.
- procedure Add_View_Conversion_Invariants
- (Formal : Entity_Id;
- Actual : Node_Id);
- -- Adds invariant checks for every intermediate type between the range
- -- of a view converted argument to its ancestor (from parent to child).
-
- function Can_Fold_Predicate_Call (P : Entity_Id) return Boolean;
- -- Try to constant-fold a predicate check, which often enough is a
- -- simple arithmetic expression that can be computed statically if
- -- its argument is static. This cleans up the output of CCG, even
- -- though useless predicate checks will be generally removed by
- -- back-end optimizations.
-
- procedure Check_Subprogram_Variant;
- -- Emit a call to the internally generated procedure with checks for
- -- aspect Subprogram_Variant, if present and enabled.
-
- function Inherited_From_Formal (S : Entity_Id) return Entity_Id;
- -- Within an instance, a type derived from an untagged formal derived
- -- type inherits from the original parent, not from the actual. The
- -- current derivation mechanism has the derived type inherit from the
- -- actual, which is only correct outside of the instance. If the
- -- subprogram is inherited, we test for this particular case through a
- -- convoluted tree traversal before setting the proper subprogram to be
- -- called.
-
- function In_Unfrozen_Instance (E : Entity_Id) return Boolean;
- -- Return true if E comes from an instance that is not yet frozen
-
- function Is_Class_Wide_Interface_Type (E : Entity_Id) return Boolean;
- -- Return True when E is a class-wide interface type or an access to
- -- a class-wide interface type.
-
- function Is_Direct_Deep_Call (Subp : Entity_Id) return Boolean;
- -- Determine if Subp denotes a non-dispatching call to a Deep routine
-
- function New_Value (From : Node_Id) return Node_Id;
- -- From is the original Expression. New_Value is equivalent to a call
- -- to Duplicate_Subexpr with an explicit dereference when From is an
- -- access parameter.
-
- --------------------------
- -- Add_Actual_Parameter --
- --------------------------
-
- procedure Add_Actual_Parameter (Insert_Param : Node_Id) is
- Actual_Expr : constant Node_Id :=
- Explicit_Actual_Parameter (Insert_Param);
-
- begin
- -- Case of insertion is first named actual
-
- if No (Prev) or else
- Nkind (Parent (Prev)) /= N_Parameter_Association
- then
- Set_Next_Named_Actual
- (Insert_Param, First_Named_Actual (Call_Node));
- Set_First_Named_Actual (Call_Node, Actual_Expr);
-
- if No (Prev) then
- if No (Parameter_Associations (Call_Node)) then
- Set_Parameter_Associations (Call_Node, New_List);
- end if;
-
- Append (Insert_Param, Parameter_Associations (Call_Node));
-
- else
- Insert_After (Prev, Insert_Param);
- end if;
-
- -- Case of insertion is not first named actual
-
- else
- Set_Next_Named_Actual
- (Insert_Param, Next_Named_Actual (Parent (Prev)));
- Set_Next_Named_Actual (Parent (Prev), Actual_Expr);
- Append (Insert_Param, Parameter_Associations (Call_Node));
- end if;
-
- Prev := Actual_Expr;
- end Add_Actual_Parameter;
-
--------------------------------------
-- Add_Cond_Expression_Extra_Actual --
--------------------------------------
@@ -3368,14 +3276,14 @@ package body Exp_Ch6 is
if Etype (Formal) = Standard_Natural then
Actual := Make_Integer_Literal (Loc, Uint_0);
Analyze_And_Resolve (Actual, Standard_Natural);
- Add_Extra_Actual_To_Call (N, Formal, Actual);
+ Add_Extra_Actual_To_Call (Call_Node, Formal, Actual);
-- BIPtaskmaster
elsif Etype (Formal) = Standard_Integer then
Actual := Make_Integer_Literal (Loc, Uint_0);
Analyze_And_Resolve (Actual, Standard_Integer);
- Add_Extra_Actual_To_Call (N, Formal, Actual);
+ Add_Extra_Actual_To_Call (Call_Node, Formal, Actual);
-- BIPstoragepool, BIPcollection, BIPactivationchain,
-- and BIPaccess.
@@ -3383,7 +3291,7 @@ package body Exp_Ch6 is
elsif Is_Access_Type (Etype (Formal)) then
Actual := Make_Null (Loc);
Analyze_And_Resolve (Actual, Etype (Formal));
- Add_Extra_Actual_To_Call (N, Formal, Actual);
+ Add_Extra_Actual_To_Call (Call_Node, Formal, Actual);
else
pragma Assert (False);
@@ -3402,6 +3310,47 @@ package body Exp_Ch6 is
pragma Assert (Check_BIP_Actuals (Call_Node, Function_Id));
end Add_Dummy_Build_In_Place_Actuals;
+ --------------------------
+ -- Add_Actual_Parameter --
+ --------------------------
+
+ procedure Add_Actual_Parameter (Insert_Param : Node_Id) is
+ Actual_Expr : constant Node_Id :=
+ Explicit_Actual_Parameter (Insert_Param);
+
+ begin
+ -- Case of insertion is first named actual
+
+ if No (Prev)
+ or else Nkind (Parent (Prev)) /= N_Parameter_Association
+ then
+ Set_Next_Named_Actual
+ (Insert_Param, First_Named_Actual (Call_Node));
+ Set_First_Named_Actual (Call_Node, Actual_Expr);
+
+ if No (Prev) then
+ if No (Parameter_Associations (Call_Node)) then
+ Set_Parameter_Associations (Call_Node, New_List);
+ end if;
+
+ Append (Insert_Param, Parameter_Associations (Call_Node));
+
+ else
+ Insert_After (Prev, Insert_Param);
+ end if;
+
+ -- Case of insertion is not first named actual
+
+ else
+ Set_Next_Named_Actual
+ (Insert_Param, Next_Named_Actual (Parent (Prev)));
+ Set_Next_Named_Actual (Parent (Prev), Actual_Expr);
+ Append (Insert_Param, Parameter_Associations (Call_Node));
+ end if;
+
+ Prev := Actual_Expr;
+ end Add_Actual_Parameter;
+
----------------------
-- Add_Extra_Actual --
----------------------
@@ -3427,6 +3376,421 @@ package body Exp_Ch6 is
end if;
end Add_Extra_Actual;
+ -- Local variables
+
+ use Deferred_Extra_Formals_Support;
+
+ Actual : Node_Id;
+ Formal : Entity_Id;
+ Param_Count : Positive;
+ Subp : constant Entity_Id := Get_Called_Entity (Call_Node);
+
+ -- Start of processing for Create_Extra_Actuals
+
+ begin
+ -- Special case: Thunks must not compute the extra actuals; they must
+ -- just propagate their extra actuals to the target primitive.
+
+ if Is_Thunk (Current_Scope)
+ and then Thunk_Entity (Current_Scope) = Subp
+ then
+ declare
+ Target_Formal : Entity_Id;
+ Thunk_Formal : Entity_Id;
+
+ begin
+ pragma Assert (Extra_Formals_Known (Subp)
+ and then Extra_Formals_Match_OK (Current_Scope, Subp));
+
+ Target_Formal := Extra_Formals (Subp);
+ Thunk_Formal := Extra_Formals (Current_Scope);
+ while Present (Target_Formal) loop
+ Add_Extra_Actual
+ (Expr => New_Occurrence_Of (Thunk_Formal, Loc),
+ EF => Thunk_Formal);
+
+ Target_Formal := Extra_Formal (Target_Formal);
+ Thunk_Formal := Extra_Formal (Thunk_Formal);
+ end loop;
+
+ while Is_Non_Empty_List (Extra_Actuals) loop
+ Add_Actual_Parameter (Remove_Head (Extra_Actuals));
+ end loop;
+
+ return;
+ end;
+ end if;
+
+ pragma Assert (Extra_Formals_Known (Subp)
+ or else Is_Unsupported_Extra_Formals_Entity (Subp));
+
+ -- First step, compute extra actuals, corresponding to any Extra_Formals
+ -- present. Note that we do not access Extra_Formals directly; instead
+ -- we generate and collect the corresponding actuals in Extra_Actuals.
+
+ Formal := First_Formal (Subp);
+ Actual := First_Actual (Call_Node);
+ Param_Count := 1;
+ while Present (Formal) loop
+ -- Prepare to examine current entry
+
+ Prev := Actual;
+
+ -- Create possible extra actual for constrained case. Usually, the
+ -- extra actual is of the form actual'constrained, but since this
+ -- attribute is only available for unconstrained records, TRUE is
+ -- expanded if the type of the formal happens to be constrained (for
+ -- instance when this procedure is inherited from an unconstrained
+ -- record to a constrained one) or if the actual has no discriminant
+ -- (its type is constrained). An exception to this is the case of a
+ -- private type without discriminants. In this case we pass FALSE
+ -- because the object has underlying discriminants with defaults.
+
+ if Present (Extra_Constrained (Formal)) then
+ if Is_Mutably_Tagged_Type (Etype (Actual))
+ or else (Is_Private_Type (Etype (Prev))
+ and then not Has_Discriminants
+ (Base_Type (Etype (Prev))))
+ then
+ Add_Extra_Actual
+ (Expr => New_Occurrence_Of (Standard_False, Loc),
+ EF => Extra_Constrained (Formal));
+
+ elsif Is_Constrained (Etype (Formal))
+ or else not Has_Discriminants (Etype (Prev))
+ then
+ Add_Extra_Actual
+ (Expr => New_Occurrence_Of (Standard_True, Loc),
+ EF => Extra_Constrained (Formal));
+
+ -- Do not produce extra actuals for Unchecked_Union parameters.
+ -- Jump directly to the end of the loop.
+
+ elsif Is_Unchecked_Union (Base_Type (Etype (Actual))) then
+ goto Skip_Extra_Actual_Generation;
+
+ else
+ -- If the actual is a type conversion, then the constrained
+ -- test applies to the actual, not the target type.
+
+ declare
+ Act_Prev : Node_Id;
+
+ begin
+ -- Test for unchecked conversions as well, which can occur
+ -- as out parameter actuals on calls to stream procedures.
+
+ Act_Prev := Prev;
+ while Nkind (Act_Prev) in N_Type_Conversion
+ | N_Unchecked_Type_Conversion
+ loop
+ Act_Prev := Expression (Act_Prev);
+ end loop;
+
+ -- If the expression is a conversion of a dereference, this
+ -- is internally generated code that manipulates addresses,
+ -- e.g. when building interface tables. No check should
+ -- occur in this case, and the discriminated object is not
+ -- directly at hand.
+
+ if not Comes_From_Source (Actual)
+ and then Nkind (Actual) = N_Unchecked_Type_Conversion
+ and then Nkind (Act_Prev) = N_Explicit_Dereference
+ then
+ Add_Extra_Actual
+ (Expr => New_Occurrence_Of (Standard_False, Loc),
+ EF => Extra_Constrained (Formal));
+
+ else
+ Add_Extra_Actual
+ (Expr =>
+ Make_Attribute_Reference (Sloc (Prev),
+ Prefix =>
+ Duplicate_Subexpr_No_Checks
+ (Act_Prev, Name_Req => True),
+ Attribute_Name => Name_Constrained),
+ EF => Extra_Constrained (Formal));
+ end if;
+ end;
+ end if;
+ end if;
+
+ -- Create possible extra actual for accessibility level
+
+ if Present (Extra_Accessibility (Formal)) then
+
+ -- Ada 2005 (AI-251): Thunks must propagate the extra actuals of
+ -- accessibility levels.
+
+ if Is_Thunk (Current_Scope) then
+ declare
+ Parm_Ent : Entity_Id;
+
+ begin
+ if Is_Controlling_Actual (Actual) then
+
+ -- Find the corresponding actual of the thunk
+
+ Parm_Ent := First_Entity (Current_Scope);
+ for J in 2 .. Param_Count loop
+ Next_Entity (Parm_Ent);
+ end loop;
+
+ -- Handle unchecked conversion of access types generated
+ -- in thunks (cf. Expand_Interface_Thunk).
+
+ elsif Is_Access_Type (Etype (Actual))
+ and then Nkind (Actual) = N_Unchecked_Type_Conversion
+ then
+ Parm_Ent := Entity (Expression (Actual));
+
+ else pragma Assert (Is_Entity_Name (Actual));
+ Parm_Ent := Entity (Actual);
+ end if;
+
+ Add_Extra_Actual
+ (Expr => Accessibility_Level
+ (Expr => Parm_Ent,
+ Level => Dynamic_Level,
+ Allow_Alt_Model => False),
+ EF => Extra_Accessibility (Formal));
+ end;
+
+ -- Conditional expressions
+
+ elsif Nkind (Prev) = N_Expression_With_Actions
+ and then Nkind (Original_Node (Prev)) in
+ N_If_Expression | N_Case_Expression
+ then
+ Add_Cond_Expression_Extra_Actual (Formal);
+
+ -- Internal constant generated to remove side effects (normally
+ -- from the expansion of dispatching calls).
+
+ -- First verify the actual is internal
+
+ elsif not Comes_From_Source (Prev)
+ and then not Is_Rewrite_Substitution (Prev)
+
+ -- Next check that the actual is a constant
+
+ and then Nkind (Prev) = N_Identifier
+ and then Ekind (Entity (Prev)) = E_Constant
+ and then Nkind (Parent (Entity (Prev))) = N_Object_Declaration
+ then
+ -- Generate the accessibility level based on the expression in
+ -- the constant's declaration.
+
+ declare
+ Ent : Entity_Id := Entity (Prev);
+
+ begin
+ -- Handle deferred constants
+
+ if Present (Full_View (Ent)) then
+ Ent := Full_View (Ent);
+ end if;
+
+ Add_Extra_Actual
+ (Expr => Accessibility_Level
+ (Expr => Expression (Parent (Ent)),
+ Level => Dynamic_Level,
+ Allow_Alt_Model => False),
+ EF => Extra_Accessibility (Formal));
+ end;
+
+ -- Normal case
+
+ else
+ Add_Extra_Actual
+ (Expr => Accessibility_Level
+ (Expr => Prev,
+ Level => Dynamic_Level,
+ Allow_Alt_Model => False),
+ EF => Extra_Accessibility (Formal));
+ end if;
+ end if;
+
+ -- This label is required when skipping extra actual generation for
+ -- Unchecked_Union parameters.
+
+ <<Skip_Extra_Actual_Generation>>
+
+ Param_Count := Param_Count + 1;
+ Next_Actual (Actual);
+ Next_Formal (Formal);
+ end loop;
+
+ -- If we are calling an Ada 2012 function which needs to have the
+ -- "accessibility level determined by the point of call" (AI05-0234)
+ -- passed in to it, then pass it in.
+
+ if Ekind (Subp) in E_Function | E_Operator | E_Subprogram_Type
+ and then
+ Present (Extra_Accessibility_Of_Result (Ultimate_Alias (Subp)))
+ then
+ declare
+ Extra_Form : Node_Id := Empty;
+ Level : Node_Id := Empty;
+
+ begin
+ -- Detect cases where the function call has been internally
+ -- generated by examining the original node and return library
+ -- level - taking care to avoid ignoring function calls expanded
+ -- in prefix notation.
+
+ if Nkind (Original_Node (Call_Node)) not in N_Function_Call
+ | N_Selected_Component
+ | N_Indexed_Component
+ then
+ Level := Make_Integer_Literal
+ (Loc, Scope_Depth (Standard_Standard));
+
+ -- Otherwise get the level normally based on the call node
+
+ else
+ Level := Accessibility_Level
+ (Expr => Call_Node,
+ Level => Dynamic_Level,
+ Allow_Alt_Model => False);
+ end if;
+
+ -- It may be possible that we are re-expanding an already
+ -- expanded call when are are dealing with dispatching ???
+
+ if No (Parameter_Associations (Call_Node))
+ or else Nkind (Last (Parameter_Associations (Call_Node)))
+ /= N_Parameter_Association
+ or else not Is_Accessibility_Actual
+ (Last (Parameter_Associations (Call_Node)))
+ then
+ Extra_Form := Extra_Accessibility_Of_Result
+ (Ultimate_Alias (Subp));
+
+ Add_Extra_Actual
+ (Expr => Level,
+ EF => Extra_Form);
+ end if;
+ end;
+ end if;
+
+ -- Second step: In the previous loop we gathered the extra actuals (the
+ -- ones that correspond to Extra_Formals), so now they can be appended.
+
+ if Is_Non_Empty_List (Extra_Actuals) then
+ declare
+ Num_Extra_Actuals : constant Nat := List_Length (Extra_Actuals);
+
+ begin
+ while Is_Non_Empty_List (Extra_Actuals) loop
+ Add_Actual_Parameter (Remove_Head (Extra_Actuals));
+ end loop;
+
+ -- Add dummy extra BIP actuals if we are calling a function that
+ -- inherited the BIP extra actuals but does not require them.
+
+ if Nkind (Call_Node) = N_Function_Call
+ and then Is_Function_Call_With_BIP_Formals (Call_Node)
+ and then not Is_Build_In_Place_Function_Call (Call_Node)
+ then
+ Add_Dummy_Build_In_Place_Actuals (Subp,
+ Num_Added_Extra_Actuals => Num_Extra_Actuals);
+ end if;
+ end;
+
+ -- Add dummy extra BIP actuals if we are calling a function that
+ -- inherited the BIP extra actuals but does not require them.
+
+ elsif Nkind (Call_Node) = N_Function_Call
+ and then Is_Function_Call_With_BIP_Formals (Call_Node)
+ and then not Is_Build_In_Place_Function_Call (Call_Node)
+ then
+ Add_Dummy_Build_In_Place_Actuals (Subp);
+ end if;
+
+ -- For non build-in-place calls formals and actuals must match;
+ -- for build-in-place function calls, the pending bip actuals are
+ -- added by the following subprograms as part of the bottom-up
+ -- expansion of the call (and this check will be performed there):
+ -- Make_Build_In_Place_Call_In_Allocator
+ -- Make_Build_In_Place_Call_In_Anonymous_Context
+ -- Make_Build_In_Place_Call_In_Assignment
+ -- Make_Build_In_Place_Call_In_Object_Declaration
+ -- Make_Build_In_Place_Iface_Call_In_Allocator
+ -- Make_Build_In_Place_Iface_Call_In_Anonymous_Context
+ -- Make_Build_In_Place_Iface_Call_In_Object_Declaration
+
+ pragma Assert (Is_Build_In_Place_Function_Call (Call_Node)
+ or else (Check_Number_Of_Actuals (Call_Node, Subp)
+ and then Check_BIP_Actuals (Call_Node, Subp)));
+ end Create_Extra_Actuals;
+
+ ------------------------
+ -- Expand_Call_Helper --
+ ------------------------
+
+ -- This procedure handles expansion of function calls and procedure call
+ -- statements (i.e. it serves as the body for Expand_N_Function_Call and
+ -- Expand_N_Procedure_Call_Statement). Processing for calls includes:
+
+ -- Replace call to Raise_Exception by Raise_Exception_Always if possible
+ -- Provide values of actuals for all formals in Extra_Formals list
+ -- Replace "call" to enumeration literal function by literal itself
+ -- Rewrite call to predefined operator as operator
+ -- Replace actuals to in-out parameters that are numeric conversions,
+ -- with explicit assignment to temporaries before and after the call.
+
+ -- Note that the list of actuals has been filled with default expressions
+ -- during semantic analysis of the call. Only the extra actuals required
+ -- for the 'Constrained attribute and for accessibility checks are added
+ -- at this point.
+
+ procedure Expand_Call_Helper (N : Node_Id; Post_Call : out List_Id) is
+ Loc : constant Source_Ptr := Sloc (N);
+ Call_Node : Node_Id := N;
+ Prev : Node_Id := Empty;
+
+ procedure Add_View_Conversion_Invariants
+ (Formal : Entity_Id;
+ Actual : Node_Id);
+ -- Adds invariant checks for every intermediate type between the range
+ -- of a view converted argument to its ancestor (from parent to child).
+
+ function Can_Fold_Predicate_Call (P : Entity_Id) return Boolean;
+ -- Try to constant-fold a predicate check, which often enough is a
+ -- simple arithmetic expression that can be computed statically if
+ -- its argument is static. This cleans up the output of CCG, even
+ -- though useless predicate checks will be generally removed by
+ -- back-end optimizations.
+
+ procedure Check_Subprogram_Variant;
+ -- Emit a call to the internally generated procedure with checks for
+ -- aspect Subprogram_Variant, if present and enabled.
+
+ function Inherited_From_Formal (S : Entity_Id) return Entity_Id;
+ -- Within an instance, a type derived from an untagged formal derived
+ -- type inherits from the original parent, not from the actual. The
+ -- current derivation mechanism has the derived type inherit from the
+ -- actual, which is only correct outside of the instance. If the
+ -- subprogram is inherited, we test for this particular case through a
+ -- convoluted tree traversal before setting the proper subprogram to be
+ -- called.
+
+ function In_Unfrozen_Instance (E : Entity_Id) return Boolean;
+ -- Return true if E comes from an instance that is not yet frozen
+
+ function Is_Class_Wide_Interface_Type (E : Entity_Id) return Boolean;
+ -- Return True when E is a class-wide interface type or an access to
+ -- a class-wide interface type.
+
+ function Is_Direct_Deep_Call (Subp : Entity_Id) return Boolean;
+ -- Determine if Subp denotes a non-dispatching call to a Deep routine
+
+ function New_Value (From : Node_Id) return Node_Id;
+ -- From is the original Expression. New_Value is equivalent to a call
+ -- to Duplicate_Subexpr with an explicit dereference when From is an
+ -- access parameter.
+
------------------------------------
-- Add_View_Conversion_Invariants --
------------------------------------
@@ -3943,6 +4307,9 @@ package body Exp_Ch6 is
Subp : Entity_Id;
CW_Interface_Formals_Present : Boolean := False;
+ Defer_Extra_Actuals : Boolean := False;
+
+ use Deferred_Extra_Formals_Support;
-- Start of processing for Expand_Call_Helper
@@ -4029,12 +4396,6 @@ package body Exp_Ch6 is
end if;
end if;
- -- Ensure that the called subprogram has all its formals
-
- if not Is_Frozen (Subp) then
- Create_Extra_Formals (Subp);
- end if;
-
-- Ada 2005 (AI-345): We have a procedure call as a triggering
-- alternative in an asynchronous select or as an entry call in
-- a conditional or timed select. Check whether the procedure call
@@ -4080,6 +4441,50 @@ package body Exp_Ch6 is
end;
end if;
+ -- Ensure that the called subprogram has all its formals; extra formals
+ -- of init procs were added when they were built.
+
+ if not Extra_Formals_Known (Subp) then
+ Create_Extra_Formals (Subp);
+
+ -- If the previous call to Create_Extra_Formals could not add the
+ -- extra formals, then we must defer adding the extra actuals of
+ -- this call until we know the underlying type of all the formals
+ -- and return type of the called subprogram or entry. Deferral of
+ -- extra actuals occurs in two cases:
+ -- 1) In the body of internally built dynamic call helpers of
+ -- class-wide preconditions.
+ -- 2) In the body of expanded expression functions.
+
+ if not Extra_Formals_Known (Subp) then
+ declare
+ Scop_Id : Entity_Id := Current_Scope;
+
+ begin
+ -- Locate the enclosing subprogram or entry since it is
+ -- required to register this deferred call.
+
+ Scop_Id := Current_Scope;
+ while Present (Scop_Id)
+ and then Scop_Id /= Standard_Standard
+ and then not Is_Subprogram_Or_Entry (Scop_Id)
+ loop
+ Scop_Id := Scope (Scop_Id);
+ end loop;
+
+ pragma Assert (Is_Subprogram_Or_Entry (Scop_Id));
+ pragma Assert (Is_Deferred_Extra_Formals_Entity (Subp));
+ Register_Deferred_Extra_Formals_Call (Call_Node, Scop_Id);
+
+ Defer_Extra_Actuals := True;
+ end;
+ end if;
+ end if;
+
+ pragma Assert (Extra_Formals_Known (Subp)
+ or else Is_Deferred_Extra_Formals_Entity (Subp)
+ or else Is_Unsupported_Extra_Formals_Entity (Subp));
+
-- If this is a call to a predicate function, try to constant fold it
if Nkind (Call_Node) = N_Function_Call
@@ -4091,56 +4496,39 @@ package body Exp_Ch6 is
end if;
-- First step, compute extra actuals, corresponding to any Extra_Formals
- -- present. Note that we do not access Extra_Formals directly, instead
+ -- present. Note that we do not access Extra_Formals directly; instead
-- we simply note the presence of the extra formals as we process the
-- regular formals collecting corresponding actuals in Extra_Actuals.
- -- We also generate any required range checks for actuals for in formals
- -- as we go through the loop, since this is a convenient place to do it.
- -- (Though it seems that this would be better done in Expand_Actuals???)
+ -- We also generate any required range checks for actuals for in-mode
+ -- formals as we go through the loop, since this is a convenient place
+ -- to do it. (Though it seems that this would be better done in
+ -- Expand_Actuals???)
-- Special case: Thunks must not compute the extra actuals; they must
- -- just propagate to the target primitive their extra actuals.
+ -- just propagate their extra actuals to the target primitive (this
+ -- propagation is performed by Create_Extra_Actuals).
if Is_Thunk (Current_Scope)
and then Thunk_Entity (Current_Scope) = Subp
+ and then Extra_Formals_Known (Subp)
and then Present (Extra_Formals (Subp))
then
- pragma Assert (Extra_Formals_Match_OK (Current_Scope, Subp));
+ Create_Extra_Actuals (N);
- declare
- Target_Formal : Entity_Id;
- Thunk_Formal : Entity_Id;
+ -- Mark the call as an expanded build-in-place call; required
+ -- to avoid adding the extra formals twice.
- begin
- Target_Formal := Extra_Formals (Subp);
- Thunk_Formal := Extra_Formals (Current_Scope);
- while Present (Target_Formal) loop
- Add_Extra_Actual
- (Expr => New_Occurrence_Of (Thunk_Formal, Loc),
- EF => Thunk_Formal);
+ if Nkind (Call_Node) = N_Function_Call then
+ Set_Is_Expanded_Build_In_Place_Call (Call_Node);
+ end if;
- Target_Formal := Extra_Formal (Target_Formal);
- Thunk_Formal := Extra_Formal (Thunk_Formal);
- end loop;
+ Expand_Actuals (Call_Node, Subp, Post_Call);
- while Is_Non_Empty_List (Extra_Actuals) loop
- Add_Actual_Parameter (Remove_Head (Extra_Actuals));
- end loop;
-
- -- Mark the call as processed build-in-place call; required
- -- to avoid adding the extra formals twice.
-
- if Nkind (Call_Node) = N_Function_Call then
- Set_Is_Expanded_Build_In_Place_Call (Call_Node);
- end if;
-
- Expand_Actuals (Call_Node, Subp, Post_Call);
- pragma Assert (Is_Empty_List (Post_Call));
- pragma Assert (Check_Number_Of_Actuals (Call_Node, Subp));
- pragma Assert (Check_BIP_Actuals (Call_Node, Subp));
- return;
- end;
+ pragma Assert (Is_Empty_List (Post_Call));
+ pragma Assert (Check_Number_Of_Actuals (Call_Node, Subp));
+ pragma Assert (Check_BIP_Actuals (Call_Node, Subp));
+ return;
end if;
Formal := First_Formal (Subp);
@@ -4158,180 +4546,6 @@ package body Exp_Ch6 is
CW_Interface_Formals_Present
or else Is_Class_Wide_Interface_Type (Etype (Formal));
- -- Create possible extra actual for constrained case. Usually, the
- -- extra actual is of the form actual'constrained, but since this
- -- attribute is only available for unconstrained records, TRUE is
- -- expanded if the type of the formal happens to be constrained (for
- -- instance when this procedure is inherited from an unconstrained
- -- record to a constrained one) or if the actual has no discriminant
- -- (its type is constrained). An exception to this is the case of a
- -- private type without discriminants. In this case we pass FALSE
- -- because the object has underlying discriminants with defaults.
-
- if Present (Extra_Constrained (Formal)) then
- if Is_Mutably_Tagged_Type (Etype (Actual))
- or else (Is_Private_Type (Etype (Prev))
- and then not Has_Discriminants
- (Base_Type (Etype (Prev))))
- then
- Add_Extra_Actual
- (Expr => New_Occurrence_Of (Standard_False, Loc),
- EF => Extra_Constrained (Formal));
-
- elsif Is_Constrained (Etype (Formal))
- or else not Has_Discriminants (Etype (Prev))
- then
- Add_Extra_Actual
- (Expr => New_Occurrence_Of (Standard_True, Loc),
- EF => Extra_Constrained (Formal));
-
- -- Do not produce extra actuals for Unchecked_Union parameters.
- -- Jump directly to the end of the loop.
-
- elsif Is_Unchecked_Union (Base_Type (Etype (Actual))) then
- goto Skip_Extra_Actual_Generation;
-
- else
- -- If the actual is a type conversion, then the constrained
- -- test applies to the actual, not the target type.
-
- declare
- Act_Prev : Node_Id;
-
- begin
- -- Test for unchecked conversions as well, which can occur
- -- as out parameter actuals on calls to stream procedures.
-
- Act_Prev := Prev;
- while Nkind (Act_Prev) in N_Type_Conversion
- | N_Unchecked_Type_Conversion
- loop
- Act_Prev := Expression (Act_Prev);
- end loop;
-
- -- If the expression is a conversion of a dereference, this
- -- is internally generated code that manipulates addresses,
- -- e.g. when building interface tables. No check should
- -- occur in this case, and the discriminated object is not
- -- directly at hand.
-
- if not Comes_From_Source (Actual)
- and then Nkind (Actual) = N_Unchecked_Type_Conversion
- and then Nkind (Act_Prev) = N_Explicit_Dereference
- then
- Add_Extra_Actual
- (Expr => New_Occurrence_Of (Standard_False, Loc),
- EF => Extra_Constrained (Formal));
-
- else
- Add_Extra_Actual
- (Expr =>
- Make_Attribute_Reference (Sloc (Prev),
- Prefix =>
- Duplicate_Subexpr_No_Checks
- (Act_Prev, Name_Req => True),
- Attribute_Name => Name_Constrained),
- EF => Extra_Constrained (Formal));
- end if;
- end;
- end if;
- end if;
-
- -- Create possible extra actual for accessibility level
-
- if Present (Extra_Accessibility (Formal)) then
- -- Ada 2005 (AI-251): Thunks must propagate the extra actuals of
- -- accessibility levels.
-
- if Is_Thunk (Current_Scope) then
- declare
- Parm_Ent : Entity_Id;
-
- begin
- if Is_Controlling_Actual (Actual) then
-
- -- Find the corresponding actual of the thunk
-
- Parm_Ent := First_Entity (Current_Scope);
- for J in 2 .. Param_Count loop
- Next_Entity (Parm_Ent);
- end loop;
-
- -- Handle unchecked conversion of access types generated
- -- in thunks (cf. Expand_Interface_Thunk).
-
- elsif Is_Access_Type (Etype (Actual))
- and then Nkind (Actual) = N_Unchecked_Type_Conversion
- then
- Parm_Ent := Entity (Expression (Actual));
-
- else pragma Assert (Is_Entity_Name (Actual));
- Parm_Ent := Entity (Actual);
- end if;
-
- Add_Extra_Actual
- (Expr => Accessibility_Level
- (Expr => Parm_Ent,
- Level => Dynamic_Level,
- Allow_Alt_Model => False),
- EF => Extra_Accessibility (Formal));
- end;
-
- -- Conditional expressions
-
- elsif Nkind (Prev) = N_Expression_With_Actions
- and then Nkind (Original_Node (Prev)) in
- N_If_Expression | N_Case_Expression
- then
- Add_Cond_Expression_Extra_Actual (Formal);
-
- -- Internal constant generated to remove side effects (normally
- -- from the expansion of dispatching calls).
-
- -- First verify the actual is internal
-
- elsif not Comes_From_Source (Prev)
- and then not Is_Rewrite_Substitution (Prev)
-
- -- Next check that the actual is a constant
-
- and then Nkind (Prev) = N_Identifier
- and then Ekind (Entity (Prev)) = E_Constant
- and then Nkind (Parent (Entity (Prev))) = N_Object_Declaration
- then
- -- Generate the accessibility level based on the expression in
- -- the constant's declaration.
-
- declare
- Ent : Entity_Id := Entity (Prev);
-
- begin
- -- Handle deferred constants
-
- if Present (Full_View (Ent)) then
- Ent := Full_View (Ent);
- end if;
-
- Add_Extra_Actual
- (Expr => Accessibility_Level
- (Expr => Expression (Parent (Ent)),
- Level => Dynamic_Level,
- Allow_Alt_Model => False),
- EF => Extra_Accessibility (Formal));
- end;
-
- -- Normal case
-
- else
- Add_Extra_Actual
- (Expr => Accessibility_Level
- (Expr => Prev,
- Level => Dynamic_Level,
- Allow_Alt_Model => False),
- EF => Extra_Accessibility (Formal));
- end if;
- end if;
-
-- Perform the check of 4.6(49) that prevents a null value from being
-- passed as an actual to an access parameter. Note that the check
-- is elided in the common cases of passing an access attribute or
@@ -4525,66 +4739,11 @@ package body Exp_Ch6 is
-- This label is required when skipping extra actual generation for
-- Unchecked_Union parameters.
- <<Skip_Extra_Actual_Generation>>
-
Param_Count := Param_Count + 1;
Next_Actual (Actual);
Next_Formal (Formal);
end loop;
- -- If we are calling an Ada 2012 function which needs to have the
- -- "accessibility level determined by the point of call" (AI05-0234)
- -- passed in to it, then pass it in.
-
- if Ekind (Subp) in E_Function | E_Operator | E_Subprogram_Type
- and then
- Present (Extra_Accessibility_Of_Result (Ultimate_Alias (Subp)))
- then
- declare
- Extra_Form : Node_Id := Empty;
- Level : Node_Id := Empty;
-
- begin
- -- Detect cases where the function call has been internally
- -- generated by examining the original node and return library
- -- level - taking care to avoid ignoring function calls expanded
- -- in prefix notation.
-
- if Nkind (Original_Node (Call_Node)) not in N_Function_Call
- | N_Selected_Component
- | N_Indexed_Component
- then
- Level := Make_Integer_Literal
- (Loc, Scope_Depth (Standard_Standard));
-
- -- Otherwise get the level normally based on the call node
-
- else
- Level := Accessibility_Level
- (Expr => Call_Node,
- Level => Dynamic_Level,
- Allow_Alt_Model => False);
- end if;
-
- -- It may be possible that we are re-expanding an already
- -- expanded call when are are dealing with dispatching ???
-
- if No (Parameter_Associations (Call_Node))
- or else Nkind (Last (Parameter_Associations (Call_Node)))
- /= N_Parameter_Association
- or else not Is_Accessibility_Actual
- (Last (Parameter_Associations (Call_Node)))
- then
- Extra_Form := Extra_Accessibility_Of_Result
- (Ultimate_Alias (Subp));
-
- Add_Extra_Actual
- (Expr => Level,
- EF => Extra_Form);
- end if;
- end;
- end if;
-
-- If we are expanding the RHS of an assignment we need to check if tag
-- propagation is needed. You might expect this processing to be in
-- Analyze_Assignment but has to be done earlier (bottom-up) because the
@@ -4778,38 +4937,12 @@ package body Exp_Ch6 is
then
null;
- -- During that loop we gathered the extra actuals (the ones that
- -- correspond to Extra_Formals), so now they can be appended.
+ elsif not Defer_Extra_Actuals then
+ Create_Extra_Formals (Subp);
- elsif Is_Non_Empty_List (Extra_Actuals) then
- declare
- Num_Extra_Actuals : constant Nat := List_Length (Extra_Actuals);
-
- begin
- while Is_Non_Empty_List (Extra_Actuals) loop
- Add_Actual_Parameter (Remove_Head (Extra_Actuals));
- end loop;
-
- -- Add dummy extra BIP actuals if we are calling a function that
- -- inherited the BIP extra actuals but does not require them.
-
- if Nkind (Call_Node) = N_Function_Call
- and then Is_Function_Call_With_BIP_Formals (Call_Node)
- and then not Is_Build_In_Place_Function_Call (Call_Node)
- then
- Add_Dummy_Build_In_Place_Actuals (Subp,
- Num_Added_Extra_Actuals => Num_Extra_Actuals);
- end if;
- end;
-
- -- Add dummy extra BIP actuals if we are calling a function that
- -- inherited the BIP extra actuals but does not require them.
-
- elsif Nkind (Call_Node) = N_Function_Call
- and then Is_Function_Call_With_BIP_Formals (Call_Node)
- and then not Is_Build_In_Place_Function_Call (Call_Node)
- then
- Add_Dummy_Build_In_Place_Actuals (Subp);
+ if Extra_Formals_Known (Subp) then
+ Create_Extra_Actuals (N);
+ end if;
end if;
-- At this point we have all the actuals, so this is the point at which
@@ -8563,6 +8696,8 @@ package body Exp_Ch6 is
Rewrite (Allocator, New_Occurrence_Of (Return_Obj_Access, Loc));
Analyze_And_Resolve (Allocator, Acc_Type);
+
+ pragma Assert (Returns_By_Ref (Function_Id));
pragma Assert (Check_Number_Of_Actuals (Func_Call, Function_Id));
pragma Assert (Check_BIP_Actuals (Func_Call, Function_Id));
end Make_Build_In_Place_Call_In_Allocator;
@@ -8668,6 +8803,7 @@ package body Exp_Ch6 is
Set_Is_Expanded_Build_In_Place_Call (Func_Call);
+ pragma Assert (Returns_By_Ref (Function_Id));
pragma Assert (Check_Number_Of_Actuals (Func_Call, Function_Id));
pragma Assert (Check_BIP_Actuals (Func_Call, Function_Id));
end if;
@@ -8769,6 +8905,8 @@ package body Exp_Ch6 is
Insert_After_And_Analyze (Ptr_Typ_Decl, Obj_Decl);
Rewrite (Assign, Make_Null_Statement (Loc));
+
+ pragma Assert (Returns_By_Ref (Func_Id));
pragma Assert (Check_Number_Of_Actuals (Func_Call, Func_Id));
pragma Assert (Check_BIP_Actuals (Func_Call, Func_Id));
end Make_Build_In_Place_Call_In_Assignment;
@@ -9193,6 +9331,7 @@ package body Exp_Ch6 is
end if;
end if;
+ pragma Assert (Returns_By_Ref (Function_Id));
pragma Assert (Check_Number_Of_Actuals (Func_Call, Function_Id));
pragma Assert (Check_BIP_Actuals (Func_Call, Function_Id));
end Make_Build_In_Place_Call_In_Object_Declaration;
@@ -9830,35 +9969,16 @@ package body Exp_Ch6 is
=>
declare
Call_Node : Node_Id renames Nod;
- Subp : Entity_Id;
+ Subp : constant Entity_Id := Get_Called_Entity (Nod);
begin
- -- Call using access to subprogram with explicit dereference
-
- if Nkind (Name (Call_Node)) = N_Explicit_Dereference then
- Subp := Etype (Name (Call_Node));
-
- -- Prefix notation calls
-
- elsif Nkind (Name (Call_Node)) = N_Selected_Component then
- Subp := Entity (Selector_Name (Name (Call_Node)));
-
- -- Call to member of entry family, where Name is an indexed
- -- component, with the prefix being a selected component
- -- giving the task and entry family name, and the index
- -- being the entry index.
-
- elsif Nkind (Name (Call_Node)) = N_Indexed_Component then
- Subp :=
- Entity (Selector_Name (Prefix (Name (Call_Node))));
-
- -- Normal case
-
- else
- Subp := Entity (Name (Call_Node));
- end if;
-
pragma Assert (Check_BIP_Actuals (Call_Node, Subp));
+
+ -- Build-in-place function calls return their result by
+ -- reference.
+
+ pragma Assert (not Is_Build_In_Place_Function (Subp)
+ or else Returns_By_Ref (Subp));
end;
-- Skip generic bodies
diff --git a/gcc/ada/exp_ch6.ads b/gcc/ada/exp_ch6.ads
index 118d994e605..483b78bd178 100644
--- a/gcc/ada/exp_ch6.ads
+++ b/gcc/ada/exp_ch6.ads
@@ -101,6 +101,10 @@ package Exp_Ch6 is
-- Adds Extra_Actual as a named parameter association for the formal
-- Extra_Formal in Subprogram_Call.
+ procedure Create_Extra_Actuals (Call_Node : Node_Id);
+ -- Create the extra actuals of the given call and add them to its
+ -- actual parameters list.
+
procedure Apply_CW_Accessibility_Check (Exp : Node_Id; Func : Entity_Id);
-- Ada 2005 (AI95-344): If the result type is class-wide, insert a check
-- that the level of the return expression's underlying type is not deeper
diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb
index 009bee4bc6c..5d406a3416a 100644
--- a/gcc/ada/exp_ch7.adb
+++ b/gcc/ada/exp_ch7.adb
@@ -59,6 +59,7 @@ with Sinfo.Nodes; use Sinfo.Nodes;
with Sinfo.Utils; use Sinfo.Utils;
with Sem; use Sem;
with Sem_Aux; use Sem_Aux;
+with Sem_Ch6; use Sem_Ch6;
with Sem_Ch7; use Sem_Ch7;
with Sem_Ch8; use Sem_Ch8;
with Sem_Res; use Sem_Res;
@@ -2331,6 +2332,8 @@ package body Exp_Ch7 is
Ensure_Freeze_Node (Fin_Id);
Insert_After (Fin_Spec, Freeze_Node (Fin_Id));
+ Mutate_Ekind (Fin_Id, E_Procedure);
+ Freeze_Extra_Formals (Fin_Id);
Set_Is_Frozen (Fin_Id);
Append_To (Stmts, Fin_Body);
@@ -9448,9 +9451,16 @@ package body Exp_Ch7 is
procedure Wrap_Transient_Expression (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Expr : Node_Id := Relocate_Node (N);
- Temp : constant Entity_Id := Make_Temporary (Loc, 'E', N);
Typ : constant Entity_Id := Etype (N);
+ Temp : constant Entity_Id := Make_Temporary (Loc, 'E',
+ Related_Node => Expr);
+ -- We link the temporary with its relocated expression to facilitate
+ -- locating the expression in the expanded code; this simplifies the
+ -- implementation of the function that searchs in the expanded code
+ -- for a function call that has been wrapped in a transient block
+ -- (see Get_Relocated_Function_Call).
+
begin
-- Generate:
diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb
index 9cfc6b536e9..c979cf6899b 100644
--- a/gcc/ada/exp_ch9.adb
+++ b/gcc/ada/exp_ch9.adb
@@ -4691,11 +4691,11 @@ package body Exp_Ch9 is
-- The availability of the activation chain entity does not ensure
-- that we have tasks to activate because it may have been declared
- -- by the frontend to pass a required extra formal to a build-in-place
+ -- by the front end to pass a required extra formal to a build-in-place
-- subprogram call. If we are within the scope of a protected type and
-- pragma Detect_Blocking is active we can assume that no tasks will be
-- activated; if tasks are created in a protected object and this pragma
- -- is active then the frontend emits a warning and Program_Error is
+ -- is active then the front end emits a warning and Program_Error is
-- raised at runtime.
elsif Detect_Blocking and then Within_Protected_Type (Current_Scope) then
@@ -8094,12 +8094,18 @@ package body Exp_Ch9 is
-- access type. Finally the Entry_Component of each formal is set to
-- reference the corresponding record component.
- procedure Expand_N_Entry_Declaration (N : Node_Id) is
+ procedure Expand_N_Entry_Declaration
+ (N : Node_Id;
+ Was_Deferred : Boolean := False)
+ is
+ use Deferred_Extra_Formals_Support;
+
Loc : constant Source_Ptr := Sloc (N);
Entry_Ent : constant Entity_Id := Defining_Identifier (N);
Components : List_Id;
Formal : Node_Id;
Ftype : Entity_Id;
+ First_Decl : Node_Id;
Last_Decl : Node_Id;
Component : Entity_Id;
Ctype : Entity_Id;
@@ -8108,7 +8114,21 @@ package body Exp_Ch9 is
Acc_Ent : Entity_Id;
begin
+ -- No action if the addition of the extra formals was deferred,
+ -- since it means that the underlying type of some formal is not
+ -- available, and hence we cannot build the record type that will
+ -- hold all the parameter values.
+
+ if Present (First_Formal (Entry_Ent))
+ and then not Extra_Formals_Known (Entry_Ent)
+ and then not Is_Unsupported_Extra_Formals_Entity (Entry_Ent)
+ then
+ pragma Assert (Is_Deferred_Extra_Formals_Entity (Entry_Ent));
+ return;
+ end if;
+
Formal := First_Formal (Entry_Ent);
+ First_Decl := N;
Last_Decl := N;
-- Most processing is done only if parameters are present
@@ -8184,6 +8204,24 @@ package body Exp_Ch9 is
Subtype_Indication => New_Occurrence_Of (Rec_Ent, Loc)));
Insert_After (Last_Decl, Decl);
+ Last_Decl := Decl;
+
+ -- Analyze all the inserted declarations. This is required when
+ -- the entry has formals and the addition of its extra formals
+ -- was deferred; otherwise their analysis will be performed as
+ -- as part of the regular flow of the front end at the end of
+ -- analysis of the enclosing task/protected type declaration.
+
+ if Was_Deferred then
+ Push_Scope (Scope (Entry_Ent));
+
+ while First_Decl /= Last_Decl loop
+ Next (First_Decl);
+ Analyze (First_Decl);
+ end loop;
+
+ End_Scope;
+ end if;
end if;
end Expand_N_Entry_Declaration;
diff --git a/gcc/ada/exp_ch9.ads b/gcc/ada/exp_ch9.ads
index cae6cb3a166..681114133fe 100644
--- a/gcc/ada/exp_ch9.ads
+++ b/gcc/ada/exp_ch9.ads
@@ -227,9 +227,16 @@ package Exp_Ch9 is
procedure Expand_N_Delay_Until_Statement (N : Node_Id);
procedure Expand_N_Entry_Body (N : Node_Id);
procedure Expand_N_Entry_Call_Statement (N : Node_Id);
- procedure Expand_N_Entry_Declaration (N : Node_Id);
procedure Expand_N_Protected_Body (N : Node_Id);
+ procedure Expand_N_Entry_Declaration
+ (N : Node_Id;
+ Was_Deferred : Boolean := False);
+ -- Expands an entry declaration, building a record type to hold all the
+ -- parameter values. Was_Deferred is True when this expansion was deferred
+ -- because the underlying type of some formal was not available to build
+ -- the record.
+
procedure Expand_N_Protected_Type_Declaration (N : Node_Id);
-- Expands protected type declarations. This results, among other things,
-- in the declaration of a record type for the representation of protected
diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb
index 080a2e1a6c1..6cd4f6a515c 100644
--- a/gcc/ada/exp_disp.adb
+++ b/gcc/ada/exp_disp.adb
@@ -926,6 +926,8 @@ package body Exp_Disp is
New_Formal : Entity_Id;
Last_Formal : Entity_Id := Empty;
+ use Deferred_Extra_Formals_Support;
+
begin
if Present (Old_Formal) then
New_Formal := New_Copy (Old_Formal);
@@ -962,51 +964,21 @@ package body Exp_Disp is
end if;
-- Now that the explicit formals have been duplicated, any extra
- -- formals needed by the subprogram must be duplicated; we know
- -- that extra formals are available because they were added when
- -- the tagged type was frozen (see Expand_Freeze_Record_Type).
+ -- formals needed by the subprogram must be added; we know that
+ -- extra formals are available because they were added when the
+ -- tagged type was frozen (see Expand_Freeze_Record_Type).
pragma Assert (Is_Frozen (Typ));
- -- Warning: The addition of the extra formals cannot be performed
- -- here invoking Create_Extra_Formals since we must ensure that all
- -- the extra formals of the pointer type and the target subprogram
- -- match (and for functions that return a tagged type the profile of
- -- the built subprogram type always returns a class-wide type, which
- -- may affect the addition of some extra formals).
+ if Extra_Formals_Known (Subp) then
+ Create_Extra_Formals (Subp_Typ);
- if Present (Last_Formal)
- and then Present (Extra_Formal (Last_Formal))
- then
- Old_Formal := Extra_Formal (Last_Formal);
- New_Formal := New_Copy (Old_Formal);
- Set_Scope (New_Formal, Subp_Typ);
+ -- Extra formals were previously deferred
- Set_Extra_Formal (Last_Formal, New_Formal);
- Set_Extra_Formals (Subp_Typ, New_Formal);
-
- if Ekind (Subp) = E_Function
- and then Present (Extra_Accessibility_Of_Result (Subp))
- and then Extra_Accessibility_Of_Result (Subp) = Old_Formal
- then
- Set_Extra_Accessibility_Of_Result (Subp_Typ, New_Formal);
- end if;
-
- Old_Formal := Extra_Formal (Old_Formal);
- while Present (Old_Formal) loop
- Set_Extra_Formal (New_Formal, New_Copy (Old_Formal));
- New_Formal := Extra_Formal (New_Formal);
- Set_Scope (New_Formal, Subp_Typ);
-
- if Ekind (Subp) = E_Function
- and then Present (Extra_Accessibility_Of_Result (Subp))
- and then Extra_Accessibility_Of_Result (Subp) = Old_Formal
- then
- Set_Extra_Accessibility_Of_Result (Subp_Typ, New_Formal);
- end if;
-
- Old_Formal := Extra_Formal (Old_Formal);
- end loop;
+ else
+ pragma Assert (Is_Deferred_Extra_Formals_Entity (Subp));
+ Register_Deferred_Extra_Formals_Entity (Subp_Typ);
+ Register_Deferred_Extra_Formals_Call (Call_Node, Current_Scope);
end if;
end;
@@ -8345,13 +8317,15 @@ package body Exp_Disp is
Defining_Unit_Name => IP,
Parameter_Specifications => Parms)));
- Set_Init_Proc (Typ, IP);
- Set_Is_Imported (IP);
- Set_Is_Constructor (IP);
- Set_Interface_Name (IP, Interface_Name (E));
- Set_Convention (IP, Convention_CPP);
- Set_Is_Public (IP);
- Set_Has_Completion (IP);
+ Set_Init_Proc (Typ, IP);
+ Set_Is_Imported (IP);
+ Set_Is_Constructor (IP);
+ Set_Interface_Name (IP, Interface_Name (E));
+ Set_Convention (IP, Convention_CPP);
+ Set_Is_Public (IP);
+ Set_Has_Completion (IP);
+ Mutate_Ekind (IP, E_Procedure);
+ Freeze_Extra_Formals (IP);
-- Case 2: Constructor of a tagged type
@@ -8484,6 +8458,8 @@ package body Exp_Disp is
Discard_Node (IP_Body);
Set_Init_Proc (Typ, IP);
+ Mutate_Ekind (IP, E_Procedure);
+ Freeze_Extra_Formals (IP);
end;
end if;
@@ -8549,6 +8525,8 @@ package body Exp_Disp is
Discard_Node (IP_Body);
Set_Init_Proc (Typ, IP);
+ Mutate_Ekind (IP, E_Procedure);
+ Freeze_Extra_Formals (IP);
end;
end if;
diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb
index 3755d9e53de..c47b884701a 100644
--- a/gcc/ada/freeze.adb
+++ b/gcc/ada/freeze.adb
@@ -8130,6 +8130,7 @@ package body Freeze is
if Ekind (E) = E_Anonymous_Access_Subprogram_Type
and then Ekind (Designated_Type (E)) = E_Subprogram_Type
then
+ Create_Extra_Formals (Designated_Type (E));
Layout_Type (Etype (Designated_Type (E)));
end if;
@@ -10393,6 +10394,8 @@ package body Freeze is
-- Local variables
+ use Deferred_Extra_Formals_Support;
+
F : Entity_Id;
Retype : Entity_Id;
@@ -10493,8 +10496,11 @@ package body Freeze is
Create_Extra_Formals (E);
pragma Assert
- ((Ekind (E) = E_Subprogram_Type
- and then Extra_Formals_OK (E))
+ ((Extra_Formals_Known (E)
+ or else Is_Deferred_Extra_Formals_Entity (E))
+ or else
+ (Ekind (E) = E_Subprogram_Type
+ and then Extra_Formals_OK (E))
or else
(Is_Subprogram (E)
and then Extra_Formals_OK (E)
@@ -10523,6 +10529,10 @@ package body Freeze is
else
Set_Mechanisms (E);
+ if not Extra_Formals_Known (E) then
+ Freeze_Extra_Formals (E);
+ end if;
+
-- For foreign conventions, warn about return of unconstrained array
if Ekind (E) = E_Function then
@@ -10578,6 +10588,11 @@ package body Freeze is
end if;
end if;
+ -- Check formals matching in thunks
+
+ pragma Assert (not Is_Thunk (E)
+ or else Extra_Formals_Match_OK (Thunk_Entity (E), E));
+
-- Pragma Inline_Always is disallowed for dispatching subprograms
-- because the address of such subprograms is saved in the dispatch
-- table to support dispatching calls, and dispatching calls cannot
diff --git a/gcc/ada/gen_il-fields.ads b/gcc/ada/gen_il-fields.ads
index 9b4adee1d46..68adcf4a71a 100644
--- a/gcc/ada/gen_il-fields.ads
+++ b/gcc/ada/gen_il-fields.ads
@@ -539,6 +539,7 @@ package Gen_IL.Fields is
Extra_Constrained,
Extra_Formal,
Extra_Formals,
+ Extra_Formals_Known,
Finalization_Collection,
Finalization_Master_Node,
Finalize_Storage_Only,
diff --git a/gcc/ada/gen_il-gen-gen_entities.adb
b/gcc/ada/gen_il-gen-gen_entities.adb
index b2970e6c2bf..44995452b10 100644
--- a/gcc/ada/gen_il-gen-gen_entities.adb
+++ b/gcc/ada/gen_il-gen-gen_entities.adb
@@ -935,11 +935,13 @@ begin -- Gen_IL.Gen.Gen_Entities
(Sm (Access_Subprogram_Wrapper, Node_Id),
Sm (Extra_Accessibility_Of_Result, Node_Id),
Sm (Extra_Formals, Node_Id),
+ Sm (Extra_Formals_Known, Flag),
Sm (Needs_No_Actuals, Flag)));
Ab (Overloadable_Kind, Entity_Kind,
(Sm (Renamed_Or_Alias, Node_Id),
Sm (Extra_Formals, Node_Id),
+ Sm (Extra_Formals_Known, Flag),
Sm (Is_Abstract_Subprogram, Flag),
Sm (Is_Primitive, Flag),
Sm (Needs_No_Actuals, Flag),
@@ -1127,6 +1129,7 @@ begin -- Gen_IL.Gen.Gen_Entities
Sm (Entry_Accepted, Flag),
Sm (Entry_Parameters_Type, Node_Id),
Sm (Extra_Formals, Node_Id),
+ Sm (Extra_Formals_Known, Flag),
Sm (First_Entity, Node_Id),
Sm (Has_Out_Or_In_Out_Parameter, Flag),
Sm (Ignore_SPARK_Mode_Pragmas, Flag),
@@ -1328,6 +1331,7 @@ begin -- Gen_IL.Gen.Gen_Entities
(Sm (Anonymous_Collections, Elist_Id),
Sm (Contract, Node_Id),
Sm (Extra_Formals, Node_Id),
+ Sm (Extra_Formals_Known, Flag),
Sm (First_Entity, Node_Id),
Sm (Ignore_SPARK_Mode_Pragmas, Flag),
Sm (Interface_Name, Node_Id),
diff --git a/gcc/ada/gen_il-internals.adb b/gcc/ada/gen_il-internals.adb
index 8d0dfc710a4..3fa8b940542 100644
--- a/gcc/ada/gen_il-internals.adb
+++ b/gcc/ada/gen_il-internals.adb
@@ -277,6 +277,8 @@ package body Gen_IL.Internals is
return "DT_Offset_To_Top_Func";
when DT_Position =>
return "DT_Position";
+ when Extra_Formals_Known =>
+ return "Extra_Formals_Known";
when Forwards_OK =>
return "Forwards_OK";
when Has_First_Controlling_Parameter_Aspect =>
diff --git a/gcc/ada/sem_aux.adb b/gcc/ada/sem_aux.adb
index 08ff0b11268..0aa74e39050 100644
--- a/gcc/ada/sem_aux.adb
+++ b/gcc/ada/sem_aux.adb
@@ -453,16 +453,28 @@ package body Sem_Aux is
Id : Entity_Id;
begin
+ -- Call using access to subprogram with explicit dereference
+
if Nkind (Nam) = N_Explicit_Dereference then
Id := Etype (Nam);
pragma Assert (Ekind (Id) = E_Subprogram_Type);
+ -- Case of call to simple entry, where the Name is a selected component
+ -- whose prefix is the task or protected record, and whose selector name
+ -- is the entry name.
+
elsif Nkind (Nam) = N_Selected_Component then
Id := Entity (Selector_Name (Nam));
+ -- Case of call to member of entry family, where Name is an indexed
+ -- component, with the prefix being a selected component giving the
+ -- task and entry family name, and the index being the entry index.
+
elsif Nkind (Nam) = N_Indexed_Component then
Id := Entity (Selector_Name (Prefix (Nam)));
+ -- Normal case
+
else
Id := Entity (Nam);
end if;
diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb
index 704bf3e0412..8a1cac0451d 100644
--- a/gcc/ada/sem_ch13.adb
+++ b/gcc/ada/sem_ch13.adb
@@ -15887,6 +15887,8 @@ package body Sem_Ch13 is
-- We may freeze Subp_Id immediately since Ent has just been frozen.
-- This will help to shield us from potential late freezing issues.
+ Mutate_Ekind (Subp_Id, E_Procedure);
+ Freeze_Extra_Formals (Subp_Id);
Set_Is_Frozen (Subp_Id);
else
diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb
index 9fb2030a42b..227dda25d04 100644
--- a/gcc/ada/sem_ch3.adb
+++ b/gcc/ada/sem_ch3.adb
@@ -3020,6 +3020,8 @@ package body Sem_Ch3 is
-----------------------------------
procedure Analyze_Full_Type_Declaration (N : Node_Id) is
+ use Deferred_Extra_Formals_Support;
+
Def : constant Node_Id := Type_Definition (N);
Def_Id : constant Entity_Id := Defining_Identifier (N);
T : Entity_Id;
@@ -3558,6 +3560,16 @@ package body Sem_Ch3 is
end if;
end if;
+ -- If we have some subprogram, subprogram type, or entry, with deferred
+ -- addition of its extra formals (because the underlying type of this
+ -- type was not previously available), then try creating now its extra
+ -- formals. Create also the extra actuals of deferred calls to entities
+ -- with deferred extra formals.
+
+ if Has_Deferred_Extra_Formals (T) then
+ Add_Deferred_Extra_Params (T);
+ end if;
+
if Ekind (T) = E_Record_Type
and then Is_Large_Unconstrained_Definite (T)
and then not Is_Limited_Type (T)
diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb
index 8af980fe0c3..a13f4bd97df 100644
--- a/gcc/ada/sem_ch6.adb
+++ b/gcc/ada/sem_ch6.adb
@@ -3864,9 +3864,14 @@ package body Sem_Ch6 is
Spec_Id := Build_Internal_Protected_Declaration (N);
end if;
- -- If a separate spec is present, then deal with freezing issues
+ -- Separate spec is not present
- if Present (Spec_Id) then
+ if No (Spec_Id) then
+ Create_Extra_Formals (Body_Id);
+
+ -- Separate spec is present; deal with freezing issues
+
+ else
Spec_Decl := Unit_Declaration_Node (Spec_Id);
Verify_Overriding_Indicator;
@@ -3882,6 +3887,8 @@ package body Sem_Ch6 is
and then not Has_BIP_Formals (Spec_Id)
then
Create_Extra_Formals (Spec_Id);
+ pragma Assert (not Expander_Active
+ or else Extra_Formals_Known (Spec_Id));
Compute_Returns_By_Ref (Spec_Id);
end if;
@@ -8564,14 +8571,13 @@ package body Sem_Ch6 is
-- without coordinating with CodePeer, which makes use of these to
-- provide better messages.
+ -- A and B denote extra formals for unchecked unions equality. See
+ -- exp_ch3.Build_Variant_Record_Equality.
-- O denotes the Constrained bit.
-- L denotes the accessibility level.
-- BIP_xxx denotes an extra formal for a build-in-place function. See
-- the full list in exp_ch6.BIP_Formal_Kind.
- function Has_Extra_Formals (E : Entity_Id) return Boolean;
- -- Determines if E has its extra formals
-
function Might_Need_BIP_Task_Actuals (E : Entity_Id) return Boolean;
-- Determines if E is a function or an access to a function returning a
-- limited tagged type object. On dispatching primitives this predicate
@@ -8610,14 +8616,6 @@ package body Sem_Ch6 is
EF : Entity_Id;
begin
- -- A little optimization. Never generate an extra formal for the
- -- _init operand of an initialization procedure, since it could
- -- never be used.
-
- if Chars (Formal) = Name_uInit then
- return Empty;
- end if;
-
EF := Make_Defining_Identifier (Sloc (Assoc_Entity),
Chars => New_External_Name (Chars (Assoc_Entity),
Suffix => Suffix));
@@ -8643,18 +8641,6 @@ package body Sem_Ch6 is
return EF;
end Add_Extra_Formal;
- -----------------------
- -- 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;
-
---------------------------------
-- Might_Need_BIP_Task_Actuals --
---------------------------------
@@ -8792,10 +8778,12 @@ package body Sem_Ch6 is
-- 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.
+ -- formals of Subp_Id because its extra formals are shared
+ -- with its parent subprogram (see Sem_Ch3.Derive_Subprogram).
else
pragma Assert (not Comes_From_Source (Ovr_E));
+ Freeze_Extra_Formals (Ovr_E);
end if;
-- Use as our reference entity the ultimate renaming of the
@@ -8818,10 +8806,14 @@ package body Sem_Ch6 is
-- Local variables
- Formal_Type : Entity_Id;
- May_Have_Alias : Boolean;
+ use Deferred_Extra_Formals_Support;
+
+ Can_Be_Deferred : constant Boolean :=
+ not Is_Unsupported_Extra_Formals_Entity (E);
Alias_Formal : Entity_Id := Empty;
Alias_Subp : Entity_Id := Empty;
+ Formal_Type : Entity_Id;
+ May_Have_Alias : Boolean;
Parent_Formal : Entity_Id := Empty;
Parent_Subp : Entity_Id := Empty;
Ref_E : Entity_Id;
@@ -8832,10 +8824,18 @@ package body Sem_Ch6 is
pragma Assert (Is_Subprogram_Or_Entry (E)
or else Ekind (E) in E_Subprogram_Type);
+ -- No action needed if extra formals were already handled. This
+ -- situation may arise because of a previous call to create the
+ -- extra formals, and also for subprogram types created as part
+ -- of dispatching calls (see Expand_Dispatching_Call).
+
+ if Extra_Formals_Known (E) then
+ return;
+
-- 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
+ elsif not Expander_Active then
return;
-- Enumeration literals have no extra formal; this case occurs when
@@ -8844,25 +8844,38 @@ package body Sem_Ch6 is
elsif Ekind (E) = E_Function
and then Ekind (Ultimate_Alias (E)) = E_Enumeration_Literal
then
+ Freeze_Extra_Formals (E);
return;
- -- Extra formals of Initialization procedures are added by the function
- -- Exp_Ch3.Init_Formals
+ -- Extra formals of init procs are added by Exp_Ch3.Init_Formals and
+ -- Set_CPP_Constructors when they are built, but we must handle here
+ -- aliased init procs.
elsif Is_Init_Proc (E) then
+ pragma Assert (Present (Alias (E)));
+ pragma Assert (Extra_Formals_Known (Ultimate_Alias (E)));
+ Freeze_Extra_Formals (E);
return;
-- 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
+ elsif Is_Thunk (E)
+ and then Extra_Formals_Known (Thunk_Target (E))
+ and then No (Extra_Formals (Thunk_Target (E)))
+ then
+ Freeze_Extra_Formals (E);
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).
+ -- Handle alias of unchecked union equality with frozen extra formals
- elsif Has_Extra_Formals (E) then
+ elsif Is_Overloadable (E)
+ and then Present (Alias (E))
+ and then Extra_Formals_Known (Ultimate_Alias (E))
+ and then Is_Unchecked_Union_Equality (Ultimate_Alias (E))
+ then
+ Set_Extra_Formals (E, Extra_Formals (Ultimate_Alias (E)));
+ Freeze_Extra_Formals (E);
return;
-- Extra formals of renamings of generic actual subprograms and
@@ -8880,6 +8893,8 @@ package body Sem_Ch6 is
= Is_Generic_Instance (Ultimate_Alias (E)));
Create_Extra_Formals (Ultimate_Alias (E));
+ pragma Assert (not Expander_Active
+ or else Extra_Formals_Known (Ultimate_Alias (E)));
-- Share the extra formals
@@ -8891,17 +8906,72 @@ package body Sem_Ch6 is
end if;
pragma Assert (Extra_Formals_OK (E));
+ Freeze_Extra_Formals (E);
return;
end if;
- -- Locate the last formal; required by Add_Extra_Formal.
+ -- Check if the addition of the extra formals must be deferred
Formal := First_Formal (E);
while Present (Formal) loop
- Last_Extra := Formal;
+ if No (Underlying_Type (Etype (Formal)))
+ and then Can_Be_Deferred
+ then
+ Register_Deferred_Extra_Formals_Entity (E);
+ return;
+ end if;
+
Next_Formal (Formal);
end loop;
+ if Ekind (E) in E_Function
+ | E_Subprogram_Type
+ and then No (Underlying_Type (Etype (E)))
+ and then Can_Be_Deferred
+ then
+ Register_Deferred_Extra_Formals_Entity (E);
+ return;
+ end if;
+
+ -- Here we start adding the extra formals
+
+ -- We we know that either the underlying type of all the formals and
+ -- returned results of E are known, or this is an special case where
+ -- some underlying type is still not available.
+
+ -- In the former case, we can already mark functions that return their
+ -- result by reference; in the latter case, we can mark them only if the
+ -- underlying return type is available (and it will be marked later).
+
+ if not Is_Unsupported_Extra_Formals_Entity (E)
+ or else (Ekind (E) in E_Function | E_Subprogram_Type
+ and then Present (Underlying_Type (Etype (E))))
+ then
+ Compute_Returns_By_Ref (E);
+ end if;
+
+ -- Locate the last formal (required by Add_Extra_Formal)
+
+ if Present (First_Formal (E))
+ and then Is_Unchecked_Union (Etype (First_Formal (E)))
+ and then Present (Extra_Formals (E))
+ and then Has_Suffix (Extra_Formals (E), 'A')
+ then
+ -- An unchecked union equality has two extra formals per discriminant
+
+ First_Extra := Extra_Formals (E);
+ Last_Extra := First_Extra;
+ while Present (Last_Extra) loop
+ pragma Assert (Has_Suffix (Last_Extra, 'A'));
+ Last_Extra := Extra_Formal (Last_Extra);
+
+ pragma Assert (Has_Suffix (Last_Extra, 'B'));
+ Last_Extra := Extra_Formal (Last_Extra);
+ end loop;
+ else
+ Last_Extra := Last_Formal (E);
+ end if;
+
-- We rely on three entities to ensure consistency of extra formals of
-- entity E:
--
@@ -8961,6 +9031,7 @@ package body Sem_Ch6 is
or else (Present (Alias_Subp)
and then Has_Foreign_Convention (Alias_Subp))
then
+ Freeze_Extra_Formals (E);
return;
end if;
@@ -9039,14 +9110,44 @@ package body Sem_Ch6 is
-- 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);
+ -- Common case: the underlying type of all the formals is known
+ -- to be available.
- elsif Present (Alias_Formal) then
- Formal_Type := Etype (Alias_Formal);
+ if Can_Be_Deferred then
+ if Present (Parent_Formal) then
+ Formal_Type := Underlying_Type (Etype (Parent_Formal));
+ elsif Present (Alias_Formal) then
+ Formal_Type := Underlying_Type (Etype (Alias_Formal));
+ else
+ Formal_Type := Underlying_Type (Etype (Formal));
+ end if;
+
+ pragma Assert (Present (Formal_Type));
+
+ -- Special case: The underlying type of some formal is not available.
+ -- We use the underlying type when present. More work needed here???
else
- Formal_Type := Etype (Formal);
+ if Present (Parent_Formal) then
+ Formal_Type := Etype (Parent_Formal);
+
+ if Present (Underlying_Type (Formal_Type)) then
+ Formal_Type := Underlying_Type (Formal_Type);
+ end if;
+
+ elsif Present (Alias_Formal) then
+ Formal_Type := Etype (Alias_Formal);
+
+ if Present (Underlying_Type (Formal_Type)) then
+ Formal_Type := Underlying_Type (Formal_Type);
+ end if;
+ else
+ Formal_Type := Etype (Formal);
+
+ if Present (Underlying_Type (Formal_Type)) then
+ Formal_Type := Underlying_Type (Formal_Type);
+ end if;
+ end if;
end if;
-- Create extra formal for supporting the attribute 'Constrained.
@@ -9093,12 +9194,13 @@ package body Sem_Ch6 is
and then (Is_Definite_Subtype (Formal_Type)
or else Is_Mutably_Tagged_Type (Formal_Type))
and then (Ada_Version < Ada_2012
- or else No (Underlying_Type (Formal_Type))
+ or else
+ (not Can_Be_Deferred
+ and then No (Underlying_Type (Formal_Type)))
or else not
(Is_Limited_Type (Formal_Type)
and then
- Is_Tagged_Type
- (Underlying_Type (Formal_Type))))
+ Is_Tagged_Type (Formal_Type)))
then
Set_Extra_Constrained
(Formal, Add_Extra_Formal (Formal, Standard_Boolean, E, "O"));
@@ -9337,6 +9439,8 @@ package body Sem_Ch6 is
Set_Extra_Formals (Alias (E), Extra_Formals (E));
end if;
+ Freeze_Extra_Formals (E);
+
pragma Assert (No (Alias_Subp)
or else Extra_Formals_Match_OK (E, Alias_Subp));
@@ -9651,6 +9755,19 @@ package body Sem_Ch6 is
return False;
end if;
+ -- Extra formals (A and B) of Unchecked_Unions (see Build_Variant_
+ -- Record_Equality)
+
+ elsif Has_Suffix (Formal_1, 'A') then
+ if not Has_Suffix (Formal_2, 'A') then
+ return False;
+ end if;
+
+ elsif Has_Suffix (Formal_1, 'B') then
+ if not Has_Suffix (Formal_2, 'B') then
+ return False;
+ end if;
+
elsif BIP_Suffix_Kind (Formal_1) /= BIP_Suffix_Kind (Formal_2) then
return False;
end if;
@@ -10003,6 +10120,16 @@ package body Sem_Ch6 is
return Empty;
end Find_Corresponding_Spec;
+ --------------------------
+ -- Freeze_Extra_Formals --
+ --------------------------
+
+ procedure Freeze_Extra_Formals (E : Entity_Id) is
+ begin
+ pragma Assert (not Extra_Formals_Known (E));
+ Set_Extra_Formals_Known (E);
+ end Freeze_Extra_Formals;
+
----------------------
-- Fully_Conformant --
----------------------
@@ -10622,6 +10749,10 @@ package body Sem_Ch6 is
Formal : Entity_Id := First_Formal_With_Extras (E);
begin
+ -- It makes no sense to perform this check if the extra formals
+ -- have not been added.
+ pragma Assert (Extra_Formals_Known (E));
+
while Present (Formal) loop
if Is_Build_In_Place_Entity (Formal) then
return True;
@@ -12795,6 +12926,530 @@ package body Sem_Ch6 is
end if;
end New_Overloaded_Entity;
+ ------------------------------------
+ -- Deferred_Extra_Formals_Support --
+ ------------------------------------
+
+ package body Deferred_Extra_Formals_Support is
+ Calls_List : Elist_Id := No_Elist;
+ Calls_Scope_List : Elist_Id := No_Elist;
+ -- Calls to subprograms or entries with some unknown underlying type
+ -- in their parameters or result type, and the scope where each call
+ -- is performed.
+
+ Entities_List : Elist_Id := No_Elist;
+ -- Subprograms, entries, and subprogram types with some unknown
+ -- underlying type in their formals or result type.
+
+ Types_List : Elist_Id := No_Elist;
+ -- Types with no underlying type
+
+ function Underlying_Types_Available (E : Entity_Id) return Boolean;
+ -- Determines if the underlying type of all the formals and result
+ -- type of the given subprogram, subprogram type, or entry are
+ -- available.
+
+ -------------------------------
+ -- Add_Deferred_Extra_Params --
+ -------------------------------
+
+ procedure Add_Deferred_Extra_Params (Typ : Entity_Id) is
+
+ procedure Check_Registered_Calls;
+ -- Check all the registered calls; for each registered call that
+ -- has the underlying type of all the parameters and result types
+ -- of the called entity available, call Create_Extra_Actuals, and
+ -- unregister the call.
+
+ procedure Check_Registered_Entities;
+ -- Check all the registered entities (subprograms, entries and
+ -- subprogram types); for each registered entity E that has all
+ -- its underlying types available, call Create_Extra_Formals,
+ -- and unregister E.
+
+ ----------------------------
+ -- Check_Registered_Calls --
+ ----------------------------
+
+ procedure Check_Registered_Calls is
+
+ function Get_Relocated_Function_Call (N : Node_Id) return Node_Id;
+ -- Given a node N that references a function call that has been
+ -- relocated to remove possible side effects of the call (see
+ -- Remove_Side_Effects) or to wrap the call in a transient scope
+ -- (see Wrap_Transient_Expression), search and return the function
+ -- call. Notice that this function does not use the Original_Node
+ -- field of N; it searchs for the actual call associated with N
+ -- in the expanded code (since we need to add to such call its
+ -- missing extra actuals).
+
+ ---------------------------------
+ -- Get_Relocated_Function_Call --
+ ---------------------------------
+
+ function Get_Relocated_Function_Call (N : Node_Id) return Node_Id
+ is
+ Current_Node : Node_Id;
+ Decl : Node_Id;
+ Id : Entity_Id;
+
+ begin
+ Current_Node := N;
+
+ while Nkind (Current_Node) /= N_Function_Call loop
+ case Nkind (Current_Node) is
+ when N_Identifier =>
+ Id := Entity (Current_Node);
+ Decl := Parent (Id);
+
+ if Nkind (Decl) = N_Object_Renaming_Declaration then
+ Current_Node := Name (Decl);
+
+ else
+ pragma Assert (Nkind (Decl) = N_Object_Declaration);
+
+ if Present (Expression (Decl)) then
+ Current_Node := Expression (Decl);
+
+ elsif Present (BIP_Initialization_Call (Id)) then
+ Decl := BIP_Initialization_Call (Id);
+ pragma Assert (Present (Expression (Decl)));
+ Current_Node := Expression (Decl);
+
+ elsif Present (Related_Expression (Id)) then
+ Current_Node := Related_Expression (Id);
+
+ else
+ pragma Assert (False);
+ raise Program_Error;
+ end if;
+ end if;
+
+ when N_Explicit_Dereference | N_Reference =>
+ Current_Node := Prefix (Current_Node);
+
+ when others =>
+ pragma Assert (False);
+ raise Program_Error;
+ end case;
+ end loop;
+
+ return Current_Node;
+ end Get_Relocated_Function_Call;
+
+ -- Local variables
+
+ Call_Node : Node_Id;
+ Call_Id : Entity_Id;
+ Elmt_Call : Elmt_Id;
+ Elmt_Scope : Elmt_Id;
+ Remove_Call : Boolean;
+ Scop_Id : Entity_Id;
+
+ -- Start of processing for Check_Registered_Calls
+
+ begin
+ -- Perform a single traversal of both lists simultaneously,
+ -- since they have the same number of elements with a 1-to-1
+ -- relationship.
+
+ Elmt_Scope := First_Elmt (Calls_Scope_List);
+ Elmt_Call := First_Elmt (Calls_List);
+
+ while Present (Elmt_Scope) loop
+ Scop_Id := Node (Elmt_Scope);
+ Remove_Call := False;
+
+ -- Check the enclosing scope of the call: if the underlying
+ -- type of some formal or return type of the enclosing scope
+ -- of this call is not available then we must skip processing
+ -- this call.
+
+ if Underlying_Types_Available (Scop_Id) then
+ Call_Node := Node (Elmt_Call);
+
+ if Nkind (Call_Node) in N_Entry_Call_Statement
+ | N_Function_Call
+ | N_Procedure_Call_Statement
+ then
+ Call_Id := Get_Called_Entity (Call_Node);
+
+ -- Handle expanded function calls that could have side
+ -- effects.
+
+ else
+ pragma Assert
+ (Nkind (Original_Node (Call_Node)) = N_Function_Call);
+
+ Call_Node := Get_Relocated_Function_Call (Call_Node);
+ Call_Id := Get_Called_Entity (Call_Node);
+ end if;
+
+ -- If the underlying types of all the formal and return
+ -- types of this called entity are available then create
+ -- its extra actuals and remove it from the list of
+ -- registered calls.
+
+ if Underlying_Types_Available (Call_Id) then
+
+ -- Given that the call is placed in the body of an
+ -- internally built subprogram, ensure that the extra
+ -- formals of the enclosing scope are available before
+ -- adding the extra actuals of this call.
+
+ Create_Extra_Formals (Scop_Id);
+ Create_Extra_Formals (Call_Id);
+
+ pragma Assert (Extra_Formals_Known (Scop_Id));
+ pragma Assert (Extra_Formals_Known (Call_Id));
+
+ -- Mark functions that return a result by reference
+
+ Compute_Returns_By_Ref (Scop_Id);
+ Compute_Returns_By_Ref (Call_Id);
+
+ Push_Scope (Scop_Id);
+ Create_Extra_Actuals (Call_Node);
+ Pop_Scope;
+
+ Remove_Call := True;
+ end if;
+ end if;
+
+ -- In order to safely remove these elements from their
+ -- containing lists, remember these elements before moving
+ -- to the next list elements.
+
+ if Remove_Call then
+ declare
+ Removed_Call : constant Elmt_Id := Elmt_Call;
+ Removed_Scope : constant Elmt_Id := Elmt_Scope;
+
+ begin
+ Next_Elmt (Elmt_Scope);
+ Next_Elmt (Elmt_Call);
+
+ Remove_Elmt (Calls_List, Removed_Call);
+ Remove_Elmt (Calls_Scope_List, Removed_Scope);
+ end;
+ else
+ Next_Elmt (Elmt_Scope);
+ Next_Elmt (Elmt_Call);
+ end if;
+
+ end loop;
+ end Check_Registered_Calls;
+
+ -------------------------------
+ -- Check_Registered_Entities --
+ -------------------------------
+
+ procedure Check_Registered_Entities is
+ Elmt : Elmt_Id;
+ Found_Elmt : Elmt_Id;
+ Id : Entity_Id;
+
+ begin
+ Elmt := First_Elmt (Entities_List);
+
+ while Present (Elmt) loop
+ Id := Node (Elmt);
+
+ -- If the underlying type of some formal or return type of this
+ -- entity is not available then skip this element.
+
+ if not Underlying_Types_Available (Id) then
+ Next_Elmt (Elmt);
+
+ -- Otherwise, create its extra formals and remove it from the
+ -- list of entities that require adding the extra formals.
+
+ else
+ -- In order to safely remove this element from the list,
+ -- temporarily remember this element, and move to the next
+ -- element.
+
+ Found_Elmt := Elmt;
+ Next_Elmt (Elmt);
+
+ -- Create the extra formals, and mark functions that return
+ -- by reference (not be done before if the underying return
+ -- type was previously unknown).
+
+ Create_Extra_Formals (Id);
+ Compute_Returns_By_Ref (Id);
+
+ Remove_Elmt (Entities_List, Found_Elmt);
+
+ -- For deferred entries and entry families, the expansion of
+ -- their entry declaration was deferred, and must be done
+ -- now (after adding their extra formals).
+
+ if Ekind (Id) in E_Entry | E_Entry_Family then
+ Expand_N_Entry_Declaration (Parent (Id),
+ Was_Deferred => True);
+ end if;
+ end if;
+ end loop;
+ end Check_Registered_Entities;
+
+ -- Start of processing for Add_Deferred_Extra_Params
+
+ begin
+ pragma Assert (Present (Underlying_Type (Typ)));
+
+ if Present (Entities_List) then
+ Check_Registered_Entities;
+ end if;
+
+ if Present (Calls_List) then
+ Check_Registered_Calls;
+ end if;
+
+ Remove (Types_List, Typ);
+ end Add_Deferred_Extra_Params;
+
+ --------------------------------
+ -- Has_Deferred_Extra_Formals --
+ --------------------------------
+
+ function Has_Deferred_Extra_Formals (Typ : Entity_Id) return Boolean is
+ begin
+ return Contains (Types_List, Typ);
+ end Has_Deferred_Extra_Formals;
+
+ --------------------------------------
+ -- Is_Deferred_Extra_Formals_Entity --
+ --------------------------------------
+
+ function Is_Deferred_Extra_Formals_Entity
+ (Id : Entity_Id) return Boolean is
+ begin
+ return Contains (Entities_List, Id);
+ end Is_Deferred_Extra_Formals_Entity;
+
+ ---------------------------------------
+ -- Is_Unsupported_Extra_Actuals_Call --
+ ---------------------------------------
+
+ -- Similarly to Is_Unsupported_Extra_Formals_Entity, we cannot
+ -- determine if the extra formals are needed when the underlying
+ -- type of some formal or result type is not available, and we are
+ -- compiling the body of a subprogram or package. However, for calls
+ -- we must also handle internal calls generated by the compiler as
+ -- part of compiling a package spec. For example, internal calls
+ -- performed in thunks of secondary dispatch table entries.
+ --
+ -- Example
+ -- -------
+ -- package P is
+ -- type T is tagged null record;
+ -- end;
+ --
+ -- limited with P;
+ -- package Q is
+ -- type Iface is interface;
+ -- procedure Prim (Self : Iface; Current : P.T) is abstract;
+ -- end;
+ --
+ -- limited with P;
+ -- with Q;
+ -- package R is
+ -- type Root is tagged null record;
+ -- type DT is new Root and Q.Iface with null record;
+ --
+ -- procedure Prim (Self : DT; Current : P.T);
+ -- end;
+ --
+ -- The initialization of the secondary dispatch table of tagged type
+ -- DT has an internally generated thunk that displaces the pointer to
+ -- the object and calls the primitive Prim (and the underlying type
+ -- of type T is not available).
+
+ function Is_Unsupported_Extra_Actuals_Call
+ (Call_Node : Node_Id; Id : Entity_Id) return Boolean
+ is
+ Comp_Unit : constant Entity_Id :=
+ Cunit_Entity (Get_Source_Unit (Call_Node));
+ begin
+ return not Underlying_Types_Available (Id)
+ and then Is_Compilation_Unit (Comp_Unit)
+ and then Ekind (Comp_Unit) in E_Package
+ | E_Package_Body
+ | E_Subprogram_Body;
+ end Is_Unsupported_Extra_Actuals_Call;
+
+ -----------------------------------------
+ -- Is_Unsupported_Extra_Formals_Entity --
+ -----------------------------------------
+
+ -- We cannot determine if the extra formals are needed when the
+ -- underlying type of some formal or result type is not available,
+ -- and we are compiling the body of a subprogram or package. The
+ -- scenery for this case is a package spec that has a limited_with_
+ -- clause on unit Q, and its body has no regular with-clause on Q
+ -- (AI05-0151-1/08).
+
+ function Is_Unsupported_Extra_Formals_Entity
+ (Id : Entity_Id) return Boolean
+ is
+ Comp_Unit : constant Entity_Id :=
+ Cunit_Entity (Get_Source_Unit (Id));
+ begin
+ return not Underlying_Types_Available (Id)
+ and then Is_Compilation_Unit (Comp_Unit)
+ and then Ekind (Comp_Unit) in E_Package_Body
+ | E_Subprogram_Body;
+ end Is_Unsupported_Extra_Formals_Entity;
+
+ --------------------------------------------
+ -- Register_Deferred_Extra_Formals_Entity --
+ --------------------------------------------
+
+ procedure Register_Deferred_Extra_Formals_Entity (Id : Entity_Id) is
+
+ procedure Register_Type (Typ : Entity_Id);
+ -- Register the given type in Types_List; for types visible though
+ -- limited_with_clauses, register their non-limited view.
+
+ -------------------
+ -- Register_Type --
+ -------------------
+
+ procedure Register_Type (Typ : Entity_Id) is
+ begin
+ -- Handle entities visible through limited_with_clauses
+
+ if Has_Non_Limited_View (Typ) then
+ Append_Unique_Elmt (Non_Limited_View (Typ), Types_List);
+ else
+ Append_Unique_Elmt (Typ, Types_List);
+ end if;
+ end Register_Type;
+
+ -- Local variables
+
+ Formal : Entity_Id;
+
+ -- Start of processing for Register_Deferred_Extra_Formals_Entity
+
+ begin
+ pragma Assert (Is_Subprogram_Or_Entry (Id)
+ or else Ekind (Id) in E_Subprogram_Type);
+
+ if not Is_Deferred_Extra_Formals_Entity (Id) then
+ if No (Types_List) then
+ Types_List := New_Elmt_List;
+ end if;
+
+ if No (Entities_List) then
+ Entities_List := New_Elmt_List;
+ end if;
+
+ -- Register all the types of the subprogram profile that are not
+ -- fully known.
+
+ Formal := First_Formal (Id);
+ while Present (Formal) loop
+
+ if No (Underlying_Type (Etype (Formal))) then
+ Register_Type (Etype (Formal));
+ end if;
+
+ Next_Formal (Formal);
+ end loop;
+
+ if Ekind (Id) in E_Function | E_Subprogram_Type
+ and then No (Underlying_Type (Etype (Id)))
+ then
+ Register_Type (Etype (Id));
+ end if;
+
+ -- Register this subprogram
+
+ Append_Elmt (Id, Entities_List);
+ end if;
+ end Register_Deferred_Extra_Formals_Entity;
+
+ ------------------------------------------
+ -- Register_Deferred_Extra_Formals_Call --
+ ------------------------------------------
+
+ procedure Register_Deferred_Extra_Formals_Call
+ (Call_Node : Node_Id;
+ Scope_Id : Entity_Id) is
+ begin
+ pragma Assert (Nkind (Call_Node) in N_Subprogram_Call
+ | N_Entry_Call_Statement);
+ if No (Calls_List) then
+ Calls_List := New_Elmt_List;
+ Calls_Scope_List := New_Elmt_List;
+ end if;
+
+ -- Avoid registering any call twice; this may occur in dispatching
+ -- calls with deferred extra actuals because Expand_Call_Helper
+ -- registers the call and invokes Expand_Dispatching_Call (which
+ -- tries again to register the expanded call).
+
+ if not Contains (Calls_List, Call_Node) then
+ Append_Elmt (Call_Node, Calls_List);
+ Append_Elmt (Scope_Id, Calls_Scope_List);
+ end if;
+ end Register_Deferred_Extra_Formals_Call;
+
+ --------------------------------
+ -- Underlying_Types_Available --
+ --------------------------------
+
+ function Underlying_Types_Available (E : Entity_Id) return Boolean is
+ Formal : Entity_Id;
+ Formal_Typ : Entity_Id;
+ Func_Typ : Entity_Id;
+
+ begin
+ -- If the extra formals are available, then the nonlimited view
+ -- of all the types referenced in the profile are available.
+
+ if Extra_Formals_Known (E) then
+ return True;
+ end if;
+
+ -- Check the return type
+
+ if Ekind (E) in E_Function | E_Subprogram_Type then
+ Func_Typ := Etype (E);
+
+ if Has_Non_Limited_View (Func_Typ) then
+ Func_Typ := Non_Limited_View (Func_Typ);
+ end if;
+
+ if No (Underlying_Type (Func_Typ)) then
+ return False;
+ end if;
+ end if;
+
+ -- Check the type of the formals
+
+ Formal := First_Formal (E);
+ while Present (Formal) loop
+ Formal_Typ := Etype (Formal);
+
+ if Has_Non_Limited_View (Formal_Typ) then
+ Formal_Typ := Non_Limited_View (Formal_Typ);
+ end if;
+
+ if No (Underlying_Type (Formal_Typ)) then
+ return False;
+ end if;
+
+ Next_Formal (Formal);
+ end loop;
+
+ return True;
+ end Underlying_Types_Available;
+
+ end Deferred_Extra_Formals_Support;
+
---------------------
-- Process_Formals --
---------------------
diff --git a/gcc/ada/sem_ch6.ads b/gcc/ada/sem_ch6.ads
index 7ebbcaa84ac..4ef5b654bb0 100644
--- a/gcc/ada/sem_ch6.ads
+++ b/gcc/ada/sem_ch6.ads
@@ -190,6 +190,14 @@ package Sem_Ch6 is
-- Use the subprogram specification in the body to retrieve the previous
-- subprogram declaration, if any.
+ procedure Freeze_Extra_Formals (E : Entity_Id);
+ -- Given a subprogram, subprogram type, or entry, flag E to indicate that
+ -- its extra formals (if any) are known (by setting Extra_Formals_Known).
+ -- This subprogram serves three purposes: (1) Document the places where
+ -- the extra formals are known, (2) Ensure that extra formals are added
+ -- only once, and (3) Provide a convenient place for setting a debugger
+ -- breakpoint to locate when extra formals are known.
+
function Fully_Conformant (New_Id, Old_Id : Entity_Id) return Boolean;
-- Determine whether two callable entities (subprograms, entries,
-- literals) are fully conformant (RM 6.3.1(17))
@@ -299,4 +307,156 @@ package Sem_Ch6 is
procedure Valid_Operator_Definition (Designator : Entity_Id);
-- Verify that an operator definition has the proper number of formals
+ ------------------------------------
+ -- Deferred_Extra_Formals_Support --
+ ------------------------------------
+
+ -- This package provides support for deferring the addition of extra
+ -- formals to subprograms, entries, and subprogram types; it also provides
+ -- support for deferring the addition of extra actuals to direct calls to
+ -- subprograms and entries, and indirect calls through subprogram types.
+ -- The addition of the extra formals and actuals is deferred until the
+ -- underlying type of all the parameters and result types of registered
+ -- subprograms, entries, and subprogram types is known.
+
+ -- Functional Description
+ -- ----------------------
+ --
+ -- When Create_Extra_Formals identifies that the underlying type of
+ -- some parameter or result type of an entity E is not available, E is
+ -- registered by this package, and the addition of its extra formals is
+ -- deferred. As part of this registration, the types of all the params
+ -- and result types of E with no underlying type are also registered.
+ --
+ -- When Expand_Call_Helper identifies that the underlying type of some
+ -- parameter or result type of a called entity is not available, the call
+ -- is registered by Register_Deferred_Extra_Formals_Call, and the addition
+ -- of its extra actuals is deferred.
+ --
+ -- When the full type declaration of some registered type T is analyzed,
+ -- the subprogram Add_Deferred_Extra_Params is invoked; this subprogram
+ -- does the following actions:
+ -- 1) Check all the registered entities (subprograms, entries, and
+ -- subprogram types); for each registered entity that has all its
+ -- underlying types available, call Create_Extra_Formals, and
+ -- unregister the entity.
+ -- 2) Check all the registered calls; for each registered call that
+ -- has available the underlying type of all the parameters and result
+ -- types of the called entity, call Create_Extra_Actuals, and
+ -- unregister the call.
+ -- 3) Unregister T.
+ --
+ -- Example 1
+ -- ---------
+ -- A package spec has a private type declaration T, and declarations of
+ -- expression functions and/or primitives with class-wide conditions
+ -- invoking primitives of type T before the full view of T is defined.
+ --
+ -- As part of processing the early freezing of the called subprograms
+ -- (and as part of processing the calls) the functions are registered as
+ -- subprograms with deferred extra formals, and the calls are registered
+ -- as calls with deferred extra actuals.
+ --
+ -- When the full type declaration of T is analyzed, extra formals are
+ -- added to all the registered subprograms, and extra actuals are added
+ -- to all the registered calls with deferred extra actuals.
+ --
+ -- Example 2
+ -- ---------
+ -- The specification of package P has a limited_with_clause on package Q,
+ -- and the type of the formals of subprograms defined in P are types
+ -- defined in Q.
+ --
+ -- When compiling the spec of P, similarly to the previous example,
+ -- subprograms with incomplete formals are registered as subprograms
+ -- with deferred extra formals; if the spec of P has calls to these
+ -- subprograms, then these calls are registered as calls with deferred
+ -- extra actuals. That is, when the analysis of package P completes,
+ -- deferred extra formals and actuals have not been added.
+ --
+ -- When another compilation unit is analyzed (including the body of
+ -- package P), and a regular with-clause on Q is processed, when the
+ -- full type declaration of deferred entities is analyzed, deferred
+ -- extra formals and deferred extra actuals are added.
+ --
+ -- This machinery relies on the GNAT Compilation Model; that is, when
+ -- we analyze the spec of P (for which we generally don't generate code),
+ -- it is safe to complete the compilation and still have entities with
+ -- deferred extra formals, and calls with deferred extra actuals.
+ --
+ -- The body package P generally has a regular with-clause on package Q.
+ -- Hence, when we compile the body of package P, the implicit dependence
+ -- on its package spec causes the analysis of the spec of P (thus
+ -- registering deferred entities), followed by the analysis of context
+ -- clauses in the body of P. When the regular with-clause on package Q
+ -- is analyzed, we add the extra formals and extra actuals to deferred
+ -- entities. Thus, the generated code will have all the needed formals.
+ --
+ -- The (still) unsupported case is when the body of package P does not
+ -- have a regular with-clause on package Q (AI05-0151-1/08). This case
+ -- is left documented in the front-end sources by means of calls to
+ -- the following subprograms: Is_Unsupported_Extra_Formals_Entity, and
+ -- Is_Unsupported_Extra_Actuals_Call.
+
+ package Deferred_Extra_Formals_Support is
+
+ procedure Add_Deferred_Extra_Params (Typ : Entity_Id);
+ -- Check all the registered subprograms, entries, and subprogram types
+ -- with deferred addition of their extra formals; if the underlying
+ -- types of all their formals is available then add their extra formals.
+ -- Check also all the registered calls with deferred addition of their
+ -- extra actuals; add their extra actuals if the underlying types of all
+ -- their parameters and result types are available. Finally unregister
+ -- Typ from the list of types used for the deferral of extra formals/
+ -- actuals.
+
+ procedure Register_Deferred_Extra_Formals_Entity (Id : Entity_Id);
+ -- Register the given subprogram, entry, or subprogram type to defer the
+ -- addition of its extra formals.
+
+ procedure Register_Deferred_Extra_Formals_Call
+ (Call_Node : Node_Id;
+ Scope_Id : Entity_Id);
+ -- Register the given call, performed from the given scope, to defer the
+ -- addition of its extra actuals.
+
+ function Has_Deferred_Extra_Formals (Typ : Entity_Id) return Boolean;
+ -- Return True if there some registered subprogram, subprogram type, or
+ -- entry with deferred extra formals that has some formal type or
+ -- result type of type Typ (i.e. which depends on the given type to
+ -- add its extra formals).
+
+ function Is_Deferred_Extra_Formals_Entity
+ (Id : Entity_Id) return Boolean;
+ -- Return True if Id is a subprogram, subprogram type, or entry that has
+ -- been registered to defer the addition of its extra formals.
+
+ function Is_Unsupported_Extra_Formals_Entity
+ (Id : Entity_Id) return Boolean;
+ -- Id is a subprogram, subprogram type, or entry. Return True if Id is
+ -- unsupported for deferring the addition of its extra formals; that is,
+ -- it is defined in a compilation unit that is a package body or a
+ -- subprogram body, and the underlying type of some of its parameters
+ -- or result type is not available.
+ --
+ -- The context for this case is an unsupported case of AI05-0151-1/08
+ -- that allows incomplete tagged types as parameter and result types.
+ -- More concretely, a type T is visible in a package spec through a
+ -- limited_with_clause, and the body of the package has no regular
+ -- with_clause. In such a case, the machinery for deferring the
+ -- addition of extra formals does not work because the underlying
+ -- type of the type is not seen during the compilation of the
+ -- package body.
+ --
+ -- The purpose of this function is to facilitate locating in the sources
+ -- the places where the front end performs the current (incomplete)
+ -- management of such case (to facilitate further work) ???
+
+ function Is_Unsupported_Extra_Actuals_Call
+ (Call_Node : Node_Id; Id : Entity_Id) return Boolean;
+ -- Same as previous function but applicable to a call to the given
+ -- entity Id.
+
+ end Deferred_Extra_Formals_Support;
+
end Sem_Ch6;
diff --git a/gcc/ada/sem_ch9.adb b/gcc/ada/sem_ch9.adb
index e32612e4cfb..bf387d35a65 100644
--- a/gcc/ada/sem_ch9.adb
+++ b/gcc/ada/sem_ch9.adb
@@ -1700,6 +1700,12 @@ package body Sem_Ch9 is
Process_Formals (Formals, N);
Create_Extra_Formals (Def_Id);
End_Scope;
+
+ -- If the entry has no formals, extra formals are definitely not
+ -- required.
+
+ else
+ Freeze_Extra_Formals (Def_Id);
end if;
if Ekind (Def_Id) = E_Entry then
diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
index 4c289c251f0..bdbfea86ce0 100644
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -21373,6 +21373,18 @@ package body Sem_Util is
return False;
end Is_Unchecked_Conversion_Instance;
+ ---------------------------------
+ -- Is_Unchecked_Union_Equality --
+ ---------------------------------
+
+ function Is_Unchecked_Union_Equality (Id : Entity_Id) return Boolean is
+ begin
+ return Ekind (Id) = E_Function
+ and then Present (First_Formal (Id))
+ and then Is_Unchecked_Union (Etype (First_Formal (Id)))
+ and then Id = TSS (Etype (First_Formal (Id)), TSS_Composite_Equality);
+ end Is_Unchecked_Union_Equality;
+
-------------------------------
-- Is_Universal_Numeric_Type --
-------------------------------
diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads
index efeafdae92e..b872180201e 100644
--- a/gcc/ada/sem_util.ads
+++ b/gcc/ada/sem_util.ads
@@ -1578,7 +1578,7 @@ package Sem_Util is
-- underlying type).
function Has_Suffix (E : Entity_Id; Suffix : Character) return Boolean;
- -- Returns true if the last character of E is Suffix. Used in Assertions.
+ -- Returns true if the last character of E is Suffix.
function Has_Tagged_Component (Typ : Entity_Id) return Boolean;
-- Returns True if Typ is a composite type (array or record) that is either
@@ -2449,6 +2449,10 @@ package Sem_Util is
-- Determine whether an arbitrary entity denotes an instance of function
-- Ada.Unchecked_Conversion.
+ function Is_Unchecked_Union_Equality (Id : Entity_Id) return Boolean;
+ -- Determine whether an arbitrary entity denotes the predefined equality
+ -- function of an Unchecked_Union type (see Build_Variant_Record_Equality).
+
function Is_Unconstrained_Or_Tagged_Item (Item : Entity_Id) return Boolean;
-- Subsidiary to Collect_Subprogram_Inputs_Outputs and the analysis of
-- pragma Depends. Determine whether the type of dependency item Item is
--
2.43.0
