diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index c5f88c7a898..a8470b6f2c5 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -1,4 +1,4 @@ ------------------------------------------------------------------------------- +----------------------------------------------------------------------------- -- -- -- GNAT COMPILER COMPONENTS -- -- -- @@ -110,13 +110,16 @@ package body Exp_Ch6 is procedure Add_Final_List_Actual_To_Build_In_Place_Call (Function_Call : Node_Id; Function_Id : Entity_Id; - Acc_Type : Entity_Id); + Acc_Type : Entity_Id; + Sel_Comp : Node_Id := Empty); -- Ada 2005 (AI-318-02): For a build-in-place call, if the result type has -- controlled parts, add an actual parameter that is a pointer to -- appropriate finalization list. The finalization list is that of the -- current scope, except for "new Acc'(F(...))" in which case it's the -- finalization list of the access type returned by the allocator. Acc_Type - -- is that type in the allocator case; Empty otherwise. + -- is that type in the allocator case; Empty otherwise. If Sel_Comp is + -- not Empty, then it denotes a selected component and the finalization + -- list is obtained from the _controller list of the prefix object. procedure Add_Task_Actuals_To_Build_In_Place_Call (Function_Call : Node_Id; @@ -379,12 +382,16 @@ package body Exp_Ch6 is procedure Add_Final_List_Actual_To_Build_In_Place_Call (Function_Call : Node_Id; Function_Id : Entity_Id; - Acc_Type : Entity_Id) + Acc_Type : Entity_Id; + Sel_Comp : Node_Id := Empty) is Loc : constant Source_Ptr := Sloc (Function_Call); Final_List : Node_Id; Final_List_Actual : Node_Id; Final_List_Formal : Node_Id; + Is_Ctrl_Result : constant Boolean := + Controlled_Type + (Underlying_Type (Etype (Function_Id))); begin -- No such extra parameter is needed if there are no controlled parts. @@ -395,7 +402,7 @@ package body Exp_Ch6 is -- must be treated the same as a call to class-wide functions. Both of -- these situations require that a finalization list be passed. - if not Controlled_Type (Underlying_Type (Etype (Function_Id))) + if not Is_Ctrl_Result and then not Is_Tagged_Type (Underlying_Type (Etype (Function_Id))) then return; @@ -416,6 +423,14 @@ package body Exp_Ch6 is Present (Associated_Final_Chain (Base_Type (Acc_Type)))) then Final_List := Find_Final_List (Acc_Type); + + -- If Sel_Comp is present and the function result is controlled, then + -- the finalization list will be obtained from the _controller list of + -- the selected component's prefix object. + + elsif Present (Sel_Comp) and then Is_Ctrl_Result then + Final_List := Find_Final_List (Current_Scope, Sel_Comp); + else Final_List := Find_Final_List (Current_Scope); end if; @@ -1016,7 +1031,7 @@ package body Exp_Ch6 is Low_Bound => Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (Var, Loc), - Attribute_name => Name_First), + Attribute_Name => Name_First), High_Bound => Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (Var, Loc), @@ -1541,8 +1556,7 @@ package body Exp_Ch6 is -- 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 ??? + -- conversion" errors. elsif Is_Access_Type (E_Formal) and then not Same_Type (E_Formal, Etype (Actual)) @@ -1662,9 +1676,9 @@ package body Exp_Ch6 is -- 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: + -- Expand_N_Procedure_Call_Statement). Processing for calls includes: - -- Replace call to Raise_Exception by Raise_Exception always if possible + -- 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 @@ -1694,12 +1708,12 @@ package body Exp_Ch6 is 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. + -- type inherits from the original parent, not from the actual. The + -- current derivation mechanism has the derived type inherit from the + -- actual, which is only correct outside of the instance. If the + -- subprogram is inherited, we test for this particular case through a + -- convoluted tree traversal before setting the proper subprogram to be + -- called. -------------------------- -- Add_Actual_Parameter -- @@ -1919,11 +1933,11 @@ package body Exp_Ch6 is -- Replace call to Raise_Exception by call to Raise_Exception_Always -- if we can tell that the first parameter cannot possibly be null. - -- This helps optimization and also generation of warnings. + -- This improves efficiency by avoiding a run-time test. -- We do not do this if Raise_Exception_Always does not exist, which -- can happen in configurable run time profiles which provide only a - -- Raise_Exception, which is in fact an unconditional raise anyway. + -- Raise_Exception. if Is_RTE (Subp, RE_Raise_Exception) and then RTE_Available (RE_Raise_Exception_Always) @@ -2547,21 +2561,31 @@ package body Exp_Ch6 is if Nkind_In (N, N_Function_Call, N_Procedure_Call_Statement) and then Present (Controlling_Argument (N)) - and then VM_Target = No_VM then - Expand_Dispatching_Call (N); + if VM_Target = No_VM then + Expand_Dispatching_Call (N); - -- The following return is worrisome. Is it really OK to - -- skip all remaining processing in this procedure ??? + -- The following return is worrisome. Is it really OK to + -- skip all remaining processing in this procedure ??? - return; + return; + + -- Expansion of a dispatching call results in an indirect call, which + -- in turn causes current values to be killed (see Resolve_Call), so + -- on VM targets we do the call here to ensure consistent warnings + -- between VM and non-VM targets. + + else + Kill_Current_Values; + end if; + end if; -- 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 rewriting to occur in expanded code. - elsif Is_All_Remote_Call (N) then + if 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 @@ -3110,34 +3134,6 @@ 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. - - -- Note: We must check that the node has not been inlined. This is - -- required because under zfp the Raise_Exception subprogram has the - -- pragma inline_always (and hence the call has been expanded above - -- into a block containing the code of the subprogram). - - if Ada_Version >= Ada_05 - and then not GNAT_Mode - and then Is_RTE (Subp, RE_Raise_Exception) - and then Nkind (N) = N_Procedure_Call_Statement - 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; -------------------------- @@ -3978,12 +3974,9 @@ package body Exp_Ch6 is Loc : constant Source_Ptr := Sloc (N); H : constant Node_Id := Handled_Statement_Sequence (N); Body_Id : Entity_Id; - Spec_Id : Entity_Id; Except_H : Node_Id; - Scop : Entity_Id; - Dec : Node_Id; - Next_Op : Node_Id; L : List_Id; + Spec_Id : Entity_Id; procedure Add_Return (S : List_Id); -- Append a return statement to the statement sequence S if the last @@ -4165,6 +4158,8 @@ package body Exp_Ch6 is if Is_Scalar_Type (Etype (F)) and then Ekind (F) = E_Out_Parameter then + Check_Restriction (No_Default_Initialization, F); + -- Insert the initialization. We turn off validity checks -- for this assignment, since we do not want any check on -- the initial value itself (which may well be invalid). @@ -4172,7 +4167,7 @@ package body Exp_Ch6 is Insert_Before_And_Analyze (First (L), Make_Assignment_Statement (Loc, Name => New_Occurrence_Of (F, Loc), - Expression => Get_Simple_Init_Val (Etype (F), Loc)), + Expression => Get_Simple_Init_Val (Etype (F), N)), Suppress => Validity_Check); end if; @@ -4181,34 +4176,6 @@ 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 @@ -4226,6 +4193,16 @@ package body Exp_Ch6 is end if; end if; + -- Create a set of discriminals for the next protected subprogram body + + if Is_List_Member (N) + and then Present (Parent (List_Containing (N))) + and then Nkind (Parent (List_Containing (N))) = N_Protected_Body + and then Present (Next_Protected_Operation (N)) + then + Set_Discriminals (Parent (Base_Type (Scope (Spec_Id)))); + end if; + -- Returns_By_Ref flag is normally set when the subprogram is frozen -- but subprograms with no specs are not frozen. @@ -4324,37 +4301,6 @@ package body Exp_Ch6 is 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; - -- Set to encode entity names in package body before gigi is called Qualify_Entity_Names (N); @@ -4780,7 +4726,7 @@ package body Exp_Ch6 is New_Reference_To (Node (Next_Elmt (Iface_DT_Ptr)), Loc), Position => DT_Position (Prim), Address_Node => - Unchecked_Convert_To (RTE (RE_Address), + Unchecked_Convert_To (RTE (RE_Prim_Ptr), Make_Attribute_Reference (Loc, Prefix => New_Reference_To (Thunk_Id, Loc), Attribute_Name => Name_Unrestricted_Access))), @@ -4792,7 +4738,7 @@ package body Exp_Ch6 is Loc), Position => DT_Position (Prim), Address_Node => - Unchecked_Convert_To (RTE (RE_Address), + Unchecked_Convert_To (RTE (RE_Prim_Ptr), Make_Attribute_Reference (Loc, Prefix => New_Reference_To (Prim, Loc), Attribute_Name => Name_Unrestricted_Access))))); @@ -5250,8 +5196,16 @@ package body Exp_Ch6 is Add_Alloc_Form_Actual_To_Build_In_Place_Call (Func_Call, Function_Id, Alloc_Form => Caller_Allocation); - Add_Final_List_Actual_To_Build_In_Place_Call - (Func_Call, Function_Id, Acc_Type => Empty); + -- If Lhs is a selected component, then pass it along so that its prefix + -- object will be used as the source of the finalization list. + + if Nkind (Lhs) = N_Selected_Component then + Add_Final_List_Actual_To_Build_In_Place_Call + (Func_Call, Function_Id, Acc_Type => Empty, Sel_Comp => Lhs); + else + Add_Final_List_Actual_To_Build_In_Place_Call + (Func_Call, Function_Id, Acc_Type => Empty); + end if; Add_Task_Actuals_To_Build_In_Place_Call (Func_Call, Function_Id, Make_Identifier (Loc, Name_uMaster)); diff --git a/gcc/ada/exp_tss.adb b/gcc/ada/exp_tss.adb index e3a7c292c25..f9b9e33374e 100644 --- a/gcc/ada/exp_tss.adb +++ b/gcc/ada/exp_tss.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2008, 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- -- @@ -28,6 +28,8 @@ with Einfo; use Einfo; with Elists; use Elists; with Exp_Util; use Exp_Util; with Lib; use Lib; +with Restrict; use Restrict; +with Rident; use Rident; with Sem_Util; use Sem_Util; with Sinfo; use Sinfo; @@ -159,11 +161,16 @@ package body Exp_Tss is -- Has_Non_Null_Base_Init_Proc -- --------------------------------- + -- Note: if a base Init_Proc is present, and No_Default_Initialization is + -- present, then we must avoid testing for a null init proc, since there + -- is no init proc present in this case. + function Has_Non_Null_Base_Init_Proc (Typ : Entity_Id) return Boolean is BIP : constant Entity_Id := Base_Init_Proc (Typ); - begin - return Present (BIP) and then not Is_Null_Init_Proc (BIP); + return Present (BIP) + and then (Restriction_Active (No_Default_Initialization) + or else not Is_Null_Init_Proc (BIP)); end Has_Non_Null_Base_Init_Proc; --------------- @@ -306,20 +313,31 @@ package body Exp_Tss is ------------- procedure Set_TSS (Typ : Entity_Id; TSS : Entity_Id) is - Subprog_Body : constant Node_Id := Unit_Declaration_Node (TSS); - begin - -- Case of insertion location is in unit defining the type + -- Make sure body of subprogram is frozen - if In_Same_Code_Unit (Typ, TSS) then - Append_Freeze_Action (Typ, Subprog_Body); + -- Skip this for Init_Proc with No_Default_Initialization, since the + -- Init proc is a dummy void entity in this case to be ignored. - -- Otherwise, we are using an already existing TSS in another unit + if Is_Init_Proc (TSS) + and then Restriction_Active (No_Default_Initialization) + then + null; + + -- Skip this if not in the same code unit (since it means we are using + -- an already existing TSS in another unit) + + elsif not In_Same_Code_Unit (Typ, TSS) then + null; + + -- Otherwise make sure body is frozen else - null; + Append_Freeze_Action (Typ, Unit_Declaration_Node (TSS)); end if; + -- Set TSS entry + Copy_TSS (TSS, Typ); end Set_TSS; diff --git a/gcc/ada/s-rident.ads b/gcc/ada/s-rident.ads index b88e3691cba..68a5197266f 100644 --- a/gcc/ada/s-rident.ads +++ b/gcc/ada/s-rident.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2006, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2008, 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- -- @@ -56,7 +56,9 @@ package System.Rident is type Restriction_Id is - -- The following cases are checked for consistency in the binder + -- The following cases are checked for consistency in the binder. The + -- binder will check that every unit either has the restriction set, or + -- does not violate the restriction. (Simple_Barriers, -- GNAT (Ravenscar) No_Abort_Statements, -- (RM D.7(5), H.4(3)) @@ -111,7 +113,12 @@ package System.Rident is Static_Priorities, -- GNAT Static_Storage_Size, -- GNAT - -- The following cases do not require partition-wide checks + -- The following require consistency checking with special rules. See + -- individual routines in unit Bcheck for details of what is required. + + No_Default_Initialization, -- GNAT + + -- The following cases do not require consistency checking Immediate_Reclamation, -- (RM H.4(10)) No_Implementation_Attributes, -- Ada 2005 AI-257 @@ -123,29 +130,28 @@ package System.Rident is -- The following cases require a parameter value - -- The following entries are fully checked at compile/bind time, - -- which means that the compiler can in general tell the minimum - -- value which could be used with a restrictions pragma. The binder - -- can deduce the appropriate minimum value for the partition by - -- taking the maximum value required by any unit. + -- The following entries are fully checked at compile/bind time, which + -- means that the compiler can in general tell the minimum value which + -- could be used with a restrictions pragma. The binder can deduce the + -- appropriate minimum value for the partition by taking the maximum + -- value required by any unit. Max_Protected_Entries, -- (RM D.7(14)) Max_Select_Alternatives, -- (RM D.7(12)) Max_Task_Entries, -- (RM D.7(13), H.4(3)) - -- The following entries are also fully checked at compile/bind - -- time, and the compiler can also at least in some cases tell - -- the minimum value which could be used with a restriction pragma. - -- The difference is that the contributions are additive, so the - -- binder deduces this value by adding the unit contributions. + -- The following entries are also fully checked at compile/bind time, + -- and the compiler can also at least in some cases tell the minimum + -- value which could be used with a restriction pragma. The difference + -- is that the contributions are additive, so the binder deduces this + -- value by adding the unit contributions. Max_Tasks, -- (RM D.7(19), H.4(3)) - -- The following entries are checked at compile time only for - -- zero/nonzero entries. This means that the compiler can tell - -- at compile time if a restriction value of zero is (would be) - -- violated, but that is all. The compiler cannot distinguish - -- between different non-zero values. + -- The following entries are checked at compile time only for zero/ + -- nonzero entries. This means that the compiler can tell at compile + -- time if a restriction value of zero is (would be) violated, but that + -- the compiler cannot distinguish between different non-zero values. Max_Asynchronous_Select_Nesting, -- (RM D.7(18), H.4(3)) Max_Entry_Queue_Length, -- GNAT @@ -237,9 +243,9 @@ package System.Rident is -- Restriction Status Declarations -- ------------------------------------- - -- The following declarations are used to record the current status - -- or restrictions (for the current unit, or related units, at compile - -- time, and for all units in a partition at bind time or run time). + -- The following declarations are used to record the current status or + -- restrictions (for the current unit, or related units, at compile time, + -- and for all units in a partition at bind time or run time). type Restriction_Flags is array (All_Restrictions) of Boolean; type Restriction_Values is array (All_Parameter_Restrictions) of Natural; @@ -247,11 +253,10 @@ package System.Rident is type Restrictions_Info is record Set : Restriction_Flags; - -- An entry is True in the Set array if a restrictions pragma has - -- been encountered for the given restriction. If the value is - -- True for a parameter restriction, then the corresponding entry - -- in the Value array gives the minimum value encountered for any - -- such restriction. + -- An entry is True in the Set array if a restrictions pragma has been + -- encountered for the given restriction. If the value is True for a + -- parameter restriction, then the corresponding entry in the Value + -- array gives the minimum value encountered for any such restriction. Value : Restriction_Values; -- If the entry for a parameter restriction in Set is True (i.e. a @@ -261,23 +266,23 @@ package System.Rident is -- pragma specifying a value greater than Int'Last is simply ignored. Violated : Restriction_Flags; - -- An entry is True in the violations array if the compiler has - -- detected a violation of the restriction. For a parameter - -- restriction, the Count and Unknown arrays have additional - -- information. + -- An entry is True in the violations array if the compiler has detected + -- a violation of the restriction. For a parameter restriction, the + -- Count and Unknown arrays have additional information. Count : Restriction_Values; - -- If an entry for a parameter restriction is True in Violated, - -- the corresponding entry in the Count array may record additional + -- If an entry for a parameter restriction is True in Violated, the + -- corresponding entry in the Count array may record additional -- information. If the actual minimum count is known (by taking -- maximums, or sums, depending on the restriction), it will be -- recorded in this array. If not, then the value will remain zero. + -- The value is also zero for a non-violated restriction. Unknown : Parameter_Flags; - -- If an entry for a parameter restriction is True in Violated, - -- the corresponding entry in the Unknown array may record additional + -- If an entry for a parameter restriction is True in Violated, the + -- corresponding entry in the Unknown array may record additional -- information. If the actual count is not known by the compiler (but - -- is known to be non-zero), then the entry in Unknown will be True. + -- is nown to be non-zero), then the entry in Unknown will be True. -- This indicates that the value in Count is not known to be exact, -- and the actual violation count may be higher.