-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2011, 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;
-- 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
-- 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
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;
-- 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 =>
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 :=
-- 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
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;
- -- Guard against missing or misspelled child units.
+ -- 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
- Set_Name (N, Make_Null (Sloc (N)));
+ 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;
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;
if Nkind (Item) /= N_With_Clause
or else Implicit_With (Item)
or else Limited_Present (Item)
+ or else Error_Posted (Item)
then
null;
-- 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
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,
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);
OSDN Git Service
