procyberian/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

[multiple changes]

Browse source 
2012-10-29  Ed Schonberg  <schonberg@adacore.com>

	* sem_aux.adb (Get_Rep_Item): Treat Priority and Interrupt_Priority
	as equivalent, because only one of them can be specified for a
	task, protected definition, or subprogram body.
	* aspects.adb ((Same_Aspect): The canonical aspect of
	Interrupt_Priority is Priority.

2012-10-29  Robert Dewar  <dewar@adacore.com>

	* sem_ch13.adb: Minor reformatting.

2012-10-29  Robert Dewar  <dewar@adacore.com>

	* i-cstrea.ads: Avoid redefinition of standard symbol string.
	* prj-makr.adb: Add comment for OK redefinition of Stadard.
	* prj.ads: Add comment for OK redefinition of Stadard.
	* s-crtl.ads: Avoid redefinition of standard symbol string.
	* sinfo-cn.adb (Change_Identifier_To_Defining_Identifier):
	Generate warning for standard redefinition if
	Warn_On_Standard_Definition set.
	* usage.adb: Add lines for -gnatw.k and -gnatw.K
	* warnsw.adb: Set/reset Warn_On_Standard_Redefinition
	appropriately.
	* warnsw.ads (Warn_On_Standard_Redefinition): New flag.
	* s-stratt-xdr.adb: Avoid new warning.

2012-10-29  Ed Schonberg  <schonberg@adacore.com>

	* exp_dbug.ads, exp_dbug.adb (Build_Subprogram_Instance_Renamings):
	in the body of a subpogram instance, introduce local renamings
	for actuals of an elementary type, so that GDB can recover the
	values of these actuals more directly.

From-SVN: r192919
This commit is contained in:
Arnaud Charlet 2012-10-29 11:17:29 +01:00
parent 30ebb1146d
commit 616547fa1d
16 changed files with 282 additions and 143 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

34
gcc/ada/ChangeLog
View file

@ -1,3 +1,37 @@
2012-10-29 Ed Schonberg <schonberg@adacore.com>
* sem_aux.adb (Get_Rep_Item): Treat Priority and Interrupt_Priority
as equivalent, because only one of them can be specified for a
task, protected definition, or subprogram body.
* aspects.adb ((Same_Aspect): The canonical aspect of
Interrupt_Priority is Priority.
2012-10-29 Robert Dewar <dewar@adacore.com>
* sem_ch13.adb: Minor reformatting.
2012-10-29 Robert Dewar <dewar@adacore.com>
* i-cstrea.ads: Avoid redefinition of standard symbol string.
* prj-makr.adb: Add comment for OK redefinition of Stadard.
* prj.ads: Add comment for OK redefinition of Stadard.
* s-crtl.ads: Avoid redefinition of standard symbol string.
* sinfo-cn.adb (Change_Identifier_To_Defining_Identifier):
Generate warning for standard redefinition if
Warn_On_Standard_Definition set.
* usage.adb: Add lines for -gnatw.k and -gnatw.K
* warnsw.adb: Set/reset Warn_On_Standard_Redefinition
appropriately.
* warnsw.ads (Warn_On_Standard_Redefinition): New flag.
* s-stratt-xdr.adb: Avoid new warning.
2012-10-29 Ed Schonberg <schonberg@adacore.com>
* exp_dbug.ads, exp_dbug.adb (Build_Subprogram_Instance_Renamings):
in the body of a subpogram instance, introduce local renamings
for actuals of an elementary type, so that GDB can recover the
values of these actuals more directly.
2012-10-29 Robert Dewar <dewar@adacore.com>
* sem_ch5.adb (Analyze_Loop_Statement): Add warning for identical

2
gcc/ada/aspects.adb
View file

@ -275,7 +275,7 @@ package body Aspects is
Aspect_Inline_Always => Aspect_Inline,
Aspect_Input => Aspect_Input,
Aspect_Interrupt_Handler => Aspect_Interrupt_Handler,
Aspect_Interrupt_Priority => Aspect_Interrupt_Priority,
Aspect_Interrupt_Priority => Aspect_Priority,
Aspect_Invariant => Aspect_Invariant,
Aspect_Iterator_Element => Aspect_Iterator_Element,
Aspect_Link_Name => Aspect_Link_Name,

35
gcc/ada/exp_dbug.adb
View file

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1996-2011, Free Software Foundation, Inc. --
-- Copyright (C) 1996-2012, 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- --
@ -902,6 +902,39 @@ package body Exp_Dbug is
end if;
end Get_Variant_Encoding;
------------------------------------------
-- Build_Subprogram_Instance_Renamings --
------------------------------------------
procedure Build_Subprogram_Instance_Renamings
(N : Node_Id;
Wrapper : Entity_Id)
is
Loc : Source_Ptr;
Decl : Node_Id;
E : Entity_Id;
begin
E := First_Entity (Wrapper);
while Present (E) loop
if Nkind (Parent (E)) = N_Object_Declaration
and then Is_Elementary_Type (Etype (E))
then
Loc := Sloc (Expression (Parent (E)));
Decl := Make_Object_Renaming_Declaration (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc, Chars (E)),
Subtype_Mark => New_Occurrence_Of (Etype (E), Loc),
Name => New_Occurrence_Of (E, Loc));
Append (Decl, Declarations (N));
Set_Needs_Debug_Info (Defining_Identifier (Decl));
end if;
Next_Entity (E);
end loop;
end Build_Subprogram_Instance_Renamings;
------------------------------------
-- Get_Secondary_DT_External_Name --
------------------------------------

18
gcc/ada/exp_dbug.ads
View file

@ -1442,6 +1442,24 @@ package Exp_Dbug is
-- corresponding to variants, and consider the fields inside as belonging
-- to the containing record.
-----------------------------------------------
-- Extra renamings for subprogram instances --
-----------------------------------------------
procedure Build_Subprogram_Instance_Renamings
(N : Node_Id;
Wrapper : Entity_Id);
-- The debugger has difficulties in recovering the value of actuals of an
-- elementary type, from within the body of a subprogram instantiation.
-- This is because such actuals generate an object declaration that is
-- placed within the wrapper package of the instance, and the entity in
-- these declarations is encoded in a complex way that GDB does not handle
-- well. These new renaming declarations appear within the body of the
-- subprogram, and are redundant from a visibility point of view, but They
-- should have no measurable performance impact, and require no special
-- decoding in the debugger.
-------------------------------------------
-- Character literals in Character Types --
-------------------------------------------

2
gcc/ada/i-cstrea.ads
View file

@ -175,7 +175,7 @@ package Interfaces.C_Streams is
mode : int;
size : size_t) return int;
procedure tmpnam (string : chars) renames System.CRTL.tmpnam;
procedure tmpnam (str : chars) renames System.CRTL.tmpnam;
-- The parameter must be a pointer to a string buffer of at least L_tmpnam
-- bytes (the call with a null parameter is not supported). The returned
-- value, which is just a copy of the input argument, is discarded.

7
gcc/ada/prj-makr.adb
View file

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2001-2011, Free Software Foundation, Inc. --
-- Copyright (C) 2001-2012, 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- --
@ -120,7 +120,12 @@ package body Prj.Makr is
Non_Empty_Node : constant Project_Node_Id := 1;
-- Used for the With_Clause of the naming project
-- Turn off warnings for now around this redefinition of True and False,
-- but it really seems a bit horrible to do this redefinition ???
pragma Warnings (Off);
type Matched_Type is (True, False, Excluded);
pragma Warnings (On);
Naming_File_Suffix : constant String := "_naming";
Source_List_File_Suffix : constant String := "_source_list.txt";

19
gcc/ada/prj.ads
View file

@ -68,14 +68,21 @@ package Prj is
type Yes_No_Unknown is (Yes, No, Unknown);
-- Tri-state to decide if -lgnarl is needed when linking
pragma Warnings (Off);
type Project_Qualifier is
(Unspecified,
-- The following clash with Standard is OK, and justified by the context
-- which really wants to use the same set of qualifiers.
Standard,
Library,
Configuration,
Dry,
Aggregate,
Aggregate_Library);
pragma Warnings (On);
-- Qualifiers that can prefix the reserved word "project" in a project
-- file:
-- Standard: standard project ...
@ -1188,7 +1195,17 @@ package Prj is
-- The following record describes a project file representation
type Standalone is (No, Standard, Encapsulated);
pragma Warnings (Off);
type Standalone is
(No,
-- The following clash with Standard is OK, and justified by the context
-- which really wants to use the same set of qualifiers.
Standard,
Encapsulated);
pragma Warnings (On);
type Project_Data (Qualifier : Project_Qualifier := Unspecified) is record

2
gcc/ada/s-crtl.ads
View file

@ -177,7 +177,7 @@ package System.CRTL is
size : size_t) return int;
pragma Import (C, setvbuf, "setvbuf");
procedure tmpnam (string : chars);
procedure tmpnam (str : chars);
pragma Import (C, tmpnam, "tmpnam");
function tmpfile return FILEs;

131
gcc/ada/s-stratt-xdr.adb
View file

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1996-2010, Free Software Foundation, Inc. --
-- Copyright (C) 1996-2012, Free Software Foundation, Inc. --
-- --
-- GARLIC 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- --
@ -374,12 +374,12 @@ package body System.Stream_Attributes is
F_Bytes : SEO renames Fields (I).F_Bytes;
F_Size : Integer renames Fields (I).F_Size;
Positive : Boolean;
Exponent : Long_Unsigned;
Fraction : Long_Unsigned;
Result : Float;
S : SEA (1 .. F_L);
L : SEO;
Is_Positive : Boolean;
Exponent : Long_Unsigned;
Fraction : Long_Unsigned;
Result : Float;
S : SEA (1 .. F_L);
L : SEO;
begin
Ada.Streams.Read (Stream.all, S, L);
@ -397,10 +397,10 @@ package body System.Stream_Attributes is
Result := Float'Scaling (Float (Fraction), -F_Size);
if BS <= S (1) then
Positive := False;
Is_Positive := False;
Exponent := Long_Unsigned (S (1) - BS);
else
Positive := True;
Is_Positive := True;
Exponent := Long_Unsigned (S (1));
end if;
@ -434,7 +434,7 @@ package body System.Stream_Attributes is
(1.0 + Result, Integer (Exponent) - E_Bias);
end if;
if not Positive then
if not Is_Positive then
Result := -Result;
end if;
@ -489,12 +489,12 @@ package body System.Stream_Attributes is
F_Bytes : SEO renames Fields (I).F_Bytes;
F_Size : Integer renames Fields (I).F_Size;
Positive : Boolean;
Exponent : Long_Unsigned;
Fraction : Long_Long_Unsigned;
Result : Long_Float;
S : SEA (1 .. LF_L);
L : SEO;
Is_Positive : Boolean;
Exponent : Long_Unsigned;
Fraction : Long_Long_Unsigned;
Result : Long_Float;
S : SEA (1 .. LF_L);
L : SEO;
begin
Ada.Streams.Read (Stream.all, S, L);
@ -513,10 +513,10 @@ package body System.Stream_Attributes is
Result := Long_Float'Scaling (Long_Float (Fraction), -F_Size);
if BS <= S (1) then
Positive := False;
Is_Positive := False;
Exponent := Long_Unsigned (S (1) - BS);
else
Positive := True;
Is_Positive := True;
Exponent := Long_Unsigned (S (1));
end if;
@ -551,7 +551,7 @@ package body System.Stream_Attributes is
(1.0 + Result, Integer (Exponent) - E_Bias);
end if;
if not Positive then
if not Is_Positive then
Result := -Result;
end if;
@ -617,7 +617,7 @@ package body System.Stream_Attributes is
F_Bytes : SEO renames Fields (I).F_Bytes;
F_Size : Integer renames Fields (I).F_Size;
Positive : Boolean;
Is_Positive : Boolean;
Exponent : Long_Unsigned;
Fraction_1 : Long_Long_Unsigned := 0;
Fraction_2 : Long_Long_Unsigned := 0;
@ -648,10 +648,10 @@ package body System.Stream_Attributes is
Result := Long_Long_Float'Scaling (Result, HF - F_Size);
if BS <= S (1) then
Positive := False;
Is_Positive := False;
Exponent := Long_Unsigned (S (1) - BS);
else
Positive := True;
Is_Positive := True;
Exponent := Long_Unsigned (S (1));
end if;
@ -686,7 +686,7 @@ package body System.Stream_Attributes is
(1.0 + Result, Integer (Exponent) - E_Bias);
end if;
if not Positive then
if not Is_Positive then
Result := -Result;
end if;
@ -827,12 +827,12 @@ package body System.Stream_Attributes is
F_Bytes : SEO renames Fields (I).F_Bytes;
F_Size : Integer renames Fields (I).F_Size;
Exponent : Long_Unsigned;
Fraction : Long_Unsigned;
Positive : Boolean;
Result : Short_Float;
S : SEA (1 .. SF_L);
L : SEO;
Exponent : Long_Unsigned;
Fraction : Long_Unsigned;
Is_Positive : Boolean;
Result : Short_Float;
S : SEA (1 .. SF_L);
L : SEO;
begin
Ada.Streams.Read (Stream.all, S, L);
@ -850,10 +850,10 @@ package body System.Stream_Attributes is
Result := Short_Float'Scaling (Short_Float (Fraction), -F_Size);
if BS <= S (1) then
Positive := False;
Is_Positive := False;
Exponent := Long_Unsigned (S (1) - BS);
else
Positive := True;
Is_Positive := True;
Exponent := Long_Unsigned (S (1));
end if;
@ -887,7 +887,7 @@ package body System.Stream_Attributes is
(1.0 + Result, Integer (Exponent) - E_Bias);
end if;
if not Positive then
if not Is_Positive then
Result := -Result;
end if;
@ -1179,12 +1179,12 @@ package body System.Stream_Attributes is
F_Size : Integer renames Fields (I).F_Size;
F_Mask : SE renames Fields (I).F_Mask;
Exponent : Long_Unsigned;
Fraction : Long_Unsigned;
Positive : Boolean;
E : Integer;
F : Float;
S : SEA (1 .. F_L) := (others => 0);
Exponent : Long_Unsigned;
Fraction : Long_Unsigned;
Is_Positive : Boolean;
E : Integer;
F : Float;
S : SEA (1 .. F_L) := (others => 0);
begin
if not Item'Valid then
@ -1193,7 +1193,7 @@ package body System.Stream_Attributes is
-- Compute Sign
Positive := (0.0 <= Item);
Is_Positive := (0.0 <= Item);
F := abs (Item);
-- Signed zero
@ -1241,7 +1241,7 @@ package body System.Stream_Attributes is
-- Store Sign
if not Positive then
if not Is_Positive then
S (1) := S (1) + BS;
end if;
@ -1293,12 +1293,12 @@ package body System.Stream_Attributes is
F_Size : Integer renames Fields (I).F_Size;
F_Mask : SE renames Fields (I).F_Mask;
Exponent : Long_Unsigned;
Fraction : Long_Long_Unsigned;
Positive : Boolean;
E : Integer;
F : Long_Float;
S : SEA (1 .. LF_L) := (others => 0);
Exponent : Long_Unsigned;
Fraction : Long_Long_Unsigned;
Is_Positive : Boolean;
E : Integer;
F : Long_Float;
S : SEA (1 .. LF_L) := (others => 0);
begin
if not Item'Valid then
@ -1307,7 +1307,7 @@ package body System.Stream_Attributes is
-- Compute Sign
Positive := (0.0 <= Item);
Is_Positive := (0.0 <= Item);
F := abs (Item);
-- Signed zero
@ -1355,7 +1355,7 @@ package body System.Stream_Attributes is
-- Store Sign
if not Positive then
if not Is_Positive then
S (1) := S (1) + BS;
end if;
@ -1421,13 +1421,13 @@ package body System.Stream_Attributes is
HFS : constant Integer := F_Size / 2;
Exponent : Long_Unsigned;
Fraction_1 : Long_Long_Unsigned;
Fraction_2 : Long_Long_Unsigned;
Positive : Boolean;
E : Integer;
F : Long_Long_Float := Item;
S : SEA (1 .. LLF_L) := (others => 0);
Exponent : Long_Unsigned;
Fraction_1 : Long_Long_Unsigned;
Fraction_2 : Long_Long_Unsigned;
Is_Positive : Boolean;
E : Integer;
F : Long_Long_Float := Item;
S : SEA (1 .. LLF_L) := (others => 0);
begin
if not Item'Valid then
@ -1436,7 +1436,8 @@ package body System.Stream_Attributes is
-- Compute Sign
Positive := (0.0 <= Item);
Is_Positive := (0.0 <= Item);
if F < 0.0 then
F := -Item;
end if;
@ -1495,7 +1496,7 @@ package body System.Stream_Attributes is
-- Store Sign
if not Positive then
if not Is_Positive then
S (1) := S (1) + BS;
end if;
@ -1639,12 +1640,12 @@ package body System.Stream_Attributes is
F_Size : Integer renames Fields (I).F_Size;
F_Mask : SE renames Fields (I).F_Mask;
Exponent : Long_Unsigned;
Fraction : Long_Unsigned;
Positive : Boolean;
E : Integer;
F : Short_Float;
S : SEA (1 .. SF_L) := (others => 0);
Exponent : Long_Unsigned;
Fraction : Long_Unsigned;
Is_Positive : Boolean;
E : Integer;
F : Short_Float;
S : SEA (1 .. SF_L) := (others => 0);
begin
if not Item'Valid then
@ -1653,7 +1654,7 @@ package body System.Stream_Attributes is
-- Compute Sign
Positive := (0.0 <= Item);
Is_Positive := (0.0 <= Item);
F := abs (Item);
-- Signed zero
@ -1701,7 +1702,7 @@ package body System.Stream_Attributes is
-- Store Sign
if not Positive then
if not Is_Positive then
S (1) := S (1) + BS;
end if;

8
gcc/ada/sem_aux.adb
View file

@ -431,11 +431,17 @@ package body Sem_Aux is
begin
N := First_Rep_Item (E);
while Present (N) loop
-- Only one of Priority / Interrupt_Priority can be specified, so
-- return whichever one is present to catch illegal duplication.
if Nkind (N) = N_Pragma
and then
(Pragma_Name (N) = Nam
or else (Nam = Name_Priority
and then Pragma_Name (N) = Name_Interrupt_Priority))
and then Pragma_Name (N) = Name_Interrupt_Priority)
or else (Nam = Name_Interrupt_Priority
and then Pragma_Name (N) = Name_Priority))
then
if Check_Parents then
return N;

113
gcc/ada/sem_ch13.adb
View file

@ -253,9 +253,7 @@ package body Sem_Ch13 is
-- is important, since otherwise if there are record subtypes, we
-- could reverse the bits once for each subtype, which is wrong.
if Present (CC)
and then Ekind (R) = E_Record_Type
then
if Present (CC) and then Ekind (R) = E_Record_Type then
declare
CFB : constant Uint := Component_Bit_Offset (Comp);
CSZ : constant Uint := Esize (Comp);
@ -623,14 +621,12 @@ package body Sem_Ch13 is
for C in Start .. Stop loop
declare
Comp : constant Entity_Id := Comps (C);
CC : constant Node_Id :=
Component_Clause (Comp);
LB : constant Uint :=
Static_Integer (Last_Bit (CC));
CC : constant Node_Id := Component_Clause (Comp);
LB : constant Uint := Static_Integer (Last_Bit (CC));
NFB : constant Uint := MSS - Uint_1 - LB;
NLB : constant Uint := NFB + Esize (Comp) - 1;
Pos : constant Uint :=
Static_Integer (Position (CC));
Pos : constant Uint := Static_Integer (Position (CC));
begin
if Warn_On_Reverse_Bit_Order then
@ -1012,9 +1008,7 @@ package body Sem_Ch13 is
procedure Analyze_Aspect_Implicit_Dereference is
begin
if not Is_Type (E)
or else not Has_Discriminants (E)
then
if not Is_Type (E) or else not Has_Discriminants (E) then
Error_Msg_N
("Aspect must apply to a type with discriminants", N);
@ -1306,7 +1300,8 @@ package body Sem_Ch13 is
A_Name := Chars (Identifier (A));
if A_Name = Name_Import
or else A_Name = Name_Export
or else
A_Name = Name_Export
then
if Found then
Error_Msg_N ("conflicting", A);
@ -1331,6 +1326,7 @@ package body Sem_Ch13 is
end loop;
Arg_List := New_List (Relocate_Node (Expr), Ent);
if Present (L_Assoc) then
Append_To (Arg_List, L_Assoc);
end if;
@ -1769,9 +1765,7 @@ package body Sem_Ch13 is
-- For a Boolean aspect, create the corresponding pragma if
-- no expression or if the value is True.
if Is_Boolean_Aspect (Aspect)
and then No (Aitem)
then
if Is_Boolean_Aspect (Aspect) and then No (Aitem) then
if Is_True (Static_Boolean (Expr)) then
Aitem :=
Make_Pragma (Loc,
@ -4752,11 +4746,13 @@ package body Sem_Ch13 is
or else Intval (Last_Bit (Rep1)) /=
Intval (Last_Bit (CC))
then
Error_Msg_N ("component clause inconsistent "
& "with representation of ancestor", CC);
Error_Msg_N
("component clause inconsistent "
& "with representation of ancestor", CC);
elsif Warn_On_Redundant_Constructs then
Error_Msg_N ("?redundant component clause "
& "for inherited component!", CC);
Error_Msg_N
("?redundant component clause "
& "for inherited component!", CC);
end if;
end;
end if;
@ -5031,9 +5027,10 @@ package body Sem_Ch13 is
-- Replace_Type_Reference --
----------------------------
-- Note: See comments in Add_Predicates.Replace_Type_Reference
-- regarding handling of Sloc and Comes_From_Source.
procedure Replace_Type_Reference (N : Node_Id) is
-- See comments in Add_Predicates.Replace_Type_Reference regarding
-- Sloc and Comes_From_Source.
begin
-- Invariant'Class, replace with T'Class (obj)
@ -5145,7 +5142,8 @@ package body Sem_Ch13 is
Assoc := New_List (
Make_Pragma_Argument_Association (Loc,
Expression => Make_Identifier (Loc, Name_Invariant)),
Make_Pragma_Argument_Association (Loc, Expression => Exp));
Make_Pragma_Argument_Association (Loc,
Expression => Exp));
-- Add message if present in Invariant pragma
@ -5254,7 +5252,6 @@ package body Sem_Ch13 is
-- Build the procedure if we generated at least one Check pragma
if Stmts /= No_List then
Spec := Copy_Separate_Tree (Specification (PDecl));
PBody :=
@ -5487,7 +5484,6 @@ package body Sem_Ch13 is
if Entity (Arg1) = Typ
or else Full_View (Entity (Arg1)) = Typ
then
-- We have a match, this entry is for our subtype
-- We need to replace any occurrences of the name of the
@ -6074,6 +6070,7 @@ package body Sem_Ch13 is
-- Comparisons of type with static value
when N_Op_Compare =>
-- Type is left operand
if Is_Type_Ref (Left_Opnd (Exp))
@ -6336,9 +6333,7 @@ package body Sem_Ch13 is
begin
-- Not static if type does not have static predicates
if not Has_Predicates (Typ)
or else No (Static_Predicate (Typ))
then
if not Has_Predicates (Typ) or else No (Static_Predicate (Typ)) then
raise Non_Static;
end if;
@ -7435,9 +7430,7 @@ package body Sem_Ch13 is
-- Check parent overlap if component might overlap parent field
if Present (Tagged_Parent)
and then Fbit <= Parent_Last_Bit
then
if Present (Tagged_Parent) and then Fbit <= Parent_Last_Bit then
Pcomp := First_Component_Or_Discriminant (Tagged_Parent);
while Present (Pcomp) loop
if not Is_Tag (Pcomp)
@ -7599,7 +7592,7 @@ package body Sem_Ch13 is
-- Outer level of record definition, check discriminants
if Nkind_In (Clist, N_Full_Type_Declaration,
N_Private_Type_Declaration)
N_Private_Type_Declaration)
then
if Has_Discriminants (Defining_Identifier (Clist)) then
C2_Ent :=
@ -7951,6 +7944,7 @@ package body Sem_Ch13 is
if Asiz <= Siz then
return;
else
Error_Msg_Uint_1 := Asiz;
Error_Msg_NE
@ -8281,11 +8275,12 @@ package body Sem_Ch13 is
begin
if Nkind (N) /= N_Attribute_Definition_Clause then
return False;
else
declare
Id : constant Attribute_Id := Get_Attribute_Id (Chars (N));
Id : constant Attribute_Id := Get_Attribute_Id (Chars (N));
begin
return Id = Attribute_Input
return Id = Attribute_Input
or else Id = Attribute_Output
or else Id = Attribute_Read
or else Id = Attribute_Write
@ -8681,6 +8676,7 @@ package body Sem_Ch13 is
elsif Has_Private_Component (T) then
if Nkind (N) = N_Pragma then
return False;
else
Error_Msg_N
("representation item must appear after type is fully defined",
@ -8775,9 +8771,7 @@ package body Sem_Ch13 is
-- but avoid chaining if we have an overloadable entity, and the pragma
-- is one that can apply to multiple overloaded entities.
if Is_Overloadable (T)
and then Nkind (N) = N_Pragma
then
if Is_Overloadable (T) and then Nkind (N) = N_Pragma then
declare
Pname : constant Name_Id := Pragma_Name (N);
begin
@ -9045,8 +9039,6 @@ package body Sem_Ch13 is
begin
if Has_Discriminants (T1) then
CD1 := First_Discriminant (T1);
CD2 := First_Discriminant (T2);
-- The number of discriminants may be different if the
-- derived type has fewer (constrained by values). The
@ -9054,9 +9046,9 @@ package body Sem_Ch13 is
-- the original, so the discrepancy does not per se
-- indicate a different representation.
while Present (CD1)
and then Present (CD2)
loop
CD1 := First_Discriminant (T1);
CD2 := First_Discriminant (T2);
while Present (CD1) and then Present (CD2) loop
if not Same_Rep then
return False;
else
@ -9068,7 +9060,6 @@ package body Sem_Ch13 is
CD1 := First_Component (Underlying_Type (Base_Type (T1)));
CD2 := First_Component (Underlying_Type (Base_Type (T2)));
while Present (CD1) loop
if not Same_Rep then
return False;
@ -9094,7 +9085,6 @@ package body Sem_Ch13 is
begin
L1 := First_Literal (T1);
L2 := First_Literal (T2);
while Present (L1) loop
if Enumeration_Rep (L1) /= Enumeration_Rep (L2) then
return False;
@ -9105,7 +9095,6 @@ package body Sem_Ch13 is
end loop;
return True;
end Enumeration_Case;
-- Any other types have the same representation for these purposes
@ -9219,7 +9208,6 @@ package body Sem_Ch13 is
-- Skip processing of this entry if warning already posted
if not Address_Warning_Posted (ACCR.N) then
Expr := Original_Node (Expression (ACCR.N));
-- Get alignments
@ -9353,9 +9341,8 @@ package body Sem_Ch13 is
-- Bad component size, check reason
if Has_Component_Size_Clause (Atyp) then
P :=
Get_Attribute_Definition_Clause
(Atyp, Attribute_Component_Size);
P := Get_Attribute_Definition_Clause
(Atyp, Attribute_Component_Size);
if Present (P) then
Error_Msg_Sloc := Sloc (P);
@ -9427,7 +9414,8 @@ package body Sem_Ch13 is
-- cases where we cannot check static values.
if not (Known_Static_Esize (C)
and then Known_Static_Esize (Ctyp))
and then
Known_Static_Esize (Ctyp))
then
return False;
end if;
@ -9435,9 +9423,7 @@ package body Sem_Ch13 is
-- Size of component must be addressable or greater than 64 bits
-- and a multiple of bytes.
if not Addressable (Esize (C))
and then Esize (C) < Uint_64
then
if not Addressable (Esize (C)) and then Esize (C) < Uint_64 then
return False;
end if;
@ -9626,9 +9612,7 @@ package body Sem_Ch13 is
-- Source may be unconstrained array, but not target
if Is_Array_Type (Target)
and then not Is_Constrained (Target)
then
if Is_Array_Type (Target) and then not Is_Constrained (Target) then
Error_Msg_N
("unchecked conversion to unconstrained array not allowed", N);
return;
@ -9674,9 +9658,7 @@ package body Sem_Ch13 is
begin
pragma Assert (Present (Calendar_Time));
if Source = Calendar_Time
or else Target = Calendar_Time
then
if Source = Calendar_Time or else Target = Calendar_Time then
Error_Msg_N
("?representation of 'Time values may change between " &
"'G'N'A'T versions", N);
@ -9691,10 +9673,9 @@ package body Sem_Ch13 is
if Warn_On_Unchecked_Conversion then
Unchecked_Conversions.Append
(New_Val => UC_Entry'
(Eloc => Sloc (N),
Source => Source,
Target => Target));
(New_Val => UC_Entry'(Eloc => Sloc (N),
Source => Source,
Target => Target));
-- If both sizes are known statically now, then back end annotation
-- is not required to do a proper check but if either size is not
@ -9792,7 +9773,8 @@ package body Sem_Ch13 is
Error_Msg_Uint_1 := UI_Abs (Source_Siz - Target_Siz);
if Is_Discrete_Type (Source)
and then Is_Discrete_Type (Target)
and then
Is_Discrete_Type (Target)
then
if Source_Siz > Target_Siz then
Error_Msg
@ -9856,7 +9838,8 @@ package body Sem_Ch13 is
begin
if Known_Alignment (D_Source)
and then Known_Alignment (D_Target)
and then
Known_Alignment (D_Target)
then
declare
Source_Align : constant Uint := Alignment (D_Source);

11
gcc/ada/sem_ch6.adb
View file

@ -33,6 +33,7 @@ with Expander; use Expander;
with Exp_Ch6; use Exp_Ch6;
with Exp_Ch7; use Exp_Ch7;
with Exp_Ch9; use Exp_Ch9;
with Exp_Dbug; use Exp_Dbug;
with Exp_Disp; use Exp_Disp;
with Exp_Tss; use Exp_Tss;
with Exp_Util; use Exp_Util;
@ -2723,6 +2724,16 @@ package body Sem_Ch6 is
Install_Formals (Spec_Id);
Last_Real_Spec_Entity := Last_Entity (Spec_Id);
-- Within an instance, add local renaming declarations so that
-- gdb can retrieve the values of actuals more easily.
if Is_Generic_Instance (Spec_Id)
and then Is_Wrapper_Package (Current_Scope)
then
Build_Subprogram_Instance_Renamings (N, Current_Scope);
end if;
Push_Scope (Spec_Id);
-- Make sure that the subprogram is immediately visible. For

23
gcc/ada/sinfo-cn.adb
View file

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2011, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2012, 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- --
@ -30,8 +30,11 @@
-- general manner, but in some specific cases, the fields of related nodes
-- have been deliberately layed out in a manner that permits such alteration.
with Atree; use Atree;
with Snames; use Snames;
with Atree; use Atree;
with Errout; use Errout;
with Sem_Util; use Sem_Util;
with Snames; use Snames;
with Warnsw; use Warnsw;
package body Sinfo.CN is
@ -71,6 +74,20 @@ package body Sinfo.CN is
procedure Change_Identifier_To_Defining_Identifier (N : in out Node_Id) is
begin
-- Check for redefinition of standard entity (requiring a warning)
if Warn_On_Standard_Redefinition then
declare
C : constant Entity_Id := Current_Entity (N);
begin
if Present (C) and then Sloc (C) = Standard_Location then
Error_Msg_N ("redefinition of entity& in Standard?", N);
end if;
end;
end if;
-- Go ahead with the change
Set_Nkind (N, N_Defining_Identifier);
N := Extend_Node (N);
end Change_Identifier_To_Defining_Identifier;

6
gcc/ada/usage.adb
View file

@ -435,6 +435,8 @@ begin
Write_Switch_Char ("wxx");
Write_Line ("Enable selected warning modes, xx = list of parameters:");
Write_Line (" * indicates default setting");
Write_Line (" + indicates warning flag included in -gnatwa");
Write_Line (" a turn on all info/warnings marked below with +");
Write_Line (" A turn off all optional info/warnings");
Write_Line (" .a*+ turn on warnings for failing assertion");
@ -472,6 +474,8 @@ begin
"(annex J) feature");
Write_Line (" k+ turn on warnings on constant variable");
Write_Line (" K* turn off warnings on constant variable");
Write_Line (" .k+ turn on warnings for standard redefinition");
Write_Line (" .K* turn off warnings for standard redefinition");
Write_Line (" l turn on warnings for missing " &
"elaboration pragma");
Write_Line (" L* turn off warnings for missing " &
@ -541,8 +545,6 @@ begin
"unchecked conversion");
Write_Line (" Z turn off warnings for suspicious " &
"unchecked conversion");
Write_Line (" * indicates default in above list");
Write_Line (" + indicates warning flag included in -gnatwa");
-- Line for -gnatW switch

8
gcc/ada/warnsw.adb
View file

@ -87,6 +87,7 @@ package body Warnsw is
Warn_On_Record_Holes := True;
Warn_On_Redundant_Constructs := True;
Warn_On_Reverse_Bit_Order := True;
Warn_On_Standard_Redefinition := True;
Warn_On_Suspicious_Contract := True;
Warn_On_Unchecked_Conversion := True;
Warn_On_Unordered_Enumeration_Type := True;
@ -109,6 +110,12 @@ package body Warnsw is
when 'I' =>
Warn_On_Overlap := False;
when 'k' =>
Warn_On_Standard_Redefinition := True;
when 'K' =>
Warn_On_Standard_Redefinition := False;
when 'l' =>
List_Inherited_Aspects := True;
@ -307,6 +314,7 @@ package body Warnsw is
Warn_On_Questionable_Missing_Parens := False;
Warn_On_Redundant_Constructs := False;
Warn_On_Reverse_Bit_Order := False;
Warn_On_Standard_Redefinition := False;
Warn_On_Suspicious_Contract := False;
Warn_On_Suspicious_Modulus_Value := False;
Warn_On_Unchecked_Conversion := False;

6
gcc/ada/warnsw.ads
View file

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1999-2011, Free Software Foundation, Inc. --
-- Copyright (C) 1999-2012, 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- --
@ -47,6 +47,10 @@ package Warnsw is
-- set with an explicit size clause. Off by default, set by -gnatw.s (but
-- not -gnatwa).
Warn_On_Standard_Redefinition : Boolean := False;
-- Warn when a program defines an identifier that matches a name in
-- Standard. Off by default, set by -gnatw.k (and also by -gnatwa).
-----------------
-- Subprograms --
-----------------