aboutsummaryrefslogtreecommitdiff
path: root/gcc/ada
diff options
context:
space:
mode:
authorArnaud Charlet <charlet@gcc.gnu.org>2017-04-25 10:56:41 +0200
committerArnaud Charlet <charlet@gcc.gnu.org>2017-04-25 10:56:41 +0200
commitb6e6a4e3804fc142a8c130cd2189f2461c9403ff (patch)
treef760767dba4ad37e4f3a5347e4b00c17d4b5f0c6 /gcc/ada
parentf8a219349a28d326ca09932040eec82c9fd841c4 (diff)
downloadgcc-b6e6a4e3804fc142a8c130cd2189f2461c9403ff.zip
gcc-b6e6a4e3804fc142a8c130cd2189f2461c9403ff.tar.gz
gcc-b6e6a4e3804fc142a8c130cd2189f2461c9403ff.tar.bz2
[multiple changes]
2017-04-25 Hristian Kirtchev <kirtchev@adacore.com> * sem_attr.adb, sem_ch5.adb: Minor reformatting. 2017-04-25 Bob Duff <duff@adacore.com> * types.ads: Minor: Fix '???' comment. * sem_ch8.adb: Minor comment fix. 2017-04-25 Bob Duff <duff@adacore.com> * 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 <squirek@adacore.com> * sem_ch3.adb (Analyze_Declarations): Add additional condition for edge case. 2017-04-25 Bob Duff <duff@adacore.com> * 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 <miranda@adacore.com> * 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 <kirtchev@adacore.com> * exp_util.adb (Build_Chain): Account for ancestor subtypes while traversing the derivation chain. From-SVN: r247150
Diffstat (limited to 'gcc/ada')
-rw-r--r--gcc/ada/ChangeLog41
-rw-r--r--gcc/ada/a-tags.adb36
-rw-r--r--gcc/ada/a-tags.ads12
-rw-r--r--gcc/ada/exp_dbug.adb2
-rw-r--r--gcc/ada/exp_disp.adb14
-rw-r--r--gcc/ada/exp_intr.adb2
-rw-r--r--gcc/ada/exp_util.adb36
-rw-r--r--gcc/ada/par-ch2.adb9
-rw-r--r--gcc/ada/par.adb4
-rw-r--r--gcc/ada/rtsfind.ads4
-rw-r--r--gcc/ada/scans.ads8
-rw-r--r--gcc/ada/scn.adb28
-rw-r--r--gcc/ada/sem_attr.adb15
-rw-r--r--gcc/ada/sem_ch3.adb2
-rw-r--r--gcc/ada/sem_ch5.adb23
-rw-r--r--gcc/ada/sem_ch8.adb2
-rw-r--r--gcc/ada/sem_dim.adb9
-rw-r--r--gcc/ada/sem_prag.adb51
-rw-r--r--gcc/ada/stringt.adb24
-rw-r--r--gcc/ada/stringt.ads20
-rw-r--r--gcc/ada/types.ads10
21 files changed, 207 insertions, 145 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index d3635f8..e9ef039 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,44 @@
+2017-04-25 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * sem_attr.adb, sem_ch5.adb: Minor reformatting.
+
+2017-04-25 Bob Duff <duff@adacore.com>
+
+ * types.ads: Minor: Fix '???' comment.
+ * sem_ch8.adb: Minor comment fix.
+
+2017-04-25 Bob Duff <duff@adacore.com>
+
+ * 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 <squirek@adacore.com>
+
+ * sem_ch3.adb (Analyze_Declarations): Add
+ additional condition for edge case.
+
+2017-04-25 Bob Duff <duff@adacore.com>
+
+ * 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 <miranda@adacore.com>
+
+ * 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 <kirtchev@adacore.com>
+
+ * exp_util.adb (Build_Chain): Account for ancestor
+ subtypes while traversing the derivation chain.
+
2017-04-25 Ed Schonberg <schonberg@adacore.com>
* sem_attr.adb: minor reformatting.
diff --git a/gcc/ada/a-tags.adb b/gcc/ada/a-tags.adb
index 08c4dd9..95bc208 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 1d247aa..7397de5 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 a2ddfc3..c617e88 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 d2ddb5e..65eb632 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 => <<boolean-value>>,
- -- Type_Is_Abstract => <<boolean-value>>,
+ -- Is_Abstract => <<boolean-value>>,
-- Needs_Finalization => <<boolean-value>>,
-- [ Size_Func => Size_Prim'Access, ]
-- [ Interfaces_Table => <<access-value>>, ]
@@ -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 3d0934c..4363c75 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 ef794d7..638f574 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 16e3be7..cd79ac3 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 6c39e33..26730d4 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 cbeb007..cf53e67 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 8ff3f9d..a8972be 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 ef03116..643fde9 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 98c057e..1d25da7 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 ed385dd..0c4d230 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 694c45f..46281ec 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 d879492..2fc7322 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 2c57bcb..d2edeeb 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 47402fb..a035827 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 175b80c..5070b1f 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 4b7c0e5..b057586 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 20093c1..8df9ff1 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