-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2004 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2005 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 Osint.C; use Osint.C;
with Output; use Output;
with Par;
+with Restrict; use Restrict;
with Scn; use Scn;
with Sinfo; use Sinfo;
with Sinput; use Sinput;
---------------
function Load_Unit
- (Load_Name : Unit_Name_Type;
- Required : Boolean;
- Error_Node : Node_Id;
- Subunit : Boolean;
- Corr_Body : Unit_Number_Type := No_Unit;
- Renamings : Boolean := False) return Unit_Number_Type
+ (Load_Name : Unit_Name_Type;
+ Required : Boolean;
+ Error_Node : Node_Id;
+ Subunit : Boolean;
+ Corr_Body : Unit_Number_Type := No_Unit;
+ Renamings : Boolean := False;
+ From_Limited_With : Boolean := False) return Unit_Number_Type
is
Calling_Unit : Unit_Number_Type;
Uname_Actual : Unit_Name_Type;
or else Acts_As_Spec (Units.Table (Unum).Cunit))
and then (Nkind (Error_Node) /= N_With_Clause
or else not Limited_Present (Error_Node))
-
+ and then not From_Limited_With
then
if Debug_Flag_L then
Write_Str (" circular dependency encountered");
Multiple_Unit_Index := Get_Unit_Index (Uname_Actual);
Units.Table (Unum).Munit_Index := Multiple_Unit_Index;
Initialize_Scanner (Unum, Source_Index (Unum));
- Discard_List (Par (Configuration_Pragmas => False));
+ Discard_List (Par (Configuration_Pragmas => False,
+ From_Limited_With => From_Limited_With));
Multiple_Unit_Index := Save_Index;
Set_Loading (Unum, False);
end;
-- Generate message if unit required
if Required and then Present (Error_Node) then
-
if Is_Predefined_File_Name (Fname) then
+
+ -- This is a predefined library unit which is not present
+ -- in the run time. If a predefined unit is not available
+ -- it may very likely be the case that there is also pragma
+ -- Restriction forbidding its usage. This is typically the
+ -- case when building a configurable run time, where the
+ -- usage of certain run-time units units is restricted by
+ -- means of both the corresponding pragma Restriction (such
+ -- as No_Calendar), and by not including the unit. Hence,
+ -- we check whether this predefined unit is forbidden, so
+ -- that the message about the restriction violation is
+ -- generated, if needed.
+
+ Check_Restricted_Unit (Load_Name, Error_Node);
+
Error_Msg_Name_1 := Uname_Actual;
Error_Msg
("% is not a predefined library unit", Load_Msg_Sloc);
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2004, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2005 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- --
-- and then closed on return.
function Load_Unit
- (Load_Name : Unit_Name_Type;
- Required : Boolean;
- Error_Node : Node_Id;
- Subunit : Boolean;
- Corr_Body : Unit_Number_Type := No_Unit;
- Renamings : Boolean := False) return Unit_Number_Type;
+ (Load_Name : Unit_Name_Type;
+ Required : Boolean;
+ Error_Node : Node_Id;
+ Subunit : Boolean;
+ Corr_Body : Unit_Number_Type := No_Unit;
+ Renamings : Boolean := False;
+ From_Limited_With : Boolean := False) return Unit_Number_Type;
-- This function loads and parses the unit specified by Load_Name (or
-- returns the unit number for the previously constructed units table
-- entry if this is not the first call for this unit). Required indicates
-- described in the documentation of this unit. If this parameter is
-- set to True, then Load_Name may not be the real unit name and it
-- is necessary to load parents to find the real name.
+ --
+ -- From_Limited_With is True if we are loading a unit X found in a
+ -- limited-with clause, or some unit in the context of X. It is used to
+ -- avoid the check on circular dependency (Ada 2005, AI-50217)
function Create_Dummy_Package_Unit
(With_Node : Node_Id;
---------------------
procedure Analyze_Context (N : Node_Id) is
+ Ukind : constant Node_Kind := Nkind (Unit (N));
Item : Node_Id;
begin
if Nkind (Item) = N_With_Clause
and then Limited_Present (Item)
then
-
- if Nkind (Unit (N)) /= N_Package_Declaration then
- Error_Msg_N ("limited with_clause only allowed in"
- & " package specification", Item);
+ -- Check the compilation unit containing the limited-with
+ -- clause
+
+ if Ukind /= N_Package_Declaration
+ and then Ukind /= N_Subprogram_Declaration
+ and then Ukind /= N_Subprogram_Renaming_Declaration
+ and then Ukind /= N_Generic_Package_Declaration
+ and then Ukind /= N_Generic_Package_Renaming_Declaration
+ and then Ukind /= N_Generic_Subprogram_Declaration
+ and then Ukind /= N_Generic_Procedure_Renaming_Declaration
+ and then Ukind /= N_Package_Instantiation
+ and then Ukind /= N_Package_Renaming_Declaration
+ and then Ukind /= N_Procedure_Instantiation
+ then
+ Error_Msg_N
+ ("limited with_clause not allowed here", Item);
end if;
-- Skip analyzing with clause if no unit, see above
while Present (Item) loop
if Nkind (Item) = N_With_Clause then
- Unit_Name := Entity (Name (Item));
+ -- Protect the frontend against previous errors
+ -- in context clauses
- while Is_Child_Unit (Unit_Name) loop
- Set_Is_Visible_Child_Unit (Unit_Name);
- Unit_Name := Scope (Unit_Name);
- end loop;
+ if Nkind (Name (Item)) /= N_Selected_Component then
+ Unit_Name := Entity (Name (Item));
- if not Is_Immediately_Visible (Unit_Name) then
- Set_Is_Immediately_Visible (Unit_Name);
- Set_Context_Installed (Item);
+ while Is_Child_Unit (Unit_Name) loop
+ Set_Is_Visible_Child_Unit (Unit_Name);
+ Unit_Name := Scope (Unit_Name);
+ end loop;
+
+ if not Is_Immediately_Visible (Unit_Name) then
+ Set_Is_Immediately_Visible (Unit_Name);
+ Set_Context_Installed (Item);
+ end if;
end if;
elsif Nkind (Item) = N_Use_Package_Clause then
while Present (Item) loop
- if Nkind (Item) = N_With_Clause then
+ if Nkind (Item) = N_With_Clause
+
+ -- Protect the frontend against previous errors in context
+ -- clauses
+
+ and then Nkind (Name (Item)) /= N_Selected_Component
+ then
Unit_Name := Entity (Name (Item));
while Is_Child_Unit (Unit_Name) loop
E := First_Entity (Current_Scope);
+ -- Make entities in scope visible again. For child units, restore
+ -- visibility only if they are actually in context.
+
while Present (E) loop
- Set_Is_Immediately_Visible (E);
+ if not Is_Child_Unit (E)
+ or else Is_Visible_Child_Unit (E)
+ then
+ Set_Is_Immediately_Visible (E);
+ end if;
+
Next_Entity (E);
end loop;
"and version-dependent?",
Name (N));
- elsif U_Kind = Ada_05_Unit and then Ada_Version = Ada_95 then
+ elsif U_Kind = Ada_05_Unit
+ and then Ada_Version < Ada_05
+ and then Warn_On_Ada_2005_Compatibility
+ then
Error_Msg_N ("& is an Ada 2005 unit?", Name (N));
end if;
end;
From_With_Type (Scope (Entity (Selector_Name (Name (Item)))))
then
Error_Msg_Sloc := Sloc (Item);
- Error_Msg_N ("Missing With_Clause for With_Type_Clause#", N);
+ Error_Msg_N ("missing With_Clause for With_Type_Clause#", N);
end if;
Next (Item);
begin
pragma Assert (Nkind (W) = N_With_Clause);
+ -- Protect the frontend against previous critical errors
+
+ case Nkind (Unit (Library_Unit (W))) is
+ when N_Subprogram_Declaration |
+ N_Package_Declaration |
+ N_Generic_Subprogram_Declaration |
+ N_Generic_Package_Declaration =>
+ null;
+
+ when others =>
+ return;
+ end case;
+
-- Step 1: Check if the unlimited view is installed in the parent
Item := First (Context_Items (P));
-- scope of each entity is an ancestor of the current unit.
Item := First (Context_Items (N));
+
+ -- Do not install private_with_clauses if the unit is a package
+ -- declaration, unless it is itself a private child unit.
+
while Present (Item) loop
if Nkind (Item) = N_With_Clause
and then not Implicit_With (Item)
and then not Limited_Present (Item)
+ and then
+ (not Private_Present (Item)
+ or else Nkind (Unit (N)) /= N_Package_Declaration
+ or else Private_Present (N))
then
Id := Entity (Name (Item));
begin
-- In case of limited with_clause on subprograms, generics, instances,
- -- or generic renamings, the corresponding error was previously posted
- -- and we have nothing to do here.
-
- case Nkind (P_Unit) is
-
- when N_Package_Declaration =>
- null;
+ -- or renamings, the corresponding error was previously posted and we
+ -- have nothing to do here.
- when N_Subprogram_Declaration |
- N_Generic_Package_Declaration |
- N_Generic_Subprogram_Declaration |
- N_Package_Instantiation |
- N_Function_Instantiation |
- N_Procedure_Instantiation |
- N_Generic_Package_Renaming_Declaration |
- N_Generic_Procedure_Renaming_Declaration |
- N_Generic_Function_Renaming_Declaration =>
- return;
-
- when others =>
- raise Program_Error;
- end case;
+ if Nkind (P_Unit) /= N_Package_Declaration then
+ return;
+ end if;
P := Defining_Unit_Name (Specification (P_Unit));
-- analyzing the private part of the package).
if Private_Present (With_Clause)
- and then Nkind (Cunit (Current_Sem_Unit)) = N_Package_Declaration
+ and then Nkind (Unit (Parent (With_Clause))) = N_Package_Declaration
and then not (Private_With_OK)
then
return;
elsif not Is_Visible_Child_Unit (Uname) then
Set_Is_Visible_Child_Unit (Uname);
+ -- If the child unit appears in the context of its parent, it
+ -- is immediately visible.
+
+ if In_Open_Scopes (Scope (Uname)) then
+ Set_Is_Immediately_Visible (Uname);
+ end if;
+
if Is_Generic_Instance (Uname)
and then Ekind (Uname) in Subprogram_Kind
then
& "limited with_clauses", N);
return;
+ when N_Subprogram_Renaming_Declaration =>
+ Error_Msg_N ("renamed subprograms not allowed in "
+ & "limited with_clauses", N);
+ return;
+
+ when N_Package_Renaming_Declaration =>
+ Error_Msg_N ("renamed packages not allowed in "
+ & "limited with_clauses", N);
+ return;
+
when others =>
raise Program_Error;
end case;
OSDN Git Service
