OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

[multiple changes] 

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.

From-SVN: r237959
This commit is contained in:
Arnaud Charlet 2016-07-04 12:00:57 +02:00
parent 15f6e0dac3
commit 10edebe7b4
10 changed files with 349 additions and 130 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

35
gcc/ada/ChangeLog
View File

@ -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

233
gcc/ada/exp_aggr.adb
View File

@ -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;
--------------

9
gcc/ada/exp_ch13.adb
View File

@ -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;

13
gcc/ada/exp_util.adb
View File

@ -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

18
gcc/ada/g-forstr.ads
View File

@ -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';

14
gcc/ada/opt.ads
View File

@ -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

64
gcc/ada/sem_aggr.adb
View File

@ -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

60
gcc/ada/sem_prag.adb
View File

@ -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
-- Set appropriate restrictions
if Ttypes.System_Word_Size = 32 then
Duration_32_Bits_On_Target := True;
end if;
Set_Restriction (No_Finalization, N);
Set_Restriction (No_Exception_Handlers, N);
Set_Restriction (Max_Tasks, N, 0);
Set_Restriction (No_Tasking, N);
-- Set appropriate restrictions
-----------------------
-- No_Tagged_Streams --
-----------------------
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;
-- pragma No_Tagged_Streams;
-- pragma No_Tagged_Streams ([Entity => ]tagged_type_local_NAME);
-----------------------
-- No_Tagged_Streams --
-----------------------
-- 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 --

18
gcc/ada/sinfo.adb
View File

@ -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

15
gcc/ada/sinfo.ads
View File

@ -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);