diff options
Diffstat (limited to 'gcc/ada/sem_ch10.adb')
| -rw-r--r-- | gcc/ada/sem_ch10.adb | 946 |
1 files changed, 891 insertions, 55 deletions
diff --git a/gcc/ada/sem_ch10.adb b/gcc/ada/sem_ch10.adb index 37d789e32c0..743e943ff7a 100644 --- a/gcc/ada/sem_ch10.adb +++ b/gcc/ada/sem_ch10.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2003 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- -- @@ -28,6 +28,7 @@ with Atree; use Atree; with Debug; use Debug; with Einfo; use Einfo; with Errout; use Errout; +with Elists; use Elists; with Exp_Util; use Exp_Util; with Fname; use Fname; with Fname.UF; use Fname.UF; @@ -57,6 +58,7 @@ with Sinfo.CN; use Sinfo.CN; with Sinput; use Sinput; with Snames; use Snames; with Style; use Style; +with Stylesw; use Stylesw; with Tbuild; use Tbuild; with Ttypes; use Ttypes; with Uname; use Uname; @@ -70,6 +72,14 @@ package body Sem_Ch10 is procedure Analyze_Context (N : Node_Id); -- Analyzes items in the context clause of compilation unit + procedure Build_Limited_Views (N : Node_Id); + -- Build list of shadow entities for a package mentioned in a + -- limited_with clause. + + procedure Check_Body_Needed_For_SAL (Unit_Name : Entity_Id); + -- Check whether the source for the body of a compilation unit must + -- be included in a standalone library. + procedure Check_With_Type_Clauses (N : Node_Id); -- If N is a body, verify that any with_type clauses on the spec, or -- on the spec of any parent, have a matching with_clause. @@ -82,6 +92,13 @@ package body Sem_Ch10 is -- Verify that a stub is declared immediately within a compilation unit, -- and not in an inner frame. + procedure Expand_Limited_With_Clause (Nam : Node_Id; N : Node_Id); + -- if a child unit appears in a limited_with clause, there are implicit + -- limited_with clauses on all parents that are not already visible + -- through a regular with clause. This procedure creates the implicit + -- limited with_clauses for the parents and loads the corresponding units. + -- The shadow entities are created when the inserted clause is analyzed. + procedure Expand_With_Clause (Nam : Node_Id; N : Node_Id); -- When a child unit appears in a context clause, the implicit withs on -- parents are made explicit, and with clauses are inserted in the context @@ -106,6 +123,11 @@ package body Sem_Ch10 is -- Subsidiary to previous one. Process only with_ and use_clauses for -- current unit and its library unit if any. + procedure Install_Limited_Withed_Unit (N : Node_Id); + -- Place shadow entities for a limited_with package in the visibility + -- structures for the current compilation. Verify that there is no + -- regular with_clause in the context. + procedure Install_Withed_Unit (With_Clause : Node_Id); -- If the unit is not a child unit, make unit immediately visible. -- The caller ensures that the unit is not already currently installed. @@ -145,6 +167,10 @@ package body Sem_Ch10 is procedure Remove_Context_Clauses (N : Node_Id); -- Subsidiary of previous one. Remove use_ and with_clauses. + procedure Remove_Limited_With_Clause (N : Node_Id); + -- Remove from visibility the shadow entities introduced for a package + -- mentioned in a limited_with clause. + procedure Remove_Parents (Lib_Unit : Node_Id); -- Remove_Parents checks if Lib_Unit is a child spec. If so then the parent -- contexts established by the corresponding call to Install_Parents are @@ -155,6 +181,9 @@ package body Sem_Ch10 is -- 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 @@ -162,6 +191,34 @@ package body Sem_Ch10 is -- entity for which the proper body provides a completion. Subprogram -- stubs are handled differently because they can be declarations. + -------------------------- + -- Limited_With_Clauses -- + -------------------------- + + -- Limited_With clauses are the mechanism chosen for Ada05 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 + -- restriction that these types can only be used as incomplete types. + -- The limited_with clause does not impose a semantic dependence on P, + -- and it is possible for two packages to have limited_with_clauses on + -- each other without creating an elaboration circularity. + + -- To support this feature, the analysis of a limited_with clause must + -- create an abbreviated view of the package, without performing any + -- semantic analysis on it. This "package abstract" contains shadow + -- types that are in one-one correspondence with the real types in the + -- package, and that have the properties of incomplete types. + + -- The implementation creates two element lists: one to chain the shadow + -- entities, and one to chain the corresponding type entities in the tree + -- of the package. Links between corresponding entities in both chains + -- allow the compiler to select the proper view of a given type, depending + -- on the context. Note that in contrast with the handling of private + -- types, the limited view and the non-limited view of a type are treated + -- as separate entities, and no entity exchange needs to take place, which + -- makes the implementation must simpler than could be feared. + ------------------------------ -- Analyze_Compilation_Unit -- ------------------------------ @@ -378,7 +435,7 @@ package body Sem_Ch10 is -- The analysis of the parent is done with style checks off declare - Save_Style_Check : constant Boolean := Opt.Style_Check; + Save_Style_Check : constant Boolean := Style_Check; Save_C_Restrict : constant Save_Compilation_Unit_Restrictions := Compilation_Unit_Restrictions_Save; @@ -485,6 +542,15 @@ package body Sem_Ch10 is then Remove_Unit_From_Visibility (Defining_Entity (Unit_Node)); + -- If the unit is an instantiation whose body will be elaborated + -- for inlining purposes, use the the proper entity of the instance. + + elsif Nkind (Unit_Node) = N_Package_Instantiation + and then not Error_Posted (Unit_Node) + then + Remove_Unit_From_Visibility + (Defining_Entity (Instance_Spec (Unit_Node))); + elsif Nkind (Unit_Node) = N_Package_Body or else (Nkind (Unit_Node) = N_Subprogram_Body and then not Acts_As_Spec (Unit_Node)) @@ -515,6 +581,11 @@ package body Sem_Ch10 is and then Operating_Mode = Generate_Code and then Expander_Active then + -- Check whether the source for the body of the unit must be + -- included in a standalone library. + + Check_Body_Needed_For_SAL (Cunit_Entity (Main_Unit)); + -- Indicate that the main unit is now analyzed, to catch possible -- circularities between it and generic bodies. Remove main unit -- from visibility. This might seem superfluous, but the main unit @@ -528,28 +599,25 @@ package body Sem_Ch10 is Nam : Entity_Id; Un : Unit_Number_Type; - Save_Style_Check : constant Boolean := Opt.Style_Check; + Save_Style_Check : constant Boolean := Style_Check; Save_C_Restrict : constant Save_Compilation_Unit_Restrictions := Compilation_Unit_Restrictions_Save; begin Item := First (Context_Items (N)); - while Present (Item) loop - if Nkind (Item) = N_With_Clause and then not Implicit_With (Item) + and then not Limited_Present (Item) then Nam := Entity (Name (Item)); - if (Ekind (Nam) = E_Generic_Procedure + if (Is_Generic_Subprogram (Nam) and then not Is_Intrinsic_Subprogram (Nam)) - or else (Ekind (Nam) = E_Generic_Function - and then not Is_Intrinsic_Subprogram (Nam)) or else (Ekind (Nam) = E_Generic_Package and then Unit_Requires_Body (Nam)) then - Opt.Style_Check := False; + Style_Check := False; if Present (Renamed_Object (Nam)) then Un := @@ -580,8 +648,9 @@ package body Sem_Ch10 is elsif not Analyzed (Cunit (Un)) and then Un /= Main_Unit + and then not Fatal_Error (Un) then - Opt.Style_Check := False; + Style_Check := False; Semantics (Cunit (Un)); end if; end if; @@ -682,10 +751,24 @@ package body Sem_Ch10 is if Nkind (Unit_Node) = N_Package_Declaration and then Get_Cunit_Unit_Number (N) /= Main_Unit - and then Front_End_Inlining and then Expander_Active then - Check_Body_For_Inlining (N, Defining_Entity (Unit_Node)); + declare + Save_Style_Check : constant Boolean := Style_Check; + Save_Warning : constant Warning_Mode_Type := Warning_Mode; + Options : Style_Check_Options; + + begin + Save_Style_Check_Options (Options); + Reset_Style_Check_Options; + Opt.Warning_Mode := Suppress; + Check_Body_For_Inlining (N, Defining_Entity (Unit_Node)); + + Reset_Style_Check_Options; + Set_Style_Check_Options (Options); + Style_Check := Save_Style_Check; + Warning_Mode := Save_Warning; + end; end if; end Analyze_Compilation_Unit; @@ -697,7 +780,11 @@ package body Sem_Ch10 is Item : Node_Id; begin - -- Loop through context items + -- Loop through context items. This is done is three passes: + -- a) The first pass analyze non-limited with-clauses. + -- b) The second pass add implicit limited_with clauses for the + -- the parents of child units. + -- c) The third pass analyzes limited_with clauses. Item := First (Context_Items (N)); while Present (Item) loop @@ -708,7 +795,7 @@ package body Sem_Ch10 is if Nkind (Item) = N_With_Clause then -- Skip analyzing with clause if no unit, nothing to do (this - -- happens for a with that references a non-existent unit) + -- happens for a with that references a non-existant unit) if Present (Library_Unit (Item)) then Analyze (Item); @@ -731,6 +818,49 @@ package body Sem_Ch10 is Next (Item); end loop; + + -- Second pass: add implicit limited_with_clauses for parents of + -- child units mentioned in limited_with clauses. + + Item := First (Context_Items (N)); + + while Present (Item) loop + if Nkind (Item) = N_With_Clause + and then Limited_Present (Item) + and then Nkind (Name (Item)) = N_Selected_Component + then + Expand_Limited_With_Clause + (Nam => Prefix (Name (Item)), N => Item); + end if; + + Next (Item); + end loop; + + -- Third pass: examine all limited_with clauses. + + Item := First (Context_Items (N)); + + while Present (Item) loop + if Nkind (Item) = N_With_Clause + and then Limited_Present (Item) + then + + -- Skip analyzing with clause if no unit, see above. + + if Present (Library_Unit (Item)) then + Analyze (Item); + end if; + + -- A limited_with does not impose an elaboration order, but + -- there is a semantic dependency for recompilation purposes. + + if not Implicit_With (Item) then + Version_Update (N, Library_Unit (Item)); + end if; + end if; + + Next (Item); + end loop; end Analyze_Context; ------------------------------- @@ -763,6 +893,7 @@ package body Sem_Ch10 is Set_Has_Completion (Nam); Set_Scope (Defining_Entity (N), Current_Scope); + Generate_Reference (Nam, Id, 'b'); Analyze_Proper_Body (N, Nam); end if; end Analyze_Package_Body_Stub; @@ -774,7 +905,6 @@ package body Sem_Ch10 is procedure Analyze_Proper_Body (N : Node_Id; Nam : Entity_Id) is Subunit_Name : constant Unit_Name_Type := Get_Unit_Name (N); Unum : Unit_Number_Type; - Subunit_Not_Found : Boolean := False; procedure Optional_Subunit; -- This procedure is called when the main unit is a stub, or when we @@ -806,7 +936,9 @@ package body Sem_Ch10 is -- All done if we successfully loaded the subunit - if Unum /= No_Unit and then not Fatal_Error (Unum) then + if Unum /= No_Unit + and then (not Fatal_Error (Unum) or else Try_Semantics) + then Comp_Unit := Cunit (Unum); Set_Corresponding_Stub (Unit (Comp_Unit), N); @@ -864,6 +996,16 @@ package body Sem_Ch10 is if Unum /= No_Unit then Compiler_State := Analyzing; + + -- Check that the proper body is a subunit and not a child + -- unit. If the unit was previously loaded, the error will + -- have been emitted when copying the generic node, so we + -- just return to avoid cascaded errors. + + if Nkind (Unit (Cunit (Unum))) /= N_Subunit then + return; + end if; + Set_Corresponding_Stub (Unit (Cunit (Unum)), N); Analyze_Subunit (Cunit (Unum)); Set_Library_Unit (N, Cunit (Unum)); @@ -878,7 +1020,7 @@ package body Sem_Ch10 is elsif Nkind (Unit (Cunit (Main_Unit))) = N_Subunit and then Subunit_Name /= Unit_Name (Main_Unit) then - if Tree_Output then + if ASIS_Mode then Optional_Subunit; end if; @@ -901,7 +1043,7 @@ package body Sem_Ch10 is -- presence, and emit a warning if not found, rather than terminating -- the compilation abruptly, as for other missing file problems. - elsif Operating_Mode = Generate_Code then + elsif Original_Operating_Mode = Generate_Code then -- If the proper body is already linked to the stub node, -- the stub is in a generic unit and just needs analyzing. @@ -926,7 +1068,7 @@ package body Sem_Ch10 is Subunit => True, Error_Node => N); - if Operating_Mode = Generate_Code + if Original_Operating_Mode = Generate_Code and then Unum = No_Unit then Error_Msg_Name_1 := Subunit_Name; @@ -935,7 +1077,6 @@ package body Sem_Ch10 is Error_Msg_N ("subunit% in file{ not found!?", N); Subunits_Missing := True; - Subunit_Not_Found := True; end if; -- Load_Unit may reset Compiler_State, since it may have been @@ -944,8 +1085,9 @@ package body Sem_Ch10 is Compiler_State := Analyzing; - if Unum /= No_Unit and then not Fatal_Error (Unum) then - + if Unum /= No_Unit + and then (not Fatal_Error (Unum) or else Try_Semantics) + then if Debug_Flag_L then Write_Str ("*** Loaded subunit from stub. Analyze"); Write_Eol; @@ -1003,7 +1145,7 @@ package body Sem_Ch10 is begin Check_Stub_Level (N); - -- First occurrence of name may have been as an incomplete type. + -- First occurence of name may have been as an incomplete type. if Present (Nam) and then Ekind (Nam) = E_Incomplete_Type then Nam := Full_View (Nam); @@ -1016,6 +1158,7 @@ package body Sem_Ch10 is else Set_Scope (Defining_Entity (N), Current_Scope); Set_Has_Completion (Etype (Nam)); + Generate_Reference (Nam, Defining_Identifier (N), 'b'); Analyze_Proper_Body (N, Etype (Nam)); end if; end Analyze_Protected_Body_Stub; @@ -1065,11 +1208,7 @@ package body Sem_Ch10 is -- declaration, or else introduces entity and its signature. Analyze_Subprogram_Body (N); - - if Serious_Errors_Detected = 0 then - Analyze_Proper_Body (N, Empty); - end if; - + Analyze_Proper_Body (N, Empty); end Analyze_Subprogram_Body_Stub; --------------------- @@ -1355,7 +1494,6 @@ package body Sem_Ch10 is Analyze (Proper_Body (Unit (N))); Remove_Context (N); - end Analyze_Subunit; ---------------------------- @@ -1369,7 +1507,7 @@ package body Sem_Ch10 is begin Check_Stub_Level (N); - -- First occurrence of name may have been as an incomplete type. + -- First occurence of name may have been as an incomplete type. if Present (Nam) and then Ekind (Nam) = E_Incomplete_Type then Nam := Full_View (Nam); @@ -1381,6 +1519,7 @@ package body Sem_Ch10 is Error_Msg_N ("missing specification for task body", N); else Set_Scope (Defining_Entity (N), Current_Scope); + Generate_Reference (Nam, Defining_Identifier (N), 'b'); Set_Has_Completion (Etype (Nam)); Analyze_Proper_Body (N, Etype (Nam)); @@ -1410,7 +1549,16 @@ package body Sem_Ch10 is -- label the with clause with the defining entity for the unit. procedure Analyze_With_Clause (N : Node_Id) is - Unit_Kind : constant Node_Kind := Nkind (Unit (Library_Unit (N))); + + -- Retrieve the original kind of the unit node, before analysis. + -- If it is a subprogram instantiation, its analysis below will + -- rewrite as the declaration of the wrapper package. If the same + -- instantiation appears indirectly elsewhere in the context, it + -- will have been analyzed already. + + Unit_Kind : constant Node_Kind := + Nkind (Original_Node (Unit (Library_Unit (N)))); + E_Name : Entity_Id; Par_Name : Entity_Id; Pref : Node_Id; @@ -1424,6 +1572,14 @@ package body Sem_Ch10 is Compilation_Unit_Restrictions_Save; begin + if Limited_Present (N) then + + -- Build visibility structures but do not analyze unit + + Build_Limited_Views (N); + return; + end if; + -- We reset ordinary style checking during the analysis of a with'ed -- unit, but we do NOT reset GNAT special analysis mode (the latter -- definitely *does* apply to with'ed units). @@ -1432,19 +1588,19 @@ package body Sem_Ch10 is Style_Check := False; end if; - -- If the library unit is a predefined unit, and we are in no - -- run time mode, then temporarily reset No_Run_Time mode for the - -- analysis of the with'ed unit. The No_Run_Time pragma does not - -- prevent explicit with'ing of run-time units. + -- If the library unit is a predefined unit, and we are in high + -- integrity mode, then temporarily reset Configurable_Run_Time_Mode + -- for the analysis of the with'ed unit. This mode does not prevent + -- explicit with'ing of run-time units. - if No_Run_Time + if Configurable_Run_Time_Mode and then Is_Predefined_File_Name (Unit_File_Name (Get_Source_Unit (Unit (Library_Unit (N))))) then - No_Run_Time := False; + Configurable_Run_Time_Mode := False; Semantics (Library_Unit (N)); - No_Run_Time := True; + Configurable_Run_Time_Mode := True; else Semantics (Library_Unit (N)); @@ -1469,12 +1625,14 @@ package body Sem_Ch10 is -- Check for inappropriate with of internal implementation unit -- if we are currently compiling the main unit and the main unit - -- is itself not an internal unit. + -- is itself not an internal unit. We do not issue this message + -- for implicit with's generated by the compiler itself. if Implementation_Unit_Warnings and then Current_Sem_Unit = Main_Unit and then Implementation_Unit (Get_Source_Unit (U)) and then not Intunit + and then not Implicit_With (N) then Error_Msg_N ("& is an internal 'G'N'A'T unit?", Name (N)); Error_Msg_N @@ -1562,7 +1720,7 @@ package body Sem_Ch10 is -- reference that occurs. Set_Entity_With_Style_Check (Name (N), E_Name); - Generate_Reference (E_Name, Name (N), Set_Ref => False); + Generate_Reference (E_Name, Name (N), 'w', Set_Ref => False); if Is_Child_Unit (E_Name) then Pref := Prefix (Name (N)); @@ -1602,7 +1760,7 @@ package body Sem_Ch10 is if Chars (E_Name) = Name_System and then Scope (E_Name) = Standard_Standard - and then Present (System_Extend_Pragma_Arg) + and then Present (System_Extend_Unit) and then Present_System_Aux (N) then -- If the extension is not present, an error will have been emitted. @@ -1617,7 +1775,7 @@ package body Sem_Ch10 is procedure Analyze_With_Type_Clause (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); - Nam : Node_Id := Name (N); + Nam : constant Node_Id := Name (N); Pack : Node_Id; Decl : Node_Id; P : Entity_Id; @@ -1972,8 +2130,10 @@ package body Sem_Ch10 is -- an explicit designation of private. function Is_Private_Library_Unit (Unit : Entity_Id) return Boolean is + Comp_Unit : constant Node_Id := Parent (Unit_Declaration_Node (Unit)); + begin - return Private_Present (Parent (Unit_Declaration_Node (Unit))); + return Private_Present (Comp_Unit); end Is_Private_Library_Unit; -- Start of processing for Check_Private_Child_Unit @@ -2180,6 +2340,88 @@ package body Sem_Ch10 is New_Nodes_OK := New_Nodes_OK - 1; end Expand_With_Clause; + -------------------------------- + -- Expand_Limited_With_Clause -- + -------------------------------- + + procedure Expand_Limited_With_Clause (Nam : Node_Id; N : Node_Id) is + Loc : constant Source_Ptr := Sloc (Nam); + P : Entity_Id; + Unum : Unit_Number_Type; + Withn : Node_Id; + + begin + New_Nodes_OK := New_Nodes_OK + 1; + + if Nkind (Nam) = N_Identifier then + Withn := + Make_With_Clause (Loc, Name => Nam); + Set_Limited_Present (Withn); + Set_First_Name (Withn); + Set_Implicit_With (Withn); + + -- Load the corresponding parent unit + + Unum := + Load_Unit + (Load_Name => Get_Spec_Name (Get_Unit_Name (Nam)), + Required => True, + Subunit => False, + Error_Node => Nam); + + P := Cunit_Entity (Unum); + + if not Analyzed (Cunit (Unum)) then + Set_Library_Unit (Withn, Cunit (Unum)); + Set_Corresponding_Spec + (Withn, Specification (Unit (Cunit (Unum)))); + + Prepend (Withn, Context_Items (Parent (N))); + Mark_Rewrite_Insertion (Withn); + end if; + + elsif Nkind (Nam) = N_Selected_Component then + Withn := + Make_With_Clause + (Loc, + Name => + Make_Selected_Component + (Loc, + Prefix => Prefix (Nam), + Selector_Name => Selector_Name (Nam))); + + Set_Parent (Withn, Parent (N)); + Set_Limited_Present (Withn); + Set_First_Name (Withn); + Set_Implicit_With (Withn); + + Unum := + Load_Unit + (Load_Name => Get_Spec_Name (Get_Unit_Name (Nam)), + Required => True, + Subunit => False, + Error_Node => Nam); + + P := Cunit_Entity (Unum); + + if not Analyzed (Cunit (Unum)) then + Set_Library_Unit (Withn, Cunit (Unum)); + Set_Corresponding_Spec + (Withn, Specification (Unit (Cunit (Unum)))); + Prepend (Withn, Context_Items (Parent (N))); + Mark_Rewrite_Insertion (Withn); + + Expand_Limited_With_Clause (Prefix (Nam), N); + end if; + + else + null; + pragma Assert (False); + end if; + + New_Nodes_OK := New_Nodes_OK - 1; + end Expand_Limited_With_Clause; + ----------------------- -- Get_Parent_Entity -- ----------------------- @@ -2204,8 +2446,7 @@ package body Sem_Ch10 is Loc : constant Source_Ptr := Sloc (N); P : constant Node_Id := Parent_Spec (Child_Unit); P_Unit : constant Node_Id := Unit (P); - - P_Name : Entity_Id := Get_Parent_Entity (P_Unit); + P_Name : constant Entity_Id := Get_Parent_Entity (P_Unit); Withn : Node_Id; function Build_Ancestor_Name (P : Node_Id) return Node_Id; @@ -2220,7 +2461,8 @@ package body Sem_Ch10 is ------------------------- function Build_Ancestor_Name (P : Node_Id) return Node_Id is - P_Ref : Node_Id := New_Reference_To (Defining_Entity (P), Loc); + P_Ref : constant Node_Id := + New_Reference_To (Defining_Entity (P), Loc); begin if No (Parent_Spec (P)) then @@ -2283,7 +2525,7 @@ package body Sem_Ch10 is --------------------- procedure Install_Context (N : Node_Id) is - Lib_Unit : Node_Id := Unit (N); + Lib_Unit : constant Node_Id := Unit (N); begin Install_Context_Clauses (N); @@ -2300,15 +2542,18 @@ package body Sem_Ch10 is ----------------------------- procedure Install_Context_Clauses (N : Node_Id) is - Lib_Unit : Node_Id := Unit (N); + Lib_Unit : constant Node_Id := Unit (N); Item : Node_Id; Uname_Node : Entity_Id; Check_Private : Boolean := False; Decl_Node : Node_Id; Lib_Parent : Entity_Id; + Lim_Present : Boolean := False; begin - -- Loop through context clauses to find the with/use clauses + -- Loop through context clauses to find the with/use clauses. + -- This is done twice, first for everything except limited_with + -- clauses, and then for those, if any are present. Item := First (Context_Items (N)); while Present (Item) loop @@ -2318,10 +2563,21 @@ package body Sem_Ch10 is if Nkind (Item) = N_With_Clause and then not Implicit_With (Item) then + if Limited_Present (Item) then + + -- Second pass will be necessary + + Lim_Present := True; + goto Continue; + -- If Name (Item) is not an entity name, something is wrong, and -- this will be detected in due course, for now ignore the item - if not Is_Entity_Name (Name (Item)) then + elsif not Is_Entity_Name (Name (Item)) then + goto Continue; + + elsif No (Entity (Name (Item))) then + Set_Entity (Name (Item), Any_Id); goto Continue; end if; @@ -2522,6 +2778,22 @@ package body Sem_Ch10 is if Check_Private then Check_Private_Child_Unit (N); end if; + + -- Second pass: install limited_with clauses + + if Lim_Present then + Item := First (Context_Items (N)); + + while Present (Item) loop + if Nkind (Item) = N_With_Clause + and then Limited_Present (Item) + then + Install_Limited_Withed_Unit (Item); + end if; + + Next (Item); + end loop; + end if; end Install_Context_Clauses; --------------------- @@ -2616,6 +2888,13 @@ package body Sem_Ch10 is Install_Visible_Declarations (P_Name); Set_Use (Visible_Declarations (P_Spec)); + -- If the parent is a generic unit, its formal part may contain + -- formal packages and use clauses for them. + + if Ekind (P_Name) = E_Generic_Package then + Set_Use (Generic_Formal_Declarations (Parent (P_Spec))); + end if; + if Is_Private or else Private_Present (Parent (Lib_Unit)) then @@ -2670,6 +2949,7 @@ package body Sem_Ch10 is if Nkind (Item) = N_With_Clause and then not Implicit_With (Item) + and then not Limited_Present (Item) then Id := Entity (Name (Item)); @@ -2716,18 +2996,143 @@ package body Sem_Ch10 is then Set_Is_Immediately_Visible (Scope (Id)); end if; + end if; Next (Item); end loop; end Install_Siblings; + ------------------------------- + -- Install_Limited_With_Unit -- + ------------------------------- + + procedure Install_Limited_Withed_Unit (N : Node_Id) is + Unum : Unit_Number_Type := + Get_Source_Unit (Library_Unit (N)); + P_Unit : Entity_Id := Unit (Library_Unit (N)); + P : Entity_Id := + Defining_Unit_Name (Specification (P_Unit)); + Lim_Elmt : Elmt_Id; + Lim_Typ : Entity_Id; + Is_Child_Package : Boolean := False; + + function In_Chain (E : Entity_Id) return Boolean; + -- Check that the shadow entity is not already in the homonym + -- chain, for example through a limited_with clause in a parent unit. + + function In_Chain (E : Entity_Id) return Boolean is + H : Entity_Id := Current_Entity (E); + + begin + while Present (H) loop + if H = E then + return True; + else + H := Homonym (H); + end if; + end loop; + + return False; + end In_Chain; + + -- Start of processing for Install_Limited_Withed_Unit + + begin + if Nkind (P) = N_Defining_Program_Unit_Name then + + -- Retrieve entity of child package + + Is_Child_Package := True; + P := Defining_Identifier (P); + end if; + + if Analyzed (Cunit (Unum)) + and then Is_Immediately_Visible (P) + then + -- disallow naming in a limited with clause a unit (or renaming + -- thereof) that is mentioned in an enclosing normal with clause. + Error_Msg_N ("limited_with not allowed on unit already withed", N); + + return; + end if; + + if not Analyzed (Cunit (Unum)) then + Set_Ekind (P, E_Package); + Set_Etype (P, Standard_Void_Type); + Set_Scope (P, Standard_Standard); + + -- Place entity on visibility structure + + if Current_Entity (P) /= P then + Set_Homonym (P, Current_Entity (P)); + Set_Current_Entity (P); + end if; + + if Is_Child_Package then + Set_Is_Child_Unit (P); + Set_Is_Visible_Child_Unit (P); + + declare + Parent_Comp : Node_Id; + Parent_Id : Entity_Id; + + begin + Parent_Comp := Parent_Spec (Unit (Cunit (Unum))); + Parent_Id := Defining_Entity (Unit (Parent_Comp)); + + Set_Scope (P, Parent_Id); + end; + end if; + else + -- If the unit appears in a previous regular with_clause, the + -- regular entities must be unchained before the shadow ones + -- are made accessible. + + declare + Ent : Entity_Id; + begin + Ent := First_Entity (P); + + while Present (Ent) loop + Unchain (Ent); + Next_Entity (Ent); + end loop; + end; + end if; + + -- The package must be visible while the with_type clause is active, + -- because references to the type P.T must resolve in the usual way. + + Set_Is_Immediately_Visible (P); + + -- Install each incomplete view + + Lim_Elmt := First_Elmt (Limited_Views (P)); + + while Present (Lim_Elmt) loop + Lim_Typ := Node (Lim_Elmt); + + if not In_Chain (Lim_Typ) then + Set_Homonym (Lim_Typ, Current_Entity (Lim_Typ)); + Set_Current_Entity (Lim_Typ); + end if; + + Next_Elmt (Lim_Elmt); + end loop; + + -- The context clause has installed a limited-view, mark it + -- accordingly, to uninstall it when the context is removed. + + Set_Limited_View_Installed (N); + end Install_Limited_Withed_Unit; + ------------------------- -- Install_Withed_Unit -- ------------------------- procedure Install_Withed_Unit (With_Clause : Node_Id) is - Uname : Entity_Id := Entity (Name (With_Clause)); + Uname : constant Entity_Id := Entity (Name (With_Clause)); P : constant Entity_Id := Scope (Uname); begin @@ -2853,7 +3258,7 @@ package body Sem_Ch10 is else Compiler_State := Analyzing; -- reset after load - if not Fatal_Error (Unum) then + if not Fatal_Error (Unum) or else Try_Semantics then if Debug_Flag_L then Write_Str ("*** Loaded generic body"); Write_Eol; @@ -2868,6 +3273,357 @@ package body Sem_Ch10 is Style_Check := Save_Style_Check; end Load_Needed_Body; + ------------------------- + -- Build_Limited_Views -- + ------------------------- + + procedure Build_Limited_Views (N : Node_Id) is + + Unum : Unit_Number_Type := Get_Source_Unit (Library_Unit (N)); + P : Entity_Id := Cunit_Entity (Unum); + + Spec : Node_Id; -- To denote a package specification + Lim_Typ : Entity_Id; -- To denote shadow entities. + Comp_Typ : Entity_Id; -- To denote real entities. + + procedure Decorate_Incomplete_Type + (E : Entity_Id; + Scop : Entity_Id); + -- Add attributes of an incomplete type to a shadow entity. The same + -- attributes are placed on the real entity, so that gigi receives + -- a consistent view. + + procedure Decorate_Package_Specification (P : Entity_Id); + -- Add attributes of a package entity to the entity in a package + -- declaration + + 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. + + procedure Build_Chain (Spec : Node_Id; Scope : Entity_Id); + -- Construct list of shadow entities and attach it to entity of + -- package that is mentioned in a limited_with clause. + + ------------------------------ + -- Decorate_Incomplete_Type -- + ------------------------------ + + procedure Decorate_Incomplete_Type + (E : Entity_Id; + Scop : Entity_Id) + is + begin + Set_Ekind (E, E_Incomplete_Type); + Set_Scope (E, Scop); + Set_Etype (E, E); + Set_Is_First_Subtype (E, True); + Set_Stored_Constraint (E, No_Elist); + Set_Full_View (E, Empty); + Init_Size_Align (E); + Set_Has_Unknown_Discriminants (E); + end Decorate_Incomplete_Type; + + -------------------------- + -- Decorate_Tagged_Type -- + -------------------------- + + procedure Decorate_Tagged_Type + (Loc : Source_Ptr; + T : Entity_Id; + Scop : Entity_Id) + is + CW : Entity_Id; + + begin + Decorate_Incomplete_Type (T, Scop); + Set_Is_Tagged_Type (T); + + -- Build corresponding class_wide type, if not previously done + + if No (Class_Wide_Type (T)) then + CW := Make_Defining_Identifier (Loc, New_Internal_Name ('S')); + + Set_Ekind (CW, E_Class_Wide_Type); + Set_Etype (CW, T); + Set_Scope (CW, Scop); + Set_Is_Tagged_Type (CW); + Set_Is_First_Subtype (CW, True); + Init_Size_Align (CW); + Set_Has_Unknown_Discriminants (CW, True); + Set_Class_Wide_Type (CW, CW); + Set_Equivalent_Type (CW, Empty); + Set_From_With_Type (CW, From_With_Type (T)); + + Set_Class_Wide_Type (T, CW); + end if; + end Decorate_Tagged_Type; + + ------------------------------------ + -- Decorate_Package_Specification -- + ------------------------------------ + + procedure Decorate_Package_Specification (P : Entity_Id) is + begin + -- Place only the most basic attributes + + Set_Ekind (P, E_Package); + Set_Etype (P, Standard_Void_Type); + end Decorate_Package_Specification; + + ----------------- + -- Build_Chain -- + ----------------- + + procedure Build_Chain (Spec : Node_Id; Scope : Entity_Id) is + Decl : Node_Id; + + begin + Decl := First (Visible_Declarations (Spec)); + + while Present (Decl) loop + if Nkind (Decl) = N_Full_Type_Declaration then + Comp_Typ := Defining_Identifier (Decl); + + if not Analyzed (Cunit (Unum)) then + if Tagged_Present (Type_Definition (Decl)) then + Decorate_Tagged_Type (Sloc (Decl), Comp_Typ, Scope); + else + Decorate_Incomplete_Type (Comp_Typ, Scope); + end if; + end if; + + -- Create shadow entity for type + + Lim_Typ := New_Internal_Entity + (Kind => Ekind (Comp_Typ), + Scope_Id => Scope, + Sloc_Value => Sloc (Comp_Typ), + Id_Char => 'Z'); + + Set_Chars (Lim_Typ, Chars (Comp_Typ)); + Set_Parent (Lim_Typ, Parent (Comp_Typ)); + Set_From_With_Type (Lim_Typ); + + if Tagged_Present (Type_Definition (Decl)) then + Decorate_Tagged_Type (Sloc (Decl), Lim_Typ, Scope); + else + Decorate_Incomplete_Type (Lim_Typ, Scope); + end if; + + Set_Non_Limited_View (Lim_Typ, Comp_Typ); + + -- Add each entity to the proper list + + Append_Elmt (Comp_Typ, To => Non_Limited_Views (P)); + Append_Elmt (Lim_Typ, To => Limited_Views (P)); + + elsif Nkind (Decl) = N_Private_Type_Declaration + and then Tagged_Present (Decl) + then + Comp_Typ := Defining_Identifier (Decl); + + if not Analyzed (Cunit (Unum)) then + Decorate_Tagged_Type (Sloc (Decl), Comp_Typ, Scope); + end if; + + Lim_Typ := New_Internal_Entity + (Kind => Ekind (Comp_Typ), + Scope_Id => Scope, + Sloc_Value => Sloc (Comp_Typ), + Id_Char => 'Z'); + + Set_Chars (Lim_Typ, Chars (Comp_Typ)); + Set_Parent (Lim_Typ, Parent (Comp_Typ)); + Set_From_With_Type (Lim_Typ); + + Decorate_Tagged_Type (Sloc (Decl), Lim_Typ, Scope); + + Set_Non_Limited_View (Lim_Typ, Comp_Typ); + + -- Add the entities to the proper list + + Append_Elmt (Comp_Typ, To => Non_Limited_Views (P)); + Append_Elmt (Lim_Typ, To => Limited_Views (P)); + + elsif Nkind (Decl) = N_Package_Declaration then + + -- Local package + + declare + Spec : Node_Id := Specification (Decl); + + begin + Comp_Typ := Defining_Unit_Name (Spec); + + if not Analyzed (Cunit (Unum)) then + Decorate_Package_Specification (Comp_Typ); + Set_Scope (Comp_Typ, Scope); + end if; + + Lim_Typ := New_Internal_Entity + (Kind => Ekind (Comp_Typ), + Scope_Id => Scope, + Sloc_Value => Sloc (Comp_Typ), + Id_Char => 'Z'); + + Decorate_Package_Specification (Lim_Typ); + Set_Scope (Lim_Typ, Scope); + + Set_Chars (Lim_Typ, Chars (Comp_Typ)); + Set_Parent (Lim_Typ, Parent (Comp_Typ)); + Set_From_With_Type (Lim_Typ); + + -- Note: The non_limited_view attribute is not used + -- for local packages. + + -- Add the entities to the proper list. + Append_Elmt (Comp_Typ, To => Non_Limited_Views (P)); + Append_Elmt (Lim_Typ, To => Limited_Views (P)); + + Build_Chain (Spec, Scope => Lim_Typ); + end; + end if; + + Next (Decl); + end loop; + end Build_Chain; + + -- Start of processing for Build_Limited_Views + + begin + pragma Assert (Limited_Present (N)); + + -- Limited withed subprograms are not allowed. Therefore, we + -- don't need to build the limited-view auxiliary chain. + + if Nkind (Parent (P)) = N_Function_Specification + or else Nkind (Parent (P)) = N_Procedure_Specification + then + return; + end if; + + -- Check if the chain is already built + + Spec := Specification (Unit (Library_Unit (N))); + + if Limited_View_Installed (Spec) then + return; + end if; + + Set_Ekind (P, E_Package); + Set_Limited_Views (P, New_Elmt_List); + Set_Non_Limited_Views (P, New_Elmt_List); + -- Set_Entity (Name (N), P); + + -- Create the auxiliary chain + + Build_Chain (Spec, Scope => P); + Set_Limited_View_Installed (Spec); + end Build_Limited_Views; + + ------------------------------- + -- Check_Body_Needed_For_SAL -- + ------------------------------- + + procedure Check_Body_Needed_For_SAL (Unit_Name : Entity_Id) is + + function Entity_Needs_Body (E : Entity_Id) return Boolean; + -- Determine whether use of entity E might require the presence + -- of its body. For a package this requires a recursive traversal + -- of all nested declarations. + + --------------------------- + -- Entity_Needed_For_SAL -- + --------------------------- + + function Entity_Needs_Body (E : Entity_Id) return Boolean is + Ent : Entity_Id; + + begin + if Is_Subprogram (E) + and then Has_Pragma_Inline (E) + then + return True; + + elsif Ekind (E) = E_Generic_Function + or else Ekind (E) = E_Generic_Procedure + then + return True; + + elsif Ekind (E) = E_Generic_Package + and then + Nkind (Unit_Declaration_Node (E)) = N_Generic_Package_Declaration + and then Present (Corresponding_Body (Unit_Declaration_Node (E))) + then + return True; + + elsif Ekind (E) = E_Package + and then + Nkind (Unit_Declaration_Node (E)) = N_Package_Declaration + and then Present (Corresponding_Body (Unit_Declaration_Node (E))) + then + Ent := First_Entity (E); + + while Present (Ent) loop + if Entity_Needs_Body (Ent) then + return True; + end if; + + Next_Entity (Ent); + end loop; + + return False; + + else + return False; + end if; + end Entity_Needs_Body; + + -- Start of processing for Check_Body_Needed_For_SAL + + begin + if Ekind (Unit_Name) = E_Generic_Package + and then + Nkind (Unit_Declaration_Node (Unit_Name)) = + N_Generic_Package_Declaration + and then + Present (Corresponding_Body (Unit_Declaration_Node (Unit_Name))) + then + Set_Body_Needed_For_SAL (Unit_Name); + + elsif Ekind (Unit_Name) = E_Generic_Procedure + or else Ekind (Unit_Name) = E_Generic_Function + then + Set_Body_Needed_For_SAL (Unit_Name); + + elsif Is_Subprogram (Unit_Name) + and then Nkind (Unit_Declaration_Node (Unit_Name)) = + N_Subprogram_Declaration + and then Has_Pragma_Inline (Unit_Name) + then + Set_Body_Needed_For_SAL (Unit_Name); + + elsif Ekind (Unit_Name) = E_Subprogram_Body then + Check_Body_Needed_For_SAL + (Corresponding_Spec (Unit_Declaration_Node (Unit_Name))); + + elsif Ekind (Unit_Name) = E_Package + and then Entity_Needs_Body (Unit_Name) + then + Set_Body_Needed_For_SAL (Unit_Name); + + elsif Ekind (Unit_Name) = E_Package_Body + and then Nkind (Unit_Declaration_Node (Unit_Name)) = N_Package_Body + then + Check_Body_Needed_For_SAL + (Corresponding_Spec (Unit_Declaration_Node (Unit_Name))); + end if; + end Check_Body_Needed_For_SAL; + -------------------- -- Remove_Context -- -------------------- @@ -2905,6 +3661,12 @@ package body Sem_Ch10 is -- on entry, as indicated by their Context_Installed flag set if Nkind (Item) = N_With_Clause + and then Limited_Present (Item) + and then Limited_View_Installed (Item) + then + Remove_Limited_With_Clause (Item); + + elsif Nkind (Item) = N_With_Clause and then Context_Installed (Item) then -- Remove items from one with'ed unit @@ -2928,6 +3690,52 @@ package body Sem_Ch10 is end Remove_Context_Clauses; + -------------------------------- + -- Remove_Limited_With_Clause -- + -------------------------------- + + procedure Remove_Limited_With_Clause (N : Node_Id) is + P_Unit : Entity_Id := Unit (Library_Unit (N)); + P : Entity_Id := Defining_Unit_Name (Specification (P_Unit)); + + Lim_Elmt : Elmt_Id; + Lim_Typ : Entity_Id; + + begin + if Nkind (P) = N_Defining_Program_Unit_Name then + + -- Retrieve entity of Child package + + P := Defining_Identifier (P); + end if; + + -- Remove all shadow entities from visibility + + Lim_Elmt := First_Elmt (Limited_Views (P)); + + while Present (Lim_Elmt) loop + Lim_Typ := Node (Lim_Elmt); + + Unchain (Lim_Typ); + Next_Elmt (Lim_Elmt); + end loop; + + -- If the exporting package has previously been analyzed, it + -- has appeared in the closure already and should be left alone. + -- Otherwise, remove package itself from visibility. + + if not Analyzed (P_Unit) then + Unchain (P); + Set_First_Entity (P, Empty); + Set_Last_Entity (P, Empty); + Set_Ekind (P, E_Void); + Set_Scope (P, Empty); + Set_Is_Immediately_Visible (P, False); + end if; + + Set_Limited_View_Installed (N, False); + end Remove_Limited_With_Clause; + -------------------- -- Remove_Parents -- -------------------- @@ -2942,7 +3750,7 @@ package body Sem_Ch10 is begin if Is_Child_Spec (Lib_Unit) then P := Unit (Parent_Spec (Lib_Unit)); - P_Name := Defining_Entity (P); + P_Name := Get_Parent_Entity (P); Remove_Context_Clauses (Parent_Spec (Lib_Unit)); End_Package_Scope (P_Name); @@ -3005,7 +3813,7 @@ package body Sem_Ch10 is Prev := Homonym (Prev); end loop; - if (Present (Prev)) then + if Present (Prev) then Set_Homonym (Prev, Homonym (E)); end if; end if; @@ -3069,7 +3877,7 @@ package body Sem_Ch10 is --------------------------------- procedure Remove_Unit_From_Visibility (Unit_Name : Entity_Id) is - P : Entity_Id := Scope (Unit_Name); + P : constant Entity_Id := Scope (Unit_Name); begin @@ -3088,4 +3896,32 @@ package body Sem_Ch10 is end Remove_Unit_From_Visibility; + ------------- + -- Unchain -- + ------------- + + procedure Unchain (E : Entity_Id) is + Prev : Entity_Id; + + begin + Prev := Current_Entity (E); + + if No (Prev) then + return; + + elsif Prev = E then + Set_Name_Entity_Id (Chars (E), Homonym (E)); + + else + while Present (Prev) + and then Homonym (Prev) /= E + loop + Prev := Homonym (Prev); + end loop; + + if Present (Prev) then + Set_Homonym (Prev, Homonym (E)); + end if; + end if; + end Unchain; end Sem_Ch10; |