===================================================================
@@ -4084,6 +4084,7 @@
Use_Clauses : array (1 .. Scope_Stack_Depth) of Node_Id;
Instances : array (1 .. Scope_Stack_Depth) of Entity_Id;
Inner_Scopes : array (1 .. Scope_Stack_Depth) of Entity_Id;
+ List : Elist_Id;
Num_Inner : Int := 0;
N_Instances : Int := 0;
S : Entity_Id;
@@ -4187,7 +4188,7 @@
-- Remove entities in current scopes from visibility, so that
-- instance body is compiled in a clean environment.
- Save_Scope_Stack (Handle_Use => False);
+ List := Save_Scope_Stack (Handle_Use => False);
if Is_Child_Unit (S) then
@@ -4261,7 +4262,7 @@
end loop;
end if;
- Restore_Scope_Stack (Handle_Use => False);
+ Restore_Scope_Stack (List, Handle_Use => False);
if Present (Curr_Scope)
and then
===================================================================
@@ -1340,8 +1340,10 @@
----------------
procedure Do_Analyze is
+ List : Elist_Id;
+
begin
- Save_Scope_Stack;
+ List := Save_Scope_Stack;
Push_Scope (Standard_Standard);
Scope_Suppress := Suppress_Options;
Scope_Stack.Table
@@ -1362,7 +1364,7 @@
-- Then pop entry for Standard, and pop implicit types
Pop_Scope;
- Restore_Scope_Stack;
+ Restore_Scope_Stack (List);
end Do_Analyze;
Already_Analyzed : constant Boolean := Analyzed (Comp_Unit);
===================================================================
@@ -7654,119 +7654,20 @@
-- Restore_Scope_Stack --
-------------------------
- procedure Restore_Scope_Stack (Handle_Use : Boolean := True) is
- E : Entity_Id;
- S : Entity_Id;
- Comp_Unit : Node_Id;
- In_Child : Boolean := False;
- Full_Vis : Boolean := True;
- SS_Last : constant Int := Scope_Stack.Last;
+ procedure Restore_Scope_Stack
+ (List : Elist_Id;
+ Handle_Use : Boolean := True)
+ is
+ SS_Last : constant Int := Scope_Stack.Last;
+ Elmt : Elmt_Id;
begin
-- Restore visibility of previous scope stack, if any
- for J in reverse 0 .. Scope_Stack.Last loop
- exit when Scope_Stack.Table (J).Entity = Standard_Standard
- or else No (Scope_Stack.Table (J).Entity);
-
- S := Scope_Stack.Table (J).Entity;
-
- if not Is_Hidden_Open_Scope (S) then
-
- -- If the parent scope is hidden, its entities are hidden as
- -- well, unless the entity is the instantiation currently
- -- being analyzed.
-
- if not Is_Hidden_Open_Scope (Scope (S))
- or else not Analyzed (Parent (S))
- or else Scope (S) = Standard_Standard
- then
- Set_Is_Immediately_Visible (S, True);
- end if;
-
- E := First_Entity (S);
- while Present (E) loop
- if Is_Child_Unit (E) then
- if not From_With_Type (E) then
- Set_Is_Immediately_Visible (E,
- Is_Visible_Lib_Unit (E) or else In_Open_Scopes (E));
-
- else
- pragma Assert
- (Nkind (Parent (E)) = N_Defining_Program_Unit_Name
- and then
- Nkind (Parent (Parent (E))) =
- N_Package_Specification);
- Set_Is_Immediately_Visible (E,
- Limited_View_Installed (Parent (Parent (E))));
- end if;
- else
- Set_Is_Immediately_Visible (E, True);
- end if;
-
- Next_Entity (E);
-
- if not Full_Vis and then Is_Package_Or_Generic_Package (S) then
-
- -- We are in the visible part of the package scope
-
- exit when E = First_Private_Entity (S);
- end if;
- end loop;
-
- -- The visibility of child units (siblings of current compilation)
- -- must be restored in any case. Their declarations may appear
- -- after the private part of the parent.
-
- if not Full_Vis then
- while Present (E) loop
- if Is_Child_Unit (E) then
- Set_Is_Immediately_Visible (E,
- Is_Visible_Lib_Unit (E) or else In_Open_Scopes (E));
- end if;
-
- Next_Entity (E);
- end loop;
- end if;
- end if;
-
- if Is_Child_Unit (S)
- and not In_Child -- check only for current unit
- then
- In_Child := True;
-
- -- Restore visibility of parents according to whether the child
- -- is private and whether we are in its visible part.
-
- Comp_Unit := Parent (Unit_Declaration_Node (S));
-
- if Nkind (Comp_Unit) = N_Compilation_Unit
- and then Private_Present (Comp_Unit)
- then
- Full_Vis := True;
-
- elsif Is_Package_Or_Generic_Package (S)
- and then (In_Private_Part (S) or else In_Package_Body (S))
- then
- Full_Vis := True;
-
- -- if S is the scope of some instance (which has already been
- -- seen on the stack) it does not affect the visibility of
- -- other scopes.
-
- elsif Is_Hidden_Open_Scope (S) then
- null;
-
- elsif Ekind_In (S, E_Procedure, E_Function)
- and then Has_Completion (S)
- then
- Full_Vis := True;
- else
- Full_Vis := False;
- end if;
- else
- Full_Vis := True;
- end if;
+ Elmt := First_Elmt (List);
+ while Present (Elmt) loop
+ Set_Is_Immediately_Visible (Node (Elmt));
+ Next_Elmt (Elmt);
end loop;
if SS_Last >= Scope_Stack.First
@@ -7781,11 +7682,24 @@
-- Save_Scope_Stack --
----------------------
- procedure Save_Scope_Stack (Handle_Use : Boolean := True) is
+ function Save_Scope_Stack (Handle_Use : Boolean := True) return Elist_Id is
+ Result : constant Elist_Id := New_Elmt_List;
E : Entity_Id;
S : Entity_Id;
SS_Last : constant Int := Scope_Stack.Last;
+ procedure Remove_From_Visibility (E : Entity_Id);
+ -- If E is immediately visible then append it to the result and remove
+ -- it temporarily from visibility
+
+ procedure Remove_From_Visibility (E : Entity_Id) is
+ begin
+ if Is_Immediately_Visible (E) then
+ Append_Elmt (E, Result);
+ Set_Is_Immediately_Visible (E, False);
+ end if;
+ end Remove_From_Visibility;
+
begin
if SS_Last >= Scope_Stack.First
and then Scope_Stack.Table (SS_Last).Entity /= Standard_Standard
@@ -7803,16 +7717,19 @@
or else No (Scope_Stack.Table (J).Entity);
S := Scope_Stack.Table (J).Entity;
- Set_Is_Immediately_Visible (S, False);
+ Remove_From_Visibility (S);
+
E := First_Entity (S);
while Present (E) loop
- Set_Is_Immediately_Visible (E, False);
+ Remove_From_Visibility (E);
Next_Entity (E);
end loop;
end loop;
end if;
+
+ return Result;
end Save_Scope_Stack;
-------------
===================================================================
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
+-- Copyright (C) 1992-2013, 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- --
@@ -148,9 +148,11 @@
-- with-clause on system. N is absent when the function is called to find
-- the visibility of implicit operators.
- procedure Restore_Scope_Stack (Handle_Use : Boolean := True);
- procedure Save_Scope_Stack (Handle_Use : Boolean := True);
- -- These two procedures are called from Semantics, when a unit U1 is to
+ function Save_Scope_Stack (Handle_Use : Boolean := True) return Elist_Id;
+ procedure Restore_Scope_Stack
+ (List : Elist_Id;
+ Handle_Use : Boolean := True);
+ -- These two subprograms are called from Semantics, when a unit U1 is to
-- be compiled in the course of the compilation of another unit U2. This
-- happens whenever Rtsfind is called. U1, the unit retrieved by Rtsfind,
-- must be compiled in its own context, and the current scope stack
@@ -159,7 +161,9 @@
-- Handle_Use indicates whether local use clauses must be removed or
-- installed. In the case of inlining of instance bodies, the visibility
-- handling is done fully in Inline_Instance_Body, and use clauses are
- -- handled there.
+ -- handled there. Save_Scope_Stack returns the list of entities which have
+ -- been temporarily removed from visibility; that list must be passed to
+ -- Restore_Scope_Stack to restore their visibility.
procedure Set_Use (L : List_Id);
-- Find use clauses that are declarative items in a package declaration
This patch modifies the approach taken by the compiler to save/restore the scope stack. The save routine now returns the list of entitites which have been temporarily removed from visibility, and that list is passed to the restore routine to restore their visibility. This approach consumes more memory than the previous approach but avoids latent problems caused by the previous approach. After this patch the following test compiles silently. package P is type Root_Type is abstract tagged limited record N : Natural; end record; type Child_Type is abstract limited new Root_Type with null record; type Interface_Type is limited interface; function F (N : Natural) return Interface_Type is abstract; end P; generic package P.Generic_Child_Package is type T is new P.Child_Type and P.Interface_Type with null record; overriding function F (N : in Natural) return T; end P.Generic_Child_Package; with P.Generic_Child_Package; package Q is package Instance_Package is new P.Generic_Child_Package; X : Instance_Package.T := Instance_Package.F (10); end Q; Command: gcc -c -gnat05 q.ads Tested on x86_64-pc-linux-gnu, committed on trunk 2013-07-08 Javier Miranda <miranda@adacore.com> * sem_ch8.ad[sb] (Save_Scope_Stack): Modified to return the list of entities which have been temporarily removed from immediate visibility. (Restore_Scope_Stack): Modified to receive an additional parameter with the list of entities whose immediate visibility must be restored. * sem.adb (Do_Analyze): Use new version of Save_Scope_Stack/Restore_Scope_Stack * sem_ch12.adb (Inline_Instance_Body): Use new version of Save_Scope_Stack and Restore_Scope_Stack