X-Git-Url: http://git.sourceforge.jp/view?a=blobdiff_plain;f=gcc%2Fada%2Fexp_ch6.adb;h=304919fb19054167f11ef5148bf78c52a4deeb99;hb=a42bb2562af9c39c854ae03846cd408b5d5140f2;hp=6a54343c67820940543ec011e603c9e72416899c;hpb=698d81ad3d737d882aab66d64cf53bf741d09546;p=pf3gnuchains%2Fgcc-fork.git diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index 6a54343c678..304919fb190 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2004, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2006, 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- -- @@ -16,8 +16,8 @@ -- 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. -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- @@ -34,7 +34,6 @@ 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; @@ -51,6 +50,7 @@ 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_Ch6; use Sem_Ch6; @@ -59,6 +59,7 @@ 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_Mech; use Sem_Mech; with Sem_Res; use Sem_Res; with Sem_Util; use Sem_Util; with Sinfo; use Sinfo; @@ -98,10 +99,11 @@ package body Exp_Ch6 is -- 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: + -- 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); + -- Temp : T[ := T (A)]; -- -- prior to the call. Then we replace the actual with a reference to Temp, -- and append the assignment: @@ -122,6 +124,9 @@ package body Exp_Ch6 is -- -- For all parameter modes, actuals that denote components and slices -- of packed arrays are expanded into suitable temporaries. + -- + -- For non-scalar objects that are possibly unaligned, add call by copy + -- code (copy in for IN and IN OUT, copy out for OUT and IN OUT). procedure Expand_Inlined_Call (N : Node_Id; @@ -167,10 +172,10 @@ package body Exp_Ch6 is 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. + -- 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 @@ -206,12 +211,12 @@ package body Exp_Ch6 is -- 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. + -- 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. + -- 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 @@ -354,11 +359,11 @@ package body Exp_Ch6 is -- 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. + -- 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 + if Restriction_Active (No_Implicit_Conditionals) then return; end if; @@ -367,9 +372,9 @@ package body Exp_Ch6 is 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!) + -- 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; @@ -377,15 +382,15 @@ package body Exp_Ch6 is -- 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 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. + -- 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); @@ -396,10 +401,10 @@ package body Exp_Ch6 is 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. + -- 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, @@ -500,11 +505,10 @@ package body Exp_Ch6 is -- 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 appropriate temporary. + procedure Add_Simple_Call_By_Copy_Code; + -- 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. procedure Check_Fortran_Logical; -- A value of type Logical that is passed through a formal parameter @@ -512,6 +516,14 @@ package body Exp_Ch6 is -- 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 actual is of a by_reference type then + -- the program is illegal (this can only happen in the presence of + -- rep. clauses that force an incorrect alignment). If the formal is + -- a by_reference parameter imposed by a DEC pragma, emit a warning to + -- the effect 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 @@ -528,16 +540,32 @@ package body Exp_Ch6 is --------------------------- 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; + Expr : Node_Id; + Init : Node_Id; + Temp : Entity_Id; + Indic : Node_Id; + Var : Entity_Id; + F_Typ : constant Entity_Id := Etype (Formal); + V_Typ : Entity_Id; + Crep : Boolean; begin + if not Is_Legal_Copy then + return; + end if; + Temp := Make_Defining_Identifier (Loc, New_Internal_Name ('T')); + -- 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 (Etype (Formal), Loc); + end if; + if Nkind (Actual) = N_Type_Conversion then V_Typ := Etype (Expression (Actual)); @@ -547,7 +575,7 @@ package body Exp_Ch6 is Var := Make_Var (Expression (Actual)); Crep := not Same_Representation - (Etype (Formal), Etype (Expression (Actual))); + (F_Typ, Etype (Expression (Actual))); else V_Typ := Etype (Actual); @@ -559,19 +587,48 @@ package body Exp_Ch6 is -- 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 Ekind (Formal) = E_In_Out_Parameter - or else (Is_Array_Type (Etype (Formal)) - and then - not Is_Constrained (Etype (Formal))) + or else (Is_Array_Type (F_Typ) and then not Is_Constrained (F_Typ)) then if Nkind (Actual) = N_Type_Conversion then if Conversion_OK (Actual) then - Init := OK_Convert_To - (Etype (Formal), New_Occurrence_Of (Var, Loc)); + Init := OK_Convert_To (F_Typ, New_Occurrence_Of (Var, Loc)); else - Init := Convert_To - (Etype (Formal), New_Occurrence_Of (Var, Loc)); + 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; @@ -584,17 +641,19 @@ package body Exp_Ch6 is elsif Ekind (Formal) = E_Out_Parameter and then Nkind (Actual) = N_Type_Conversion - and then (Is_Bit_Packed_Array (Etype (Formal)) + 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 (Etype (Formal), New_Occurrence_Of (Var, Loc)); + Init := OK_Convert_To (F_Typ, New_Occurrence_Of (Var, Loc)); else - Init := - Convert_To (Etype (Formal), New_Occurrence_Of (Var, Loc)); + Init := Convert_To (F_Typ, New_Occurrence_Of (Var, Loc)); end if; + + elsif Ekind (Formal) = E_In_Parameter then + Init := New_Occurrence_Of (Var, Loc); + else Init := Empty; end if; @@ -602,9 +661,8 @@ package body Exp_Ch6 is N_Node := Make_Object_Declaration (Loc, Defining_Identifier => Temp, - Object_Definition => - New_Occurrence_Of (Etype (Formal), Loc), - Expression => Init); + Object_Definition => Indic, + Expression => Init); Set_Assignment_OK (N_Node); Insert_Action (N, N_Node); @@ -640,6 +698,11 @@ package body Exp_Ch6 is -- 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); + -- If type conversion, use reverse conversion on exit if Nkind (Actual) = N_Type_Conversion then @@ -665,38 +728,101 @@ package body Exp_Ch6 is end Add_Call_By_Copy_Code; ---------------------------------- - -- Add_Packed_Call_By_Copy_Code -- + -- Add_Simple_Call_By_Copy_Code -- ---------------------------------- - procedure Add_Packed_Call_By_Copy_Code is + procedure Add_Simple_Call_By_Copy_Code is Temp : Entity_Id; + Decl : Node_Id; Incod : Node_Id; Outcod : Node_Id; Lhs : Node_Id; Rhs : Node_Id; + Indic : Node_Id; + F_Typ : constant Entity_Id := Etype (Formal); begin - Reset_Packed_Prefix; + if not Is_Legal_Copy then + return; + 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 (Etype (Formal), Loc); + end if; -- Prepare to generate code + Reset_Packed_Prefix; + 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. + -- 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 (Etype (Formal)) then + Indic := New_Occurrence_Of (Etype (Actual), Loc); + end if; + + elsif Inside_Init_Proc then + + -- Could use a comment here to match comment below ??? + + if Nkind (Actual) /= N_Selected_Component + or else + not Has_Discriminant_Dependent_Constraint + (Entity (Selector_Name (Actual))) + then + Incod := Empty; + + -- Otherwise, keep the component in order to generate the proper + -- actual subtype, that depends on enclosing discriminants. + + else + null; + end if; end if; - Insert_Action (N, + Decl := Make_Object_Declaration (Loc, Defining_Identifier => Temp, - Object_Definition => - New_Occurrence_Of (Etype (Formal), Loc), - Expression => Incod)); + 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 @@ -719,8 +845,9 @@ package body Exp_Ch6 is Make_Assignment_Statement (Loc, Name => Lhs, Expression => Rhs)); + Set_Assignment_OK (Name (Last (Post_Call))); end if; - end Add_Packed_Call_By_Copy_Code; + end Add_Simple_Call_By_Copy_Code; --------------------------- -- Check_Fortran_Logical -- @@ -754,6 +881,38 @@ package body Exp_Ch6 is 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)) then + Error_Msg_N + ("misaligned actual cannot be passed by reference", Actual); + return False; + + -- For users of Starlet, we assume that the specification of by- + -- reference mechanism is mandatory. This may lead to unligned + -- 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 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 -- -------------- @@ -786,7 +945,6 @@ package body Exp_Ch6 is procedure Reset_Packed_Prefix is Pfx : Node_Id := Actual; - begin loop Set_Analyzed (Pfx, False); @@ -799,11 +957,10 @@ package body Exp_Ch6 is -- Start of processing for Expand_Actuals begin - Formal := First_Formal (Subp); - Actual := First_Actual (N); - Post_Call := New_List; + Formal := First_Formal (Subp); + Actual := First_Actual (N); while Present (Formal) loop E_Formal := Etype (Formal); @@ -895,7 +1052,14 @@ package body Exp_Ch6 is -- [in] out parameters. elsif Is_Ref_To_Bit_Packed_Array (Actual) then - Add_Packed_Call_By_Copy_Code; + Add_Simple_Call_By_Copy_Code; + + -- If a non-scalar 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; -- References to slices of bit packed arrays are expanded @@ -920,8 +1084,13 @@ package body Exp_Ch6 is then Add_Call_By_Copy_Code; + -- If the actual is not a scalar and is marked for volatile + -- treatment, whereas the formal is not volatile, then pass + -- by copy unless it is a by-reference type. + elsif Is_Entity_Name (Actual) and then Treat_As_Volatile (Entity (Actual)) + and then not Is_By_Reference_Type (Etype (Actual)) and then not Is_Scalar_Type (Etype (Entity (Actual))) and then not Treat_As_Volatile (E_Formal) then @@ -943,7 +1112,7 @@ package body Exp_Ch6 is -- 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. + -- easier simply to handle all cases here.) if Nkind (Actual) = N_Indexed_Component and then Is_Packed (Etype (Prefix (Actual))) @@ -957,7 +1126,14 @@ package body Exp_Ch6 is -- Is this really necessary in all cases??? elsif Is_Ref_To_Bit_Packed_Array (Actual) then - Add_Packed_Call_By_Copy_Code; + Add_Simple_Call_By_Copy_Code; + + -- If a non-scalar 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; -- Similarly, we have to expand slices of packed arrays here -- because the result must be byte aligned. @@ -982,10 +1158,9 @@ package body Exp_Ch6 is 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 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 @@ -1011,7 +1186,7 @@ package body Exp_Ch6 is end if; end if; - -- The call node itself is re-analyzed in Expand_Call. + -- The call node itself is re-analyzed in Expand_Call end Expand_Actuals; @@ -1046,20 +1221,27 @@ package body Exp_Ch6 is Actual : Node_Id; Formal : Entity_Id; Prev : Node_Id := Empty; - Prev_Orig : Node_Id; + + Prev_Orig : Node_Id; + -- Original node for an actual, which may have been rewritten. If the + -- actual is a function call that has been transformed from a selected + -- component, the original node is unanalyzed. Otherwise, it carries + -- semantic information used to generate additional actuals. + Scop : Entity_Id; Extra_Actuals : List_Id := No_List; - Cond : Node_Id; + + CW_Interface_Formals_Present : Boolean := False; 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. + -- 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. + -- 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 @@ -1088,7 +1270,7 @@ package body Exp_Ch6 is Set_First_Named_Actual (N, Actual_Expr); if No (Prev) then - if not Present (Parameter_Associations (N)) then + if No (Parameter_Associations (N)) then Set_Parameter_Associations (N, New_List); Append (Insert_Param, Parameter_Associations (N)); end if; @@ -1149,8 +1331,8 @@ package body Exp_Ch6 is 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 Nkind (Type_Definition (Original_Node (Parent (S)))) /= + N_Derived_Type_Definition or else not In_Instance then return Empty; @@ -1178,31 +1360,29 @@ package body Exp_Ch6 is Gen_Par := Generic_Parent_Type (Parent (Par)); 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 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); + Elmt := First_Elmt (Gen_Prim); while Present (Elmt) loop if Chars (Node (Elmt)) = Chars (S) then declare F1 : Entity_Id; F2 : Entity_Id; - begin + 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 @@ -1265,7 +1445,7 @@ package body Exp_Ch6 is -- if we can tell that the first parameter cannot possibly be null. -- This helps optimization and also generation of warnings. - if not Restrictions (No_Exception_Handlers) + if not Restriction_Active (No_Exception_Handlers) and then Is_RTE (Subp, RE_Raise_Exception) then declare @@ -1273,7 +1453,8 @@ package body Exp_Ch6 is begin -- The case we catch is where the first argument is obtained - -- using the Identity attribute (which must always be non-null) + -- using the Identity attribute (which must always be + -- non-null). if Nkind (FA) = N_Attribute_Reference and then Attribute_Name (FA) = Name_Identity @@ -1289,6 +1470,48 @@ package body Exp_Ch6 is 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_05 + and then Nkind (N) = N_Procedure_Call_Statement + and then + ((Nkind (Parent (N)) = N_Triggering_Alternative + and then Triggering_Statement (Parent (N)) = N) + or else + (Nkind (Parent (N)) = N_Entry_Call_Alternative + and then Entry_Call_Statement (Parent (N)) = N)) + 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 (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 (N, + Make_Entry_Call_Statement (Loc, + Name => + New_Copy_Tree (Name (Ren_Decl)), + Parameter_Associations => + New_Copy_List_Tree (Parameter_Associations (N)))); + + return; + end if; + 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 @@ -1315,16 +1538,34 @@ package body Exp_Ch6 is 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 not Analyzed (Prev_Orig) + and then Nkind (Actual) = N_Function_Call + then + Prev_Orig := Prev; + end if; + + -- 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 + (Ekind (Etype (Formal)) = E_Class_Wide_Type + and then Is_Interface (Etype (Etype (Formal)))) + or else + (Ekind (Etype (Formal)) = E_Anonymous_Access_Type + and then Is_Interface (Directly_Designated_Type + (Etype (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 Ekind (Etype (Prev)) in Private_Kind @@ -1341,31 +1582,53 @@ package body Exp_Ch6 is New_Occurrence_Of (Standard_True, Loc), 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 := Prev; + Act_Prev : Node_Id; begin - -- Test for unchecked conversions as well, which can - -- occur as out parameter actuals on calls to stream - -- procedures. + -- 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) = N_Type_Conversion or else Nkind (Act_Prev) = N_Unchecked_Type_Conversion loop Act_Prev := Expression (Act_Prev); end loop; - Add_Extra_Actual ( - Make_Attribute_Reference (Sloc (Prev), - Prefix => - Duplicate_Subexpr_No_Checks - (Act_Prev, Name_Req => True), - Attribute_Name => Name_Constrained), - Extra_Constrained (Formal)); + -- 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 a 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 + (New_Occurrence_Of (Standard_False, Loc), + Extra_Constrained (Formal)); + + else + Add_Extra_Actual + (Make_Attribute_Reference (Sloc (Prev), + Prefix => + Duplicate_Subexpr_No_Checks + (Act_Prev, Name_Req => True), + Attribute_Name => Name_Constrained), + Extra_Constrained (Formal)); + end if; end; end if; end if; @@ -1377,7 +1640,7 @@ package body Exp_Ch6 is -- 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 + -- associated access level parameter. This is done if we are -- in the scope of the formal access parameter (if this is an -- inlined body the extra formal is irrelevant). @@ -1392,10 +1655,10 @@ package body Exp_Ch6 is 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)); + 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, @@ -1403,10 +1666,10 @@ package body Exp_Ch6 is -- accessibility. else - Add_Extra_Actual ( - Make_Integer_Literal (Loc, - Intval => Scope_Depth (Standard_Standard)), - Extra_Accessibility (Formal)); + Add_Extra_Actual + (Make_Integer_Literal (Loc, + Intval => Scope_Depth (Standard_Standard)), + Extra_Accessibility (Formal)); end if; end; @@ -1414,10 +1677,10 @@ package body Exp_Ch6 is -- 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)); + Add_Extra_Actual + (Make_Integer_Literal (Loc, + Intval => Type_Access_Level (Etype (Prev_Orig))), + Extra_Accessibility (Formal)); end if; else @@ -1476,58 +1739,70 @@ package body Exp_Ch6 is 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. + -- 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 Access_Checks_Suppressed (Subp) - then - null; + if Ada_Version >= Ada_05 then - elsif Debug_Flag_J then - null; + -- Ada 2005 (AI-231): Check null-excluding access types - elsif not Comes_From_Source (Prev) then - null; + if Is_Access_Type (Etype (Formal)) + and then Can_Never_Be_Null (Etype (Formal)) + and then Nkind (Prev) /= N_Raise_Constraint_Error + and then (Nkind (Prev) = N_Null + or else not Can_Never_Be_Null (Etype (Prev))) + then + Install_Null_Excluding_Check (Prev); + end if; - elsif Is_Entity_Name (Prev) - and then Ekind (Etype (Prev)) = E_Anonymous_Access_Type - then - null; + -- Ada_Version < Ada_05 - elsif Nkind (Prev) = N_Allocator - or else Nkind (Prev) = N_Attribute_Reference - then - null; + else + if Ekind (Etype (Formal)) /= E_Anonymous_Access_Type + or else Access_Checks_Suppressed (Subp) + then + null; - -- Suppress null checks when passing to access parameters - -- of Java subprograms. (Should this be done for other - -- foreign conventions as well ???) + elsif Debug_Flag_J then + null; - elsif Convention (Subp) = Convention_Java then - null; + elsif not Comes_From_Source (Prev) then + null; - else - Cond := - Make_Op_Eq (Loc, - Left_Opnd => Duplicate_Subexpr_No_Checks (Prev), - Right_Opnd => Make_Null (Loc)); - Insert_Action (Prev, - Make_Raise_Constraint_Error (Loc, - Condition => Cond, - Reason => CE_Access_Parameter_Is_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 + 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 + 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, it has not been expanded yet. It will be @@ -1539,11 +1814,6 @@ package body Exp_Ch6 is end if; 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; @@ -1565,11 +1835,10 @@ package body Exp_Ch6 is 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 return from the procedure. + -- 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) @@ -1579,14 +1848,15 @@ package body Exp_Ch6 is Set_Is_Known_Valid (Entity (Actual), False); end if; - -- For an OUT or IN OUT parameter of an access type, if the - -- actual is an entity, then it is no longer known to be non-null. + -- 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 Is_Access_Type (Etype (Actual)) then - Set_Is_Known_Non_Null (Entity (Actual), False); + Kill_Current_Values (Entity (Actual)); end if; -- If the formal is class wide and the actual is an aggregate, force @@ -1616,20 +1886,24 @@ package body Exp_Ch6 is Get_Remotely_Callable (Duplicate_Subexpr_Move_Checks (Actual))), Then_Statements => New_List ( - Make_Procedure_Call_Statement (Loc, - New_Occurrence_Of (RTE - (RE_Raise_Program_Error_For_E_4_18), Loc))))); + Make_Raise_Program_Error (Loc, + Reason => PE_Illegal_RACW_E_4_18)))); end if; + -- This label is required when skipping extra actual generation for + -- Unchecked_Union parameters. + + <> + 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 we are expanding a 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 (N) = N_Function_Call and then Is_Tag_Indeterminate (N) @@ -1667,6 +1941,16 @@ package body Exp_Ch6 is end; end if; + -- Ada 2005 (AI-251): If some formal is a class-wide interface, expand + -- it to point to the correct secondary virtual table + + if (Nkind (N) = N_Function_Call + or else Nkind (N) = N_Procedure_Call_Statement) + and then CW_Interface_Formals_Present + then + Expand_Interface_Actuals (N); + 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 @@ -1680,7 +1964,7 @@ package body Exp_Ch6 is and then Present (Controlling_Argument (N)) and then not Java_VM then - Expand_Dispatch_Call (N); + Expand_Dispatching_Call (N); -- The following return is worrisome. Is it really OK to -- skip all remaining processing in this procedure ??? @@ -1715,13 +1999,10 @@ package body Exp_Ch6 is 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; + -- At this point we have all the actuals, so this is the point at + -- which the various expansion activities for actuals is carried out. + + Expand_Actuals (N, Subp); -- 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. @@ -1740,6 +2021,8 @@ package body Exp_Ch6 is end loop; end if; + -- The below setting of Entity is suspect, see F109-018 discussion??? + Set_Entity (Name (N), Parent_Subp); if Is_Abstract (Parent_Subp) @@ -1767,7 +2050,6 @@ package body Exp_Ch6 is 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 @@ -1782,8 +2064,8 @@ package body Exp_Ch6 is Enable_Range_Check (Actual); elsif Is_Access_Type (Etype (Formal)) - and then Base_Type (Etype (Parent_Formal)) - /= Base_Type (Etype (Actual)) + and then Base_Type (Etype (Parent_Formal)) /= + Base_Type (Etype (Actual)) then if Ekind (Formal) /= E_In_Parameter then Rewrite (Actual, @@ -1824,10 +2106,27 @@ package body Exp_Ch6 is Subp := Parent_Subp; end if; + -- Check for violation of No_Abort_Statements + if Is_RTE (Subp, RE_Abort_Task) then Check_Restriction (No_Abort_Statements, N); + + -- Check for violation of No_Dynamic_Attachment + + elsif RTU_Loaded (Ada_Interrupts) + and then (Is_RTE (Subp, RE_Is_Reserved) or else + Is_RTE (Subp, RE_Is_Attached) or else + Is_RTE (Subp, RE_Current_Handler) or else + Is_RTE (Subp, RE_Attach_Handler) or else + Is_RTE (Subp, RE_Exchange_Handler) or else + Is_RTE (Subp, RE_Detach_Handler) or else + Is_RTE (Subp, RE_Reference)) + then + Check_Restriction (No_Dynamic_Attachment, N); end if; + -- Deal with case where call is an explicit dereference + if Nkind (Name (N)) = N_Explicit_Dereference then -- Handle case of access to protected subprogram type @@ -1854,14 +2153,17 @@ package body Exp_Ch6 is 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)); + 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); @@ -1904,6 +2206,10 @@ package body Exp_Ch6 is -- appropriate expansion to the corresponding tree node and we -- are all done (since after that the call is gone!) + -- In the case where the intrinsic is to be processed by the back end, + -- the call to Expand_Intrinsic_Call will do nothing, which is fine, + -- since the idea in this case is to pass the call unchanged. + if Is_Intrinsic_Subprogram (Subp) then Expand_Intrinsic_Call (N, Subp); return; @@ -1914,17 +2220,51 @@ package body Exp_Ch6 is then if Is_Inlined (Subp) then - declare + Inlined_Subprogram : declare Bod : Node_Id; Must_Inline : Boolean := False; Spec : constant Node_Id := Unit_Declaration_Node (Subp); Scop : constant Entity_Id := Scope (Subp); + function In_Unfrozen_Instance return Boolean; + -- If the subprogram comes from an instance in the same + -- unit, and the instance is not yet frozen, inlining might + -- trigger order-of-elaboration problems in gigi. + + -------------------------- + -- In_Unfrozen_Instance -- + -------------------------- + + function In_Unfrozen_Instance return Boolean is + S : Entity_Id; + + begin + S := Scop; + 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; + + -- Start of processing for Inlined_Subprogram + 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. + -- 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 the back end. + + -- This should be documented in sinfo/einfo ??? if No (Spec) or else Nkind (Spec) /= N_Subprogram_Declaration @@ -1942,14 +2282,7 @@ package body Exp_Ch6 is then Must_Inline := False; - -- If the subprogram comes from an instance in the same - -- unit, and the instance is not yet frozen, inlining might - -- trigger order-of-elaboration problems in gigi. - - elsif Is_Generic_Instance (Scop) - and then Present (Freeze_Node (Scop)) - and then not Analyzed (Freeze_Node (Scop)) - then + elsif In_Unfrozen_Instance then Must_Inline := False; else @@ -1970,10 +2303,16 @@ package body Exp_Ch6 is -- temporaries are generated when compiling the body by -- itself. Otherwise link errors can occur. + -- If the function being called is itself in the main unit, + -- we cannot inline, because there is a risk of double + -- elaboration and/or circularity: the inlining can make + -- visible a private entity in the body of the main unit, + -- that gigi will see before its sees its proper definition. + elsif not (In_Extended_Main_Code_Unit (N)) and then In_Package_Body then - Must_Inline := True; + Must_Inline := not In_Extended_Main_Source_Unit (Subp); end if; end if; @@ -1997,7 +2336,7 @@ package body Exp_Ch6 is N, Subp); end if; end if; - end; + end Inlined_Subprogram; end if; end if; @@ -2005,10 +2344,16 @@ package body Exp_Ch6 is -- call, or a protected function call. Protected procedure calls are -- rewritten as entry calls and handled accordingly. + -- In Ada 2005, this may be an indirect call to an access parameter + -- that is an access_to_subprogram. In that case the anonymous type + -- has a scope that is a protected operation, but the call is a + -- regular one. + Scop := Scope (Subp); if Nkind (N) /= N_Entry_Call_Statement and then Is_Protected_Type (Scop) + and then Ekind (Subp) /= E_Subprogram_Type then -- If the call is an internal one, it is rewritten as a call to -- to the corresponding unprotected subprogram. @@ -2166,6 +2511,28 @@ package body Exp_Ch6 is end if; end; end if; + + -- Special processing for Ada 2005 AI-329, which requires a call to + -- Raise_Exception to raise Constraint_Error if the Exception_Id is + -- null. Note that we never need to do this in GNAT mode, or if the + -- parameter to Raise_Exception is a use of Identity, since in these + -- cases we know that the parameter is never null. + + if Ada_Version >= Ada_05 + and then not GNAT_Mode + and then Is_RTE (Subp, RE_Raise_Exception) + and then (Nkind (First_Actual (N)) /= N_Attribute_Reference + or else Attribute_Name (First_Actual (N)) /= Name_Identity) + then + declare + RCE : constant Node_Id := + Make_Raise_Constraint_Error (Loc, + Reason => CE_Null_Exception_Id); + begin + Insert_After (N, RCE); + Analyze (RCE); + end; + end if; end Expand_Call; -------------------------- @@ -2187,6 +2554,7 @@ package body Exp_Ch6 is Blk : Node_Id; Bod : Node_Id; Decl : Node_Id; + Decls : constant List_Id := New_List; Exit_Lab : Entity_Id := Empty; F : Entity_Id; A : Node_Id; @@ -2196,11 +2564,25 @@ package body Exp_Ch6 is Num_Ret : Int := 0; Ret_Type : Entity_Id; Targ : Node_Id; + Targ1 : Node_Id; Temp : Entity_Id; Temp_Typ : Entity_Id; + Is_Unc : constant Boolean := + Is_Array_Type (Etype (Subp)) + and then not Is_Constrained (Etype (Subp)); + -- If the type returned by the function is unconstrained and the + -- call can be inlined, special processing is required. + + procedure Find_Result; + -- For a function that returns an unconstrained type, retrieve the + -- name of the single variable that is the expression of a return + -- statement in the body of the function. Build_Body_To_Inline has + -- verified that this variable is unique, even in the presence of + -- multiple return statements. + procedure Make_Exit_Label; - -- Build declaration for exit label to be used in Return statements. + -- 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 @@ -2222,13 +2604,60 @@ package body Exp_Ch6 is -- If procedure body has no local variables, inline body without -- creating block, otherwise rewrite call with block. + function Formal_Is_Used_Once (Formal : Entity_Id) return Boolean; + -- Determine whether a formal parameter is used only once in Orig_Bod + + ----------------- + -- Find_Result -- + ----------------- + + procedure Find_Result is + Decl : Node_Id; + Id : Node_Id; + + function Get_Return (N : Node_Id) return Traverse_Result; + -- Recursive function to locate return statements in body. + + function Get_Return (N : Node_Id) return Traverse_Result is + begin + if Nkind (N) = N_Return_Statement then + Id := Expression (N); + return Abandon; + else + return OK; + end if; + end Get_Return; + + procedure Find_It is new Traverse_Proc (Get_Return); + + -- Start of processing for Find_Result + + begin + Find_It (Handled_Statement_Sequence (Orig_Bod)); + + -- At this point the body is unanalyzed. Traverse the list of + -- declarations to locate the defining_identifier for it. + + Decl := First (Declarations (Blk)); + + while Present (Decl) loop + if Chars (Defining_Identifier (Decl)) = Chars (Id) then + Targ1 := Defining_Identifier (Decl); + exit; + + else + Next (Decl); + end if; + end loop; + end Find_Result; + --------------------- -- Make_Exit_Label -- --------------------- procedure Make_Exit_Label is begin - -- Create exit label for subprogram, if one doesn't exist yet. + -- Create exit label for subprogram if one does not exist yet if No (Exit_Lab) then Lab_Id := Make_Identifier (Loc, New_Internal_Name ('L')); @@ -2406,22 +2835,42 @@ package body Exp_Ch6 is 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. + -- 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))) + and then + (Is_Entity_Name (Name (Parent (N))) + or else + (Nkind (Name (Parent (N))) = N_Explicit_Dereference + and then Is_Entity_Name (Prefix (Name (Parent (N)))))) then - -- Replace assignment with the block - Rewrite (Parent (N), Blk); + declare + Original_Assignment : constant Node_Id := Parent (N); + + begin + -- Preserve the original assignment node to keep the complete + -- assignment subtree consistent enough for Analyze_Assignment + -- to proceed (specifically, the original Lhs node must still + -- have an assignment statement as its parent). + + -- We cannot rely on Original_Node to go back from the block + -- node to the assignment node, because the assignment might + -- already be a rewrite substitution. + + Discard_Node (Relocate_Node (Original_Assignment)); + Rewrite (Original_Assignment, Blk); + end; elsif Nkind (Parent (N)) = N_Object_Declaration then Set_Expression (Parent (N), Empty); Insert_After (Parent (N), Blk); + + elsif Is_Unc then + Insert_Before (Parent (N), Blk); end if; end Rewrite_Function_Call; @@ -2431,7 +2880,6 @@ package body Exp_Ch6 is procedure Rewrite_Procedure_Call (N : Node_Id; Blk : Node_Id) is HSS : constant Node_Id := Handled_Statement_Sequence (Blk); - begin if Is_Empty_List (Declarations (Blk)) then Insert_List_After (N, Statements (HSS)); @@ -2441,14 +2889,70 @@ package body Exp_Ch6 is end if; end Rewrite_Procedure_Call; + ------------------------- + -- Formal_Is_Used_Once -- + ------------------------ + + function Formal_Is_Used_Once (Formal : Entity_Id) return Boolean is + Use_Counter : Int := 0; + + function Count_Uses (N : Node_Id) return Traverse_Result; + -- Traverse the tree and count the uses of the formal parameter. + -- In this case, for optimization purposes, we do not need to + -- continue the traversal once more than one use is encountered. + + ---------------- + -- Count_Uses -- + ---------------- + + function Count_Uses (N : Node_Id) return Traverse_Result is + begin + -- The original node is an identifier + + if Nkind (N) = N_Identifier + and then Present (Entity (N)) + + -- Original node's entity points to the one in the copied body + + and then Nkind (Entity (N)) = N_Identifier + and then Present (Entity (Entity (N))) + + -- The entity of the copied node is the formal parameter + + and then Entity (Entity (N)) = Formal + then + Use_Counter := Use_Counter + 1; + + if Use_Counter > 1 then + + -- Denote more than one use and abandon the traversal + + Use_Counter := 2; + return Abandon; + + end if; + end if; + + return OK; + end Count_Uses; + + procedure Count_Formal_Uses is new Traverse_Proc (Count_Uses); + + -- Start of processing for Formal_Is_Used_Once + + begin + Count_Formal_Uses (Orig_Bod); + return Use_Counter = 1; + end Formal_Is_Used_Once; + -- Start of processing for Expand_Inlined_Call begin - -- Check for special case of To_Address call, and if so, just - -- do an unchecked conversion instead of expanding the call. - -- Not only is this more efficient, but it also avoids a - -- problem with order of elaboration when address clauses - -- are inlined (address expr elaborated at wrong point). + -- Check for special case of To_Address call, and if so, just do an + -- unchecked conversion instead of expanding the call. Not only is this + -- more efficient, but it also avoids problem with order of elaboration + -- when address clauses are inlined (address expression elaborated at + -- wrong point). if Subp = RTE (RE_To_Address) then Rewrite (N, @@ -2458,13 +2962,32 @@ package body Exp_Ch6 is return; end if; - if Nkind (Orig_Bod) = N_Defining_Identifier then + -- Check for an illegal attempt to inline a recursive procedure. If the + -- subprogram has parameters this is detected when trying to supply a + -- binding for parameters that already have one. For parameterless + -- subprograms this must be done explicitly. + if In_Open_Scopes (Subp) then + Error_Msg_N ("call to recursive subprogram cannot be inlined?", N); + Set_Is_Inlined (Subp, False); + return; + end if; + + if Nkind (Orig_Bod) = N_Defining_Identifier + or else Nkind (Orig_Bod) = N_Defining_Operator_Symbol + 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. + -- directly, because the subprograms are subtype conformant. If + -- the renamed subprogram is an inherited operation, we must redo + -- the expansion because implicit conversions may be needed. Set_Name (N, New_Occurrence_Of (Orig_Bod, Loc)); + + if Present (Alias (Orig_Bod)) then + Expand_Call (N); + end if; + return; end if; @@ -2485,9 +3008,16 @@ package body Exp_Ch6 is Set_Declarations (Blk, New_List); end if; - -- If this is a derived function, establish the proper return type. + -- For the unconstrained case, capture the name of the local + -- variable that holds the result. - if Present (Orig_Subp) + if Is_Unc then + Find_Result; + 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); @@ -2495,23 +3025,22 @@ package body Exp_Ch6 is 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. + F := First_Formal (Subp); + A := First_Actual (N); while Present (F) loop if Present (Renamed_Object (F)) then - Error_Msg_N (" cannot inline call to recursive subprogram", N); + 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. + -- 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)) @@ -2537,6 +3066,13 @@ package body Exp_Ch6 is (not Is_Scalar_Type (Etype (A)) or else Ekind (Entity (A)) = E_Enumeration_Literal)) + -- When the actual is an identifier and the corresponding formal + -- is used only once in the original body, the formal can be + -- substituted directly with the actual parameter. + + or else (Nkind (A) = N_Identifier + and then Formal_Is_Used_Once (F)) + or else Nkind (A) = N_Real_Literal or else Nkind (A) = N_Integer_Literal or else Nkind (A) = N_Character_Literal @@ -2594,7 +3130,7 @@ package body Exp_Ch6 is Name => New_A); end if; - Prepend (Decl, Declarations (Blk)); + Append (Decl, Decls); Set_Renamed_Object (F, Temp); end if; @@ -2606,7 +3142,7 @@ package body Exp_Ch6 is -- 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. + -- simple enough, i.e. an entity or an explicit dereference of one. if Ekind (Subp) = E_Function then if Nkind (Parent (N)) = N_Assignment_Statement @@ -2614,26 +3150,53 @@ package body Exp_Ch6 is then Targ := Name (Parent (N)); + elsif Nkind (Parent (N)) = N_Assignment_Statement + and then Nkind (Name (Parent (N))) = N_Explicit_Dereference + and then Is_Entity_Name (Prefix (Name (Parent (N)))) + then + Targ := Name (Parent (N)); + else - -- Replace call with temporary, and create its declaration. + -- Replace call with temporary and create its declaration Temp := Make_Defining_Identifier (Loc, New_Internal_Name ('C')); + Set_Is_Internal (Temp); - Decl := - Make_Object_Declaration (Loc, - Defining_Identifier => Temp, - Object_Definition => - New_Occurrence_Of (Ret_Type, Loc)); + -- For the unconstrained case. the generated temporary has the + -- same constrained declaration as the result variable. + -- It may eventually be possible to remove that temporary and + -- use the result variable directly. + + if Is_Unc then + Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => Temp, + Object_Definition => + New_Copy_Tree (Object_Definition (Parent (Targ1)))); + + Replace_Formals (Decl); + + else + Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => Temp, + Object_Definition => + New_Occurrence_Of (Ret_Type, Loc)); + + Set_Etype (Temp, Ret_Type); + end if; Set_No_Initialization (Decl); - Insert_Action (N, Decl); + Append (Decl, Decls); Rewrite (N, New_Occurrence_Of (Temp, Loc)); Targ := Temp; end if; end if; - -- Traverse the tree and replace formals with actuals or their thunks. + Insert_Actions (N, Decls); + + -- Traverse the tree and replace formals with actuals or their thunks. -- Attach block to tree before analysis and rewriting. Replace_Formals (Blk); @@ -2663,7 +3226,7 @@ package body Exp_Ch6 is end if; -- Analyze Blk with In_Inlined_Body set, to avoid spurious errors on - -- conflicting private views that Gigi would ignore. If this is a + -- conflicting private views that Gigi would ignore. If this is -- predefined unit, analyze with checks off, as is done in the non- -- inlined run-time units. @@ -2693,14 +3256,25 @@ package body Exp_Ch6 is Rewrite_Procedure_Call (N, Blk); else Rewrite_Function_Call (N, Blk); + + -- For the unconstrained case, the replacement of the call has been + -- made prior to the complete analysis of the generated declarations. + -- Propagate the proper type now. + + if Is_Unc then + if Nkind (N) = N_Identifier then + Set_Etype (N, Etype (Entity (N))); + else + Set_Etype (N, Etype (Targ1)); + end if; + end if; end if; Restore_Env; - -- Cleanup mapping between formals and actuals, for other expansions. + -- 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); @@ -2712,14 +3286,30 @@ package body Exp_Ch6 is ---------------------------- procedure Expand_N_Function_Call (N : Node_Id) is - Typ : constant Entity_Id := Etype (N); + Typ : constant Entity_Id := Etype (N); function Returned_By_Reference return Boolean; -- If the return type is returned through the secondary stack. that is -- by reference, we don't want to create a temp to force stack checking. + -- Shouldn't this function be moved to exp_util??? + + function Rhs_Of_Assign_Or_Decl (N : Node_Id) return Boolean; + -- If the call is the right side of an assignment or the expression in + -- an object declaration, we don't need to create a temp as the left + -- side will already trigger stack checking if necessary. + -- + -- If the call is a component in an extension aggregate, it will be + -- expanded into assignments as well, so no temporary is needed. This + -- also solves the problem of functions returning types with unknown + -- discriminants, where it is not possible to declare an object of the + -- type altogether. + + --------------------------- + -- Returned_By_Reference -- + --------------------------- function Returned_By_Reference return Boolean is - S : Entity_Id := Current_Scope; + S : Entity_Id; begin if Is_Return_By_Reference_Type (Typ) then @@ -2730,9 +3320,10 @@ package body Exp_Ch6 is 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. + -- Verify that the return type of the enclosing function has the + -- same constrained status as that of the expression. + S := Current_Scope; while Ekind (S) /= E_Function loop S := Scope (S); end loop; @@ -2743,87 +3334,134 @@ package body Exp_Ch6 is end if; end Returned_By_Reference; + --------------------------- + -- Rhs_Of_Assign_Or_Decl -- + --------------------------- + + function Rhs_Of_Assign_Or_Decl (N : Node_Id) return Boolean is + begin + if (Nkind (Parent (N)) = N_Assignment_Statement + and then Expression (Parent (N)) = N) + or else + (Nkind (Parent (N)) = N_Qualified_Expression + and then Nkind (Parent (Parent (N))) = N_Assignment_Statement + and then Expression (Parent (Parent (N))) = Parent (N)) + or else + (Nkind (Parent (N)) = N_Object_Declaration + and then Expression (Parent (N)) = N) + or else + (Nkind (Parent (N)) = N_Component_Association + and then Expression (Parent (N)) = N + and then Nkind (Parent (Parent (N))) = N_Aggregate + and then Rhs_Of_Assign_Or_Decl (Parent (Parent (N)))) + or else + (Nkind (Parent (N)) = N_Extension_Aggregate + and then Is_Private_Type (Etype (Typ))) + then + return True; + else + return False; + end if; + end Rhs_Of_Assign_Or_Decl; + -- 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. + -- 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. + + -- This is unecessary if the call is the expression in an object + -- declaration, or if it appears outside of any library unit. This can + -- only happen if it appears as an actual in a library-level instance, + -- in which case a temporary will be generated for it once the instance + -- itself is installed. if May_Generate_Large_Temp (Typ) - and then Nkind (Parent (N)) /= N_Assignment_Statement - and then - (Nkind (Parent (N)) /= N_Qualified_Expression - or else Nkind (Parent (Parent (N))) /= N_Assignment_Statement) - and then - (Nkind (Parent (N)) /= N_Object_Declaration - or else Expression (Parent (N)) /= N) + and then not Rhs_Of_Assign_Or_Decl (N) and then not Returned_By_Reference + and then Current_Scope /= Standard_Standard 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. + if Stack_Checking_Enabled then - declare - Loc : constant Source_Ptr := Sloc (N); - Temp_Obj : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('F')); - Temp_Typ : Entity_Id := Typ; - Decl : Node_Id; - A : Node_Id; - F : Entity_Id; - Proc : Entity_Id; + -- 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 can results in a 'Reference construct that may still need + -- a temporary. - 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 + declare + Loc : constant Source_Ptr := Sloc (N); + Temp_Obj : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => 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 this is a tag-indeterminate call, the object must - -- be classwide. + 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; + 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; + 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); + if Is_Controlling_Formal (F) then + Temp_Typ := Class_Wide_Type (Typ); + end if; 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); + 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; - Insert_Actions (N, New_List (Decl)); - Rewrite (N, New_Occurrence_Of (Temp_Obj, Loc)); - end; + else + -- If stack-checking is not enabled, increment serial number + -- for internal names, so that subsequent symbols are consistent + -- with and without stack-checking. + + Synchronize_Serial_Number; + + -- Now we can expand the call with consistent symbol names + + Expand_Call (N); + end if; -- Normal case, expand the call @@ -2845,11 +3483,12 @@ package body Exp_Ch6 is -- Expand_N_Subprogram_Body -- ------------------------------ - -- Add poll call if ATC polling is enabled + -- Add poll call if ATC polling is enabled, unless the body will be + -- inlined by the back-end. - -- 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 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 @@ -3004,7 +3643,7 @@ package body Exp_Ch6 is -- Create new exception handler - if Restrictions (No_Exception_Handlers) then + if Restriction_Active (No_Exception_Handlers) then Excep_Handlers := No_List; else @@ -3074,14 +3713,6 @@ package body Exp_Ch6 is 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 Body_Id := Defining_Entity (N); @@ -3092,6 +3723,23 @@ package body Exp_Ch6 is Spec_Id := Body_Id; 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. Do not add polling + -- point if calls to this subprogram will be inlined by the back-end, + -- to avoid repeated polling points in nested inlinings. + + if Is_Non_Empty_List (L) then + if Is_Inlined (Spec_Id) + and then Front_End_Inlining + and then Optimization_Level > 1 + then + null; + else + Generate_Poll_Call (First (L)); + end if; + end if; + -- If this is a Pure function which has any parameters whose root -- type is System.Address, reset the Pure indication, since it will -- likely cause incorrect code to be generated as the parameter is @@ -3110,11 +3758,12 @@ package body Exp_Ch6 is and then not Has_Pragma_Pure_Function (Spec_Id) then declare - F : Entity_Id := First_Formal (Spec_Id); + F : Entity_Id; begin + F := First_Formal (Spec_Id); while Present (F) loop - if Is_RTE (Root_Type (Etype (F)), RE_Address) then + if Is_Descendent_Of_Address (Etype (F)) then Set_Is_Pure (Spec_Id, False); if Spec_Id /= Body_Id then @@ -3133,7 +3782,7 @@ package body Exp_Ch6 is if Init_Or_Norm_Scalars and then Is_Subprogram (Spec_Id) then declare - F : Entity_Id := First_Formal (Spec_Id); + F : Entity_Id; V : constant Boolean := Validity_Checks_On; begin @@ -3145,6 +3794,7 @@ package body Exp_Ch6 is -- Loop through formals + F := First_Formal (Spec_Id); while Present (F) loop if Is_Scalar_Type (Etype (F)) and then Ekind (F) = E_Out_Parameter @@ -3162,6 +3812,33 @@ package body Exp_Ch6 is end; end if; + Scop := Scope (Spec_Id); + + -- 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); + end if; + end if; + -- Clear out statement list for stubbed procedure if Present (Corresponding_Spec (N)) then @@ -3179,10 +3856,8 @@ package body Exp_Ch6 is 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 + -- but subprograms with no specs are not frozen. declare Typ : constant Entity_Id := Etype (Spec_Id); @@ -3214,16 +3889,15 @@ package body Exp_Ch6 is 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: + -- 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 -- ... @@ -3269,32 +3943,6 @@ package body Exp_Ch6 is 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); - 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. @@ -3317,7 +3965,6 @@ package body Exp_Ch6 is begin Formal := First_Formal (Spec_Id); - while Present (Formal) loop Floc := Sloc (Formal); @@ -3344,18 +3991,6 @@ package body Exp_Ch6 is Expand_Thread_Body; 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); @@ -3382,6 +4017,8 @@ package body Exp_Ch6 is -- protected subprogram an associated formals. For a normal protected -- operation, this is done when expanding the protected type declaration. + -- If the declaration is for a null procedure, emit null body + procedure Expand_N_Subprogram_Declaration (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); Subp : constant Entity_Id := Defining_Entity (N); @@ -3391,19 +4028,22 @@ package body Exp_Ch6 is Prot_Id : Entity_Id; begin - -- Deal with case of protected subprogram + -- Deal with case of protected subprogram. Do not generate protected + -- operation if operation is flagged as eliminated. 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 + if No (Protected_Body_Subprogram (Subp)) + and then not Is_Eliminated (Subp) + then Prot_Decl := Make_Subprogram_Declaration (Loc, Specification => Build_Protected_Sub_Specification - (N, Scop, Unprotected => True)); + (N, Scop, Unprotected_Mode)); -- The protected subprogram is declared outside of the protected -- body. Given that the body has frozen all entities so far, we @@ -3426,6 +4066,35 @@ package body Exp_Ch6 is Set_Protected_Body_Subprogram (Subp, Prot_Id); Pop_Scope; end if; + + elsif Nkind (Specification (N)) = N_Procedure_Specification + and then Null_Present (Specification (N)) + then + declare + Bod : constant Node_Id := + Make_Subprogram_Body (Loc, + Specification => + New_Copy_Tree (Specification (N)), + Declarations => New_List, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List (Make_Null_Statement (Loc)))); + begin + Set_Body_To_Inline (N, Bod); + Insert_After (N, Bod); + Analyze (Bod); + + -- Corresponding_Spec isn't being set by Analyze_Subprogram_Body, + -- evidently because Set_Has_Completion is called earlier for null + -- procedures in Analyze_Subprogram_Declaration, so we force its + -- setting here. If the setting of Has_Completion is not set + -- earlier, then it can result in missing body errors if other + -- errors were already reported (since expansion is turned off). + + -- Should creation of the empty body be moved to the analyzer??? + + Set_Corresponding_Spec (Bod, Defining_Entity (Specification (N))); + end; end if; end Expand_N_Subprogram_Declaration; @@ -3448,18 +4117,16 @@ package body Exp_Ch6 is 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. + -- 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 @@ -3483,21 +4150,20 @@ package body Exp_Ch6 is if Is_Subprogram (Proc) and then Proc /= Corr then - -- Protected function or procedure. + -- 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. + -- 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. + -- Entry or barrier function for entry body. The first parameter of + -- the entry body procedure is 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; @@ -3523,9 +4189,8 @@ package body Exp_Ch6 is 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. + -- 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); @@ -3601,7 +4266,327 @@ package body Exp_Ch6 is ----------------------- procedure Freeze_Subprogram (N : Node_Id) is - E : constant Entity_Id := Entity (N); + Loc : constant Source_Ptr := Sloc (N); + E : constant Entity_Id := Entity (N); + + procedure Check_Overriding_Inherited_Interfaces (E : Entity_Id); + -- (Ada 2005): Check if the primitive E covers some interface already + -- implemented by some ancestor of the tagged-type associated with E. + + procedure Register_Interface_DT_Entry + (Prim : Entity_Id; + Ancestor_Iface_Prim : Entity_Id := Empty); + -- (Ada 2005): Register an interface primitive in a secondary dispatch + -- table. If Prim overrides an ancestor primitive of its associated + -- tagged-type then Ancestor_Iface_Prim indicates the entity of that + -- immediate ancestor associated with the interface. + + procedure Register_Predefined_DT_Entry (Prim : Entity_Id); + -- (Ada 2005): Register a predefined primitive in all the secondary + -- dispatch tables of its primitive type. + + ------------------------------------------- + -- Check_Overriding_Inherited_Interfaces -- + ------------------------------------------- + + procedure Check_Overriding_Inherited_Interfaces (E : Entity_Id) is + Typ : Entity_Id; + Elmt : Elmt_Id; + Prim_Op : Entity_Id; + Overriden_Op : Entity_Id := Empty; + + begin + if Ada_Version < Ada_05 + or else not Is_Overriding_Operation (E) + or else Is_Predefined_Dispatching_Operation (E) + or else Present (Alias (E)) + then + return; + end if; + + -- Get the entity associated with this primitive operation + + Typ := Scope (DTC_Entity (E)); + loop + exit when Etype (Typ) = Typ + or else (Present (Full_View (Etype (Typ))) + and then Full_View (Etype (Typ)) = Typ); + + -- Climb to the immediate ancestor handling private types + + if Present (Full_View (Etype (Typ))) then + Typ := Full_View (Etype (Typ)); + else + Typ := Etype (Typ); + end if; + + if Present (Abstract_Interfaces (Typ)) then + + -- Look for the overriden subprogram in the primary dispatch + -- table of the ancestor. + + Overriden_Op := Empty; + Elmt := First_Elmt (Primitive_Operations (Typ)); + while Present (Elmt) loop + Prim_Op := Node (Elmt); + + if Chars (Prim_Op) = Chars (E) + and then Type_Conformant + (New_Id => Prim_Op, + Old_Id => E, + Skip_Controlling_Formals => True) + and then DT_Position (Prim_Op) = DT_Position (E) + and then Etype (DTC_Entity (Prim_Op)) = RTE (RE_Tag) + and then No (Abstract_Interface_Alias (Prim_Op)) + then + if Overriden_Op = Empty then + Overriden_Op := Prim_Op; + + -- Additional check to ensure that if two candidates have + -- been found then they refer to the same subprogram. + + else + declare + A1 : Entity_Id; + A2 : Entity_Id; + + begin + A1 := Overriden_Op; + while Present (Alias (A1)) loop + A1 := Alias (A1); + end loop; + + A2 := Prim_Op; + while Present (Alias (A2)) loop + A2 := Alias (A2); + end loop; + + if A1 /= A2 then + raise Program_Error; + end if; + end; + end if; + end if; + + Next_Elmt (Elmt); + end loop; + + -- If not found this is the first overriding of some abstract + -- interface. + + if Overriden_Op /= Empty then + + -- Find the entries associated with interfaces that are + -- alias of this primitive operation in the ancestor. + + Elmt := First_Elmt (Primitive_Operations (Typ)); + while Present (Elmt) loop + Prim_Op := Node (Elmt); + + if Present (Abstract_Interface_Alias (Prim_Op)) + and then Alias (Prim_Op) = Overriden_Op + then + Register_Interface_DT_Entry (E, Prim_Op); + end if; + + Next_Elmt (Elmt); + end loop; + end if; + end if; + end loop; + end Check_Overriding_Inherited_Interfaces; + + --------------------------------- + -- Register_Interface_DT_Entry -- + --------------------------------- + + procedure Register_Interface_DT_Entry + (Prim : Entity_Id; + Ancestor_Iface_Prim : Entity_Id := Empty) + is + E : Entity_Id; + Prim_Typ : Entity_Id; + Prim_Op : Entity_Id; + Iface_Typ : Entity_Id; + Iface_DT_Ptr : Entity_Id; + Iface_Tag : Entity_Id; + New_Thunk : Node_Id; + Thunk_Id : Entity_Id; + + begin + -- Nothing to do if the run-time does not give support to abstract + -- interfaces. + + if not (RTE_Available (RE_Interface_Tag)) then + return; + end if; + + if No (Ancestor_Iface_Prim) then + Prim_Typ := Scope (DTC_Entity (Alias (Prim))); + + -- Look for the abstract interface subprogram + + E := Abstract_Interface_Alias (Prim); + while Present (E) + and then Is_Abstract (E) + and then not Is_Interface (Scope (DTC_Entity (E))) + loop + E := Alias (E); + end loop; + + Iface_Typ := Scope (DTC_Entity (E)); + + -- Generate the code of the thunk only when this primitive + -- operation is associated with a secondary dispatch table. + + if Is_Interface (Iface_Typ) then + Iface_Tag := Find_Interface_Tag + (T => Prim_Typ, + Iface => Iface_Typ); + + if Etype (Iface_Tag) = RTE (RE_Interface_Tag) then + Thunk_Id := + Make_Defining_Identifier (Loc, + Chars => New_Internal_Name ('T')); + + New_Thunk := + Expand_Interface_Thunk + (N => Prim, + Thunk_Alias => Alias (Prim), + Thunk_Id => Thunk_Id); + + Insert_After (N, New_Thunk); + + Iface_DT_Ptr := + Find_Interface_ADT + (T => Prim_Typ, + Iface => Iface_Typ); + + Insert_After (New_Thunk, + Fill_Secondary_DT_Entry (Sloc (Prim), + Prim => Prim, + Iface_DT_Ptr => Iface_DT_Ptr, + Thunk_Id => Thunk_Id)); + end if; + end if; + + else + Iface_Typ := + Scope (DTC_Entity (Abstract_Interface_Alias + (Ancestor_Iface_Prim))); + + Iface_Tag := + Find_Interface_Tag + (T => Scope (DTC_Entity (Alias (Ancestor_Iface_Prim))), + Iface => Iface_Typ); + + -- Generate the thunk only if the associated tag is an interface + -- tag. The case in which the associated tag is the primary tag + -- occurs when a tagged type is a direct derivation of an + -- interface. For example: + + -- type I is interface; + -- ... + -- type T is new I with ... + + if Etype (Iface_Tag) = RTE (RE_Interface_Tag) then + Thunk_Id := + Make_Defining_Identifier (Loc, + Chars => New_Internal_Name ('T')); + + if Present (Alias (Prim)) then + Prim_Op := Alias (Prim); + else + Prim_Op := Prim; + end if; + + New_Thunk := + Expand_Interface_Thunk + (N => Ancestor_Iface_Prim, + Thunk_Alias => Prim_Op, + Thunk_Id => Thunk_Id); + + Insert_After (N, New_Thunk); + + Iface_DT_Ptr := + Find_Interface_ADT + (T => Scope (DTC_Entity (Prim_Op)), + Iface => Iface_Typ); + + Insert_After (New_Thunk, + Fill_Secondary_DT_Entry (Sloc (Prim), + Prim => Ancestor_Iface_Prim, + Iface_DT_Ptr => Iface_DT_Ptr, + Thunk_Id => Thunk_Id)); + end if; + end if; + end Register_Interface_DT_Entry; + + ---------------------------------- + -- Register_Predefined_DT_Entry -- + ---------------------------------- + + procedure Register_Predefined_DT_Entry (Prim : Entity_Id) is + Iface_DT_Ptr : Elmt_Id; + Iface_Tag : Entity_Id; + Iface_Typ : Elmt_Id; + New_Thunk : Entity_Id; + Prim_Typ : Entity_Id; + Thunk_Id : Entity_Id; + + begin + Prim_Typ := Scope (DTC_Entity (Prim)); + + if No (Access_Disp_Table (Prim_Typ)) + or else No (Abstract_Interfaces (Prim_Typ)) + or else not RTE_Available (RE_Interface_Tag) + then + return; + end if; + + -- Skip the first acces-to-dispatch-table pointer since it leads + -- to the primary dispatch table. We are only concerned with the + -- secondary dispatch table pointers. Note that the access-to- + -- dispatch-table pointer corresponds to the first implemented + -- interface retrieved below. + + Iface_DT_Ptr := Next_Elmt (First_Elmt (Access_Disp_Table (Prim_Typ))); + Iface_Typ := First_Elmt (Abstract_Interfaces (Prim_Typ)); + while Present (Iface_DT_Ptr) and then Present (Iface_Typ) loop + Iface_Tag := Find_Interface_Tag (Prim_Typ, Node (Iface_Typ)); + pragma Assert (Present (Iface_Tag)); + + if Etype (Iface_Tag) = RTE (RE_Interface_Tag) then + Thunk_Id := Make_Defining_Identifier (Loc, + New_Internal_Name ('T')); + + New_Thunk := + Expand_Interface_Thunk + (N => Prim, + Thunk_Alias => Prim, + Thunk_Id => Thunk_Id); + + Insert_After (N, New_Thunk); + Insert_After (New_Thunk, + Make_DT_Access_Action (Node (Iface_Typ), + Action => Set_Predefined_Prim_Op_Address, + Args => New_List ( + Unchecked_Convert_To (RTE (RE_Tag), + New_Reference_To (Node (Iface_DT_Ptr), Loc)), + + Make_Integer_Literal (Loc, DT_Position (Prim)), + + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Thunk_Id, Loc), + Attribute_Name => Name_Address)))); + end if; + + Next_Elmt (Iface_DT_Ptr); + Next_Elmt (Iface_Typ); + end loop; + end Register_Predefined_DT_Entry; + + -- Start of processing for Freeze_Subprogram begin -- When a primitive is frozen, enter its name in the corresponding @@ -3613,16 +4598,68 @@ package body Exp_Ch6 is 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 + and then not Is_CPP_Class (Scope (DTC_Entity (E))) then Check_Overriding_Operation (E); - Insert_After (N, Fill_DT_Entry (Sloc (N), E)); + + -- Ada 95 case: Register the subprogram in the primary dispatch table + + if Ada_Version < Ada_05 then + + -- Do not register the subprogram in the dispatch table if we + -- are compiling with the No_Dispatching_Calls restriction. + + if not Restriction_Active (No_Dispatching_Calls) then + Insert_After (N, + Fill_DT_Entry (Sloc (N), Prim => E)); + end if; + + -- Ada 2005 case: Register the subprogram in the secondary dispatch + -- tables associated with abstract interfaces. + + else + declare + Typ : constant Entity_Id := Scope (DTC_Entity (E)); + + begin + -- There is no dispatch table associated with abstract + -- interface types. Each type implementing interfaces will + -- fill the associated secondary DT entries. + + if not Is_Interface (Typ) + or else Present (Alias (E)) + then + -- Ada 2005 (AI-251): Check if this entry corresponds with + -- a subprogram that covers an abstract interface type. + + if Present (Abstract_Interface_Alias (E)) then + Register_Interface_DT_Entry (E); + + -- Common case: Primitive subprogram + + else + -- Generate thunks for all the predefined operations + + if not Restriction_Active (No_Dispatching_Calls) then + if Is_Predefined_Dispatching_Operation (E) then + Register_Predefined_DT_Entry (E); + end if; + + Insert_After (N, + Fill_DT_Entry (Sloc (N), Prim => E)); + end if; + + Check_Overriding_Inherited_Interfaces (E); + end if; + end if; + end; + end if; 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) + -- underlying returned type may not be known yet (for private types). declare Typ : constant Entity_Id := Etype (E);