Commit 15529d0a by Pierre-Marie de Rodat

exp_ch6.adb: (Make_Build_In_Place_Call_In_Object_Declaration): Remove the code at the end of...

gcc/ada/

2017-10-09  Bob Duff  <duff@adacore.com>

	* exp_ch6.adb: (Make_Build_In_Place_Call_In_Object_Declaration): Remove
	the code at the end of this procedure that was setting the type of a
	class-wide object to the specific type returned by a function call.
	Treat this case as indefinite instead.

2017-10-09  Ed Schonberg  <schonberg@adacore.com>

	* sem_ch4.adb (Try_Class_Wide_Operation, Traverse_Homonyms):
	Suppress spurious ambiguity error when two traversals of the homonym
	chain (first directly, and then through an examination of relevant
	interfaces) retrieve the same operation, when other irrelevant homonyms
	of the operatioh are also present.

2017-10-09  Ed Schonberg  <schonberg@adacore.com>

	* sem_util.adb (Object_Access_Level): If the object is the return
	statement of an expression function, return the level of the function.
	This is relevant when the object involves an implicit conversion
	between access types and the expression function is a completion, which
	forces the analysis of the expression before rewriting it as a body, so
	that freeze nodes can appear in the proper scope.

2017-10-09  Bob Duff  <duff@adacore.com>

	* atree.adb: Make nnd apply to everything "interesting", including
	Rewrite.  Remove rrd.

2017-10-09  Javier Miranda  <miranda@adacore.com>

	* exp_ch3.adb (Expand_N_Object_Declaration): Avoid never-ending loop
	processing the declaration of the dummy object internally created by
	Make_DT to compute the offset to the top of components referencing
	secondary dispatch tables.
	(Initialize_Tag): Do not initialize the offset-to-top field if it has
	been initialized initialized.
	* exp_disp.ads (Building_Static_Secondary_DT): New subprogram.
	* exp_disp.adb (Building_Static_Secondary_DT): New subprogram.
	(Make_DT): Create a dummy constant object if we can statically build
	secondary dispatch tables.
	(Make_Secondary_DT): For statically allocated secondary dispatch tables
	use the dummy object to compute the offset-to-top field value by means
	of the attribute 'Position.

gcc/testsuite/

2017-10-09  Ed Schonberg  <schonberg@adacore.com>

	* gnat.dg/class_wide3.adb, gnat.dg/class_wide3_pkg.ads: New testcase.

From-SVN: r253550
parent 5168a9b3
2017-10-09 Bob Duff <duff@adacore.com> 2017-10-09 Bob Duff <duff@adacore.com>
* exp_ch6.adb: (Make_Build_In_Place_Call_In_Object_Declaration): Remove
the code at the end of this procedure that was setting the type of a
class-wide object to the specific type returned by a function call.
Treat this case as indefinite instead.
2017-10-09 Ed Schonberg <schonberg@adacore.com>
* sem_ch4.adb (Try_Class_Wide_Operation, Traverse_Homonyms):
Suppress spurious ambiguity error when two traversals of the homonym
chain (first directly, and then through an examination of relevant
interfaces) retrieve the same operation, when other irrelevant homonyms
of the operatioh are also present.
2017-10-09 Ed Schonberg <schonberg@adacore.com>
* sem_util.adb (Object_Access_Level): If the object is the return
statement of an expression function, return the level of the function.
This is relevant when the object involves an implicit conversion
between access types and the expression function is a completion, which
forces the analysis of the expression before rewriting it as a body, so
that freeze nodes can appear in the proper scope.
2017-10-09 Bob Duff <duff@adacore.com>
* atree.adb: Make nnd apply to everything "interesting", including
Rewrite. Remove rrd.
2017-10-09 Javier Miranda <miranda@adacore.com>
* exp_ch3.adb (Expand_N_Object_Declaration): Avoid never-ending loop
processing the declaration of the dummy object internally created by
Make_DT to compute the offset to the top of components referencing
secondary dispatch tables.
(Initialize_Tag): Do not initialize the offset-to-top field if it has
been initialized initialized.
* exp_disp.ads (Building_Static_Secondary_DT): New subprogram.
* exp_disp.adb (Building_Static_Secondary_DT): New subprogram.
(Make_DT): Create a dummy constant object if we can statically build
secondary dispatch tables.
(Make_Secondary_DT): For statically allocated secondary dispatch tables
use the dummy object to compute the offset-to-top field value by means
of the attribute 'Position.
2017-10-09 Bob Duff <duff@adacore.com>
* exp_ch6.adb (Expand_N_Extended_Return_Statement): Add self-checking * exp_ch6.adb (Expand_N_Extended_Return_Statement): Add self-checking
code so if BIPAlloc is not passed in, it will likely raise code so if BIPAlloc is not passed in, it will likely raise
Program_Error instead of cause miscellaneous chaos. Program_Error instead of cause miscellaneous chaos.
......
...@@ -73,11 +73,12 @@ package body Atree is ...@@ -73,11 +73,12 @@ package body Atree is
-- ww := 12345 -- ww := 12345
-- and set a breakpoint on New_Node_Breakpoint (nickname "nn"). Continue. -- and set a breakpoint on New_Node_Breakpoint (nickname "nn"). Continue.
-- Either way, gnat1 will stop when node 12345 is created -- Either way, gnat1 will stop when node 12345 is created, or certain other
-- interesting operations are performed, such as Rewrite. To see exactly
-- which operations, search for "pragma Debug" below.
-- The second method is much faster -- The second method is much faster if the amount of Ada code being
-- compiled is large.
-- Similarly, rr and rrd allow breaking on rewriting of a given node
ww : Node_Id'Base := Node_Id'First - 1; ww : Node_Id'Base := Node_Id'First - 1;
pragma Export (Ada, ww); -- trick the optimizer pragma Export (Ada, ww); -- trick the optimizer
...@@ -103,24 +104,8 @@ package body Atree is ...@@ -103,24 +104,8 @@ package body Atree is
-- If Node = Watch_Node, this prints out the new node and calls -- If Node = Watch_Node, this prints out the new node and calls
-- New_Node_Breakpoint. Otherwise, does nothing. -- New_Node_Breakpoint. Otherwise, does nothing.
procedure rr;
pragma Export (Ada, rr);
procedure Rewrite_Breakpoint renames rr;
-- This doesn't do anything interesting; it's just for setting breakpoint
-- on as explained above.
procedure rrd (Old_Node, New_Node : Node_Id);
pragma Export (Ada, rrd);
procedure Rewrite_Debugging_Output
(Old_Node, New_Node : Node_Id) renames rrd;
-- For debugging. If debugging is turned on, Rewrite calls this. If debug
-- flag N is turned on, this prints out the new node.
--
-- If Old_Node = Watch_Node, this prints out the old and new nodes and
-- calls Rewrite_Breakpoint. Otherwise, does nothing.
procedure Node_Debug_Output (Op : String; N : Node_Id); procedure Node_Debug_Output (Op : String; N : Node_Id);
-- Common code for nnd and rrd, writes Op followed by information about N -- Called by nnd; writes Op followed by information about N
procedure Print_Statistics; procedure Print_Statistics;
pragma Export (Ada, Print_Statistics); pragma Export (Ada, Print_Statistics);
...@@ -751,6 +736,8 @@ package body Atree is ...@@ -751,6 +736,8 @@ package body Atree is
Save_Link : constant Union_Id := Nodes.Table (Destination).Link; Save_Link : constant Union_Id := Nodes.Table (Destination).Link;
begin begin
pragma Debug (New_Node_Debugging_Output (Source));
pragma Debug (New_Node_Debugging_Output (Destination));
Nodes.Table (Destination) := Nodes.Table (Source); Nodes.Table (Destination) := Nodes.Table (Source);
Nodes.Table (Destination).In_List := Save_In_List; Nodes.Table (Destination).In_List := Save_In_List;
Nodes.Table (Destination).Link := Save_Link; Nodes.Table (Destination).Link := Save_Link;
...@@ -1348,6 +1335,8 @@ package body Atree is ...@@ -1348,6 +1335,8 @@ package body Atree is
Temp_Flg : Flags_Byte; Temp_Flg : Flags_Byte;
begin begin
pragma Debug (New_Node_Debugging_Output (E1));
pragma Debug (New_Node_Debugging_Output (E2));
pragma Assert (True pragma Assert (True
and then Has_Extension (E1) and then Has_Extension (E1)
and then Has_Extension (E2) and then Has_Extension (E2)
...@@ -1746,7 +1735,6 @@ package body Atree is ...@@ -1746,7 +1735,6 @@ package body Atree is
begin begin
Write_Str ("Watched node "); Write_Str ("Watched node ");
Write_Int (Int (Watch_Node)); Write_Int (Int (Watch_Node));
Write_Str (" created");
Write_Eol; Write_Eol;
end nn; end nn;
...@@ -1759,7 +1747,7 @@ package body Atree is ...@@ -1759,7 +1747,7 @@ package body Atree is
begin begin
if Debug_Flag_N or else Node_Is_Watched then if Debug_Flag_N or else Node_Is_Watched then
Node_Debug_Output ("Allocate", N); Node_Debug_Output ("Node", N);
if Node_Is_Watched then if Node_Is_Watched then
New_Node_Breakpoint; New_Node_Breakpoint;
...@@ -2163,6 +2151,8 @@ package body Atree is ...@@ -2163,6 +2151,8 @@ package body Atree is
(not Has_Extension (Old_Node) (not Has_Extension (Old_Node)
and not Has_Extension (New_Node) and not Has_Extension (New_Node)
and not Nodes.Table (New_Node).In_List); and not Nodes.Table (New_Node).In_List);
pragma Debug (New_Node_Debugging_Output (Old_Node));
pragma Debug (New_Node_Debugging_Output (New_Node));
-- Do copy, preserving link and in list status and required flags -- Do copy, preserving link and in list status and required flags
...@@ -2214,7 +2204,8 @@ package body Atree is ...@@ -2214,7 +2204,8 @@ package body Atree is
(not Has_Extension (Old_Node) (not Has_Extension (Old_Node)
and not Has_Extension (New_Node) and not Has_Extension (New_Node)
and not Nodes.Table (New_Node).In_List); and not Nodes.Table (New_Node).In_List);
pragma Debug (Rewrite_Debugging_Output (Old_Node, New_Node)); pragma Debug (New_Node_Debugging_Output (Old_Node));
pragma Debug (New_Node_Debugging_Output (New_Node));
if Nkind (Old_Node) in N_Subexpr then if Nkind (Old_Node) in N_Subexpr then
Old_Paren_Count := Paren_Count (Old_Node); Old_Paren_Count := Paren_Count (Old_Node);
...@@ -2264,36 +2255,6 @@ package body Atree is ...@@ -2264,36 +2255,6 @@ package body Atree is
end if; end if;
end Rewrite; end Rewrite;
-------------------------
-- Rewrite_Breakpoint --
-------------------------
procedure rr is
begin
Write_Str ("Watched node ");
Write_Int (Int (Watch_Node));
Write_Str (" rewritten");
Write_Eol;
end rr;
------------------------------
-- Rewrite_Debugging_Output --
------------------------------
procedure rrd (Old_Node, New_Node : Node_Id) is
Node_Is_Watched : constant Boolean := Old_Node = Watch_Node;
begin
if Debug_Flag_N or else Node_Is_Watched then
Node_Debug_Output ("Rewrite", Old_Node);
Node_Debug_Output ("into", New_Node);
if Node_Is_Watched then
Rewrite_Breakpoint;
end if;
end if;
end rrd;
------------------ ------------------
-- Set_Analyzed -- -- Set_Analyzed --
------------------ ------------------
......
...@@ -6138,6 +6138,19 @@ package body Exp_Ch3 is ...@@ -6138,6 +6138,19 @@ package body Exp_Ch3 is
return; return;
end if; end if;
-- No action needed for the internal imported dummy object added by
-- Make_DT to compute the offset of the components that reference
-- secondary dispatch tables; required to avoid never-ending loop
-- processing this internal object declaration.
if Tagged_Type_Expansion
and then Is_Internal (Def_Id)
and then Is_Imported (Def_Id)
and then Related_Type (Def_Id) = Implementation_Base_Type (Typ)
then
return;
end if;
-- First we do special processing for objects of a tagged type where -- First we do special processing for objects of a tagged type where
-- this is the point at which the type is frozen. The creation of the -- this is the point at which the type is frozen. The creation of the
-- dispatch table and the initialization procedure have to be deferred -- dispatch table and the initialization procedure have to be deferred
...@@ -8384,10 +8397,13 @@ package body Exp_Ch3 is ...@@ -8384,10 +8397,13 @@ package body Exp_Ch3 is
-- Normal case: No discriminants in the parent type -- Normal case: No discriminants in the parent type
else else
-- Don't need to set any value if this interface shares the -- Don't need to set any value if the offset-to-top field is
-- primary dispatch table. -- statically set or if this interface shares the primary
-- dispatch table.
if not Is_Ancestor (Iface, Typ, Use_Full_View => True) then if not Building_Static_Secondary_DT (Typ)
and then not Is_Ancestor (Iface, Typ, Use_Full_View => True)
then
Append_To (Stmts_List, Append_To (Stmts_List,
Build_Set_Static_Offset_To_Top (Loc, Build_Set_Static_Offset_To_Top (Loc,
Iface_Tag => New_Occurrence_Of (Iface_Tag, Loc), Iface_Tag => New_Occurrence_Of (Iface_Tag, Loc),
......
...@@ -174,6 +174,11 @@ package Exp_Disp is ...@@ -174,6 +174,11 @@ package Exp_Disp is
pragma Inline (Building_Static_DT); pragma Inline (Building_Static_DT);
-- Returns true when building statically allocated dispatch tables -- Returns true when building statically allocated dispatch tables
function Building_Static_Secondary_DT (Typ : Entity_Id) return Boolean;
pragma Inline (Building_Static_Secondary_DT);
-- Returns true when building statically allocated secondary dispatch
-- tables
procedure Build_Static_Dispatch_Tables (N : Node_Id); procedure Build_Static_Dispatch_Tables (N : Node_Id);
-- N is a library level package declaration or package body. Build the -- N is a library level package declaration or package body. Build the
-- static dispatch table of the tagged types defined at library level. In -- static dispatch table of the tagged types defined at library level. In
......
...@@ -8860,7 +8860,7 @@ package body Sem_Ch4 is ...@@ -8860,7 +8860,7 @@ package body Sem_Ch4 is
while Present (Hom) loop while Present (Hom) loop
if Ekind_In (Hom, E_Procedure, E_Function) if Ekind_In (Hom, E_Procedure, E_Function)
and then (not Is_Hidden (Hom) or else In_Instance) and then (not Is_Hidden (Hom) or else In_Instance)
and then Scope (Hom) = Scope (Anc_Type) and then Scope (Hom) = Scope (Base_Type (Anc_Type))
and then Present (First_Formal (Hom)) and then Present (First_Formal (Hom))
and then and then
(Base_Type (Etype (First_Formal (Hom))) = Cls_Type (Base_Type (Etype (First_Formal (Hom))) = Cls_Type
...@@ -8921,8 +8921,13 @@ package body Sem_Ch4 is ...@@ -8921,8 +8921,13 @@ package body Sem_Ch4 is
Success => Success, Success => Success,
Skip_First => True); Skip_First => True);
-- The same operation may be encountered on two homonym
-- traversals, before and after looking at interfaces.
-- Check for this case before reporting a real ambiguity.
if Present (Valid_Candidate (Success, Call_Node, Hom)) if Present (Valid_Candidate (Success, Call_Node, Hom))
and then Nkind (Call_Node) /= N_Function_Call and then Nkind (Call_Node) /= N_Function_Call
and then Hom /= Matching_Op
then then
Error_Msg_NE ("ambiguous call to&", N, Hom); Error_Msg_NE ("ambiguous call to&", N, Hom);
Report_Ambiguity (Matching_Op); Report_Ambiguity (Matching_Op);
......
...@@ -20383,6 +20383,17 @@ package body Sem_Util is ...@@ -20383,6 +20383,17 @@ package body Sem_Util is
(Nearest_Dynamic_Scope (Nearest_Dynamic_Scope
(Defining_Entity (Node_Par))); (Defining_Entity (Node_Par)));
-- For a return statement within a function, return
-- the depth of the function itself. This is not just
-- a small optimization, but matters when analyzing
-- the expression in an expression function before
-- the body is created.
when N_Simple_Return_Statement =>
if Ekind (Current_Scope) = E_Function then
return Scope_Depth (Current_Scope);
end if;
when others => when others =>
null; null;
end case; end case;
......
with Ada.Text_IO; use Ada.Text_IO;
with Class_Wide3_Pkg; use Class_Wide3_Pkg;
procedure Class_Wide3 is
DC : Disc_Child := (N => 1, I => 3, J => 5);
begin
DC.Put_Line;
end Class_Wide3;
package Class_Wide3_Pkg is
type Iface is interface;
type Iface_Ptr is access all Iface'Class;
procedure Put_Line (I : Iface'Class);
type Root is tagged record
I : Integer;
end record;
type Disc_Child (N : Integer) is new Root and Iface with record
J : Integer;
end record;
end Class_Wide3_Pkg;
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment