diff options
Diffstat (limited to 'gcc/ada/sem_ch12.adb')
| -rw-r--r-- | gcc/ada/sem_ch12.adb | 121 |
1 files changed, 57 insertions, 64 deletions
diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index cbb0deb..702939a 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -599,8 +599,8 @@ package body Sem_Ch12 is -- whose views can change between the point of instantiation and the point -- of instantiation of the body. In addition, mark the generic renamings -- as generic actuals, so that they are not compatible with other actuals. - -- Recurse on an actual that is a formal package whose declaration has - -- a box. + -- For an instantiation of a formal package that is declared with a box or + -- contains defaulted parameters, make the corresponding actuals visible. function Component_Type_For_Private_View (T : Entity_Id) return Entity_Id; -- Return the component type of array type T, with the following addition: @@ -944,6 +944,13 @@ package body Sem_Ch12 is -- Restore suffix 'P' to primitives of Prims_List and leave Prims_List -- set to No_Elist. + procedure Restore_Private_Views (Pack_Id : Entity_Id; Is_Package : Boolean); + -- Restore the private views of external types, and unmark the generic + -- renamings of actuals, so that they become compatible subtypes again. + -- Reset the visibility of the actuals (some of them may have been made + -- visible by Check_Generic_Actuals). For subprograms, Pack_Id is the + -- wrapper package built to hold the renamings and Is_Package is False. + procedure Set_Instance_Env (Gen_Unit : Entity_Id; Act_Unit : Entity_Id); @@ -958,6 +965,10 @@ package body Sem_Ch12 is -- Associate analyzed generic parameter with corresponding instance. Used -- for semantic checks at instantiation time. + procedure Switch_View (T : Entity_Id); + -- Switch the partial and full views of a type, as well as those of its + -- private dependents (i.e. its subtypes and derived types). + function True_Parent (N : Node_Id) return Node_Id; -- For a subunit, return parent of corresponding stub, else return -- parent of node. @@ -1080,18 +1091,6 @@ package body Sem_Ch12 is Table_Increment => 100, Table_Name => "Instance_Envs"); - procedure Restore_Private_Views - (Pack_Id : Entity_Id; - Is_Package : Boolean := True); - -- Restore the private views of external types, and unmark the generic - -- renamings of actuals, so that they become compatible subtypes again. - -- For subprograms, Pack_Id is the package constructed to hold the - -- renamings. - - procedure Switch_View (T : Entity_Id); - -- Switch the partial and full views of a type and its private - -- dependents (i.e. its subtypes and derived types). - ------------------------------------ -- Structures for Error Reporting -- ------------------------------------ @@ -1607,8 +1606,8 @@ package body Sem_Ch12 is return Result : Actual_Rec do case Nkind (Un_Formal) is when N_Formal_Object_Declaration => - if Present (Default_Expression (Un_Formal)) then - Result := (Name_Exp, Default_Expression (Un_Formal)); + if Present (Expression (Un_Formal)) then + Result := (Name_Exp, Expression (Un_Formal)); end if; when N_Formal_Type_Declaration => if Present (Default_Subtype_Mark (Un_Formal)) then @@ -1663,18 +1662,14 @@ package body Sem_Ch12 is if Box_Present (Src_Assoc) then Assoc.Actual := (Kind => Box_Actual); - if False then -- ??? - -- Disable this for now, because we have various - -- code that needs to be updated. - Error_Msg_N - ("box requires named notation", Src_Assoc); - end if; + Error_Msg_N ("box requires named notation", Src_Assoc); else Assoc.Actual := (Name_Exp, Explicit_Generic_Actual_Parameter (Src_Assoc)); pragma Assert (Present (Assoc.Actual.Name_Exp)); end if; + Assoc.Actual_Origin := From_Explicit_Actual; Next (Src_Assoc); @@ -2557,7 +2552,7 @@ package body Sem_Ch12 is (Defining_Identifier (Assoc.Un_Formal), Sloc (N)), Explicit_Generic_Actual_Parameter => - New_Copy_Tree (Default_Expression (Assoc.Un_Formal)))); + New_Copy_Tree (Expression (Assoc.Un_Formal)))); end if; end if; @@ -3361,7 +3356,7 @@ package body Sem_Ch12 is --------------------------------------- procedure Analyze_Formal_Object_Declaration (N : Node_Id) is - E : constant Node_Id := Default_Expression (N); + E : constant Node_Id := Expression (N); Id : constant Node_Id := Defining_Identifier (N); K : Entity_Kind; @@ -5696,7 +5691,7 @@ package body Sem_Ch12 is Check_Formal_Packages (Act_Decl_Id); Restore_Hidden_Primitives (Vis_Prims_List); - Restore_Private_Views (Act_Decl_Id); + Restore_Private_Views (Act_Decl_Id, Is_Package => True); Inherit_Context (Gen_Decl, N); @@ -7218,7 +7213,7 @@ package body Sem_Ch12 is if not Is_Intrinsic_Subprogram (Act_Decl_Id) then Inherit_Context (Gen_Decl, N); - Restore_Private_Views (Pack_Id, False); + Restore_Private_Views (Pack_Id, Is_Package => False); -- If the context requires a full instantiation, mark node for -- subsequent construction of the body. @@ -8571,9 +8566,6 @@ package body Sem_Ch12 is Set_Is_Generic_Actual_Type (Full_View (E)); end if; - Set_Is_Hidden (E, False); - Set_Is_Potentially_Use_Visible (E, In_Use (Instance)); - -- We constructed the generic actual type as a subtype of the -- supplied type. This means that it normally would not inherit -- subtype specific attributes of the actual, which is wrong for @@ -8627,21 +8619,15 @@ package body Sem_Ch12 is (Renamed_Entity (E), Is_Formal_Box => Box_Present (Parent (Associated_Formal_Package (E)))); - - Set_Is_Hidden (E, False); end if; - - -- If this is a subprogram instance (in a wrapper package) the - -- actual is fully visible. - - elsif Is_Wrapper_Package (Instance) then - Set_Is_Hidden (E, False); + end if; -- If the formal package is declared with a box, or if the formal - -- parameter is defaulted, it is visible in the body. + -- parameter is defaulted, the actual is visible in the instance. - elsif Is_Formal_Box or else Is_Visible_Formal (E) then + if Is_Formal_Box or else Is_Visible_Formal (E) then Set_Is_Hidden (E, False); + Set_Is_Potentially_Use_Visible (E, In_Use (Instance)); end if; -- Check directly the type of the actual objects, including the @@ -11660,8 +11646,10 @@ package body Sem_Ch12 is null; elsif Present (Associated_Formal_Package (E)) then - Check_Generic_Actuals (Renamed_Entity (E), True); - Set_Is_Hidden (E, False); + Check_Generic_Actuals + (Renamed_Entity (E), + Is_Formal_Box => + Box_Present (Parent (Associated_Formal_Package (E)))); -- Find formal package in generic unit that corresponds to -- (instance of) formal package in instance. @@ -12450,7 +12438,7 @@ package body Sem_Ch12 is (Nkind (Actual_Of_Formal) = N_Package_Instantiation); end if; - Next (Actual_Of_Formal); + Next_Non_Pragma (Actual_Of_Formal); -- A formal subprogram may be overloaded, so advance in -- the list of actuals to make sure we do not match two @@ -13223,7 +13211,7 @@ package body Sem_Ch12 is -- to capture local names that may be hidden if the generic is -- a child unit. - if Nkind (Actual) = N_Aggregate then + if Nkind (Unqualify (Actual)) = N_Aggregate then Preanalyze_And_Resolve (Actual, Typ); end if; @@ -13236,7 +13224,7 @@ package body Sem_Ch12 is end if; end; - elsif Present (Default_Expression (Formal)) then + elsif Present (Expression (Formal)) then -- Use default to construct declaration @@ -13254,7 +13242,7 @@ package body Sem_Ch12 is Null_Exclusion_Present => Null_Exclusion_Present (Formal), Object_Definition => Def, Expression => New_Copy_Tree - (Default_Expression (Formal))); + (Expression (Formal))); Copy_Ghost_Aspect (Formal, To => Decl_Node); Set_Corresponding_Generic_Association @@ -13679,7 +13667,7 @@ package body Sem_Ch12 is Set_Defining_Unit_Name (Act_Body, Act_Body_Name); Set_Corresponding_Spec (Act_Body, Act_Decl_Id); - Check_Generic_Actuals (Act_Decl_Id, False); + Check_Generic_Actuals (Act_Decl_Id, Is_Formal_Box => False); Check_Initialized_Types; -- Install primitives hidden at the point of the instantiation but @@ -13927,7 +13915,7 @@ package body Sem_Ch12 is -- the two mechanisms swap exactly the same entities, in particular -- the private entities dependent on the primary private entities. - Restore_Private_Views (Act_Decl_Id); + Restore_Private_Views (Act_Decl_Id, Is_Package => True); -- Remove the current unit from visibility if this is an instance -- that is not elaborated on the fly for inlining purposes. @@ -14174,7 +14162,7 @@ package body Sem_Ch12 is Set_Corresponding_Spec (Act_Body, Act_Decl_Id); Set_Has_Completion (Act_Decl_Id); - Check_Generic_Actuals (Pack_Id, False); + Check_Generic_Actuals (Pack_Id, Is_Formal_Box => False); -- Generate a reference to link the visible subprogram instance to -- the generic body, which for navigation purposes is the only @@ -14245,7 +14233,7 @@ package body Sem_Ch12 is Inherit_Context (Gen_Body, Inst_Node); - Restore_Private_Views (Pack_Id, False); + Restore_Private_Views (Pack_Id, Is_Package => False); if Par_Installed then Remove_Parent (In_Body => True); @@ -17093,10 +17081,18 @@ package body Sem_Ch12 is Saved : Instance_Env renames Instance_Envs.Table (Instance_Envs.Last); begin - if No (Current_Instantiated_Parent.Act_Id) then - -- Restore environment after subprogram inlining + -- Restore environment after subprogram inlining - Restore_Private_Views (Empty); + if No (Current_Instantiated_Parent.Act_Id) then + declare + M : Elmt_Id; + begin + M := First_Elmt (Exchanged_Views); + while Present (M) loop + Exchange_Declarations (Node (M)); + Next_Elmt (M); + end loop; + end; end if; Current_Instantiated_Parent := Saved.Instantiated_Parent; @@ -17115,9 +17111,7 @@ package body Sem_Ch12 is -- Restore_Private_Views -- --------------------------- - procedure Restore_Private_Views - (Pack_Id : Entity_Id; - Is_Package : Boolean := True) + procedure Restore_Private_Views (Pack_Id : Entity_Id; Is_Package : Boolean) is M : Elmt_Id; E : Entity_Id; @@ -17136,6 +17130,7 @@ package body Sem_Ch12 is procedure Restore_Nested_Formal (Formal : Entity_Id) is pragma Assert (Ekind (Formal) = E_Package); Ent : Entity_Id; + begin if Present (Renamed_Entity (Formal)) and then Denotes_Formal_Package (Renamed_Entity (Formal), True) @@ -17198,16 +17193,13 @@ package body Sem_Ch12 is Next_Elmt (M); end loop; - if No (Pack_Id) then - return; - end if; - -- Make the generic formal parameters private, and make the formal types -- into subtypes of the actuals again. E := First_Entity (Pack_Id); while Present (E) loop - Set_Is_Hidden (E, True); + Set_Is_Hidden (E); + Set_Is_Potentially_Use_Visible (E, False); if Is_Type (E) and then Nkind (Parent (E)) = N_Subtype_Declaration @@ -17231,6 +17223,7 @@ package body Sem_Ch12 is (Entity (Subtype_Indication (Parent (E)))) then null; + else Set_Is_Generic_Actual_Type (E, False); @@ -17275,7 +17268,7 @@ package body Sem_Ch12 is -- If the actual is itself a formal package for the enclosing -- generic, or the actual for such a formal package, it remains -- visible on exit from the instance, and therefore nothing needs - -- to be done either, except to keep it accessible. + -- to be done either. if Is_Package and then Renamed_Entity (E) = Pack_Id then exit; @@ -17286,7 +17279,7 @@ package body Sem_Ch12 is elsif Denotes_Formal_Package (Renamed_Entity (E), True, Pack_Id) then - Set_Is_Hidden (E, False); + null; else declare @@ -17301,8 +17294,8 @@ package body Sem_Ch12 is exit when Ekind (Id) = E_Package and then Renamed_Entity (Id) = Act_P; - Set_Is_Hidden (Id, True); - Set_Is_Potentially_Use_Visible (Id, In_Use (Act_P)); + Set_Is_Hidden (Id); + Set_Is_Potentially_Use_Visible (Id, False); if Ekind (Id) = E_Package then Restore_Nested_Formal (Id); |