diff options
Diffstat (limited to 'gcc/ada/sem_ch12.adb')
| -rw-r--r-- | gcc/ada/sem_ch12.adb | 184 |
1 files changed, 99 insertions, 85 deletions
diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index 3575b04..cbb0deb 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -480,14 +480,16 @@ package body Sem_Ch12 is -- Create a new access type with the given designated type function Analyze_Associations - (N : Node_Id; - Formals : List_Id; - F_Copy : List_Id) return List_Id; + (N : Node_Id; + Formals : List_Id; + F_Copy : List_Id; + Parent_Installed : Boolean) return List_Id; -- At instantiation time, build the list of associations between formals -- and actuals. Each association becomes a renaming declaration for the -- formal entity. N is the instantiation node. Formals is the list of - -- unanalyzed formals. F_Copy is the analyzed list of formals in the - -- generic copy. + -- unanalyzed formals. F_Copy is the list of analyzed formals in the + -- generic copy. Parent_Installed is True if the parent has been installed + -- during the instantiation. procedure Analyze_Subprogram_Instantiation (N : Node_Id; @@ -838,9 +840,12 @@ package body Sem_Ch12 is -- the same list it is passing to Actual_Decls. function Instantiate_Formal_Subprogram - (Formal : Node_Id; - Actual : Node_Id; - Analyzed_Formal : Node_Id) return Node_Id; + (Formal : Node_Id; + Actual : Node_Id; + Analyzed_Formal : Node_Id; + Parent_Installed : Boolean) return Node_Id; + -- Parent_Installed is True if the parent has been installed during the + -- instantiation. function Instantiate_Formal_Package (Formal : Node_Id; @@ -1283,12 +1288,14 @@ package body Sem_Ch12 is procedure Analyze_One_Association (N : Node_Id; Assoc : Associations.Assoc_Rec; + Parent_Installed : Boolean; Result_Renamings : List_Id; Default_Actuals : List_Id; Actuals_To_Freeze : Elist_Id); - -- Called by Analyze_Associations for each association. The renamings - -- are appended onto Result_Renamings. Defaulted actuals are appended - -- onto Default_Actuals, and actuals that require freezing are + -- Called by Analyze_Associations for each association. Parent_Installed + -- is True if the parent has been installed during the instantiation. The + -- renamings are appended onto Result_Renamings. The defaulted actuals are + -- appended onto Default_Actuals, and actuals that require freezing are -- appended onto Actuals_To_Freeze. procedure Analyze_Structural_Associations @@ -2362,9 +2369,10 @@ package body Sem_Ch12 is -------------------------- function Analyze_Associations - (N : Node_Id; - Formals : List_Id; - F_Copy : List_Id) return List_Id + (N : Node_Id; + Formals : List_Id; + F_Copy : List_Id; + Parent_Installed : Boolean) return List_Id is use Associations; @@ -2412,6 +2420,7 @@ package body Sem_Ch12 is Analyze_One_Association (N, Assoc, + Parent_Installed, Result_Renamings, Default_Actuals, Actuals_To_Freeze); @@ -2470,6 +2479,7 @@ package body Sem_Ch12 is procedure Analyze_One_Association (N : Node_Id; Assoc : Associations.Assoc_Rec; + Parent_Installed : Boolean; Result_Renamings : List_Id; Default_Actuals : List_Id; Actuals_To_Freeze : Elist_Id) @@ -2736,7 +2746,10 @@ package body Sem_Ch12 is else Append_To (Result_Renamings, Instantiate_Formal_Subprogram - (Assoc.Un_Formal, Match, Assoc.An_Formal)); + (Assoc.Un_Formal, + Match, + Assoc.An_Formal, + Parent_Installed)); -- If formal subprogram has contracts, create wrappers -- for it. This is an expansion activity that cannot @@ -3557,7 +3570,7 @@ package body Sem_Ch12 is -- List of primitives made temporarily visible in the instantiation -- to match the visibility of the formal type. - function Build_Local_Package return Node_Id; + function Build_Local_Package (Parent_Installed : Boolean) return Node_Id; -- The formal package is rewritten so that its parameters are replaced -- with corresponding declarations. For parameters with bona fide -- associations these declarations are created by Analyze_Associations @@ -3569,7 +3582,8 @@ package body Sem_Ch12 is -- Build_Local_Package -- ------------------------- - function Build_Local_Package return Node_Id is + function Build_Local_Package (Parent_Installed : Boolean) return Node_Id + is Decls : List_Id; Pack_Decl : Node_Id; @@ -3639,15 +3653,16 @@ package body Sem_Ch12 is Instantiating => True); begin - Generic_Renamings.Set_Last (0); + Generic_Renamings.Clear; Generic_Renamings_HTable.Reset; Instantiation_Node := N; Decls := Analyze_Associations - (N => Original_Node (N), - Formals => Generic_Formal_Declarations (Act_Tree), - F_Copy => Generic_Formal_Declarations (Gen_Decl)); + (N => Original_Node (N), + Formals => Generic_Formal_Declarations (Act_Tree), + F_Copy => Generic_Formal_Declarations (Gen_Decl), + Parent_Installed => Parent_Installed); Vis_Prims_List := Check_Hidden_Primitives (Decls); end; @@ -3782,7 +3797,7 @@ package body Sem_Ch12 is -- internal declarations. begin - New_N := Build_Local_Package; + New_N := Build_Local_Package (Parent_Installed); -- If there are errors in the parameter list, Analyze_Associations -- raises Instantiation_Error. Patch the declaration to prevent further @@ -3868,6 +3883,7 @@ package body Sem_Ch12 is Renaming_In_Par := Make_Defining_Identifier (Loc, Chars (Gen_Unit)); Mutate_Ekind (Renaming_In_Par, E_Package); + Set_Is_Internal (Renaming_In_Par); Set_Is_Not_Self_Hidden (Renaming_In_Par); Set_Etype (Renaming_In_Par, Standard_Void_Type); Set_Scope (Renaming_In_Par, Parent_Instance); @@ -4998,7 +5014,7 @@ package body Sem_Ch12 is -- inherited from formal packages of parent units, and these are -- constructed when the parents are installed. - Generic_Renamings.Set_Last (0); + Generic_Renamings.Clear; Generic_Renamings_HTable.Reset; -- Except for an abbreviated instance created to check a formal package, @@ -5159,9 +5175,10 @@ package body Sem_Ch12 is Renamings := Analyze_Associations - (N => N, - Formals => Generic_Formal_Declarations (Act_Tree), - F_Copy => Generic_Formal_Declarations (Gen_Decl)); + (N => N, + Formals => Generic_Formal_Declarations (Act_Tree), + F_Copy => Generic_Formal_Declarations (Gen_Decl), + Parent_Installed => Parent_Installed); -- Bail out if the instantiation has been turned into something else @@ -6718,7 +6735,7 @@ package body Sem_Ch12 is -- Remove package itself from visibility, so it does not -- conflict with subprogram. - Set_Name_Entity_Id (Chars (Pack_Id), Homonym (Pack_Id)); + Remove_Homonym (Pack_Id); -- Set name and scope of internal subprogram so that the proper -- external name will be generated. The proper scope is the scope @@ -6962,7 +6979,7 @@ package body Sem_Ch12 is -- Initialize renamings map, for error checking - Generic_Renamings.Set_Last (0); + Generic_Renamings.Clear; Generic_Renamings_HTable.Reset; Create_Instantiation_Source (N, Gen_Unit, S_Adjustment); @@ -6981,9 +6998,10 @@ package body Sem_Ch12 is Renamings := Analyze_Associations - (N => N, - Formals => Generic_Formal_Declarations (Act_Tree), - F_Copy => Generic_Formal_Declarations (Gen_Decl)); + (N => N, + Formals => Generic_Formal_Declarations (Act_Tree), + F_Copy => Generic_Formal_Declarations (Gen_Decl), + Parent_Installed => Parent_Installed); -- Bail out if the instantiation has been turned into something else @@ -7236,7 +7254,7 @@ package body Sem_Ch12 is Restore_Hidden_Primitives (Vis_Prims_List); Restore_Env; Env_Installed := False; - Generic_Renamings.Set_Last (0); + Generic_Renamings.Clear; Generic_Renamings_HTable.Reset; end if; @@ -12538,9 +12556,10 @@ package body Sem_Ch12 is ----------------------------------- function Instantiate_Formal_Subprogram - (Formal : Node_Id; - Actual : Node_Id; - Analyzed_Formal : Node_Id) return Node_Id + (Formal : Node_Id; + Actual : Node_Id; + Analyzed_Formal : Node_Id; + Parent_Installed : Boolean) return Node_Id is Analyzed_S : constant Entity_Id := Defining_Unit_Name (Specification (Analyzed_Formal)); @@ -12548,13 +12567,7 @@ package body Sem_Ch12 is Defining_Unit_Name (Specification (Formal)); function From_Parent_Scope (Subp : Entity_Id) return Boolean; - -- If the generic is a child unit, the parent has been installed on the - -- scope stack, but a default subprogram cannot resolve to something - -- on the parent because that parent is not really part of the visible - -- context (it is there to resolve explicit local entities). If the - -- default has resolved in this way, we remove the entity from immediate - -- visibility and analyze the node again to emit an error message or - -- find another visible candidate. + -- Return true if Subp is declared in a parent scope of Analyzed_S procedure Valid_Actual_Subprogram (Act : Node_Id); -- Perform legality check and raise exception on failure @@ -12812,21 +12825,31 @@ package body Sem_Ch12 is end if; -- Gather possible interpretations for the actual before analyzing the - -- instance. If overloaded, it will be resolved when analyzing the - -- renaming declaration. + -- instance. If the actual is overloaded, then it will be resolved when + -- the renaming declaration is analyzed. if Box_Present (Formal) and then No (Actual) then Analyze (Nam); - if Is_Child_Unit (Scope (Analyzed_S)) - and then Present (Entity (Nam)) + -- If the generic is a child unit and the parent has been installed + -- during this instantiation (as opposed to having been installed in + -- the context of the instantiation at some earlier point), a default + -- subprogram cannot resolve to something in the parent because the + -- parent is not really part of the visible context (it is there to + -- resolve explicit local entities). If the default subprogram has + -- been resolved in this way, we remove the entity from immediate + -- visibility and analyze the node again to emit an error message + -- or find another visible candidate. + + if Present (Entity (Nam)) + and then Is_Child_Unit (Scope (Analyzed_S)) + and then Parent_Installed then if not Is_Overloaded (Nam) then if From_Parent_Scope (Entity (Nam)) then Set_Is_Immediately_Visible (Entity (Nam), False); Set_Entity (Nam, Empty); Set_Etype (Nam, Empty); - Analyze (Nam); Set_Is_Immediately_Visible (Entity (Nam)); end if; @@ -17639,6 +17662,8 @@ package body Sem_Ch12 is Set_Etype (N2, E); end if; + -- If the entity is global, save its type in the generic node + if Is_Global (E) then Set_Global_Type (N, N2); @@ -17659,12 +17684,24 @@ package body Sem_Ch12 is Set_Etype (N, Empty); end if; + -- If default actuals have been added to a generic instantiation + -- and they are global, save them in the generic node. + if Nkind (Parent (N)) in N_Generic_Instantiation and then N = Name (Parent (N)) then Save_Global_Defaults (Parent (N), Parent (N2)); end if; + if Nkind (Parent (N)) = N_Selected_Component + and then N = Selector_Name (Parent (N)) + and then Nkind (Parent (Parent (N))) in N_Generic_Instantiation + and then Parent (N) = Name (Parent (Parent (N))) + then + Save_Global_Defaults + (Parent (Parent (N)), Parent (Parent (N2))); + end if; + elsif Nkind (Parent (N)) = N_Selected_Component and then Nkind (Parent (N2)) = N_Expanded_Name then @@ -18488,12 +18525,13 @@ package body Sem_Ch12 is elsif Nkind (N) = N_Pragma then Save_References_In_Pragma (N); + -- Aspects + elsif Nkind (N) = N_Aspect_Specification then declare P : constant Node_Id := Parent (N); - Expr : Node_Id; - begin + begin if Permits_Aspect_Specifications (P) then -- The capture of global references within aspects @@ -18505,15 +18543,11 @@ package body Sem_Ch12 is if Requires_Delayed_Save (Original_Node (P)) then null; - -- Otherwise save all global references within the - -- aspects - - else - Expr := Expression (N); + -- Otherwise save all global references within the + -- expression of the aspect. - if Present (Expr) then - Save_Global_References (Expr); - end if; + elsif Present (Expression (N)) then + Save_Global_References (Expression (N)); end if; end if; end; @@ -18523,10 +18557,11 @@ package body Sem_Ch12 is elsif Nkind (N) = N_Implicit_Label_Declaration then null; + -- Other nodes + else Save_References_In_Descendants (N); end if; - end Save_References; --------------------- @@ -18686,9 +18721,8 @@ package body Sem_Ch12 is procedure Set_Instance_Of (A : Entity_Id; B : Entity_Id) is begin - Generic_Renamings.Table (Generic_Renamings.Last) := (A, B, Assoc_Null); + Generic_Renamings.Append ((A, B, Assoc_Null)); Generic_Renamings_HTable.Set (Generic_Renamings.Last); - Generic_Renamings.Increment_Last; end Set_Instance_Of; -------------------- @@ -19321,39 +19355,22 @@ package body Sem_Ch12 is -------------------- function Save_And_Reset return Context is + First : constant Integer := Integer (Generic_Renamings.First); + Last : constant Integer := Integer (Generic_Renamings.Last); begin - return Result : Context (0 .. Integer (Generic_Renamings.Last)) do + return Result : Context (First .. Last) do for Index in Result'Range loop declare Indexed_Assoc : Assoc renames Generic_Renamings.Table (Assoc_Ptr (Index)); Result_Pair : Binding_Pair renames Result (Index); begin - -- If we have called Increment_Last but have not yet - -- initialized the new last element of the table, then - -- that last element might be invalid. Saving and - -- restoring (especially restoring, it turns out) invalid - -- values can result in exceptions if predicate checking - -- is enabled, so replace invalid values with Empty. - - if Indexed_Assoc.Gen_Id'Valid then - Result_Pair.Formal_Id := Indexed_Assoc.Gen_Id; - else - pragma Assert (Index = Result'Last); - Result_Pair.Formal_Id := Empty; - end if; - - if Indexed_Assoc.Act_Id'Valid then - Result_Pair.Actual_Id := Indexed_Assoc.Act_Id; - else - pragma Assert (Index = Result'Last); - Result_Pair.Actual_Id := Empty; - end if; + Result_Pair.Formal_Id := Indexed_Assoc.Gen_Id; + Result_Pair.Actual_Id := Indexed_Assoc.Act_Id; end; end loop; Generic_Renamings.Init; - Generic_Renamings.Set_Last (-1); Generic_Renamings_HTable.Reset; end return; end Save_And_Reset; @@ -19365,13 +19382,10 @@ package body Sem_Ch12 is procedure Restore (Saved : Context) is begin Generic_Renamings.Init; - Generic_Renamings.Set_Last (0); Generic_Renamings_HTable.Reset; - Generic_Renamings.Increment_Last; for Pair of Saved loop Set_Instance_Of (Pair.Formal_Id, Pair.Actual_Id); end loop; - Generic_Renamings.Decrement_Last; end Restore; end Instance_Context; |