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

[multiple changes]

Browse source 
2015-05-26  Robert Dewar  <dewar@adacore.com>

	* exp_prag.adb, sem_ch3.adb, sem_ch5.adb, exp_ch11.adb, ghost.adb,
	exp_ch6.adb, sem_ch6.adb, sem_ch8.adb, sem_ch11.adb, sem_ch13.adb,
	exp_ch3.adb: Minor reformatting.

2015-05-26  Bob Duff  <duff@adacore.com>

	* treepr.adb: Minor improvement to debugging routines (pp, pn)
	robustness.  Rearrange the code so passing a nonexistent Node_Id
	prints "No such node" rather than crashing, and causing gdb to
	generate confusing messages.

2015-05-26  Gary Dismukes  <dismukes@adacore.com>

	* sem_util.adb: Minor typo fix.

2015-05-26  Yannick Moy  <moy@adacore.com>

	* sem_aux.adb (Subprogram_Body_Entity): Deal with subprogram stubs.

From-SVN: r223685
This commit is contained in:
Arnaud Charlet 2015-05-26 12:49:18 +02:00
parent 241ebe892a
commit ad4ba28bb0
15 changed files with 99 additions and 62 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

21
gcc/ada/ChangeLog
View file

@ -1,3 +1,24 @@
2015-05-26 Robert Dewar <dewar@adacore.com>
* exp_prag.adb, sem_ch3.adb, sem_ch5.adb, exp_ch11.adb, ghost.adb,
exp_ch6.adb, sem_ch6.adb, sem_ch8.adb, sem_ch11.adb, sem_ch13.adb,
exp_ch3.adb: Minor reformatting.
2015-05-26 Bob Duff <duff@adacore.com>
* treepr.adb: Minor improvement to debugging routines (pp, pn)
robustness. Rearrange the code so passing a nonexistent Node_Id
prints "No such node" rather than crashing, and causing gdb to
generate confusing messages.
2015-05-26 Gary Dismukes <dismukes@adacore.com>
* sem_util.adb: Minor typo fix.
2015-05-26 Yannick Moy <moy@adacore.com>
* sem_aux.adb (Subprogram_Body_Entity): Deal with subprogram stubs.
2015-05-26 Hristian Kirtchev <kirtchev@adacore.com>
* exp_ch3.adb (Expand_N_Full_Type_Declaration): Capture, set and

7
gcc/ada/exp_ch11.adb
View file

@ -1191,11 +1191,11 @@ package body Exp_Ch11 is
procedure Expand_N_Exception_Declaration (N : Node_Id) is
GM : constant Ghost_Mode_Type := Ghost_Mode;
Id : constant Entity_Id := Defining_Identifier (N);
Loc : constant Source_Ptr := Sloc (N);
Id : constant Entity_Id := Defining_Identifier (N);
Loc : constant Source_Ptr := Sloc (N);
Ex_Id : Entity_Id;
Flag_Id : Entity_Id;
L : List_Id := New_List;
L : List_Id;
procedure Force_Static_Allocation_Of_Referenced_Objects
(Aggregate : Node_Id);
@ -1304,6 +1304,7 @@ package body Exp_Ch11 is
-- Create the aggregate list for type Standard.Exception_Type:
-- Handled_By_Other component: False
L := Empty_List;
Append_To (L, New_Occurrence_Of (Standard_False, Loc));
-- Lang component: 'A'

16
gcc/ada/exp_ch3.adb
View file

@ -4792,8 +4792,8 @@ package body Exp_Ch3 is
-- Local declarations
Def_Id : constant Entity_Id := Defining_Identifier (N);
B_Id : constant Entity_Id := Base_Type (Def_Id);
Def_Id : constant Entity_Id := Defining_Identifier (N);
B_Id : constant Entity_Id := Base_Type (Def_Id);
GM : constant Ghost_Mode_Type := Ghost_Mode;
FN : Node_Id;
Par_Id : Entity_Id;
@ -4942,13 +4942,13 @@ package body Exp_Ch3 is
---------------------------------
procedure Expand_N_Object_Declaration (N : Node_Id) is
Def_Id : constant Entity_Id := Defining_Identifier (N);
Expr : constant Node_Id := Expression (N);
Loc : constant Source_Ptr := Sloc (N);
Def_Id : constant Entity_Id := Defining_Identifier (N);
Expr : constant Node_Id := Expression (N);
GM : constant Ghost_Mode_Type := Ghost_Mode;
Loc : constant Source_Ptr := Sloc (N);
Obj_Def : constant Node_Id := Object_Definition (N);
Typ : constant Entity_Id := Etype (Def_Id);
Base_Typ : constant Entity_Id := Base_Type (Typ);
Obj_Def : constant Node_Id := Object_Definition (N);
Typ : constant Entity_Id := Etype (Def_Id);
Base_Typ : constant Entity_Id := Base_Type (Typ);
Expr_Q : Node_Id;
function Build_Equivalent_Aggregate return Boolean;

10
gcc/ada/exp_ch6.adb
View file

@ -5006,8 +5006,8 @@ package body Exp_Ch6 is
procedure Expand_N_Subprogram_Body (N : Node_Id) is
GM : constant Ghost_Mode_Type := Ghost_Mode;
Loc : constant Source_Ptr := Sloc (N);
HSS : constant Node_Id := Handled_Statement_Sequence (N);
Loc : constant Source_Ptr := Sloc (N);
HSS : constant Node_Id := Handled_Statement_Sequence (N);
Body_Id : Entity_Id;
Except_H : Node_Id;
L : List_Id;
@ -5451,10 +5451,10 @@ package body Exp_Ch6 is
-- If the declaration is for a null procedure, emit null body
procedure Expand_N_Subprogram_Declaration (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
GM : constant Ghost_Mode_Type := Ghost_Mode;
Loc : constant Source_Ptr := Sloc (N);
Subp : constant Entity_Id := Defining_Entity (N);
Scop : constant Entity_Id := Scope (Subp);
Subp : constant Entity_Id := Defining_Entity (N);
Scop : constant Entity_Id := Scope (Subp);
Prot_Bod : Node_Id;
Prot_Decl : Node_Id;
Prot_Id : Entity_Id;

7
gcc/ada/exp_prag.adb
View file

@ -294,8 +294,8 @@ package body Exp_Prag is
procedure Expand_Pragma_Check (N : Node_Id) is
GM : constant Ghost_Mode_Type := Ghost_Mode;
Cond : constant Node_Id := Arg2 (N);
Nam : constant Name_Id := Chars (Arg1 (N));
Cond : constant Node_Id := Arg2 (N);
Nam : constant Name_Id := Chars (Arg1 (N));
Msg : Node_Id;
Loc : constant Source_Ptr := Sloc (First_Node (Cond));
@ -1580,8 +1580,9 @@ package body Exp_Prag is
-- end loop;
procedure Expand_Pragma_Loop_Variant (N : Node_Id) is
Last_Var : constant Node_Id := Last (Pragma_Argument_Associations (N));
Loc : constant Source_Ptr := Sloc (N);
Last_Var : constant Node_Id :=
Last (Pragma_Argument_Associations (N));
Curr_Assign : List_Id := No_List;
Flag_Id : Entity_Id := Empty;

30
gcc/ada/ghost.adb
View file

@ -121,18 +121,18 @@ package body Ghost is
Error_Msg_N ("incompatible ghost policies in effect", Partial_View);
Error_Msg_N ("\& declared with ghost policy `Check`", Partial_View);
Error_Msg_N
("\& completed # with ghost policy `Ignore`", Partial_View);
Error_Msg_N ("\& completed # with ghost policy `Ignore`",
Partial_View);
elsif Is_Ignored_Ghost_Entity (Partial_View)
and then Policy = Name_Check
then
Error_Msg_Sloc := Sloc (Full_View);
Error_Msg_N ("incompatible ghost policies in effect", Partial_View);
Error_Msg_N ("incompatible ghost policies in effect", Partial_View);
Error_Msg_N ("\& declared with ghost policy `Ignore`", Partial_View);
Error_Msg_N
("\& completed # with ghost policy `Check`", Partial_View);
Error_Msg_N ("\& completed # with ghost policy `Check`",
Partial_View);
end if;
end Check_Ghost_Completion;
@ -300,7 +300,8 @@ package body Ghost is
if GP = Name_Ignore and then AP /= Name_Ignore then
Error_Msg_N
("incompatible ghost policies in effect", Ghost_Ref);
("incompatible ghost policies in effect",
Ghost_Ref);
Error_Msg_NE
("\ghost entity & has policy `Ignore`",
Ghost_Ref, Ghost_Id);
@ -494,14 +495,14 @@ package body Ghost is
Error_Msg_N ("incompatible ghost policies in effect", Err_N);
Error_Msg_NE ("\& declared with ghost policy `Check`", Err_N, Id);
Error_Msg_NE ("\& used # with ghost policy `Ignore`", Err_N, Id);
Error_Msg_NE ("\& used # with ghost policy `Ignore`", Err_N, Id);
elsif Is_Ignored_Ghost_Entity (Id) and then Policy = Name_Check then
Error_Msg_Sloc := Sloc (Err_N);
Error_Msg_N ("incompatible ghost policies in effect", Err_N);
Error_Msg_N ("incompatible ghost policies in effect", Err_N);
Error_Msg_NE ("\& declared with ghost policy `Ignore`", Err_N, Id);
Error_Msg_NE ("\& used # with ghost policy `Check`", Err_N, Id);
Error_Msg_NE ("\& used # with ghost policy `Check`", Err_N, Id);
end if;
end Check_Ghost_Policy;
@ -558,7 +559,7 @@ package body Ghost is
if not Is_Ghost_Entity (Iface) then
Error_Msg_N ("type extension & cannot be ghost", Typ);
Error_Msg_NE ("\interface type & is not ghost", Typ, Iface);
Error_Msg_NE ("\interface type & is not ghost", Typ, Iface);
return;
end if;
@ -587,10 +588,10 @@ package body Ghost is
if Is_Checked_Ghost_Entity (Par_Subp)
and then Is_Ignored_Ghost_Entity (Subp)
then
Error_Msg_N ("incompatible ghost policies in effect", Subp);
Error_Msg_N ("incompatible ghost policies in effect", Subp);
Error_Msg_Sloc := Sloc (Par_Subp);
Error_Msg_N ("\& declared # with ghost policy `Check`", Subp);
Error_Msg_N ("\& declared # with ghost policy `Check`", Subp);
Error_Msg_Sloc := Sloc (Subp);
Error_Msg_N ("\overridden # with ghost policy `Ignore`", Subp);
@ -598,13 +599,13 @@ package body Ghost is
elsif Is_Ignored_Ghost_Entity (Par_Subp)
and then Is_Checked_Ghost_Entity (Subp)
then
Error_Msg_N ("incompatible ghost policies in effect", Subp);
Error_Msg_N ("incompatible ghost policies in effect", Subp);
Error_Msg_Sloc := Sloc (Par_Subp);
Error_Msg_N ("\& declared # with ghost policy `Ignore`", Subp);
Error_Msg_Sloc := Sloc (Subp);
Error_Msg_N ("\overridden # with ghost policy `Check`", Subp);
Error_Msg_N ("\overridden # with ghost policy `Check`", Subp);
end if;
end if;
end Check_Ghost_Overriding;
@ -1158,7 +1159,6 @@ package body Ghost is
begin
if Is_Checked_Ghost_Entity (Id) then
Ghost_Mode := Check;
elsif Is_Ignored_Ghost_Entity (Id) then
Ghost_Mode := Ignore;
end if;

8
gcc/ada/sem_aux.adb
View file

@ -1524,15 +1524,15 @@ package body Sem_Aux is
N := Parent (Subprogram_Specification (E));
-- If this declaration is not a subprogram body, then it must be a
-- subprogram declaration, from which we can retrieve the entity for
-- the corresponding subprogram body if any, or an abstract subprogram
-- declaration, for which we return Empty.
-- subprogram declaration or body stub, from which we can retrieve the
-- entity for the corresponding subprogram body if any, or an abstract
-- subprogram declaration, for which we return Empty.
case Nkind (N) is
when N_Subprogram_Body =>
return E;
when N_Subprogram_Declaration =>
when N_Subprogram_Declaration | N_Subprogram_Body_Stub =>
return Corresponding_Body (N);
when others =>

4
gcc/ada/sem_ch11.adb
View file

@ -56,8 +56,8 @@ package body Sem_Ch11 is
procedure Analyze_Exception_Declaration (N : Node_Id) is
GM : constant Ghost_Mode_Type := Ghost_Mode;
Id : constant Entity_Id := Defining_Identifier (N);
PF : constant Boolean := Is_Pure (Current_Scope);
Id : constant Entity_Id := Defining_Identifier (N);
PF : constant Boolean := Is_Pure (Current_Scope);
begin
-- The exception declaration may be subject to pragma Ghost with policy

6
gcc/ada/sem_ch13.adb
View file

@ -7763,14 +7763,14 @@ package body Sem_Ch13 is
function Build_Invariant_Procedure_Declaration
(Typ : Entity_Id) return Node_Id
is
Loc : constant Source_Ptr := Sloc (Typ);
GM : constant Ghost_Mode_Type := Ghost_Mode;
Loc : constant Source_Ptr := Sloc (Typ);
Decl : Node_Id;
Obj_Id : Entity_Id;
SId : Entity_Id;
begin
-- Check for duplicate definiations
-- Check for duplicate definitions
if Has_Invariants (Typ) and then Present (Invariant_Procedure (Typ)) then
return Empty;
@ -8011,7 +8011,7 @@ package body Sem_Ch13 is
-- analyzed at the end of the private part, but that yields the
-- wrong visibility.
-- Historic note: we used to set N as the parent, but a package
-- Historical note: we used to set N as the parent, but a package
-- specification as the parent of an expression is bizarre.
Set_Parent (Expr, Parent (Arg2));

14
gcc/ada/sem_ch3.adb
View file

@ -2556,8 +2556,8 @@ package body Sem_Ch3 is
-----------------------------------
procedure Analyze_Full_Type_Declaration (N : Node_Id) is
Def : constant Node_Id := Type_Definition (N);
Def_Id : constant Entity_Id := Defining_Identifier (N);
Def : constant Node_Id := Type_Definition (N);
Def_Id : constant Entity_Id := Defining_Identifier (N);
GM : constant Ghost_Mode_Type := Ghost_Mode;
T : Entity_Id;
Prev : Entity_Id;
@ -2923,7 +2923,7 @@ package body Sem_Ch3 is
----------------------------------
procedure Analyze_Incomplete_Type_Decl (N : Node_Id) is
F : constant Boolean := Is_Pure (Current_Scope);
F : constant Boolean := Is_Pure (Current_Scope);
GM : constant Ghost_Mode_Type := Ghost_Mode;
T : Entity_Id;
@ -3406,9 +3406,9 @@ package body Sem_Ch3 is
--------------------------------
procedure Analyze_Object_Declaration (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
GM : constant Ghost_Mode_Type := Ghost_Mode;
Id : constant Entity_Id := Defining_Identifier (N);
Loc : constant Source_Ptr := Sloc (N);
Id : constant Entity_Id := Defining_Identifier (N);
Act_T : Entity_Id;
T : Entity_Id;
@ -4544,8 +4544,8 @@ package body Sem_Ch3 is
procedure Analyze_Private_Extension_Declaration (N : Node_Id) is
GM : constant Ghost_Mode_Type := Ghost_Mode;
Indic : constant Node_Id := Subtype_Indication (N);
T : constant Entity_Id := Defining_Identifier (N);
Indic : constant Node_Id := Subtype_Indication (N);
T : constant Entity_Id := Defining_Identifier (N);
Parent_Base : Entity_Id;
Parent_Type : Entity_Id;

4
gcc/ada/sem_ch5.adb
View file

@ -91,8 +91,8 @@ package body Sem_Ch5 is
procedure Analyze_Assignment (N : Node_Id) is
GM : constant Ghost_Mode_Type := Ghost_Mode;
Lhs : constant Node_Id := Name (N);
Rhs : constant Node_Id := Expression (N);
Lhs : constant Node_Id := Name (N);
Rhs : constant Node_Id := Expression (N);
T1 : Entity_Id;
T2 : Entity_Id;
Decl : Node_Id;

4
gcc/ada/sem_ch6.adb
View file

@ -210,8 +210,8 @@ package body Sem_Ch6 is
procedure Analyze_Abstract_Subprogram_Declaration (N : Node_Id) is
GM : constant Ghost_Mode_Type := Ghost_Mode;
Scop : constant Entity_Id := Current_Scope;
Subp_Id : constant Entity_Id :=
Scop : constant Entity_Id := Current_Scope;
Subp_Id : constant Entity_Id :=
Analyze_Subprogram_Specification (Specification (N));
begin

6
gcc/ada/sem_ch8.adb
View file

@ -672,7 +672,9 @@ package body Sem_Ch8 is
GM : constant Ghost_Mode_Type := Ghost_Mode;
New_P : constant Entity_Id := Defining_Entity (N);
Old_P : Entity_Id;
Inst : Boolean := False; -- prevent junk warning
Inst : Boolean := False;
-- Prevent junk warning
begin
if Name (N) = Error then
@ -2646,7 +2648,7 @@ package body Sem_Ch8 is
-- type is class-wide.
GM : constant Ghost_Mode_Type := Ghost_Mode;
Inst_Node : Node_Id := Empty;
Inst_Node : Node_Id := Empty;
New_S : Entity_Id;
-- Start of processing for Analyze_Subprogram_Renaming

2
gcc/ada/sem_util.adb
View file

@ -17003,7 +17003,7 @@ package body Sem_Util is
Comp := First_Entity (Typ);
while Present (Comp) loop
if Ekind (Comp) = E_Component then
-- ???It's not cleare we need a full recursive call to
-- ???It's not clear we need a full recursive call to
-- Requires_Transient_Scope here. Note that the following
-- can't happen.

22
gcc/ada/treepr.adb
View file

@ -974,7 +974,7 @@ package body Treepr is
Prefix_Char : Character)
is
F : Fchar;
P : Natural := Pchar_Pos (Nkind (N));
P : Natural;
Field_To_Be_Printed : Boolean;
Prefix_Str_Char : String (Prefix_Str'First .. Prefix_Str'Last + 1);
@ -987,10 +987,14 @@ package body Treepr is
return;
end if;
if Nkind (N) = N_Integer_Literal and then Print_In_Hex (N) then
Fmt := Hex;
else
Fmt := Auto;
-- If there is no such node, indicate that. Skip the rest, so we don't
-- crash getting fields of the nonexistent node.
if N > Atree_Private_Part.Nodes.Last then
Print_Str ("No such node: ");
Print_Int (Int (N));
Print_Eol;
return;
end if;
Prefix_Str_Char (Prefix_Str'Range) := Prefix_Str;
@ -1184,6 +1188,14 @@ package body Treepr is
-- Loop to print fields included in Pchars array
P := Pchar_Pos (Nkind (N));
if Nkind (N) = N_Integer_Literal and then Print_In_Hex (N) then
Fmt := Hex;
else
Fmt := Auto;
end if;
while P < Pchar_Pos (Node_Kind'Succ (Nkind (N))) loop
F := Pchars (P);
P := P + 1;