-- included in a standalone library.
procedure Check_Private_Child_Unit (N : Node_Id);
- -- If a with_clause mentions a private child unit, the compilation
- -- unit must be a member of the same family, as described in 10.1.2.
+ -- If a with_clause mentions a private child unit, the compilation unit
+ -- must be a member of the same family, as described in 10.1.2.
procedure Check_Stub_Level (N : Node_Id);
-- Verify that a stub is declared immediately within a compilation unit,
-- example through a limited_with clause in a parent unit.
procedure Install_Context_Clauses (N : Node_Id);
- -- Subsidiary to Install_Context and Install_Parents. Process only with_
- -- and use_clauses for current unit and its library unit if any.
+ -- Subsidiary to Install_Context and Install_Parents. Process all with
+ -- and use clauses for current unit and its library unit if any.
procedure Install_Limited_Context_Clauses (N : Node_Id);
-- Subsidiary to Install_Context. Process only limited with_clauses for
-- that all parents are removed in the nested case.
procedure Remove_Unit_From_Visibility (Unit_Name : Entity_Id);
- -- Reset all visibility flags on unit after compiling it, either as a
- -- main unit or as a unit in the context.
+ -- Reset all visibility flags on unit after compiling it, either as a main
+ -- unit or as a unit in the context.
procedure Unchain (E : Entity_Id);
-- Remove single entity from visibility list
procedure Analyze_Proper_Body (N : Node_Id; Nam : Entity_Id);
-- Common processing for all stubs (subprograms, tasks, packages, and
- -- protected cases). N is the stub to be analyzed. Once the subunit
- -- name is established, load and analyze. Nam is the non-overloadable
- -- entity for which the proper body provides a completion. Subprogram
- -- stubs are handled differently because they can be declarations.
+ -- protected cases). N is the stub to be analyzed. Once the subunit name
+ -- is established, load and analyze. Nam is the non-overloadable entity
+ -- for which the proper body provides a completion. Subprogram stubs are
+ -- handled differently because they can be declarations.
procedure sm;
-- A dummy procedure, for debugging use, called just before analyzing the
Clause : Node_Id;
Used : in out Boolean;
Used_Type_Or_Elab : in out Boolean);
- -- Examine the context clauses of a package body, trying to match
- -- the name entity of Clause with any list element. If the match
- -- occurs on a use package clause, set Used to True, for a use
- -- type clause, pragma Elaborate or pragma Elaborate_All, set
- -- Used_Type_Or_Elab to True.
+ -- Examine the context clauses of a package body, trying to match the
+ -- name entity of Clause with any list element. If the match occurs
+ -- on a use package clause set Used to True, for a use type clause or
+ -- pragma Elaborate[_All], set Used_Type_Or_Elab to True.
procedure Process_Spec_Clauses
(Context_List : List_Id;
-- compilation unit actions list, and analyze them.
declare
- Loc : constant Source_Ptr := Sloc (N);
- L : constant List_Id :=
- Freeze_Entity (Cunit_Entity (Current_Sem_Unit), Loc);
+ L : constant List_Id :=
+ Freeze_Entity (Cunit_Entity (Current_Sem_Unit), N);
begin
while Is_Non_Empty_List (L) loop
Insert_Library_Level_Action (Remove_Head (L));
P := Parent_Spec (Unit (N));
loop
if Unit (P) = Lib_U then
- Error_Msg_N ("limited with_clause of immediate "
- & "ancestor not allowed", Item);
+ Error_Msg_N ("limited with_clause cannot "
+ & "name ancestor", Item);
exit;
end if;
-- Otherwise we must load the subunit and link to it
else
+ -- Make sure that, if the subunit is preprocessed and -gnateG is
+ -- specified, the preprocessed file will be written.
+
+ Lib.Analysing_Subunit_Of_Main := True;
Unum :=
Load_Unit
(Load_Name => Subunit_Name,
Required => False,
Subunit => True,
Error_Node => N);
+ Lib.Analysing_Subunit_Of_Main := False;
-- Give message if we did not get the unit Emit warning even if
-- missing subunit is not within main unit, to simplify debugging.
end if;
end if;
- -- The remaining case is when the subunit is not already loaded and
- -- we are not generating code. In this case we are just performing
- -- semantic analysis on the parent, and we are not interested in
- -- the subunit. For subprograms, analyze the stub as a body. For
- -- other entities the stub has already been marked as completed.
+ -- The remaining case is when the subunit is not already loaded and we
+ -- are not generating code. In this case we are just performing semantic
+ -- analysis on the parent, and we are not interested in the subunit. For
+ -- subprograms, analyze the stub as a body. For other entities the stub
+ -- has already been marked as completed.
else
Optional_Subunit;
else
Set_Scope (Defining_Entity (N), Current_Scope);
Generate_Reference (Nam, Defining_Identifier (N), 'b');
- Set_Has_Completion (Etype (Nam));
+
+ -- Check for duplicate stub, if so give message and terminate
+
+ if Has_Completion (Etype (Nam)) then
+ Error_Msg_N ("duplicate stub for task", N);
+ return;
+ else
+ Set_Has_Completion (Etype (Nam));
+ end if;
+
Analyze_Proper_Body (N, Etype (Nam));
-- Set elaboration flag to indicate that entity is callable. This
Make_Assignment_Statement (Loc,
Name =>
Make_Identifier (Loc,
- New_External_Name (Chars (Etype (Nam)), 'E')),
+ Chars => New_External_Name (Chars (Etype (Nam)), 'E')),
Expression => New_Reference_To (Standard_True, Loc)));
end if;
end if;
"and version-dependent?", Name (N));
end if;
- elsif U_Kind = Ada_05_Unit
- and then Ada_Version < Ada_05
+ elsif U_Kind = Ada_2005_Unit
+ and then Ada_Version < Ada_2005
and then Warn_On_Ada_2005_Compatibility
then
Error_Msg_N ("& is an Ada 2005 unit?", Name (N));
+
+ elsif U_Kind = Ada_2012_Unit
+ and then Ada_Version < Ada_2012
+ and then Warn_On_Ada_2012_Compatibility
+ then
+ Error_Msg_N ("& is an Ada 2012 unit?", Name (N));
end if;
end;
end if;
elsif Unit_Kind = N_Package_Instantiation
and then Nkind (U) = N_Package_Instantiation
+ and then Present (Instance_Spec (U))
then
-- If the instance has not been rewritten as a package declaration,
-- then it appeared already in a previous with clause. Retrieve
Par_Name := Scope (E_Name);
while Nkind (Pref) = N_Selected_Component loop
Change_Selected_Component_To_Expanded_Name (Pref);
+
+ if Present (Entity (Selector_Name (Pref)))
+ and then
+ Present (Renamed_Entity (Entity (Selector_Name (Pref))))
+ and then Entity (Selector_Name (Pref)) /= Par_Name
+ then
+ -- The prefix is a child unit that denotes a renaming declaration.
+ -- Replace the prefix directly with the renamed unit, because the
+ -- rest of the prefix is irrelevant to the visibility of the real
+ -- unit.
+
+ Rewrite (Pref, New_Occurrence_Of (Par_Name, Sloc (Pref)));
+ exit;
+ end if;
+
Set_Entity_With_Style_Check (Pref, Par_Name);
Generate_Reference (Par_Name, Pref);
while Present (Item) loop
if Nkind (Item) = N_With_Clause
and then Limited_Present (Item)
+ and then not Error_Posted (Item)
then
if Nkind (Name (Item)) = N_Selected_Component then
Expand_Limited_With_Clause
-- looking for incomplete subtype declarations of incomplete types
-- visible through a limited with clause.
- if Ada_Version >= Ada_05
+ if Ada_Version >= Ada_2005
and then Analyzed (N)
and then Nkind (Unit (N)) = N_Package_Declaration
then
(Is_Immediately_Visible (P)
or else (Is_Child_Package and then Is_Visible_Child_Unit (P)))
then
- return;
+
+ -- The presence of both the limited and the analyzed nonlimited view
+ -- may also be an error, such as an illegal context for a limited
+ -- with_clause. In that case, do not process the context item at all.
+
+ if Error_Posted (N) then
+ return;
+ end if;
+
+ if Nkind (Unit (Cunit (Current_Sem_Unit))) = N_Package_Body then
+ declare
+ Item : Node_Id;
+ begin
+ Item := First (Context_Items (Cunit (Current_Sem_Unit)));
+ while Present (Item) loop
+ if Nkind (Item) = N_With_Clause
+ and then Comes_From_Source (Item)
+ and then Entity (Name (Item)) = P
+ then
+ return;
+ end if;
+
+ Next (Item);
+ end loop;
+ end;
+
+ -- If this is a child body, assume that the nonlimited with_clause
+ -- appears in an ancestor. Could be refined ???
+
+ if Is_Child_Unit
+ (Defining_Entity
+ (Unit (Library_Unit (Cunit (Current_Sem_Unit)))))
+ then
+ return;
+ end if;
+
+ else
+
+ -- If in package declaration, nonlimited view brought in from
+ -- parent unit or some error condition.
+
+ return;
+ end if;
end if;
if Debug_Flag_I then
if Is_Child_Unit (Uname)
and then Is_Visible_Child_Unit (Uname)
- and then Ada_Version >= Ada_05
+ and then Ada_Version >= Ada_2005
then
declare
Decl1 : constant Node_Id := Unit_Declaration_Node (P);
-- If the unit is not generic, but contains a generic unit, it is loaded on
-- demand, at the point of instantiation (see ch12).
- procedure Load_Needed_Body (N : Node_Id; OK : out Boolean) is
+ procedure Load_Needed_Body
+ (N : Node_Id;
+ OK : out Boolean;
+ Do_Analyze : Boolean := True)
+ is
Body_Name : Unit_Name_Type;
Unum : Unit_Number_Type;
Write_Eol;
end if;
- Semantics (Cunit (Unum));
+ if Do_Analyze then
+ Semantics (Cunit (Unum));
+ end if;
end if;
OK := True;
OSDN Git Service
