[multiple changes]

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

	* sem_ch5.adb (Analyze_Loop_Statement): Attach generated loop
	identifier to the tree, because it may be the root of a tree
	traversal in Pop_Scope when freeze actions are pending.

2015-10-20  Steve Baird  <baird@adacore.com>

	* pprint.ads (Expression_Image) Add new generic formal flag
	Hide_Parameter_Blocks.
	* pprint.adb (Expression_Image) If new flag is set, then display
	dereferences of parameter block components accordingly.

From-SVN: r229068
This commit is contained in:
Arnaud Charlet 2015-10-20 14:20:20 +02:00
parent e5f2c03cea
commit 78cef47f96
4 changed files with 209 additions and 110 deletions

View File

@ -1,3 +1,16 @@
2015-10-20 Ed Schonberg <schonberg@adacore.com>
* sem_ch5.adb (Analyze_Loop_Statement): Attach generated loop
identifier to the tree, because it may be the root of a tree
traversal in Pop_Scope when freeze actions are pending.
2015-10-20 Steve Baird <baird@adacore.com>
* pprint.ads (Expression_Image) Add new generic formal flag
Hide_Parameter_Blocks.
* pprint.adb (Expression_Image) If new flag is set, then display
dereferences of parameter block components accordingly.
2015-10-20 Ed Schonberg <schonberg@adacore.com>
* sem_prag.adb: Code clean up.

View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2008-2014, Free Software Foundation, Inc. --
-- Copyright (C) 2008-2015, 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- --
@ -43,13 +43,16 @@ package body Pprint is
-- Expression_Image --
----------------------
function Expression_Image (Expr : Node_Id; Default : String)
return String is
function Expression_Image
(Expr : Node_Id;
Default : String) return String
is
From_Source : constant Boolean :=
Comes_From_Source (Expr)
and then not Opt.Debug_Generated_Code;
Append_Paren : Boolean := False;
Left : Node_Id := Original_Node (Expr);
Right : Node_Id := Original_Node (Expr);
From_Source : constant Boolean :=
Comes_From_Source (Expr) and then not Opt.Debug_Generated_Code;
Append_Paren : Boolean := False;
function Expr_Name
(Expr : Node_Id;
@ -76,6 +79,10 @@ package body Pprint is
Add_Paren : Boolean := True) return String;
-- Return a string corresponding to List
---------------
-- List_Name --
---------------
function List_Name
(List : Node_Id;
Add_Space : Boolean := True;
@ -87,6 +94,7 @@ package body Pprint is
Add_Space : Boolean := True;
Add_Paren : Boolean := True;
Num : Natural := 1) return String;
-- ??? what does this do
------------------------
-- Internal_List_Name --
@ -100,6 +108,7 @@ package body Pprint is
Num : Natural := 1) return String
is
function Prepend (S : String) return String;
-- ??? what does this do
-------------
-- Prepend --
@ -137,20 +146,22 @@ package body Pprint is
end if;
end if;
-- ??? the Internal_List_Name calls can be factored out
if First then
return Prepend
(Expr_Name (List)
& Internal_List_Name (Next (List),
First => False,
Add_Paren => Add_Paren,
Num => Num + 1));
return Prepend (Expr_Name (List)
& Internal_List_Name
(List => Next (List),
First => False,
Add_Paren => Add_Paren,
Num => Num + 1));
else
return ", " & Expr_Name (List) &
Internal_List_Name
(Next (List),
First => False,
Add_Paren => Add_Paren,
Num => Num + 1);
return ", " & Expr_Name (List)
& Internal_List_Name
(List => Next (List),
First => False,
Add_Paren => Add_Paren,
Num => Num + 1);
end if;
end Internal_List_Name;
@ -164,10 +175,13 @@ package body Pprint is
end if;
List_Name_Count := List_Name_Count + 1;
declare
Result : constant String :=
Internal_List_Name
(List, Add_Space => Add_Space, Add_Paren => Add_Paren);
Internal_List_Name
(List => List,
Add_Space => Add_Space,
Add_Paren => Add_Paren);
begin
List_Name_Count := List_Name_Count - 1;
return Result;
@ -197,14 +211,14 @@ package body Pprint is
when N_Character_Literal =>
declare
Char : constant Int :=
UI_To_Int (Char_Literal_Value (Expr));
UI_To_Int (Char_Literal_Value (Expr));
begin
if Char in 32 .. 127 then
return "'" & Character'Val (Char) & "'";
else
UI_Image (Char_Literal_Value (Expr));
return "'\" & UI_Image_Buffer (1 .. UI_Image_Length)
& "'";
return
"'\" & UI_Image_Buffer (1 .. UI_Image_Length) & "'";
end if;
end;
@ -223,8 +237,10 @@ package body Pprint is
when N_Aggregate =>
if Present (Sinfo.Expressions (Expr)) then
return List_Name
(First (Sinfo.Expressions (Expr)), Add_Space => False);
return
List_Name
(List => First (Sinfo.Expressions (Expr)),
Add_Space => False);
-- Do not return empty string for (others => <>) aggregate
-- of a componentless record type. At least one caller (the
@ -237,27 +253,30 @@ package body Pprint is
return ("(null record)");
else
return List_Name
(First (Component_Associations (Expr)),
Add_Space => False, Add_Paren => False);
return
List_Name
(List => First (Component_Associations (Expr)),
Add_Space => False,
Add_Paren => False);
end if;
when N_Extension_Aggregate =>
return "(" & Expr_Name (Ancestor_Part (Expr)) &
" with " &
List_Name (First (Sinfo.Expressions (Expr)),
Add_Space => False, Add_Paren => False) &
")";
return "(" & Expr_Name (Ancestor_Part (Expr)) & " with "
& List_Name
(List => First (Sinfo.Expressions (Expr)),
Add_Space => False,
Add_Paren => False) & ")";
when N_Attribute_Reference =>
if Take_Prefix then
declare
Str : constant String := Expr_Name (Prefix (Expr))
& "'" & Get_Name_String (Attribute_Name (Expr));
Id : constant Attribute_Id :=
Get_Attribute_Id (Attribute_Name (Expr));
Ranges : List_Id;
Get_Attribute_Id (Attribute_Name (Expr));
Str : constant String :=
Expr_Name (Prefix (Expr)) & "'"
& Get_Name_String (Attribute_Name (Expr));
N : Node_Id;
Ranges : List_Id;
begin
if (Id = Attribute_First or else Id = Attribute_Last)
@ -271,22 +290,26 @@ package body Pprint is
end if;
if Nkind (N) = N_Subtype_Declaration then
Ranges := Constraints (Constraint
(Subtype_Indication (N)));
Ranges :=
Constraints
(Constraint (Subtype_Indication (N)));
if List_Length (Ranges) = 1
and then Nkind_In
(First (Ranges),
N_Range,
N_Real_Range_Specification,
N_Signed_Integer_Type_Definition)
and then
Nkind_In
(First (Ranges),
N_Range,
N_Real_Range_Specification,
N_Signed_Integer_Type_Definition)
then
if Id = Attribute_First then
return Expression_Image
(Low_Bound (First (Ranges)), Str);
return
Expression_Image
(Low_Bound (First (Ranges)), Str);
else
return Expression_Image
(High_Bound (First (Ranges)), Str);
return
Expression_Image
(High_Bound (First (Ranges)), Str);
end if;
end if;
end if;
@ -300,7 +323,18 @@ package body Pprint is
end if;
when N_Explicit_Dereference =>
if Take_Prefix then
-- Return "Foo" instead of "Parameter_Block.Foo.all"
if Hide_Parameter_Blocks
and then Nkind (Prefix (Expr)) = N_Selected_Component
and then Present (Etype (Prefix (Expr)))
and then Is_Access_Type (Etype (Prefix (Expr)))
and then Is_Param_Block_Component_Type (Etype (Prefix (Expr)))
then
return Expr_Name (Selector_Name (Prefix (Expr)));
elsif Take_Prefix then
return Expr_Name (Prefix (Expr)) & ".all";
else
return ".all";
@ -308,31 +342,36 @@ package body Pprint is
when N_Expanded_Name | N_Selected_Component =>
if Take_Prefix then
return Expr_Name (Prefix (Expr))
& "." & Expr_Name (Selector_Name (Expr));
return
Expr_Name (Prefix (Expr)) & "." &
Expr_Name (Selector_Name (Expr));
else
return "." & Expr_Name (Selector_Name (Expr));
end if;
when N_Component_Association =>
return "("
& List_Name (First (Choices (Expr)),
Add_Space => False, Add_Paren => False)
& List_Name
(List => First (Choices (Expr)),
Add_Space => False,
Add_Paren => False)
& " => " & Expr_Name (Expression (Expr)) & ")";
when N_If_Expression =>
declare
N : constant Node_Id := First (Sinfo.Expressions (Expr));
begin
return "if " & Expr_Name (N) & " then " &
Expr_Name (Next (N)) & " else " &
Expr_Name (Next (Next (N)));
return
"if " & Expr_Name (N) & " then "
& Expr_Name (Next (N)) & " else "
& Expr_Name (Next (Next (N)));
end;
when N_Qualified_Expression =>
declare
Mark : constant String :=
Expr_Name (Subtype_Mark (Expr), Expand_Type => False);
Expr_Name
(Subtype_Mark (Expr), Expand_Type => False);
Str : constant String := Expr_Name (Expression (Expr));
begin
if Str (Str'First) = '(' and then Str (Str'Last) = ')' then
@ -347,118 +386,145 @@ package body Pprint is
when N_Raise_Constraint_Error =>
if Present (Condition (Expr)) then
return "[constraint_error when " &
Expr_Name (Condition (Expr)) & "]";
return
"[constraint_error when "
& Expr_Name (Condition (Expr)) & "]";
else
return "[constraint_error]";
end if;
when N_Raise_Program_Error =>
if Present (Condition (Expr)) then
return "[program_error when " &
Expr_Name (Condition (Expr)) & "]";
return
"[program_error when "
& Expr_Name (Condition (Expr)) & "]";
else
return "[program_error]";
end if;
when N_Range =>
return Expr_Name (Low_Bound (Expr)) & ".." &
return
Expr_Name (Low_Bound (Expr)) & ".." &
Expr_Name (High_Bound (Expr));
when N_Slice =>
return Expr_Name (Prefix (Expr)) & " (" &
return
Expr_Name (Prefix (Expr)) & " (" &
Expr_Name (Discrete_Range (Expr)) & ")";
when N_And_Then =>
return Expr_Name (Left_Opnd (Expr)) & " and then " &
return
Expr_Name (Left_Opnd (Expr)) & " and then " &
Expr_Name (Right_Opnd (Expr));
when N_In =>
return Expr_Name (Left_Opnd (Expr)) & " in " &
return
Expr_Name (Left_Opnd (Expr)) & " in " &
Expr_Name (Right_Opnd (Expr));
when N_Not_In =>
return Expr_Name (Left_Opnd (Expr)) & " not in " &
return
Expr_Name (Left_Opnd (Expr)) & " not in " &
Expr_Name (Right_Opnd (Expr));
when N_Or_Else =>
return Expr_Name (Left_Opnd (Expr)) & " or else " &
return
Expr_Name (Left_Opnd (Expr)) & " or else " &
Expr_Name (Right_Opnd (Expr));
when N_Op_And =>
return Expr_Name (Left_Opnd (Expr)) & " and " &
return
Expr_Name (Left_Opnd (Expr)) & " and " &
Expr_Name (Right_Opnd (Expr));
when N_Op_Or =>
return Expr_Name (Left_Opnd (Expr)) & " or " &
return
Expr_Name (Left_Opnd (Expr)) & " or " &
Expr_Name (Right_Opnd (Expr));
when N_Op_Xor =>
return Expr_Name (Left_Opnd (Expr)) & " xor " &
return
Expr_Name (Left_Opnd (Expr)) & " xor " &
Expr_Name (Right_Opnd (Expr));
when N_Op_Eq =>
return Expr_Name (Left_Opnd (Expr)) & " = " &
return
Expr_Name (Left_Opnd (Expr)) & " = " &
Expr_Name (Right_Opnd (Expr));
when N_Op_Ne =>
return Expr_Name (Left_Opnd (Expr)) & " /= " &
return
Expr_Name (Left_Opnd (Expr)) & " /= " &
Expr_Name (Right_Opnd (Expr));
when N_Op_Lt =>
return Expr_Name (Left_Opnd (Expr)) & " < " &
return
Expr_Name (Left_Opnd (Expr)) & " < " &
Expr_Name (Right_Opnd (Expr));
when N_Op_Le =>
return Expr_Name (Left_Opnd (Expr)) & " <= " &
return
Expr_Name (Left_Opnd (Expr)) & " <= " &
Expr_Name (Right_Opnd (Expr));
when N_Op_Gt =>
return Expr_Name (Left_Opnd (Expr)) & " > " &
return
Expr_Name (Left_Opnd (Expr)) & " > " &
Expr_Name (Right_Opnd (Expr));
when N_Op_Ge =>
return Expr_Name (Left_Opnd (Expr)) & " >= " &
return
Expr_Name (Left_Opnd (Expr)) & " >= " &
Expr_Name (Right_Opnd (Expr));
when N_Op_Add =>
return Expr_Name (Left_Opnd (Expr)) & " + " &
return
Expr_Name (Left_Opnd (Expr)) & " + " &
Expr_Name (Right_Opnd (Expr));
when N_Op_Subtract =>
return Expr_Name (Left_Opnd (Expr)) & " - " &
return
Expr_Name (Left_Opnd (Expr)) & " - " &
Expr_Name (Right_Opnd (Expr));
when N_Op_Multiply =>
return Expr_Name (Left_Opnd (Expr)) & " * " &
return
Expr_Name (Left_Opnd (Expr)) & " * " &
Expr_Name (Right_Opnd (Expr));
when N_Op_Divide =>
return Expr_Name (Left_Opnd (Expr)) & " / " &
return
Expr_Name (Left_Opnd (Expr)) & " / " &
Expr_Name (Right_Opnd (Expr));
when N_Op_Mod =>
return Expr_Name (Left_Opnd (Expr)) & " mod " &
return
Expr_Name (Left_Opnd (Expr)) & " mod " &
Expr_Name (Right_Opnd (Expr));
when N_Op_Rem =>
return Expr_Name (Left_Opnd (Expr)) & " rem " &
return
Expr_Name (Left_Opnd (Expr)) & " rem " &
Expr_Name (Right_Opnd (Expr));
when N_Op_Expon =>
return Expr_Name (Left_Opnd (Expr)) & " ** " &
return
Expr_Name (Left_Opnd (Expr)) & " ** " &
Expr_Name (Right_Opnd (Expr));
when N_Op_Shift_Left =>
return Expr_Name (Left_Opnd (Expr)) & " << " &
return
Expr_Name (Left_Opnd (Expr)) & " << " &
Expr_Name (Right_Opnd (Expr));
when N_Op_Shift_Right | N_Op_Shift_Right_Arithmetic =>
return Expr_Name (Left_Opnd (Expr)) & " >> " &
return
Expr_Name (Left_Opnd (Expr)) & " >> " &
Expr_Name (Right_Opnd (Expr));
when N_Op_Concat =>
return Expr_Name (Left_Opnd (Expr)) & " & " &
return
Expr_Name (Left_Opnd (Expr)) & " & " &
Expr_Name (Right_Opnd (Expr));
when N_Op_Plus =>
@ -485,8 +551,9 @@ package body Pprint is
when N_Indexed_Component =>
if Take_Prefix then
return Expr_Name (Prefix (Expr)) &
List_Name (First (Sinfo.Expressions (Expr)));
return
Expr_Name (Prefix (Expr))
& List_Name (First (Sinfo.Expressions (Expr)));
else
return List_Name (First (Sinfo.Expressions (Expr)));
end if;
@ -498,12 +565,15 @@ package body Pprint is
-- parentheses around function call to mark it specially.
if Default = "" then
return '(' & Expr_Name (Name (Expr)) &
List_Name (First (Sinfo.Parameter_Associations (Expr))) &
')';
return '('
& Expr_Name (Name (Expr))
& List_Name (First (Sinfo.Parameter_Associations (Expr)))
& ')';
else
return Expr_Name (Name (Expr)) &
List_Name (First (Sinfo.Parameter_Associations (Expr)));
return
Expr_Name (Name (Expr))
& List_Name
(First (Sinfo.Parameter_Associations (Expr)));
end if;
when N_Null =>
@ -538,18 +608,24 @@ package body Pprint is
loop
case Nkind (Left) is
when N_Binary_Op | N_Membership_Test |
N_And_Then | N_Or_Else =>
when N_And_Then |
N_Binary_Op |
N_Membership_Test |
N_Or_Else =>
Left := Original_Node (Left_Opnd (Left));
when N_Attribute_Reference | N_Expanded_Name |
N_Explicit_Dereference | N_Indexed_Component |
N_Reference | N_Selected_Component |
N_Slice =>
when N_Attribute_Reference |
N_Expanded_Name |
N_Explicit_Dereference |
N_Indexed_Component |
N_Reference |
N_Selected_Component |
N_Slice =>
Left := Original_Node (Prefix (Left));
when N_Designator | N_Defining_Program_Unit_Name |
N_Function_Call =>
when N_Defining_Program_Unit_Name |
N_Designator |
N_Function_Call =>
Left := Original_Node (Name (Left));
when N_Range =>
@ -567,11 +643,14 @@ package body Pprint is
loop
case Nkind (Right) is
when N_Op | N_Membership_Test |
N_And_Then | N_Or_Else =>
when N_And_Then |
N_Membership_Test |
N_Op |
N_Or_Else =>
Right := Original_Node (Right_Opnd (Right));
when N_Selected_Component | N_Expanded_Name =>
when N_Expanded_Name |
N_Selected_Component =>
Right := Original_Node (Selector_Name (Right));
when N_Designator =>
@ -634,11 +713,11 @@ package body Pprint is
end loop;
declare
Scn : Source_Ptr := Original_Location (Sloc (Left));
Src : constant Source_Buffer_Ptr :=
Source_Text (Get_Source_File_Index (Scn));
End_Sloc : constant Source_Ptr :=
Original_Location (Sloc (Right));
Original_Location (Sloc (Right));
Src : constant Source_Buffer_Ptr :=
Source_Text (Get_Source_File_Index (Scn));
Scn : Source_Ptr := Original_Location (Sloc (Left));
begin
if Scn > End_Sloc then
@ -647,9 +726,9 @@ package body Pprint is
declare
Buffer : String (1 .. Natural (End_Sloc - Scn));
Index : Natural := 0;
Skipping_Comment : Boolean := False;
Underscore : Boolean := False;
Index : Natural := 0;
begin
if Right /= Expr then

View File

@ -46,6 +46,10 @@ package Pprint is
-- nodes
-- ??? Expand_Type argument should be removed
Hide_Parameter_Blocks : Boolean := False;
-- If true, then "Parameter_Block.Field_Name.all" is
-- instead displayed as "Field_Name".
function Expression_Image
(Expr : Node_Id;
Default : String) return String;

View File

@ -3217,12 +3217,15 @@ package body Sem_Ch5 is
-- Case of no identifier present. Create one and attach it to the
-- loop statement for use as a scope and as a reference for later
-- expansions. Indicate that the label does not come from source.
-- expansions. Indicate that the label does not come from source,
-- and attach it to the loop statement so it is part of the tree,
-- even without a full declaration.
else
Ent := New_Internal_Entity (E_Loop, Current_Scope, Loc, 'L');
Set_Etype (Ent, Standard_Void_Type);
Set_Identifier (N, New_Occurrence_Of (Ent, Loc));
Set_Parent (Ent, N);
Set_Has_Created_Identifier (N);
end if;