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

exp_aggr.adb (Initialize_Array_Component): Avoid adjusting a component of an array aggregate if...

Browse Source 
gcc/ada/

2017-10-20  Bob Duff  <duff@adacore.com>

	* exp_aggr.adb (Initialize_Array_Component): Avoid adjusting a
	component of an array aggregate if it is initialized by a
	build-in-place function call.
	* exp_ch6.adb (Is_Build_In_Place_Result_Type): Use -gnatd.9 to disable
	bip for nonlimited types.
	* debug.adb: Document -gnatd.9.

2017-10-20  Bob Duff  <duff@adacore.com>

	* sem_ch12.adb: Remove redundant setting of Parent.

2017-10-20  Eric Botcazou  <ebotcazou@adacore.com>

	* sem_ch4.adb (Find_Concatenation_Types): Filter out operators if one
	of the operands is a string literal.

2017-10-20  Bob Duff  <duff@adacore.com>

	* einfo.ads: Comment fix.

2017-10-20  Clement Fumex  <fumex@adacore.com>

	* switch-c.adb: Remove -gnatwm from the switches triggered by -gnateC.

2017-10-20  Ed Schonberg  <schonberg@adacore.com>

	* sem_dim.adb (Extract_Power): Accept dimension values that are not
	non-negative integers when the dimensioned base type is an Integer
	type.

gcc/testsuite/

2017-10-20  Ed Schonberg  <schonberg@adacore.com>

	* gnat.dg/dimensions.adb, gnat.dg/dimensions.ads: New testcase.

From-SVN: r253941
This commit is contained in:
Pierre-Marie de Rodat 2017-10-20 15:08:36 +00:00
parent 3a248f7cec
commit e201023c0e
22 changed files with 196 additions and 98 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

32
gcc/ada/ChangeLog
View File

@ -1,3 +1,35 @@
2017-10-20 Bob Duff <duff@adacore.com>
* exp_aggr.adb (Initialize_Array_Component): Avoid adjusting a
component of an array aggregate if it is initialized by a
build-in-place function call.
* exp_ch6.adb (Is_Build_In_Place_Result_Type): Use -gnatd.9 to disable
bip for nonlimited types.
* debug.adb: Document -gnatd.9.
2017-10-20 Bob Duff <duff@adacore.com>
* sem_ch12.adb: Remove redundant setting of Parent.
2017-10-20 Eric Botcazou <ebotcazou@adacore.com>
* sem_ch4.adb (Find_Concatenation_Types): Filter out operators if one
of the operands is a string literal.
2017-10-20 Bob Duff <duff@adacore.com>
* einfo.ads: Comment fix.
2017-10-20 Clement Fumex <fumex@adacore.com>
* switch-c.adb: Remove -gnatwm from the switches triggered by -gnateC.
2017-10-20 Ed Schonberg <schonberg@adacore.com>
* sem_dim.adb (Extract_Power): Accept dimension values that are not
non-negative integers when the dimensioned base type is an Integer
type.
2017-10-20 Bob Duff <duff@adacore.com>
* sinfo.ads, sinfo.adb (Alloc_For_BIP_Return): New flag to indicate

35
gcc/ada/bindgen.adb
View File

@ -646,8 +646,9 @@ package body Bindgen is
-- stack globals.
if Sec_Stack_Used then
-- Elaborate the body of the binder to initialize the
-- default-sized secondary stack pool.
-- Elaborate the body of the binder to initialize the default-
-- sized secondary stack pool.
WBI ("");
WBI (" " & Get_Ada_Main_Name & "'Elab_Body;");
@ -656,12 +657,13 @@ package body Bindgen is
-- related secondary stack globals.
Set_String (" Default_Secondary_Stack_Size := ");
if Opt.Default_Sec_Stack_Size /= Opt.No_Stack_Size then
Set_Int (Opt.Default_Sec_Stack_Size);
else
Set_String
("System.Parameters.Runtime_Default_Sec_Stack_Size");
Set_String ("System.Parameters.Runtime_Default_Sec_Stack_Size");
end if;
Set_Char (';');
Write_Statement_Buffer;
@ -988,8 +990,9 @@ package body Bindgen is
-- stack globals.
if Sec_Stack_Used then
-- Elaborate the body of the binder to initialize the
-- default-sized secondary stack pool.
-- Elaborate the body of the binder to initialize the default-
-- sized secondary stack pool.
WBI (" " & Get_Ada_Main_Name & "'Elab_Body;");
@ -997,11 +1000,13 @@ package body Bindgen is
-- related secondary stack globals.
Set_String (" Default_Secondary_Stack_Size := ");
if Opt.Default_Sec_Stack_Size /= Opt.No_Stack_Size then
Set_Int (Opt.Default_Sec_Stack_Size);
else
Set_String ("System.Parameters.Runtime_Default_Sec_Stack_Size");
end if;
Set_Char (';');
Write_Statement_Buffer;
@ -1011,17 +1016,19 @@ package body Bindgen is
Write_Statement_Buffer;
Set_String (" Default_Sized_SS_Pool := ");
if Num_Sec_Stacks > 0 then
Set_String ("Sec_Default_Sized_Stacks'Address;");
else
Set_String ("System.Null_Address;");
end if;
Write_Statement_Buffer;
Write_Statement_Buffer;
WBI ("");
end if;
-- Generate call to Runtime_Initialize
WBI (" Runtime_Initialize (1);");
end if;
@ -2195,9 +2202,11 @@ package body Bindgen is
end if;
for J in Units.First .. Units.Last loop
Num_Primary_Stacks := Num_Primary_Stacks +
Units.Table (J).Primary_Stack_Count;
Num_Sec_Stacks := Num_Sec_Stacks + Units.Table (J).Sec_Stack_Count;
Num_Primary_Stacks :=
Num_Primary_Stacks + Units.Table (J).Primary_Stack_Count;
Num_Sec_Stacks :=
Num_Sec_Stacks + Units.Table (J).Sec_Stack_Count;
end loop;
-- Generate output file in appropriate language
@ -2525,11 +2534,13 @@ package body Bindgen is
Set_String (" : array (1 .. ");
Set_Int (Num_Sec_Stacks);
Set_String (") of aliased System.Secondary_Stack.SS_Stack (");
if Opt.Default_Sec_Stack_Size /= No_Stack_Size then
Set_Int (Opt.Default_Sec_Stack_Size);
else
Set_String ("System.Parameters.Runtime_Default_Sec_Stack_Size");
end if;
Set_String (");");
Write_Statement_Buffer;
WBI ("");
@ -2568,8 +2579,8 @@ package body Bindgen is
if not Suppress_Standard_Library_On_Target then
-- The B.1(39) implementation advice says that the adainit
-- and adafinal routines should be idempotent. Generate a flag to
-- The B.1(39) implementation advice says that the adainit and
-- adafinal routines should be idempotent. Generate a flag to
-- ensure that. This is not needed if we are suppressing the
-- standard library since it would never be referenced.

2
gcc/ada/debug.adb
View File

@ -163,7 +163,7 @@ package body Debug is
-- d.6 Do not avoid declaring unreferenced types in C code
-- d.7
-- d.8
-- d.9 Enable build-in-place for nonlimited types
-- d.9 Disable build-in-place for nonlimited types
-- Debug flags for binder (GNATBIND)

6
gcc/ada/einfo.ads
View File

@ -1312,9 +1312,9 @@ package Einfo is
-- that represents an activation record pointer is an extra formal.
-- Extra_Formals (Node28)
-- Applies to subprograms and subprogram types, and also to entries
-- and entry families. Returns first extra formal of the subprogram
-- or entry. Returns Empty if there are no extra formals.
-- Applies to subprograms, subprogram types, entries, and entry
-- families. Returns first extra formal of the subprogram or entry.
-- Returns Empty if there are no extra formals.
-- Finalization_Master (Node23) [root type only]
-- Defined in access-to-controlled or access-to-class-wide types. The

1
gcc/ada/exp_aggr.adb
View File

@ -1251,6 +1251,7 @@ package body Exp_Aggr is
if Finalization_OK
and then not Is_Limited_Type (Comp_Typ)
and then not Is_Build_In_Place_Function_Call (Init_Expr)
and then not
(Is_Array_Type (Comp_Typ)
and then Is_Controlled (Component_Type (Comp_Typ))

1
gcc/ada/exp_attr.adb
View File

@ -1765,7 +1765,6 @@ package body Exp_Attr is
if Attribute_Name (Parent (Pref)) = Name_Old then
null;
else
Make_Build_In_Place_Call_In_Anonymous_Context (Pref);
end if;

25
gcc/ada/exp_ch3.adb
View File

@ -5792,6 +5792,7 @@ package body Exp_Ch3 is
Sec_Stacks : out Int)
is
Component : Entity_Id;
begin
-- To calculate the number of default-sized task stacks required for
-- an object of Typ, a depth-first recursive traversal of the AST
@ -5806,8 +5807,8 @@ package body Exp_Ch3 is
end if;
case Ekind (Typ) is
when E_Task_Type
| E_Task_Subtype
when E_Task_Subtype
| E_Task_Type
=>
-- A task type is found marking the bottom of the descent. If
-- the type has no representation aspect for the corresponding
@ -5825,8 +5826,8 @@ package body Exp_Ch3 is
Sec_Stacks := 1;
end if;
when E_Array_Type
| E_Array_Subtype
when E_Array_Subtype
| E_Array_Type
=>
-- First find the number of default stacks contained within an
-- array component.
@ -5848,10 +5849,10 @@ package body Exp_Ch3 is
Sec_Stacks := Sec_Stacks * Quantity;
end;
when E_Record_Type
| E_Record_Subtype
when E_Protected_Subtype
| E_Protected_Type
| E_Protected_Subtype
| E_Record_Subtype
| E_Record_Type
=>
Component := First_Component_Or_Discriminant (Typ);
@ -5862,7 +5863,9 @@ package body Exp_Ch3 is
while Present (Component) loop
if Has_Task (Etype (Component)) then
declare
P, S : Int;
P : Int;
S : Int;
begin
Count_Default_Sized_Task_Stacks
(Etype (Component), P, S);
@ -5874,10 +5877,10 @@ package body Exp_Ch3 is
Next_Component_Or_Discriminant (Component);
end loop;
when E_Limited_Private_Type
| E_Limited_Private_Subtype
| E_Record_Type_With_Private
when E_Limited_Private_Subtype
| E_Limited_Private_Type
| E_Record_Subtype_With_Private
| E_Record_Type_With_Private
=>
-- Switch to the full view of the private type to continue
-- search.

3
gcc/ada/exp_ch4.adb
View File

@ -5564,6 +5564,7 @@ package body Exp_Ch4 is
declare
Cnn : constant Entity_Id := Make_Temporary (Loc, 'C', N);
Ptr_Typ : constant Entity_Id := Make_Temporary (Loc, 'A');
begin
-- Generate:
-- type Ann is access all Typ;
@ -5641,6 +5642,7 @@ package body Exp_Ch4 is
then
declare
Cnn : constant Node_Id := Make_Temporary (Loc, 'C', N);
begin
Insert_Action (N,
Make_Object_Declaration (Loc,
@ -5681,6 +5683,7 @@ package body Exp_Ch4 is
declare
Cnn : constant Node_Id := Make_Temporary (Loc, 'C', N);
begin
Decl :=
Make_Object_Declaration (Loc,

10
gcc/ada/exp_ch6.adb
View File

@ -7248,7 +7248,12 @@ package body Exp_Ch6 is
if Is_Limited_View (Typ) then
return Ada_Version >= Ada_2005 and then not Debug_Flag_Dot_L;
else
if Debug_Flag_Dot_9 then
return False;
end if;
if Has_Interfaces (Typ) then
return False;
end if;
@ -7284,16 +7289,15 @@ package body Exp_Ch6 is
declare
Result : Boolean;
-- So we can stop here in the debugger
begin
-- ???For now, enable build-in-place for a very narrow set of
-- controlled types. Change "if True" to "if False" to
-- experiment more controlled types. Eventually, we would
-- like to enable build-in-place for all tagged types, all
-- types that need finalization, and all caller-unknown-size
-- types. We will eventually use Debug_Flag_Dot_9 to disable
-- build-in-place for nonlimited types.
-- types.
-- if Debug_Flag_Dot_9 then
if True then
Result := Is_Controlled (T)
and then Present (Enclosing_Subprogram (T))

42
gcc/ada/exp_ch9.adb
View File

@ -5432,8 +5432,8 @@ package body Exp_Ch9 is
(Restriction_Active (No_Implicit_Heap_Allocations)
or else Restriction_Active (No_Implicit_Task_Allocations))
and then not Restriction_Active (No_Secondary_Stack)
and then Has_Rep_Item (T, Name_Secondary_Stack_Size,
Check_Parents => False);
and then Has_Rep_Item
(T, Name_Secondary_Stack_Size, Check_Parents => False);
end Create_Secondary_Stack_For_Task;
-------------------------------------
@ -11978,8 +11978,7 @@ package body Exp_Ch9 is
Get_Rep_Item
(TaskId, Name_Secondary_Stack_Size, Check_Parents => False);
-- Get Secondary_Stack_Size expression. Can be a pragma or
-- aspect.
-- Get Secondary_Stack_Size expression. Can be a pragma or aspect.
if Nkind (Ritem) = N_Pragma then
Size_Expr :=
@ -11993,21 +11992,22 @@ package body Exp_Ch9 is
-- Create the secondary stack for the task
Decl_SS := Make_Component_Declaration (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc, Name_uSecondary_Stack),
Component_Definition =>
Make_Component_Definition (Loc,
Aliased_Present => True,
Subtype_Indication => Make_Subtype_Indication (Loc,
Subtype_Mark =>
New_Occurrence_Of (RTE (RE_SS_Stack), Loc),
Constraint =>
Make_Index_Or_Discriminant_Constraint (Loc,
Constraints => New_List (
Make_Integer_Literal (Loc,
Expr_Value (Size_Expr)))))));
Decl_SS :=
Make_Component_Declaration (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc, Name_uSecondary_Stack),
Component_Definition =>
Make_Component_Definition (Loc,
Aliased_Present => True,
Subtype_Indication =>
Make_Subtype_Indication (Loc,
Subtype_Mark =>
New_Occurrence_Of (RTE (RE_SS_Stack), Loc),
Constraint =>
Make_Index_Or_Discriminant_Constraint (Loc,
Constraints => New_List (
Make_Integer_Literal (Loc,
Expr_Value (Size_Expr)))))));
Append_To (Cdecls, Decl_SS);
end;
@ -14223,8 +14223,8 @@ package body Exp_Ch9 is
Prefix =>
Make_Selected_Component (Loc,
Prefix => Make_Identifier (Loc, Name_uInit),
Selector_Name =>
Make_Identifier (Loc, Name_uSecondary_Stack)),
Selector_Name =>
Make_Identifier (Loc, Name_uSecondary_Stack)),
Attribute_Name => Name_Unrestricted_Access));
else

5
gcc/ada/exp_util.adb
View File

@ -10820,7 +10820,10 @@ package body Exp_Util is
-- Could be e.g. a loop that was transformed into a block or null
-- statement. Do nothing for terminate alternatives.
when N_Block_Statement | N_Null_Statement | N_Terminate_Alternative =>
when N_Block_Statement
| N_Null_Statement
| N_Terminate_Alternative
=>
null;
when others =>

11
gcc/ada/lib.ads
View File

@ -455,16 +455,19 @@ package Lib is
function Generate_Code (U : Unit_Number_Type) return Boolean;
function Ident_String (U : Unit_Number_Type) return Node_Id;
function Has_RACW (U : Unit_Number_Type) return Boolean;
function Is_Predefined_Renaming (U : Unit_Number_Type) return Boolean;
function Is_Internal_Unit (U : Unit_Number_Type) return Boolean;
function Is_Predefined_Unit (U : Unit_Number_Type) return Boolean;
function Is_Predefined_Renaming
(U : Unit_Number_Type) return Boolean;
function Is_Internal_Unit (U : Unit_Number_Type) return Boolean;
function Is_Predefined_Unit
(U : Unit_Number_Type) return Boolean;
function Loading (U : Unit_Number_Type) return Boolean;
function Main_CPU (U : Unit_Number_Type) return Int;
function Main_Priority (U : Unit_Number_Type) return Int;
function Munit_Index (U : Unit_Number_Type) return Nat;
function No_Elab_Code_All (U : Unit_Number_Type) return Boolean;
function OA_Setting (U : Unit_Number_Type) return Character;
function Primary_Stack_Count (U : Unit_Number_Type) return Int;
function Primary_Stack_Count
(U : Unit_Number_Type) return Int;
function Sec_Stack_Count (U : Unit_Number_Type) return Int;
function Source_Index (U : Unit_Number_Type) return Source_File_Index;
function Unit_File_Name (U : Unit_Number_Type) return File_Name_Type;

2
gcc/ada/libgnat/s-parame.adb
View File

@ -61,8 +61,10 @@ package body System.Parameters is
begin
-- There are two situations where the default secondary stack size is
-- set to zero:
--
-- * The user sets it to zero erroneously thinking it will disable
-- the secondary stack.
--
-- * Or more likely, we are building with an old compiler and
-- Default_SS_Size is never set.
--

3
gcc/ada/sem_ch12.adb
View File

@ -5305,8 +5305,7 @@ package body Sem_Ch12 is
Valid_Operator_Definition (Act_Decl_Id);
end if;
Set_Alias (Act_Decl_Id, Anon_Id);
Set_Parent (Act_Decl_Id, Parent (Anon_Id));
Set_Alias (Act_Decl_Id, Anon_Id);
Set_Has_Completion (Act_Decl_Id);
Set_Related_Instance (Pack_Id, Act_Decl_Id);

16
gcc/ada/sem_ch4.adb
View File

@ -6431,10 +6431,24 @@ package body Sem_Ch4 is
Op_Id : Entity_Id;
N : Node_Id)
is
Op_Type : constant Entity_Id := Etype (Op_Id);
Is_String : constant Boolean := Nkind (L) = N_String_Literal
or else
Nkind (R) = N_String_Literal;
Op_Type : constant Entity_Id := Etype (Op_Id);
begin
if Is_Array_Type (Op_Type)
-- Small but very effective optimization: if at least one operand is a
-- string literal, then the type of the operator must be either array
-- of characters or array of strings.
and then (not Is_String
or else
Is_Character_Type (Component_Type (Op_Type))
or else
Is_String_Type (Component_Type (Op_Type)))
and then not Is_Limited_Type (Op_Type)
and then (Has_Compatible_Type (L, Op_Type)

28
gcc/ada/sem_dim.adb
View File

@ -518,25 +518,17 @@ package body Sem_Dim is
Position : Dimension_Position)
is
begin
-- Integer case
if Is_Integer_Type (Def_Id) then
-- Dimension value must be an integer literal
if Nkind (Expr) = N_Integer_Literal then
Dimensions (Position) := +Whole (UI_To_Int (Intval (Expr)));
else
Error_Msg_N ("integer literal expected", Expr);
end if;
-- Float case
else
Dimensions (Position) := Create_Rational_From (Expr, True);
end if;
Dimensions (Position) := Create_Rational_From (Expr, True);
Processed (Position) := True;
-- If the dimensioned root type is an integer type, it is not
-- particularly useful, and fractional dimensions do not make
-- much sense for such types, so previously we used to reject
-- dimensions of integer types that were not integer literals.
-- However, the manipulation of dimensions does not depend on
-- the kind of root type, so we can accept this usage for rare
-- cases where dimensions are specified for integer values.
end Extract_Power;
------------------------

28
gcc/ada/sem_prag.adb
View File

@ -13242,25 +13242,21 @@ package body Sem_Prag is
Set_SCO_Pragma_Enabled (Loc);
end if;
-- Deal with analyzing the string argument
-- Deal with analyzing the string argument. If checks are not
-- on we don't want any expansion (since such expansion would
-- not get properly deleted) but we do want to analyze (to get
-- proper references). The Preanalyze_And_Resolve routine does
-- just what we want. Ditto if pragma is active, because it will
-- be rewritten as an if-statement whose analysis will complete
-- analysis and expansion of the string message. This makes a
-- difference in the unusual case where the expression for the
-- string may have a side effect, such as raising an exception.
-- This is mandated by RM 11.4.2, which specifies that the string
-- expression is only evaluated if the check fails and
-- Assertion_Error is to be raised.
if Arg_Count = 3 then
-- If checks are not on we don't want any expansion (since
-- such expansion would not get properly deleted) but
-- we do want to analyze (to get proper references).
-- The Preanalyze_And_Resolve routine does just what we want.
-- Ditto if pragma is active, because it will be rewritten
-- as an if-statement whose analysis will complete analysis
-- and expansion of the string message. This makes a
-- difference in the unusual case where the expression for
-- the string may have a side effect, such as raising an
-- exception. This is mandated by RM 11.4.2, which specifies
-- that the string expression is only evaluated if the
-- check fails and Assertion_Error is to be raised.
Preanalyze_And_Resolve (Str, Standard_String);
end if;
-- Now you might think we could just do the same with the Boolean

5
gcc/ada/sem_res.adb
View File

@ -4843,9 +4843,8 @@ package body Sem_Res is
(Comes_From_Source (Parent (N))
or else
(Ekind (Current_Scope) = E_Function
and then Nkind
(Original_Node (Unit_Declaration_Node (Current_Scope)))
= N_Expression_Function))
and then Nkind (Original_Node (Unit_Declaration_Node
(Current_Scope))) = N_Expression_Function))
and then not In_Instance_Body
then
if not OK_For_Limited_Init (Etype (E), Expression (E)) then

1
gcc/ada/switch-c.adb
View File

@ -548,7 +548,6 @@ package body Switch.C is
Warn_On_Bad_Fixed_Value := True; -- -gnatwb
Warn_On_Biased_Representation := True; -- -gnatw.b
Warn_On_Export_Import := True; -- -gnatwx
Warn_On_Modified_Unread := True; -- -gnatwm
Warn_On_No_Value_Assigned := True; -- -gnatwv
Warn_On_Object_Renames_Function := True; -- -gnatw.r
Warn_On_Overlap := True; -- -gnatw.i

4
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,7 @@
2017-10-20 Ed Schonberg <schonberg@adacore.com>
* gnat.dg/dimensions.adb, gnat.dg/dimensions.ads: New testcase.
2017-10-20 Richard Biener <rguenther@suse.de>
PR tree-optimization/82473

5
gcc/testsuite/gnat.dg/dimensions.adb Normal file
View File

@ -0,0 +1,5 @@
-- { dg-do compile }
package body Dimensions is
procedure Dummy is null;
end Dimensions;

29
gcc/testsuite/gnat.dg/dimensions.ads Normal file
View File

@ -0,0 +1,29 @@
package Dimensions is
type Mks_Int_Type is new Integer
with
Dimension_System => (
(Unit_Name => Meter, Unit_Symbol => 'm', Dim_Symbol => 'L'),
(Unit_Name => Kilogram, Unit_Symbol => "kg", Dim_Symbol => 'M'),
(Unit_Name => Second, Unit_Symbol => 's', Dim_Symbol => 'T'),
(Unit_Name => Ampere, Unit_Symbol => 'A', Dim_Symbol => 'I'),
(Unit_Name => Kelvin, Unit_Symbol => 'K', Dim_Symbol => '@'),
(Unit_Name => Mole, Unit_Symbol => "mol", Dim_Symbol => 'N'),
(Unit_Name => Candela, Unit_Symbol => "cd", Dim_Symbol => 'J'));
subtype Int_Length is Mks_Int_Type
with
Dimension => (Symbol => 'm',
Meter => 1,
others => 0);
subtype Int_Speed is Mks_Int_Type
with
Dimension => (
Meter => 1,
Second => -1,
others => 0);
procedure Dummy;
end Dimensions;