From: Arnaud Charlet Date: Tue, 25 Apr 2017 08:56:41 +0000 (+0200) Subject: [multiple changes] X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=b6e6a4e3804fc142a8c130cd2189f2461c9403ff;p=gcc.git [multiple changes] 2017-04-25 Hristian Kirtchev * sem_attr.adb, sem_ch5.adb: Minor reformatting. 2017-04-25 Bob Duff * types.ads: Minor: Fix '???' comment. * sem_ch8.adb: Minor comment fix. 2017-04-25 Bob Duff * sem_prag.adb: Remove suspicious uses of Name_Buf. * stringt.ads, stringt.adb, exp_dbug.adb, sem_dim.adb: Remove Add_String_To_Name_Buffer, to avoid using the global Name_Buf. Add String_To_Name with no side effects. 2017-04-25 Justin Squirek * sem_ch3.adb (Analyze_Declarations): Add additional condition for edge case. 2017-04-25 Bob Duff * par-ch2.adb, scans.ads, scn.adb: Do not give an error for reserved words inside pragmas. This is necessary to allow the pragma name Interface to be used in pragma Ignore_Pragma. * par.adb: Minor comment fix. 2017-04-25 Javier Miranda * a-tags.ads, a-tags.adb (Type_Is_Abstract): Renamed as Is_Abstract. * rtsfind.ads (RE_Type_Is_Abstract): Renamed as Is_Abstract. * exp_disp.adb (Make_DT): Update occurrences of RE_Type_Is_Abstract. * exp_intr.adb (Expand_Dispatching_Constructor_Call): Update occurrences of RE_Type_Is_Abstract 2017-04-25 Hristian Kirtchev * exp_util.adb (Build_Chain): Account for ancestor subtypes while traversing the derivation chain. From-SVN: r247150 --- diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index d3635f86c1f..e9ef0397efa 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,44 @@ +2017-04-25 Hristian Kirtchev + + * sem_attr.adb, sem_ch5.adb: Minor reformatting. + +2017-04-25 Bob Duff + + * types.ads: Minor: Fix '???' comment. + * sem_ch8.adb: Minor comment fix. + +2017-04-25 Bob Duff + + * sem_prag.adb: Remove suspicious uses of Name_Buf. + * stringt.ads, stringt.adb, exp_dbug.adb, sem_dim.adb: Remove + Add_String_To_Name_Buffer, to avoid using the global Name_Buf. + Add String_To_Name with no side effects. + +2017-04-25 Justin Squirek + + * sem_ch3.adb (Analyze_Declarations): Add + additional condition for edge case. + +2017-04-25 Bob Duff + + * par-ch2.adb, scans.ads, scn.adb: Do not give an error for + reserved words inside pragmas. This is necessary to allow the + pragma name Interface to be used in pragma Ignore_Pragma. + * par.adb: Minor comment fix. + +2017-04-25 Javier Miranda + + * a-tags.ads, a-tags.adb (Type_Is_Abstract): Renamed as Is_Abstract. + * rtsfind.ads (RE_Type_Is_Abstract): Renamed as Is_Abstract. + * exp_disp.adb (Make_DT): Update occurrences of RE_Type_Is_Abstract. + * exp_intr.adb (Expand_Dispatching_Constructor_Call): Update + occurrences of RE_Type_Is_Abstract + +2017-04-25 Hristian Kirtchev + + * exp_util.adb (Build_Chain): Account for ancestor + subtypes while traversing the derivation chain. + 2017-04-25 Ed Schonberg * sem_attr.adb: minor reformatting. diff --git a/gcc/ada/a-tags.adb b/gcc/ada/a-tags.adb index 08c4dd91b6b..95bc2087df3 100644 --- a/gcc/ada/a-tags.adb +++ b/gcc/ada/a-tags.adb @@ -177,6 +177,24 @@ package body Ada.Tags is return To_Address (TSD.External_Tag); end Get_External_Tag; + ----------------- + -- Is_Abstract -- + ----------------- + + function Is_Abstract (T : Tag) return Boolean is + TSD_Ptr : Addr_Ptr; + TSD : Type_Specific_Data_Ptr; + + begin + if T = No_Tag then + raise Tag_Error; + end if; + + TSD_Ptr := To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size); + TSD := To_Type_Specific_Data_Ptr (TSD_Ptr.all); + return TSD.Is_Abstract; + end Is_Abstract; + ------------------- -- Is_Primary_DT -- ------------------- @@ -1023,24 +1041,6 @@ package body Ada.Tags is SSD (T).SSD_Table (Position).Kind := Value; end Set_Prim_Op_Kind; - ---------------------- - -- Type_Is_Abstract -- - ---------------------- - - function Type_Is_Abstract (T : Tag) return Boolean is - TSD_Ptr : Addr_Ptr; - TSD : Type_Specific_Data_Ptr; - - begin - if T = No_Tag then - raise Tag_Error; - end if; - - TSD_Ptr := To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size); - TSD := To_Type_Specific_Data_Ptr (TSD_Ptr.all); - return TSD.Type_Is_Abstract; - end Type_Is_Abstract; - -------------------- -- Unregister_Tag -- -------------------- diff --git a/gcc/ada/a-tags.ads b/gcc/ada/a-tags.ads index 1d247aac51a..7397de57324 100644 --- a/gcc/ada/a-tags.ads +++ b/gcc/ada/a-tags.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2016, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -45,7 +45,7 @@ -- time (in terms of source lines executed): -- Expanded_Name, Wide_Expanded_Name, Wide_Wide_Expanded_Name, External_Tag, --- Is_Descendant_At_Same_Level, Parent_Tag, Type_Is_Abstract +-- Is_Abstract, Is_Descendant_At_Same_Level, Parent_Tag, -- Descendant_Tag (when used with a library-level tagged type), -- Internal_Tag (when used with a library-level tagged type). @@ -105,8 +105,8 @@ package Ada.Tags is function Interface_Ancestor_Tags (T : Tag) return Tag_Array; pragma Ada_05 (Interface_Ancestor_Tags); - function Type_Is_Abstract (T : Tag) return Boolean; - pragma Ada_2012 (Type_Is_Abstract); + function Is_Abstract (T : Tag) return Boolean; + pragma Ada_2012 (Is_Abstract); Tag_Error : exception; @@ -138,7 +138,7 @@ private -- +-------------------+ -- | transportable | -- +-------------------+ - -- | type_is_abstract | + -- | is_abstract | -- +-------------------+ -- | needs finalization| -- +-------------------+ @@ -318,7 +318,7 @@ private -- for being used in remote calls as actuals for classwide formals or as -- return values for classwide functions. - Type_Is_Abstract : Boolean; + Is_Abstract : Boolean; -- True if the type is abstract (Ada 2012: AI05-0173) Needs_Finalization : Boolean; diff --git a/gcc/ada/exp_dbug.adb b/gcc/ada/exp_dbug.adb index a2ddfc369d4..c617e88d5bd 100644 --- a/gcc/ada/exp_dbug.adb +++ b/gcc/ada/exp_dbug.adb @@ -800,7 +800,7 @@ package body Exp_Dbug is and then No (Address_Clause (E)) and then not Has_Suffix then - Add_String_To_Name_Buffer (Strval (Interface_Name (E))); + Append (Global_Name_Buffer, Strval (Interface_Name (E))); -- All other cases besides the interface name case diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb index d2ddb5e62e8..65eb6328457 100644 --- a/gcc/ada/exp_disp.adb +++ b/gcc/ada/exp_disp.adb @@ -4833,7 +4833,7 @@ package body Exp_Disp is -- External_Tag => Cstring_Ptr!(Exname'Address)) -- HT_Link => HT_Link'Address, -- Transportable => <>, - -- Type_Is_Abstract => <>, + -- Is_Abstract => <>, -- Needs_Finalization => <>, -- [ Size_Func => Size_Prim'Access, ] -- [ Interfaces_Table => <>, ] @@ -5113,16 +5113,16 @@ package body Exp_Disp is New_Occurrence_Of (Transportable, Loc)); end; - -- Type_Is_Abstract (Ada 2012: AI05-0173). This functionality is - -- not available in the HIE runtime. + -- Is_Abstract (Ada 2012: AI05-0173). This functionality is not + -- available in the HIE runtime. - if RTE_Record_Component_Available (RE_Type_Is_Abstract) then + if RTE_Record_Component_Available (RE_Is_Abstract) then declare - Type_Is_Abstract : Entity_Id; + Is_Abstract : Entity_Id; begin - Type_Is_Abstract := Boolean_Literals (Is_Abstract_Type (Typ)); + Is_Abstract := Boolean_Literals (Is_Abstract_Type (Typ)); Append_To (TSD_Aggr_List, - New_Occurrence_Of (Type_Is_Abstract, Loc)); + New_Occurrence_Of (Is_Abstract, Loc)); end; end if; diff --git a/gcc/ada/exp_intr.adb b/gcc/ada/exp_intr.adb index 3d0934c8d69..4363c75a190 100644 --- a/gcc/ada/exp_intr.adb +++ b/gcc/ada/exp_intr.adb @@ -400,7 +400,7 @@ package body Exp_Intr is Make_Implicit_If_Statement (N, Condition => Make_Function_Call (Loc, Name => - New_Occurrence_Of (RTE (RE_Type_Is_Abstract), Loc), + New_Occurrence_Of (RTE (RE_Is_Abstract), Loc), Parameter_Associations => New_List (New_Copy_Tree (Tag_Arg))), Then_Statements => New_List ( diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index ef794d72e3f..638f57417e0 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -8230,17 +8230,45 @@ package body Exp_Util is Curr_Typ := Deriv_Typ; loop - -- Work with the view which contains the discriminants and stored - -- constraints. + -- Handle the case where the current type is a record which + -- derives from a subtype. + + -- subtype Sub_Typ is Par_Typ ... + -- type Deriv_Typ is Sub_Typ ... + + if Ekind (Curr_Typ) = E_Record_Type + and then Present (Parent_Subtype (Curr_Typ)) + then + Anc_Typ := Parent_Subtype (Curr_Typ); + + -- Handle the case where the current type is a record subtype of + -- another subtype. + + -- subtype Sub_Typ1 is Par_Typ ... + -- subtype Sub_Typ2 is Sub_Typ1 ... + + elsif Ekind (Curr_Typ) = E_Record_Subtype + and then Present (Cloned_Subtype (Curr_Typ)) + then + Anc_Typ := Cloned_Subtype (Curr_Typ); + + -- Otherwise use the direct parent type - Anc_Typ := Discriminated_View (Base_Type (Etype (Curr_Typ))); + else + Anc_Typ := Etype (Curr_Typ); + end if; - -- Use the first subtype when dealing with base types + -- Use the first subtype when dealing with itypes if Is_Itype (Anc_Typ) then Anc_Typ := First_Subtype (Anc_Typ); end if; + -- Work with the view which contains the discriminants and stored + -- constraints. + + Anc_Typ := Discriminated_View (Anc_Typ); + -- Stop the climb when either the parent type has been reached or -- there are no more ancestors left to examine. diff --git a/gcc/ada/par-ch2.adb b/gcc/ada/par-ch2.adb index 16e3be731c1..cd79ac3de29 100644 --- a/gcc/ada/par-ch2.adb +++ b/gcc/ada/par-ch2.adb @@ -268,6 +268,7 @@ package body Ch2 is -- Start of processing for P_Pragma begin + Inside_Pragma := True; Prag_Node := New_Node (N_Pragma, Token_Ptr); Scan; -- past PRAGMA Prag_Name := Token_Name; @@ -362,9 +363,10 @@ package body Ch2 is Semicolon_Loc := Token_Ptr; - -- Cancel indication of being within Depends pragm. Can be done - -- unconditionally, since quicker than doing a test. + -- Cancel indication of being within a pragma or in particular a Depends + -- pragma. + Inside_Pragma := False; Inside_Depends := False; -- Now we have two tasks left, we need to scan out the semicolon @@ -388,12 +390,11 @@ package body Ch2 is Skip_Pragma_Semicolon; return Par.Prag (Prag_Node, Semicolon_Loc); end if; - exception when Error_Resync => Resync_Past_Semicolon; + Inside_Pragma := False; return Error; - end P_Pragma; -- This routine is called if a pragma is encountered in an inappropriate diff --git a/gcc/ada/par.adb b/gcc/ada/par.adb index 6c39e330dc7..26730d497e6 100644 --- a/gcc/ada/par.adb +++ b/gcc/ada/par.adb @@ -70,8 +70,8 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is -- Par.Ch5.Get_Loop_Block_Name). Inside_Record_Definition : Boolean := False; - -- Flag set True within a record definition. Used to control warning - -- for redefinition of standard entities (not issued for field names). + -- True within a record definition. Used to control warning for + -- redefinition of standard entities (not issued for field names). -------------------- -- Error Recovery -- diff --git a/gcc/ada/rtsfind.ads b/gcc/ada/rtsfind.ads index cbeb007b970..cf53e6742d3 100644 --- a/gcc/ada/rtsfind.ads +++ b/gcc/ada/rtsfind.ads @@ -637,6 +637,7 @@ package Rtsfind is RE_Interface_Data, -- Ada.Tags RE_Interface_Data_Element, -- Ada.Tags RE_Interface_Tag, -- Ada.Tags + RE_Is_Abstract, -- Ada.Tags RE_IW_Membership, -- Ada.Tags RE_Max_Predef_Prims, -- Ada.Tags RE_Needs_Finalization, -- Ada.Tags @@ -668,7 +669,6 @@ package Rtsfind is RE_Signature, -- Ada.Tags RE_SSD, -- Ada.Tags RE_TSD, -- Ada.Tags - RE_Type_Is_Abstract, -- Ada.Tags RE_Type_Specific_Data, -- Ada.Tags RE_Register_Interface_Offset, -- Ada.Tags RE_Register_Tag, -- Ada.Tags @@ -1870,6 +1870,7 @@ package Rtsfind is RE_Interface_Data => Ada_Tags, RE_Interface_Data_Element => Ada_Tags, RE_Interface_Tag => Ada_Tags, + RE_Is_Abstract => Ada_Tags, RE_IW_Membership => Ada_Tags, RE_Max_Predef_Prims => Ada_Tags, RE_Needs_Finalization => Ada_Tags, @@ -1901,7 +1902,6 @@ package Rtsfind is RE_Signature => Ada_Tags, RE_SSD => Ada_Tags, RE_TSD => Ada_Tags, - RE_Type_Is_Abstract => Ada_Tags, RE_Type_Specific_Data => Ada_Tags, RE_Register_Interface_Offset => Ada_Tags, RE_Register_Tag => Ada_Tags, diff --git a/gcc/ada/scans.ads b/gcc/ada/scans.ads index 8ff3f9d0e29..a8972bed4f5 100644 --- a/gcc/ada/scans.ads +++ b/gcc/ada/scans.ads @@ -484,9 +484,13 @@ package Scans is -- Is it really right for this to be a Name rather than a String, what -- about the case of Wide_Wide_Characters??? + Inside_Pragma : Boolean := False; + -- True within a pragma. Used to avoid complaining about reserved words + -- within pragmas (see Scan_Reserved_Identifier). + Inside_Depends : Boolean := False; - -- Flag set True for parsing the argument of a Depends pragma or aspect - -- (used to allow/require non-standard style rules for =>+ with -gnatyt). + -- True while parsing the argument of a Depends pragma or aspect (used to + -- allow/require non-standard style rules for =>+ with -gnatyt). Inside_If_Expression : Nat := 0; -- This is a counter that is set non-zero while scanning out an if diff --git a/gcc/ada/scn.adb b/gcc/ada/scn.adb index ef0311619d5..643fde9b4c2 100644 --- a/gcc/ada/scn.adb +++ b/gcc/ada/scn.adb @@ -255,9 +255,7 @@ package body Scn is -- Clear flags for reserved words used as identifiers - for J in Token_Type loop - Used_As_Identifier (J) := False; - end loop; + Used_As_Identifier := (others => False); end Initialize_Scanner; --------------- @@ -380,8 +378,8 @@ package body Scn is ------------------------------ procedure Scan_Reserved_Identifier (Force_Msg : Boolean) is - Token_Chars : constant String := Token_Type'Image (Token); - + Token_Chars : String := Token_Type'Image (Token); + Len : Natural := 0; begin -- AI12-0125 : '@' denotes the target_name, i.e. serves as an -- abbreviation for the LHS of an assignment. @@ -394,16 +392,24 @@ package body Scn is -- We have in Token_Chars the image of the Token name, i.e. Tok_xxx. -- This code extracts the xxx and makes an identifier out of it. - Name_Len := 0; - for J in 5 .. Token_Chars'Length loop - Name_Len := Name_Len + 1; - Name_Buffer (Name_Len) := Fold_Lower (Token_Chars (J)); + Len := Len + 1; + Token_Chars (Len) := Fold_Lower (Token_Chars (J)); end loop; - Token_Name := Name_Find; + Token_Name := Name_Find (Token_Chars (1 .. Len)); - if not Used_As_Identifier (Token) or else Force_Msg then + -- If Inside_Pragma is True, we don't give an error. This is to allow + -- things like "pragma Ignore_Pragma (Interface)", where "Interface" is + -- a reserved word. There is no danger of missing errors, because any + -- misuse must have been preceded by an illegal declaration. For + -- example, in "pragma Pack (Begin);", either Begin is not declared, + -- which is an error, or it is declared, which will be an error on that + -- declaration. + + if (not Used_As_Identifier (Token) or else Force_Msg) + and then not Inside_Pragma + then Error_Msg_Name_1 := Token_Name; Error_Msg_SC ("reserved word* cannot be used as identifier!"); Used_As_Identifier (Token) := True; diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index 98c057e5ef5..1d25da729ba 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -10522,10 +10522,10 @@ package body Sem_Attr is -- also be accessibility checks on those, this is where the -- checks can eventually be centralized ??? - if Ekind_In (Btyp, E_Access_Subprogram_Type, - E_Anonymous_Access_Subprogram_Type, - E_Access_Protected_Subprogram_Type, - E_Anonymous_Access_Protected_Subprogram_Type) + if Ekind_In (Btyp, E_Access_Protected_Subprogram_Type, + E_Access_Subprogram_Type, + E_Anonymous_Access_Protected_Subprogram_Type, + E_Anonymous_Access_Subprogram_Type) then -- Deal with convention mismatch @@ -10545,9 +10545,10 @@ package body Sem_Attr is Entity (Name (Parent (N))); begin if Convention (Subp) = Convention_Intrinsic then - Error_Msg_FE ("?subprogram and its formal " - & "access parameters have convention Intrinsic", - Parent (N), Subp); + Error_Msg_FE + ("?subprogram and its formal access " + & "parameters have convention Intrinsic", + Parent (N), Subp); Error_Msg_N ("actual cannot be access attribute", N); end if; diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index ed385dd5e0a..0c4d2301a3c 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -2646,6 +2646,8 @@ package body Sem_Ch3 is and then Was_Expression_Function (Next_Decl) and then not Is_Compilation_Unit (Current_Scope) and then not Is_Generic_Instance (Current_Scope) + and then not In_Package_Body + (Enclosing_Lib_Unit_Entity (Current_Scope)) then -- Loop through all entities in the current scope to identify -- an instance of the edge case outlined above and ignore diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb index 694c45f6dc1..46281ec97c2 100644 --- a/gcc/ada/sem_ch5.adb +++ b/gcc/ada/sem_ch5.adb @@ -100,11 +100,13 @@ package body Sem_Ch5 is -- Ghost mode. procedure Analyze_Assignment (N : Node_Id) is - Lhs : constant Node_Id := Name (N); - Rhs : constant Node_Id := Expression (N); - T1 : Entity_Id; - T2 : Entity_Id; - Decl : Node_Id; + Lhs : constant Node_Id := Name (N); + Rhs : constant Node_Id := Expression (N); + + Decl : Node_Id; + T1 : Entity_Id; + T2 : Entity_Id; + Save_Full_Analysis : Boolean; procedure Diagnose_Non_Variable_Lhs (N : Node_Id); @@ -312,11 +314,12 @@ package body Sem_Ch5 is Analyze (Rhs); -- Ensure that we never do an assignment on a variable marked as - -- as Safe_To_Reevaluate. + -- Is_Safe_To_Reevaluate. - pragma Assert (not Is_Entity_Name (Lhs) - or else Ekind (Entity (Lhs)) /= E_Variable - or else not Is_Safe_To_Reevaluate (Entity (Lhs))); + pragma Assert + (not Is_Entity_Name (Lhs) + or else Ekind (Entity (Lhs)) /= E_Variable + or else not Is_Safe_To_Reevaluate (Entity (Lhs))); -- Start type analysis for assignment @@ -3558,8 +3561,8 @@ package body Sem_Ch5 is ------------------------ procedure Analyze_Statements (L : List_Id) is - S : Node_Id; Lab : Entity_Id; + S : Node_Id; begin -- The labels declared in the statement list are reachable from diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb index d8794920f8b..2fc7322fcb1 100644 --- a/gcc/ada/sem_ch8.adb +++ b/gcc/ada/sem_ch8.adb @@ -3776,7 +3776,7 @@ package body Sem_Ch8 is end if; -- If the Used_Operations list is already initialized, the clause has - -- been analyzed previously, and it is begin reinstalled, for example + -- been analyzed previously, and it is being reinstalled, for example -- when the clause appears in a package spec and we are compiling the -- corresponding package body. In that case, make the entities on the -- existing list use_visible, and mark the corresponding types In_Use. diff --git a/gcc/ada/sem_dim.adb b/gcc/ada/sem_dim.adb index 2c57bcb5227..d2edeebaede 100644 --- a/gcc/ada/sem_dim.adb +++ b/gcc/ada/sem_dim.adb @@ -2521,8 +2521,9 @@ package body Sem_Dim is Add_Str_To_Name_Buffer ("has dimension "); end if; - Add_String_To_Name_Buffer - (From_Dim_To_Str_Of_Dim_Symbols (Dims_Of_N, System, True)); + Append + (Global_Name_Buffer, + From_Dim_To_Str_Of_Dim_Symbols (Dims_Of_N, System, True)); -- N is dimensionless @@ -2562,12 +2563,12 @@ package body Sem_Dim is Name_Len := 0; - Add_String_To_Name_Buffer (String_From_Numeric_Literal (N)); + Append (Global_Name_Buffer, String_From_Numeric_Literal (N)); -- Insert a blank between the literal and the symbol Add_Str_To_Name_Buffer (" "); - Add_String_To_Name_Buffer (Symbol_Of (Typ)); + Append (Global_Name_Buffer, Symbol_Of (Typ)); Error_Msg_Name_1 := Name_Find; Error_Msg_N ("assumed to be%%??", N); diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 47402fb2044..a03582738b1 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -5941,9 +5941,7 @@ package body Sem_Prag is procedure Check_Optional_Identifier (Arg : Node_Id; Id : String) is begin - Name_Buffer (1 .. Id'Length) := Id; - Name_Len := Id'Length; - Check_Optional_Identifier (Arg, Name_Find); + Check_Optional_Identifier (Arg, Name_Find (Id)); end Check_Optional_Identifier; ------------------------------------- @@ -8300,8 +8298,7 @@ package body Sem_Prag is Nam : Name_Id; begin - String_To_Name_Buffer (Strval (Expression (Arg3))); - Nam := Name_Find; + Nam := String_To_Name (Strval (Expression (Arg3))); Elmt := First_Elmt (Predefined_Float_Types); while Present (Elmt) and then Chars (Node (Elmt)) /= Nam loop @@ -9223,8 +9220,7 @@ package body Sem_Prag is begin if Prag_Id = Pragma_Import then - String_To_Name_Buffer (Strval (Expr_Value_S (Ext_Nam))); - Nam := Name_Find; + Nam := String_To_Name (Strval (Expr_Value_S (Ext_Nam))); E := Entity_Id (Get_Name_Table_Int (Nam)); if Nam /= Chars (Subprogram_Def) @@ -10273,20 +10269,9 @@ package body Sem_Prag is -- No_Dependence => Ada.Execution_Time.Group_Budget -- No_Dependence => Ada.Execution_Time.Timers - -- ??? The use of Name_Buffer here is suspicious. The names should - -- be registered in snames.ads-tmpl and used to build the qualified - -- names of units. - if Ada_Version >= Ada_2005 then - Name_Buffer (1 .. 3) := "ada"; - Name_Len := 3; - - Pref_Id := Make_Identifier (Loc, Name_Find); - - Name_Buffer (1 .. 14) := "execution_time"; - Name_Len := 14; - - Sel_Id := Make_Identifier (Loc, Name_Find); + Pref_Id := Make_Identifier (Loc, Name_Find ("ada")); + Sel_Id := Make_Identifier (Loc, Name_Find ("execution_time")); Pref := Make_Selected_Component @@ -10294,10 +10279,7 @@ package body Sem_Prag is Prefix => Pref_Id, Selector_Name => Sel_Id); - Name_Buffer (1 .. 13) := "group_budgets"; - Name_Len := 13; - - Sel_Id := Make_Identifier (Loc, Name_Find); + Sel_Id := Make_Identifier (Loc, Name_Find ("group_budgets")); Nod := Make_Selected_Component @@ -10310,10 +10292,7 @@ package body Sem_Prag is Warn => Treat_Restrictions_As_Warnings, Profile => Ravenscar); - Name_Buffer (1 .. 6) := "timers"; - Name_Len := 6; - - Sel_Id := Make_Identifier (Loc, Name_Find); + Sel_Id := Make_Identifier (Loc, Name_Find ("timers")); Nod := Make_Selected_Component @@ -10332,15 +10311,8 @@ package body Sem_Prag is -- No_Dependence => System.Multiprocessors.Dispatching_Domains if Ada_Version >= Ada_2012 then - Name_Buffer (1 .. 6) := "system"; - Name_Len := 6; - - Pref_Id := Make_Identifier (Loc, Name_Find); - - Name_Buffer (1 .. 15) := "multiprocessors"; - Name_Len := 15; - - Sel_Id := Make_Identifier (Loc, Name_Find); + Pref_Id := Make_Identifier (Loc, Name_Find ("system")); + Sel_Id := Make_Identifier (Loc, Name_Find ("multiprocessors")); Pref := Make_Selected_Component @@ -10348,10 +10320,7 @@ package body Sem_Prag is Prefix => Pref_Id, Selector_Name => Sel_Id); - Name_Buffer (1 .. 19) := "dispatching_domains"; - Name_Len := 19; - - Sel_Id := Make_Identifier (Loc, Name_Find); + Sel_Id := Make_Identifier (Loc, Name_Find ("dispatching_domains")); Nod := Make_Selected_Component diff --git a/gcc/ada/stringt.adb b/gcc/ada/stringt.adb index 175b80c257d..5070b1fab28 100644 --- a/gcc/ada/stringt.adb +++ b/gcc/ada/stringt.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2016, 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- -- @@ -75,14 +75,9 @@ package body Stringt is -- Release to get a snapshot of the tables and to restore them to their -- previous situation. - ------------------------------- - -- Add_String_To_Name_Buffer -- - ------------------------------- - - procedure Add_String_To_Name_Buffer (S : String_Id) is - begin - Append (Global_Name_Buffer, S); - end Add_String_To_Name_Buffer; + ------------ + -- Append -- + ------------ procedure Append (Buf : in out Bounded_String; S : String_Id) is begin @@ -324,6 +319,17 @@ package body Stringt is return Strings.Table (Id).Length; end String_Length; + -------------------- + -- String_To_Name -- + -------------------- + + function String_To_Name (S : String_Id) return Name_Id is + Buf : Bounded_String; + begin + Append (Buf, S); + return Name_Find (Buf); + end String_To_Name; + --------------------------- -- String_To_Name_Buffer -- --------------------------- diff --git a/gcc/ada/stringt.ads b/gcc/ada/stringt.ads index 4b7c0e5ad50..b057586b6ea 100644 --- a/gcc/ada/stringt.ads +++ b/gcc/ada/stringt.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2016, 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- -- @@ -47,9 +47,9 @@ package Stringt is -- is implemented in the scanner. -- There is no guarantee that hashing is used in the implementation, although --- it maybe. This means that the caller cannot count on having the same Id +-- it may be. This means that the caller cannot count on having the same Id -- value for two identical strings stored separately and also cannot count on --- the two Id values being different. +-- the two such Id values being different. Null_String_Id : String_Id; -- Gets set to a null string with length zero @@ -119,18 +119,18 @@ package Stringt is function String_Equal (L, R : String_Id) return Boolean; -- Determines if two string literals represent the same string - procedure String_To_Name_Buffer (S : String_Id); - -- Place characters of given string in Name_Buffer, setting Name_Len. - -- Error if any characters are out of Character range. Does not attempt - -- to do any encoding of any characters. + function String_To_Name (S : String_Id) return Name_Id; + -- Convert String_Id to Name_Id procedure Append (Buf : in out Bounded_String; S : String_Id); -- Append characters of given string to Buf. Error if any characters are - -- out of Character range. Does not attempt to do any encoding of any + -- out of Character range. Does not attempt to do any encoding of -- characters. - procedure Add_String_To_Name_Buffer (S : String_Id); - -- Same as Append (Global_Name_Buffer, S) + procedure String_To_Name_Buffer (S : String_Id); + -- Place characters of given string in Name_Buffer, setting Name_Len. + -- Error if any characters are out of Character range. Does not attempt + -- to do any encoding of any characters. function String_Chars_Address return System.Address; -- Return address of String_Chars table (used by Back_End call to Gigi) diff --git a/gcc/ada/types.ads b/gcc/ada/types.ads index 20093c19abd..8df9ff17a53 100644 --- a/gcc/ada/types.ads +++ b/gcc/ada/types.ads @@ -256,6 +256,11 @@ package Types is -- Universal integers (type Uint) -- Universal reals (type Ureal) + -- These types are represented as integer indices into various tables. + -- However, they should be treated as private, except in a few documented + -- cases. In particular it is never appropriate to perform arithmetic + -- operations using these types. + -- In most contexts, the strongly typed interface determines which of these -- types is present. However, there are some situations (involving untyped -- traversals of the tree), where it is convenient to be easily able to @@ -486,11 +491,6 @@ package Types is -- String_Id values are used to identify entries in the strings table. They -- are subscripts into the Strings table defined in package Stringt. - -- Note that with only a few exceptions, which are clearly documented, the - -- type String_Id should be regarded as a private type. In particular it is - -- never appropriate to perform arithmetic operations using this type. - -- Doesn't this also apply to all other *_Id types??? - type String_Id is range Strings_Low_Bound .. Strings_High_Bound; -- Type used to identify entries in the strings table