Google Git
Sign in
gnu / gcc / refs/tags/basepoints/gcc-13 / . / gcc / ada / exp_ch6.adb
blob: 24476194337a01eb03f9949aa42dc2953077319b [file] [log] [blame]
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- E X P _ C H 6 --
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2022, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING3. If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
with Atree; use Atree;
with Aspects; use Aspects;
with Checks; use Checks;
with Contracts; use Contracts;
with Debug; use Debug;
with Einfo; use Einfo;
with Einfo.Entities; use Einfo.Entities;
with Einfo.Utils; use Einfo.Utils;
with Errout; use Errout;
with Elists; use Elists;
with Expander; use Expander;
with Exp_Aggr; use Exp_Aggr;
with Exp_Atag; use Exp_Atag;
with Exp_Ch3; use Exp_Ch3;
with Exp_Ch7; use Exp_Ch7;
with Exp_Ch9; use Exp_Ch9;
with Exp_Dbug; use Exp_Dbug;
with Exp_Disp; use Exp_Disp;
with Exp_Dist; use Exp_Dist;
with Exp_Intr; use Exp_Intr;
with Exp_Pakd; use Exp_Pakd;
with Exp_Tss; use Exp_Tss;
with Exp_Util; use Exp_Util;
with Freeze; use Freeze;
with Inline; use Inline;
with Itypes; use Itypes;
with Lib; use Lib;
with Namet; use Namet;
with Nlists; use Nlists;
with Nmake; use Nmake;
with Opt; use Opt;
with Restrict; use Restrict;
with Rident; use Rident;
with Rtsfind; use Rtsfind;
with Sem; use Sem;
with Sem_Aux; use Sem_Aux;
with Sem_Ch6; use Sem_Ch6;
with Sem_Ch8; use Sem_Ch8;
with Sem_Ch13; use Sem_Ch13;
with Sem_Dim; use Sem_Dim;
with Sem_Disp; use Sem_Disp;
with Sem_Dist; use Sem_Dist;
with Sem_Eval; use Sem_Eval;
with Sem_Mech; use Sem_Mech;
with Sem_Res; use Sem_Res;
with Sem_SCIL; use Sem_SCIL;
with Sem_Util; use Sem_Util;
with Sinfo; use Sinfo;
with Sinfo.Nodes; use Sinfo.Nodes;
with Sinfo.Utils; use Sinfo.Utils;
with Sinput; use Sinput;
with Snames; use Snames;
with Stand; use Stand;
with Stringt; use Stringt;
with Tbuild; use Tbuild;
with Uintp; use Uintp;
with Validsw; use Validsw;
package body Exp_Ch6 is
-- Suffix for BIP formals
BIP_Alloc_Suffix : constant String := "BIPalloc";
BIP_Storage_Pool_Suffix : constant String := "BIPstoragepool";
BIP_Finalization_Master_Suffix : constant String := "BIPfinalizationmaster";
BIP_Task_Master_Suffix : constant String := "BIPtaskmaster";
BIP_Activation_Chain_Suffix : constant String := "BIPactivationchain";
BIP_Object_Access_Suffix : constant String := "BIPaccess";
-----------------------
-- Local Subprograms --
-----------------------
procedure Add_Access_Actual_To_Build_In_Place_Call
(Function_Call : Node_Id;
Function_Id : Entity_Id;
Return_Object : Node_Id;
Is_Access : Boolean := False);
-- Ada 2005 (AI-318-02): Apply the Unrestricted_Access attribute to the
-- object name given by Return_Object and add the attribute to the end of
-- the actual parameter list associated with the build-in-place function
-- call denoted by Function_Call. However, if Is_Access is True, then
-- Return_Object is already an access expression, in which case it's passed
-- along directly to the build-in-place function. Finally, if Return_Object
-- is empty, then pass a null literal as the actual.
procedure Add_Unconstrained_Actuals_To_Build_In_Place_Call
(Function_Call : Node_Id;
Function_Id : Entity_Id;
Alloc_Form : BIP_Allocation_Form := Unspecified;
Alloc_Form_Exp : Node_Id := Empty;
Pool_Actual : Node_Id := Make_Null (No_Location));
-- Ada 2005 (AI-318-02): Add the actuals needed for a build-in-place
-- function call that returns a caller-unknown-size result (BIP_Alloc_Form
-- and BIP_Storage_Pool). If Alloc_Form_Exp is present, then use it,
-- otherwise pass a literal corresponding to the Alloc_Form parameter
-- (which must not be Unspecified in that case). Pool_Actual is the
-- parameter to pass to BIP_Storage_Pool.
procedure Add_Finalization_Master_Actual_To_Build_In_Place_Call
(Func_Call : Node_Id;
Func_Id : Entity_Id;
Ptr_Typ : Entity_Id := Empty;
Master_Exp : Node_Id := Empty);
-- Ada 2005 (AI-318-02): If the result type of a build-in-place call needs
-- finalization actions, add an actual parameter which is a pointer to the
-- finalization master of the caller. If Master_Exp is not Empty, then that
-- will be passed as the actual. Otherwise, if Ptr_Typ is left Empty, this
-- will result in an automatic "null" value for the actual.
procedure Add_Task_Actuals_To_Build_In_Place_Call
(Function_Call : Node_Id;
Function_Id : Entity_Id;
Master_Actual : Node_Id;
Chain : Node_Id := Empty);
-- Ada 2005 (AI-318-02): For a build-in-place call, if the result type
-- contains tasks, add two actual parameters: the master, and a pointer to
-- the caller's activation chain. Master_Actual is the actual parameter
-- expression to pass for the master. In most cases, this is the current
-- master (_master). The two exceptions are: If the function call is the
-- initialization expression for an allocator, we pass the master of the
-- access type. If the function call is the initialization expression for a
-- return object, we pass along the master passed in by the caller. In most
-- contexts, the activation chain to pass is the local one, which is
-- indicated by No (Chain). However, in an allocator, the caller passes in
-- the activation Chain. Note: Master_Actual can be Empty, but only if
-- there are no tasks.
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
-- than the level of the master enclosing the function. Always generate the
-- check when the type of the return expression is class-wide, when it's a
-- type conversion, or when it's a formal parameter. Otherwise suppress the
-- check in the case where the return expression has a specific type whose
-- level is known not to be statically deeper than the result type of the
-- function.
function Caller_Known_Size
(Func_Call : Node_Id;
Result_Subt : Entity_Id) return Boolean;
-- True if result subtype is definite, or has a size that does not require
-- secondary stack usage (i.e. no variant part or components whose type
-- depends on discriminants). In particular, untagged types with only
-- access discriminants do not require secondary stack use. Note we must
-- always use the secondary stack for dispatching-on-result calls.
function Check_BIP_Actuals
(Subp_Call : Node_Id;
Subp_Id : Entity_Id) return Boolean;
-- Given a subprogram call to the given subprogram return True if the
-- names of BIP extra actual and formal parameters match.
function Check_Number_Of_Actuals
(Subp_Call : Node_Id;
Subp_Id : Entity_Id) return Boolean;
-- Given a subprogram call to the given subprogram return True if the
-- number of actual parameters (including extra actuals) is correct.
procedure Check_Overriding_Operation (Subp : Entity_Id);
-- Subp is a dispatching operation. Check whether it may override an
-- inherited private operation, in which case its DT entry is that of
-- the hidden operation, not the one it may have received earlier.
-- This must be done before emitting the code to set the corresponding
-- DT to the address of the subprogram. The actual placement of Subp in
-- the proper place in the list of primitive operations is done in
-- Declare_Inherited_Private_Subprograms, which also has to deal with
-- implicit operations. This duplication is unavoidable for now???
procedure Detect_Infinite_Recursion (N : Node_Id; Spec : Entity_Id);
-- This procedure is called only if the subprogram body N, whose spec
-- has the given entity Spec, contains a parameterless recursive call.
-- It attempts to generate runtime code to detect if this a case of
-- infinite recursion.
--
-- The body is scanned to determine dependencies. If the only external
-- dependencies are on a small set of scalar variables, then the values
-- of these variables are captured on entry to the subprogram, and if
-- the values are not changed for the call, we know immediately that
-- we have an infinite recursion.
procedure Expand_Actuals
(N : Node_Id;
Subp : Entity_Id;
Post_Call : out List_Id);
-- Return a list of actions to take place after the call in Post_Call. The
-- call will later be rewritten as an Expression_With_Actions, with the
-- Post_Call actions inserted, and the call inside.
--
-- For each actual of an in-out or out parameter which is a numeric (view)
-- conversion of the form T (A), where A denotes a variable, we insert the
-- declaration:
--
-- Temp : T[ := T (A)];
--
-- prior to the call. Then we replace the actual with a reference to Temp,
-- and append the assignment:
--
-- A := TypeA (Temp);
--
-- after the call. Here TypeA is the actual type of variable A. For out
-- parameters, the initial declaration has no expression. If A is not an
-- entity name, we generate instead:
--
-- Var : TypeA renames A;
-- Temp : T := Var; -- omitting expression for out parameter.
-- ...
-- Var := TypeA (Temp);
--
-- For other in-out parameters, we emit the required constraint checks
-- before and/or after the call.
--
-- For all parameter modes, actuals that denote components and slices of
-- packed arrays are expanded into suitable temporaries.
--
-- For nonscalar objects that are possibly unaligned, add call by copy code
-- (copy in for IN and IN OUT, copy out for OUT and IN OUT).
--
-- For OUT and IN OUT parameters, add predicate checks after the call
-- based on the predicates of the actual type.
procedure Expand_Call_Helper (N : Node_Id; Post_Call : out List_Id);
-- Does the main work of Expand_Call. Post_Call is as for Expand_Actuals.
procedure Expand_Ctrl_Function_Call (N : Node_Id);
-- N is a function call which returns a controlled object. Transform the
-- call into a temporary which retrieves the returned object from the
-- secondary stack using 'reference.
procedure Expand_Non_Function_Return (N : Node_Id);
-- Expand a simple return statement found in a procedure body, entry body,
-- accept statement, or an extended return statement. Note that all non-
-- function returns are simple return statements.
function Expand_Protected_Object_Reference
(N : Node_Id;
Scop : Entity_Id) return Node_Id;
procedure Expand_Protected_Subprogram_Call
(N : Node_Id;
Subp : Entity_Id;
Scop : Entity_Id);
-- A call to a protected subprogram within the protected object may appear
-- as a regular call. The list of actuals must be expanded to contain a
-- reference to the object itself, and the call becomes a call to the
-- corresponding protected subprogram.
procedure Expand_Simple_Function_Return (N : Node_Id);
-- Expand simple return from function. In the case where we are returning
-- from a function body this is called by Expand_N_Simple_Return_Statement.
function Has_BIP_Extra_Formal
(E : Entity_Id;
Kind : BIP_Formal_Kind) return Boolean;
-- Given a frozen subprogram, subprogram type, entry or entry family,
-- return True if E has the BIP extra formal associated with Kind. It must
-- be invoked with a frozen entity or a subprogram type of a dispatching
-- call since we can only rely on the availability of the extra formals
-- on these entities.
procedure Insert_Post_Call_Actions (N : Node_Id; Post_Call : List_Id);
-- Insert the Post_Call list previously produced by routine Expand_Actuals
-- or Expand_Call_Helper into the tree.
procedure Replace_Renaming_Declaration_Id
(New_Decl : Node_Id;
Orig_Decl : Node_Id);
-- Replace the internal identifier of the new renaming declaration New_Decl
-- with the identifier of its original declaration Orig_Decl exchanging the
-- entities containing their defining identifiers to ensure the correct
-- replacement of the object declaration by the object renaming declaration
-- to avoid homograph conflicts (since the object declaration's defining
-- identifier was already entered in the current scope). The Next_Entity
-- links of the two entities are also swapped since the entities are part
-- of the return scope's entity list and the list structure would otherwise
-- be corrupted. The homonym chain is preserved as well.
procedure Rewrite_Function_Call_For_C (N : Node_Id);
-- When generating C code, replace a call to a function that returns an
-- array into the generated procedure with an additional out parameter.
procedure Set_Enclosing_Sec_Stack_Return (N : Node_Id);
-- N is a return statement for a function that returns its result on the
-- secondary stack. This sets the Sec_Stack_Needed_For_Return flag on the
-- function and all blocks and loops that the return statement is jumping
-- out of. This ensures that the secondary stack is not released; otherwise
-- the function result would be reclaimed before returning to the caller.
procedure Warn_BIP (Func_Call : Node_Id);
-- Give a warning on a build-in-place function call if the -gnatd_B switch
-- was given.
----------------------------------------------
-- Add_Access_Actual_To_Build_In_Place_Call --
----------------------------------------------
procedure Add_Access_Actual_To_Build_In_Place_Call
(Function_Call : Node_Id;
Function_Id : Entity_Id;
Return_Object : Node_Id;
Is_Access : Boolean := False)
is
Loc : constant Source_Ptr := Sloc (Function_Call);
Obj_Address : Node_Id;
Obj_Acc_Formal : Entity_Id;
begin
-- Locate the implicit access parameter in the called function
Obj_Acc_Formal := Build_In_Place_Formal (Function_Id, BIP_Object_Access);
-- If no return object is provided, then pass null
if not Present (Return_Object) then
Obj_Address := Make_Null (Loc);
Set_Parent (Obj_Address, Function_Call);
-- If Return_Object is already an expression of an access type, then use
-- it directly, since it must be an access value denoting the return
-- object, and couldn't possibly be the return object itself.
elsif Is_Access then
Obj_Address := Return_Object;
Set_Parent (Obj_Address, Function_Call);
-- Apply Unrestricted_Access to caller's return object
else
Obj_Address :=
Make_Attribute_Reference (Loc,
Prefix => Return_Object,
Attribute_Name => Name_Unrestricted_Access);
Set_Parent (Return_Object, Obj_Address);
Set_Parent (Obj_Address, Function_Call);
end if;
Analyze_And_Resolve (Obj_Address, Etype (Obj_Acc_Formal));
-- Build the parameter association for the new actual and add it to the
-- end of the function's actuals.
Add_Extra_Actual_To_Call (Function_Call, Obj_Acc_Formal, Obj_Address);
end Add_Access_Actual_To_Build_In_Place_Call;
------------------------------------------------------
-- Add_Unconstrained_Actuals_To_Build_In_Place_Call --
------------------------------------------------------
procedure Add_Unconstrained_Actuals_To_Build_In_Place_Call
(Function_Call : Node_Id;
Function_Id : Entity_Id;
Alloc_Form : BIP_Allocation_Form := Unspecified;
Alloc_Form_Exp : Node_Id := Empty;
Pool_Actual : Node_Id := Make_Null (No_Location))
is
Loc : constant Source_Ptr := Sloc (Function_Call);
Alloc_Form_Actual : Node_Id;
Alloc_Form_Formal : Node_Id;
Pool_Formal : Node_Id;
begin
-- Nothing to do when the size of the object is known, and the caller is
-- in charge of allocating it, and the callee doesn't unconditionally
-- require an allocation form (such as due to having a tagged result).
if not Needs_BIP_Alloc_Form (Function_Id) then
return;
end if;
-- Locate the implicit allocation form parameter in the called function.
-- Maybe it would be better for each implicit formal of a build-in-place
-- function to have a flag or a Uint attribute to identify it. ???
Alloc_Form_Formal := Build_In_Place_Formal (Function_Id, BIP_Alloc_Form);
if Present (Alloc_Form_Exp) then
pragma Assert (Alloc_Form = Unspecified);
Alloc_Form_Actual := Alloc_Form_Exp;
else
pragma Assert (Alloc_Form /= Unspecified);
Alloc_Form_Actual :=
Make_Integer_Literal (Loc,
Intval => UI_From_Int (BIP_Allocation_Form'Pos (Alloc_Form)));
end if;
Analyze_And_Resolve (Alloc_Form_Actual, Etype (Alloc_Form_Formal));
-- Build the parameter association for the new actual and add it to the
-- end of the function's actuals.
Add_Extra_Actual_To_Call
(Function_Call, Alloc_Form_Formal, Alloc_Form_Actual);
-- Pass the Storage_Pool parameter. This parameter is omitted on ZFP as
-- those targets do not support pools.
if RTE_Available (RE_Root_Storage_Pool_Ptr) then
Pool_Formal := Build_In_Place_Formal (Function_Id, BIP_Storage_Pool);
Analyze_And_Resolve (Pool_Actual, Etype (Pool_Formal));
Add_Extra_Actual_To_Call
(Function_Call, Pool_Formal, Pool_Actual);
end if;
end Add_Unconstrained_Actuals_To_Build_In_Place_Call;
-----------------------------------------------------------
-- Add_Finalization_Master_Actual_To_Build_In_Place_Call --
-----------------------------------------------------------
procedure Add_Finalization_Master_Actual_To_Build_In_Place_Call
(Func_Call : Node_Id;
Func_Id : Entity_Id;
Ptr_Typ : Entity_Id := Empty;
Master_Exp : Node_Id := Empty)
is
begin
if not Needs_BIP_Finalization_Master (Func_Id) then
return;
end if;
declare
Formal : constant Entity_Id :=
Build_In_Place_Formal (Func_Id, BIP_Finalization_Master);
Loc : constant Source_Ptr := Sloc (Func_Call);
Actual : Node_Id;
Desig_Typ : Entity_Id;
begin
-- If there is a finalization master actual, such as the implicit
-- finalization master of an enclosing build-in-place function,
-- then this must be added as an extra actual of the call.
if Present (Master_Exp) then
Actual := Master_Exp;
-- Case where the context does not require an actual master
elsif No (Ptr_Typ) then
Actual := Make_Null (Loc);
else
Desig_Typ := Directly_Designated_Type (Ptr_Typ);
-- Check for a library-level access type whose designated type has
-- suppressed finalization or the access type is subject to pragma
-- No_Heap_Finalization. Such an access type lacks a master. Pass
-- a null actual to callee in order to signal a missing master.
if Is_Library_Level_Entity (Ptr_Typ)
and then (Finalize_Storage_Only (Desig_Typ)
or else No_Heap_Finalization (Ptr_Typ))
then
Actual := Make_Null (Loc);
-- Types in need of finalization actions
elsif Needs_Finalization (Desig_Typ) then
-- The general mechanism of creating finalization masters for
-- anonymous access types is disabled by default, otherwise
-- finalization masters will pop all over the place. Such types
-- use context-specific masters.
if Ekind (Ptr_Typ) = E_Anonymous_Access_Type
and then No (Finalization_Master (Ptr_Typ))
then
Build_Anonymous_Master (Ptr_Typ);
end if;
-- Access-to-controlled types should always have a master
pragma Assert (Present (Finalization_Master (Ptr_Typ)));
Actual :=
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (Finalization_Master (Ptr_Typ), Loc),
Attribute_Name => Name_Unrestricted_Access);
-- Tagged types
else
Actual := Make_Null (Loc);
end if;
end if;
Analyze_And_Resolve (Actual, Etype (Formal));
-- Build the parameter association for the new actual and add it to
-- the end of the function's actuals.
Add_Extra_Actual_To_Call (Func_Call, Formal, Actual);
end;
end Add_Finalization_Master_Actual_To_Build_In_Place_Call;
------------------------------
-- Add_Extra_Actual_To_Call --
------------------------------
procedure Add_Extra_Actual_To_Call
(Subprogram_Call : Node_Id;
Extra_Formal : Entity_Id;
Extra_Actual : Node_Id)
is
Loc : constant Source_Ptr := Sloc (Subprogram_Call);
Param_Assoc : Node_Id;
begin
Param_Assoc :=
Make_Parameter_Association (Loc,
Selector_Name => New_Occurrence_Of (Extra_Formal, Loc),
Explicit_Actual_Parameter => Extra_Actual);
Set_Parent (Param_Assoc, Subprogram_Call);
Set_Parent (Extra_Actual, Param_Assoc);
if Present (Parameter_Associations (Subprogram_Call)) then
if Nkind (Last (Parameter_Associations (Subprogram_Call))) =
N_Parameter_Association
then
-- Find last named actual, and append
declare
L : Node_Id;
begin
L := First_Actual (Subprogram_Call);
while Present (L) loop
if No (Next_Actual (L)) then
Set_Next_Named_Actual (Parent (L), Extra_Actual);
exit;
end if;
Next_Actual (L);
end loop;
end;
else
Set_First_Named_Actual (Subprogram_Call, Extra_Actual);
end if;
Append (Param_Assoc, To => Parameter_Associations (Subprogram_Call));
else
Set_Parameter_Associations (Subprogram_Call, New_List (Param_Assoc));
Set_First_Named_Actual (Subprogram_Call, Extra_Actual);
end if;
end Add_Extra_Actual_To_Call;
---------------------------------------------
-- Add_Task_Actuals_To_Build_In_Place_Call --
---------------------------------------------
procedure Add_Task_Actuals_To_Build_In_Place_Call
(Function_Call : Node_Id;
Function_Id : Entity_Id;
Master_Actual : Node_Id;
Chain : Node_Id := Empty)
is
Loc : constant Source_Ptr := Sloc (Function_Call);
Actual : Node_Id;
Chain_Actual : Node_Id;
Chain_Formal : Node_Id;
Master_Formal : Node_Id;
begin
-- No such extra parameters are needed if there are no tasks
if not Needs_BIP_Task_Actuals (Function_Id) then
return;
end if;
Actual := Master_Actual;
-- Use a dummy _master actual in case of No_Task_Hierarchy
if Restriction_Active (No_Task_Hierarchy) then
Actual := Make_Integer_Literal (Loc, Library_Task_Level);
-- In the case where we use the master associated with an access type,
-- the actual is an entity and requires an explicit reference.
elsif Nkind (Actual) = N_Defining_Identifier then
Actual := New_Occurrence_Of (Actual, Loc);
end if;
-- Locate the implicit master parameter in the called function
Master_Formal := Build_In_Place_Formal (Function_Id, BIP_Task_Master);
Analyze_And_Resolve (Actual, Etype (Master_Formal));
-- Build the parameter association for the new actual and add it to the
-- end of the function's actuals.
Add_Extra_Actual_To_Call (Function_Call, Master_Formal, Actual);
-- Locate the implicit activation chain parameter in the called function
Chain_Formal :=
Build_In_Place_Formal (Function_Id, BIP_Activation_Chain);
-- Create the actual which is a pointer to the current activation chain
if No (Chain) then
Chain_Actual :=
Make_Attribute_Reference (Loc,
Prefix => Make_Identifier (Loc, Name_uChain),
Attribute_Name => Name_Unrestricted_Access);
-- Allocator case; make a reference to the Chain passed in by the caller
else
Chain_Actual :=
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Chain, Loc),
Attribute_Name => Name_Unrestricted_Access);
end if;
Analyze_And_Resolve (Chain_Actual, Etype (Chain_Formal));
-- Build the parameter association for the new actual and add it to the
-- end of the function's actuals.
Add_Extra_Actual_To_Call (Function_Call, Chain_Formal, Chain_Actual);
end Add_Task_Actuals_To_Build_In_Place_Call;
----------------------------------
-- Apply_CW_Accessibility_Check --
----------------------------------
procedure Apply_CW_Accessibility_Check (Exp : Node_Id; Func : Entity_Id) is
Loc : constant Source_Ptr := Sloc (Exp);
begin
if Ada_Version >= Ada_2005
and then Tagged_Type_Expansion
and then not Scope_Suppress.Suppress (Accessibility_Check)
and then
(Is_Class_Wide_Type (Etype (Exp))
or else Nkind (Exp) in
N_Type_Conversion | N_Unchecked_Type_Conversion
or else (Is_Entity_Name (Exp)
and then Is_Formal (Entity (Exp)))
or else Scope_Depth (Enclosing_Dynamic_Scope (Etype (Exp))) >
Scope_Depth (Enclosing_Dynamic_Scope (Func)))
then
declare
Tag_Node : Node_Id;
begin
-- Ada 2005 (AI-251): In class-wide interface objects we displace
-- "this" to reference the base of the object. This is required to
-- get access to the TSD of the object.
if Is_Class_Wide_Type (Etype (Exp))
and then Is_Interface (Etype (Exp))
then
-- If the expression is an explicit dereference then we can
-- directly displace the pointer to reference the base of
-- the object.
if Nkind (Exp) = N_Explicit_Dereference then
Tag_Node :=
Make_Explicit_Dereference (Loc,
Prefix =>
Unchecked_Convert_To (RTE (RE_Tag_Ptr),
Make_Function_Call (Loc,
Name =>
New_Occurrence_Of (RTE (RE_Base_Address), Loc),
Parameter_Associations => New_List (
Unchecked_Convert_To (RTE (RE_Address),
Duplicate_Subexpr (Prefix (Exp)))))));
-- Similar case to the previous one but the expression is a
-- renaming of an explicit dereference.
elsif Nkind (Exp) = N_Identifier
and then Present (Renamed_Object (Entity (Exp)))
and then Nkind (Renamed_Object (Entity (Exp)))
= N_Explicit_Dereference
then
Tag_Node :=
Make_Explicit_Dereference (Loc,
Prefix =>
Unchecked_Convert_To (RTE (RE_Tag_Ptr),
Make_Function_Call (Loc,
Name =>
New_Occurrence_Of (RTE (RE_Base_Address), Loc),
Parameter_Associations => New_List (
Unchecked_Convert_To (RTE (RE_Address),
Duplicate_Subexpr
(Prefix
(Renamed_Object (Entity (Exp)))))))));
-- Common case: obtain the address of the actual object and
-- displace the pointer to reference the base of the object.
else
Tag_Node :=
Make_Explicit_Dereference (Loc,
Prefix =>
Unchecked_Convert_To (RTE (RE_Tag_Ptr),
Make_Function_Call (Loc,
Name =>
New_Occurrence_Of (RTE (RE_Base_Address), Loc),
Parameter_Associations => New_List (
Make_Attribute_Reference (Loc,
Prefix => Duplicate_Subexpr (Exp),
Attribute_Name => Name_Address)))));
end if;
else
Tag_Node :=
Make_Attribute_Reference (Loc,
Prefix => Duplicate_Subexpr (Exp),
Attribute_Name => Name_Tag);
end if;
-- CodePeer does not do anything useful with
-- Ada.Tags.Type_Specific_Data components.
if not CodePeer_Mode then
Insert_Action (Exp,
Make_Raise_Program_Error (Loc,
Condition =>
Make_Op_Gt (Loc,
Left_Opnd => Build_Get_Access_Level (Loc, Tag_Node),
Right_Opnd =>
Make_Integer_Literal (Loc,
Scope_Depth (Enclosing_Dynamic_Scope (Func)))),
Reason => PE_Accessibility_Check_Failed));
end if;
end;
end if;
end Apply_CW_Accessibility_Check;
-----------------------
-- BIP_Formal_Suffix --
-----------------------
function BIP_Formal_Suffix (Kind : BIP_Formal_Kind) return String is
begin
case Kind is
when BIP_Alloc_Form =>
return BIP_Alloc_Suffix;
when BIP_Storage_Pool =>
return BIP_Storage_Pool_Suffix;
when BIP_Finalization_Master =>
return BIP_Finalization_Master_Suffix;
when BIP_Task_Master =>
return BIP_Task_Master_Suffix;
when BIP_Activation_Chain =>
return BIP_Activation_Chain_Suffix;
when BIP_Object_Access =>
return BIP_Object_Access_Suffix;
end case;
end BIP_Formal_Suffix;
---------------------
-- BIP_Suffix_Kind --
---------------------
function BIP_Suffix_Kind (E : Entity_Id) return BIP_Formal_Kind is
Nam : constant String := Get_Name_String (Chars (E));
function Has_Suffix (Suffix : String) return Boolean;
-- Return True if Nam has suffix Suffix
function Has_Suffix (Suffix : String) return Boolean is
Len : constant Natural := Suffix'Length;
begin
return Nam'Length > Len
and then Nam (Nam'Last - Len + 1 .. Nam'Last) = Suffix;
end Has_Suffix;
-- Start of processing for BIP_Suffix_Kind
begin
if Has_Suffix (BIP_Alloc_Suffix) then
return BIP_Alloc_Form;
elsif Has_Suffix (BIP_Storage_Pool_Suffix) then
return BIP_Storage_Pool;
elsif Has_Suffix (BIP_Finalization_Master_Suffix) then
return BIP_Finalization_Master;
elsif Has_Suffix (BIP_Task_Master_Suffix) then
return BIP_Task_Master;
elsif Has_Suffix (BIP_Activation_Chain_Suffix) then
return BIP_Activation_Chain;
elsif Has_Suffix (BIP_Object_Access_Suffix) then
return BIP_Object_Access;
else
raise Program_Error;
end if;
end BIP_Suffix_Kind;
---------------------------
-- Build_In_Place_Formal --
---------------------------
function Build_In_Place_Formal
(Func : Entity_Id;
Kind : BIP_Formal_Kind) return Entity_Id
is
Extra_Formal : Entity_Id := Extra_Formals (Func);
Formal_Suffix : constant String := BIP_Formal_Suffix (Kind);
begin
-- Maybe it would be better for each implicit formal of a build-in-place
-- function to have a flag or a Uint attribute to identify it. ???
-- The return type in the function declaration may have been a limited
-- view, and the extra formals for the function were not generated at
-- that point. At the point of call the full view must be available and
-- the extra formals can be created.
if No (Extra_Formal) then
Create_Extra_Formals (Func);
Extra_Formal := Extra_Formals (Func);
end if;
-- We search for a formal with a matching suffix. We can't search
-- for the full name, because of the code at the end of Sem_Ch6.-
-- Create_Extra_Formals, which copies the Extra_Formals over to
-- the Alias of an instance, which will cause the formals to have
-- "incorrect" names.
loop
pragma Assert (Present (Extra_Formal));
declare
Name : constant String := Get_Name_String (Chars (Extra_Formal));
begin
exit when Name'Length >= Formal_Suffix'Length
and then Formal_Suffix =
Name (Name'Last - Formal_Suffix'Length + 1 .. Name'Last);
end;
Next_Formal_With_Extras (Extra_Formal);
end loop;
return Extra_Formal;
end Build_In_Place_Formal;
-------------------------------
-- Build_Procedure_Body_Form --
-------------------------------
function Build_Procedure_Body_Form
(Func_Id : Entity_Id;
Func_Body : Node_Id) return Node_Id
is
Loc : constant Source_Ptr := Sloc (Func_Body);
Proc_Decl : constant Node_Id := Prev (Unit_Declaration_Node (Func_Id));
-- It is assumed that the node before the declaration of the
-- corresponding subprogram spec is the declaration of the procedure
-- form.
Proc_Id : constant Entity_Id := Defining_Entity (Proc_Decl);
procedure Replace_Returns (Param_Id : Entity_Id; Stmts : List_Id);
-- Replace each return statement found in the list Stmts with an
-- assignment of the return expression to parameter Param_Id.
---------------------
-- Replace_Returns --
---------------------
procedure Replace_Returns (Param_Id : Entity_Id; Stmts : List_Id) is
Stmt : Node_Id;
begin
Stmt := First (Stmts);
while Present (Stmt) loop
if Nkind (Stmt) = N_Block_Statement then
Replace_Returns (Param_Id,
Statements (Handled_Statement_Sequence (Stmt)));
elsif Nkind (Stmt) = N_Case_Statement then
declare
Alt : Node_Id;
begin
Alt := First (Alternatives (Stmt));
while Present (Alt) loop
Replace_Returns (Param_Id, Statements (Alt));
Next (Alt);
end loop;
end;
elsif Nkind (Stmt) = N_Extended_Return_Statement then
declare
Ret_Obj : constant Entity_Id :=
Defining_Entity
(First (Return_Object_Declarations (Stmt)));
Assign : constant Node_Id :=
Make_Assignment_Statement (Sloc (Stmt),
Name =>
New_Occurrence_Of (Param_Id, Loc),
Expression =>
New_Occurrence_Of (Ret_Obj, Sloc (Stmt)));
Stmts : List_Id;
begin
-- The extended return may just contain the declaration
if Present (Handled_Statement_Sequence (Stmt)) then
Stmts := Statements (Handled_Statement_Sequence (Stmt));
else
Stmts := New_List;
end if;
Set_Assignment_OK (Name (Assign));
Rewrite (Stmt,
Make_Block_Statement (Sloc (Stmt),
Declarations =>
Return_Object_Declarations (Stmt),
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => Stmts)));
Replace_Returns (Param_Id, Stmts);
Append_To (Stmts, Assign);
Append_To (Stmts, Make_Simple_Return_Statement (Loc));
end;
elsif Nkind (Stmt) = N_If_Statement then
Replace_Returns (Param_Id, Then_Statements (Stmt));
Replace_Returns (Param_Id, Else_Statements (Stmt));
declare
Part : Node_Id;
begin
Part := First (Elsif_Parts (Stmt));
while Present (Part) loop
Replace_Returns (Param_Id, Then_Statements (Part));
Next (Part);
end loop;
end;
elsif Nkind (Stmt) = N_Loop_Statement then
Replace_Returns (Param_Id, Statements (Stmt));
elsif Nkind (Stmt) = N_Simple_Return_Statement then
-- Generate:
-- Param := Expr;
-- return;
Rewrite (Stmt,
Make_Assignment_Statement (Sloc (Stmt),
Name => New_Occurrence_Of (Param_Id, Loc),
Expression => Relocate_Node (Expression (Stmt))));
Insert_After (Stmt, Make_Simple_Return_Statement (Loc));
-- Skip the added return
Next (Stmt);
end if;
Next (Stmt);
end loop;
end Replace_Returns;
-- Local variables
Stmts : List_Id;
New_Body : Node_Id;
-- Start of processing for Build_Procedure_Body_Form
begin
-- This routine replaces the original function body:
-- function F (...) return Array_Typ is
-- begin
-- ...
-- return Something;
-- end F;
-- with the following:
-- procedure P (..., Result : out Array_Typ) is
-- begin
-- ...
-- Result := Something;
-- end P;
Stmts :=
Statements (Handled_Statement_Sequence (Func_Body));
Replace_Returns (Last_Entity (Proc_Id), Stmts);
New_Body :=
Make_Subprogram_Body (Loc,
Specification =>
Copy_Subprogram_Spec (Specification (Proc_Decl)),
Declarations => Declarations (Func_Body),
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => Stmts));
-- If the function is a generic instance, so is the new procedure.
-- Set flag accordingly so that the proper renaming declarations are
-- generated.
Set_Is_Generic_Instance (Proc_Id, Is_Generic_Instance (Func_Id));
return New_Body;
end Build_Procedure_Body_Form;
-----------------------
-- Caller_Known_Size --
-----------------------
function Caller_Known_Size
(Func_Call : Node_Id;
Result_Subt : Entity_Id) return Boolean
is
begin
return
(Is_Definite_Subtype (Underlying_Type (Result_Subt))
and then No (Controlling_Argument (Func_Call)))
or else not Requires_Transient_Scope (Underlying_Type (Result_Subt));
end Caller_Known_Size;
-----------------------
-- Check_BIP_Actuals --
-----------------------
function Check_BIP_Actuals
(Subp_Call : Node_Id;
Subp_Id : Entity_Id) return Boolean
is
Formal : Entity_Id;
Actual : Node_Id;
begin
pragma Assert (Nkind (Subp_Call) in N_Entry_Call_Statement
| N_Function_Call
| N_Procedure_Call_Statement);
Formal := First_Formal_With_Extras (Subp_Id);
Actual := First_Actual (Subp_Call);
while Present (Formal) and then Present (Actual) loop
if Is_Build_In_Place_Entity (Formal)
and then Nkind (Actual) = N_Identifier
and then Is_Build_In_Place_Entity (Entity (Actual))
and then BIP_Suffix_Kind (Formal)
/= BIP_Suffix_Kind (Entity (Actual))
then
return False;
end if;
Next_Formal_With_Extras (Formal);
Next_Actual (Actual);
end loop;
return No (Formal) and then No (Actual);
end Check_BIP_Actuals;
-----------------------------
-- Check_Number_Of_Actuals --
-----------------------------
function Check_Number_Of_Actuals
(Subp_Call : Node_Id;
Subp_Id : Entity_Id) return Boolean
is
Formal : Entity_Id;
Actual : Node_Id;
begin
pragma Assert (Nkind (Subp_Call) in N_Entry_Call_Statement
| N_Function_Call
| N_Procedure_Call_Statement);
Formal := First_Formal_With_Extras (Subp_Id);
Actual := First_Actual (Subp_Call);
while Present (Formal) and then Present (Actual) loop
Next_Formal_With_Extras (Formal);
Next_Actual (Actual);
end loop;
return No (Formal) and then No (Actual);
end Check_Number_Of_Actuals;
--------------------------------
-- Check_Overriding_Operation --
--------------------------------
procedure Check_Overriding_Operation (Subp : Entity_Id) is
Typ : constant Entity_Id := Find_Dispatching_Type (Subp);
Op_List : constant Elist_Id := Primitive_Operations (Typ);
Op_Elmt : Elmt_Id;
Prim_Op : Entity_Id;
Par_Op : Entity_Id;
begin
if Is_Derived_Type (Typ)
and then not Is_Private_Type (Typ)
and then In_Open_Scopes (Scope (Etype (Typ)))
and then Is_Base_Type (Typ)
then
-- Subp overrides an inherited private operation if there is an
-- inherited operation with a different name than Subp (see
-- Derive_Subprogram) whose Alias is a hidden subprogram with the
-- same name as Subp.
Op_Elmt := First_Elmt (Op_List);
while Present (Op_Elmt) loop
Prim_Op := Node (Op_Elmt);
Par_Op := Alias (Prim_Op);
if Present (Par_Op)
and then not Comes_From_Source (Prim_Op)
and then Chars (Prim_Op) /= Chars (Par_Op)
and then Chars (Par_Op) = Chars (Subp)
and then Is_Hidden (Par_Op)
and then Type_Conformant (Prim_Op, Subp)
then
Set_DT_Position_Value (Subp, DT_Position (Prim_Op));
end if;
Next_Elmt (Op_Elmt);
end loop;
end if;
end Check_Overriding_Operation;
-------------------------------
-- Detect_Infinite_Recursion --
-------------------------------
procedure Detect_Infinite_Recursion (N : Node_Id; Spec : Entity_Id) is
Loc : constant Source_Ptr := Sloc (N);
Var_List : constant Elist_Id := New_Elmt_List;
-- List of globals referenced by body of procedure
Call_List : constant Elist_Id := New_Elmt_List;
-- List of recursive calls in body of procedure
Shad_List : constant Elist_Id := New_Elmt_List;
-- List of entity id's for entities created to capture the value of
-- referenced globals on entry to the procedure.
Scop : constant Uint := Scope_Depth (Spec);
-- This is used to record the scope depth of the current procedure, so
-- that we can identify global references.
Max_Vars : constant := 4;
-- Do not test more than four global variables
Count_Vars : Natural := 0;
-- Count variables found so far
Var : Entity_Id;
Elm : Elmt_Id;
Ent : Entity_Id;
Call : Elmt_Id;
Decl : Node_Id;
Test : Node_Id;
Elm1 : Elmt_Id;
Elm2 : Elmt_Id;
Last : Node_Id;
function Process (Nod : Node_Id) return Traverse_Result;
-- Function to traverse the subprogram body (using Traverse_Func)
-------------
-- Process --
-------------
function Process (Nod : Node_Id) return Traverse_Result is
begin
-- Procedure call
if Nkind (Nod) = N_Procedure_Call_Statement then
-- Case of one of the detected recursive calls
if Is_Entity_Name (Name (Nod))
and then Has_Recursive_Call (Entity (Name (Nod)))
and then Entity (Name (Nod)) = Spec
then
Append_Elmt (Nod, Call_List);
return Skip;
-- Any other procedure call may have side effects
else
return Abandon;
end if;
-- A call to a pure function can always be ignored
elsif Nkind (Nod) = N_Function_Call
and then Is_Entity_Name (Name (Nod))
and then Is_Pure (Entity (Name (Nod)))
then
return Skip;
-- Case of an identifier reference
elsif Nkind (Nod) = N_Identifier then
Ent := Entity (Nod);
-- If no entity, then ignore the reference
-- Not clear why this can happen. To investigate, remove this
-- test and look at the crash that occurs here in 3401-004 ???
if No (Ent) then
return Skip;
-- Ignore entities with no Scope, again not clear how this
-- can happen, to investigate, look at 4108-008 ???
elsif No (Scope (Ent)) then
return Skip;
-- Ignore the reference if not to a more global object
elsif Scope_Depth (Scope (Ent)) >= Scop then
return Skip;
-- References to types, exceptions and constants are always OK
elsif Is_Type (Ent)
or else Ekind (Ent) = E_Exception
or else Ekind (Ent) = E_Constant
then
return Skip;
-- If other than a non-volatile scalar variable, we have some
-- kind of global reference (e.g. to a function) that we cannot
-- deal with so we forget the attempt.
elsif Ekind (Ent) /= E_Variable
or else not Is_Scalar_Type (Etype (Ent))
or else Treat_As_Volatile (Ent)
then
return Abandon;
-- Otherwise we have a reference to a global scalar
else
-- Loop through global entities already detected
Elm := First_Elmt (Var_List);
loop
-- If not detected before, record this new global reference
if No (Elm) then
Count_Vars := Count_Vars + 1;
if Count_Vars <= Max_Vars then
Append_Elmt (Entity (Nod), Var_List);
else
return Abandon;
end if;
exit;
-- If recorded before, ignore
elsif Node (Elm) = Entity (Nod) then
return Skip;
-- Otherwise keep looking
else
Next_Elmt (Elm);
end if;
end loop;
return Skip;
end if;
-- For all other node kinds, recursively visit syntactic children
else
return OK;
end if;
end Process;
function Traverse_Body is new Traverse_Func (Process);
-- Start of processing for Detect_Infinite_Recursion
begin
-- Do not attempt detection in No_Implicit_Conditional mode, since we
-- won't be able to generate the code to handle the recursion in any
-- case.
if Restriction_Active (No_Implicit_Conditionals) then
return;
end if;
-- Otherwise do traversal and quit if we get abandon signal
if Traverse_Body (N) = Abandon then
return;
-- We must have a call, since Has_Recursive_Call was set. If not just
-- ignore (this is only an error check, so if we have a funny situation,
-- due to bugs or errors, we do not want to bomb).
elsif Is_Empty_Elmt_List (Call_List) then
return;
end if;
-- Here is the case where we detect recursion at compile time
-- Push our current scope for analyzing the declarations and code that
-- we will insert for the checking.
Push_Scope (Spec);
-- This loop builds temporary variables for each of the referenced
-- globals, so that at the end of the loop the list Shad_List contains
-- these temporaries in one-to-one correspondence with the elements in
-- Var_List.
Last := Empty;
Elm := First_Elmt (Var_List);
while Present (Elm) loop
Var := Node (Elm);
Ent := Make_Temporary (Loc, 'S');
Append_Elmt (Ent, Shad_List);
-- Insert a declaration for this temporary at the start of the
-- declarations for the procedure. The temporaries are declared as
-- constant objects initialized to the current values of the
-- corresponding temporaries.
Decl :=
Make_Object_Declaration (Loc,
Defining_Identifier => Ent,
Object_Definition => New_Occurrence_Of (Etype (Var), Loc),
Constant_Present => True,
Expression => New_Occurrence_Of (Var, Loc));
if No (Last) then
Prepend (Decl, Declarations (N));
else
Insert_After (Last, Decl);
end if;
Last := Decl;
Analyze (Decl);
Next_Elmt (Elm);
end loop;
-- Loop through calls
Call := First_Elmt (Call_List);
while Present (Call) loop
-- Build a predicate expression of the form
-- True
-- and then global1 = temp1
-- and then global2 = temp2
-- ...
-- This predicate determines if any of the global values
-- referenced by the procedure have changed since the
-- current call, if not an infinite recursion is assured.
Test := New_Occurrence_Of (Standard_True, Loc);
Elm1 := First_Elmt (Var_List);
Elm2 := First_Elmt (Shad_List);
while Present (Elm1) loop
Test :=
Make_And_Then (Loc,
Left_Opnd => Test,
Right_Opnd =>
Make_Op_Eq (Loc,
Left_Opnd => New_Occurrence_Of (Node (Elm1), Loc),
Right_Opnd => New_Occurrence_Of (Node (Elm2), Loc)));
Next_Elmt (Elm1);
Next_Elmt (Elm2);
end loop;
-- Now we replace the call with the sequence
-- if no-changes (see above) then
-- raise Storage_Error;
-- else
-- original-call
-- end if;
Rewrite (Node (Call),
Make_If_Statement (Loc,
Condition => Test,
Then_Statements => New_List (
Make_Raise_Storage_Error (Loc,
Reason => SE_Infinite_Recursion)),
Else_Statements => New_List (
Relocate_Node (Node (Call)))));
Analyze (Node (Call));
Next_Elmt (Call);
end loop;
-- Remove temporary scope stack entry used for analysis
Pop_Scope;
end Detect_Infinite_Recursion;
--------------------
-- Expand_Actuals --
--------------------
procedure Expand_Actuals
(N : Node_Id;
Subp : Entity_Id;
Post_Call : out List_Id)
is
Loc : constant Source_Ptr := Sloc (N);
Actual : Node_Id;
Formal : Entity_Id;
N_Node : Node_Id;
E_Actual : Entity_Id;
E_Formal : Entity_Id;
procedure Add_Call_By_Copy_Code;
-- For cases where the parameter must be passed by copy, this routine
-- generates a temporary variable into which the actual is copied and
-- then passes this as the parameter. For an OUT or IN OUT parameter,
-- an assignment is also generated to copy the result back. The call
-- also takes care of any constraint checks required for the type
-- conversion case (on both the way in and the way out).
procedure Add_Simple_Call_By_Copy_Code (Force : Boolean);
-- This is similar to the above, but is used in cases where we know
-- that all that is needed is to simply create a temporary and copy
-- the value in and out of the temporary. If Force is True, then the
-- procedure may disregard legality considerations.
-- ??? We need to do the copy for a bit-packed array because this is
-- where the rewriting into a mask-and-shift sequence is done. But of
-- course this may break the program if it expects bits to be really
-- passed by reference. That's what we have done historically though.
procedure Add_Validation_Call_By_Copy_Code (Act : Node_Id);
-- Perform copy-back for actual parameter Act which denotes a validation
-- variable.
procedure Check_Fortran_Logical;
-- A value of type Logical that is passed through a formal parameter
-- must be normalized because .TRUE. usually does not have the same
-- representation as True. We assume that .FALSE. = False = 0.
-- What about functions that return a logical type ???
function Is_Legal_Copy return Boolean;
-- Check that an actual can be copied before generating the temporary
-- to be used in the call. If the formal is of a by_reference type or
-- is aliased, then the program is illegal (this can only happen in
-- the presence of representation clauses that force a misalignment)
-- If the formal is a by_reference parameter imposed by a DEC pragma,
-- emit a warning that this might lead to unaligned arguments.
function Make_Var (Actual : Node_Id) return Entity_Id;
-- Returns an entity that refers to the given actual parameter, Actual
-- (not including any type conversion). If Actual is an entity name,
-- then this entity is returned unchanged, otherwise a renaming is
-- created to provide an entity for the actual.
procedure Reset_Packed_Prefix;
-- The expansion of a packed array component reference is delayed in
-- the context of a call. Now we need to complete the expansion, so we
-- unmark the analyzed bits in all prefixes.
function Requires_Atomic_Or_Volatile_Copy return Boolean;
-- Returns whether a copy is required as per RM C.6(19) and gives a
-- warning in this case.
---------------------------
-- Add_Call_By_Copy_Code --
---------------------------
procedure Add_Call_By_Copy_Code is
Crep : Boolean;
Expr : Node_Id;
F_Typ : Entity_Id := Etype (Formal);
Indic : Node_Id;
Init : Node_Id;
Temp : Entity_Id;
V_Typ : Entity_Id;
Var : Entity_Id;
begin
if not Is_Legal_Copy then
return;
end if;
Temp := Make_Temporary (Loc, 'T', Actual);
-- Handle formals whose type comes from the limited view
if From_Limited_With (F_Typ)
and then Has_Non_Limited_View (F_Typ)
then
F_Typ := Non_Limited_View (F_Typ);
end if;
-- Use formal type for temp, unless formal type is an unconstrained
-- array, in which case we don't have to worry about bounds checks,
-- and we use the actual type, since that has appropriate bounds.
if Is_Array_Type (F_Typ) and then not Is_Constrained (F_Typ) then
Indic := New_Occurrence_Of (Etype (Actual), Loc);
else
Indic := New_Occurrence_Of (F_Typ, Loc);
end if;
-- The new code will be properly analyzed below and the setting of
-- the Do_Range_Check flag recomputed so remove the obsolete one.
Set_Do_Range_Check (Actual, False);
if Nkind (Actual) = N_Type_Conversion then
Set_Do_Range_Check (Expression (Actual), False);
V_Typ := Etype (Expression (Actual));
-- If the formal is an (in-)out parameter, capture the name
-- of the variable in order to build the post-call assignment.
Var := Make_Var (Expression (Actual));
Crep := not Has_Compatible_Representation
(Target_Type => F_Typ,
Operand_Type => Etype (Expression (Actual)));
else
V_Typ := Etype (Actual);
Var := Make_Var (Actual);
Crep := False;
end if;
-- Setup initialization for case of in out parameter, or an out
-- parameter where the formal is an unconstrained array (in the
-- latter case, we have to pass in an object with bounds).
-- If this is an out parameter, the initial copy is wasteful, so as
-- an optimization for the one-dimensional case we extract the
-- bounds of the actual and build an uninitialized temporary of the
-- right size.
-- If the formal is an out parameter with discriminants, the
-- discriminants must be captured even if the rest of the object
-- is in principle uninitialized, because the discriminants may
-- be read by the called subprogram.
if Ekind (Formal) = E_In_Out_Parameter
or else (Is_Array_Type (F_Typ) and then not Is_Constrained (F_Typ))
or else Has_Discriminants (F_Typ)
then
if Nkind (Actual) = N_Type_Conversion then
if Conversion_OK (Actual) then
Init := OK_Convert_To (F_Typ, New_Occurrence_Of (Var, Loc));
else
Init := Convert_To (F_Typ, New_Occurrence_Of (Var, Loc));
end if;
elsif Ekind (Formal) = E_Out_Parameter
and then Is_Array_Type (F_Typ)
and then Number_Dimensions (F_Typ) = 1
and then not Has_Non_Null_Base_Init_Proc (F_Typ)
then
-- Actual is a one-dimensional array or slice, and the type
-- requires no initialization. Create a temporary of the
-- right size, but do not copy actual into it (optimization).
Init := Empty;
Indic :=
Make_Subtype_Indication (Loc,
Subtype_Mark => New_Occurrence_Of (F_Typ, Loc),
Constraint =>
Make_Index_Or_Discriminant_Constraint (Loc,
Constraints => New_List (
Make_Range (Loc,
Low_Bound =>
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Var, Loc),
Attribute_Name => Name_First),
High_Bound =>
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Var, Loc),
Attribute_Name => Name_Last)))));
else
Init := New_Occurrence_Of (Var, Loc);
end if;
-- An initialization is created for packed conversions as
-- actuals for out parameters to enable Make_Object_Declaration
-- to determine the proper subtype for N_Node. Note that this
-- is wasteful because the extra copying on the call side is
-- not required for such out parameters. ???
elsif Ekind (Formal) = E_Out_Parameter
and then Nkind (Actual) = N_Type_Conversion
and then (Is_Bit_Packed_Array (F_Typ)
or else
Is_Bit_Packed_Array (Etype (Expression (Actual))))
then
if Conversion_OK (Actual) then
Init := OK_Convert_To (F_Typ, New_Occurrence_Of (Var, Loc));
else
Init := Convert_To (F_Typ, New_Occurrence_Of (Var, Loc));
end if;
elsif Ekind (Formal) = E_In_Parameter then
-- Handle the case in which the actual is a type conversion
if Nkind (Actual) = N_Type_Conversion then
if Conversion_OK (Actual) then
Init := OK_Convert_To (F_Typ, New_Occurrence_Of (Var, Loc));
else
Init := Convert_To (F_Typ, New_Occurrence_Of (Var, Loc));
end if;
else
Init := New_Occurrence_Of (Var, Loc);
end if;
-- Access types are passed in without checks, but if a copy-back is
-- required for a null-excluding check on an in-out or out parameter,
-- then the initial value is that of the actual.
elsif Is_Access_Type (E_Formal)
and then Can_Never_Be_Null (Etype (Actual))
and then not Can_Never_Be_Null (E_Formal)
then
Init := New_Occurrence_Of (Var, Loc);
-- View conversions when the formal type has the Default_Value aspect
-- require passing in the value of the conversion's operand. The type
-- of that operand also has Default_Value, as required by AI12-0074
-- (RM 6.4.1(5.3/4)). The subtype denoted by the subtype_indication
-- is changed to the base type of the formal subtype, to ensure that
-- the actual's value can be assigned without a constraint check
-- (note that no check is done on passing to an out parameter). Also
-- note that the two types necessarily share the same ancestor type,
-- as required by 6.4.1(5.2/4), so underlying base types will match.
elsif Ekind (Formal) = E_Out_Parameter
and then Is_Scalar_Type (Etype (F_Typ))
and then Nkind (Actual) = N_Type_Conversion
and then Present (Default_Aspect_Value (Etype (F_Typ)))
then
Indic := New_Occurrence_Of (Base_Type (F_Typ), Loc);
Init := Convert_To
(Base_Type (F_Typ), New_Occurrence_Of (Var, Loc));
else
Init := Empty;
end if;
N_Node :=
Make_Object_Declaration (Loc,
Defining_Identifier => Temp,
Object_Definition => Indic,
Expression => Init);
Set_Assignment_OK (N_Node);
Insert_Action (N, N_Node);
-- Now, normally the deal here is that we use the defining
-- identifier created by that object declaration. There is
-- one exception to this. In the change of representation case
-- the above declaration will end up looking like:
-- temp : type := identifier;
-- And in this case we might as well use the identifier directly
-- and eliminate the temporary. Note that the analysis of the
-- declaration was not a waste of time in that case, since it is
-- what generated the necessary change of representation code. If
-- the change of representation introduced additional code, as in
-- a fixed-integer conversion, the expression is not an identifier
-- and must be kept.
if Crep
and then Present (Expression (N_Node))
and then Is_Entity_Name (Expression (N_Node))
then
Temp := Entity (Expression (N_Node));
Rewrite (N_Node, Make_Null_Statement (Loc));
end if;
-- For IN parameter, all we do is to replace the actual
if Ekind (Formal) = E_In_Parameter then
Rewrite (Actual, New_Occurrence_Of (Temp, Loc));
Analyze (Actual);
-- Processing for OUT or IN OUT parameter
else
-- Kill current value indications for the temporary variable we
-- created, since we just passed it as an OUT parameter.
Kill_Current_Values (Temp);
Set_Is_Known_Valid (Temp, False);
Set_Is_True_Constant (Temp, False);
-- If type conversion, use reverse conversion on exit
if Nkind (Actual) = N_Type_Conversion then
if Conversion_OK (Actual) then
Expr := OK_Convert_To (V_Typ, New_Occurrence_Of (Temp, Loc));
else
Expr := Convert_To (V_Typ, New_Occurrence_Of (Temp, Loc));
end if;
else
Expr := New_Occurrence_Of (Temp, Loc);
end if;
Rewrite (Actual, New_Occurrence_Of (Temp, Loc));
Analyze (Actual);
-- If the actual is a conversion of a packed reference, it may
-- already have been expanded by Remove_Side_Effects, and the
-- resulting variable is a temporary which does not designate
-- the proper out-parameter, which may not be addressable. In
-- that case, generate an assignment to the original expression
-- (before expansion of the packed reference) so that the proper
-- expansion of assignment to a packed component can take place.
declare
Obj : Node_Id;
Lhs : Node_Id;
begin
if Is_Renaming_Of_Object (Var)
and then Nkind (Renamed_Object (Var)) = N_Selected_Component
and then Nkind (Original_Node (Prefix (Renamed_Object (Var))))
= N_Indexed_Component
and then
Has_Non_Standard_Rep (Etype (Prefix (Renamed_Object (Var))))
then
Obj := Renamed_Object (Var);
Lhs :=
Make_Selected_Component (Loc,
Prefix =>
New_Copy_Tree (Original_Node (Prefix (Obj))),
Selector_Name => New_Copy (Selector_Name (Obj)));
Reset_Analyzed_Flags (Lhs);
else
Lhs := New_Occurrence_Of (Var, Loc);
end if;
Set_Assignment_OK (Lhs);
if Is_Access_Type (E_Formal)
and then Is_Entity_Name (Lhs)
and then
Present (Effective_Extra_Accessibility (Entity (Lhs)))
and then not No_Dynamic_Accessibility_Checks_Enabled (Lhs)
then
-- Copyback target is an Ada 2012 stand-alone object of an
-- anonymous access type.
pragma Assert (Ada_Version >= Ada_2012);
Apply_Accessibility_Check (Lhs, E_Formal, N);
Append_To (Post_Call,
Make_Assignment_Statement (Loc,
Name => Lhs,
Expression => Expr));
-- We would like to somehow suppress generation of the
-- extra_accessibility assignment generated by the expansion
-- of the above assignment statement. It's not a correctness
-- issue because the following assignment renders it dead,
-- but generating back-to-back assignments to the same
-- target is undesirable. ???
Append_To (Post_Call,
Make_Assignment_Statement (Loc,
Name => New_Occurrence_Of (
Effective_Extra_Accessibility (Entity (Lhs)), Loc),
Expression => Make_Integer_Literal (Loc,
Type_Access_Level (E_Formal))));
else
if Is_Access_Type (E_Formal)
and then Can_Never_Be_Null (Etype (Actual))
and then not Can_Never_Be_Null (E_Formal)
then
Append_To (Post_Call,
Make_Raise_Constraint_Error (Loc,
Condition =>
Make_Op_Eq (Loc,
Left_Opnd => New_Occurrence_Of (Temp, Loc),
Right_Opnd => Make_Null (Loc)),
Reason => CE_Access_Check_Failed));
end if;
Append_To (Post_Call,
Make_Assignment_Statement (Loc,
Name => Lhs,
Expression => Expr));
end if;
end;
end if;
end Add_Call_By_Copy_Code;
----------------------------------
-- Add_Simple_Call_By_Copy_Code --
----------------------------------
procedure Add_Simple_Call_By_Copy_Code (Force : Boolean) is
Decl : Node_Id;
F_Typ : Entity_Id := Etype (Formal);
Incod : Node_Id;
Indic : Node_Id;
Lhs : Node_Id;
Outcod : Node_Id;
Rhs : Node_Id;
Temp : Entity_Id;
begin
-- Unless forced not to, check the legality of the copy operation
if not Force and then not Is_Legal_Copy then
return;
end if;
-- Handle formals whose type comes from the limited view
if From_Limited_With (F_Typ)
and then Has_Non_Limited_View (F_Typ)
then
F_Typ := Non_Limited_View (F_Typ);
end if;
-- Use formal type for temp, unless formal type is an unconstrained
-- array, in which case we don't have to worry about bounds checks,
-- and we use the actual type, since that has appropriate bounds.
if Is_Array_Type (F_Typ) and then not Is_Constrained (F_Typ) then
Indic := New_Occurrence_Of (Etype (Actual), Loc);
else
Indic := New_Occurrence_Of (F_Typ, Loc);
end if;
-- Prepare to generate code
Reset_Packed_Prefix;
Temp := Make_Temporary (Loc, 'T', Actual);
Incod := Relocate_Node (Actual);
Outcod := New_Copy_Tree (Incod);
-- Generate declaration of temporary variable, initializing it
-- with the input parameter unless we have an OUT formal or
-- this is an initialization call.
-- If the formal is an out parameter with discriminants, the
-- discriminants must be captured even if the rest of the object
-- is in principle uninitialized, because the discriminants may
-- be read by the called subprogram.
if Ekind (Formal) = E_Out_Parameter then
Incod := Empty;
if Has_Discriminants (F_Typ) then
Indic := New_Occurrence_Of (Etype (Actual), Loc);
end if;
elsif Inside_Init_Proc then
-- Skip using the actual as the expression in Decl if we are in
-- an init proc and it is not a component which depends on a
-- discriminant, because, in this case, we need to use the actual
-- type of the component instead.
if Nkind (Actual) /= N_Selected_Component
or else
not Has_Discriminant_Dependent_Constraint
(Entity (Selector_Name (Actual)))
then
Incod := Empty;
-- Otherwise, keep the component so we can generate the proper
-- actual subtype - since the subtype depends on enclosing
-- discriminants.
else
null;
end if;
end if;
Decl :=
Make_Object_Declaration (Loc,
Defining_Identifier => Temp,
Object_Definition => Indic,
Expression => Incod);
if Inside_Init_Proc
and then No (Incod)
then
-- If the call is to initialize a component of a composite type,
-- and the component does not depend on discriminants, use the
-- actual type of the component. This is required in case the
-- component is constrained, because in general the formal of the
-- initialization procedure will be unconstrained. Note that if
-- the component being initialized is constrained by an enclosing
-- discriminant, the presence of the initialization in the
-- declaration will generate an expression for the actual subtype.
Set_No_Initialization (Decl);
Set_Object_Definition (Decl,
New_Occurrence_Of (Etype (Actual), Loc));
end if;
Insert_Action (N, Decl);
-- The actual is simply a reference to the temporary
Rewrite (Actual, New_Occurrence_Of (Temp, Loc));
-- Generate copy out if OUT or IN OUT parameter
if Ekind (Formal) /= E_In_Parameter then
Lhs := Outcod;
Rhs := New_Occurrence_Of (Temp, Loc);
Set_Is_True_Constant (Temp, False);
-- Deal with conversion
if Nkind (Lhs) = N_Type_Conversion then
Lhs := Expression (Lhs);
Rhs := Convert_To (Etype (Actual), Rhs);
end if;
Append_To (Post_Call,
Make_Assignment_Statement (Loc,
Name => Lhs,
Expression => Rhs));
Set_Assignment_OK (Name (Last (Post_Call)));
end if;
end Add_Simple_Call_By_Copy_Code;
--------------------------------------
-- Add_Validation_Call_By_Copy_Code --
--------------------------------------
procedure Add_Validation_Call_By_Copy_Code (Act : Node_Id) is
Expr : Node_Id;
Obj : Node_Id;
Obj_Typ : Entity_Id;
Var : constant Node_Id := Unqual_Conv (Act);
Var_Id : Entity_Id;
begin
-- Generate range check if required
if Do_Range_Check (Actual) then
Generate_Range_Check (Actual, E_Formal, CE_Range_Check_Failed);
end if;
-- If there is a type conversion in the actual, it will be reinstated
-- below, the new instance will be properly analyzed and the setting
-- of the Do_Range_Check flag recomputed so remove the obsolete one.
if Nkind (Actual) = N_Type_Conversion then
Set_Do_Range_Check (Expression (Actual), False);
end if;
-- Copy the value of the validation variable back into the object
-- being validated.
if Is_Entity_Name (Var) then
Var_Id := Entity (Var);
Obj := Validated_Object (Var_Id);
Obj_Typ := Etype (Obj);
Expr := New_Occurrence_Of (Var_Id, Loc);
-- A type conversion is needed when the validation variable and
-- the validated object carry different types. This case occurs
-- when the actual is qualified in some fashion.
-- Common:
-- subtype Int is Integer range ...;
-- procedure Call (Val : in out Integer);
-- Original:
-- Object : Int;
-- Call (Integer (Object));
-- Expanded:
-- Object : Int;
-- Var : Integer := Object; -- conversion to base type
-- if not Var'Valid then -- validity check
-- Call (Var); -- modify Var
-- Object := Int (Var); -- conversion to subtype
if Etype (Var_Id) /= Obj_Typ then
Expr :=
Make_Type_Conversion (Loc,
Subtype_Mark => New_Occurrence_Of (Obj_Typ, Loc),
Expression => Expr);
end if;
-- Generate:
-- Object := Var;
-- <or>
-- Object := Object_Type (Var);
Append_To (Post_Call,
Make_Assignment_Statement (Loc,
Name => Obj,
Expression => Expr));
-- If the flow reaches this point, then this routine was invoked with
-- an actual which does not denote a validation variable.
else
pragma Assert (False);
null;
end if;
end Add_Validation_Call_By_Copy_Code;
---------------------------
-- Check_Fortran_Logical --
---------------------------
procedure Check_Fortran_Logical is
Logical : constant Entity_Id := Etype (Formal);
Var : Entity_Id;
-- Note: this is very incomplete, e.g. it does not handle arrays
-- of logical values. This is really not the right approach at all???)
begin
if Convention (Subp) = Convention_Fortran
and then Root_Type (Etype (Formal)) = Standard_Boolean
and then Ekind (Formal) /= E_In_Parameter
then
Var := Make_Var (Actual);
Append_To (Post_Call,
Make_Assignment_Statement (Loc,
Name => New_Occurrence_Of (Var, Loc),
Expression =>
Unchecked_Convert_To (
Logical,
Make_Op_Ne (Loc,
Left_Opnd => New_Occurrence_Of (Var, Loc),
Right_Opnd =>
Unchecked_Convert_To (
Logical,
New_Occurrence_Of (Standard_False, Loc))))));
end if;
end Check_Fortran_Logical;
-------------------
-- Is_Legal_Copy --
-------------------
function Is_Legal_Copy return Boolean is
begin
-- An attempt to copy a value of such a type can only occur if
-- representation clauses give the actual a misaligned address.
if Is_By_Reference_Type (Etype (Formal))
or else Is_Aliased (Formal)
or else (Mechanism (Formal) = By_Reference
and then not Has_Foreign_Convention (Subp))
then
-- The actual may in fact be properly aligned but there is not
-- enough front-end information to determine this. In that case
-- gigi will emit an error or a warning if a copy is not legal,
-- or generate the proper code.
return False;
-- For users of Starlet, we assume that the specification of by-
-- reference mechanism is mandatory. This may lead to unaligned
-- objects but at least for DEC legacy code it is known to work.
-- The warning will alert users of this code that a problem may
-- be lurking.
elsif Mechanism (Formal) = By_Reference
and then Ekind (Scope (Formal)) = E_Procedure
and then Is_Valued_Procedure (Scope (Formal))
then
Error_Msg_N
("by_reference actual may be misaligned??", Actual);
return False;
else
return True;
end if;
end Is_Legal_Copy;
--------------
-- Make_Var --
--------------
function Make_Var (Actual : Node_Id) return Entity_Id is
Var : Entity_Id;
begin
if Is_Entity_Name (Actual) then
return Entity (Actual);
else
Var := Make_Temporary (Loc, 'T', Actual);
N_Node :=
Make_Object_Renaming_Declaration (Loc,
Defining_Identifier => Var,
Subtype_Mark =>
New_Occurrence_Of (Etype (Actual), Loc),
Name => Relocate_Node (Actual));
Insert_Action (N, N_Node);
return Var;
end if;
end Make_Var;
-------------------------
-- Reset_Packed_Prefix --
-------------------------
procedure Reset_Packed_Prefix is
Pfx : Node_Id := Actual;
begin
loop
Set_Analyzed (Pfx, False);
exit when
Nkind (Pfx) not in N_Selected_Component | N_Indexed_Component;
Pfx := Prefix (Pfx);
end loop;
end Reset_Packed_Prefix;
----------------------------------------
-- Requires_Atomic_Or_Volatile_Copy --
----------------------------------------
function Requires_Atomic_Or_Volatile_Copy return Boolean is
begin
-- If the formal is already passed by copy, no need to do anything
if Is_By_Copy_Type (E_Formal) then
return False;
end if;
-- There is no requirement inside initialization procedures and this
-- would generate copies for atomic or volatile composite components.
if Inside_Init_Proc then
return False;
end if;
-- Check for atomicity mismatch
if Is_Atomic_Object (Actual) and then not Is_Atomic (E_Formal)
then
if Comes_From_Source (N) then
Error_Msg_N
("??atomic actual passed by copy (RM C.6(19))", Actual);
end if;
return True;
end if;
-- Check for volatility mismatch
if Is_Volatile_Object_Ref (Actual) and then not Is_Volatile (E_Formal)
then
if Comes_From_Source (N) then
Error_Msg_N
("??volatile actual passed by copy (RM C.6(19))", Actual);
end if;
return True;
end if;
return False;
end Requires_Atomic_Or_Volatile_Copy;
-- Start of processing for Expand_Actuals
begin
Post_Call := New_List;
Formal := First_Formal (Subp);
Actual := First_Actual (N);
while Present (Formal) loop
E_Formal := Etype (Formal);
E_Actual := Etype (Actual);
-- Handle formals whose type comes from the limited view
if From_Limited_With (E_Formal)
and then Has_Non_Limited_View (E_Formal)
then
E_Formal := Non_Limited_View (E_Formal);
end if;
if Is_Scalar_Type (E_Formal)
or else Nkind (Actual) = N_Slice
then
Check_Fortran_Logical;
-- RM 6.4.1 (11)
elsif Ekind (Formal) /= E_Out_Parameter then
-- The unusual case of the current instance of a protected type
-- requires special handling. This can only occur in the context
-- of a call within the body of a protected operation.
if Is_Entity_Name (Actual)
and then Ekind (Entity (Actual)) = E_Protected_Type
and then In_Open_Scopes (Entity (Actual))
then
if Scope (Subp) /= Entity (Actual) then
Error_Msg_N
("operation outside protected type may not "
& "call back its protected operations??", Actual);
end if;
Rewrite (Actual,
Expand_Protected_Object_Reference (N, Entity (Actual)));
end if;
-- Ada 2005 (AI-318-02): If the actual parameter is a call to a
-- build-in-place function, then a temporary return object needs
-- to be created and access to it must be passed to the function
-- (and ensure that we have an activation chain defined for tasks
-- and a Master variable).
-- Currently we limit such functions to those with inherently
-- limited result subtypes, but eventually we plan to expand the
-- functions that are treated as build-in-place to include other
-- composite result types.
-- But do not do it here for intrinsic subprograms since this will
-- be done properly after the subprogram is expanded.
if Is_Intrinsic_Subprogram (Subp) then
null;
elsif Is_Build_In_Place_Function_Call (Actual) then
if Might_Have_Tasks (Etype (Actual)) then
Build_Activation_Chain_Entity (N);
Build_Master_Entity (Etype (Actual));
end if;
Make_Build_In_Place_Call_In_Anonymous_Context (Actual);
-- Ada 2005 (AI-318-02): Specialization of the previous case for
-- actuals containing build-in-place function calls whose returned
-- object covers interface types.
elsif Present (Unqual_BIP_Iface_Function_Call (Actual)) then
Build_Activation_Chain_Entity (N);
Build_Master_Entity (Etype (Actual));
Make_Build_In_Place_Iface_Call_In_Anonymous_Context (Actual);
end if;
Apply_Constraint_Check (Actual, E_Formal);
-- Out parameter case. No constraint checks on access type
-- RM 6.4.1 (13), but on return a null-excluding check may be
-- required (see below).
elsif Is_Access_Type (E_Formal) then
null;
-- RM 6.4.1 (14)
elsif Has_Discriminants (Base_Type (E_Formal))
or else Has_Non_Null_Base_Init_Proc (E_Formal)
then
Apply_Constraint_Check (Actual, E_Formal);
-- RM 6.4.1 (15)
else
Apply_Constraint_Check (Actual, Base_Type (E_Formal));
end if;
-- Processing for IN-OUT and OUT parameters
if Ekind (Formal) /= E_In_Parameter then
-- For type conversions of arrays, apply length/range checks
if Is_Array_Type (E_Formal)
and then Nkind (Actual) = N_Type_Conversion
then
if Is_Constrained (E_Formal) then
Apply_Length_Check (Expression (Actual), E_Formal);
else
Apply_Range_Check (Expression (Actual), E_Formal);
end if;
end if;
-- The actual denotes a variable which captures the value of an
-- object for validation purposes. Add a copy-back to reflect any
-- potential changes in value back into the original object.
-- Var : ... := Object;
-- if not Var'Valid then -- validity check
-- Call (Var); -- modify var
-- Object := Var; -- update Object
-- This case is given higher priority because the subsequent check
-- for type conversion may add an extra copy of the variable and
-- prevent proper value propagation back in the original object.
if Is_Validation_Variable_Reference (Actual) then
Add_Validation_Call_By_Copy_Code (Actual);
-- If argument is a type conversion for a type that is passed by
-- copy, then we must pass the parameter by copy.
elsif Nkind (Actual) = N_Type_Conversion
and then
(Is_Elementary_Type (E_Formal)
or else Is_Bit_Packed_Array (Etype (Formal))
or else Is_Bit_Packed_Array (Etype (Expression (Actual)))
-- Also pass by copy if change of representation
or else not Has_Compatible_Representation
(Target_Type => Etype (Formal),
Operand_Type => Etype (Expression (Actual))))
then
Add_Call_By_Copy_Code;
-- References to components of bit-packed arrays are expanded
-- at this point, rather than at the point of analysis of the
-- actuals, to handle the expansion of the assignment to
-- [in] out parameters.
elsif Is_Ref_To_Bit_Packed_Array (Actual) then
Add_Simple_Call_By_Copy_Code (Force => True);
-- If a nonscalar actual is possibly bit-aligned, we need a copy
-- because the back-end cannot cope with such objects. In other
-- cases where alignment forces a copy, the back-end generates
-- it properly. It should not be generated unconditionally in the
-- front-end because it does not know precisely the alignment
-- requirements of the target, and makes too conservative an
-- estimate, leading to superfluous copies or spurious errors
-- on by-reference parameters.
elsif Nkind (Actual) = N_Selected_Component
and then
Component_May_Be_Bit_Aligned (Entity (Selector_Name (Actual)))
and then not Represented_As_Scalar (Etype (Formal))
then
Add_Simple_Call_By_Copy_Code (Force => False);
-- References to slices of bit-packed arrays are expanded
elsif Is_Ref_To_Bit_Packed_Slice (Actual) then
Add_Call_By_Copy_Code;
-- References to possibly unaligned slices of arrays are expanded
elsif Is_Possibly_Unaligned_Slice (Actual) then
Add_Call_By_Copy_Code;
-- Deal with access types where the actual subtype and the
-- formal subtype are not the same, requiring a check.
-- It is necessary to exclude tagged types because of "downward
-- conversion" errors, but null-excluding checks on return may be
-- required.
elsif Is_Access_Type (E_Formal)
and then not Is_Tagged_Type (Designated_Type (E_Formal))
and then (not Same_Type (E_Formal, E_Actual)
or else (Can_Never_Be_Null (E_Actual)
and then not Can_Never_Be_Null (E_Formal)))
then
Add_Call_By_Copy_Code;
-- We may need to force a copy because of atomicity or volatility
-- considerations.
elsif Requires_Atomic_Or_Volatile_Copy then
Add_Call_By_Copy_Code;
-- Add call-by-copy code for the case of scalar out parameters
-- when it is not known at compile time that the subtype of the
-- formal is a subrange of the subtype of the actual (or vice
-- versa for in out parameters), in order to get range checks
-- on such actuals. (Maybe this case should be handled earlier
-- in the if statement???)
elsif Is_Scalar_Type (E_Formal)
and then
(not In_Subrange_Of (E_Formal, E_Actual)
or else
(Ekind (Formal) = E_In_Out_Parameter
and then not In_Subrange_Of (E_Actual, E_Formal)))
then
Add_Call_By_Copy_Code;
end if;
-- RM 3.2.4 (23/3): A predicate is checked on in-out and out
-- by-reference parameters on exit from the call. If the actual
-- is a derived type and the operation is inherited, the body
-- of the operation will not contain a call to the predicate
-- function, so it must be done explicitly after the call. Ditto
-- if the actual is an entity of a predicated subtype.
-- The rule refers to by-reference types, but a check is needed
-- for by-copy types as well. That check is subsumed by the rule
-- for subtype conversion on assignment, but we can generate the
-- required check now.
-- Note also that Subp may be either a subprogram entity for
-- direct calls, or a type entity for indirect calls, which must
-- be handled separately because the name does not denote an
-- overloadable entity.
By_Ref_Predicate_Check : declare
Aund : constant Entity_Id := Underlying_Type (E_Actual);
Atyp : Entity_Id;
begin
if No (Aund) then
Atyp := E_Actual;
else
Atyp := Aund;
end if;
if Predicate_Enabled (Atyp)
-- Skip predicate checks for special cases
and then Predicate_Tests_On_Arguments (Subp)
then
Append_To (Post_Call,
Make_Predicate_Check (Atyp, Actual));
end if;
end By_Ref_Predicate_Check;
-- Processing for IN parameters
else
-- Generate range check if required
if Do_Range_Check (Actual) then
Generate_Range_Check (Actual, E_Formal, CE_Range_Check_Failed);
end if;
-- For IN parameters in the bit-packed array case, we expand an
-- indexed component (the circuit in Exp_Ch4 deliberately left
-- indexed components appearing as actuals untouched, so that
-- the special processing above for the OUT and IN OUT cases
-- could be performed. We could make the test in Exp_Ch4 more
-- complex and have it detect the parameter mode, but it is
-- easier simply to handle all cases here.)
if Nkind (Actual) = N_Indexed_Component
and then Is_Bit_Packed_Array (Etype (Prefix (Actual)))
then
Reset_Packed_Prefix;
Expand_Packed_Element_Reference (Actual);
-- If we have a reference to a bit-packed array, we copy it, since
-- the actual must be byte aligned.
-- Is this really necessary in all cases???
elsif Is_Ref_To_Bit_Packed_Array (Actual) then
Add_Simple_Call_By_Copy_Code (Force => True);
-- If we have a C++ constructor call, we need to create the object
elsif Is_CPP_Constructor_Call (Actual) then
Add_Simple_Call_By_Copy_Code (Force => True);
-- If a nonscalar actual is possibly unaligned, we need a copy
elsif Is_Possibly_Unaligned_Object (Actual)
and then not Represented_As_Scalar (Etype (Formal))
then
Add_Simple_Call_By_Copy_Code (Force => False);
-- Similarly, we have to expand slices of packed arrays here
-- because the result must be byte aligned.
elsif Is_Ref_To_Bit_Packed_Slice (Actual) then
Add_Call_By_Copy_Code;
-- Only processing remaining is to pass by copy if this is a
-- reference to a possibly unaligned slice, since the caller
-- expects an appropriately aligned argument.
elsif Is_Possibly_Unaligned_Slice (Actual) then
Add_Call_By_Copy_Code;
-- We may need to force a copy because of atomicity or volatility
-- considerations.
elsif Requires_Atomic_Or_Volatile_Copy then
Add_Call_By_Copy_Code;
-- An unusual case: a current instance of an enclosing task can be
-- an actual, and must be replaced by a reference to self.
elsif Is_Entity_Name (Actual)
and then Is_Task_Type (Entity (Actual))
then
if In_Open_Scopes (Entity (Actual)) then
Rewrite (Actual,
(Make_Function_Call (Loc,
Name => New_Occurrence_Of (RTE (RE_Self), Loc))));
Analyze (Actual);
-- A task type cannot otherwise appear as an actual
else
raise Program_Error;
end if;
end if;
end if;
-- Type-invariant checks for in-out and out parameters, as well as
-- for in parameters of procedures (AI05-0289 and AI12-0044).
if Ekind (Formal) /= E_In_Parameter
or else Ekind (Subp) = E_Procedure
then
Caller_Side_Invariant_Checks : declare
function Is_Public_Subp return Boolean;
-- Check whether the subprogram being called is a visible
-- operation of the type of the actual. Used to determine
-- whether an invariant check must be generated on the
-- caller side.
---------------------
-- Is_Public_Subp --
---------------------
function Is_Public_Subp return Boolean is
Pack : constant Entity_Id := Scope (Subp);
Subp_Decl : Node_Id;
begin
if not Is_Subprogram (Subp) then
return False;
-- The operation may be inherited, or a primitive of the
-- root type.
elsif
Nkind (Parent (Subp)) in N_Private_Extension_Declaration
| N_Full_Type_Declaration
then
Subp_Decl := Parent (Subp);
else
Subp_Decl := Unit_Declaration_Node (Subp);
end if;
return Ekind (Pack) = E_Package
and then
List_Containing (Subp_Decl) =
Visible_Declarations
(Specification (Unit_Declaration_Node (Pack)));
end Is_Public_Subp;
-- Start of processing for Caller_Side_Invariant_Checks
begin
-- We generate caller-side invariant checks in two cases:
-- a) when calling an inherited operation, where there is an
-- implicit view conversion of the actual to the parent type.
-- b) When the conversion is explicit
-- We treat these cases separately because the required
-- conversion for a) is added later when expanding the call.
if Has_Invariants (Etype (Actual))
and then
Nkind (Parent (Etype (Actual)))
= N_Private_Extension_Declaration
then
if Comes_From_Source (N) and then Is_Public_Subp then
Append_To (Post_Call, Make_Invariant_Call (Actual));
end if;
elsif Nkind (Actual) = N_Type_Conversion
and then Has_Invariants (Etype (Expression (Actual)))
then
if Comes_From_Source (N) and then Is_Public_Subp then
Append_To
(Post_Call, Make_Invariant_Call (Expression (Actual)));
end if;
end if;
end Caller_Side_Invariant_Checks;
end if;
Next_Formal (Formal);
Next_Actual (Actual);
end loop;
end Expand_Actuals;
-----------------
-- Expand_Call --
-----------------
procedure Expand_Call (N : Node_Id) is
Post_Call : List_Id;
-- If this is an indirect call through an Access_To_Subprogram
-- with contract specifications, it is rewritten as a call to
-- the corresponding Access_Subprogram_Wrapper with the same
-- actuals, whose body contains a naked indirect call (which
-- itself must not be rewritten, to prevent infinite recursion).
Must_Rewrite_Indirect_Call : constant Boolean :=
Ada_Version >= Ada_2022
and then Nkind (Name (N)) = N_Explicit_Dereference
and then Ekind (Etype (Name (N))) = E_Subprogram_Type
and then Present
(Access_Subprogram_Wrapper (Etype (Name (N))));
begin
pragma Assert (Nkind (N) in N_Entry_Call_Statement
| N_Function_Call
| N_Procedure_Call_Statement);
-- Check that this is not the call in the body of the wrapper
if Must_Rewrite_Indirect_Call
and then (not Is_Overloadable (Current_Scope)
or else not Is_Access_Subprogram_Wrapper (Current_Scope))
then
declare
Loc : constant Source_Ptr := Sloc (N);
Wrapper : constant Entity_Id :=
Access_Subprogram_Wrapper (Etype (Name (N)));
Ptr : constant Node_Id := Prefix (Name (N));
Ptr_Type : constant Entity_Id := Etype (Ptr);
Typ : constant Entity_Id := Etype (N);
New_N : Node_Id;
Parms : List_Id := Parameter_Associations (N);
Ptr_Act : Node_Id;
begin
-- The last actual in the call is the pointer itself.
-- If the aspect is inherited, convert the pointer to the
-- parent type that specifies the contract.
-- If the original access_to_subprogram has defaults for
-- in_parameters, the call may include named associations, so
-- we create one for the pointer as well.
if Is_Derived_Type (Ptr_Type)
and then Ptr_Type /= Etype (Last_Formal (Wrapper))
then
Ptr_Act :=
Make_Type_Conversion (Loc,
New_Occurrence_Of
(Etype (Last_Formal (Wrapper)), Loc), Ptr);
else
Ptr_Act := Ptr;
end if;
-- Handle parameterless subprogram.
if No (Parms) then
Parms := New_List;
end if;
Append
(Make_Parameter_Association (Loc,
Selector_Name => Make_Identifier (Loc,
Chars (Last_Formal (Wrapper))),
Explicit_Actual_Parameter => Ptr_Act),
Parms);
if Nkind (N) = N_Procedure_Call_Statement then
New_N := Make_Procedure_Call_Statement (Loc,
Name => New_Occurrence_Of (Wrapper, Loc),
Parameter_Associations => Parms);
else
New_N := Make_Function_Call (Loc,
Name => New_Occurrence_Of (Wrapper, Loc),
Parameter_Associations => Parms);
end if;
Rewrite (N, New_N);
Analyze_And_Resolve (N, Typ);
end;
else
Expand_Call_Helper (N, Post_Call);
Insert_Post_Call_Actions (N, Post_Call);
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.
procedure Expand_Call_Helper (N : Node_Id; Post_Call : out List_Id) is
Loc : constant Source_Ptr := Sloc (N);
Call_Node : Node_Id := N;
Extra_Actuals : List_Id := No_List;
Prev : Node_Id := Empty;
procedure Add_Actual_Parameter (Insert_Param : Node_Id);
-- Adds one entry to the end of the actual parameter list. Used for
-- default parameters and for extra actuals (for Extra_Formals). The
-- argument is an N_Parameter_Association node.
procedure Add_Cond_Expression_Extra_Actual (Formal : Entity_Id);
-- Adds extra accessibility actuals in the case of a conditional
-- expression corresponding to Formal.
-- Note: Conditional expressions used as actuals for anonymous access
-- formals complicate the process of propagating extra accessibility
-- actuals and must be handled in a recursive fashion since they can
-- be embedded within each other.
procedure Add_Extra_Actual (Expr : Node_Id; EF : Entity_Id);
-- Adds an extra actual to the list of extra actuals. Expr is the
-- 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 --
--------------------------------------
procedure Add_Cond_Expression_Extra_Actual
(Formal : Entity_Id)
is
Decl : Node_Id;
Lvl : Entity_Id;
procedure Insert_Level_Assign (Branch : Node_Id);
-- Recursively add assignment of the level temporary on each branch
-- while moving through nested conditional expressions.
-------------------------
-- Insert_Level_Assign --
-------------------------
procedure Insert_Level_Assign (Branch : Node_Id) is
procedure Expand_Branch (Res_Assn : Node_Id);
-- Perform expansion or iterate further within nested
-- conditionals given the object declaration or assignment to
-- result object created during expansion which represents a
-- branch of the conditional expression.
-------------------
-- Expand_Branch --
-------------------
procedure Expand_Branch (Res_Assn : Node_Id) is
begin
pragma Assert (Nkind (Res_Assn) in
N_Assignment_Statement |
N_Object_Declaration);
-- There are more nested conditional expressions so we must go
-- deeper.
if Nkind (Expression (Res_Assn)) = N_Expression_With_Actions
and then
Nkind (Original_Node (Expression (Res_Assn)))
in N_Case_Expression | N_If_Expression
then
Insert_Level_Assign
(Expression (Res_Assn));
-- Add the level assignment
else
Insert_Before_And_Analyze (Res_Assn,
Make_Assignment_Statement (Loc,
Name => New_Occurrence_Of (Lvl, Loc),
Expression =>
Accessibility_Level
(Expr => Expression (Res_Assn),
Level => Dynamic_Level,
Allow_Alt_Model => False)));
end if;
end Expand_Branch;
Cond : Node_Id;
Alt : Node_Id;
-- Start of processing for Insert_Level_Assign
begin
-- Examine further nested condtionals
pragma Assert (Nkind (Branch) =
N_Expression_With_Actions);
-- Find the relevant statement in the actions
Cond := First (Actions (Branch));
while Present (Cond) loop
exit when Nkind (Cond) in N_Case_Statement | N_If_Statement;
Next (Cond);
end loop;
-- The conditional expression may have been optimized away, so
-- examine the actions in the branch.
if No (Cond) then
Expand_Branch (Last (Actions (Branch)));
-- Iterate through if expression branches
elsif Nkind (Cond) = N_If_Statement then
Expand_Branch (Last (Then_Statements (Cond)));
Expand_Branch (Last (Else_Statements (Cond)));
-- Iterate through case alternatives
elsif Nkind (Cond) = N_Case_Statement then
Alt := First (Alternatives (Cond));
while Present (Alt) loop
Expand_Branch (Last (Statements (Alt)));
Next (Alt);
end loop;
end if;
end Insert_Level_Assign;
-- Start of processing for cond expression case
begin
-- Create declaration of a temporary to store the accessibility
-- level of each branch of the conditional expression.
Lvl := Make_Temporary (Loc, 'L');
Decl := Make_Object_Declaration (Loc,
Defining_Identifier => Lvl,
Object_Definition =>
New_Occurrence_Of (Standard_Natural, Loc));
-- Install the declaration and perform necessary expansion if we
-- are dealing with a procedure call.
if Nkind (Call_Node) = N_Procedure_Call_Statement then
-- Generate:
-- Lvl : Natural;
-- Call (
-- {do
-- If_Exp_Res : Typ;
-- if Cond then
-- Lvl := 0; -- Access level
-- If_Exp_Res := Exp;
-- ...
-- in If_Exp_Res end;},
-- Lvl,
-- ...
-- )
Insert_Before_And_Analyze (Call_Node, Decl);
-- Ditto for a function call. Note that we do not wrap the function
-- call into an expression with action to avoid bad interactions with
-- Exp_Ch4.Process_Transient_In_Expression.
else
-- Generate:
-- Lvl : Natural; -- placed above the function call
-- ...
-- Func_Call (
-- {do
-- If_Exp_Res : Typ
-- if Cond then
-- Lvl := 0; -- Access level
-- If_Exp_Res := Exp;
-- in If_Exp_Res end;},
-- Lvl,
-- ...
-- )
Insert_Action (Call_Node, Decl);
Analyze (Call_Node);
end if;
-- Decorate the conditional expression with assignments to our level
-- temporary.
Insert_Level_Assign (Prev);
-- Make our level temporary the passed actual
Add_Extra_Actual
(Expr => New_Occurrence_Of (Lvl, Loc),
EF => Extra_Accessibility (Formal));
end Add_Cond_Expression_Extra_Actual;
----------------------
-- Add_Extra_Actual --
----------------------
procedure Add_Extra_Actual (Expr : Node_Id; EF : Entity_Id) is
Loc : constant Source_Ptr := Sloc (Expr);
begin
if Extra_Actuals = No_List then
Extra_Actuals := New_List;
Set_Parent (Extra_Actuals, Call_Node);
end if;
Append_To (Extra_Actuals,
Make_Parameter_Association (Loc,
Selector_Name => New_Occurrence_Of (EF, Loc),
Explicit_Actual_Parameter => Expr));
Analyze_And_Resolve (Expr, Etype (EF));
if Nkind (Call_Node) = N_Function_Call then
Set_Is_Accessibility_Actual (Parent (Expr));
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;
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)
return Boolean
is
Aspect_Bearer : Entity_Id := Entity (DP_Aspect_Spec);
begin
loop
Aspect_Bearer := Nearest_Ancestor (Aspect_Bearer);
if not Present (Aspect_Bearer) then
return False;
end if;
declare
Aspect_Spec : constant Node_Id :=
Find_Aspect (Aspect_Bearer, Aspect_Dynamic_Predicate);
begin
if Present (Aspect_Spec)
and then Aspect_Spec /= DP_Aspect_Spec
then
-- Found another Dynamic_Predicate aspect spec
return True;
end if;
end;
end loop;
end Augments_Other_Dynamic_Predicate;
--------------
-- May_Fold --
--------------
function May_Fold (N : Node_Id) return Traverse_Result is
begin
case Nkind (N) is
when N_Op =>
return OK;
when N_Expanded_Name
| N_Identifier
=>
if Ekind (Entity (N)) = E_In_Parameter
and then Entity (N) = First_Entity (P)
then
Rewrite (N, New_Copy (Actual));
Set_Is_Static_Expression (N);
return OK;
elsif Ekind (Entity (N)) = E_Enumeration_Literal then
return OK;
else
return Abandon;
end if;
when N_Case_Expression
| N_If_Expression
=>
return OK;
when N_Integer_Literal =>
return OK;
when others =>
return Abandon;
end case;
end May_Fold;
function Try_Fold is new Traverse_Func (May_Fold);
-- Other Local variables
Subt : constant Entity_Id := Etype (First_Entity (P));
Aspect : Node_Id;
Pred : Node_Id;
-- Start of processing for Can_Fold_Predicate_Call
begin
-- Folding is only interesting if the actual is static and its type
-- has a Dynamic_Predicate aspect. For CodePeer we preserve the
-- function call.
Actual := First (Parameter_Associations (Call_Node));
Aspect := Find_Aspect (Subt, Aspect_Dynamic_Predicate);
-- If actual is a declared constant, retrieve its value
if Is_Entity_Name (Actual)
and then Ekind (Entity (Actual)) = E_Constant
then
Actual := Constant_Value (Entity (Actual));
end if;
if No (Actual)
or else Nkind (Actual) /= N_Integer_Literal
or else not Has_Dynamic_Predicate_Aspect (Subt)
or else No (Aspect)
-- Do not fold if multiple applicable predicate aspects
or else Present (Find_Aspect (Subt, Aspect_Static_Predicate))
or else Present (Find_Aspect (Subt, Aspect_Predicate))
or else Augments_Other_Dynamic_Predicate (Aspect)
or else CodePeer_Mode
then
return False;
end if;
-- Retrieve the analyzed expression for the predicate
Pred := New_Copy_Tree (Expression (Aspect));
if Try_Fold (Pred) = OK then
Rewrite (Call_Node, Pred);
Analyze_And_Resolve (Call_Node, Standard_Boolean);
return True;
-- Otherwise continue the expansion of the function call
else
return False;
end if;
end Can_Fold_Predicate_Call;
------------------------------
-- Check_Subprogram_Variant --
------------------------------
procedure Check_Subprogram_Variant is
Variant_Prag : constant Node_Id :=
Get_Pragma (Current_Scope, Pragma_Subprogram_Variant);
Variant_Proc : Entity_Id;
begin
if Present (Variant_Prag) and then Is_Checked (Variant_Prag) then
-- Analysis of the pragma rewrites its argument with a reference
-- to the internally generated procedure.
Variant_Proc :=
Entity
(Expression
(First
(Pragma_Argument_Associations (Variant_Prag))));
Insert_Action (Call_Node,
Make_Procedure_Call_Statement (Loc,
Name =>
New_Occurrence_Of (Variant_Proc, Loc),
Parameter_Associations =>
New_Copy_List (Parameter_Associations (Call_Node))));
end if;
end Check_Subprogram_Variant;
---------------------------
-- Inherited_From_Formal --
---------------------------
function Inherited_From_Formal (S : Entity_Id) return Entity_Id is
Par : Entity_Id;
Gen_Par : Entity_Id;
Gen_Prim : Elist_Id;
Elmt : Elmt_Id;
Indic : Node_Id;
begin
-- If the operation is inherited, it is attached to the corresponding
-- type derivation. If the parent in the derivation is a generic
-- actual, it is a subtype of the actual, and we have to recover the
-- original derived type declaration to find the proper parent.
if Nkind (Parent (S)) /= N_Full_Type_Declaration
or else not Is_Derived_Type (Defining_Identifier (Parent (S)))
or else Nkind (Type_Definition (Original_Node (Parent (S)))) /=
N_Derived_Type_Definition
or else not In_Instance
then
return Empty;
else
Indic :=
Subtype_Indication
(Type_Definition (Original_Node (Parent (S))));
if Nkind (Indic) = N_Subtype_Indication then
Par := Entity (Subtype_Mark (Indic));
else
Par := Entity (Indic);
end if;
end if;
if not Is_Generic_Actual_Type (Par)
or else Is_Tagged_Type (Par)
or else Nkind (Parent (Par)) /= N_Subtype_Declaration
or else not In_Open_Scopes (Scope (Par))
then
return Empty;
else
Gen_Par := Generic_Parent_Type (Parent (Par));
end if;
-- If the actual has no generic parent type, the formal is not
-- a formal derived type, so nothing to inherit.
if No (Gen_Par) then
return Empty;
end if;
-- If the generic parent type is still the generic type, this is a
-- private formal, not a derived formal, and there are no operations
-- inherited from the formal.
if Nkind (Parent (Gen_Par)) = N_Formal_Type_Declaration then
return Empty;
end if;
Gen_Prim := Collect_Primitive_Operations (Gen_Par);
Elmt := First_Elmt (Gen_Prim);
while Present (Elmt) loop
if Chars (Node (Elmt)) = Chars (S) then
declare
F1 : Entity_Id;
F2 : Entity_Id;
begin
F1 := First_Formal (S);
F2 := First_Formal (Node (Elmt));
while Present (F1)
and then Present (F2)
loop
if Etype (F1) = Etype (F2)
or else Etype (F2) = Gen_Par
then
Next_Formal (F1);
Next_Formal (F2);
else
Next_Elmt (Elmt);
exit; -- not the right subprogram
end if;
return Node (Elmt);
end loop;
end;
else
Next_Elmt (Elmt);
end if;
end loop;
raise Program_Error;
end Inherited_From_Formal;
--------------------------
-- In_Unfrozen_Instance --
--------------------------
function In_Unfrozen_Instance (E : Entity_Id) return Boolean is
S : Entity_Id;
begin
S := E;
while Present (S) and then S /= Standard_Standard loop
if Is_Generic_Instance (S)
and then Present (Freeze_Node (S))
and then not Analyzed (Freeze_Node (S))
then
return True;
end if;
S := Scope (S);
end loop;
return False;
end In_Unfrozen_Instance;
----------------------------------
-- Is_Class_Wide_Interface_Type --
----------------------------------
function Is_Class_Wide_Interface_Type (E : Entity_Id) return Boolean is
DDT : Entity_Id;
Typ : Entity_Id := E;
begin
if Has_Non_Limited_View (Typ) then
Typ := Non_Limited_View (Typ);
end if;
if Ekind (Typ) = E_Anonymous_Access_Type then
DDT := Directly_Designated_Type (Typ);
if Has_Non_Limited_View (DDT) then
DDT := Non_Limited_View (DDT);
end if;
return Is_Class_Wide_Type (DDT) and then Is_Interface (DDT);
else
return Is_Class_Wide_Type (Typ) and then Is_Interface (Typ);
end if;
end Is_Class_Wide_Interface_Type;
-------------------------
-- Is_Direct_Deep_Call --
-------------------------
function Is_Direct_Deep_Call (Subp : Entity_Id) return Boolean is
begin
if Is_TSS (Subp, TSS_Deep_Adjust)
or else Is_TSS (Subp, TSS_Deep_Finalize)
or else Is_TSS (Subp, TSS_Deep_Initialize)
then
declare
Actual : Node_Id;
Formal : Entity_Id;
begin
Actual := First (Parameter_Associations (Call_Node));
Formal := First_Formal (Subp);
while Present (Actual)
and then Present (Formal)
loop
if Nkind (Actual) = N_Identifier
and then Is_Controlling_Actual (Actual)
and then Etype (Actual) = Etype (Formal)
then
return True;
end if;
Next (Actual);
Next_Formal (Formal);
end loop;
end;
end if;
return False;
end Is_Direct_Deep_Call;
---------------
-- New_Value --
---------------
function New_Value (From : Node_Id) return Node_Id is
Res : constant Node_Id := Duplicate_Subexpr (From);
begin
if Is_Access_Type (Etype (From)) then
return Make_Explicit_Dereference (Sloc (From), Prefix => Res);
else
return Res;
end if;
end New_Value;
-- Local variables
Remote : constant Boolean := Is_Remote_Call (Call_Node);
Actual : Node_Id;
Formal : Entity_Id;
Orig_Subp : Entity_Id := Empty;
Param_Count : Positive;
Parent_Formal : Entity_Id;
Parent_Subp : Entity_Id;
Scop : Entity_Id;
Subp : Entity_Id;
CW_Interface_Formals_Present : Boolean := False;
-- Start of processing for Expand_Call_Helper
begin
Post_Call := New_List;
-- Expand the function or procedure call if the first actual has a
-- declared dimension aspect, and the subprogram is declared in one
-- of the dimension I/O packages.
if Ada_Version >= Ada_2012
and then Nkind (Call_Node) in N_Subprogram_Call
and then Present (Parameter_Associations (Call_Node))
then
Expand_Put_Call_With_Symbol (Call_Node);
end if;
-- Ignore if previous error
if Nkind (Call_Node) in N_Has_Etype
and then Etype (Call_Node) = Any_Type
then
return;
end if;
-- Call using access to subprogram with explicit dereference
if Nkind (Name (Call_Node)) = N_Explicit_Dereference then
Subp := Etype (Name (Call_Node));
Parent_Subp := Empty;
-- Case of call to simple entry, where the Name is a selected component
-- whose prefix is the task, and whose selector name is the entry name
elsif Nkind (Name (Call_Node)) = N_Selected_Component then
Subp := Entity (Selector_Name (Name (Call_Node)));
Parent_Subp := Empty;
-- 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 (Name (Call_Node)) = N_Indexed_Component then
Subp := Entity (Selector_Name (Prefix (Name (Call_Node))));
Parent_Subp := Empty;
-- Normal case
else
Subp := Entity (Name (Call_Node));
Parent_Subp := Alias (Subp);
-- Replace call to Raise_Exception by call to Raise_Exception_Always
-- if we can tell that the first parameter cannot possibly be null.
-- This improves efficiency by avoiding a run-time test.
-- We do not do this if Raise_Exception_Always does not exist, which
-- can happen in configurable run time profiles which provide only a
-- Raise_Exception.
if Is_RTE (Subp, RE_Raise_Exception)
and then RTE_Available (RE_Raise_Exception_Always)
then
declare
FA : constant Node_Id :=
Original_Node (First_Actual (Call_Node));
begin
-- The case we catch is where the first argument is obtained
-- using the Identity attribute (which must always be
-- non-null).
if Nkind (FA) = N_Attribute_Reference
and then Attribute_Name (FA) = Name_Identity
then
Subp := RTE (RE_Raise_Exception_Always);
Set_Name (Call_Node, New_Occurrence_Of (Subp, Loc));
end if;
end;
end if;
if Ekind (Subp) = E_Entry then
Parent_Subp := Empty;
end if;
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
-- is a renaming of an entry and rewrite it as an entry call.
if Ada_Version >= Ada_2005
and then Nkind (Call_Node) = N_Procedure_Call_Statement
and then
((Nkind (Parent (Call_Node)) = N_Triggering_Alternative
and then Triggering_Statement (Parent (Call_Node)) = Call_Node)
or else
(Nkind (Parent (Call_Node)) = N_Entry_Call_Alternative
and then Entry_Call_Statement (Parent (Call_Node)) = Call_Node))
then
declare
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;
if Transform_Function_Array
and then Nkind (Call_Node) = N_Function_Call
and then Is_Entity_Name (Name (Call_Node))
then
declare
Func_Id : constant Entity_Id :=
Ultimate_Alias (Entity (Name (Call_Node)));
begin
-- When generating C code, transform a function call that returns
-- a constrained array type into procedure form.
if Rewritten_For_C (Func_Id) then
-- For internally generated calls ensure that they reference
-- the entity of the spec of the called function (needed since
-- the expander may generate calls using the entity of their
-- body).
if not Comes_From_Source (Call_Node)
and then Nkind (Unit_Declaration_Node (Func_Id)) =
N_Subprogram_Body
then
Set_Entity (Name (Call_Node),
Corresponding_Function
(Corresponding_Procedure (Func_Id)));
end if;
Rewrite_Function_Call_For_C (Call_Node);
return;
-- Also introduce a temporary for functions that return a record
-- called within another procedure or function call, since records
-- are passed by pointer in the generated C code, and we cannot
-- take a pointer from a subprogram call.
elsif Modify_Tree_For_C
and then Nkind (Parent (Call_Node)) in N_Subprogram_Call
and then Is_Record_Type (Etype (Func_Id))
then
declare
Temp_Id : constant Entity_Id := Make_Temporary (Loc, 'T');
Decl : Node_Id;
begin
-- Generate:
-- Temp : ... := Func_Call (...);
Decl :=
Make_Object_Declaration (Loc,
Defining_Identifier => Temp_Id,
Object_Definition =>
New_Occurrence_Of (Etype (Func_Id), Loc),
Expression =>
Make_Function_Call (Loc,
Name =>
New_Occurrence_Of (Func_Id, Loc),
Parameter_Associations =>
Parameter_Associations (Call_Node)));
Insert_Action (Parent (Call_Node), Decl);
Rewrite (Call_Node, New_Occurrence_Of (Temp_Id, Loc));
return;
end;
end if;
end;
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 (Present (Extra_Formals (Current_Scope)));
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;
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_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 Original_Node (Prev) = 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.
Add_Extra_Actual
(Expr => Accessibility_Level
(Expr => Expression
(Parent (Entity (Prev))),
Level => Dynamic_Level,
Allow_Alt_Model => False),
EF => Extra_Accessibility (Formal));
-- Normal case
else
Add_Extra_Actual
(Expr => Accessibility_Level
(Expr => Prev,
Level => Dynamic_Level,
Allow_Alt_Model => False),
EF => Extra_Accessibility (Formal));
end if;
end if;
-- Perform the check of 4.6(49) that prevents a null value from being
-- passed as an actual to an access parameter. Note that the check
-- is elided in the common cases of passing an access attribute or
-- access parameter as an actual. Also, we currently don't enforce
-- this check for expander-generated actuals and when -gnatdj is set.
if Ada_Version >= Ada_2005 then
-- Ada 2005 (AI-231): Check null-excluding access types. Note that
-- the intent of 6.4.1(13) is that null-exclusion checks should
-- not be done for 'out' parameters, even though it refers only
-- to constraint checks, and a null_exclusion is not a constraint.
-- Note that AI05-0196-1 corrects this mistake in the RM.
if Is_Access_Type (Etype (Formal))
and then Can_Never_Be_Null (Etype (Formal))
and then Ekind (Formal) /= E_Out_Parameter
and then Nkind (Prev) /= N_Raise_Constraint_Error
and then (Known_Null (Prev)
or else not Can_Never_Be_Null (Etype (Prev)))
then
Install_Null_Excluding_Check (Prev);
end if;
-- Ada_Version < Ada_2005
else
if Ekind (Etype (Formal)) /= E_Anonymous_Access_Type
or else Access_Checks_Suppressed (Subp)
then
null;
elsif Debug_Flag_J then
null;
elsif not Comes_From_Source (Prev) then
null;
elsif Is_Entity_Name (Prev)
and then Ekind (Etype (Prev)) = E_Anonymous_Access_Type
then
null;
elsif Nkind (Prev) in N_Allocator | N_Attribute_Reference then
null;
else
Install_Null_Excluding_Check (Prev);
end if;
end if;
-- Perform appropriate validity checks on parameters that
-- are entities.
if Validity_Checks_On then
if (Ekind (Formal) = E_In_Parameter
and then Validity_Check_In_Params)
or else
(Ekind (Formal) = E_In_Out_Parameter
and then Validity_Check_In_Out_Params)
then
-- If the actual is an indexed component of a packed type (or
-- is an indexed or selected component whose prefix recursively
-- meets this condition), it has not been expanded yet. It will
-- be copied in the validity code that follows, and has to be
-- expanded appropriately, so reanalyze it.
-- What we do is just to unset analyzed bits on prefixes till
-- we reach something that does not have a prefix.
declare
Nod : Node_Id;
begin
Nod := Actual;
while Nkind (Nod) in
N_Indexed_Component | N_Selected_Component
loop
Set_Analyzed (Nod, False);
Nod := Prefix (Nod);
end loop;
end;
Ensure_Valid (Actual);
end if;
end if;
-- For IN OUT and OUT parameters, ensure that subscripts are valid
-- since this is a left side reference. We only do this for calls
-- from the source program since we assume that compiler generated
-- calls explicitly generate any required checks. We also need it
-- only if we are doing standard validity checks, since clearly it is
-- not needed if validity checks are off, and in subscript validity
-- checking mode, all indexed components are checked with a call
-- directly from Expand_N_Indexed_Component.
if Comes_From_Source (Call_Node)
and then Ekind (Formal) /= E_In_Parameter
and then Validity_Checks_On
and then Validity_Check_Default
and then not Validity_Check_Subscripts
then
Check_Valid_Lvalue_Subscripts (Actual);
end if;
-- Mark any scalar OUT parameter that is a simple variable as no
-- longer known to be valid (unless the type is always valid). This
-- reflects the fact that if an OUT parameter is never set in a
-- procedure, then it can become invalid on the procedure return.
if Ekind (Formal) = E_Out_Parameter
and then Is_Entity_Name (Actual)
and then Ekind (Entity (Actual)) = E_Variable
and then not Is_Known_Valid (Etype (Actual))
then
Set_Is_Known_Valid (Entity (Actual), False);
end if;
-- For an OUT or IN OUT parameter, if the actual is an entity, then
-- clear current values, since they can be clobbered. We are probably
-- doing this in more places than we need to, but better safe than
-- sorry when it comes to retaining bad current values.
if Ekind (Formal) /= E_In_Parameter
and then Is_Entity_Name (Actual)
and then Present (Entity (Actual))
then
declare
Ent : constant Entity_Id := Entity (Actual);
Sav : Node_Id;
begin
-- For an OUT or IN OUT parameter that is an assignable entity,
-- we do not want to clobber the Last_Assignment field, since
-- if it is set, it was precisely because it is indeed an OUT
-- or IN OUT parameter. We do reset the Is_Known_Valid flag
-- since the subprogram could have returned in invalid value.
if Is_Assignable (Ent) then
Sav := Last_Assignment (Ent);
Kill_Current_Values (Ent);
Set_Last_Assignment (Ent, Sav);
Set_Is_Known_Valid (Ent, False);
Set_Is_True_Constant (Ent, False);
-- For all other cases, just kill the current values
else
Kill_Current_Values (Ent);
end if;
end;
end if;
-- If the formal is class-wide and the actual is an aggregate, force
-- evaluation so that the back end who does not know about class-wide
-- type, does not generate a temporary of the wrong size.
if not Is_Class_Wide_Type (Etype (Formal)) then
null;
elsif Nkind (Actual) = N_Aggregate
or else (Nkind (Actual) = N_Qualified_Expression
and then Nkind (Expression (Actual)) = N_Aggregate)
then
Force_Evaluation (Actual);
end if;
-- In a remote call, if the formal is of a class-wide type, check
-- that the actual meets the requirements described in E.4(18).
if Remote and then Is_Class_Wide_Type (Etype (Formal)) then
Insert_Action (Actual,
Make_Transportable_Check (Loc,
Duplicate_Subexpr_Move_Checks (Actual)));
end if;
-- Perform invariant checks for all intermediate types in a view
-- conversion after successful return from a call that passes the
-- view conversion as an IN OUT or OUT parameter (RM 7.3.2 (12/3,
-- 13/3, 14/3)). Consider only source conversion in order to avoid
-- generating spurious checks on complex expansion such as object
-- initialization through an extension aggregate.
if Comes_From_Source (Call_Node)
and then Ekind (Formal) /= E_In_Parameter
and then Nkind (Actual) = N_Type_Conversion
then
Add_View_Conversion_Invariants (Formal, Actual);
end if;
-- Generating C the initialization of an allocator is performed by
-- means of individual statements, and hence it must be done before
-- the call.
if Modify_Tree_For_C
and then Nkind (Actual) = N_Allocator
and then Nkind (Expression (Actual)) = N_Qualified_Expression
then
Remove_Side_Effects (Actual);
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 not Present (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
-- assignment might be transformed to a declaration for an unconstrained
-- value if the expression is classwide.
if Nkind (Call_Node) = N_Function_Call
and then Is_Tag_Indeterminate (Call_Node)
and then Is_Entity_Name (Name (Call_Node))
then
declare
Ass : Node_Id := Empty;
begin
if Nkind (Parent (Call_Node)) = N_Assignment_Statement then
Ass := Parent (Call_Node);
elsif Nkind (Parent (Call_Node)) = N_Qualified_Expression
and then Nkind (Parent (Parent (Call_Node))) =
N_Assignment_Statement
then
Ass := Parent (Parent (Call_Node));
elsif Nkind (Parent (Call_Node)) = N_Explicit_Dereference
and then Nkind (Parent (Parent (Call_Node))) =
N_Assignment_Statement
then
Ass := Parent (Parent (Call_Node));
end if;
if Present (Ass)
and then Is_Class