From 4f94fa1186d071b2f4b5d864acb4b0427cb63368 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Thu, 19 Jan 2017 12:55:21 +0100 Subject: [PATCH] [multiple changes] 2017-01-19 Javier Miranda * exp_ch6.adb (Expand_Call): Remove side effects on actuals that are allocators with qualified expression since the initialization of the object is performed by means of individual statements (and hence it must be done before the call). 2017-01-19 Ed Schonberg * sem_ch3.adb (Analyze_Declarations): Minor reformatting. (Build_Derived_Enumeration_Type): If the derived type inherits a dynamic predicate from its parent, the bounds of the type must freeze because an explicit constraint is constructed for the type and the corresponding range is elaborated now. 2017-01-19 Arnaud Charlet * sem_attr.ads: minor fix of inconsistent casing in comment * lib-writ.ads: minor align comments in columns * sem_ch3.adb: Minor reformatting. * spark_xrefs.ads: minor fix typo in SPARK-related comment * table.ads: minor style fix in comment * lib-xref-spark_specific.adb (Add_SPARK_Xrefs): simplify processing of SPARK cross-references. * sem_ch12.adb: minor whitespace fix * freeze.adb: Add comment. * sem_util.adb (Unique_Name): for instances of generic subprograms ignore the name of the wrapper package. 2017-01-19 Javier Miranda * exp_aggr.adb (Resolve_Record_Aggregate): Factorize code needed for aggregates of limited and unlimited types in a new routine. (Pass_Aggregate_To_Back_End): New subprogram. 2017-01-19 Yannick Moy * sinfo.adb (Pragma_Name): Only access up to Last_Pair of Pragma_Map. From-SVN: r244622 --- gcc/ada/ChangeLog | 40 ++++ gcc/ada/exp_aggr.adb | 306 +++++++++++++++------------- gcc/ada/exp_ch6.adb | 11 + gcc/ada/freeze.adb | 3 + gcc/ada/lib-writ.ads | 40 ++-- gcc/ada/lib-xref-spark_specific.adb | 24 +-- gcc/ada/sem_attr.ads | 2 +- gcc/ada/sem_ch12.adb | 3 +- gcc/ada/sem_ch3.adb | 19 +- gcc/ada/sem_util.adb | 82 +++++--- gcc/ada/sinfo.adb | 2 +- gcc/ada/spark_xrefs.ads | 2 +- gcc/ada/table.ads | 4 +- 13 files changed, 322 insertions(+), 216 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 5eda55755df..4782ab70910 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,43 @@ +2017-01-19 Javier Miranda + + * exp_ch6.adb (Expand_Call): Remove side effects on + actuals that are allocators with qualified expression since the + initialization of the object is performed by means of individual + statements (and hence it must be done before the call). + +2017-01-19 Ed Schonberg + + * sem_ch3.adb (Analyze_Declarations): Minor reformatting. + (Build_Derived_Enumeration_Type): If the derived type inherits a + dynamic predicate from its parent, the bounds of the type must + freeze because an explicit constraint is constructed for the + type and the corresponding range is elaborated now. + +2017-01-19 Arnaud Charlet + + * sem_attr.ads: minor fix of inconsistent casing in comment + * lib-writ.ads: minor align comments in columns + * sem_ch3.adb: Minor reformatting. + * spark_xrefs.ads: minor fix typo in SPARK-related comment + * table.ads: minor style fix in comment + * lib-xref-spark_specific.adb + (Add_SPARK_Xrefs): simplify processing of SPARK cross-references. + * sem_ch12.adb: minor whitespace fix + * freeze.adb: Add comment. + * sem_util.adb (Unique_Name): for instances of + generic subprograms ignore the name of the wrapper package. + +2017-01-19 Javier Miranda + + * exp_aggr.adb (Resolve_Record_Aggregate): + Factorize code needed for aggregates of limited and unlimited + types in a new routine. + (Pass_Aggregate_To_Back_End): New subprogram. + +2017-01-19 Yannick Moy + + * sinfo.adb (Pragma_Name): Only access up to Last_Pair of Pragma_Map. + 2017-01-19 Ed Schonberg * sem_ch4.ads, sem_ch4.adb (Try_Object_Operation): Make subprogram diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb index 25647048951..81134024993 100644 --- a/gcc/ada/exp_aggr.adb +++ b/gcc/ada/exp_aggr.adb @@ -6545,6 +6545,9 @@ package body Exp_Aggr is -- because it will not be set when type and its parent are in the -- same scope, and the parent component needs expansion. + procedure Pass_Aggregate_To_Back_End; + -- Build a proper aggregate to be handled by the back-end + function Top_Level_Aggregate (N : Node_Id) return Node_Id; -- For nested aggregates return the ultimate enclosing aggregate; for -- non-nested aggregates return N. @@ -6723,155 +6726,16 @@ package body Exp_Aggr is end loop; end Has_Visible_Private_Ancestor; - ------------------------- - -- Top_Level_Aggregate -- - ------------------------- + -------------------------------- + -- Pass_Aggregate_To_Back_End -- + -------------------------------- - function Top_Level_Aggregate (N : Node_Id) return Node_Id is - Aggr : Node_Id; + procedure Pass_Aggregate_To_Back_End is + Comp : Entity_Id; + New_Comp : Node_Id; + Tag_Value : Node_Id; begin - Aggr := N; - while Present (Parent (Aggr)) - and then Nkind_In (Parent (Aggr), N_Component_Association, - N_Aggregate) - loop - Aggr := Parent (Aggr); - end loop; - - return Aggr; - end Top_Level_Aggregate; - - -- Local variables - - Top_Level_Aggr : constant Node_Id := Top_Level_Aggregate (N); - Tag_Value : Node_Id; - Comp : Entity_Id; - New_Comp : Node_Id; - - -- Start of processing for Expand_Record_Aggregate - - begin - -- If the aggregate is to be assigned to an atomic/VFA variable, we have - -- to prevent a piecemeal assignment even if the aggregate is to be - -- expanded. We create a temporary for the aggregate, and assign the - -- temporary instead, so that the back end can generate an atomic move - -- for it. - - if Is_Atomic_VFA_Aggregate (N) then - return; - - -- No special management required for aggregates used to initialize - -- statically allocated dispatch tables - - elsif Is_Static_Dispatch_Table_Aggregate (N) then - return; - end if; - - -- Ada 2005 (AI-318-2): We need to convert to assignments if components - -- are build-in-place function calls. The assignments will each turn - -- into a build-in-place function call. If components are all static, - -- we can pass the aggregate to the backend regardless of limitedness. - - -- Extension aggregates, aggregates in extended return statements, and - -- aggregates for C++ imported types must be expanded. - - if Ada_Version >= Ada_2005 and then Is_Limited_View (Typ) then - if not Nkind_In (Parent (N), N_Object_Declaration, - N_Component_Association) - then - Convert_To_Assignments (N, Typ); - - elsif Nkind (N) = N_Extension_Aggregate - or else Convention (Typ) = Convention_CPP - then - Convert_To_Assignments (N, Typ); - - elsif not Size_Known_At_Compile_Time (Typ) - or else Component_Not_OK_For_Backend - or else not Static_Components - then - Convert_To_Assignments (N, Typ); - - else - Set_Compile_Time_Known_Aggregate (N); - Set_Expansion_Delayed (N, False); - end if; - - -- Gigi doesn't properly handle temporaries of variable size so we - -- generate it in the front-end - - elsif not Size_Known_At_Compile_Time (Typ) - and then Tagged_Type_Expansion - then - Convert_To_Assignments (N, Typ); - - -- An aggregate used to initialize a controlled object must be turned - -- into component assignments as the components themselves may require - -- finalization actions such as adjustment. - - elsif Needs_Finalization (Typ) then - Convert_To_Assignments (N, Typ); - - -- Ada 2005 (AI-287): In case of default initialized components we - -- convert the aggregate into assignments. - - elsif Has_Default_Init_Comps (N) then - Convert_To_Assignments (N, Typ); - - -- Check components - - elsif Component_Not_OK_For_Backend then - Convert_To_Assignments (N, Typ); - - -- If an ancestor is private, some components are not inherited and we - -- cannot expand into a record aggregate. - - elsif Has_Visible_Private_Ancestor (Typ) then - Convert_To_Assignments (N, Typ); - - -- ??? The following was done to compile fxacc00.ads in the ACVCs. Gigi - -- is not able to handle the aggregate for Late_Request. - - elsif Is_Tagged_Type (Typ) and then Has_Discriminants (Typ) then - Convert_To_Assignments (N, Typ); - - -- If the tagged types covers interface types we need to initialize all - -- hidden components containing pointers to secondary dispatch tables. - - elsif Is_Tagged_Type (Typ) and then Has_Interfaces (Typ) then - Convert_To_Assignments (N, Typ); - - -- If some components are mutable, the size of the aggregate component - -- may be distinct from the default size of the type component, so - -- we need to expand to insure that the back-end copies the proper - -- size of the data. However, if the aggregate is the initial value of - -- a constant, the target is immutable and might be built statically - -- if components are appropriate. - - elsif Has_Mutable_Components (Typ) - and then - (Nkind (Parent (Top_Level_Aggr)) /= N_Object_Declaration - or else not Constant_Present (Parent (Top_Level_Aggr)) - or else not Static_Components) - then - Convert_To_Assignments (N, Typ); - - -- If the type involved has bit aligned components, then we are not sure - -- that the back end can handle this case correctly. - - elsif Type_May_Have_Bit_Aligned_Components (Typ) then - Convert_To_Assignments (N, Typ); - - -- When generating C, only generate an aggregate when declaring objects - -- since C does not support aggregates in e.g. assignment statements. - - elsif Modify_Tree_For_C and then not In_Object_Declaration (N) then - Convert_To_Assignments (N, Typ); - - -- In all other cases, build a proper aggregate to be handled by gigi - - else if Nkind (N) = N_Aggregate then -- If the aggregate is static and can be handled by the back-end, @@ -7164,8 +7028,158 @@ package body Exp_Aggr is end; end if; end if; + end Pass_Aggregate_To_Back_End; + + ------------------------- + -- Top_Level_Aggregate -- + ------------------------- + + function Top_Level_Aggregate (N : Node_Id) return Node_Id is + Aggr : Node_Id; + + begin + Aggr := N; + while Present (Parent (Aggr)) + and then Nkind_In (Parent (Aggr), N_Component_Association, + N_Aggregate) + loop + Aggr := Parent (Aggr); + end loop; + + return Aggr; + end Top_Level_Aggregate; + + -- Local variables + + Top_Level_Aggr : constant Node_Id := Top_Level_Aggregate (N); + + -- Start of processing for Expand_Record_Aggregate + + begin + -- If the aggregate is to be assigned to an atomic/VFA variable, we have + -- to prevent a piecemeal assignment even if the aggregate is to be + -- expanded. We create a temporary for the aggregate, and assign the + -- temporary instead, so that the back end can generate an atomic move + -- for it. + + if Is_Atomic_VFA_Aggregate (N) then + return; + + -- No special management required for aggregates used to initialize + -- statically allocated dispatch tables + + elsif Is_Static_Dispatch_Table_Aggregate (N) then + return; end if; + -- Ada 2005 (AI-318-2): We need to convert to assignments if components + -- are build-in-place function calls. The assignments will each turn + -- into a build-in-place function call. If components are all static, + -- we can pass the aggregate to the backend regardless of limitedness. + + -- Extension aggregates, aggregates in extended return statements, and + -- aggregates for C++ imported types must be expanded. + + if Ada_Version >= Ada_2005 and then Is_Limited_View (Typ) then + if not Nkind_In (Parent (N), N_Object_Declaration, + N_Component_Association) + then + Convert_To_Assignments (N, Typ); + + elsif Nkind (N) = N_Extension_Aggregate + or else Convention (Typ) = Convention_CPP + then + Convert_To_Assignments (N, Typ); + + elsif not Size_Known_At_Compile_Time (Typ) + or else Component_Not_OK_For_Backend + or else not Static_Components + then + Convert_To_Assignments (N, Typ); + + -- In all other cases, build a proper aggregate to be handled by + -- the back-end + + else + Pass_Aggregate_To_Back_End; + end if; + + -- Gigi doesn't properly handle temporaries of variable size so we + -- generate it in the front-end + + elsif not Size_Known_At_Compile_Time (Typ) + and then Tagged_Type_Expansion + then + Convert_To_Assignments (N, Typ); + + -- An aggregate used to initialize a controlled object must be turned + -- into component assignments as the components themselves may require + -- finalization actions such as adjustment. + + elsif Needs_Finalization (Typ) then + Convert_To_Assignments (N, Typ); + + -- Ada 2005 (AI-287): In case of default initialized components we + -- convert the aggregate into assignments. + + elsif Has_Default_Init_Comps (N) then + Convert_To_Assignments (N, Typ); + + -- Check components + + elsif Component_Not_OK_For_Backend then + Convert_To_Assignments (N, Typ); + + -- If an ancestor is private, some components are not inherited and we + -- cannot expand into a record aggregate. + + elsif Has_Visible_Private_Ancestor (Typ) then + Convert_To_Assignments (N, Typ); + + -- ??? The following was done to compile fxacc00.ads in the ACVCs. Gigi + -- is not able to handle the aggregate for Late_Request. + + elsif Is_Tagged_Type (Typ) and then Has_Discriminants (Typ) then + Convert_To_Assignments (N, Typ); + + -- If the tagged types covers interface types we need to initialize all + -- hidden components containing pointers to secondary dispatch tables. + + elsif Is_Tagged_Type (Typ) and then Has_Interfaces (Typ) then + Convert_To_Assignments (N, Typ); + + -- If some components are mutable, the size of the aggregate component + -- may be distinct from the default size of the type component, so + -- we need to expand to insure that the back-end copies the proper + -- size of the data. However, if the aggregate is the initial value of + -- a constant, the target is immutable and might be built statically + -- if components are appropriate. + + elsif Has_Mutable_Components (Typ) + and then + (Nkind (Parent (Top_Level_Aggr)) /= N_Object_Declaration + or else not Constant_Present (Parent (Top_Level_Aggr)) + or else not Static_Components) + then + Convert_To_Assignments (N, Typ); + + -- If the type involved has bit aligned components, then we are not sure + -- that the back end can handle this case correctly. + + elsif Type_May_Have_Bit_Aligned_Components (Typ) then + Convert_To_Assignments (N, Typ); + + -- When generating C, only generate an aggregate when declaring objects + -- since C does not support aggregates in e.g. assignment statements. + + elsif Modify_Tree_For_C and then not In_Object_Declaration (N) then + Convert_To_Assignments (N, Typ); + + -- In all other cases, build a proper aggregate to be handled by gigi + + else + Pass_Aggregate_To_Back_End; + end if; end Expand_Record_Aggregate; ---------------------------- diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index 22caddd6590..fef399f4def 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -3315,6 +3315,17 @@ package body Exp_Ch6 is Add_View_Conversion_Invariants (Formal, Actual); end if; + -- Generating C the initialization of an allocator is performed by + -- means of individual statements, and hence it must be done before + -- the call. + + if Modify_Tree_For_C + and then Nkind (Actual) = N_Allocator + and then Nkind (Expression (Actual)) = N_Qualified_Expression + then + Remove_Side_Effects (Actual); + end if; + -- This label is required when skipping extra actual generation for -- Unchecked_Union parameters. diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index 81524c1f4d1..2a453fe0020 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -5305,6 +5305,9 @@ package body Freeze is -- trigger the analysis of aspect expressions, so in this case we -- want to continue the freezing process. + -- Is_Generic_Unit (Scope (E)) is dubious here, do we want instead + -- In_Generic_Scope (E)??? + if Present (Scope (E)) and then Is_Generic_Unit (Scope (E)) and then diff --git a/gcc/ada/lib-writ.ads b/gcc/ada/lib-writ.ads index 0060c9e1869..f113b0a5993 100644 --- a/gcc/ada/lib-writ.ads +++ b/gcc/ada/lib-writ.ads @@ -192,8 +192,8 @@ package Lib.Writ is -- the units in this file, where x is the first character -- (upper case) of the policy name (e.g. 'C' for Concurrent). - -- FX Units in this file use front-end exceptions, with explicit - -- handlers to trigger AT-END actions on exception paths. + -- FX Units in this file use front-end exceptions, with explicit + -- handlers to trigger AT-END actions on exception paths. -- GP Set if this compilation was done in GNATprove mode, either -- from direct use of GNATprove, or from use of -gnatdF. @@ -240,12 +240,12 @@ package Lib.Writ is -- (upper case) of the corresponding policy name (e.g. 'F' -- for FIFO_Within_Priorities). - -- UA Unreserve_All_Interrupts pragma was processed in one or - -- more units in this file + -- UA Unreserve_All_Interrupts pragma was processed in one or + -- more units in this file - -- ZX Units in this file use zero-cost exceptions and have - -- generated exception tables. If ZX is not present, the - -- longjmp/setjmp exception scheme is in use. + -- ZX Units in this file use zero-cost exceptions and have + -- generated exception tables. If ZX is not present, the + -- longjmp/setjmp exception scheme is in use. -- Note that language defined units never output policy (Lx, Tx, Qx) -- parameters. Language defined units must correctly handle all @@ -570,22 +570,22 @@ package Lib.Writ is -- code is required. Set if N_Compilation_Unit node has flag -- Has_No_Elaboration_Code set. - -- OL The units in this file are compiled with a local pragma - -- Optimize_Alignment, so no consistency requirement applies - -- to these units. All internal units have this status since - -- they have an automatic default of Optimize_Alignment (Off). + -- OL The units in this file are compiled with a local pragma + -- Optimize_Alignment, so no consistency requirement applies + -- to these units. All internal units have this status since + -- they have an automatic default of Optimize_Alignment (Off). -- - -- OO Optimize_Alignment (Off) is the default setting for all - -- units in this file. All files in the partition that specify - -- a default must specify the same default. + -- OO Optimize_Alignment (Off) is the default setting for all + -- units in this file. All files in the partition that specify + -- a default must specify the same default. - -- OS Optimize_Alignment (Space) is the default setting for all - -- units in this file. All files in the partition that specify - -- a default must specify the same default. + -- OS Optimize_Alignment (Space) is the default setting for all + -- units in this file. All files in the partition that specify + -- a default must specify the same default. - -- OT Optimize_Alignment (Time) is the default setting for all - -- units in this file. All files in the partition that specify - -- a default must specify the same default. + -- OT Optimize_Alignment (Time) is the default setting for all + -- units in this file. All files in the partition that specify + -- a default must specify the same default. -- PF The unit has a library-level (package) finalizer diff --git a/gcc/ada/lib-xref-spark_specific.adb b/gcc/ada/lib-xref-spark_specific.adb index d00c4eed4e7..8cd50af281b 100644 --- a/gcc/ada/lib-xref-spark_specific.adb +++ b/gcc/ada/lib-xref-spark_specific.adb @@ -381,7 +381,7 @@ package body SPARK_Specific is Rnums : array (0 .. Nrefs + Nrefs_Add) of Nat; -- This array contains numbers of references in the Xrefs table. This -- list is sorted in output order. The extra 0'th entry is convenient - -- for the call to sort. When we sort the table, we move the entries in + -- for the call to sort. When we sort the table, we move the indices in -- Rnums around, but we do not move the original table entries. --------------------- @@ -683,7 +683,7 @@ package body SPARK_Specific is Col : Nat; From_Index : Xref_Index; Line : Nat; - Loc : Source_Ptr; + Prev_Loc : Source_Ptr; Prev_Typ : Character; Ref_Count : Nat; Ref_Id : Entity_Id; @@ -701,17 +701,9 @@ package body SPARK_Specific is end; end loop; - -- Set up the pointer vector for the sort - - for Index in 1 .. Nrefs loop - Rnums (Index) := Index; - end loop; - for Index in Drefs.First .. Drefs.Last loop Xrefs.Append (Drefs.Table (Index)); - - Nrefs := Nrefs + 1; - Rnums (Nrefs) := Xrefs.Last; + Nrefs := Nrefs + 1; end loop; -- Capture the definition Sloc values. As in the case of normal cross @@ -730,7 +722,7 @@ package body SPARK_Specific is for Index in 1 .. Ref_Count loop declare - Ref : Xref_Key renames Xrefs.Table (Rnums (Index)).Key; + Ref : Xref_Key renames Xrefs.Table (Index).Key; begin if SPARK_Entities (Ekind (Ref.Ent)) @@ -745,7 +737,7 @@ package body SPARK_Specific is and then Get_Scope_Num (Ref.Ref_Scope) /= No_Scope then Nrefs := Nrefs + 1; - Rnums (Nrefs) := Rnums (Index); + Rnums (Nrefs) := Index; end if; end; end loop; @@ -778,7 +770,7 @@ package body SPARK_Specific is Ref_Count := Nrefs; Nrefs := 0; - Loc := No_Location; + Prev_Loc := No_Location; Prev_Typ := 'm'; for Index in 1 .. Ref_Count loop @@ -786,10 +778,10 @@ package body SPARK_Specific is Ref : Xref_Key renames Xrefs.Table (Rnums (Index)).Key; begin - if Ref.Loc /= Loc + if Ref.Loc /= Prev_Loc or else (Prev_Typ = 'm' and then Ref.Typ = 'r') then - Loc := Ref.Loc; + Prev_Loc := Ref.Loc; Prev_Typ := Ref.Typ; Nrefs := Nrefs + 1; Rnums (Nrefs) := Rnums (Index); diff --git a/gcc/ada/sem_attr.ads b/gcc/ada/sem_attr.ads index c68ce0de954..38463ff6df0 100644 --- a/gcc/ada/sem_attr.ads +++ b/gcc/ada/sem_attr.ads @@ -402,7 +402,7 @@ package Sem_Attr is -- fixed-point types and discrete types. For fixed-point types and -- discrete types, this attribute gives the size used for default -- allocation of objects and components of the size. See section in - -- Einfo ("Handling of type'Size values") for further details. + -- Einfo ("Handling of Type'Size values") for further details. ------------------------- -- Passed_By_Reference -- diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index fadb831bb47..c43533603be 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -6372,8 +6372,7 @@ package body Sem_Ch12 is Set_Is_Generic_Actual_Type (E, True); Set_Is_Hidden (E, False); - Set_Is_Potentially_Use_Visible (E, - In_Use (Instance)); + 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 diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 729a4224260..77ab2545589 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -2466,6 +2466,8 @@ package body Sem_Ch3 is Freeze_All (First_Entity (Current_Scope), Decl); Freeze_From := Last_Entity (Current_Scope); + -- Current scope is a package specification + elsif Scope (Current_Scope) /= Standard_Standard and then not Is_Child_Unit (Current_Scope) and then No (Generic_Parent (Parent (L))) @@ -2485,6 +2487,8 @@ package body Sem_Ch3 is then Adjust_Decl; + -- End of a package declaration + -- In compilation mode the expansion of freeze node takes care -- of resolving expressions of all aspects in the list. In ASIS -- mode this must be done explicitly. @@ -2495,6 +2499,9 @@ package body Sem_Ch3 is Resolve_Aspects; end if; + -- This is a freeze point because it is the end of a + -- compilation unit. + Freeze_All (First_Entity (Current_Scope), Decl); Freeze_From := Last_Entity (Current_Scope); @@ -2561,6 +2568,12 @@ package body Sem_Ch3 is end if; Adjust_Decl; + + -- The generated body of an expression function does not freeze, + -- unless it is a completion, in which case only the expression + -- itself freezes. THis is handled when the body itself is + -- analyzed (see Freeze_Expr_Types, sem_ch6.adb). + Freeze_All (Freeze_From, Decl); Freeze_From := Last_Entity (Current_Scope); end if; @@ -6740,8 +6753,12 @@ package body Sem_Ch3 is -- If we constructed a default range for the case where no range -- was given, then the expressions in the range must not freeze -- since they do not correspond to expressions in the source. + -- However, if the type inherits predicates the expressions will + -- be elaborated earlier and must freeze. - if Nkind (Indic) /= N_Subtype_Indication then + if Nkind (Indic) /= N_Subtype_Indication + and then not Has_Predicates (Derived_Type) + then Set_Must_Not_Freeze (Lo); Set_Must_Not_Freeze (Hi); Set_Must_Not_Freeze (Rang_Expr); diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 9d868043ee8..baf6f2c66fc 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -20971,48 +20971,78 @@ package body Sem_Util is function Unique_Name (E : Entity_Id) return String is - -- Names of E_Subprogram_Body or E_Package_Body entities are not + -- Names in E_Subprogram_Body or E_Package_Body entities are not -- reliable, as they may not include the overloading suffix. Instead, -- when looking for the name of E or one of its enclosing scope, we get -- the name of the corresponding Unique_Entity. - function Get_Scoped_Name (E : Entity_Id) return String; - -- Return the name of E prefixed by all the names of the scopes to which - -- E belongs, except for Standard. + U : constant Entity_Id := Unique_Entity (E); - --------------------- - -- Get_Scoped_Name -- - --------------------- + function This_Name return String; + + --------------- + -- This_Name -- + --------------- - function Get_Scoped_Name (E : Entity_Id) return String is - Name : constant String := Get_Name_String (Chars (E)); + function This_Name return String is begin - if Has_Fully_Qualified_Name (E) - or else Scope (E) = Standard_Standard - then - return Name; - else - return Get_Scoped_Name (Unique_Entity (Scope (E))) & "__" & Name; - end if; - end Get_Scoped_Name; + return Get_Name_String (Chars (U)); + end This_Name; -- Start of processing for Unique_Name begin - if E = Standard_Standard then - return Get_Name_String (Name_Standard); - - elsif Scope (E) = Standard_Standard - and then not (Ekind (E) = E_Package or else Is_Subprogram (E)) + if E = Standard_Standard + or else Has_Fully_Qualified_Name (E) then - return Get_Name_String (Name_Standard) & "__" & - Get_Name_String (Chars (E)); + return This_Name; elsif Ekind (E) = E_Enumeration_Literal then - return Unique_Name (Etype (E)) & "__" & Get_Name_String (Chars (E)); + return Unique_Name (Etype (E)) & "__" & This_Name; else - return Get_Scoped_Name (Unique_Entity (E)); + declare + S : constant Entity_Id := Scope (U); + pragma Assert (Present (S)); + + begin + -- Prefix names of predefined types with standard__, but leave + -- names of user-defined packages and subprograms without prefix + -- (even if technically they are nested in the Standard package). + + if S = Standard_Standard then + if Ekind (U) = E_Package or else Is_Subprogram (U) then + return This_Name; + else + return Unique_Name (S) & "__" & This_Name; + end if; + + -- For intances of generic subprograms use the name of the related + -- instace and skip the scope of its wrapper package. + + elsif Is_Wrapper_Package (S) then + pragma Assert (Scope (S) = Scope (Related_Instance (S))); + -- Wrapper package and the instantiation are in the same scope + + declare + Enclosing_Name : constant String := + Unique_Name (Scope (S)) & "__" & + Get_Name_String (Chars (Related_Instance (S))); + + begin + if Is_Subprogram (U) + and then not Is_Generic_Actual_Subprogram (U) + then + return Enclosing_Name; + else + return Enclosing_Name & "__" & This_Name; + end if; + end; + + else + return Unique_Name (S) & "__" & This_Name; + end if; + end; end if; end Unique_Name; diff --git a/gcc/ada/sinfo.adb b/gcc/ada/sinfo.adb index a99790b50f7..ef521167e37 100644 --- a/gcc/ada/sinfo.adb +++ b/gcc/ada/sinfo.adb @@ -6895,7 +6895,7 @@ package body Sinfo is function Pragma_Name (N : Node_Id) return Name_Id is Result : constant Name_Id := Pragma_Name_Unmapped (N); begin - for J in Pragma_Map'Range loop + for J in Pragma_Map'First .. Last_Pair loop if Result = Pragma_Map (J).Key then return Pragma_Map (J).Value; end if; diff --git a/gcc/ada/spark_xrefs.ads b/gcc/ada/spark_xrefs.ads index f3cbdfdbc76..52c0ef69478 100644 --- a/gcc/ada/spark_xrefs.ads +++ b/gcc/ada/spark_xrefs.ads @@ -137,7 +137,7 @@ package SPARK_Xrefs is -- dependency-number and filename identify a file in FD lines -- entity-number and entity identify a scope in FS lines - -- for the file previously identified file. + -- for the previously identified file. -- (filename and entity are just a textual representations of -- dependency-number and entity-number) diff --git a/gcc/ada/table.ads b/gcc/ada/table.ads index e928ef084ba..29b6fb009bf 100644 --- a/gcc/ada/table.ads +++ b/gcc/ada/table.ads @@ -221,8 +221,8 @@ package Table is -- Writes out contents of table using Tree_IO procedure Tree_Read; - -- Initializes table by reading contents previously written - -- with the Tree_Write call (also using Tree_IO) + -- Initializes table by reading contents previously written with the + -- Tree_Write call (also using Tree_IO). private -- 2.30.2