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

[multiple changes] 

2014-05-21  Robert Dewar  <dewar@adacore.com>

	* gnatcmd.adb: Minor error msg changes (no upper case letter
	at start).
	* sem_ch12.adb, sem_ch5.adb, sem_res.adb, sem_util.adb: Minor
	reformatting.

2014-05-21  Robert Dewar  <dewar@adacore.com>

	* debug.adb: Debug flag -gnatd.G inhibits static elab tracing
	via generic formals.
	* sem_elab.adb (Is_Call_Of_Generic_Formal): Return False if
	-gnatd.G is set.

2014-05-21  Thomas Quinot  <quinot@adacore.com>

	* exp_pakd.adb (Revert_Storage_Order): Renamed from Byte_Swap to
	more accurately describe that this subprogram needs to come into
	play also in cases where no byte swapping is involved, because
	it also takes care of some required shifts (left-justification
	of values).

2014-05-21  Thomas Quinot  <quinot@adacore.com>

	* freeze.adb (Check_Component_Storage_Order): Indicate whether
	a Scalar_Storage_Order attribute definition is present for the
	component's type.
	(Freeze_Record_Type): Suppress junk warnings
	about purportedly junk Bit_Order / Scalar_Storage_Order attribute
	definitions.

2014-05-21  Robert Dewar  <dewar@adacore.com>

	* sem_ch8.adb (Analyze_Subprogram_Renaming): Put back call
	to Kill_Elaboration_Checks.

2014-05-21  Gary Dismukes  <dismukes@adacore.com>

	* layout.adb (Assoc_Add): Suppress the optimization of the (E
	- C1) + C2 case, when the expression type is unsigned and C1 <
	C2, to avoid creating a negative literal when folding.

From-SVN: r210709
This commit is contained in:
Arnaud Charlet 2014-05-21 15:25:03 +02:00
parent ea26c8e414
commit ee6208f2d5
12 changed files with 200 additions and 112 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

42
gcc/ada/ChangeLog
View File

@ -1,3 +1,45 @@
2014-05-21 Robert Dewar <dewar@adacore.com>
* gnatcmd.adb: Minor error msg changes (no upper case letter
at start).
* sem_ch12.adb, sem_ch5.adb, sem_res.adb, sem_util.adb: Minor
reformatting.
2014-05-21 Robert Dewar <dewar@adacore.com>
* debug.adb: Debug flag -gnatd.G inhibits static elab tracing
via generic formals.
* sem_elab.adb (Is_Call_Of_Generic_Formal): Return False if
-gnatd.G is set.
2014-05-21 Thomas Quinot <quinot@adacore.com>
* exp_pakd.adb (Revert_Storage_Order): Renamed from Byte_Swap to
more accurately describe that this subprogram needs to come into
play also in cases where no byte swapping is involved, because
it also takes care of some required shifts (left-justification
of values).
2014-05-21 Thomas Quinot <quinot@adacore.com>
* freeze.adb (Check_Component_Storage_Order): Indicate whether
a Scalar_Storage_Order attribute definition is present for the
component's type.
(Freeze_Record_Type): Suppress junk warnings
about purportedly junk Bit_Order / Scalar_Storage_Order attribute
definitions.
2014-05-21 Robert Dewar <dewar@adacore.com>
* sem_ch8.adb (Analyze_Subprogram_Renaming): Put back call
to Kill_Elaboration_Checks.
2014-05-21 Gary Dismukes <dismukes@adacore.com>
* layout.adb (Assoc_Add): Suppress the optimization of the (E
- C1) + C2 case, when the expression type is unsigned and C1 <
C2, to avoid creating a negative literal when folding.
2014-05-21 Hristian Kirtchev <kirtchev@adacore.com>
* freeze.adb (Freeze_Record_Type): Update the use of

7
gcc/ada/debug.adb
View File

@ -124,7 +124,7 @@ package body Debug is
-- d.D
-- d.E Turn selected errors into warnings
-- d.F Debug mode for GNATprove
-- d.G
-- d.G Ignore calls through generic formal parameters for elaboration
-- d.H
-- d.I Do not ignore enum representation clauses in CodePeer mode
-- d.J Disable parallel SCIL generation mode
@ -623,6 +623,11 @@ package body Debug is
-- d.F Sets GNATprove_Mode to True. This allows debugging the frontend in
-- the special mode used by GNATprove.
-- d.G Previously the compiler ignored calls via generic formal parameters
-- when doing the analysis for the static elaboration model. This is
-- now fixed, but we provide this debug flag to revert to the previous
-- situation of ignoring such calls to aid in transition.
-- d.I Do not ignore enum representation clauses in CodePeer mode.
-- The default of ignoring representation clauses for enumeration
-- types in CodePeer is good for the majority of Ada code, but in some

65
gcc/ada/exp_pakd.adb
View File

@ -543,25 +543,19 @@ package body Exp_Pakd is
-- array type on the fly). Such actions are inserted into the tree
-- directly using Insert_Action.
function Byte_Swap
(N : Node_Id;
Left_Justify : Boolean := False;
Right_Justify : Boolean := False) return Node_Id;
-- Wrap N in a call to a byte swapping function, with appropriate type
-- conversions. If Left_Justify is set True, the value is left justified
-- before swapping. If Right_Justify is set True, the value is right
-- justified after swapping. The Etype of the returned node is an
-- integer type of an appropriate power-of-2 size.
function Revert_Storage_Order (N : Node_Id) return Node_Id;
-- Perform appropriate justification and byte ordering adjustments for N,
-- an element of a packed array type, when both the component type and
-- the enclosing packed array type have reverse scalar storage order.
-- On little-endian targets, the value is left justified before byte
-- swapping. The Etype of the returned expression is an integer type of
-- an appropriate power-of-2 size.
---------------
-- Byte_Swap --
---------------
--------------------------
-- Revert_Storage_Order --
--------------------------
function Byte_Swap
(N : Node_Id;
Left_Justify : Boolean := False;
Right_Justify : Boolean := False) return Node_Id
is
function Revert_Storage_Order (N : Node_Id) return Node_Id is
Loc : constant Source_Ptr := Sloc (N);
T : constant Entity_Id := Etype (N);
T_Size : constant Uint := RM_Size (T);
@ -571,16 +565,21 @@ package body Exp_Pakd is
Swap_T : Entity_Id;
-- Swapping function
Arg : Node_Id;
Swapped : Node_Id;
Shift : Uint;
Arg : Node_Id;
Adjusted : Node_Id;
Shift : Uint;
begin
if T_Size <= 8 then
-- Array component size is less than a byte: no swapping needed
Swap_F := Empty;
Swap_T := RTE (RE_Unsigned_8);
else
-- Select byte swapping function depending on array component size
if T_Size <= 16 then
Swap_RE := RE_Bswap_16;
@ -600,7 +599,7 @@ package body Exp_Pakd is
Arg := RJ_Unchecked_Convert_To (Swap_T, N);
if Left_Justify and then Shift > Uint_0 then
if not Bytes_Big_Endian and then Shift > Uint_0 then
Arg :=
Make_Op_Shift_Left (Loc,
Left_Opnd => Arg,
@ -608,24 +607,17 @@ package body Exp_Pakd is
end if;
if Present (Swap_F) then
Swapped :=
Adjusted :=
Make_Function_Call (Loc,
Name => New_Occurrence_Of (Swap_F, Loc),
Parameter_Associations => New_List (Arg));
else
Swapped := Arg;
Adjusted := Arg;
end if;
if Right_Justify and then Shift > Uint_0 then
Swapped :=
Make_Op_Shift_Right (Loc,
Left_Opnd => Swapped,
Right_Opnd => Make_Integer_Literal (Loc, Shift));
end if;
Set_Etype (Swapped, Swap_T);
return Swapped;
end Byte_Swap;
Set_Etype (Adjusted, Swap_T);
return Adjusted;
end Revert_Storage_Order;
------------------------------
-- Compute_Linear_Subscript --
@ -2095,15 +2087,10 @@ package body Exp_Pakd is
-- it back to its expected endianness after extraction.
if Reverse_Storage_Order (Atyp)
and then Esize (Atyp) > 8
and then (Is_Record_Type (Ctyp) or else Is_Array_Type (Ctyp))
and then Reverse_Storage_Order (Ctyp)
then
Arg :=
Byte_Swap
(Arg,
Left_Justify => not Bytes_Big_Endian,
Right_Justify => False);
Arg := Revert_Storage_Order (Arg);
end if;
-- We needed to analyze this before we do the unchecked convert

117
gcc/ada/freeze.adb
View File

@ -90,16 +90,19 @@ package body Freeze is
-- performed only after the object has been frozen.
procedure Check_Component_Storage_Order
(Encl_Type : Entity_Id;
Comp : Entity_Id;
ADC : Node_Id);
(Encl_Type : Entity_Id;
Comp : Entity_Id;
ADC : Node_Id;
Comp_ADC_Present : out Boolean);
-- For an Encl_Type that has a Scalar_Storage_Order attribute definition
-- clause, verify that the component type has an explicit and compatible
-- attribute/aspect. For arrays, Comp is Empty; for records, it is the
-- entity of the component under consideration. For an Encl_Type that
-- does not have a Scalar_Storage_Order attribute definition clause,
-- verify that the component also does not have such a clause.
-- ADC is the attribute definition clause if present (or Empty).
-- ADC is the attribute definition clause if present (or Empty). On return,
-- Comp_ADC_Present is set True if the component has a Scalar_Storage_Order
-- attribute definition clause.
procedure Check_Strict_Alignment (E : Entity_Id);
-- E is a base type. If E is tagged or has a component that is aliased
@ -1070,9 +1073,10 @@ package body Freeze is
-----------------------------------
procedure Check_Component_Storage_Order
(Encl_Type : Entity_Id;
Comp : Entity_Id;
ADC : Node_Id)
(Encl_Type : Entity_Id;
Comp : Entity_Id;
ADC : Node_Id;
Comp_ADC_Present : out Boolean)
is
Comp_Type : Entity_Id;
Comp_ADC : Node_Id;
@ -1124,12 +1128,13 @@ package body Freeze is
Comp_ADC := Get_Attribute_Definition_Clause
(First_Subtype (Comp_Type),
Attribute_Scalar_Storage_Order);
Comp_ADC_Present := Present (Comp_ADC);
-- Case of enclosing type not having explicit SSO: component cannot
-- have it either.
if No (ADC) then
if Present (Comp_ADC) then
if Comp_ADC_Present then
Error_Msg_N
("composite type must have explicit scalar storage order",
Err_Node);
@ -2350,14 +2355,19 @@ package body Freeze is
-- Check for scalar storage order
Check_Component_Storage_Order
(Encl_Type => Arr,
Comp => Empty,
ADC => Get_Attribute_Definition_Clause
(First_Subtype (Arr),
Attribute_Scalar_Storage_Order));
declare
Dummy : Boolean;
begin
Check_Component_Storage_Order
(Encl_Type => Arr,
Comp => Empty,
ADC => Get_Attribute_Definition_Clause
(First_Subtype (Arr),
Attribute_Scalar_Storage_Order),
Comp_ADC_Present => Dummy);
end;
-- Processing that is done only for subtypes
-- Processing that is done only for subtypes
else
-- Acquire alignment from base type
@ -2549,8 +2559,8 @@ package body Freeze is
procedure Freeze_Record_Type (Rec : Entity_Id) is
Comp : Entity_Id;
IR : Node_Id;
ADC : Node_Id;
Prev : Entity_Id;
ADC : Node_Id;
Junk : Boolean;
pragma Warnings (Off, Junk);
@ -2560,6 +2570,9 @@ package body Freeze is
-- stack. Needed for the analysis of delayed aspects specified to the
-- components of Rec.
SSO_ADC : Node_Id;
-- Scalar_Storage_Order attribute definition clause for the record
Unplaced_Component : Boolean := False;
-- Set True if we find at least one component with no component
-- clause (used to warn about useless Pack pragmas).
@ -2574,6 +2587,10 @@ package body Freeze is
-- is used to prevent Implicit_Packing of the record, since packing
-- cannot modify the size of alignment of an aliased component.
SSO_ADC_Component : Boolean := False;
-- Set True if we find at least one component whose type has a
-- Scalar_Storage_Order attribute definition clause.
All_Scalar_Components : Boolean := True;
-- Set False if we encounter a component of a non-scalar type
@ -3014,56 +3031,80 @@ package body Freeze is
Next_Entity (Comp);
end loop;
ADC := Get_Attribute_Definition_Clause
(Rec, Attribute_Scalar_Storage_Order);
SSO_ADC := Get_Attribute_Definition_Clause
(Rec, Attribute_Scalar_Storage_Order);
if Present (ADC) then
-- Check consistent attribute setting on component types
declare
Comp_ADC_Present : Boolean;
begin
Comp := First_Component (Rec);
while Present (Comp) loop
Check_Component_Storage_Order
(Encl_Type => Rec,
Comp => Comp,
ADC => SSO_ADC,
Comp_ADC_Present => Comp_ADC_Present);
SSO_ADC_Component := SSO_ADC_Component or Comp_ADC_Present;
Next_Component (Comp);
end loop;
end;
if Present (SSO_ADC) then
-- Check compatibility of Scalar_Storage_Order with Bit_Order, if
-- the former is specified.
if Reverse_Bit_Order (Rec) /= Reverse_Storage_Order (Rec) then
-- Note: report error on Rec, not on ADC, as ADC may apply to
-- an ancestor type.
-- Note: report error on Rec, not on SSO_ADC, as ADC may apply
-- to some ancestor type.
Error_Msg_Sloc := Sloc (ADC);
Error_Msg_Sloc := Sloc (SSO_ADC);
Error_Msg_N
("scalar storage order for& specified# inconsistent with "
& "bit order", Rec);
end if;
-- Warn if there is a Scalar_Storage_Order but no component clause
-- (or pragma Pack).
-- Warn if there is an Scalar_Storage_Order attribute definition
-- clause but no component clause, no component that itself has
-- such an attribute definition, and no pragma Pack.
if not (Placed_Component or else Is_Packed (Rec)) then
if not (Placed_Component
or else
SSO_ADC_Component
or else
Is_Packed (Rec))
then
Error_Msg_N
("??scalar storage order specified but no component clause",
ADC);
SSO_ADC);
end if;
end if;
-- Check consistent attribute setting on component types
Comp := First_Component (Rec);
while Present (Comp) loop
Check_Component_Storage_Order
(Encl_Type => Rec, Comp => Comp, ADC => ADC);
Next_Component (Comp);
end loop;
-- Deal with Bit_Order aspect specifying a non-default bit order
-- Deal with Bit_Order aspect
ADC := Get_Attribute_Definition_Clause (Rec, Attribute_Bit_Order);
if Present (ADC) and then Base_Type (Rec) = Rec then
if not (Placed_Component or else Is_Packed (Rec)) then
if not (Placed_Component
or else
Present (SSO_ADC)
or else
Is_Packed (Rec))
then
-- Warn if clause has no effect when no component clause is
-- present, but suppress warning if the Bit_Order is required
-- due to the presence of a Scalar_Storage_Order attribute.
Error_Msg_N
("??bit order specification has no effect", ADC);
Error_Msg_N
("\??since no component clauses were specified", ADC);
-- Here is where we do the processing for reversed bit order
-- Here is where we do the processing to adjust component clauses
-- for reversed bit order.
elsif Reverse_Bit_Order (Rec)
and then not Reverse_Storage_Order (Rec)

27
gcc/ada/gnatcmd.adb
View File

@ -1527,7 +1527,7 @@ begin
if Command_List (The_Command).VMS_Only then
Non_VMS_Usage;
Fail
("Command """
("command """
& Command_List (The_Command).Cname.all
& """ can only be used on VMS");
end if;
@ -1542,13 +1542,13 @@ begin
begin
Alternate := Alternate_Command'Value
(Argument (Command_Arg));
(Argument (Command_Arg));
The_Command := Corresponding_To (Alternate);
exception
when Constraint_Error =>
Non_VMS_Usage;
Fail ("Unknown command: " & Argument (Command_Arg));
Fail ("unknown command: " & Argument (Command_Arg));
end;
end;
@ -1578,12 +1578,9 @@ begin
exception
when others =>
Put
(Standard_Error, "Cannot open argument file """);
Put
(Standard_Error,
The_Arg (The_Arg'First + 1 .. The_Arg'Last));
Put (Standard_Error, "Cannot open argument file """);
Put (Standard_Error,
The_Arg (The_Arg'First + 1 .. The_Arg'Last));
Put_Line (Standard_Error, """");
raise Error_Exit;
end;
@ -1816,7 +1813,7 @@ begin
end case;
else
Fail ("invalid verbosity level: "
& Argv (Argv'First + 3 .. Argv'Last));
& Argv (Argv'First + 3 .. Argv'Last));
end if;
Remove_Switch (Arg_Num);
@ -2104,13 +2101,13 @@ begin
end if;
end;
if The_Command = Bind
or else The_Command = Link
or else The_Command = Elim
if The_Command = Bind or else
The_Command = Link or else
The_Command = Elim
then
if Project.Object_Directory.Name = No_Path then
Fail ("project " & Get_Name_String (Project.Display_Name) &
" has no object directory");
Fail ("project " & Get_Name_String (Project.Display_Name)
& " has no object directory");
end if;
Change_Dir (Get_Name_String (Project.Object_Directory.Name));

13
gcc/ada/layout.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2001-2013, Free Software Foundation, Inc. --
-- Copyright (C) 2001-2014, 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- --
@ -353,7 +353,7 @@ package body Layout is
elsif Nkind (L) = N_Op_Subtract then
-- (C1 - E) + C2 = (C1 + C2) + E
-- (C1 - E) + C2 = (C1 + C2) - E
if Compile_Time_Known_Value (Sinfo.Left_Opnd (L)) then
Rewrite_Integer
@ -363,7 +363,14 @@ package body Layout is
-- (E - C1) + C2 = E - (C1 - C2)
elsif Compile_Time_Known_Value (Sinfo.Right_Opnd (L)) then
-- If the type is unsigned, then only do the optimization if
-- C1 >= C2, to avoid creating a negative literal that can't be
-- used with the unsigned type.
elsif Compile_Time_Known_Value (Sinfo.Right_Opnd (L))
and then (not Is_Unsigned_Type (Etype (Sinfo.Right_Opnd (L)))
or else Expr_Value (Sinfo.Right_Opnd (L)) >= R)
then
Rewrite_Integer
(Sinfo.Right_Opnd (L),
Expr_Value (Sinfo.Right_Opnd (L)) - R);

1
gcc/ada/sem_ch12.adb
View File

@ -10070,7 +10070,6 @@ package body Sem_Ch12 is
Set_Corresponding_Spec (Act_Body, Act_Decl_Id);
Check_Generic_Actuals (Act_Decl_Id, False);
Check_Initialized_Types;
-- Install primitives hidden at the point of the instantiation but

1
gcc/ada/sem_ch5.adb
View File

@ -1875,7 +1875,6 @@ package body Sem_Ch5 is
if No (Elt) then
Error_Msg_N
("missing Element primitive for iteration", N);
else
Set_Etype (Def_Id, Etype (Elt));
end if;

24
gcc/ada/sem_ch8.adb
View File

@ -2505,26 +2505,25 @@ package body Sem_Ch8 is
end if;
end if;
-- At this point, we used to have the following, but we removed it
-- because it was certainly wrong for generic formal parameters in
-- at least some cases, causing elaboration checks to be skipped.
-- Possibly it is helpful in some other cases, but it caused no
-- regressions to remove it completely.
-- There is no need for elaboration checks on the new entity, which may
-- be called before the next freezing point where the body will appear.
-- Elaboration checks refer to the real entity, not the one created by
-- the renaming declaration.
-- Set_Kill_Elaboration_Checks (New_S, True);
Set_Kill_Elaboration_Checks (New_S, True);
-- If we had a previous error, indicate a completely is present to stop
-- junk cascaded messages, but don't take any further action.
if Etype (Nam) = Any_Type then
Set_Has_Completion (New_S);
return;
-- Case where name has the form of a selected component
elsif Nkind (Nam) = N_Selected_Component then
-- A prefix of the form A.B can designate an entry of task A, a
-- A name which has the form A.B can designate an entry of task A, a
-- protected operation of protected object A, or finally a primitive
-- operation of object A. In the later case, A is an object of some
-- tagged type, or an access type that denotes one such. To further
@ -2573,6 +2572,8 @@ package body Sem_Ch8 is
end if;
end;
-- Case where name is an explicit dereference X.all
elsif Nkind (Nam) = N_Explicit_Dereference then
-- Renamed entity is designated by access_to_subprogram expression.
@ -2581,14 +2582,21 @@ package body Sem_Ch8 is
Analyze_Renamed_Dereference (N, New_S, Present (Rename_Spec));
return;
-- Indexed component
elsif Nkind (Nam) = N_Indexed_Component then
Analyze_Renamed_Family_Member (N, New_S, Present (Rename_Spec));
return;
-- Character literal
elsif Nkind (Nam) = N_Character_Literal then
Analyze_Renamed_Character (N, New_S, Present (Rename_Spec));
return;
-- Only remaining case is where we have a non-entity name, or a
-- renaming of some other non-overloadable entity.
elsif not Is_Entity_Name (Nam)
or else not Is_Overloadable (Entity (Nam))
then

8
gcc/ada/sem_elab.adb
View File

@ -552,6 +552,10 @@ package body Sem_Elab is
begin
return Nkind_In (N, N_Function_Call, N_Procedure_Call_Statement)
-- Always return False if debug flag -gnatd.G is set
and then not Debug_Flag_Dot_GG
-- For now, we detect this by looking for the strange identifier
-- node, whose Chars reflect the name of the generic formal, but
-- the Chars of the Entity references the generic actual.
@ -564,10 +568,12 @@ package body Sem_Elab is
begin
-- If the call is known to be within a local Suppress Elaboration
-- pragma, nothing to check. This can happen in task bodies.
-- pragma, nothing to check. This can happen in task bodies. But
-- we ignore this for a call to a generic formal.
if Nkind (N) in N_Subprogram_Call
and then No_Elaboration_Check (N)
and then not Is_Call_Of_Generic_Formal
then
return;
end if;

3
gcc/ada/sem_res.adb
View File

@ -6583,8 +6583,7 @@ package body Sem_Res is
and then Is_SPARK_Volatile (E)
and then Comes_From_Source (E)
and then
(Async_Writers_Enabled (E)
or else Effective_Reads_Enabled (E))
(Async_Writers_Enabled (E) or else Effective_Reads_Enabled (E))
then
-- The volatile object can appear on either side of an assignment

4
gcc/ada/sem_util.adb
View File

@ -7500,9 +7500,7 @@ package body Sem_Util is
elsif Property = Name_Effective_Writes
and then
(Present (EW)
or else
(No (AR) and then No (AW) and then No (ER)))
(Present (EW) or else (No (AR) and then No (AW) and then No (ER)))
then
return True;