------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- E X P _ C H 6 -- -- -- -- B o d y -- -- -- -- $Revision: 1.1 $ -- -- -- Copyright (C) 1992-2001, 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 2, 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 COPYING. If not, write -- -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- -- MA 02111-1307, USA. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- -- -- ------------------------------------------------------------------------------ with Atree; use Atree; with Checks; use Checks; with Debug; use Debug; with Einfo; use Einfo; with Errout; use Errout; with Elists; use Elists; with Exp_Ch2; use Exp_Ch2; with Exp_Ch3; use Exp_Ch3; with Exp_Ch7; use Exp_Ch7; with Exp_Ch9; use Exp_Ch9; with Exp_Ch11; use Exp_Ch11; 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 Hostparm; use Hostparm; with Inline; use Inline; with Lib; use Lib; with Nlists; use Nlists; with Nmake; use Nmake; with Opt; use Opt; with Restrict; use Restrict; with Rtsfind; use Rtsfind; with Sem; use Sem; with Sem_Ch6; use Sem_Ch6; with Sem_Ch8; use Sem_Ch8; with Sem_Ch12; use Sem_Ch12; with Sem_Ch13; use Sem_Ch13; with Sem_Disp; use Sem_Disp; with Sem_Dist; use Sem_Dist; with Sem_Res; use Sem_Res; with Sem_Util; use Sem_Util; with Sinfo; use Sinfo; with Snames; use Snames; with Stand; use Stand; with Tbuild; use Tbuild; with Uintp; use Uintp; with Validsw; use Validsw; package body Exp_Ch6 is ----------------------- -- Local Subprograms -- ----------------------- 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); -- For each actual of an in-out parameter which is a numeric 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 := T' (Temp); -- -- after the call. Here T' 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 : T' renames A; -- Temp : T := Var; -- omitting expression for out parameter. -- ... -- Var := T' (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. procedure Expand_Inlined_Call (N : Node_Id; Subp : Entity_Id; Orig_Subp : Entity_Id); -- If called subprogram can be inlined by the front-end, retrieve the -- analyzed body, replace formals with actuals and expand call in place. -- Generate thunks for actuals that are expressions, and insert the -- corresponding constant declarations before the call. If the original -- call is to a derived operation, the return type is the one of the -- derived operation, but the body is that of the original, so return -- expressions in the body must be converted to the desired type (which -- is simply not noted in the tree without inline expansion). 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. --------------------------------- -- 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 Typ = 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 (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 : Elist_Id := New_Elmt_List; -- List of globals referenced by body of procedure Call_List : Elist_Id := New_Elmt_List; -- List of recursive calls in body of procedure Shad_List : 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 Is_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; -- 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 Restrictions (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. New_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_Defining_Identifier (Loc, Chars => New_Internal_Name ('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)), 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) is Loc : constant Source_Ptr := Sloc (N); Actual : Node_Id; Formal : Entity_Id; N_Node : Node_Id; Post_Call : List_Id; E_Formal : Entity_Id; procedure Add_Call_By_Copy_Code; -- For In and In-Out parameters, 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. This -- routine also takes care of any constraint checks required for the -- type conversion case (on both the way in and the way out). procedure Add_Packed_Call_By_Copy_Code; -- This is used when the actual involves a reference to an element -- of a packed array, where we can appropriately use a simpler -- approach than the full call by copy code. We just copy the value -- in and out of an apropriate temporary. 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 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. --------------------------- -- Add_Call_By_Copy_Code -- --------------------------- procedure Add_Call_By_Copy_Code is Expr : Node_Id; Init : Node_Id; Temp : Entity_Id; Var : Entity_Id; V_Typ : Entity_Id; Crep : Boolean; begin Temp := Make_Defining_Identifier (Loc, New_Internal_Name ('T')); if Nkind (Actual) = N_Type_Conversion then V_Typ := Etype (Expression (Actual)); Var := Make_Var (Expression (Actual)); Crep := not Same_Representation (Etype (Formal), 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 Ekind (Formal) = E_In_Out_Parameter or else (Is_Array_Type (Etype (Formal)) and then not Is_Constrained (Etype (Formal))) then if Nkind (Actual) = N_Type_Conversion then if Conversion_OK (Actual) then Init := OK_Convert_To (Etype (Formal), New_Occurrence_Of (Var, Loc)); else Init := Convert_To (Etype (Formal), New_Occurrence_Of (Var, Loc)); end if; 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 (Etype (Formal)) or else Is_Bit_Packed_Array (Etype (Expression (Actual)))) then if Conversion_OK (Actual) then Init := OK_Convert_To (Etype (Formal), New_Occurrence_Of (Var, Loc)); else Init := Convert_To (Etype (Formal), New_Occurrence_Of (Var, Loc)); end if; else Init := Empty; end if; N_Node := Make_Object_Declaration (Loc, Defining_Identifier => Temp, Object_Definition => New_Occurrence_Of (Etype (Formal), Loc), 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; -- 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_Reference_To (Temp, Loc)); Analyze (Actual); Append_To (Post_Call, Make_Assignment_Statement (Loc, Name => New_Occurrence_Of (Var, Loc), Expression => Expr)); Set_Assignment_OK (Name (Last (Post_Call))); end Add_Call_By_Copy_Code; ---------------------------------- -- Add_Packed_Call_By_Copy_Code -- ---------------------------------- procedure Add_Packed_Call_By_Copy_Code is Temp : Entity_Id; Incod : Node_Id; Outcod : Node_Id; Lhs : Node_Id; Rhs : Node_Id; begin Reset_Packed_Prefix; -- Prepare to generate code Temp := Make_Defining_Identifier (Loc, New_Internal_Name ('T')); 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 variable. if Ekind (Formal) = E_Out_Parameter then Incod := Empty; end if; Insert_Action (N, Make_Object_Declaration (Loc, Defining_Identifier => Temp, Object_Definition => New_Occurrence_Of (Etype (Formal), Loc), Expression => Incod)); -- 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); -- 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)); end if; end Add_Packed_Call_By_Copy_Code; --------------------------- -- Check_Fortran_Logical -- --------------------------- procedure Check_Fortran_Logical is Logical : 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; -------------- -- 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_Defining_Identifier (Loc, New_Internal_Name ('T')); 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) /= N_Selected_Component and then Nkind (Pfx) /= N_Indexed_Component; Pfx := Prefix (Pfx); end loop; end Reset_Packed_Prefix; -- Start of processing for Expand_Actuals begin Formal := First_Formal (Subp); Actual := First_Actual (N); Post_Call := New_List; while Present (Formal) loop E_Formal := Etype (Formal); 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; Apply_Constraint_Check (Actual, E_Formal); -- Out parameter case. No constraint checks on access type -- RM 6.4.1 (13) 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; -- If argument is a type conversion for a type that is passed -- by copy, then we must pass the parameter by copy. if Nkind (Actual) = N_Type_Conversion and then (Is_Numeric_Type (E_Formal) or else Is_Access_Type (E_Formal) or else Is_Enumeration_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 Same_Representation (Etype (Formal), 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_Packed_Call_By_Copy_Code; -- References to slices of bit packed arrays are expanded elsif Is_Ref_To_Bit_Packed_Slice (Actual) then Add_Call_By_Copy_Code; -- Deal with access types where the actual subtpe and the -- formal subtype are not the same, requiring a check. -- It is necessary to exclude tagged types because of "downward -- conversion" errors and a strange assertion error in namet -- from gnatf in bug 1215-001 ??? elsif Is_Access_Type (E_Formal) and then not Same_Type (E_Formal, Etype (Actual)) and then not Is_Tagged_Type (Designated_Type (E_Formal)) then Add_Call_By_Copy_Code; elsif Is_Entity_Name (Actual) and then Is_Volatile (Entity (Actual)) and then not Is_Scalar_Type (Etype (Entity (Actual))) and then not Is_Volatile (E_Formal) then Add_Call_By_Copy_Code; elsif Nkind (Actual) = N_Indexed_Component and then Is_Entity_Name (Prefix (Actual)) and then Has_Volatile_Components (Entity (Prefix (Actual))) then Add_Call_By_Copy_Code; end if; -- The only processing required for IN parameters is in the packed -- array case, where we expand the 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. -- Similarly, we have to expand slices of packed arrays here else if Nkind (Actual) = N_Indexed_Component and then Is_Packed (Etype (Prefix (Actual))) then Reset_Packed_Prefix; Expand_Packed_Element_Reference (Actual); elsif Is_Ref_To_Bit_Packed_Array (Actual) then Add_Packed_Call_By_Copy_Code; elsif Is_Ref_To_Bit_Packed_Slice (Actual) then declare Typ : constant Entity_Id := Etype (Actual); Ent : constant Entity_Id := Make_Defining_Identifier (Loc, Chars => New_Internal_Name ('T')); Decl : constant Node_Id := Make_Object_Declaration (Loc, Defining_Identifier => Ent, Object_Definition => New_Occurrence_Of (Typ, Loc)); begin Set_No_Initialization (Decl); Insert_Actions (N, New_List ( Decl, Make_Assignment_Statement (Loc, Name => New_Occurrence_Of (Ent, Loc), Expression => Relocate_Node (Actual)))); Rewrite (Actual, New_Occurrence_Of (Ent, Loc)); Analyze_And_Resolve (Actual, Typ); end; end if; end if; Next_Formal (Formal); Next_Actual (Actual); end loop; -- Find right place to put post call stuff if it is present if not Is_Empty_List (Post_Call) then -- If call is not a list member, it must be the triggering -- statement of a triggering alternative or an entry call -- alternative, and we can add the post call stuff to the -- corresponding statement list. if not Is_List_Member (N) then declare P : constant Node_Id := Parent (N); begin pragma Assert (Nkind (P) = N_Triggering_Alternative or else Nkind (P) = N_Entry_Call_Alternative); if Is_Non_Empty_List (Statements (P)) then Insert_List_Before_And_Analyze (First (Statements (P)), Post_Call); else Set_Statements (P, Post_Call); end if; end; -- Otherwise, normal case where N is in a statement sequence, -- just put the post-call stuff after the call statement. else Insert_Actions_After (N, Post_Call); end if; end if; -- The call node itself is re-analyzed in Expand_Call. end Expand_Actuals; ----------------- -- Expand_Call -- ----------------- -- 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. -- Remove optional actuals if First_Optional_Parameter specified. -- 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 (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); Remote : constant Boolean := Is_Remote_Call (N); Subp : Entity_Id; Orig_Subp : Entity_Id := Empty; Parent_Subp : Entity_Id; Parent_Formal : Entity_Id; Actual : Node_Id; Formal : Entity_Id; Prev : Node_Id := Empty; Prev_Orig : Node_Id; Scop : Entity_Id; Extra_Actuals : List_Id := No_List; Cond : Node_Id; 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_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. function Inherited_From_Formal (S : Entity_Id) return Entity_Id; -- Within an instance, a type derived from a non-tagged formal derived -- type inherits from the original parent, not from the actual. This is -- tested in 4723-003. 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. -------------------------- -- 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 (N)); Set_First_Named_Actual (N, Actual_Expr); if No (Prev) then if not Present (Parameter_Associations (N)) then Set_Parameter_Associations (N, New_List); Append (Insert_Param, Parameter_Associations (N)); end if; 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 (N)); end if; Prev := Actual_Expr; end Add_Actual_Parameter; ---------------------- -- 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, N); end if; Append_To (Extra_Actuals, Make_Parameter_Association (Loc, Explicit_Actual_Parameter => Expr, Selector_Name => Make_Identifier (Loc, Chars (EF)))); Analyze_And_Resolve (Expr, Etype (EF)); end Add_Extra_Actual; --------------------------- -- 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 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)) or else not In_Instance then return Empty; else Gen_Par := Generic_Parent_Type (Parent (Par)); 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; -- Start of processing for Expand_Call begin -- Call using access to subprogram with explicit dereference if Nkind (Name (N)) = N_Explicit_Dereference then Subp := Etype (Name (N)); 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 (N)) = N_Selected_Component then Subp := Entity (Selector_Name (Name (N))); 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 (N)) = N_Indexed_Component then Subp := Entity (Selector_Name (Prefix (Name (N)))); Parent_Subp := Empty; -- Normal case else Subp := Entity (Name (N)); 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. if not Restrictions (No_Exception_Handlers) and then Is_RTE (Subp, RE_Raise_Exception) then declare FA : constant Node_Id := Original_Node (First_Actual (N)); 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_Entity (Name (N), Subp); end if; end; end if; if Ekind (Subp) = E_Entry then Parent_Subp := Empty; end if; 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 and collect the -- corresponding actuals in Extra_Actuals. Formal := First_Formal (Subp); Actual := First_Actual (N); while Present (Formal) loop Prev := Actual; Prev_Orig := Original_Node (Prev); -- 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 Ekind (Etype (Prev)) in Private_Kind and then not Has_Discriminants (Base_Type (Etype (Prev))) then Add_Extra_Actual ( New_Occurrence_Of (Standard_False, Loc), Extra_Constrained (Formal)); elsif Is_Constrained (Etype (Formal)) or else not Has_Discriminants (Etype (Prev)) then Add_Extra_Actual ( New_Occurrence_Of (Standard_True, Loc), Extra_Constrained (Formal)); 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 := Prev; begin -- Test for unchecked conversions as well, which can -- occur as out parameter actuals on calls to stream -- procedures. if Nkind (Act_Prev) = N_Type_Conversion or else Nkind (Act_Prev) = N_Unchecked_Type_Conversion then Act_Prev := Expression (Act_Prev); end if; Add_Extra_Actual ( Make_Attribute_Reference (Sloc (Prev), Prefix => Duplicate_Subexpr (Act_Prev, Name_Req => True), Attribute_Name => Name_Constrained), Extra_Constrained (Formal)); end; end if; end if; -- Create possible extra actual for accessibility level if Present (Extra_Accessibility (Formal)) then if Is_Entity_Name (Prev_Orig) then -- When passing an access parameter as the actual to another -- access parameter we need to pass along the actual's own -- associated access level parameter. This is done is we are -- in the scope of the formal access parameter (if this is an -- inlined body the extra formal is irrelevant). if Ekind (Entity (Prev_Orig)) in Formal_Kind and then Ekind (Etype (Prev_Orig)) = E_Anonymous_Access_Type and then In_Open_Scopes (Scope (Entity (Prev_Orig))) then declare Parm_Ent : constant Entity_Id := Param_Entity (Prev_Orig); begin pragma Assert (Present (Parm_Ent)); if Present (Extra_Accessibility (Parm_Ent)) then Add_Extra_Actual ( New_Occurrence_Of (Extra_Accessibility (Parm_Ent), Loc), Extra_Accessibility (Formal)); -- If the actual access parameter does not have an -- associated extra formal providing its scope level, -- then treat the actual as having library-level -- accessibility. else Add_Extra_Actual ( Make_Integer_Literal (Loc, Intval => Scope_Depth (Standard_Standard)), Extra_Accessibility (Formal)); end if; end; -- The actual is a normal access value, so just pass the -- level of the actual's access type. else Add_Extra_Actual ( Make_Integer_Literal (Loc, Intval => Type_Access_Level (Etype (Prev_Orig))), Extra_Accessibility (Formal)); end if; else case Nkind (Prev_Orig) is when N_Attribute_Reference => case Get_Attribute_Id (Attribute_Name (Prev_Orig)) is -- For X'Access, pass on the level of the prefix X when Attribute_Access => Add_Extra_Actual ( Make_Integer_Literal (Loc, Intval => Object_Access_Level (Prefix (Prev_Orig))), Extra_Accessibility (Formal)); -- Treat the unchecked attributes as library-level when Attribute_Unchecked_Access | Attribute_Unrestricted_Access => Add_Extra_Actual ( Make_Integer_Literal (Loc, Intval => Scope_Depth (Standard_Standard)), Extra_Accessibility (Formal)); -- No other cases of attributes returning access -- values that can be passed to access parameters when others => raise Program_Error; end case; -- For allocators we pass the level of the execution of -- the called subprogram, which is one greater than the -- current scope level. when N_Allocator => Add_Extra_Actual ( Make_Integer_Literal (Loc, Scope_Depth (Current_Scope) + 1), Extra_Accessibility (Formal)); -- For other cases we simply pass the level of the -- actual's access type. when others => Add_Extra_Actual ( Make_Integer_Literal (Loc, Intval => Type_Access_Level (Etype (Prev_Orig))), Extra_Accessibility (Formal)); end case; 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 Ekind (Etype (Formal)) /= E_Anonymous_Access_Type or else Suppress_Accessibility_Checks (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) = N_Allocator or else Nkind (Prev) = N_Attribute_Reference then null; -- Suppress null checks when passing to access parameters -- of Java subprograms. (Should this be done for other -- foreign conventions as well ???) elsif Convention (Subp) = Convention_Java then null; else Cond := Make_Op_Eq (Loc, Left_Opnd => Duplicate_Subexpr (Prev), Right_Opnd => Make_Null (Loc)); Insert_Action (Prev, Make_Raise_Constraint_Error (Loc, Cond)); end if; -- Perform apropriate validity checks on parameters if Validity_Checks_On then if Ekind (Formal) = E_In_Parameter and then Validity_Check_In_Params then Ensure_Valid (Actual); elsif Ekind (Formal) = E_In_Out_Parameter and then Validity_Check_In_Out_Params then 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 (N) 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; -- 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_Implicit_If_Statement (N, Condition => Make_Op_Not (Loc, Get_Remotely_Callable (Duplicate_Subexpr (Actual))), Then_Statements => New_List ( Make_Procedure_Call_Statement (Loc, New_Occurrence_Of (RTE (RE_Raise_Program_Error_For_E_4_18), Loc))))); end if; Next_Actual (Actual); Next_Formal (Formal); end loop; -- If we are expanding a rhs of an assignement we need to check if -- tag propagation is needed. This code belongs theorically in Analyze -- Assignment but has to be done earlier (bottom-up) because the -- assignment might be transformed into a declaration for an uncons- -- trained value, if the expression is classwide. if Nkind (N) = N_Function_Call and then Is_Tag_Indeterminate (N) and then Is_Entity_Name (Name (N)) then declare Ass : Node_Id := Empty; begin if Nkind (Parent (N)) = N_Assignment_Statement then Ass := Parent (N); elsif Nkind (Parent (N)) = N_Qualified_Expression and then Nkind (Parent (Parent (N))) = N_Assignment_Statement then Ass := Parent (Parent (N)); end if; if Present (Ass) and then Is_Class_Wide_Type (Etype (Name (Ass))) then Propagate_Tag (Name (Ass), N); return; end if; end; end if; -- Deals with Dispatch_Call if we still have a call, before expanding -- extra actuals since this will be done on the re-analysis of the -- dispatching call. Note that we do not try to shorten the actual -- list for a dispatching call, it would not make sense to do so. -- Expansion of dispatching calls is suppressed when Java_VM, because -- the JVM back end directly handles the generation of dispatching -- calls and would have to undo any expansion to an indirect call. if (Nkind (N) = N_Function_Call or else Nkind (N) = N_Procedure_Call_Statement) and then Present (Controlling_Argument (N)) and then not Java_VM then Expand_Dispatch_Call (N); return; -- Similarly, expand calls to RCI subprograms on which pragma -- All_Calls_Remote applies. The rewriting will be reanalyzed -- later. Do this only when the call comes from source since we do -- not want such a rewritting to occur in expanded code. elsif Is_All_Remote_Call (N) then Expand_All_Calls_Remote_Subprogram_Call (N); -- Similarly, do not add extra actuals for an entry call whose entity -- is a protected procedure, or for an internal protected subprogram -- call, because it will be rewritten as a protected subprogram call -- and reanalyzed (see Expand_Protected_Subprogram_Call). elsif Is_Protected_Type (Scope (Subp)) and then (Ekind (Subp) = E_Procedure or else Ekind (Subp) = E_Function) then null; -- During that loop we gathered the extra actuals (the ones that -- correspond to Extra_Formals), so now they can be appended. else while Is_Non_Empty_List (Extra_Actuals) loop Add_Actual_Parameter (Remove_Head (Extra_Actuals)); end loop; end if; if Ekind (Subp) = E_Procedure or else (Ekind (Subp) = E_Subprogram_Type and then Etype (Subp) = Standard_Void_Type) or else Is_Entry (Subp) then Expand_Actuals (N, Subp); end if; -- If the subprogram is a renaming, or if it is inherited, replace it -- in the call with the name of the actual subprogram being called. -- If this is a dispatching call, the run-time decides what to call. -- The Alias attribute does not apply to entries. if Nkind (N) /= N_Entry_Call_Statement and then No (Controlling_Argument (N)) and then Present (Parent_Subp) then if Present (Inherited_From_Formal (Subp)) then Parent_Subp := Inherited_From_Formal (Subp); else while Present (Alias (Parent_Subp)) loop Parent_Subp := Alias (Parent_Subp); end loop; end if; Set_Entity (Name (N), Parent_Subp); if Is_Abstract (Parent_Subp) and then not In_Instance then Error_Msg_NE ("cannot call abstract subprogram &!", Name (N), Parent_Subp); end if; -- Add an explicit conversion for parameter of the derived type. -- This is only done for scalar and access in-parameters. Others -- have been expanded in expand_actuals. Formal := First_Formal (Subp); Parent_Formal := First_Formal (Parent_Subp); Actual := First_Actual (N); -- It is not clear that conversion is needed for intrinsic -- subprograms, but it certainly is for those that are user- -- defined, and that can be inherited on derivation, namely -- unchecked conversion and deallocation. -- General case needs study ??? if not Is_Intrinsic_Subprogram (Parent_Subp) or else Is_Generic_Instance (Parent_Subp) then while Present (Formal) loop if Etype (Formal) /= Etype (Parent_Formal) and then Is_Scalar_Type (Etype (Formal)) and then Ekind (Formal) = E_In_Parameter then Rewrite (Actual, OK_Convert_To (Etype (Parent_Formal), Relocate_Node (Actual))); Analyze (Actual); Resolve (Actual, Etype (Parent_Formal)); Enable_Range_Check (Actual); elsif Is_Access_Type (Etype (Formal)) and then Base_Type (Etype (Parent_Formal)) /= Base_Type (Etype (Actual)) then if Ekind (Formal) /= E_In_Parameter then Rewrite (Actual, Convert_To (Etype (Parent_Formal), Relocate_Node (Actual))); Analyze (Actual); Resolve (Actual, Etype (Parent_Formal)); elsif Ekind (Etype (Parent_Formal)) = E_Anonymous_Access_Type and then Designated_Type (Etype (Parent_Formal)) /= Designated_Type (Etype (Actual)) and then not Is_Controlling_Formal (Formal) then -- This unchecked conversion is not necessary unless -- inlining is unabled, because in that case the type -- mismatch may become visible in the body about to be -- inlined. Rewrite (Actual, Unchecked_Convert_To (Etype (Parent_Formal), Relocate_Node (Actual))); Analyze (Actual); Resolve (Actual, Etype (Parent_Formal)); end if; end if; Next_Formal (Formal); Next_Formal (Parent_Formal); Next_Actual (Actual); end loop; end if; Orig_Subp := Subp; Subp := Parent_Subp; end if; -- Some more special cases for cases other than explicit dereference if Nkind (Name (N)) /= N_Explicit_Dereference then -- Calls to an enumeration literal are replaced by the literal -- This case occurs only when we have a call to a function that -- is a renaming of an enumeration literal. The normal case of -- a direct reference to an enumeration literal has already been -- been dealt with by Resolve_Call. If the function is itself -- inherited (see 7423-001) the literal of the parent type must -- be explicitly converted to the return type of the function. if Ekind (Subp) = E_Enumeration_Literal then if Base_Type (Etype (Subp)) /= Base_Type (Etype (N)) then Rewrite (N, Convert_To (Etype (N), New_Occurrence_Of (Subp, Loc))); else Rewrite (N, New_Occurrence_Of (Subp, Loc)); Resolve (N, Etype (N)); end if; end if; -- Handle case of access to protected subprogram type else if Ekind (Base_Type (Etype (Prefix (Name (N))))) = E_Access_Protected_Subprogram_Type then -- If this is a call through an access to protected operation, -- the prefix has the form (object'address, operation'access). -- Rewrite as a for other protected calls: the object is the -- first parameter of the list of actuals. declare Call : Node_Id; Parm : List_Id; Nam : Node_Id; Obj : Node_Id; Ptr : Node_Id := Prefix (Name (N)); T : Entity_Id := Equivalent_Type (Base_Type (Etype (Ptr))); D_T : Entity_Id := Designated_Type (Base_Type (Etype (Ptr))); begin Obj := Make_Selected_Component (Loc, Prefix => Unchecked_Convert_To (T, Ptr), Selector_Name => New_Occurrence_Of (First_Entity (T), Loc)); Nam := Make_Selected_Component (Loc, Prefix => Unchecked_Convert_To (T, Ptr), Selector_Name => New_Occurrence_Of ( Next_Entity (First_Entity (T)), Loc)); Nam := Make_Explicit_Dereference (Loc, Nam); if Present (Parameter_Associations (N)) then Parm := Parameter_Associations (N); else Parm := New_List; end if; Prepend (Obj, Parm); if Etype (D_T) = Standard_Void_Type then Call := Make_Procedure_Call_Statement (Loc, Name => Nam, Parameter_Associations => Parm); else Call := Make_Function_Call (Loc, Name => Nam, Parameter_Associations => Parm); end if; Set_First_Named_Actual (Call, First_Named_Actual (N)); Set_Etype (Call, Etype (D_T)); -- We do not re-analyze the call to avoid infinite recursion. -- We analyze separately the prefix and the object, and set -- the checks on the prefix that would otherwise be emitted -- when resolving a call. Rewrite (N, Call); Analyze (Nam); Apply_Access_Check (Nam); Analyze (Obj); return; end; end if; end if; -- If this is a call to an intrinsic subprogram, then perform the -- appropriate expansion to the corresponding tree node and we -- are all done (since after that the call is gone!) if Is_Intrinsic_Subprogram (Subp) then Expand_Intrinsic_Call (N, Subp); return; end if; if Ekind (Subp) = E_Function or else Ekind (Subp) = E_Procedure then if Is_Inlined (Subp) then declare Spec : constant Node_Id := Unit_Declaration_Node (Subp); begin -- Verify that the body to inline has already been seen, -- and that if the body is in the current unit the inlining -- does not occur earlier. This avoids order-of-elaboration -- problems in gigi. if Present (Spec) and then Nkind (Spec) = N_Subprogram_Declaration and then Present (Body_To_Inline (Spec)) and then (In_Extended_Main_Code_Unit (N) or else In_Extended_Main_Code_Unit (Parent (N))) and then (not In_Same_Extended_Unit (Sloc (Body_To_Inline (Spec)), Loc) or else Earlier_In_Extended_Unit (Sloc (Body_To_Inline (Spec)), Loc)) then Expand_Inlined_Call (N, Subp, Orig_Subp); else -- Let the back-end handle it. Add_Inlined_Body (Subp); if Front_End_Inlining and then Nkind (Spec) = N_Subprogram_Declaration and then (In_Extended_Main_Code_Unit (N)) and then No (Body_To_Inline (Spec)) and then not Has_Completion (Subp) and then In_Same_Extended_Unit (Sloc (Spec), Loc) and then Ineffective_Inline_Warnings then Error_Msg_N ("call cannot be inlined before body is seen?", N); end if; end if; end; end if; end if; -- Check for a protected subprogram. This is either an intra-object -- call, or a protected function call. Protected procedure calls are -- rewritten as entry calls and handled accordingly. Scop := Scope (Subp); if Nkind (N) /= N_Entry_Call_Statement and then Is_Protected_Type (Scop) then -- If the call is an internal one, it is rewritten as a call to -- to the corresponding unprotected subprogram. Expand_Protected_Subprogram_Call (N, Subp, Scop); end if; -- Functions returning controlled objects need special attention if Controlled_Type (Etype (Subp)) and then not Is_Return_By_Reference_Type (Etype (Subp)) then Expand_Ctrl_Function_Call (N); end if; -- Test for First_Optional_Parameter, and if so, truncate parameter -- list if there are optional parameters at the trailing end. -- Note we never delete procedures for call via a pointer. if (Ekind (Subp) = E_Procedure or else Ekind (Subp) = E_Function) and then Present (First_Optional_Parameter (Subp)) then declare Last_Keep_Arg : Node_Id; begin -- Last_Keep_Arg will hold the last actual that should be -- retained. If it remains empty at the end, it means that -- all parameters are optional. Last_Keep_Arg := Empty; -- Find first optional parameter, must be present since we -- checked the validity of the parameter before setting it. Formal := First_Formal (Subp); Actual := First_Actual (N); while Formal /= First_Optional_Parameter (Subp) loop Last_Keep_Arg := Actual; Next_Formal (Formal); Next_Actual (Actual); end loop; -- Now we have Formal and Actual pointing to the first -- potentially droppable argument. We can drop all the -- trailing arguments whose actual matches the default. -- Note that we know that all remaining formals have -- defaults, because we checked that this requirement -- was met before setting First_Optional_Parameter. -- We use Fully_Conformant_Expressions to check for identity -- between formals and actuals, which may miss some cases, but -- on the other hand, this is only an optimization (if we fail -- to truncate a parameter it does not affect functionality). -- So if the default is 3 and the actual is 1+2, we consider -- them unequal, which hardly seems worrisome. while Present (Formal) loop if not Fully_Conformant_Expressions (Actual, Default_Value (Formal)) then Last_Keep_Arg := Actual; end if; Next_Formal (Formal); Next_Actual (Actual); end loop; -- If no arguments, delete entire list, this is the easy case if No (Last_Keep_Arg) then while Is_Non_Empty_List (Parameter_Associations (N)) loop Delete_Tree (Remove_Head (Parameter_Associations (N))); end loop; Set_Parameter_Associations (N, No_List); Set_First_Named_Actual (N, Empty); -- Case where at the last retained argument is positional. This -- is also an easy case, since the retained arguments are already -- in the right form, and we don't need to worry about the order -- of arguments that get eliminated. elsif Is_List_Member (Last_Keep_Arg) then while Present (Next (Last_Keep_Arg)) loop Delete_Tree (Remove_Next (Last_Keep_Arg)); end loop; Set_First_Named_Actual (N, Empty); -- This is the annoying case where the last retained argument -- is a named parameter. Since the original arguments are not -- in declaration order, we may have to delete some fairly -- random collection of arguments. else declare Temp : Node_Id; Passoc : Node_Id; Junk : Node_Id; begin -- First step, remove all the named parameters from the -- list (they are still chained using First_Named_Actual -- and Next_Named_Actual, so we have not lost them!) Temp := First (Parameter_Associations (N)); -- Case of all parameters named, remove them all if Nkind (Temp) = N_Parameter_Association then while Is_Non_Empty_List (Parameter_Associations (N)) loop Temp := Remove_Head (Parameter_Associations (N)); end loop; -- Case of mixed positional/named, remove named parameters else while Nkind (Next (Temp)) /= N_Parameter_Association loop Next (Temp); end loop; while Present (Next (Temp)) loop Junk := Remove_Next (Temp); end loop; end if; -- Now we loop through the named parameters, till we get -- to the last one to be retained, adding them to the list. -- Note that the Next_Named_Actual list does not need to be -- touched since we are only reordering them on the actual -- parameter association list. Passoc := Parent (First_Named_Actual (N)); loop Temp := Relocate_Node (Passoc); Append_To (Parameter_Associations (N), Temp); exit when Last_Keep_Arg = Explicit_Actual_Parameter (Passoc); Passoc := Parent (Next_Named_Actual (Passoc)); end loop; Set_Next_Named_Actual (Temp, Empty); loop Temp := Next_Named_Actual (Passoc); exit when No (Temp); Set_Next_Named_Actual (Passoc, Next_Named_Actual (Parent (Temp))); Delete_Tree (Temp); end loop; end; end if; end; end if; end Expand_Call; -------------------------- -- Expand_Inlined_Call -- -------------------------- procedure Expand_Inlined_Call (N : Node_Id; Subp : Entity_Id; Orig_Subp : Entity_Id) is Loc : constant Source_Ptr := Sloc (N); Blk : Node_Id; Bod : Node_Id; Decl : Node_Id; Exit_Lab : Entity_Id := Empty; F : Entity_Id; A : Node_Id; Lab_Decl : Node_Id; Lab_Id : Node_Id; New_A : Node_Id; Num_Ret : Int := 0; Orig_Bod : constant Node_Id := Body_To_Inline (Unit_Declaration_Node (Subp)); Ret_Type : Entity_Id; Targ : Node_Id; Temp : Entity_Id; Temp_Typ : Entity_Id; procedure Make_Exit_Label; -- Build declaration for exit label to be used in Return statements. function Process_Formals (N : Node_Id) return Traverse_Result; -- Replace occurrence of a formal with the corresponding actual, or -- the thunk generated for it. procedure Rewrite_Function_Call (N : Node_Id; Blk : Node_Id); -- If the function body is a single expression, replace call with -- expression, else insert block appropriately. procedure Rewrite_Procedure_Call (N : Node_Id; Blk : Node_Id); -- If procedure body has no local variables, inline body without -- creating block, otherwise rewrite call with block. --------------------- -- Make_Exit_Label -- --------------------- procedure Make_Exit_Label is begin -- Create exit label for subprogram, if one doesn't exist yet. if No (Exit_Lab) then Lab_Id := Make_Identifier (Loc, New_Internal_Name ('L')); Set_Entity (Lab_Id, Make_Defining_Identifier (Loc, Chars (Lab_Id))); Exit_Lab := Make_Label (Loc, Lab_Id); Lab_Decl := Make_Implicit_Label_Declaration (Loc, Defining_Identifier => Entity (Lab_Id), Label_Construct => Exit_Lab); end if; end Make_Exit_Label; --------------------- -- Process_Formals -- --------------------- function Process_Formals (N : Node_Id) return Traverse_Result is A : Entity_Id; E : Entity_Id; Ret : Node_Id; begin if Is_Entity_Name (N) and then Present (Entity (N)) then E := Entity (N); if Is_Formal (E) and then Scope (E) = Subp then A := Renamed_Object (E); if Is_Entity_Name (A) then Rewrite (N, New_Occurrence_Of (Entity (A), Loc)); elsif Nkind (A) = N_Defining_Identifier then Rewrite (N, New_Occurrence_Of (A, Loc)); else -- numeric literal Rewrite (N, New_Copy (A)); end if; end if; return Skip; elsif Nkind (N) = N_Return_Statement then if No (Expression (N)) then Make_Exit_Label; Rewrite (N, Make_Goto_Statement (Loc, Name => New_Copy (Lab_Id))); else if Nkind (Parent (N)) = N_Handled_Sequence_Of_Statements and then Nkind (Parent (Parent (N))) = N_Subprogram_Body then -- function body is a single expression. No need for -- exit label. null; else Num_Ret := Num_Ret + 1; Make_Exit_Label; end if; -- Because of the presence of private types, the views of the -- expression and the context may be different, so place an -- unchecked conversion to the context type to avoid spurious -- errors, eg. when the expression is a numeric literal and -- the context is private. If the expression is an aggregate, -- use a qualified expression, because an aggregate is not a -- legal argument of a conversion. if Nkind (Expression (N)) = N_Aggregate then Ret := Make_Qualified_Expression (Sloc (N), Subtype_Mark => New_Occurrence_Of (Ret_Type, Sloc (N)), Expression => Relocate_Node (Expression (N))); else Ret := Unchecked_Convert_To (Ret_Type, Relocate_Node (Expression (N))); end if; if Nkind (Targ) = N_Defining_Identifier then Rewrite (N, Make_Assignment_Statement (Loc, Name => New_Occurrence_Of (Targ, Loc), Expression => Ret)); else Rewrite (N, Make_Assignment_Statement (Loc, Name => New_Copy (Targ), Expression => Ret)); end if; Set_Assignment_OK (Name (N)); if Present (Exit_Lab) then Insert_After (N, Make_Goto_Statement (Loc, Name => New_Copy (Lab_Id))); end if; end if; return OK; else return OK; end if; end Process_Formals; procedure Replace_Formals is new Traverse_Proc (Process_Formals); --------------------------- -- Rewrite_Function_Call -- --------------------------- procedure Rewrite_Function_Call (N : Node_Id; Blk : Node_Id) is HSS : Node_Id := Handled_Statement_Sequence (Blk); Fst : Node_Id := First (Statements (HSS)); begin -- Optimize simple case: function body is a single return statement, -- which has been expanded into an assignment. if Is_Empty_List (Declarations (Blk)) and then Nkind (Fst) = N_Assignment_Statement and then No (Next (Fst)) then -- The function call may have been rewritten as the temporary -- that holds the result of the call, in which case remove the -- now useless declaration. if Nkind (N) = N_Identifier and then Nkind (Parent (Entity (N))) = N_Object_Declaration then Rewrite (Parent (Entity (N)), Make_Null_Statement (Loc)); end if; Rewrite (N, Expression (Fst)); elsif Nkind (N) = N_Identifier and then Nkind (Parent (Entity (N))) = N_Object_Declaration then -- The block assigns the result of the call to the temporary. Insert_After (Parent (Entity (N)), Blk); elsif Nkind (Parent (N)) = N_Assignment_Statement and then Is_Entity_Name (Name (Parent (N))) then -- replace assignment with the block. Rewrite (Parent (N), Blk); elsif Nkind (Parent (N)) = N_Object_Declaration then Set_Expression (Parent (N), Empty); Insert_After (Parent (N), Blk); end if; end Rewrite_Function_Call; ---------------------------- -- Rewrite_Procedure_Call -- ---------------------------- procedure Rewrite_Procedure_Call (N : Node_Id; Blk : Node_Id) is HSS : Node_Id := Handled_Statement_Sequence (Blk); begin if Is_Empty_List (Declarations (Blk)) then Insert_List_After (N, Statements (HSS)); Rewrite (N, Make_Null_Statement (Loc)); else Rewrite (N, Blk); end if; end Rewrite_Procedure_Call; -- Start of processing for Expand_Inlined_Call begin if Nkind (Orig_Bod) = N_Defining_Identifier then -- Subprogram is a renaming_as_body. Calls appearing after the -- renaming can be replaced with calls to the renamed entity -- directly, because the subprograms are subtype conformant. Set_Name (N, New_Occurrence_Of (Orig_Bod, Loc)); return; end if; -- Use generic machinery to copy body of inlined subprogram, as if it -- were an instantiation, resetting source locations appropriately, so -- that nested inlined calls appear in the main unit. Save_Env (Subp, Empty); Set_Copied_Sloc (N, Defining_Entity (Orig_Bod)); Bod := Copy_Generic_Node (Orig_Bod, Empty, Instantiating => True); Blk := Make_Block_Statement (Loc, Declarations => Declarations (Bod), Handled_Statement_Sequence => Handled_Statement_Sequence (Bod)); if No (Declarations (Bod)) then Set_Declarations (Blk, New_List); end if; -- If this is a derived function, establish the proper return type. if Present (Orig_Subp) and then Orig_Subp /= Subp then Ret_Type := Etype (Orig_Subp); else Ret_Type := Etype (Subp); end if; F := First_Formal (Subp); A := First_Actual (N); -- Create temporaries for the actuals that are expressions, or that -- are scalars and require copying to preserve semantics. while Present (F) loop if Present (Renamed_Object (F)) then Error_Msg_N (" cannot inline call to recursive subprogram", N); return; end if; -- If the argument may be a controlling argument in a call within -- the inlined body, we must preserve its classwide nature to -- insure that dynamic dispatching take place subsequently. -- If the formal has a constraint it must be preserved to retain -- the semantics of the body. if Is_Class_Wide_Type (Etype (F)) or else (Is_Access_Type (Etype (F)) and then Is_Class_Wide_Type (Designated_Type (Etype (F)))) then Temp_Typ := Etype (F); elsif Base_Type (Etype (F)) = Base_Type (Etype (A)) and then Etype (F) /= Base_Type (Etype (F)) then Temp_Typ := Etype (F); else Temp_Typ := Etype (A); end if; if (not Is_Entity_Name (A) and then Nkind (A) /= N_Integer_Literal and then Nkind (A) /= N_Real_Literal) or else Is_Scalar_Type (Etype (A)) then Temp := Make_Defining_Identifier (Loc, Chars => New_Internal_Name ('C')); -- If the actual for an in/in-out parameter is a view conversion, -- make it into an unchecked conversion, given that an untagged -- type conversion is not a proper object for a renaming. -- In-out conversions that involve real conversions have already -- been transformed in Expand_Actuals. if Nkind (A) = N_Type_Conversion and then (Ekind (F) = E_In_Out_Parameter or else not Is_Tagged_Type (Etype (F))) then New_A := Make_Unchecked_Type_Conversion (Loc, Subtype_Mark => New_Occurrence_Of (Etype (F), Loc), Expression => Relocate_Node (Expression (A))); elsif Etype (F) /= Etype (A) then New_A := Unchecked_Convert_To (Etype (F), Relocate_Node (A)); Temp_Typ := Etype (F); else New_A := Relocate_Node (A); end if; Set_Sloc (New_A, Sloc (N)); if Ekind (F) = E_In_Parameter and then not Is_Limited_Type (Etype (A)) then Decl := Make_Object_Declaration (Loc, Defining_Identifier => Temp, Constant_Present => True, Object_Definition => New_Occurrence_Of (Temp_Typ, Loc), Expression => New_A); else Decl := Make_Object_Renaming_Declaration (Loc, Defining_Identifier => Temp, Subtype_Mark => New_Occurrence_Of (Temp_Typ, Loc), Name => New_A); end if; Prepend (Decl, Declarations (Blk)); Set_Renamed_Object (F, Temp); else if Etype (F) /= Etype (A) then Set_Renamed_Object (F, Unchecked_Convert_To (Etype (F), Relocate_Node (A))); else Set_Renamed_Object (F, A); end if; end if; Next_Formal (F); Next_Actual (A); end loop; -- Establish target of function call. If context is not assignment or -- declaration, create a temporary as a target. The declaration for -- the temporary may be subsequently optimized away if the body is a -- single expression, or if the left-hand side of the assignment is -- simple enough. if Ekind (Subp) = E_Function then if Nkind (Parent (N)) = N_Assignment_Statement and then Is_Entity_Name (Name (Parent (N))) then Targ := Name (Parent (N)); else -- Replace call with temporary, and create its declaration. Temp := Make_Defining_Identifier (Loc, New_Internal_Name ('C')); Decl := Make_Object_Declaration (Loc, Defining_Identifier => Temp, Object_Definition => New_Occurrence_Of (Ret_Type, Loc)); Set_No_Initialization (Decl); Insert_Action (N, Decl); Rewrite (N, New_Occurrence_Of (Temp, Loc)); Targ := Temp; end if; end if; -- Traverse the tree and replace formals with actuals or their thunks. -- Attach block to tree before analysis and rewriting. Replace_Formals (Blk); Set_Parent (Blk, N); if Present (Exit_Lab) then -- If the body was a single expression, the single return statement -- and the corresponding label are useless. if Num_Ret = 1 and then Nkind (Last (Statements (Handled_Statement_Sequence (Blk)))) = N_Goto_Statement then Remove (Last (Statements (Handled_Statement_Sequence (Blk)))); else Append (Lab_Decl, (Declarations (Blk))); Append (Exit_Lab, Statements (Handled_Statement_Sequence (Blk))); end if; end if; -- Analyze Blk with In_Inlined_Body set, to avoid spurious errors on -- conflicting private views that Gigi would ignore. declare I_Flag : constant Boolean := In_Inlined_Body; begin In_Inlined_Body := True; Analyze (Blk); In_Inlined_Body := I_Flag; end; if Ekind (Subp) = E_Procedure then Rewrite_Procedure_Call (N, Blk); else Rewrite_Function_Call (N, Blk); end if; Restore_Env; -- Cleanup mapping between formals and actuals, for other expansions. F := First_Formal (Subp); while Present (F) loop Set_Renamed_Object (F, Empty); Next_Formal (F); end loop; end Expand_Inlined_Call; ---------------------------- -- Expand_N_Function_Call -- ---------------------------- procedure Expand_N_Function_Call (N : Node_Id) is Typ : constant Entity_Id := Etype (N); function Returned_By_Reference return Boolean; -- If the return type is returned through the secondary stack. i.e. -- by reference, we don't want to create a temporary to force stack -- checking. function Returned_By_Reference return Boolean is S : Entity_Id := Current_Scope; begin if Is_Return_By_Reference_Type (Typ) then return True; elsif Nkind (Parent (N)) /= N_Return_Statement then return False; elsif Requires_Transient_Scope (Typ) then -- Verify that the return type of the enclosing function has -- the same constrained status as that of the expression. while Ekind (S) /= E_Function loop S := Scope (S); end loop; return Is_Constrained (Typ) = Is_Constrained (Etype (S)); else return False; end if; end Returned_By_Reference; -- Start of processing for Expand_N_Function_Call begin -- A special check. If stack checking is enabled, and the return type -- might generate a large temporary, and the call is not the right -- side of an assignment, then generate an explicit temporary. We do -- this because otherwise gigi may generate a large temporary on the -- fly and this can cause trouble with stack checking. if May_Generate_Large_Temp (Typ) and then Nkind (Parent (N)) /= N_Assignment_Statement and then (Nkind (Parent (N)) /= N_Object_Declaration or else Expression (Parent (N)) /= N) and then not Returned_By_Reference then -- Note: it might be thought that it would be OK to use a call to -- Force_Evaluation here, but that's not good enough, because that -- results in a 'Reference construct that may still need a temporary. declare Loc : constant Source_Ptr := Sloc (N); Temp_Obj : constant Entity_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('F')); Temp_Typ : Entity_Id := Typ; Decl : Node_Id; A : Node_Id; F : Entity_Id; Proc : Entity_Id; begin if Is_Tagged_Type (Typ) and then Present (Controlling_Argument (N)) then if Nkind (Parent (N)) /= N_Procedure_Call_Statement and then Nkind (Parent (N)) /= N_Function_Call then -- If this is a tag-indeterminate call, the object must -- be classwide. if Is_Tag_Indeterminate (N) then Temp_Typ := Class_Wide_Type (Typ); end if; else -- If this is a dispatching call that is itself the -- controlling argument of an enclosing call, the nominal -- subtype of the object that replaces it must be classwide, -- so that dispatching will take place properly. If it is -- not a controlling argument, the object is not classwide. Proc := Entity (Name (Parent (N))); F := First_Formal (Proc); A := First_Actual (Parent (N)); while A /= N loop Next_Formal (F); Next_Actual (A); end loop; if Is_Controlling_Formal (F) then Temp_Typ := Class_Wide_Type (Typ); end if; end if; end if; Decl := Make_Object_Declaration (Loc, Defining_Identifier => Temp_Obj, Object_Definition => New_Occurrence_Of (Temp_Typ, Loc), Constant_Present => True, Expression => Relocate_Node (N)); Set_Assignment_OK (Decl); Insert_Actions (N, New_List (Decl)); Rewrite (N, New_Occurrence_Of (Temp_Obj, Loc)); end; -- Normal case, expand the call else Expand_Call (N); end if; end Expand_N_Function_Call; --------------------------------------- -- Expand_N_Procedure_Call_Statement -- --------------------------------------- procedure Expand_N_Procedure_Call_Statement (N : Node_Id) is begin Expand_Call (N); end Expand_N_Procedure_Call_Statement; ------------------------------ -- Expand_N_Subprogram_Body -- ------------------------------ -- Add poll call if ATC polling is enabled -- Add return statement if last statement in body is not a return -- statement (this makes things easier on Gigi which does not want -- to have to handle a missing return). -- Add call to Activate_Tasks if body is a task activator -- Deal with possible detection of infinite recursion -- Eliminate body completely if convention stubbed -- Encode entity names within body, since we will not need to reference -- these entities any longer in the front end. -- Initialize scalar out parameters if Initialize/Normalize_Scalars procedure Expand_N_Subprogram_Body (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); H : constant Node_Id := Handled_Statement_Sequence (N); Spec_Id : Entity_Id; Except_H : Node_Id; Scop : Entity_Id; Dec : Node_Id; Next_Op : Node_Id; L : List_Id; procedure Add_Return (S : List_Id); -- Append a return statement to the statement sequence S if the last -- statement is not already a return or a goto statement. Note that -- the latter test is not critical, it does not matter if we add a -- few extra returns, since they get eliminated anyway later on. ---------------- -- Add_Return -- ---------------- procedure Add_Return (S : List_Id) is Last_S : constant Node_Id := Last (S); -- Get original node, in case raise has been rewritten begin if not Is_Transfer (Last_S) then Append_To (S, Make_Return_Statement (Sloc (Last_S))); end if; end Add_Return; -- Start of processing for Expand_N_Subprogram_Body begin -- Set L to either the list of declarations if present, or -- to the list of statements if no declarations are present. -- This is used to insert new stuff at the start. if Is_Non_Empty_List (Declarations (N)) then L := Declarations (N); else L := Statements (Handled_Statement_Sequence (N)); end if; -- Need poll on entry to subprogram if polling enabled. We only -- do this for non-empty subprograms, since it does not seem -- necessary to poll for a dummy null subprogram. if Is_Non_Empty_List (L) then Generate_Poll_Call (First (L)); end if; -- Find entity for subprogram if Present (Corresponding_Spec (N)) then Spec_Id := Corresponding_Spec (N); else Spec_Id := Defining_Entity (N); end if; -- Initialize any scalar OUT args if Initialize/Normalize_Scalars if Init_Or_Norm_Scalars and then Is_Subprogram (Spec_Id) then declare F : Entity_Id := First_Formal (Spec_Id); V : constant Boolean := Validity_Checks_On; begin -- We turn off validity checking, since we do not want any -- check on the initializing value itself (which we know -- may well be invalid!) Validity_Checks_On := False; -- Loop through formals while Present (F) loop if Is_Scalar_Type (Etype (F)) and then Ekind (F) = E_Out_Parameter then Insert_Before_And_Analyze (First (L), Make_Assignment_Statement (Loc, Name => New_Occurrence_Of (F, Loc), Expression => Get_Simple_Init_Val (Etype (F), Loc))); end if; Next_Formal (F); end loop; Validity_Checks_On := V; end; end if; -- Clear out statement list for stubbed procedure if Present (Corresponding_Spec (N)) then Set_Elaboration_Flag (N, Spec_Id); if Convention (Spec_Id) = Convention_Stubbed or else Is_Eliminated (Spec_Id) then Set_Declarations (N, Empty_List); Set_Handled_Statement_Sequence (N, Make_Handled_Sequence_Of_Statements (Loc, Statements => New_List ( Make_Null_Statement (Loc)))); return; end if; end if; Scop := Scope (Spec_Id); -- Returns_By_Ref flag is normally set when the subprogram is frozen -- but subprograms with no specs are not frozen declare Typ : constant Entity_Id := Etype (Spec_Id); Utyp : constant Entity_Id := Underlying_Type (Typ); begin if not Acts_As_Spec (N) and then Nkind (Parent (Parent (Spec_Id))) /= N_Subprogram_Body_Stub then null; elsif Is_Return_By_Reference_Type (Typ) then Set_Returns_By_Ref (Spec_Id); elsif Present (Utyp) and then Controlled_Type (Utyp) then Set_Returns_By_Ref (Spec_Id); end if; end; -- For a procedure, we add a return for all possible syntactic ends -- of the subprogram. Note that reanalysis is not necessary in this -- case since it would require a lot of work and accomplish nothing. if Ekind (Spec_Id) = E_Procedure or else Ekind (Spec_Id) = E_Generic_Procedure then Add_Return (Statements (H)); if Present (Exception_Handlers (H)) then Except_H := First_Non_Pragma (Exception_Handlers (H)); while Present (Except_H) loop Add_Return (Statements (Except_H)); Next_Non_Pragma (Except_H); end loop; end if; -- For a function, we must deal with the case where there is at -- least one missing return. What we do is to wrap the entire body -- of the function in a block: -- begin -- ... -- end; -- becomes -- begin -- begin -- ... -- end; -- raise Program_Error; -- end; -- This approach is necessary because the raise must be signalled -- to the caller, not handled by any local handler (RM 6.4(11)). -- Note: we do not need to analyze the constructed sequence here, -- since it has no handler, and an attempt to analyze the handled -- statement sequence twice is risky in various ways (e.g. the -- issue of expanding cleanup actions twice). elsif Has_Missing_Return (Spec_Id) then declare Hloc : constant Source_Ptr := Sloc (H); Blok : constant Node_Id := Make_Block_Statement (Hloc, Handled_Statement_Sequence => H); Rais : constant Node_Id := Make_Raise_Program_Error (Hloc); begin Set_Handled_Statement_Sequence (N, Make_Handled_Sequence_Of_Statements (Hloc, Statements => New_List (Blok, Rais))); New_Scope (Spec_Id); Analyze (Blok); Analyze (Rais); Pop_Scope; end; end if; -- Add discriminal renamings to protected subprograms. -- Install new discriminals for expansion of the next -- subprogram of this protected type, if any. if Is_List_Member (N) and then Present (Parent (List_Containing (N))) and then Nkind (Parent (List_Containing (N))) = N_Protected_Body then Add_Discriminal_Declarations (Declarations (N), Scop, Name_uObject, Loc); Add_Private_Declarations (Declarations (N), Scop, Name_uObject, Loc); -- Associate privals and discriminals with the next protected -- operation body to be expanded. These are used to expand -- references to private data objects and discriminants, -- respectively. Next_Op := Next_Protected_Operation (N); if Present (Next_Op) then Dec := Parent (Base_Type (Scop)); Set_Privals (Dec, Next_Op, Loc); Set_Discriminals (Dec, Next_Op, Loc); end if; end if; -- If subprogram contains a parameterless recursive call, then we may -- have an infinite recursion, so see if we can generate code to check -- for this possibility if storage checks are not suppressed. if Ekind (Spec_Id) = E_Procedure and then Has_Recursive_Call (Spec_Id) and then not Storage_Checks_Suppressed (Spec_Id) then Detect_Infinite_Recursion (N, Spec_Id); end if; -- Finally, if we are in Normalize_Scalars mode, then any scalar out -- parameters must be initialized to the appropriate default value. if Ekind (Spec_Id) = E_Procedure and then Normalize_Scalars then declare Floc : Source_Ptr; Formal : Entity_Id; Stm : Node_Id; begin Formal := First_Formal (Spec_Id); while Present (Formal) loop Floc := Sloc (Formal); if Ekind (Formal) = E_Out_Parameter and then Is_Scalar_Type (Etype (Formal)) then Stm := Make_Assignment_Statement (Floc, Name => New_Occurrence_Of (Formal, Floc), Expression => Get_Simple_Init_Val (Etype (Formal), Floc)); Prepend (Stm, Declarations (N)); Analyze (Stm); end if; Next_Formal (Formal); end loop; end; end if; -- If the subprogram does not have pending instantiations, then we -- must generate the subprogram descriptor now, since the code for -- the subprogram is complete, and this is our last chance. However -- if there are pending instantiations, then the code is not -- complete, and we will delay the generation. if Is_Subprogram (Spec_Id) and then not Delay_Subprogram_Descriptors (Spec_Id) then Generate_Subprogram_Descriptor_For_Subprogram (N, Spec_Id); end if; -- Set to encode entity names in package body before gigi is called Qualify_Entity_Names (N); end Expand_N_Subprogram_Body; ----------------------------------- -- Expand_N_Subprogram_Body_Stub -- ----------------------------------- procedure Expand_N_Subprogram_Body_Stub (N : Node_Id) is begin if Present (Corresponding_Body (N)) then Expand_N_Subprogram_Body ( Unit_Declaration_Node (Corresponding_Body (N))); end if; end Expand_N_Subprogram_Body_Stub; ------------------------------------- -- Expand_N_Subprogram_Declaration -- ------------------------------------- -- The first task to be performed is the construction of default -- expression functions for in parameters with default values. These -- are parameterless inlined functions that are used to evaluate -- default expressions that are more complicated than simple literals -- or identifiers referencing constants and variables. -- If the declaration appears within a protected body, it is a private -- operation of the protected type. We must create the corresponding -- protected subprogram an associated formals. For a normal protected -- operation, this is done when expanding the protected type declaration. procedure Expand_N_Subprogram_Declaration (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); Subp : Entity_Id := Defining_Entity (N); Scop : Entity_Id := Scope (Subp); Prot_Sub : Entity_Id; Prot_Bod : Node_Id; begin -- Deal with case of protected subprogram if Is_List_Member (N) and then Present (Parent (List_Containing (N))) and then Nkind (Parent (List_Containing (N))) = N_Protected_Body and then Is_Protected_Type (Scop) then if No (Protected_Body_Subprogram (Subp)) then Prot_Sub := Make_Subprogram_Declaration (Loc, Specification => Build_Protected_Sub_Specification (N, Scop, Unprotected => True)); -- The protected subprogram is declared outside of the protected -- body. Given that the body has frozen all entities so far, we -- freeze the subprogram explicitly. If the body is a subunit, -- the insertion point is before the stub in the parent. Prot_Bod := Parent (List_Containing (N)); if Nkind (Parent (Prot_Bod)) = N_Subunit then Prot_Bod := Corresponding_Stub (Parent (Prot_Bod)); end if; Insert_Before (Prot_Bod, Prot_Sub); New_Scope (Scope (Scop)); Analyze (Prot_Sub); Set_Protected_Body_Subprogram (Subp, Defining_Unit_Name (Specification (Prot_Sub))); Pop_Scope; end if; end if; end Expand_N_Subprogram_Declaration; --------------------------------------- -- Expand_Protected_Object_Reference -- --------------------------------------- function Expand_Protected_Object_Reference (N : Node_Id; Scop : Entity_Id) return Node_Id is Loc : constant Source_Ptr := Sloc (N); Corr : Entity_Id; Rec : Node_Id; Param : Entity_Id; Proc : Entity_Id; begin Rec := Make_Identifier (Loc, Name_uObject); Set_Etype (Rec, Corresponding_Record_Type (Scop)); -- Find enclosing protected operation, and retrieve its first -- parameter, which denotes the enclosing protected object. -- If the enclosing operation is an entry, we are immediately -- within the protected body, and we can retrieve the object -- from the service entries procedure. A barrier function has -- has the same signature as an entry. A barrier function is -- compiled within the protected object, but unlike protected -- operations its never needs locks, so that its protected body -- subprogram points to itself. Proc := Current_Scope; while Present (Proc) and then Scope (Proc) /= Scop loop Proc := Scope (Proc); end loop; Corr := Protected_Body_Subprogram (Proc); if No (Corr) then -- Previous error left expansion incomplete. -- Nothing to do on this call. return Empty; end if; Param := Defining_Identifier (First (Parameter_Specifications (Parent (Corr)))); if Is_Subprogram (Proc) and then Proc /= Corr then -- Protected function or procedure. Set_Entity (Rec, Param); -- Rec is a reference to an entity which will not be in scope -- when the call is reanalyzed, and needs no further analysis. Set_Analyzed (Rec); else -- Entry or barrier function for entry body. -- The first parameter of the entry body procedure is a -- pointer to the object. We create a local variable -- of the proper type, duplicating what is done to define -- _object later on. declare Decls : List_Id; Obj_Ptr : Entity_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('T')); begin Decls := New_List ( Make_Full_Type_Declaration (Loc, Defining_Identifier => Obj_Ptr, Type_Definition => Make_Access_To_Object_Definition (Loc, Subtype_Indication => New_Reference_To (Corresponding_Record_Type (Scop), Loc)))); Insert_Actions (N, Decls); Insert_Actions (N, Freeze_Entity (Obj_Ptr, Sloc (N))); Rec := Make_Explicit_Dereference (Loc, Unchecked_Convert_To (Obj_Ptr, New_Occurrence_Of (Param, Loc))); -- Analyze new actual. Other actuals in calls are already -- analyzed and the list of actuals is not renalyzed after -- rewriting. Set_Parent (Rec, N); Analyze (Rec); end; end if; return Rec; end Expand_Protected_Object_Reference; -------------------------------------- -- Expand_Protected_Subprogram_Call -- -------------------------------------- procedure Expand_Protected_Subprogram_Call (N : Node_Id; Subp : Entity_Id; Scop : Entity_Id) is Rec : Node_Id; begin -- If the protected object is not an enclosing scope, this is -- an inter-object function call. Inter-object procedure -- calls are expanded by Exp_Ch9.Build_Simple_Entry_Call. -- The call is intra-object only if the subprogram being -- called is in the protected body being compiled, and if the -- protected object in the call is statically the enclosing type. -- The object may be an component of some other data structure, -- in which case this must be handled as an inter-object call. if not In_Open_Scopes (Scop) or else not Is_Entity_Name (Name (N)) then if Nkind (Name (N)) = N_Selected_Component then Rec := Prefix (Name (N)); else pragma Assert (Nkind (Name (N)) = N_Indexed_Component); Rec := Prefix (Prefix (Name (N))); end if; Build_Protected_Subprogram_Call (N, Name => New_Occurrence_Of (Subp, Sloc (N)), Rec => Convert_Concurrent (Rec, Etype (Rec)), External => True); else Rec := Expand_Protected_Object_Reference (N, Scop); if No (Rec) then return; end if; Build_Protected_Subprogram_Call (N, Name => Name (N), Rec => Rec, External => False); end if; Analyze (N); -- If it is a function call it can appear in elaboration code and -- the called entity must be frozen here. if Ekind (Subp) = E_Function then Freeze_Expression (Name (N)); end if; end Expand_Protected_Subprogram_Call; ----------------------- -- Freeze_Subprogram -- ----------------------- procedure Freeze_Subprogram (N : Node_Id) is E : constant Entity_Id := Entity (N); begin -- When a primitive is frozen, enter its name in the corresponding -- dispatch table. If the DTC_Entity field is not set this is an -- overridden primitive that can be ignored. We suppress the -- initialization of the dispatch table entry when Java_VM because -- the dispatching mechanism is handled internally by the JVM. if Is_Dispatching_Operation (E) and then not Is_Abstract (E) and then Present (DTC_Entity (E)) and then not Is_CPP_Class (Scope (DTC_Entity (E))) and then not Java_VM then Check_Overriding_Operation (E); Insert_After (N, Fill_DT_Entry (Sloc (N), E)); end if; -- Mark functions that return by reference. Note that it cannot be -- part of the normal semantic analysis of the spec since the -- underlying returned type may not be known yet (for private types) declare Typ : constant Entity_Id := Etype (E); Utyp : constant Entity_Id := Underlying_Type (Typ); begin if Is_Return_By_Reference_Type (Typ) then Set_Returns_By_Ref (E); elsif Present (Utyp) and then Controlled_Type (Utyp) then Set_Returns_By_Ref (E); end if; end; end Freeze_Subprogram; end Exp_Ch6;