| ------------------------------------------------------------------------------ |
| -- -- |
| -- 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_Wide_Type (Etype (Name (Ass))) |
|