-- 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
-- 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.
-- 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,
-- 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
-- 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
-- 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)
-- Overridden_Operation
-- Linker_Section_Pragma
-- Contract
+ -- Extra_Formals
+ -- Extra_Formals_Known
-- Import_Pragma
-- LSP_Subprogram
-- SPARK_Pragma
-- 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)
-- Last_Entity
-- Scope_Depth_Value
-- Extra_Formals
+ -- Extra_Formals_Known
-- Anonymous_Collections
-- Contract
-- SPARK_Pragma
-- Extra_Accessibility_Of_Result
-- Directly_Designated_Type
-- Extra_Formals
+ -- Extra_Formals_Known
-- Access_Subprogram_Wrapper
-- First_Formal (synth)
-- First_Formal_With_Extras (synth)
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);
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);
-- 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;
(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
-----------------
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
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
-- 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));
end if;
end Expand_Call;
- ------------------------
- -- 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.
+ --------------------------
+ -- Create_Extra_Actuals --
+ --------------------------
- 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;
-- 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 --
--------------------------------------
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.
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);
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 --
----------------------
end if;
end Add_Extra_Actual;
- ------------------------------------
- -- Add_View_Conversion_Invariants --
- ------------------------------------
-
- procedure Add_View_Conversion_Invariants
- (Formal : Entity_Id;
- Actual : Node_Id)
- is
- Arg : Entity_Id;
- Curr_Typ : Entity_Id;
- Inv_Checks : List_Id;
- Par_Typ : Entity_Id;
+ -- Local variables
- begin
- Inv_Checks := No_List;
+ use Deferred_Extra_Formals_Support;
- -- Extract the argument from a potentially nested set of view
- -- conversions.
+ Actual : Node_Id;
+ Formal : Entity_Id;
+ Param_Count : Positive;
+ Subp : constant Entity_Id := Get_Called_Entity (Call_Node);
- Arg := Actual;
- while Nkind (Arg) = N_Type_Conversion loop
- Arg := Expression (Arg);
- end loop;
+ -- Start of processing for Create_Extra_Actuals
- -- Move up the derivation chain starting with the type of the formal
- -- parameter down to the type of the actual object.
+ begin
+ -- Special case: Thunks must not compute the extra actuals; they must
+ -- just propagate their extra actuals to the target primitive.
- Curr_Typ := Empty;
- Par_Typ := Etype (Arg);
- while Par_Typ /= Etype (Formal) and Par_Typ /= Curr_Typ loop
- Curr_Typ := Par_Typ;
+ if Is_Thunk (Current_Scope)
+ and then Thunk_Entity (Current_Scope) = Subp
+ then
+ declare
+ Target_Formal : Entity_Id;
+ Thunk_Formal : Entity_Id;
- if Has_Invariants (Curr_Typ)
- and then Present (Invariant_Procedure (Curr_Typ))
- then
- -- Verify the invariant of the current type. Generate:
+ begin
+ pragma Assert (Extra_Formals_Known (Subp)
+ and then Extra_Formals_Match_OK (Current_Scope, Subp));
- -- <Curr_Typ>Invariant (Curr_Typ (Arg));
+ 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);
- Prepend_New_To (Inv_Checks,
- Make_Procedure_Call_Statement (Loc,
- Name =>
- New_Occurrence_Of
- (Invariant_Procedure (Curr_Typ), Loc),
- Parameter_Associations => New_List (
- Make_Type_Conversion (Loc,
- Subtype_Mark => New_Occurrence_Of (Curr_Typ, Loc),
- Expression => New_Copy_Tree (Arg)))));
- end if;
+ Target_Formal := Extra_Formal (Target_Formal);
+ Thunk_Formal := Extra_Formal (Thunk_Formal);
+ end loop;
- Par_Typ := Base_Type (Etype (Curr_Typ));
- end loop;
+ while Is_Non_Empty_List (Extra_Actuals) loop
+ Add_Actual_Parameter (Remove_Head (Extra_Actuals));
+ end loop;
- -- If the node is a function call the generated tests have been
- -- already handled in Insert_Post_Call_Actions.
+ return;
+ end;
+ end if;
- if not Is_Empty_List (Inv_Checks)
- and then Nkind (Call_Node) = N_Procedure_Call_Statement
- then
- Insert_Actions_After (Call_Node, Inv_Checks);
- end if;
- end Add_View_Conversion_Invariants;
+ pragma Assert (Extra_Formals_Known (Subp)
+ or else Is_Unsupported_Extra_Formals_Entity (Subp));
- -----------------------------
- -- Can_Fold_Predicate_Call --
- -----------------------------
+ -- 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.
- function Can_Fold_Predicate_Call (P : Entity_Id) return Boolean is
- Actual : Node_Id;
+ Formal := First_Formal (Subp);
+ Actual := First_Actual (Call_Node);
+ Param_Count := 1;
+ while Present (Formal) loop
+ -- Prepare to examine current entry
- function Augments_Other_Dynamic_Predicate (DP_Aspect_Spec : Node_Id)
- return Boolean;
- -- Given a Dynamic_Predicate aspect aspecification for a
- -- discrete type, returns True iff another DP specification
- -- applies (indirectly, via a subtype type or a derived type)
- -- to the same entity that this aspect spec applies to.
+ Prev := Actual;
- function May_Fold (N : Node_Id) return Traverse_Result;
- -- The predicate expression is foldable if it only contains operators
- -- and literals. During this check, we also replace occurrences of
- -- the formal of the constructed predicate function with the static
- -- value of the actual. This is done on a copy of the analyzed
- -- expression for the predicate.
+ -- 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.
- --------------------------------------
- -- Augments_Other_Dynamic_Predicate --
+ 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 --
+ ------------------------------------
+
+ procedure Add_View_Conversion_Invariants
+ (Formal : Entity_Id;
+ Actual : Node_Id)
+ is
+ Arg : Entity_Id;
+ Curr_Typ : Entity_Id;
+ Inv_Checks : List_Id;
+ Par_Typ : Entity_Id;
+
+ begin
+ Inv_Checks := No_List;
+
+ -- Extract the argument from a potentially nested set of view
+ -- conversions.
+
+ Arg := Actual;
+ while Nkind (Arg) = N_Type_Conversion loop
+ Arg := Expression (Arg);
+ end loop;
+
+ -- Move up the derivation chain starting with the type of the formal
+ -- parameter down to the type of the actual object.
+
+ Curr_Typ := Empty;
+ Par_Typ := Etype (Arg);
+ while Par_Typ /= Etype (Formal) and Par_Typ /= Curr_Typ loop
+ Curr_Typ := Par_Typ;
+
+ if Has_Invariants (Curr_Typ)
+ and then Present (Invariant_Procedure (Curr_Typ))
+ then
+ -- Verify the invariant of the current type. Generate:
+
+ -- <Curr_Typ>Invariant (Curr_Typ (Arg));
+
+ Prepend_New_To (Inv_Checks,
+ Make_Procedure_Call_Statement (Loc,
+ Name =>
+ New_Occurrence_Of
+ (Invariant_Procedure (Curr_Typ), Loc),
+ Parameter_Associations => New_List (
+ Make_Type_Conversion (Loc,
+ Subtype_Mark => New_Occurrence_Of (Curr_Typ, Loc),
+ Expression => New_Copy_Tree (Arg)))));
+ end if;
+
+ Par_Typ := Base_Type (Etype (Curr_Typ));
+ end loop;
+
+ -- If the node is a function call the generated tests have been
+ -- already handled in Insert_Post_Call_Actions.
+
+ if not Is_Empty_List (Inv_Checks)
+ and then Nkind (Call_Node) = N_Procedure_Call_Statement
+ then
+ Insert_Actions_After (Call_Node, Inv_Checks);
+ end if;
+ end Add_View_Conversion_Invariants;
+
+ -----------------------------
+ -- Can_Fold_Predicate_Call --
+ -----------------------------
+
+ function Can_Fold_Predicate_Call (P : Entity_Id) return Boolean is
+ Actual : Node_Id;
+
+ function Augments_Other_Dynamic_Predicate (DP_Aspect_Spec : Node_Id)
+ return Boolean;
+ -- Given a Dynamic_Predicate aspect aspecification for a
+ -- discrete type, returns True iff another DP specification
+ -- applies (indirectly, via a subtype type or a derived type)
+ -- to the same entity that this aspect spec applies to.
+
+ function May_Fold (N : Node_Id) return Traverse_Result;
+ -- The predicate expression is foldable if it only contains operators
+ -- and literals. During this check, we also replace occurrences of
+ -- the formal of the constructed predicate function with the static
+ -- value of the actual. This is done on a copy of the analyzed
+ -- expression for the predicate.
+
+ --------------------------------------
+ -- Augments_Other_Dynamic_Predicate --
--------------------------------------
function Augments_Other_Dynamic_Predicate (DP_Aspect_Spec : Node_Id)
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
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
Ren_Decl : Node_Id;
Ren_Root : Entity_Id := Subp;
- begin
- -- This may be a chain of renamings, find the root
-
- if Present (Alias (Ren_Root)) then
- Ren_Root := Alias (Ren_Root);
- end if;
-
- if Present (Parent (Ren_Root))
- and then Present (Original_Node (Parent (Parent (Ren_Root))))
- then
- Ren_Decl := Original_Node (Parent (Parent (Ren_Root)));
-
- if Nkind (Ren_Decl) = N_Subprogram_Renaming_Declaration then
- Rewrite (Call_Node,
- Make_Entry_Call_Statement (Loc,
- Name =>
- New_Copy_Tree (Name (Ren_Decl)),
- Parameter_Associations =>
- New_Copy_List_Tree
- (Parameter_Associations (Call_Node))));
-
- return;
- end if;
- end if;
- end;
- end if;
-
- -- If this is a call to a predicate function, try to constant fold it
-
- if Nkind (Call_Node) = N_Function_Call
- and then Is_Entity_Name (Name (Call_Node))
- and then Is_Predicate_Function (Subp)
- and then Can_Fold_Predicate_Call (Subp)
- then
- return;
- end if;
-
- -- First step, compute extra actuals, corresponding to any Extra_Formals
- -- 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???)
-
- -- Special case: Thunks must not compute the extra actuals; they must
- -- just propagate to the target primitive their extra actuals.
-
- if Is_Thunk (Current_Scope)
- and then Thunk_Entity (Current_Scope) = Subp
- and then Present (Extra_Formals (Subp))
- then
- pragma Assert (Extra_Formals_Match_OK (Current_Scope, Subp));
-
- declare
- Target_Formal : Entity_Id;
- Thunk_Formal : Entity_Id;
-
- 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);
-
- 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;
-
- -- 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;
- end if;
-
- Formal := First_Formal (Subp);
- Actual := First_Actual (Call_Node);
- Param_Count := 1;
- while Present (Formal) loop
- -- Prepare to examine current entry
-
- Prev := Actual;
-
- -- Ada 2005 (AI-251): Check if any formal is a class-wide interface
- -- to expand it in a further round.
-
- CW_Interface_Formals_Present :=
- 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.
+ begin
+ -- This may be a chain of renamings, find the root
- 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));
+ if Present (Alias (Ren_Root)) then
+ Ren_Root := Alias (Ren_Root);
+ end if;
- 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;
+ if Present (Parent (Ren_Root))
+ and then Present (Original_Node (Parent (Parent (Ren_Root))))
+ then
+ Ren_Decl := Original_Node (Parent (Parent (Ren_Root)));
+
+ if Nkind (Ren_Decl) = N_Subprogram_Renaming_Declaration then
+ Rewrite (Call_Node,
+ Make_Entry_Call_Statement (Loc,
+ Name =>
+ New_Copy_Tree (Name (Ren_Decl)),
+ Parameter_Associations =>
+ New_Copy_List_Tree
+ (Parameter_Associations (Call_Node))));
+
+ return;
+ end if;
end if;
- end if;
+ end;
+ end if;
- -- Create possible extra actual for accessibility level
+ -- Ensure that the called subprogram has all its formals; extra formals
+ -- of init procs were added when they were built.
- if Present (Extra_Accessibility (Formal)) then
- -- Ada 2005 (AI-251): Thunks must propagate the extra actuals of
- -- accessibility levels.
+ if not Extra_Formals_Known (Subp) then
+ Create_Extra_Formals (Subp);
- if Is_Thunk (Current_Scope) then
- declare
- Parm_Ent : Entity_Id;
+ -- 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.
- begin
- if Is_Controlling_Actual (Actual) then
+ if not Extra_Formals_Known (Subp) then
+ declare
+ Scop_Id : Entity_Id := Current_Scope;
- -- Find the corresponding actual of the thunk
+ begin
+ -- Locate the enclosing subprogram or entry since it is
+ -- required to register this deferred call.
- Parm_Ent := First_Entity (Current_Scope);
- for J in 2 .. Param_Count loop
- Next_Entity (Parm_Ent);
- end loop;
+ 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;
- -- Handle unchecked conversion of access types generated
- -- in thunks (cf. Expand_Interface_Thunk).
+ 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);
- elsif Is_Access_Type (Etype (Actual))
- and then Nkind (Actual) = N_Unchecked_Type_Conversion
- then
- Parm_Ent := Entity (Expression (Actual));
+ Defer_Extra_Actuals := True;
+ end;
+ end if;
+ end if;
- else pragma Assert (Is_Entity_Name (Actual));
- Parm_Ent := Entity (Actual);
- end if;
+ pragma Assert (Extra_Formals_Known (Subp)
+ or else Is_Deferred_Extra_Formals_Entity (Subp)
+ or else Is_Unsupported_Extra_Formals_Entity (Subp));
- Add_Extra_Actual
- (Expr => Accessibility_Level
- (Expr => Parm_Ent,
- Level => Dynamic_Level,
- Allow_Alt_Model => False),
- EF => Extra_Accessibility (Formal));
- end;
+ -- If this is a call to a predicate function, try to constant fold it
- -- Conditional expressions
+ if Nkind (Call_Node) = N_Function_Call
+ and then Is_Entity_Name (Name (Call_Node))
+ and then Is_Predicate_Function (Subp)
+ and then Can_Fold_Predicate_Call (Subp)
+ then
+ return;
+ end if;
- 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);
+ -- First step, compute extra actuals, corresponding to any Extra_Formals
+ -- 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.
- -- Internal constant generated to remove side effects (normally
- -- from the expansion of dispatching calls).
+ -- 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???)
- -- First verify the actual is internal
+ -- Special case: Thunks must not compute the extra actuals; they must
+ -- just propagate their extra actuals to the target primitive (this
+ -- propagation is performed by Create_Extra_Actuals).
- elsif not Comes_From_Source (Prev)
- and then not Is_Rewrite_Substitution (Prev)
+ 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
+ Create_Extra_Actuals (N);
- -- Next check that the actual is a constant
+ -- Mark the call as an expanded build-in-place call; required
+ -- to avoid adding the extra formals twice.
- 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.
+ if Nkind (Call_Node) = N_Function_Call then
+ Set_Is_Expanded_Build_In_Place_Call (Call_Node);
+ end if;
- declare
- Ent : Entity_Id := Entity (Prev);
+ Expand_Actuals (Call_Node, Subp, Post_Call);
- begin
- -- Handle deferred constants
+ 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;
- if Present (Full_View (Ent)) then
- Ent := Full_View (Ent);
- end if;
+ Formal := First_Formal (Subp);
+ Actual := First_Actual (Call_Node);
+ Param_Count := 1;
+ while Present (Formal) loop
+ -- Prepare to examine current entry
- Add_Extra_Actual
- (Expr => Accessibility_Level
- (Expr => Expression (Parent (Ent)),
- Level => Dynamic_Level,
- Allow_Alt_Model => False),
- EF => Extra_Accessibility (Formal));
- end;
+ Prev := Actual;
- -- Normal case
+ -- Ada 2005 (AI-251): Check if any formal is a class-wide interface
+ -- to expand it in a further round.
- else
- Add_Extra_Actual
- (Expr => Accessibility_Level
- (Expr => Prev,
- Level => Dynamic_Level,
- Allow_Alt_Model => False),
- EF => Extra_Accessibility (Formal));
- end if;
- end if;
+ CW_Interface_Formals_Present :=
+ CW_Interface_Formals_Present
+ or else Is_Class_Wide_Interface_Type (Etype (Formal));
-- 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
-- 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
then
null;
- -- During that loop we gathered the extra actuals (the ones that
- -- correspond to Extra_Formals), so now they can be appended.
-
- 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 not Defer_Extra_Actuals then
+ Create_Extra_Formals (Subp);
- 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
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;
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;
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;
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;
=>
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
+ pragma Assert (Check_BIP_Actuals (Call_Node, Subp));
- else
- Subp := Entity (Name (Call_Node));
- end if;
+ -- Build-in-place function calls return their result by
+ -- reference.
- pragma Assert (Check_BIP_Actuals (Call_Node, Subp));
+ pragma Assert (not Is_Build_In_Place_Function (Subp)
+ or else Returns_By_Ref (Subp));
end;
-- Skip generic bodies
-- 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
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;
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);
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:
-- 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
-- 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;
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
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;
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
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);
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 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);
-
- 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 Extra_Formals_Known (Subp) then
+ Create_Extra_Formals (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;
+ -- Extra formals were previously deferred
- 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;
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
Discard_Node (IP_Body);
Set_Init_Proc (Typ, IP);
+ Mutate_Ekind (IP, E_Procedure);
+ Freeze_Extra_Formals (IP);
end;
end if;
Discard_Node (IP_Body);
Set_Init_Proc (Typ, IP);
+ Mutate_Ekind (IP, E_Procedure);
+ Freeze_Extra_Formals (IP);
end;
end if;
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;
-- Local variables
+ use Deferred_Extra_Formals_Support;
+
F : Entity_Id;
Retype : Entity_Id;
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)
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
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
Extra_Constrained,
Extra_Formal,
Extra_Formals,
+ Extra_Formals_Known,
Finalization_Collection,
Finalization_Master_Node,
Finalize_Storage_Only,
(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),
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),
(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),
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 =>
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;
-- 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
-----------------------------------
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;
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)
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;
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;
-- 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
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));
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 --
---------------------------------
-- 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
-- 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;
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
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
= 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
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:
--
or else (Present (Alias_Subp)
and then Has_Foreign_Convention (Alias_Subp))
then
+ Freeze_Extra_Formals (E);
return;
end if;
-- 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.
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"));
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));
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;
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 --
----------------------
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;
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 --
---------------------
-- 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))
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;
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
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 --
-------------------------------
-- 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
-- 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
projects / thirdparty / gcc.git / commitdiff
