This patch fixes a rare visibility issue that arises when an expanded name in
a proper body has a prefix which is a package that appears in a with_clause of
the proper body, when there is a homonym of the package declared in the parent
of the subunit. Previous to this patch a (spurious) error was reported.
The following must compile quietly:
gnatmake -q -Pacttask
---
with Main;
procedure Acttask is
begin
Main.Startup;
end Acttask;
---
with Ada.Text_Io; use Ada.Text_Io;
with User;
package body Main is
task type Main_T is new User.Main.T with
entry Start;
entry Dispatch (Deliver : User.Buffer_T);
end Main_T;
T : aliased Main_T;
package Initiate is
procedure Resources;
end Initiate;
package body Initiate is separate;
procedure Startup is
begin
T.Start;
end Startup;
task body Main_T is
Deliver : User.Buffer_T;
begin
accept Start;
Initiate.Resources;
while True loop
select
accept Start;
or
accept Dispatch (Deliver : User.Buffer_T) do
Main_T.Deliver := Deliver;
end Dispatch;
User.Dispatch (Deliver);
end select;
delay 1.0;
end loop;
end Main_T;
end Main;
---
package main is
procedure Startup;
end Main;
---
with Start;
with Ada.Text_Io;
separate (Main)
package body Initiate is
procedure Resources is
begin
User.Start (T'Access);
Ada.Text_Io.Put_Line ("Hej hopp" & Integer'Image (Start.V));
end Resources;
end Initiate;
--
package start is
v : constant integer := 17;
end start;
---
generic
type Deliver_T is private;
package task_if is
type T is limited interface;
type Access_T is access all T'Class;
procedure Dispatch (Synchronized_Interface : in out T; Deliver : Deliver_T)
is abstract;
end;
---
with Ada.Text_Io; use Ada.Text_Io;
package body Task_If.Pump is
task type Pump_T is
entry Start (Deliver : in Deliver_T; Deliver_To : Access_T);
entry Start2 (Deliver : in Deliver_T; Deliver_To : Access_T);
end Pump_T;
P : Pump_T;
procedure Start (Deliver : in Deliver_T; Deliver_To : Access_T) is
begin
P.Start (Deliver, Deliver_To);
end Start;
task body Pump_T is
Deliver : Deliver_T;
Deliver_To : Access_T;
procedure Working_Hard is
begin
for I in 1 .. 15 loop
Put (".");
delay 0.1;
end loop;
Put_Line ("Eureka!");
end Working_Hard;
begin
accept Start (Deliver : in Deliver_T; Deliver_To : Access_T) do
Pump_T.Deliver := Deliver;
Pump_T.Deliver_To := Deliver_To;
requeue Start2;
end Start;
accept Start2 (Deliver : in Deliver_T; Deliver_To : Access_T) do
Put_Line ("All is well:" &
Boolean'Image
(Pump_T.Deliver = Deliver and Pump_T.Deliver_To = Deliver_To));
end Start2;
loop
-- Some possible examples we can do when Dispatch is an entry.
select
Deliver_To.Dispatch (Deliver);
else
Put_Line ("Cant deliver");
end select;
select
Deliver_To.Dispatch (Deliver);
or
delay 1.0;
Put_Line ("Timed out");
end select;
select
Deliver_To.Dispatch (Deliver);
Put_Line ("");
then abort
Working_Hard;
end select;
end loop;
end Pump_T;
end Task_If.Pump;
---
generic
package Task_If.Pump is
procedure Start (Deliver : in Deliver_T; Deliver_To : Access_T);
end Task_If.Pump;
---
with Ada.Text_Io; use Ada.Text_Io;
with Task_If.Pump;
package body User is
package Pump is new Main.Pump;
procedure Start (Deliver_To : Main.Access_T) is
begin
Pump.Start ("Hej hopp ditt feta nylle", Deliver_To);
end Start;
procedure Dispatch (Buffer : Buffer_T) is
begin
Put_Line (String (Buffer));
end Dispatch;
end User;
---
with Task_If;
package user is
type Buffer_T is new String (1 .. 24);
package Main is new Task_If (Deliver_T => Buffer_T);
procedure Start (Deliver_To : Main.Access_T);
procedure Dispatch (Buffer: Buffer_T);
end User;
Tested on x86_64-pc-linux-gnu, committed on trunk
2014-01-22 Ed Schonberg <[email protected]>
* sem_ch8.adb (Find_Selected_Component): Handle properly the case
of an expanded name in a proper body, whose prefix is a package
in the context of the proper body, when there is a homonym of
the package declared in the parent unit.
Index: sem_ch8.adb
===================================================================
--- sem_ch8.adb (revision 206918)
+++ sem_ch8.adb (working copy)
@@ -5963,6 +5963,52 @@
Nam : Node_Id;
+ function Is_Reference_In_Subunit return Boolean;
+ -- In a subunit, the scope depth is not a proper measure of hiding,
+ -- because the context of the proper body may itself hide entities in
+ -- parent units. This rare case requires inspecting the tree directly
+ -- because the proper body is inserted in the main unit and its context
+ -- is simply added to that of the parent.
+
+ -----------------------------
+ -- Is_Reference_In_Subunit --
+ -----------------------------
+
+ function Is_Reference_In_Subunit return Boolean is
+ Clause : Node_Id;
+ Comp_Unit : Node_Id;
+
+ begin
+ Comp_Unit := N;
+ while Present (Comp_Unit)
+ and then Nkind (Comp_Unit) /= N_Compilation_Unit
+ loop
+ Comp_Unit := Parent (Comp_Unit);
+ end loop;
+
+ if No (Comp_Unit)
+ or else Nkind (Unit (Comp_Unit)) /= N_Subunit
+ then
+ return False;
+ end if;
+
+ -- Now check whether the package is in the context of the subunit
+
+ Clause := First (Context_Items (Comp_Unit));
+
+ while Present (Clause) loop
+ if Nkind (Clause) = N_With_Clause
+ and then Entity (Name (Clause)) = P_Name
+ then
+ return True;
+ end if;
+
+ Clause := Next (Clause);
+ end loop;
+
+ return False;
+ end Is_Reference_In_Subunit;
+
begin
Analyze (P);
@@ -6244,11 +6290,13 @@
end loop;
if Present (P_Name) then
- Error_Msg_Sloc := Sloc (Entity (Prefix (N)));
+ if not Is_Reference_In_Subunit then
+ Error_Msg_Sloc := Sloc (Entity (Prefix (N)));
- Error_Msg_NE
- ("package& is hidden by declaration#",
- N, P_Name);
+ Error_Msg_NE
+ ("package& is hidden by declaration#",
+ N, P_Name);
+ end if;
Set_Entity (Prefix (N), P_Name);
Find_Expanded_Name (N);
