-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2010, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2012, 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- --
with Rident; use Rident;
with Rtsfind; use Rtsfind;
with Sem; use Sem;
+with Sem_Aux; use Sem_Aux;
with Sem_Ch3; use Sem_Ch3;
with Sem_Ch6; use Sem_Ch6;
with Sem_Ch7; use Sem_Ch7;
-- 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
-- Limited_With_Clauses --
--------------------------
- -- Limited_With clauses are the mechanism chosen for Ada05 to support
+ -- Limited_With clauses are the mechanism chosen for Ada 2005 to support
-- mutually recursive types declared in different units. A limited_with
-- clause that names package P in the context of unit U makes the types
-- declared in the visible part of P available within U, but with 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;
-- generated with clauses or limited with clauses. Note that
-- we examine with clauses having pragmas Elaborate or
-- Elaborate_All applied to them due to cases such as:
- --
-- with Pack;
-- with Pack;
-- up not analyzed, it means that the parent did not contain a stub for
-- it, or that there errors were detected in some ancestor.
- if Nkind (Unit_Node) = N_Subunit
- and then not Analyzed (Lib_Unit)
- then
+ if Nkind (Unit_Node) = N_Subunit and then not Analyzed (Lib_Unit) then
Semantics (Lib_Unit);
if not Analyzed (Proper_Body (Unit_Node)) then
return;
else
+ -- Analyze the package spec
+
Semantics (Lib_Unit);
+
+ -- Check for unused with's
+
Check_Unused_Withs (Get_Cunit_Unit_Number (Lib_Unit));
-- Verify that the library unit is a package declaration
-- If the unit is a subprogram body, then we similarly need to analyze
-- its spec. However, things are a little simpler in this case, because
- -- here, this analysis is done only for error checking and consistency
- -- purposes, so there's nothing else to be done.
+ -- here, this analysis is done mostly for error checking and consistency
+ -- purposes (but not only, e.g. there could be a contract on the spec),
+ -- so there's nothing else to be done.
elsif Nkind (Unit_Node) = N_Subprogram_Body then
if Acts_As_Spec (N) then
begin
Set_Comes_From_Source_Default (False);
+
+ -- Checks for redundant USE TYPE clauses have a special
+ -- exception for the synthetic spec we create here. This
+ -- special case relies on the two compilation units
+ -- sharing the same context clause.
+
+ -- Note: We used to do a shallow copy (New_Copy_List),
+ -- which defeated those checks and also created malformed
+ -- trees (subtype mark shared by two distinct
+ -- N_Use_Type_Clause nodes) which crashed the compiler.
+
Lib_Unit :=
Make_Compilation_Unit (Loc,
- Context_Items => New_Copy_List (Context_Items (N)),
+ Context_Items => Context_Items (N),
Unit =>
Make_Subprogram_Declaration (Sloc (N),
Specification =>
declare
Save_Style_Check : constant Boolean := Style_Check;
- Save_C_Restrict : constant Save_Cunit_Boolean_Restrictions :=
- Cunit_Boolean_Restrictions_Save;
begin
if not GNAT_Mode then
Semantics (Parent_Spec (Unit_Node));
Version_Update (N, Parent_Spec (Unit_Node));
+
+ -- Restore style check settings
+
Style_Check := Save_Style_Check;
- Cunit_Boolean_Restrictions_Restore (Save_C_Restrict);
end;
end if;
Un : Unit_Number_Type;
Save_Style_Check : constant Boolean := Style_Check;
- Save_C_Restrict : constant Save_Cunit_Boolean_Restrictions :=
- Cunit_Boolean_Restrictions_Save;
begin
Item := First (Context_Items (N));
Next (Item);
end loop;
+ -- Restore style checks settings
+
Style_Check := Save_Style_Check;
- Cunit_Boolean_Restrictions_Restore (Save_C_Restrict);
end;
end if;
-- 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));
-- subunit, and that the current unit is one of its parents which was
-- being analyzed to provide the needed context for the analysis of the
-- subunit. In this case we analyze the subunit and continue with the
- -- parent, without looking a subsequent subunits.
+ -- parent, without looking at subsequent subunits.
if Is_Loaded (Subunit_Name) then
if Present (Library_Unit (N)) then
Set_Corresponding_Stub (Unit (Library_Unit (N)), N);
+
+ -- If the subunit has severe errors, the spec of the enclosing
+ -- body may not be available, in which case do not try analysis.
+
+ if Serious_Errors_Detected > 0
+ and then No (Library_Unit (Library_Unit (N)))
+ then
+ return;
+ end if;
+
Analyze_Subunit (Library_Unit (N));
-- Otherwise we must load the subunit and link to it
Enclosing_Child : Entity_Id := Empty;
Svg : constant Suppress_Array := Scope_Suppress;
+ Save_Cunit_Restrictions : constant Save_Cunit_Boolean_Restrictions :=
+ Cunit_Boolean_Restrictions_Save;
+ -- Save non-partition wide restrictions before processing the subunit.
+ -- All subunits are analyzed with config restrictions reset and we need
+ -- to restore these saved values at the end.
+
procedure Analyze_Subunit_Context;
-- Capture names in use clauses of the subunit. This must be done before
-- re-installing parent declarations, because items in the context must
null;
else
+ -- If a subunits has serious syntax errors, the context
+ -- may not have been loaded. Add a harmless unit name to
+ -- attempt processing.
+
+ if Serious_Errors_Detected > 0
+ and then No (Entity (Name (Item)))
+ then
+ Set_Entity (Name (Item), Standard_Standard);
+ end if;
+
Unit_Name := Entity (Name (Item));
while Is_Child_Unit (Unit_Name) loop
Set_Is_Visible_Child_Unit (Unit_Name);
-- Start of processing for Analyze_Subunit
begin
+ -- For subunit in main extended unit, we reset the configuration values
+ -- for the non-partition-wide restrictions. For other units reset them.
+
+ if In_Extended_Main_Source_Unit (N) then
+ Restore_Config_Cunit_Boolean_Restrictions;
+ else
+ Reset_Cunit_Boolean_Restrictions;
+ end if;
+
if Style_Check then
declare
Nam : Node_Id := Name (Unit (N));
end loop;
end;
end if;
+
+ -- Deal with restore of restrictions
+
+ Cunit_Boolean_Restrictions_Restore (Save_Cunit_Restrictions);
end Analyze_Subunit;
----------------------------
-- expansion is active, because the context may be generic and the
-- flag not defined yet.
- if Expander_Active then
+ if Full_Expander_Active then
Insert_After (N,
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;
Intunit : Boolean;
-- Set True if the unit currently being compiled is an internal unit
+ Restriction_Violation : Boolean := False;
+ -- Set True if a with violates a restriction, no point in giving any
+ -- warnings if we have this definite error.
+
Save_Style_Check : constant Boolean := Opt.Style_Check;
- Save_C_Restrict : Save_Cunit_Boolean_Restrictions;
begin
U := Unit (Library_Unit (N));
Is_Predefined_File_Name (F, Renamings_Included => False)
then
Check_Restriction (No_Obsolescent_Features, N);
+ Restriction_Violation := True;
end if;
end;
end if;
- -- Save current restriction set, does not apply to with'ed unit
+ -- Check No_Implementation_Units violation
- Save_C_Restrict := Cunit_Boolean_Restrictions_Save;
+ if Restriction_Check_Required (No_Implementation_Units) then
+ if Not_Impl_Defined_Unit (Get_Source_Unit (U)) then
+ null;
+ else
+ Check_Restriction (No_Implementation_Units, Nam);
+ Restriction_Violation := True;
+ end if;
+ end if;
-- Several actions are skipped for dummy packages (those supplied for
-- with's where no matching file could be found). Such packages are
end if;
-- Check for inappropriate with of internal implementation unit if we
- -- are not compiling an internal unit. We do not issue this message
- -- for implicit with's generated by the compiler itself.
+ -- are not compiling an internal unit and also check for withing unit
+ -- in wrong version of Ada. Do not issue these messages for implicit
+ -- with's generated by the compiler itself.
if Implementation_Unit_Warnings
and then not Intunit
and then not Implicit_With (N)
+ and then not Restriction_Violation
then
declare
U_Kind : constant Kind_Of_Unit :=
"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
-- Child unit in a with clause
Change_Selected_Component_To_Expanded_Name (Name (N));
+
+ -- If this is a child unit without a spec, and it has been analyzed
+ -- already, a declaration has been created for it. The with_clause
+ -- must reflect the actual body, and not the generated declaration,
+ -- to prevent spurious binding errors involving an out-of-date spec.
+ -- Note that this can only happen if the unit includes more than one
+ -- with_clause for the child unit (e.g. in separate subunits).
+
+ if Unit_Kind = N_Subprogram_Declaration
+ and then Analyzed (Library_Unit (N))
+ and then not Comes_From_Source (Library_Unit (N))
+ then
+ Set_Library_Unit (N,
+ Cunit (Get_Source_Unit (Corresponding_Body (U))));
+ end if;
end if;
- -- Restore style checks and restrictions
+ -- Restore style checks
Style_Check := Save_Style_Check;
- Cunit_Boolean_Restrictions_Restore (Save_C_Restrict);
-- Record the reference, but do NOT set the unit as referenced, we want
-- to consider the unit as unreferenced if this is the only reference
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);
if Par_Name /= Standard_Standard then
Par_Name := Scope (Par_Name);
end if;
+
+ -- Abandon processing in case of previous errors
+
+ if No (Par_Name) then
+ pragma Assert (Serious_Errors_Detected /= 0);
+ return;
+ end if;
end loop;
if Present (Entity (Pref))
Par_Name := Entity (Pref);
end if;
- Set_Entity_With_Style_Check (Pref, Par_Name);
- Generate_Reference (Par_Name, Pref);
+ -- Guard against missing or misspelled child units
+
+ if Present (Par_Name) then
+ Set_Entity_With_Style_Check (Pref, Par_Name);
+ Generate_Reference (Par_Name, Pref);
+
+ else
+ pragma Assert (Serious_Errors_Detected /= 0);
+
+ -- Mark the node to indicate that a related error has been posted.
+ -- This defends further compilation passes against improper use of
+ -- the invalid WITH clause node.
+
+ Set_Error_Posted (N);
+ Set_Name (N, Error);
+ return;
+ end if;
end if;
-- If the withed unit is System, and a system extension pragma is
function Build_Unit_Name (Nam : Node_Id) return Node_Id is
Ent : Entity_Id;
- Renaming : Entity_Id;
Result : Node_Id;
begin
if Nkind (Nam) = N_Identifier then
-
- -- If the parent unit P in the name of the with_clause for P.Q is
- -- a renaming of package R, then the entity of the parent is set
- -- to R, but the identifier retains Chars (P) to be consistent
- -- with the source (see details in lib-load). However the implicit
- -- with_clause for the parent must make the entity for P visible,
- -- because P.Q may be used as a prefix within the current unit.
- -- The entity for P is the current_entity with that name, because
- -- the package renaming declaration for it has just been analyzed.
- -- Note that this case can only happen if P.Q has already appeared
- -- in a previous with_clause in a related unit, such as the
- -- library body of the current unit.
-
- if Chars (Nam) /= Chars (Entity (Nam)) then
- Renaming := Current_Entity (Nam);
- pragma Assert (Renamed_Entity (Renaming) = Entity (Nam));
- return New_Occurrence_Of (Renaming, Loc);
-
- else
- return New_Occurrence_Of (Entity (Nam), Loc);
- end if;
+ return New_Occurrence_Of (Entity (Nam), Loc);
else
Ent := Entity (Nam);
procedure License_Error is
begin
Error_Msg_N
- ("?license of with'ed unit & may be inconsistent",
+ ("?license of withed unit & may be inconsistent",
Name (Item));
end License_Error;
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
if Nkind (Item) /= N_With_Clause
or else Implicit_With (Item)
or else Limited_Present (Item)
+ or else Error_Posted (Item)
then
null;
(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
-- Set entity of parent identifiers if the unit is a child
-- unit. This ensures that the tree is properly formed from
- -- semantic point of view (e.g. for ASIS queries).
+ -- semantic point of view (e.g. for ASIS queries). The unit
+ -- entities are not fully analyzed, so we need to follow unit
+ -- links in the tree.
Set_Entity (Nam, Ent);
Nam := Prefix (Nam);
- Ent := Scope (Ent);
+ Ent :=
+ Defining_Entity
+ (Unit (Parent_Spec (Unit_Declaration_Node (Ent))));
-- Set entity of last ancestor
("instantiation depends on itself", Name (With_Clause));
elsif not Is_Visible_Child_Unit (Uname) then
+
+ -- Abandon processing in case of previous errors
+
+ if No (Scope (Uname)) then
+ pragma Assert (Serious_Errors_Detected /= 0);
+ return;
+ end if;
+
Set_Is_Visible_Child_Unit (Uname);
-- If the child unit appears in the context of its parent, it is
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;
procedure Decorate_Tagged_Type
(Loc : Source_Ptr;
T : Entity_Id;
- Scop : Entity_Id);
- -- Set basic attributes of tagged type T, including its class_wide type.
- -- The parameters Loc, Scope are used to decorate the class_wide type.
+ Scop : Entity_Id;
+ Mark : Boolean := False);
+ -- Set basic attributes of tagged type T, including its class-wide type.
+ -- The parameters Loc, Scope are used to decorate the class-wide type.
+ -- Use flag Mark to label the class-wide type as Materialize_Entity.
procedure Build_Chain (Scope : Entity_Id; First_Decl : Node_Id);
-- Construct list of shadow entities and attach it to entity of
if not Analyzed_Unit then
if Is_Tagged then
- Decorate_Tagged_Type (Sloc (Decl), Comp_Typ, Scope);
+ Decorate_Tagged_Type (Sloc (Decl), Comp_Typ, Scope, True);
else
Decorate_Incomplete_Type (Comp_Typ, Scope);
end if;
end if;
Set_Non_Limited_View (Lim_Typ, Comp_Typ);
+ Set_Private_Dependents (Lim_Typ, New_Elmt_List);
elsif Nkind_In (Decl, N_Private_Type_Declaration,
N_Incomplete_Type_Declaration,
if not Analyzed_Unit then
if Is_Tagged then
- Decorate_Tagged_Type (Sloc (Decl), Comp_Typ, Scope);
+ Decorate_Tagged_Type (Sloc (Decl), Comp_Typ, Scope, True);
else
Decorate_Incomplete_Type (Comp_Typ, Scope);
end if;
Set_Non_Limited_View (Lim_Typ, Comp_Typ);
+ -- Initialize Private_Depedents, so the field has the proper
+ -- type, even though the list will remain empty.
+
+ Set_Private_Dependents (Lim_Typ, New_Elmt_List);
+
elsif Nkind (Decl) = N_Private_Extension_Declaration then
Comp_Typ := Defining_Identifier (Decl);
if not Analyzed_Unit then
- Decorate_Tagged_Type (Sloc (Decl), Comp_Typ, Scope);
+ Decorate_Tagged_Type (Sloc (Decl), Comp_Typ, Scope, True);
end if;
-- Create shadow entity for type
procedure Decorate_Tagged_Type
(Loc : Source_Ptr;
T : Entity_Id;
- Scop : Entity_Id)
+ Scop : Entity_Id;
+ Mark : Boolean := False)
is
CW : Entity_Id;
-- and the full-view.
if No (Class_Wide_Type (T)) then
- CW := Make_Temporary (Loc, 'S');
+ CW := New_External_Entity (E_Void, Scope (T), Loc, T, 'C', 0, 'T');
-- Set parent to be the same as the parent of the tagged type.
-- We need a parent field set, and it is supposed to point to
Set_Class_Wide_Type (CW, CW);
Set_Equivalent_Type (CW, Empty);
Set_From_With_Type (CW, From_With_Type (T));
+ Set_Materialize_Entity (CW, Mark);
-- Link type to its class-wide type
OSDN Git Service
