From: Arnaud Charlet Date: Fri, 13 Mar 2015 13:47:24 +0000 (+0100) Subject: [multiple changes] X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=57d08392f638bae0e0051a6ea55779b9da124d81;p=gcc.git [multiple changes] 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. From-SVN: r221422 --- 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); + function Has_Discriminant_Dependent_Component + (Typ : Entity_Id) return Boolean + is + Comp : Entity_Id; - if Nkind (Spec) = N_Defining_Program_Unit_Name then - Spec := Parent (Spec); - end if; - end loop; + begin + -- Inspect all components of the record type looking for one + -- that depends on a discriminant. - declare - Params : constant List_Id := Parameter_Specifications (Spec); - Param : Node_Id; - Param_Ty : Entity_Id; + Comp := First_Component (Typ); + while Present (Comp) loop + if Has_Discriminant_Dependent_Constraint (Comp) then + return True; + end if; - begin - if Is_Non_Empty_List (Params) then - Param := First (Params); - while Present (Param) loop - Param_Ty := Etype (Defining_Identifier (Param)); + Next_Component (Comp); + end loop; - -- If the parameter is an unconstrained record, check if - -- it has components whose types depend on a discriminant. + return False; + end Has_Discriminant_Dependent_Component; - if Is_Record_Type (Param_Ty) - and then not Is_Constrained (Param_Ty) - then - declare - Comp : Node_Id := First_Component (Param_Ty); + -- Local variables - begin - while Present (Comp) loop - if Has_Discriminant_Dependent_Constraint (Comp) then - return True; - end if; + Subp_Id : constant Entity_Id := Ultimate_Alias (Id); + Formal : Entity_Id; + Formal_Typ : Entity_Id; - Comp := Next_Component (Comp); - end loop; - end; - end if; + -- Start of processing for + -- Has_Formal_With_Discriminant_Dependent_Component - Param := Next (Param); - end loop; + 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