procedure Set_Limited_View (Id : E; V : E) is
begin
- pragma Assert (Ekind (Id) = E_Package);
+ pragma Assert (Ekind (Id) = E_Package
+ and then not Is_Generic_Instance (Id));
Set_Node23 (Id, V);
end Set_Limited_View;
return Has_Own_Invariants (Id) or else Has_Inherited_Invariants (Id);
end Has_Invariants;
+ --------------------------
+ -- Has_Limited_View --
+ --------------------------
+
+ function Has_Limited_View (Id : E) return B is
+ begin
+ return Ekind (Id) = E_Package
+ and then not Is_Generic_Instance (Id)
+ and then Present (Limited_View (Id));
+ end Has_Limited_View;
+
--------------------------
-- Has_Non_Limited_View --
--------------------------
-- invariant of its own or inherits at least one class-wide invariant
-- from a parent type or an interface.
+-- Has_Limited_View (synth)
+-- Defined in all entities. True for non-generic package entities that
+-- are non-instances and their Limited_View attribute is present.
+
-- Has_Loop_Entry_Attributes (Flag260)
-- Defined in E_Loop entities. Set when the loop is subject to at least
-- one attribute 'Loop_Entry. The flag also implies that the loop has
-- Has_Null_Abstract_State (synth)
-- Is_Elaboration_Target (synth)
-- Is_Wrapper_Package (synth) (non-generic case only)
+ -- Has_Limited_View (synth) (non-generic case only)
-- Scope_Depth (synth)
-- E_Package_Body
function Has_Foreign_Convention (Id : E) return B;
function Has_Interrupt_Handler (Id : E) return B;
function Has_Invariants (Id : E) return B;
+ function Has_Limited_View (Id : E) return B;
function Has_Non_Limited_View (Id : E) return B;
function Has_Non_Null_Abstract_State (Id : E) return B;
function Has_Non_Null_Visible_Refinement (Id : E) return B;
pragma Inline (Base_Type);
pragma Inline (Float_Rep);
pragma Inline (Has_Foreign_Convention);
+ pragma Inline (Has_Limited_View);
pragma Inline (Has_Non_Limited_View);
pragma Inline (Is_Base_Type);
pragma Inline (Is_Boolean_Type);
-- Determine whether any package in the ancestor chain starting with
-- C_Unit has a limited with clause for package Pack.
- function Is_Visible_Through_Renamings (P : Entity_Id) return Boolean;
- -- Check if some package installed though normal with-clauses has a
- -- renaming declaration of package P. AARM 10.1.2(21/2).
-
-------------------------
-- Check_Body_Required --
-------------------------
return False;
end Has_Limited_With_Clause;
- ----------------------------------
- -- Is_Visible_Through_Renamings --
- ----------------------------------
-
- function Is_Visible_Through_Renamings (P : Entity_Id) return Boolean is
- Kind : constant Node_Kind :=
- Nkind (Unit (Cunit (Current_Sem_Unit)));
- Aux_Unit : Node_Id;
- Item : Node_Id;
- Decl : Entity_Id;
-
- begin
- -- Example of the error detected by this subprogram:
-
- -- package P is
- -- type T is ...
- -- end P;
-
- -- with P;
- -- package Q is
- -- package Ren_P renames P;
- -- end Q;
-
- -- with Q;
- -- package R is ...
-
- -- limited with P; -- ERROR
- -- package R.C is ...
-
- Aux_Unit := Cunit (Current_Sem_Unit);
-
- loop
- Item := First (Context_Items (Aux_Unit));
- while Present (Item) loop
- if Nkind (Item) = N_With_Clause
- and then not Limited_Present (Item)
- and then Nkind (Unit (Library_Unit (Item))) =
- N_Package_Declaration
- then
- Decl :=
- First (Visible_Declarations
- (Specification (Unit (Library_Unit (Item)))));
- while Present (Decl) loop
- if Nkind (Decl) = N_Package_Renaming_Declaration
- and then Entity (Name (Decl)) = P
- then
- -- Generate the error message only if the current unit
- -- is a package declaration; in case of subprogram
- -- bodies and package bodies we just return True to
- -- indicate that the limited view must not be
- -- installed.
-
- if Kind = N_Package_Declaration then
- Error_Msg_N
- ("simultaneous visibility of the limited and " &
- "unlimited views not allowed", N);
- Error_Msg_Sloc := Sloc (Item);
- Error_Msg_NE
- ("\\ unlimited view of & visible through the " &
- "context clause #", N, P);
- Error_Msg_Sloc := Sloc (Decl);
- Error_Msg_NE ("\\ and the renaming #", N, P);
- end if;
-
- return True;
- end if;
-
- Next (Decl);
- end loop;
- end if;
-
- Next (Item);
- end loop;
-
- -- If it is a body not acting as spec, follow pointer to the
- -- corresponding spec, otherwise follow pointer to parent spec.
-
- if Present (Library_Unit (Aux_Unit))
- and then Nkind (Unit (Aux_Unit)) in
- N_Package_Body | N_Subprogram_Body
- then
- if Aux_Unit = Library_Unit (Aux_Unit) then
-
- -- Aux_Unit is a body that acts as a spec. Clause has
- -- already been flagged as illegal.
-
- return False;
-
- else
- Aux_Unit := Library_Unit (Aux_Unit);
- end if;
-
- else
- Aux_Unit := Parent_Spec (Unit (Aux_Unit));
- end if;
-
- exit when No (Aux_Unit);
- end loop;
-
- return False;
- end Is_Visible_Through_Renamings;
-
-- Start of processing for Install_Limited_With_Clause
begin
-- Do not install the limited-view if the full-view is already visible
-- through renaming declarations.
- if Is_Visible_Through_Renamings (P) then
+ if Is_Visible_Through_Renamings (P, N) then
return;
end if;
end if;
end Is_Ancestor_Unit;
+ ----------------------------------
+ -- Is_Visible_Through_Renamings --
+ ----------------------------------
+
+ function Is_Visible_Through_Renamings
+ (P : Entity_Id;
+ Error_Node : Node_Id := Empty) return Boolean
+ is
+ function Is_Limited_Withed_Unit
+ (Lib_Unit : Node_Id;
+ Pkg_Ent : Entity_Id) return Boolean;
+ -- Return True if Pkg_Ent is a limited-withed package of the given
+ -- library unit.
+
+ ----------------------------
+ -- Is_Limited_Withed_Unit --
+ ----------------------------
+
+ function Is_Limited_Withed_Unit
+ (Lib_Unit : Node_Id;
+ Pkg_Ent : Entity_Id) return Boolean
+ is
+ Item : Node_Id := First (Context_Items (Lib_Unit));
+
+ begin
+ while Present (Item) loop
+ if Nkind (Item) = N_With_Clause
+ and then Limited_Present (Item)
+ and then Entity (Name (Item)) = Pkg_Ent
+ then
+ return True;
+ end if;
+
+ Next (Item);
+ end loop;
+
+ return False;
+ end Is_Limited_Withed_Unit;
+
+ -- Local variables
+
+ Kind : constant Node_Kind := Nkind (Unit (Cunit (Current_Sem_Unit)));
+ Aux_Unit : Node_Id;
+ Item : Node_Id;
+ Decl : Entity_Id;
+
+ begin
+ -- Example of the error detected by this subprogram:
+
+ -- package P is
+ -- type T is ...
+ -- end P;
+
+ -- with P;
+ -- package Q is
+ -- package Ren_P renames P;
+ -- end Q;
+
+ -- with Q;
+ -- package R is ...
+
+ -- limited with P; -- ERROR
+ -- package R.C is ...
+
+ Aux_Unit := Cunit (Current_Sem_Unit);
+
+ loop
+ Item := First (Context_Items (Aux_Unit));
+ while Present (Item) loop
+ if Nkind (Item) = N_With_Clause
+ and then not Limited_Present (Item)
+ and then Nkind (Unit (Library_Unit (Item))) =
+ N_Package_Declaration
+ then
+ Decl :=
+ First (Visible_Declarations
+ (Specification (Unit (Library_Unit (Item)))));
+ while Present (Decl) loop
+ if Nkind (Decl) = N_Package_Renaming_Declaration
+ and then Entity (Name (Decl)) = P
+ and then not Is_Limited_Withed_Unit
+ (Lib_Unit => Library_Unit (Item),
+ Pkg_Ent => Entity (Name (Decl)))
+ then
+ -- Generate the error message only if the current unit
+ -- is a package declaration; in case of subprogram
+ -- bodies and package bodies we just return True to
+ -- indicate that the limited view must not be
+ -- installed.
+
+ if Kind = N_Package_Declaration
+ and then Present (Error_Node)
+ then
+ Error_Msg_N
+ ("simultaneous visibility of the limited and " &
+ "unlimited views not allowed", Error_Node);
+ Error_Msg_Sloc := Sloc (Item);
+ Error_Msg_NE
+ ("\\ unlimited view of & visible through the " &
+ "context clause #", Error_Node, P);
+ Error_Msg_Sloc := Sloc (Decl);
+ Error_Msg_NE ("\\ and the renaming #", Error_Node, P);
+ end if;
+
+ return True;
+ end if;
+
+ Next (Decl);
+ end loop;
+ end if;
+
+ Next (Item);
+ end loop;
+
+ -- If it is a body not acting as spec, follow pointer to the
+ -- corresponding spec, otherwise follow pointer to parent spec.
+
+ if Present (Library_Unit (Aux_Unit))
+ and then Nkind (Unit (Aux_Unit)) in
+ N_Package_Body | N_Subprogram_Body
+ then
+ if Aux_Unit = Library_Unit (Aux_Unit) then
+
+ -- Aux_Unit is a body that acts as a spec. Clause has
+ -- already been flagged as illegal.
+
+ return False;
+
+ else
+ Aux_Unit := Library_Unit (Aux_Unit);
+ end if;
+
+ else
+ Aux_Unit := Parent_Spec (Unit (Aux_Unit));
+ end if;
+
+ exit when No (Aux_Unit);
+ end loop;
+
+ return False;
+ end Is_Visible_Through_Renamings;
+
-----------------------
-- Load_Needed_Body --
-----------------------
-- view, determine whether the package where T resides is imported through
-- a regular with clause in the current package body.
+ function Is_Visible_Through_Renamings
+ (P : Entity_Id;
+ Error_Node : Node_Id := Empty) return Boolean;
+ -- Check if some package installed though normal with-clauses has a
+ -- renaming declaration of package P. AARM 10.1.2(21/2). Errors are
+ -- reported on Error_Node (if present); otherwise no error is reported.
+
+ procedure Load_Needed_Body
+ (N : Node_Id;
+ OK : out Boolean;
+ Do_Analyze : Boolean := True);
+ -- Load and analyze the body of a context unit that is generic, or that
+ -- contains generic units or inlined units. The body becomes part of the
+ -- semantic dependency set of the unit that needs it. The returned result
+ -- in OK is True if the load is successful, and False if the requested file
+ -- cannot be found. If the flag Do_Analyze is false, the unit is loaded and
+ -- parsed only. This allows a selective analysis in some inlining cases
+ -- where a full analysis would lead so circularities in the back-end.
+
procedure Remove_Context (N : Node_Id);
-- Removes the entities from the context clause of the given compilation
-- unit from the visibility chains. This is done on exit from a unit as
-- rule imposes extra steps in order to install/remove the private_with
-- clauses of an enclosing unit.
- procedure Load_Needed_Body
- (N : Node_Id;
- OK : out Boolean;
- Do_Analyze : Boolean := True);
- -- Load and analyze the body of a context unit that is generic, or that
- -- contains generic units or inlined units. The body becomes part of the
- -- semantic dependency set of the unit that needs it. The returned result
- -- in OK is True if the load is successful, and False if the requested file
- -- cannot be found. If the flag Do_Analyze is false, the unit is loaded and
- -- parsed only. This allows a selective analysis in some inlining cases
- -- where a full analysis would lead so circularities in the back-end.
-
end Sem_Ch10;
if Nkind (S) /= N_Subtype_Indication then
Analyze (S);
- if Present (Entity (S))
+ if Nkind (S) in N_Has_Entity
+ and then Present (Entity (S))
and then Ekind (Root_Type (Entity (S))) = E_Incomplete_Type
then
Set_Directly_Designated_Type (T, Entity (S));
with Sem_Ch3; use Sem_Ch3;
with Sem_Ch4; use Sem_Ch4;
with Sem_Ch6; use Sem_Ch6;
+with Sem_Ch10; use Sem_Ch10;
with Sem_Ch12; use Sem_Ch12;
with Sem_Ch13; use Sem_Ch13;
with Sem_Dim; use Sem_Dim;
Set_Ekind (New_P, E_Package);
Set_Etype (New_P, Standard_Void_Type);
+ elsif Present (Renamed_Entity (Old_P))
+ and then (From_Limited_With (Renamed_Entity (Old_P))
+ or else Has_Limited_View (Renamed_Entity (Old_P)))
+ and then not
+ Unit_Is_Visible (Cunit (Get_Source_Unit (Renamed_Entity (Old_P))))
+ then
+ Error_Msg_NE
+ ("renaming of limited view of package & not usable in this context"
+ & " (RM 8.5.3(3.1/2))", Name (N), Renamed_Entity (Old_P));
+
+ -- Set basic attributes to minimize cascaded errors
+
+ Set_Ekind (New_P, E_Package);
+ Set_Etype (New_P, Standard_Void_Type);
+
-- Here for OK package renaming
else
then
P_Name := Renamed_Object (P_Name);
+ if From_Limited_With (P_Name)
+ and then not Unit_Is_Visible (Cunit (Get_Source_Unit (P_Name)))
+ then
+ Error_Msg_NE
+ ("renaming of limited view of package & not usable in this"
+ & " context (RM 8.5.3(3.1/2))", Prefix (N), P_Name);
+
+ elsif Has_Limited_View (P_Name)
+ and then not Unit_Is_Visible (Cunit (Get_Source_Unit (P_Name)))
+ and then not Is_Visible_Through_Renamings (P_Name)
+ then
+ Error_Msg_NE
+ ("renaming of limited view of package & not usable in this"
+ & " context (RM 8.5.3(3.1/2))", Prefix (N), P_Name);
+ end if;
+
-- Rewrite node with entity field pointing to renamed object
Rewrite (Prefix (N), New_Copy (Prefix (N)));
Candidate := Get_Full_View (Non_Limited_View (Id));
Is_New_Candidate := True;
+ -- Handle special case where the prefix is a renaming of a shadow
+ -- package which is visible. Required to avoid reporting spurious
+ -- errors.
+
+ elsif Ekind (P_Name) = E_Package
+ and then From_Limited_With (P_Name)
+ and then not From_Limited_With (Id)
+ and then Sloc (Scope (Id)) = Sloc (P_Name)
+ and then Unit_Is_Visible (Cunit (Get_Source_Unit (P_Name)))
+ then
+ Candidate := Get_Full_View (Id);
+ Is_New_Candidate := True;
+
-- An unusual case arises with a fully qualified name for an
-- entity local to a generic child unit package, within an
-- instantiation of that package. The name of the unit now
projects / gcc.git / commitdiff