diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index c3a79af55c0..42f91b7bbea 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,50 @@ +2015-03-13 Robert Dewar + + * exp_unst.adb (Note_Uplevel_Reference): Eliminate duplicate + references. + (Actual_Ref): New function. + (AREC_String): Minor reformatting. + (Unnest_Subprogram): Use Actual_Ref. + * frontend.adb (Frontend): Turn off Unnest_Subprogram_Mode + before call to Instantiate_Bodies. + +2015-03-13 Ed Schonberg + + * freeze.adb (Freeze_Profile): If the return type of a function + being frozen is an untagged limited view and the function is + abstract, mark the type as frozen because there is no later + point at which the profile of the subprogram will be elaborated. + +2015-03-13 Robert Dewar + + * einfo.adb, einfo.ads, atree.adb, atree.ads, atree.h: Add seventh + component to entities. Add new fields Field36-41 and Node36-41. + +2015-03-13 Claire Dross + + * inline.adb (Can_Be_Inlined_In_GNATprove_Mode): Rewrite after review. + +2015-03-13 Robert Dewar + + * exp_util.adb (Is_Volatile_Reference): Compile time known + value is never considered to be a volatile reference. + +2015-03-13 Robert Dewar + + * sem_ch3.adb (Analyze_Object_Contract): Suppress "constant + cannot be volatile" for internally generated object (such as + FIRST and LAST constants). + +2015-03-13 Ed Schonberg + + * sem_ch12.adb (Validate_Access_Subprogram_Instance): If a + convention is specified for the formal parameter, verify that + the actual has the same convention. + * sem_prag.adb (Set_Convention_From_Pragma): Allow convention + pragma to be set on a generic formal type. + * sem_util.adb (Set_Convention): Ignore within an instance, + as it has already been verified in the generic unit. + 2015-03-13 Claire Dross * inline.adb (Can_Be_Inlined_In_GNATprove_Mode): Do not inline diff --git a/gcc/ada/atree.adb b/gcc/ada/atree.adb index 036aee3b51a..93750872997 100644 --- a/gcc/ada/atree.adb +++ b/gcc/ada/atree.adb @@ -2553,6 +2553,42 @@ package body Atree is return Nodes.Table (N + 5).Field11; end Field35; + function Field36 (N : Node_Id) return Union_Id is + begin + pragma Assert (Nkind (N) in N_Entity); + return Nodes.Table (N + 6).Field6; + end Field36; + + function Field37 (N : Node_Id) return Union_Id is + begin + pragma Assert (Nkind (N) in N_Entity); + return Nodes.Table (N + 6).Field7; + end Field37; + + function Field38 (N : Node_Id) return Union_Id is + begin + pragma Assert (Nkind (N) in N_Entity); + return Nodes.Table (N + 6).Field8; + end Field38; + + function Field39 (N : Node_Id) return Union_Id is + begin + pragma Assert (Nkind (N) in N_Entity); + return Nodes.Table (N + 6).Field9; + end Field39; + + function Field40 (N : Node_Id) return Union_Id is + begin + pragma Assert (Nkind (N) in N_Entity); + return Nodes.Table (N + 6).Field10; + end Field40; + + function Field41 (N : Node_Id) return Union_Id is + begin + pragma Assert (Nkind (N) in N_Entity); + return Nodes.Table (N + 6).Field11; + end Field41; + function Node1 (N : Node_Id) return Node_Id is begin pragma Assert (N <= Nodes.Last); @@ -2763,6 +2799,42 @@ package body Atree is return Node_Id (Nodes.Table (N + 5).Field11); end Node35; + function Node36 (N : Node_Id) return Node_Id is + begin + pragma Assert (Nkind (N) in N_Entity); + return Node_Id (Nodes.Table (N + 6).Field6); + end Node36; + + function Node37 (N : Node_Id) return Node_Id is + begin + pragma Assert (Nkind (N) in N_Entity); + return Node_Id (Nodes.Table (N + 6).Field7); + end Node37; + + function Node38 (N : Node_Id) return Node_Id is + begin + pragma Assert (Nkind (N) in N_Entity); + return Node_Id (Nodes.Table (N + 6).Field8); + end Node38; + + function Node39 (N : Node_Id) return Node_Id is + begin + pragma Assert (Nkind (N) in N_Entity); + return Node_Id (Nodes.Table (N + 6).Field9); + end Node39; + + function Node40 (N : Node_Id) return Node_Id is + begin + pragma Assert (Nkind (N) in N_Entity); + return Node_Id (Nodes.Table (N + 6).Field10); + end Node40; + + function Node41 (N : Node_Id) return Node_Id is + begin + pragma Assert (Nkind (N) in N_Entity); + return Node_Id (Nodes.Table (N + 6).Field11); + end Node41; + function List1 (N : Node_Id) return List_Id is begin pragma Assert (N <= Nodes.Last); @@ -5334,6 +5406,42 @@ package body Atree is Nodes.Table (N + 5).Field11 := Val; end Set_Field35; + procedure Set_Field36 (N : Node_Id; Val : Union_Id) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 6).Field6 := Val; + end Set_Field36; + + procedure Set_Field37 (N : Node_Id; Val : Union_Id) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 6).Field7 := Val; + end Set_Field37; + + procedure Set_Field38 (N : Node_Id; Val : Union_Id) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 6).Field8 := Val; + end Set_Field38; + + procedure Set_Field39 (N : Node_Id; Val : Union_Id) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 6).Field9 := Val; + end Set_Field39; + + procedure Set_Field40 (N : Node_Id; Val : Union_Id) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 6).Field10 := Val; + end Set_Field40; + + procedure Set_Field41 (N : Node_Id; Val : Union_Id) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 6).Field11 := Val; + end Set_Field41; + procedure Set_Node1 (N : Node_Id; Val : Node_Id) is begin pragma Assert (N <= Nodes.Last); @@ -5544,6 +5652,42 @@ package body Atree is Nodes.Table (N + 5).Field11 := Union_Id (Val); end Set_Node35; + procedure Set_Node36 (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 6).Field6 := Union_Id (Val); + end Set_Node36; + + procedure Set_Node37 (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 6).Field7 := Union_Id (Val); + end Set_Node37; + + procedure Set_Node38 (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 6).Field8 := Union_Id (Val); + end Set_Node38; + + procedure Set_Node39 (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 6).Field9 := Union_Id (Val); + end Set_Node39; + + procedure Set_Node40 (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 6).Field10 := Union_Id (Val); + end Set_Node40; + + procedure Set_Node41 (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 6).Field11 := Union_Id (Val); + end Set_Node41; + procedure Set_List1 (N : Node_Id; Val : List_Id) is begin pragma Assert (N <= Nodes.Last); diff --git a/gcc/ada/atree.ads b/gcc/ada/atree.ads index 1be32662c25..c1c330cdc63 100644 --- a/gcc/ada/atree.ads +++ b/gcc/ada/atree.ads @@ -68,11 +68,11 @@ package Atree is -- Size of Entities -- ---------------------- - -- Currently entities are composed of 6 sequentially allocated 32-byte + -- Currently entities are composed of 7 sequentially allocated 32-byte -- nodes, considered as a single record. The following definition gives -- the number of extension nodes. - Num_Extension_Nodes : Node_Id := 5; + Num_Extension_Nodes : Node_Id := 6; -- This value is increased by one if debug flag -gnatd.N is set. This is -- for testing performance impact of adding a new extension node. We make -- this of type Node_Id for easy reference in loops using this value. @@ -213,8 +213,8 @@ package Atree is -- Elist6 Synonym for Field6 typed as Elist_Id (Empty = No_Elist) -- Uint6 Synonym for Field6 typed as Uint (Empty = Uint_0) - -- Similar definitions for Field7 to Field35 (and also Node7-Node35, - -- Elist7-Elist35, Uint7-Uint35, Ureal7-Ureal35). Note that not all + -- Similar definitions for Field7 to Field41 (and also Node7-Node41, + -- Elist7-Elist41, Uint7-Uint41, Ureal7-Ureal41). Note that not all -- these functions are defined, only the ones that are actually used. function Last_Node_Id return Node_Id; @@ -355,13 +355,13 @@ package Atree is -- Field1-5 fields are set to Empty - -- Field6-35 fields in extended nodes are set to Empty + -- Field6-41 fields in extended nodes are set to Empty -- Parent is set to Empty -- All Boolean flag fields are set to False - -- Note: the value Empty is used in Field1-Field35 to indicate a null node. + -- Note: the value Empty is used in Field1-Field41 to indicate a null node. -- The usage varies. The common uses are to indicate absence of an optional -- clause or a completely unused Field1-35 field. @@ -1185,6 +1185,24 @@ package Atree is function Field35 (N : Node_Id) return Union_Id; pragma Inline (Field35); + function Field36 (N : Node_Id) return Union_Id; + pragma Inline (Field36); + + function Field37 (N : Node_Id) return Union_Id; + pragma Inline (Field37); + + function Field38 (N : Node_Id) return Union_Id; + pragma Inline (Field38); + + function Field39 (N : Node_Id) return Union_Id; + pragma Inline (Field39); + + function Field40 (N : Node_Id) return Union_Id; + pragma Inline (Field40); + + function Field41 (N : Node_Id) return Union_Id; + pragma Inline (Field41); + function Node1 (N : Node_Id) return Node_Id; pragma Inline (Node1); @@ -1290,6 +1308,24 @@ package Atree is function Node35 (N : Node_Id) return Node_Id; pragma Inline (Node35); + function Node36 (N : Node_Id) return Node_Id; + pragma Inline (Node36); + + function Node37 (N : Node_Id) return Node_Id; + pragma Inline (Node37); + + function Node38 (N : Node_Id) return Node_Id; + pragma Inline (Node38); + + function Node39 (N : Node_Id) return Node_Id; + pragma Inline (Node39); + + function Node40 (N : Node_Id) return Node_Id; + pragma Inline (Node40); + + function Node41 (N : Node_Id) return Node_Id; + pragma Inline (Node41); + function List1 (N : Node_Id) return List_Id; pragma Inline (List1); @@ -2500,6 +2536,24 @@ package Atree is procedure Set_Field35 (N : Node_Id; Val : Union_Id); pragma Inline (Set_Field35); + procedure Set_Field36 (N : Node_Id; Val : Union_Id); + pragma Inline (Set_Field36); + + procedure Set_Field37 (N : Node_Id; Val : Union_Id); + pragma Inline (Set_Field37); + + procedure Set_Field38 (N : Node_Id; Val : Union_Id); + pragma Inline (Set_Field38); + + procedure Set_Field39 (N : Node_Id; Val : Union_Id); + pragma Inline (Set_Field39); + + procedure Set_Field40 (N : Node_Id; Val : Union_Id); + pragma Inline (Set_Field40); + + procedure Set_Field41 (N : Node_Id; Val : Union_Id); + pragma Inline (Set_Field41); + procedure Set_Node1 (N : Node_Id; Val : Node_Id); pragma Inline (Set_Node1); @@ -2605,6 +2659,24 @@ package Atree is procedure Set_Node35 (N : Node_Id; Val : Node_Id); pragma Inline (Set_Node35); + procedure Set_Node36 (N : Node_Id; Val : Node_Id); + pragma Inline (Set_Node36); + + procedure Set_Node37 (N : Node_Id; Val : Node_Id); + pragma Inline (Set_Node37); + + procedure Set_Node38 (N : Node_Id; Val : Node_Id); + pragma Inline (Set_Node38); + + procedure Set_Node39 (N : Node_Id; Val : Node_Id); + pragma Inline (Set_Node39); + + procedure Set_Node40 (N : Node_Id; Val : Node_Id); + pragma Inline (Set_Node40); + + procedure Set_Node41 (N : Node_Id; Val : Node_Id); + pragma Inline (Set_Node41); + procedure Set_List1 (N : Node_Id; Val : List_Id); pragma Inline (Set_List1); @@ -3817,8 +3889,10 @@ package Atree is -- Flags 4-18 for a normal node. Note that Flags 0-3 are stored -- separately in the Flags array. - -- The above fields are used as follows in components 2-6 of - -- an extended node entry. + -- The above fields are used as follows in components 2-6 of an + -- extended node entry. Currently they are not used in component 7, + -- since for now we have all the flags we need, but of course they + -- can be used for additional flags when needed in component 7. -- In_List used as Flag19,Flag40,Flag129,Flag216,Flag287 -- Has_Aspects used as Flag20,Flag41,Flag130,Flag217,Flag288 @@ -3849,11 +3923,12 @@ package Atree is -- node, this field holds the Node_Kind value. For an extended node, -- The Nkind field is used as follows: -- - -- Second entry: holds the Ekind field of the entity - -- Third entry: holds 8 additional flags (Flag65-Flag72) - -- Fourth entry: holds 8 additional flags (Flag239-246) - -- Fifth entry: holds 8 additional flags (Flag247-254) - -- Sixth entry: holds 8 additional flags (Flag310-317) + -- Second entry: holds the Ekind field of the entity + -- Third entry: holds 8 additional flags (Flag65-Flag72) + -- Fourth entry: holds 8 additional flags (Flag239-246) + -- Fifth entry: holds 8 additional flags (Flag247-254) + -- Sixth entry: holds 8 additional flags (Flag310-317) + -- Seventh entry: currently unused -- Now finally (on an 32-bit boundary) comes the variant part @@ -3926,6 +4001,13 @@ package Atree is -- Field6-11 Holds Field30-Field35 -- Field12 Holds Flag255-Flag286 + -- In the seventh component, the extension format as described + -- above is used to hold additional general fields as follows. + -- Flags are also available potentially, but not used now, as + -- we are not short of entity flags. + + -- Field6-11 Holds Field36-Field41 + end case; end record; @@ -3979,8 +4061,8 @@ package Atree is Field5 => Empty_List_Or_Node); -- Default value used to initialize node extensions (i.e. the second - -- through sixth components of an extended node). Note we are cheating - -- a bit here when it comes to Node12, which really holds flags and (for + -- through seventh components of an extended node). Note we are cheating + -- a bit here when it comes to Node12, which often holds flags and (for -- the third component), the convention. But it works because Empty, -- False, Convention_Ada, all happen to be all zero bits. diff --git a/gcc/ada/atree.h b/gcc/ada/atree.h index dadfce041f4..093b3663a7c 100644 --- a/gcc/ada/atree.h +++ b/gcc/ada/atree.h @@ -448,6 +448,12 @@ extern Node_Id Current_Error_Node; #define Field33(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.field9) #define Field34(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.field10) #define Field35(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.X.field11) +#define Field36(N) (Nodes_Ptr[(N) - First_Node_Id + 6].V.EX.field6) +#define Field37(N) (Nodes_Ptr[(N) - First_Node_Id + 6].V.EX.field7) +#define Field38(N) (Nodes_Ptr[(N) - First_Node_Id + 6].V.EX.field8) +#define Field39(N) (Nodes_Ptr[(N) - First_Node_Id + 6].V.EX.field9) +#define Field41(N) (Nodes_Ptr[(N) - First_Node_Id + 6].V.EX.field10) +#define Field41(N) (Nodes_Ptr[(N) - First_Node_Id + 6].V.EX.X.field11) #define Node1(N) Field1 (N) #define Node2(N) Field2 (N) @@ -485,6 +491,11 @@ extern Node_Id Current_Error_Node; #define Node34(N) Field34 (N) #define Node35(N) Field35 (N) #define Node36(N) Field36 (N) +#define Node37(N) Field37 (N) +#define Node38(N) Field38 (N) +#define Node39(N) Field39 (N) +#define Node40(N) Field40 (N) +#define Node41(N) Field41 (N) #define List1(N) Field1 (N) #define List2(N) Field2 (N) diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index e215df9eb9d..511ba3a0a33 100644 --- a/gcc/ada/einfo.adb +++ b/gcc/ada/einfo.adb @@ -264,6 +264,13 @@ package body Einfo is -- Import_Pragma Node35 + -- (unused) Node36 + -- (unused) Node37 + -- (unused) Node38 + -- (unused) Node39 + -- (unused) Node40 + -- (unused) Node41 + --------------------------------------------- -- Usage of Flags in Defining Entity Nodes -- --------------------------------------------- @@ -10063,6 +10070,78 @@ package body Einfo is end case; end Write_Field35_Name; + ------------------------ + -- Write_Field36_Name -- + ------------------------ + + procedure Write_Field36_Name (Id : Entity_Id) is + begin + case Ekind (Id) is + when others => + Write_Str ("Field36??"); + end case; + end Write_Field36_Name; + + ------------------------ + -- Write_Field37_Name -- + ------------------------ + + procedure Write_Field37_Name (Id : Entity_Id) is + begin + case Ekind (Id) is + when others => + Write_Str ("Field37??"); + end case; + end Write_Field37_Name; + + ------------------------ + -- Write_Field38_Name -- + ------------------------ + + procedure Write_Field38_Name (Id : Entity_Id) is + begin + case Ekind (Id) is + when others => + Write_Str ("Field38??"); + end case; + end Write_Field38_Name; + + ------------------------ + -- Write_Field39_Name -- + ------------------------ + + procedure Write_Field39_Name (Id : Entity_Id) is + begin + case Ekind (Id) is + when others => + Write_Str ("Field39??"); + end case; + end Write_Field39_Name; + + ------------------------ + -- Write_Field40_Name -- + ------------------------ + + procedure Write_Field40_Name (Id : Entity_Id) is + begin + case Ekind (Id) is + when others => + Write_Str ("Field40??"); + end case; + end Write_Field40_Name; + + ------------------------ + -- Write_Field41_Name -- + ------------------------ + + procedure Write_Field41_Name (Id : Entity_Id) is + begin + case Ekind (Id) is + when others => + Write_Str ("Field41??"); + end case; + end Write_Field41_Name; + ------------------------- -- Iterator Procedures -- ------------------------- diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index 81a77f972b3..178fc7e3a5c 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -8001,6 +8001,12 @@ package Einfo is procedure Write_Field33_Name (Id : Entity_Id); procedure Write_Field34_Name (Id : Entity_Id); procedure Write_Field35_Name (Id : Entity_Id); + procedure Write_Field36_Name (Id : Entity_Id); + procedure Write_Field37_Name (Id : Entity_Id); + procedure Write_Field38_Name (Id : Entity_Id); + procedure Write_Field39_Name (Id : Entity_Id); + procedure Write_Field40_Name (Id : Entity_Id); + procedure Write_Field41_Name (Id : Entity_Id); -- These routines are used in Treepr to output a nice symbolic name for -- the given field, depending on the Ekind. No blanks or end of lines are -- output, just the characters of the field name. diff --git a/gcc/ada/exp_unst.adb b/gcc/ada/exp_unst.adb index 2034b0e03b5..40b09e2816d 100644 --- a/gcc/ada/exp_unst.adb +++ b/gcc/ada/exp_unst.adb @@ -281,6 +281,8 @@ package body Exp_Unst is ---------------------------- procedure Note_Uplevel_Reference (N : Node_Id; Subp : Entity_Id) is + Elmt : Elmt_Id; + begin -- Nothing to do inside a generic (all processing is for instance) @@ -300,6 +302,18 @@ package body Exp_Unst is Set_Uplevel_References (Subp, New_Elmt_List); end if; + -- Ignore if node is already in the list. This is a bit inefficient, + -- but we can definitely get duplicates that cause trouble! + + Elmt := First_Elmt (Uplevel_References (Subp)); + while Present (Elmt) loop + if N = Node (Elmt) then + return; + else + Next_Elmt (Elmt); + end if; + end loop; + -- Add new entry to Uplevel_References. Each entry is two elements of -- the list. The first is the actual reference, the second is the -- enclosing subprogram at the point of reference @@ -322,6 +336,12 @@ package body Exp_Unst is ----------------------- procedure Unnest_Subprogram (Subp : Entity_Id; Subp_Body : Node_Id) is + function Actual_Ref (N : Node_Id) return Node_Id; + -- This function is applied to an element in the Uplevel_References + -- list, and it finds the actual reference. Often this is just N itself, + -- but in some cases it gets rewritten, e.g. as a Type_Conversion, and + -- this function digs out the actual reference + function AREC_String (Lev : Pos) return String; -- Given a level value, 1, 2, ... returns the string AREC, AREC2, ... @@ -338,6 +358,36 @@ package body Exp_Unst is function Subp_Index (Sub : Entity_Id) return SI_Type; -- Given the entity for a subprogram, return corresponding Subps index + ---------------- + -- Actual_Ref -- + ---------------- + + function Actual_Ref (N : Node_Id) return Node_Id is + begin + case Nkind (N) is + + -- If we have an entity reference, then this is the actual ref + + when N_Has_Entity => + return N; + + -- For a type conversion, go get the expression + + when N_Type_Conversion => + return Expression (N); + + -- For an explicit dereference, get the prefix + + when N_Explicit_Dereference => + return Prefix (N); + + -- No other possibilities should exist + + when others => + raise Program_Error; + end case; + end Actual_Ref; + ----------------- -- AREC_String -- ----------------- @@ -345,11 +395,9 @@ package body Exp_Unst is function AREC_String (Lev : Pos) return String is begin if Lev > 9 then - return - AREC_String (Lev / 10) & Character'Val (Lev mod 10 + 48); + return AREC_String (Lev / 10) & Character'Val (Lev mod 10 + 48); else - return - "AREC" & Character'Val (Lev + 48); + return "AREC" & Character'Val (Lev + 48); end if; end AREC_String; @@ -789,6 +837,7 @@ package body Exp_Unst is declare Loc : constant Source_Ptr := Sloc (STJ.Bod); Elmt : Elmt_Id; + Nod : Node_Id; Ent : Entity_Id; Clist : List_Id; Comp : Entity_Id; @@ -817,7 +866,8 @@ package body Exp_Unst is if Present (STJ.Urefs) then Elmt := First_Elmt (STJ.Urefs); while Present (Elmt) loop - Ent := Entity (Node (Elmt)); + Nod := Actual_Ref (Node (Elmt)); + Ent := Entity (Nod); if not Uplevel_Reference_Noted (Ent) then Set_Uplevel_Reference_Noted (Ent, True); @@ -1049,19 +1099,11 @@ package body Exp_Unst is Elmt := First_Elmt (STJ.Urefs); while Present (Elmt) loop - -- Skip if we have an explicit dereference. This means - -- that we already did the expansion. There can be - -- duplicates in ths STJ.Urefs list. - - if Nkind (Node (Elmt)) = N_Explicit_Dereference then - goto Continue; - end if; - - -- Otherwise, rewrite this reference + -- Rewrite one reference declare - Ref : constant Node_Id := Node (Elmt); - -- The uplevel reference itself + Ref : constant Node_Id := Actual_Ref (Node (Elmt)); + -- The reference to be rewritten Loc : constant Source_Ptr := Sloc (Ref); -- Source location for the reference @@ -1103,7 +1145,7 @@ package body Exp_Unst is -- type Tnn is access all typ; - Insert_Action (Ref, + Insert_Action (Node (Elmt), Make_Full_Type_Declaration (Loc, Defining_Identifier => Tnn, Type_Definition => @@ -1191,7 +1233,6 @@ package body Exp_Unst is Pop_Scope; end; - <> Next_Elmt (Elmt); Next_Elmt (Elmt); end loop; diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index bc58efebbd5..5ae0a2113f5 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -5710,6 +5710,11 @@ package body Exp_Util is elsif Is_Entity_Name (N) and then Is_Type (Entity (N)) then return False; + -- Never true for a compile time known constant + + elsif Compile_Time_Known_Value (N) then + return False; + -- True if object reference with volatile type elsif Is_Volatile_Object (N) then diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index e01b9cc6f8d..bfee6559088 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -3026,18 +3026,23 @@ package body Freeze is R_Type := Full_View (R_Type); Set_Etype (E, R_Type); - -- If the return type is a limited view and the non- - -- limited view is still incomplete, the function has - -- to be frozen at a later time. + -- If the return type is a limited view and the non-limited + -- view is still incomplete, the function has to be frozen at a + -- later time. If the function is abstract there is no place at + -- which the full view will become available, and no code to be + -- generated for it, so mark type as frozen. elsif Ekind (R_Type) = E_Incomplete_Type and then From_Limited_With (R_Type) - and then - Ekind (Non_Limited_View (R_Type)) = E_Incomplete_Type + and then Ekind (Non_Limited_View (R_Type)) = E_Incomplete_Type then - Set_Is_Frozen (E, False); - Set_Returns_Limited_View (E); - return False; + if Is_Abstract_Subprogram (E) then + null; + else + Set_Is_Frozen (E, False); + Set_Returns_Limited_View (E); + return False; + end if; end if; Freeze_And_Append (R_Type, N, Result); diff --git a/gcc/ada/frontend.adb b/gcc/ada/frontend.adb index adee97df2fe..bab0b46abfa 100644 --- a/gcc/ada/frontend.adb +++ b/gcc/ada/frontend.adb @@ -408,6 +408,13 @@ begin -- Cleanup processing after completing main analysis + -- Turn off unnesting of subprograms mode. This is not right + -- with respect to instantiations. What needs to happen is that + -- we do the unnesting AFTER the call to Instantiate_Bodies. We + -- will take care of that later ??? + + Opt.Unnest_Subprogram_Mode := False; + -- Comment needed for ASIS mode test and GNATprove mode test??? if Operating_Mode = Generate_Code diff --git a/gcc/ada/inline.adb b/gcc/ada/inline.adb index 7db46cf8178..936b056d6da 100644 --- a/gcc/ada/inline.adb +++ b/gcc/ada/inline.adb @@ -1335,10 +1335,11 @@ package body Inline is (Spec_Id : Entity_Id; Body_Id : Entity_Id) return Boolean is - function Has_Parameter_With_Discriminant_Dependent_Fields + function Has_Formal_With_Discriminant_Dependent_Fields (Id : Entity_Id) return Boolean; - -- Returns true if the subprogram as parameters of an unconstrained - -- record types with fields whose types depend on a discriminant. + -- Returns true if the subprogram has at least one formal parameters of + -- an unconstrained record type with per-object constraints on component + -- types. function Has_Some_Contract (Id : Entity_Id) return Boolean; -- Returns True if subprogram Id has any contract (Pre, Post, Global, @@ -1356,72 +1357,73 @@ package body Inline is -- Returns True if subprogram Id was defined originally as an expression -- function. - ------------------------------------------------------ - -- Has_Parameter_With_Discriminant_Dependent_Fields -- - ------------------------------------------------------ + --------------------------------------------------- + -- Has_Formal_With_Discriminant_Dependent_Fields -- + --------------------------------------------------- - function Has_Parameter_With_Discriminant_Dependent_Fields - (Id : Entity_Id) return Boolean - is - E : Entity_Id := Id; - Spec : Node_Id := Parent (E); + function Has_Formal_With_Discriminant_Dependent_Fields + (Id : Entity_Id) return Boolean is - begin - -- Get the specification of the subprogram. Go through alias if - -- needed. + function Has_Discriminant_Dependent_Component + (Typ : Entity_Id) return Boolean; + -- Determine whether unconstrained record type Typ has at least + -- one component that depends on a discriminant. - if Nkind (Spec) = N_Defining_Program_Unit_Name then - Spec := Parent (Spec); - end if; + ------------------------------------------ + -- Has_Discriminant_Dependent_Component -- + ------------------------------------------ - while Nkind (Spec) not in N_Subprogram_Specification loop - pragma Assert (Present (Alias (E))); - E := Alias (E); - Spec := Parent (E); - - if Nkind (Spec) = N_Defining_Program_Unit_Name then - Spec := Parent (Spec); - end if; - end loop; - - declare - Params : constant List_Id := Parameter_Specifications (Spec); - Param : Node_Id; - Param_Ty : Entity_Id; + function Has_Discriminant_Dependent_Component + (Typ : Entity_Id) return Boolean + is + Comp : Entity_Id; begin - if Is_Non_Empty_List (Params) then - Param := First (Params); - while Present (Param) loop - Param_Ty := Etype (Defining_Identifier (Param)); + -- Inspect all components of the record type looking for one + -- that depends on a discriminant. - -- If the parameter is an unconstrained record, check if - -- it has components whose types depend on a discriminant. + Comp := First_Component (Typ); + while Present (Comp) loop + if Has_Discriminant_Dependent_Constraint (Comp) then + return True; + end if; - if Is_Record_Type (Param_Ty) - and then not Is_Constrained (Param_Ty) - then - declare - Comp : Node_Id := First_Component (Param_Ty); + Next_Component (Comp); + end loop; - begin - while Present (Comp) loop - if Has_Discriminant_Dependent_Constraint (Comp) then - return True; - end if; + return False; + end Has_Discriminant_Dependent_Component; - Comp := Next_Component (Comp); - end loop; - end; - end if; + -- Local variables - Param := Next (Param); - end loop; + Subp_Id : constant Entity_Id := Ultimate_Alias (Id); + Formal : Entity_Id; + Formal_Typ : Entity_Id; + + -- Start of processing for + -- Has_Formal_With_Discriminant_Dependent_Component + + begin + -- Inspect all parameters of the subprogram looking for a formal + -- of an unconstrained record type with at least one discriminant + -- dependent component. + + Formal := First_Formal (Subp_Id); + while Present (Formal) loop + Formal_Typ := Etype (Formal); + + if Is_Record_Type (Formal_Typ) + and then not Is_Constrained (Formal_Typ) + and then Has_Discriminant_Dependent_Component (Formal_Typ) + then + return True; end if; - end; + + Next_Formal (Formal); + end loop; return False; - end Has_Parameter_With_Discriminant_Dependent_Fields; + end Has_Formal_With_Discriminant_Dependent_Fields; ----------------------- -- Has_Some_Contract -- @@ -1580,7 +1582,7 @@ package body Inline is -- in record component accesses (in particular with records containing -- packed arrays). - elsif Has_Parameter_With_Discriminant_Dependent_Fields (Id) then + elsif Has_Formal_With_Discriminant_Dependent_Fields (Id) then return False; -- Otherwise, this is a subprogram declared inside the private part of a diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index 0fa78179c84..b362362e70d 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -11204,6 +11204,17 @@ package body Sem_Ch12 is ("expect protected access type for formal &", Actual, Gen_T); end if; + + -- If the formal has a specified convention (which in most cases + -- will be StdCall) verify that the actual has the same convention. + + if Has_Convention_Pragma (A_Gen_T) + and then Convention (A_Gen_T) /= Convention (Act_T) + then + Error_Msg_Name_1 := Get_Convention_Name (Convention (A_Gen_T)); + Error_Msg_NE + ("actual for formal & must have convention %", Actual, Gen_T); + end if; end Validate_Access_Subprogram_Instance; ----------------------------------- diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 53fc26166a3..8a1e1320783 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -3159,6 +3159,11 @@ package body Sem_Ch3 is if SPARK_Mode = On and then Is_Effectively_Volatile (Obj_Id) and then No (Corresponding_Generic_Association (Parent (Obj_Id))) + + -- Don't give this for internally generated entities (such as the + -- FIRST and LAST temporaries generated for bounds. + + and then Comes_From_Source (Obj_Id) then Error_Msg_N ("constant cannot be volatile", Obj_Id); end if; diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index cae31f3f818..4fe9007aacb 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -6591,7 +6591,17 @@ package body Sem_Prag is Set_Convention_From_Pragma (E); if Is_Type (E) then - Check_First_Subtype (Arg2); + + -- The pragma must apply to a first subtype, but it can also + -- apply to a generic type in a generic formal part, in which + -- case it will also appear in the corresponding instance. + + if Is_Generic_Type (E) or else In_Instance then + null; + else + Check_First_Subtype (Arg2); + end if; + Set_Convention_From_Pragma (Base_Type (E)); -- For access subprograms, we must set the convention on the diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 724a9ae87ba..48d9e52b752 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -16854,7 +16854,17 @@ package body Sem_Util is and then Is_Access_Subprogram_Type (Base_Type (E)) and then Has_Foreign_Convention (E) then - Set_Can_Use_Internal_Rep (E, False); + + -- A convention pragma in an instance may apply to the subtype + -- created for a formal, in which case we have already verified + -- that conventions of actual and formal match and there is nothing + -- to flag on the subtype. + + if In_Instance then + null; + else + Set_Can_Use_Internal_Rep (E, False); + end if; end if; -- If E is an object or component, and the type of E is an anonymous