+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
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);
-- 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'
-- 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;
---------------------------------
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;
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;
-- 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;
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));
-- 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;
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;
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);
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;
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;
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);
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;
begin
if Is_Checked_Ghost_Entity (Id) then
Ghost_Mode := Check;
-
elsif Is_Ignored_Ghost_Entity (Id) then
Ghost_Mode := Ignore;
end if;
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 =>
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
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;
-- 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));
-----------------------------------
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;
----------------------------------
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;
--------------------------------
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;
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;
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;
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
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
-- 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
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.
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);
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;
-- 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;
projects / gcc.git / commitdiff