diff options
| -rw-r--r-- | gcc/ada/ChangeLog | 35 | ||||
| -rw-r--r-- | gcc/ada/exp_aggr.adb | 233 | ||||
| -rw-r--r-- | gcc/ada/exp_ch13.adb | 9 | ||||
| -rw-r--r-- | gcc/ada/exp_util.adb | 13 | ||||
| -rw-r--r-- | gcc/ada/g-forstr.ads | 18 | ||||
| -rw-r--r-- | gcc/ada/opt.ads | 14 | ||||
| -rw-r--r-- | gcc/ada/sem_aggr.adb | 64 | ||||
| -rw-r--r-- | gcc/ada/sem_prag.adb | 60 | ||||
| -rw-r--r-- | gcc/ada/sinfo.adb | 18 | ||||
| -rw-r--r-- | gcc/ada/sinfo.ads | 15 |
10 files changed, 349 insertions, 130 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 50b466a..bcd9e52 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,38 @@ +2016-07-04 Hristian Kirtchev <kirtchev@adacore.com> + + * 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 <charlet@adacore.com> + + * opt.ads, sem_prag.adb (Universal_Addressing_On_AAMP): Removed. + Remove support for pragma No_Run_Time. Update comments. + +2016-07-04 Pascal Obry <obry@adacore.com> + + * g-forstr.ads: More documentation for the Formatted_String + support. + +2016-07-04 Ed Schonberg <schonberg@adacore.com> + + * 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 <ebotcazou@adacore.com> PR ada/48835 diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb index c3949df..f40b56d 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 11e75f3..dd004a0 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 b52fccc..f3b6375 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 94c295c..a43ba5f 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 402a9e5..4027fab 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 8b65045..feb1a4a 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 c9213f1..a2392e6 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 f8ed04c..5ea25db 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 860f0d1c..29feb25 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); |