From 551e193501cebca18c19ed9ede7df7c2ee0bd9a6 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Tue, 26 May 2015 10:08:03 +0200 Subject: [PATCH] [multiple changes] 2015-05-26 Gary Dismukes * einfo.ads, sem_util.adb, sem_ch4.adb: Minor reformatting. 2015-05-26 Robert Dewar * exp_unst.adb, exp_unst.ads: Change to using Subps table index for making AREC entity names unique. 2015-05-26 Ed Schonberg * sem_cat.adb (Has_Stream_Attribute_Definition): If the type has aspect specifications, examine the corresponding list of representation items to determine whether there is a visible stream operation. The attribute definition clause generated from the aspect will be inserted at the freeze point of the type, which may be in the private part and not directly visible, but the aspect makes the operation available to a client. From-SVN: r223663 --- gcc/ada/ChangeLog | 19 +++++++ gcc/ada/einfo.ads | 2 +- gcc/ada/exp_unst.adb | 126 ++++++++++++++++++++++--------------------- gcc/ada/exp_unst.ads | 14 ++--- gcc/ada/sem_cat.adb | 65 ++++++++++++++-------- gcc/ada/sem_ch4.adb | 36 ++++++------- gcc/ada/sem_util.adb | 8 +-- 7 files changed, 156 insertions(+), 114 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 92decca3440..ccdf46b54ea 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,22 @@ +2015-05-26 Gary Dismukes + + * einfo.ads, sem_util.adb, sem_ch4.adb: Minor reformatting. + +2015-05-26 Robert Dewar + + * exp_unst.adb, exp_unst.ads: Change to using Subps table index for + making AREC entity names unique. + +2015-05-26 Ed Schonberg + + * sem_cat.adb (Has_Stream_Attribute_Definition): If the type + has aspect specifications, examine the corresponding list of + representation items to determine whether there is a visible + stream operation. The attribute definition clause generated from + the aspect will be inserted at the freeze point of the type, + which may be in the private part and not directly visible, + but the aspect makes the operation available to a client. + 2015-05-26 Robert Dewar * sem_util.adb: Minor code reorganization. diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index 8676713b7b9..5a309f914db 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -1756,7 +1756,7 @@ package Einfo is -- Object_Size clauses for a given entity. -- Has_Out_Or_In_Out_Parameter (Flag110) --- Present in subprograms, generic subprograms, entries and entry +-- Present in subprograms, generic subprograms, entries, and entry -- families. Set if they have at least one OUT or IN OUT parameter -- (allowed for functions only in Ada 2012). diff --git a/gcc/ada/exp_unst.adb b/gcc/ada/exp_unst.adb index 872a35fda67..c2a72431d34 100644 --- a/gcc/ada/exp_unst.adb +++ b/gcc/ada/exp_unst.adb @@ -124,8 +124,8 @@ package body Exp_Unst is ----------------------- procedure Unnest_Subprogram (Subp : Entity_Id; Subp_Body : Node_Id) is - function AREC_String (Lev : Pos) return String; - -- Given a level value, 1, 2, ... returns the string AREC, AREC2, ... + function AREC_Name (J : Pos; S : String) return Name_Id; + -- Returns name for string ARECjS, where j is the decimal value of j function Enclosing_Subp (Subp : SI_Type) return SI_Type; -- Subp is the index of a subprogram which has a Lev greater than 1. @@ -137,34 +137,32 @@ package body Exp_Unst is -- function returns the level of nesting (Subp = 1, subprograms that -- are immediately nested within Subp = 2, etc). + function Img_Pos (N : Pos) return String; + -- Return image of N without leading blank + function Subp_Index (Sub : Entity_Id) return SI_Type; -- Given the entity for a subprogram, return corresponding Subps index - function Suffixed_Name (Ent : Entity_Id) return Name_Id; - -- Given an entity Ent, return its name (Char (Ent)) suffixed with - -- two underscores and the entity number, to ensure a unique name. - - function Upref_Name (Ent : Entity_Id; Clist : List_Id) return Name_Id; + function Upref_Name + (Ent : Entity_Id; + Index : Pos; + Clist : List_Id) return Name_Id; -- This function returns the name to be used in the activation record to -- reference the variable uplevel. Clist is the list of components that - -- have been created in the activation record so far. Normally this is - -- just a copy of the Chars field of the entity. The exception is when - -- the name has already been used, in which case we suffix the name with - -- the entity number to avoid duplication. This happens with declare - -- blocks and generic parameters at least. + -- have been created in the activation record so far. Normally the name + -- is just a copy of the Chars field of the entity. The exception is + -- when the name has already been used, in which case we suffix the name + -- with the index value Index to avoid duplication. This happens with + -- declare blocks and generic parameters at least. - ----------------- - -- AREC_String -- - ----------------- + --------------- + -- AREC_Name -- + --------------- - function AREC_String (Lev : Pos) return String is + function AREC_Name (J : Pos; S : String) return Name_Id is begin - if Lev > 9 then - return AREC_String (Lev / 10) & Character'Val (Lev mod 10 + 48); - else - return "AREC" & Character'Val (Lev + 48); - end if; - end AREC_String; + return Name_Find_Str ("AREC" & Img_Pos (J) & S); + end AREC_Name; -------------------- -- Enclosing_Subp -- @@ -199,6 +197,27 @@ package body Exp_Unst is end loop; end Get_Level; + ------------- + -- Img_Pos -- + ------------- + + function Img_Pos (N : Pos) return String is + Buf : String (1 .. 20); + Ptr : Natural; + NV : Nat; + + begin + Ptr := Buf'Last; + NV := N; + while NV /= 0 loop + Buf (Ptr) := Character'Val (48 + NV mod 10); + Ptr := Ptr - 1; + NV := NV / 10; + end loop; + + return Buf (Ptr + 1 .. Buf'Last); + end Img_Pos; + ---------------- -- Subp_Index -- ---------------- @@ -209,23 +228,15 @@ package body Exp_Unst is return SI_Type (UI_To_Int (Subps_Index (Sub))); end Subp_Index; - ------------------- - -- Suffixed_Name -- - ------------------- - - function Suffixed_Name (Ent : Entity_Id) return Name_Id is - begin - Get_Name_String (Chars (Ent)); - Add_Str_To_Name_Buffer ("__"); - Add_Nat_To_Name_Buffer (Nat (Ent)); - return Name_Enter; - end Suffixed_Name; - ---------------- -- Upref_Name -- ---------------- - function Upref_Name (Ent : Entity_Id; Clist : List_Id) return Name_Id is + function Upref_Name + (Ent : Entity_Id; + Index : Pos; + Clist : List_Id) return Name_Id + is C : Node_Id; begin C := First (Clist); @@ -233,7 +244,8 @@ package body Exp_Unst is if No (C) then return Chars (Ent); elsif Chars (Defining_Identifier (C)) = Chars (Ent) then - return Suffixed_Name (Ent); + return Name_Find_Str + (Get_Name_String (Chars (Ent)) & Img_Pos (Index)); else Next (C); end if; @@ -946,7 +958,6 @@ package body Exp_Unst is declare STJ : Subp_Entry renames Subps.Table (J); Loc : constant Source_Ptr := Sloc (STJ.Bod); - ARS : constant String := AREC_String (STJ.Lev); begin -- First we create the ARECnF entity for the additional formal for @@ -954,32 +965,26 @@ package body Exp_Unst is if STJ.Uplevel_Ref < STJ.Lev then STJ.ARECnF := - Make_Defining_Identifier (Loc, - Chars => Name_Find_Str (AREC_String (STJ.Lev - 1) & "F")); + Make_Defining_Identifier (Loc, Chars => AREC_Name (J, "F")); end if; -- Define the AREC entities for the activation record if needed if STJ.Declares_AREC then STJ.ARECn := - Make_Defining_Identifier (Loc, Name_Find_Str (ARS)); + Make_Defining_Identifier (Loc, AREC_Name (J, "")); STJ.ARECnT := - Make_Defining_Identifier (Loc, Name_Find_Str (ARS & "T")); + Make_Defining_Identifier (Loc, AREC_Name (J, "T")); STJ.ARECnPT := - Make_Defining_Identifier (Loc, Name_Find_Str (ARS & "PT")); + Make_Defining_Identifier (Loc, AREC_Name (J, "PT")); STJ.ARECnP := - Make_Defining_Identifier (Loc, Name_Find_Str (ARS & "P")); + Make_Defining_Identifier (Loc, AREC_Name (J, "P")); -- Define uplink component entity if inner nesting case if Present (STJ.ARECnF) then - declare - ARS1 : constant String := AREC_String (STJ.Lev - 1); - begin - STJ.ARECnU := - Make_Defining_Identifier (Loc, - Chars => Name_Find_Str (ARS1 & "U")); - end; + STJ.ARECnU := + Make_Defining_Identifier (Loc, AREC_Name (J, "U")); end if; end if; end; @@ -1103,22 +1108,15 @@ package body Exp_Unst is -- List of new declarations we create begin - -- Suffix the ARECnT and ARECnPT names to make sure that - -- they are unique when Cprint moves the declarations to - -- the outer level. - - Set_Chars (STJ.ARECnT, Suffixed_Name (STJ.ARECnT)); - Set_Chars (STJ.ARECnPT, Suffixed_Name (STJ.ARECnPT)); - -- Build list of component declarations for ARECnT Clist := Empty_List; -- If we are in a subprogram that has a static link that -- is passed in (as indicated by ARECnF being defined), - -- then include ARECnU : ARECmPT where m is one less than - -- the current level and the entity ARECnPT comes from - -- the enclosing subprogram. + -- then include ARECnU : ARECmPT where ARECmPT comes from + -- the level one higher than the current level, and the + -- entity ARECnPT comes from the enclosing subprogram. if Present (STJ.ARECnF) then declare @@ -1142,14 +1140,20 @@ package body Exp_Unst is Elmt : Elmt_Id; Uent : Entity_Id; + Indx : Nat; + -- 1's origin of index in list of elements. This is + -- used to uniquify names if needed in Upref_Name. + begin Elmt := First_Elmt (STJ.Uents); + Indx := 0; while Present (Elmt) loop Uent := Node (Elmt); + Indx := Indx + 1; Comp := Make_Defining_Identifier (Loc, - Chars => Upref_Name (Uent, Clist)); + Chars => Upref_Name (Uent, Indx, Clist)); Set_Activation_Record_Component (Uent, Comp); diff --git a/gcc/ada/exp_unst.ads b/gcc/ada/exp_unst.ads index 7b92dcd4b09..084e904b677 100644 --- a/gcc/ada/exp_unst.ads +++ b/gcc/ada/exp_unst.ads @@ -184,9 +184,9 @@ package Exp_Unst is -- The fields of AREC1 are set at the point the corresponding entity -- is declared (immediately for parameters). - -- Note: the 1 in all these names represents the fact that we are at the - -- outer level of nesting. As we will see later, deeper levels of nesting - -- will use AREC2, AREC3, ... + -- Note: the 1 in all these names is a unique index number. Different + -- scopes requiring different ARECnT declarations will have different + -- values of n to ensure uniqueness. -- Note: normally the field names in the activation record match the -- name of the entity. An exception is when the entity is declared in @@ -294,8 +294,8 @@ package Exp_Unst is -- What we do is to always generate a local constant for any dynamic -- bound in a dynamic subtype xx with name xx_FIRST or xx_LAST. The one - -- case where we can skip this is where the bound is For - -- example in the third example above, subtype dynam is expanded as + -- case where we can skip this is where the bound is e.g. in the third + -- example above, subtype dynam is expanded as -- dynam_LAST : constant Integer := y + 3; -- subtype dynam is integer range x .. dynam_LAST; @@ -465,8 +465,8 @@ package Exp_Unst is -- return inner1 (x, AREC1P); -- end case4x; - -- As can be seen in this example, the level number following AREC in the - -- names avoids any confusion between AREC names at different levels. + -- As can be seen in this example, the index numbers following AREC in the + -- generated names avoid confusion between AREC names at different levels. ------------------------- -- Name Disambiguation -- diff --git a/gcc/ada/sem_cat.adb b/gcc/ada/sem_cat.adb index 83fe625f78e..15fa6ad3011 100644 --- a/gcc/ada/sem_cat.adb +++ b/gcc/ada/sem_cat.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -441,20 +441,15 @@ package body Sem_Cat is At_Any_Place : Boolean := False) return Boolean is Rep_Item : Node_Id; - Full_Type : Entity_Id := Typ; + Real_Rep : Node_Id; + -- The stream operation may be specified by an attribute definition + -- clause in the source, or by an aspect that generates such an + -- attribute definition. For an aspect, the generated attribute + -- definition may be placed at the freeze point of the full view of + -- the type, but the aspect specification makes the operation visible + -- to a client wherever the partial view is visible. begin - -- In the case of a type derived from a private view, any specified - -- stream attributes will be attached to the derived type's underlying - -- type rather the derived type entity itself (which is itself private). - - if Is_Private_Type (Typ) - and then Is_Derived_Type (Typ) - and then Present (Full_View (Typ)) - then - Full_Type := Underlying_Type (Typ); - end if; - -- We start from the declaration node and then loop until the end of -- the list until we find the requested attribute definition clause. -- In Ada 2005 mode, clauses are ignored if they are not currently @@ -462,10 +457,19 @@ package body Sem_Cat is -- inserted by the expander at the point where the clause occurs), -- unless At_Any_Place is true. - Rep_Item := First_Rep_Item (Full_Type); + Rep_Item := First_Rep_Item (Typ); while Present (Rep_Item) loop - if Nkind (Rep_Item) = N_Attribute_Definition_Clause then - case Chars (Rep_Item) is + Real_Rep := Rep_Item; + + -- If the representation item is an aspect specification, retrieve + -- the corresponding pragma or attribute definition. + + if Nkind (Rep_Item) = N_Aspect_Specification then + Real_Rep := Aspect_Rep_Item (Rep_Item); + end if; + + if Nkind (Real_Rep) = N_Attribute_Definition_Clause then + case Chars (Real_Rep) is when Name_Read => exit when Nam = TSS_Stream_Read; @@ -487,14 +491,29 @@ package body Sem_Cat is Next_Rep_Item (Rep_Item); end loop; - -- If At_Any_Place is true, return True if the attribute is available - -- at any place; if it is false, return True only if the attribute is - -- currently visible. + -- If not found, and the type is derived from a private view, check + -- for a stream attribute inherited from parent. Any specified stream + -- attributes will be attached to the derived type's underlying type + -- rather the derived type entity itself (which is itself private). + + if No (Rep_Item) + and then Is_Private_Type (Typ) + and then Is_Derived_Type (Typ) + and then Present (Full_View (Typ)) + then + return Has_Stream_Attribute_Definition + (Underlying_Type (Typ), Nam, At_Any_Place); + + -- Otherwise, if At_Any_Place is true, return True if the attribute is + -- available at any place; if it is false, return True only if the + -- attribute is currently visible. - return Present (Rep_Item) - and then (Ada_Version < Ada_2005 - or else At_Any_Place - or else not Is_Hidden (Entity (Rep_Item))); + else + return Present (Rep_Item) + and then (Ada_Version < Ada_2005 + or else At_Any_Place + or else not Is_Hidden (Entity (Rep_Item))); + end if; end Has_Stream_Attribute_Definition; ---------------------------- diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index e87af41e5e7..03fec8b9894 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -916,30 +916,30 @@ package body Sem_Ch4 is ---------------------------- -- The identification of conflicts in calls to functions with writable - -- actuals is performed in the analysis phase of the frontend to ensure + -- actuals is performed in the analysis phase of the front end to ensure -- that it reports exactly the same errors compiling with and without -- expansion enabled. It is performed in two stages: - -- 1) When a call to a function with out-mode parameters is found - -- we climb to the outermost enclosing construct which can be + -- 1) When a call to a function with out-mode parameters is found, + -- we climb to the outermost enclosing construct that can be -- evaluated in arbitrary order and we mark it with the flag -- Check_Actuals. - -- 2) When the analysis of the marked node is complete then we - -- traverse its decorated subtree searching for conflicts - -- (see function Sem_Util.Check_Function_Writable_Actuals). + -- 2) When the analysis of the marked node is complete, we traverse + -- its decorated subtree searching for conflicts (see function + -- Sem_Util.Check_Function_Writable_Actuals). - -- The unique exception to this general rule are aggregates, since - -- their analysis is performed by the frontend in the resolution - -- phase. For aggregates we do not climb to its enclosing construct: + -- The unique exception to this general rule is for aggregates, since + -- their analysis is performed by the front end in the resolution + -- phase. For aggregates we do not climb to their enclosing construct: -- we restrict the analysis to the subexpressions initializing the -- aggregate components. -- This implies that the analysis of expressions containing aggregates - -- is not complete since there may be conflicts on writable actuals + -- is not complete, since there may be conflicts on writable actuals -- involving subexpressions of the enclosing logical or arithmetic -- expressions. However, we cannot wait and perform the analysis when - -- the whole subtree is resolved since the subtrees may be transformed + -- the whole subtree is resolved, since the subtrees may be transformed, -- thus adding extra complexity and computation cost to identify and -- report exactly the same errors compiling with and without expansion -- enabled. @@ -948,9 +948,9 @@ package body Sem_Ch4 is function Is_Arbitrary_Evaluation_Order_Construct (N : Node_Id) return Boolean; - -- Return True if N is an Ada construct which may evaluate in - -- arbitrary order. This function does not cover all the language - -- constructs which can be evaluated in arbitrary order but the + -- Return True if N is an Ada construct which may be evaluated in + -- an arbitrary order. This function does not cover all the language + -- constructs that can be evaluated in arbitrary order, but only the -- subset needed for AI05-0144. --------------------------------------------- @@ -1003,11 +1003,11 @@ package body Sem_Ch4 is begin while Present (P) loop - -- For object declarations we can climb to such node from + -- For object declarations we can climb to the node from -- its object definition branch or from its initializing -- expression. We prefer to mark the child node as the -- outermost construct to avoid adding further complexity - -- to the routine which will take care later of + -- to the routine that will later take care of -- performing the writable actuals check. if Is_Arbitrary_Evaluation_Order_Construct (P) @@ -1407,8 +1407,8 @@ package body Sem_Ch4 is Check_Writable_Actuals (N); - -- If found and the outermost construct which can be evaluated in - -- arbitrary order is precisely this call then check all its + -- If found and the outermost construct that can be evaluated in + -- an arbitrary order is precisely this call, then check all its -- actuals. if Check_Actuals (N) then diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index b823d8006d1..57ec05c5698 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -2119,10 +2119,10 @@ package body Sem_Util is then return Skip; - -- For now we skip aggregate discriminants since they require + -- For now we skip aggregate discriminants, since they require -- performing the analysis in two phases to identify conflicts: -- first one analyzing discriminants and second one analyzing - -- the rest of components (since at runtime discriminants are + -- the rest of components (since at run time, discriminants are -- evaluated prior to components): too much computation cost -- to identify a corner case??? @@ -2191,8 +2191,8 @@ package body Sem_Util is -- Report the error on the second occurrence of the -- identifier. We cannot assume that N is the second - -- occurrence since traverse_func walks through Field2 - -- last (see comment in the body of traverse_func). + -- occurrence, since Traverse_Func walks through Field2 + -- last (see comment in the body of Traverse_Func). declare Elmt : Elmt_Id; -- 2.30.2