From: Arnaud Charlet Date: Mon, 4 Jul 2016 10:00:57 +0000 (+0200) Subject: [multiple changes] X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=10edebe7b49ee1903bca94e03d4cf9c8194c3905;p=gcc.git [multiple changes] 2016-07-04 Hristian Kirtchev * exp_aggr.adb (Ctrl_Init_Expression): New routine. (Gen_Assign): Code cleanup. Perform in-place side effect removal when the expression denotes a controlled function call. * exp_util.adb (Remove_Side_Effects): Do not remove side effects on a function call which has this behavior suppressed. * sem_aggr.adb Code cleanup. * sinfo.adb (No_Side_Effect_Removal): New routine. (Set_Side_Effect_Removal): New routine. * sinfo.ads New attribute No_Side_Effect_Removal along with occurences in nodes. (No_Side_Effect_Removal): New routine along with pragma Inline. (Set_Side_Effect_Removal): New routine along with pragma Inline. 2016-07-04 Arnaud Charlet * opt.ads, sem_prag.adb (Universal_Addressing_On_AAMP): Removed. Remove support for pragma No_Run_Time. Update comments. 2016-07-04 Pascal Obry * g-forstr.ads: More documentation for the Formatted_String support. 2016-07-04 Ed Schonberg * exp_ch13.adb (Expand_N_Attribute_Definition_Clause, case 'Address): If the address comes from an aspect specification and not a source attribute definition clause, do not remove side effects from the expression, because the expression must be elaborated at the freeze point of the object and not at the object declaration, because of the delayed analysis of aspect specifications. From-SVN: r237959 --- diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 50b466a4fd8..bcd9e52fa34 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,38 @@ +2016-07-04 Hristian Kirtchev + + * exp_aggr.adb (Ctrl_Init_Expression): New routine. + (Gen_Assign): Code cleanup. Perform in-place side effect removal when + the expression denotes a controlled function call. + * exp_util.adb (Remove_Side_Effects): Do not remove side effects + on a function call which has this behavior suppressed. + * sem_aggr.adb Code cleanup. + * sinfo.adb (No_Side_Effect_Removal): New routine. + (Set_Side_Effect_Removal): New routine. + * sinfo.ads New attribute No_Side_Effect_Removal along with + occurences in nodes. + (No_Side_Effect_Removal): New routine along with pragma Inline. + (Set_Side_Effect_Removal): New routine along with pragma Inline. + +2016-07-04 Arnaud Charlet + + * opt.ads, sem_prag.adb (Universal_Addressing_On_AAMP): Removed. + Remove support for pragma No_Run_Time. Update comments. + +2016-07-04 Pascal Obry + + * g-forstr.ads: More documentation for the Formatted_String + support. + +2016-07-04 Ed Schonberg + + * exp_ch13.adb (Expand_N_Attribute_Definition_Clause, case + 'Address): If the address comes from an aspect specification + and not a source attribute definition clause, do not remove + side effects from the expression, because the expression must + be elaborated at the freeze point of the object and not at the + object declaration, because of the delayed analysis of aspect + specifications. + 2016-06-29 Eric Botcazou PR ada/48835 diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb index c3949dfa7f0..f40b56d718e 100644 --- a/gcc/ada/exp_aggr.adb +++ b/gcc/ada/exp_aggr.adb @@ -1017,19 +1017,20 @@ package body Exp_Aggr is ---------------- function Gen_Assign (Ind : Node_Id; Expr : Node_Id) return List_Id is - L : constant List_Id := New_List; - A : Node_Id; - - New_Indexes : List_Id; - Indexed_Comp : Node_Id; - Expr_Q : Node_Id; - Comp_Type : Entity_Id := Empty; - function Add_Loop_Actions (Lis : List_Id) return List_Id; -- Collect insert_actions generated in the construction of a -- loop, and prepend them to the sequence of assignments to -- complete the eventual body of the loop. + function Ctrl_Init_Expression + (Comp_Typ : Entity_Id; + Stmts : List_Id) return Node_Id; + -- Perform in-place side effect removal if expression Expr denotes a + -- controlled function call. Return a reference to the entity which + -- captures the result of the call. Comp_Typ is the expected type of + -- the component. Stmts is the list of initialization statmenets. Any + -- generated code is added to Stmts. + ---------------------- -- Add_Loop_Actions -- ---------------------- @@ -1057,6 +1058,91 @@ package body Exp_Aggr is end if; end Add_Loop_Actions; + -------------------------- + -- Ctrl_Init_Expression -- + -------------------------- + + function Ctrl_Init_Expression + (Comp_Typ : Entity_Id; + Stmts : List_Id) return Node_Id + is + Init_Expr : Node_Id; + Obj_Id : Entity_Id; + Ptr_Typ : Entity_Id; + + begin + Init_Expr := New_Copy_Tree (Expr); + + -- Perform a preliminary analysis and resolution to determine + -- what the expression denotes. Note that a function call may + -- appear as an identifier or an indexed component. + + Preanalyze_And_Resolve (Init_Expr, Comp_Typ); + + -- The initialization expression is a controlled function call. + -- Perform in-place removal of side effects to avoid creating a + -- transient scope. In the end the temporary function result is + -- finalized by the general finalization machinery. + + if Nkind (Init_Expr) = N_Function_Call then + + -- Suppress the removal of side effects by generatal analysis + -- because this behavior is emulated here. + + Set_No_Side_Effect_Removal (Init_Expr); + + -- Generate: + -- type Ptr_Typ is access all Comp_Typ; + + Ptr_Typ := Make_Temporary (Loc, 'A'); + + Append_To (Stmts, + Make_Full_Type_Declaration (Loc, + Defining_Identifier => Ptr_Typ, + Type_Definition => + Make_Access_To_Object_Definition (Loc, + All_Present => True, + Subtype_Indication => + New_Occurrence_Of (Comp_Typ, Loc)))); + + -- Generate: + -- Obj : constant Ptr_Typ := Init_Expr'Reference; + + Obj_Id := Make_Temporary (Loc, 'R'); + + Append_To (Stmts, + Make_Object_Declaration (Loc, + Defining_Identifier => Obj_Id, + Object_Definition => New_Occurrence_Of (Ptr_Typ, Loc), + Expression => Make_Reference (Loc, Init_Expr))); + + -- Generate: + -- Obj.all; + + return + Make_Explicit_Dereference (Loc, + Prefix => New_Occurrence_Of (Obj_Id, Loc)); + + -- Otherwise the initialization expression denotes a controlled + -- object. There is nothing special to be done here as there is + -- no possible transient scope involvement. + + else + return Init_Expr; + end if; + end Ctrl_Init_Expression; + + -- Local variables + + Stmts : constant List_Id := New_List; + + Comp_Typ : Entity_Id := Empty; + Expr_Q : Node_Id; + Indexed_Comp : Node_Id; + New_Indexes : List_Id; + Stmt : Node_Id; + Stmt_Expr : Node_Id; + -- Start of processing for Gen_Assign begin @@ -1102,8 +1188,8 @@ package body Exp_Aggr is end if; if Present (Etype (N)) and then Etype (N) /= Any_Composite then - Comp_Type := Component_Type (Etype (N)); - pragma Assert (Comp_Type = Ctype); -- AI-287 + Comp_Typ := Component_Type (Etype (N)); + pragma Assert (Comp_Typ = Ctype); -- AI-287 elsif Present (Next (First (New_Indexes))) then @@ -1129,7 +1215,7 @@ package body Exp_Aggr is if Nkind (P) = N_Aggregate and then Present (Etype (P)) then - Comp_Type := Component_Type (Etype (P)); + Comp_Typ := Component_Type (Etype (P)); exit; else @@ -1137,7 +1223,7 @@ package body Exp_Aggr is end if; end loop; - pragma Assert (Comp_Type = Ctype); -- AI-287 + pragma Assert (Comp_Typ = Ctype); -- AI-287 end; end if; end if; @@ -1155,8 +1241,8 @@ package body Exp_Aggr is -- the analysis of non-array aggregates now in order to get the -- value of Expansion_Delayed flag for the inner aggregate ??? - if Present (Comp_Type) and then not Is_Array_Type (Comp_Type) then - Analyze_And_Resolve (Expr_Q, Comp_Type); + if Present (Comp_Typ) and then not Is_Array_Type (Comp_Typ) then + Analyze_And_Resolve (Expr_Q, Comp_Typ); end if; if Is_Delayed_Aggregate (Expr_Q) then @@ -1171,9 +1257,9 @@ package body Exp_Aggr is -- generated in the usual fashion, and sliding will take place. if Nkind (Parent (N)) = N_Assignment_Statement - and then Is_Array_Type (Comp_Type) + and then Is_Array_Type (Comp_Typ) and then Present (Component_Associations (Expr_Q)) - and then Must_Slide (Comp_Type, Etype (Expr_Q)) + and then Must_Slide (Comp_Typ, Etype (Expr_Q)) then Set_Expansion_Delayed (Expr_Q, False); Set_Analyzed (Expr_Q, False); @@ -1201,7 +1287,7 @@ package body Exp_Aggr is if Present (Base_Init_Proc (Base_Type (Ctype))) or else Has_Task (Base_Type (Ctype)) then - Append_List_To (L, + Append_List_To (Stmts, Build_Initialization_Call (Loc, Id_Ref => Indexed_Comp, Typ => Ctype, @@ -1214,28 +1300,81 @@ package body Exp_Aggr is if Has_Invariants (Ctype) then Set_Etype (Indexed_Comp, Ctype); - Append_To (L, Make_Invariant_Call (Indexed_Comp)); + Append_To (Stmts, Make_Invariant_Call (Indexed_Comp)); end if; elsif Is_Access_Type (Ctype) then - Append_To (L, + Append_To (Stmts, Make_Assignment_Statement (Loc, - Name => Indexed_Comp, + Name => New_Copy_Tree (Indexed_Comp), Expression => Make_Null (Loc))); end if; if Needs_Finalization (Ctype) then - Append_To (L, + Append_To (Stmts, Make_Init_Call (Obj_Ref => New_Copy_Tree (Indexed_Comp), Typ => Ctype)); end if; else - A := + -- Handle an initialization expression of a controlled type in + -- case it denotes a function call. In general such a scenario + -- will produce a transient scope, but this will lead to wrong + -- order of initialization, adjustment, and finalization in the + -- context of aggregates. + + -- Arr_Comp (1) := Ctrl_Func_Call; + + -- begin -- transient scope + -- Trans_Obj : ... := Ctrl_Func_Call; -- transient object + -- Arr_Comp (1) := Trans_Obj; + -- Finalize (Trans_Obj); + -- end; + -- Arr_Comp (1)._tag := ...; + -- Adjust (Arr_Comp (1)); + + -- In the example above, the call to Finalize occurs too early + -- and as a result it may leave the array component in a bad + -- state. Finalization of the transient object should really + -- happen after adjustment. + + -- To avoid this scenario, perform in-place side effect removal + -- of the function call. This eliminates the transient property + -- of the function result and ensures correct order of actions. + -- Note that the function result behaves as a source controlled + -- object and is finalized by the general finalization mechanism. + + -- begin + -- Res : ... := Ctrl_Func_Call; + -- Arr_Comp (1) := Res; + -- Arr_Comp (1)._tag := ...; + -- Adjust (Arr_Comp (1)); + -- at end + -- Finalize (Res); + -- end; + + -- There is no need to perform this kind of light expansion when + -- the component type is limited controlled because everything is + -- already done in place. + + if Present (Comp_Typ) + and then Needs_Finalization (Comp_Typ) + and then not Is_Limited_Type (Comp_Typ) + and then Nkind (Expr) /= N_Aggregate + then + Stmt_Expr := Ctrl_Init_Expression (Comp_Typ, Stmts); + + -- Otherwise use the initialization expression directly + + else + Stmt_Expr := New_Copy_Tree (Expr); + end if; + + Stmt := Make_OK_Assignment_Statement (Loc, - Name => Indexed_Comp, - Expression => New_Copy_Tree (Expr)); + Name => New_Copy_Tree (Indexed_Comp), + Expression => Stmt_Expr); -- The target of the assignment may not have been initialized, -- so it is not possible to call Finalize as expected in normal @@ -1248,7 +1387,7 @@ package body Exp_Aggr is -- actions are done manually with the proper finalization list -- coming from the context. - Set_No_Ctrl_Actions (A); + Set_No_Ctrl_Actions (Stmt); -- If this is an aggregate for an array of arrays, each -- subaggregate will be expanded as well, and even with @@ -1260,33 +1399,31 @@ package body Exp_Aggr is -- that finalization takes place for each subaggregate we wrap the -- assignment in a block. - if Present (Comp_Type) - and then Needs_Finalization (Comp_Type) - and then Is_Array_Type (Comp_Type) + if Present (Comp_Typ) + and then Needs_Finalization (Comp_Typ) + and then Is_Array_Type (Comp_Typ) and then Present (Expr) then - A := + Stmt := Make_Block_Statement (Loc, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, - Statements => New_List (A))); + Statements => New_List (Stmt))); end if; - Append_To (L, A); + Append_To (Stmts, Stmt); - -- Adjust the tag if tagged (because of possible view - -- conversions), unless compiling for a VM where tags - -- are implicit. + -- Adjust the tag due to a possible view conversion - if Present (Comp_Type) - and then Is_Tagged_Type (Comp_Type) + if Present (Comp_Typ) + and then Is_Tagged_Type (Comp_Typ) and then Tagged_Type_Expansion then declare - Full_Typ : constant Entity_Id := Underlying_Type (Comp_Type); + Full_Typ : constant Entity_Id := Underlying_Type (Comp_Typ); begin - A := + Append_To (Stmts, Make_OK_Assignment_Statement (Loc, Name => Make_Selected_Component (Loc, @@ -1299,9 +1436,7 @@ package body Exp_Aggr is Unchecked_Convert_To (RTE (RE_Tag), New_Occurrence_Of (Node (First_Elmt (Access_Disp_Table (Full_Typ))), - Loc))); - - Append_To (L, A); + Loc)))); end; end if; @@ -1316,22 +1451,22 @@ package body Exp_Aggr is -- (see comments above, concerning the creation of a block to hold -- inner finalization actions). - if Present (Comp_Type) - and then Needs_Finalization (Comp_Type) - and then not Is_Limited_Type (Comp_Type) + if Present (Comp_Typ) + and then Needs_Finalization (Comp_Typ) + and then not Is_Limited_Type (Comp_Typ) and then not - (Is_Array_Type (Comp_Type) - and then Is_Controlled (Component_Type (Comp_Type)) + (Is_Array_Type (Comp_Typ) + and then Is_Controlled (Component_Type (Comp_Typ)) and then Nkind (Expr) = N_Aggregate) then - Append_To (L, + Append_To (Stmts, Make_Adjust_Call (Obj_Ref => New_Copy_Tree (Indexed_Comp), - Typ => Comp_Type)); + Typ => Comp_Typ)); end if; end if; - return Add_Loop_Actions (L); + return Add_Loop_Actions (Stmts); end Gen_Assign; -------------- diff --git a/gcc/ada/exp_ch13.adb b/gcc/ada/exp_ch13.adb index 11e75f37b8b..dd004a0991f 100644 --- a/gcc/ada/exp_ch13.adb +++ b/gcc/ada/exp_ch13.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2016, 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- -- @@ -136,9 +136,16 @@ package body Exp_Ch13 is -- has a delayed freeze, but the address expression itself -- must be elaborated at the point it appears. If the object -- is controlled, additional checks apply elsewhere. + -- If the attribute comes from an aspect specification it + -- is being elaborated at the freeze point and side effects + -- need not be removed (and shouldn't, if the expression + -- depends on other entities that have delayed freeze). + -- This is another consequence of the delayed analysis of + -- aspects, and a real semantic difference. elsif Nkind (Decl) = N_Object_Declaration and then not Needs_Constant_Address (Decl, Typ) + and then not From_Aspect_Specification (N) then Remove_Side_Effects (Exp); end if; diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index b52fcccbdb4..f3b63758e31 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -7693,14 +7693,23 @@ package body Exp_Util is and (Inside_A_Generic or not Full_Analysis or not GNATprove_Mode) then return; - end if; -- Cannot generate temporaries if the invocation to remove side effects -- was issued too early and the type of the expression is not resolved -- (this happens because routines Duplicate_Subexpr_XX implicitly invoke -- Remove_Side_Effects). - if No (Exp_Type) or else Ekind (Exp_Type) = E_Access_Attribute_Type then + elsif No (Exp_Type) + or else Ekind (Exp_Type) = E_Access_Attribute_Type + then + return; + + -- Nothing to do if prior expansion determined that a function call does + -- not require side effect removal. + + elsif Nkind (Exp) = N_Function_Call + and then No_Side_Effect_Removal (Exp) + then return; -- No action needed for side-effect free expressions diff --git a/gcc/ada/g-forstr.ads b/gcc/ada/g-forstr.ads index 94c295c7251..a43ba5f7a84 100644 --- a/gcc/ada/g-forstr.ads +++ b/gcc/ada/g-forstr.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2014, Free Software Foundation, Inc. -- +-- Copyright (C) 2014-2016, 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- -- @@ -29,10 +29,22 @@ -- -- ------------------------------------------------------------------------------ --- This package add support for formatted string as supported by C printf(). +-- This package add support for formatted string as supported by C printf() -- A simple usage is: - +-- +-- Put_Line (-(+"%s" & "a string")); +-- +-- or with a constant for the format: +-- +-- declare +-- Format : constant Formatted_String := +"%s"; +-- begin +-- Put_Line (-(Format & "a string")); +-- end; +-- +-- Finally a more complex example: +-- -- declare -- F : Formatted_String := +"['%c' ; %10d]"; -- C : Character := 'v'; diff --git a/gcc/ada/opt.ads b/gcc/ada/opt.ads index 402a9e50e5e..4027fab60ed 100644 --- a/gcc/ada/opt.ads +++ b/gcc/ada/opt.ads @@ -776,8 +776,7 @@ package Opt is GNAT_Encodings : Int; pragma Import (C, GNAT_Encodings, "gnat_encodings"); -- Constant controlling the balance between GNAT encodings and standard - -- DWARF to emit in the debug information. See aamissing.c for definitions - -- for the GNAAMP back end. It accepts the following values. + -- DWARF to emit in the debug information. It accepts the following values. DWARF_GNAT_Encodings_All : constant Int := 0; DWARF_GNAT_Encodings_GDB : constant Int := 1; @@ -1194,13 +1193,11 @@ package Opt is Optimization_Level : Int; pragma Import (C, Optimization_Level, "optimize"); -- Constant reflecting the optimization level (0,1,2,3 for -O0,-O1,-O2,-O3) - -- See e.g. aamissing.c for definitions for the GNAAMP back end. Optimize_Size : Int; pragma Import (C, Optimize_Size, "optimize_size"); -- Constant reflecting setting of -Os (optimize for size). Set to nonzero - -- in -Os mode and set to zero otherwise. See aamissing.c for definition - -- of "optimize_size" for the GNAAMP backend. + -- in -Os mode and set to zero otherwise. Output_File_Name_Present : Boolean := False; -- GNATBIND, GNAT, GNATMAKE @@ -1576,13 +1573,6 @@ package Opt is -- If true, activates the circuitry for unnesting subprograms (see the spec -- of Exp_Unst for full details). Currently set only by use of -gnatd.1. - Universal_Addressing_On_AAMP : Boolean := False; - -- GNAAMP - -- Indicates if library-level objects should be accessed and updated using - -- universal addressing instructions on the AAMP architecture. This flag is - -- set to True when pragma Universal_Data is given as a configuration - -- pragma. - Unreserve_All_Interrupts : Boolean := False; -- GNAT, GNATBIND -- Normally set False, set True if a valid Unreserve_All_Interrupts pragma diff --git a/gcc/ada/sem_aggr.adb b/gcc/ada/sem_aggr.adb index 8b6504575ca..feb1a4a2150 100644 --- a/gcc/ada/sem_aggr.adb +++ b/gcc/ada/sem_aggr.adb @@ -1821,6 +1821,25 @@ package body Sem_Aggr is end if; Step_2 : declare + function Empty_Range (A : Node_Id) return Boolean; + -- If an association covers an empty range, some warnings on the + -- expression of the association can be disabled. + + ----------------- + -- Empty_Range -- + ----------------- + + function Empty_Range (A : Node_Id) return Boolean is + R : constant Node_Id := First (Choices (A)); + begin + return No (Next (R)) + and then Nkind (R) = N_Range + and then Compile_Time_Compare + (Low_Bound (R), High_Bound (R), False) = GT; + end Empty_Range; + + -- Local variables + Low : Node_Id; High : Node_Id; -- Denote the lowest and highest values in an aggregate choice @@ -1845,23 +1864,6 @@ package body Sem_Aggr is Errors_Posted_On_Choices : Boolean := False; -- Keeps track of whether any choices have semantic errors - function Empty_Range (A : Node_Id) return Boolean; - -- If an association covers an empty range, some warnings on the - -- expression of the association can be disabled. - - ----------------- - -- Empty_Range -- - ----------------- - - function Empty_Range (A : Node_Id) return Boolean is - R : constant Node_Id := First (Choices (A)); - begin - return No (Next (R)) - and then Nkind (R) = N_Range - and then Compile_Time_Compare - (Low_Bound (R), High_Bound (R), False) = GT; - end Empty_Range; - -- Start of processing for Step_2 begin @@ -3429,10 +3431,6 @@ package body Sem_Aggr is ----------------------- procedure Resolve_Aggr_Expr (Expr : Node_Id; Component : Node_Id) is - Expr_Type : Entity_Id := Empty; - New_C : Entity_Id := Component; - New_Expr : Node_Id; - function Has_Expansion_Delayed (Expr : Node_Id) return Boolean; -- If the expression is an aggregate (possibly qualified) then its -- expansion is delayed until the enclosing aggregate is expanded @@ -3442,15 +3440,6 @@ package body Sem_Aggr is -- dynamic-sized aggregate in the code, something that gigi cannot -- handle. - Relocate : Boolean; - -- Set to True if the resolved Expr node needs to be relocated when - -- attached to the newly created association list. This node need not - -- be relocated if its parent pointer is not set. In fact in this - -- case Expr is the output of a New_Copy_Tree call. If Relocate is - -- True then we have analyzed the expression node in the original - -- aggregate and hence it needs to be relocated when moved over to - -- the new association list. - --------------------------- -- Has_Expansion_Delayed -- --------------------------- @@ -3466,6 +3455,21 @@ package body Sem_Aggr is and then Has_Expansion_Delayed (Expression (Expr))); end Has_Expansion_Delayed; + -- Local variables + + Expr_Type : Entity_Id := Empty; + New_C : Entity_Id := Component; + New_Expr : Node_Id; + + Relocate : Boolean; + -- Set to True if the resolved Expr node needs to be relocated when + -- attached to the newly created association list. This node need not + -- be relocated if its parent pointer is not set. In fact in this + -- case Expr is the output of a New_Copy_Tree call. If Relocate is + -- True then we have analyzed the expression node in the original + -- aggregate and hence it needs to be relocated when moved over to + -- the new association list. + -- Start of processing for Resolve_Aggr_Expr begin diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index c9213f18fbd..a2392e68ee3 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -44,6 +44,7 @@ with Exp_Dist; use Exp_Dist; with Exp_Util; use Exp_Util; with Freeze; use Freeze; with Ghost; use Ghost; +with Gnatvsn; use Gnatvsn; with Lib; use Lib; with Lib.Writ; use Lib.Writ; with Lib.Xref; use Lib.Xref; @@ -17623,28 +17624,38 @@ package body Sem_Prag is Check_Valid_Configuration_Pragma; Check_Arg_Count (0); - No_Run_Time_Mode := True; - Configurable_Run_Time_Mode := True; + -- Remove backward compatibility if Build_Type is FSF or GPL and + -- generate a warning. - -- Set Duration to 32 bits if word size is 32 + declare + Ignore : constant Boolean := Build_Type in FSF .. GPL; + begin + if Ignore then + Error_Pragma ("pragma% is ignored, has no effect??"); + else + No_Run_Time_Mode := True; + Configurable_Run_Time_Mode := True; - if Ttypes.System_Word_Size = 32 then - Duration_32_Bits_On_Target := True; - end if; + -- Set Duration to 32 bits if word size is 32 + + if Ttypes.System_Word_Size = 32 then + Duration_32_Bits_On_Target := True; + end if; - -- Set appropriate restrictions + -- Set appropriate restrictions - Set_Restriction (No_Finalization, N); - Set_Restriction (No_Exception_Handlers, N); - Set_Restriction (Max_Tasks, N, 0); - Set_Restriction (No_Tasking, N); + Set_Restriction (No_Finalization, N); + Set_Restriction (No_Exception_Handlers, N); + Set_Restriction (Max_Tasks, N, 0); + Set_Restriction (No_Tasking, N); + end if; + end; - ----------------------- - -- No_Tagged_Streams -- - ----------------------- + ----------------------- + -- No_Tagged_Streams -- + ----------------------- - -- pragma No_Tagged_Streams; - -- pragma No_Tagged_Streams ([Entity => ]tagged_type_local_NAME); + -- pragma No_Tagged_Streams [([Entity => ]tagged_type_local_NAME)]; when Pragma_No_Tagged_Streams => No_Tagged_Strms : declare E : Entity_Id; @@ -22338,22 +22349,7 @@ package body Sem_Prag is when Pragma_Universal_Data => GNAT_Pragma; - - -- If this is a configuration pragma, then set the universal - -- addressing option, otherwise confirm that the pragma satisfies - -- the requirements of library unit pragma placement and leave it - -- to the GNAAMP back end to detect the pragma (avoids transitive - -- setting of the option due to withed units). - - if Is_Configuration_Pragma then - Universal_Addressing_On_AAMP := True; - else - Check_Valid_Library_Unit_Pragma; - end if; - - if not AAMP_On_Target then - Error_Pragma ("??pragma% ignored (applies only to AAMP)"); - end if; + Error_Pragma ("??pragma% ignored (applies only to AAMP)"); ---------------- -- Unmodified -- diff --git a/gcc/ada/sinfo.adb b/gcc/ada/sinfo.adb index f8ed04c9ed6..5ea25db3ee5 100644 --- a/gcc/ada/sinfo.adb +++ b/gcc/ada/sinfo.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2016, 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- -- @@ -2409,6 +2409,14 @@ package body Sinfo is return Flag17 (N); end No_Minimize_Eliminate; + function No_Side_Effect_Removal + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Function_Call); + return Flag1 (N); + end No_Side_Effect_Removal; + function No_Truncation (N : Node_Id) return Boolean is begin @@ -5664,6 +5672,14 @@ package body Sinfo is Set_Flag17 (N, Val); end Set_No_Minimize_Eliminate; + procedure Set_No_Side_Effect_Removal + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Function_Call); + Set_Flag1 (N, Val); + end Set_No_Side_Effect_Removal; + procedure Set_No_Truncation (N : Node_Id; Val : Boolean := True) is begin diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads index 860f0d1c978..29feb256401 100644 --- a/gcc/ada/sinfo.ads +++ b/gcc/ada/sinfo.ads @@ -1946,6 +1946,12 @@ package Sinfo is -- It is used to indicate that processing for extended overflow checking -- modes is not required (this is used to prevent infinite recursion). + -- No_Side_Effect_Removal (Flag1-Sem) + -- Present in N_Function_Call nodes. Set when a function call does not + -- require side effect removal. This attribute suppresses the generation + -- of a temporary to capture the result of the function which eventually + -- replaces the function call. + -- No_Truncation (Flag17-Sem) -- Present in N_Unchecked_Type_Conversion node. This flag has an effect -- only if the RM_Size of the source is greater than the RM_Size of the @@ -5296,6 +5302,7 @@ package Sinfo is -- actual parameter part) -- First_Named_Actual (Node4-Sem) -- Controlling_Argument (Node1-Sem) (set to Empty if not dispatching) + -- No_Side_Effect_Removal (Flag1-Sem) -- Is_Expanded_Build_In_Place_Call (Flag11-Sem) -- Do_Tag_Check (Flag13-Sem) -- No_Elaboration_Check (Flag14-Sem) @@ -9540,6 +9547,9 @@ package Sinfo is function No_Minimize_Eliminate (N : Node_Id) return Boolean; -- Flag17 + function No_Side_Effect_Removal + (N : Node_Id) return Boolean; -- Flag1 + function No_Truncation (N : Node_Id) return Boolean; -- Flag17 @@ -10581,6 +10591,9 @@ package Sinfo is procedure Set_No_Minimize_Eliminate (N : Node_Id; Val : Boolean := True); -- Flag17 + procedure Set_No_Side_Effect_Removal + (N : Node_Id; Val : Boolean := True); -- Flag1 + procedure Set_No_Truncation (N : Node_Id; Val : Boolean := True); -- Flag17 @@ -12877,6 +12890,7 @@ package Sinfo is pragma Inline (No_Entities_Ref_In_Spec); pragma Inline (No_Initialization); pragma Inline (No_Minimize_Eliminate); + pragma Inline (No_Side_Effect_Removal); pragma Inline (No_Truncation); pragma Inline (Non_Aliased_Prefix); pragma Inline (Null_Present); @@ -13220,6 +13234,7 @@ package Sinfo is pragma Inline (Set_No_Entities_Ref_In_Spec); pragma Inline (Set_No_Initialization); pragma Inline (Set_No_Minimize_Eliminate); + pragma Inline (Set_No_Side_Effect_Removal); pragma Inline (Set_No_Truncation); pragma Inline (Set_Non_Aliased_Prefix); pragma Inline (Set_Null_Excluding_Subtype);