diff options
| -rw-r--r-- | gcc/ada/ChangeLog | 19 | ||||
| -rw-r--r-- | gcc/ada/einfo.ads | 2 | ||||
| -rw-r--r-- | gcc/ada/exp_unst.adb | 126 | ||||
| -rw-r--r-- | gcc/ada/exp_unst.ads | 14 | ||||
| -rw-r--r-- | gcc/ada/sem_cat.adb | 65 | ||||
| -rw-r--r-- | gcc/ada/sem_ch4.adb | 36 | ||||
| -rw-r--r-- | gcc/ada/sem_util.adb | 8 |
7 files changed, 156 insertions, 114 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 92decca..ccdf46b 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,22 @@ +2015-05-26 Gary Dismukes <dismukes@adacore.com> + + * einfo.ads, sem_util.adb, sem_ch4.adb: Minor reformatting. + +2015-05-26 Robert Dewar <dewar@adacore.com> + + * exp_unst.adb, exp_unst.ads: Change to using Subps table index for + making AREC entity names unique. + +2015-05-26 Ed Schonberg <schonberg@adacore.com> + + * 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 <dewar@adacore.com> * sem_util.adb: Minor code reorganization. diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index 8676713..5a309f9 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 872a35f..c2a7243 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 7b92dcd..084e904 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 83fe625..15fa6ad 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 e87af41..03fec8b 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 b823d80..57ec05c 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; |