From 7e5e5cc7c4f75b465e1bcb0e4e5037297c5ce38e Mon Sep 17 00:00:00 2001 From: Robert Dewar Date: Wed, 26 Mar 2008 08:43:59 +0100 Subject: [PATCH] tbuild.ads, [...] (N_Pragma): Chars field removed, use Chars (Pragma_Identifier (.. 2008-03-26 Robert Dewar * tbuild.ads, tbuild.adb, trans.c, sprint.adb, exp_prag.adb, decl.c, par-ch2.adb, sem_elab.adb, sem_util.ads (N_Pragma): Chars field removed, use Chars (Pragma_Identifier (.. instead, adjustments throughout to accomodate this change. * s-pooglo.ads, s-pooloc.ads: Minor comment updates * exp_dbug.adb: Use Sem_Util.Set_Debug_Info_Needed (not Einfo.Set_Needs_Debug_Info) From-SVN: r133587 --- gcc/ada/decl.c | 7 ++++--- gcc/ada/exp_dbug.adb | 2 +- gcc/ada/exp_prag.adb | 20 ++++++++++---------- gcc/ada/par-ch2.adb | 41 ++++++++++++++++++++++------------------- gcc/ada/s-pooglo.ads | 5 ++++- gcc/ada/s-pooloc.ads | 4 +++- gcc/ada/sem_elab.adb | 32 +++++++++++++++----------------- gcc/ada/sem_util.ads | 39 ++++++++++++++++++++++++++------------- gcc/ada/sprint.adb | 4 ++-- gcc/ada/tbuild.adb | 3 +-- gcc/ada/tbuild.ads | 2 +- gcc/ada/trans.c | 5 +++-- 12 files changed, 92 insertions(+), 72 deletions(-) diff --git a/gcc/ada/decl.c b/gcc/ada/decl.c index f7b51d5c977..0db79b57646 100644 --- a/gcc/ada/decl.c +++ b/gcc/ada/decl.c @@ -5035,7 +5035,7 @@ prepend_attributes (Entity_Id gnat_entity, struct attrib ** attr_list) (First (gnat_assoc))))))); } - switch (Get_Pragma_Id (Chars (gnat_temp))) + switch (Get_Pragma_Id (Pragma_Identifier (Chars (gnat_temp)))) { case Pragma_Machine_Attribute: etype = ATTR_MACHINE_ATTRIBUTE; @@ -7068,10 +7068,11 @@ check_ok_for_atomic (tree object, Entity_Id gnat_entity, bool comp_p) gnat_node = Next_Rep_Item (gnat_node)) { if (!comp_p && Nkind (gnat_node) == N_Pragma - && Get_Pragma_Id (Chars (gnat_node)) == Pragma_Atomic) + && (Get_Pragma_Id (Chars (Pragma_Identifier (gnat_node))) + == Pragma_Atomic)) gnat_error_point = First (Pragma_Argument_Associations (gnat_node)); else if (comp_p && Nkind (gnat_node) == N_Pragma - && (Get_Pragma_Id (Chars (gnat_node)) + && (Get_Pragma_Id (Chars (Pragma_Identifier (gnat_node))) == Pragma_Atomic_Components)) gnat_error_point = First (Pragma_Argument_Associations (gnat_node)); } diff --git a/gcc/ada/exp_dbug.adb b/gcc/ada/exp_dbug.adb index 3a28087c209..39e5bde8400 100644 --- a/gcc/ada/exp_dbug.adb +++ b/gcc/ada/exp_dbug.adb @@ -464,7 +464,7 @@ package body Exp_Dbug is Set_Debug_Renaming_Link (Obj, Entity (Ren)); - Set_Needs_Debug_Info (Obj); + Set_Debug_Info_Needed (Obj); -- Mark the object as internal so that it won't be initialized when -- pragma Initialize_Scalars or Normalize_Scalars is in use. diff --git a/gcc/ada/exp_prag.adb b/gcc/ada/exp_prag.adb index 27869a83827..deabc2d27bd 100644 --- a/gcc/ada/exp_prag.adb +++ b/gcc/ada/exp_prag.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2008, 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- -- @@ -116,12 +116,14 @@ package body Exp_Prag is --------------------- procedure Expand_N_Pragma (N : Node_Id) is + Pname : constant Name_Id := Pragma_Name (N); + begin - -- Note: we may have a pragma whose chars field is not a + -- Note: we may have a pragma whose Pragma_Identifier field is not a -- recognized pragma, and we must ignore it at this stage. - if Is_Pragma_Name (Chars (N)) then - case Get_Pragma_Id (Chars (N)) is + if Is_Pragma_Name (Pname) then + case Get_Pragma_Id (Pname) is -- Pragmas requiring special expander action @@ -350,6 +352,8 @@ package body Exp_Prag is -- For now we do nothing with the size attribute ??? + -- Note: Psect_Object shares this processing + procedure Expand_Pragma_Common_Object (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); @@ -392,7 +396,6 @@ package body Exp_Prag is -- Insert the pragma Insert_After_And_Analyze (N, - Make_Pragma (Loc, Chars => Name_Machine_Attribute, Pragma_Argument_Associations => New_List ( @@ -731,10 +734,7 @@ package body Exp_Prag is -- Convert to Common_Object, and expand the resulting pragma - procedure Expand_Pragma_Psect_Object (N : Node_Id) is - begin - Set_Chars (N, Name_Common_Object); - Expand_Pragma_Common_Object (N); - end Expand_Pragma_Psect_Object; + procedure Expand_Pragma_Psect_Object (N : Node_Id) + renames Expand_Pragma_Common_Object; end Exp_Prag; diff --git a/gcc/ada/par-ch2.adb b/gcc/ada/par-ch2.adb index 697cf86d834..718afcc6a12 100644 --- a/gcc/ada/par-ch2.adb +++ b/gcc/ada/par-ch2.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2008, 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- -- @@ -241,8 +241,8 @@ package body Ch2 is -- Set True if an identifier is encountered for a pragma argument. Used -- to check that there are no more arguments without identifiers. - Pragma_Node : Node_Id; - Pragma_Name : Name_Id; + Prag_Node : Node_Id; + Prag_Name : Name_Id; Semicolon_Loc : Source_Ptr; Ident_Node : Node_Id; Assoc_Node : Node_Id; @@ -280,9 +280,9 @@ package body Ch2 is -- Start of processing for P_Pragma begin - Pragma_Node := New_Node (N_Pragma, Token_Ptr); + Prag_Node := New_Node (N_Pragma, Token_Ptr); Scan; -- past PRAGMA - Pragma_Name := Token_Name; + Prag_Name := Token_Name; if Style_Check then Style.Check_Pragma_Name; @@ -294,21 +294,20 @@ package body Ch2 is if Ada_Version >= Ada_05 and then Token = Tok_Interface then - Pragma_Name := Name_Interface; + Prag_Name := Name_Interface; Ident_Node := Make_Identifier (Token_Ptr, Name_Interface); Scan; -- past INTERFACE else Ident_Node := P_Identifier; end if; - Set_Chars (Pragma_Node, Pragma_Name); - Set_Pragma_Identifier (Pragma_Node, Ident_Node); + Set_Pragma_Identifier (Prag_Node, Ident_Node); -- See if special INTERFACE/IMPORT check is required if SIS_Entry_Active then - Interface_Check_Required := (Pragma_Name = Name_Interface); - Import_Check_Required := (Pragma_Name = Name_Import); + Interface_Check_Required := (Prag_Name = Name_Interface); + Import_Check_Required := (Prag_Name = Name_Import); else Interface_Check_Required := False; Import_Check_Required := False; @@ -322,7 +321,7 @@ package body Ch2 is or else (Token /= Tok_Semicolon and then not Token_Is_At_Start_Of_Line) then - Set_Pragma_Argument_Associations (Pragma_Node, New_List); + Set_Pragma_Argument_Associations (Prag_Node, New_List); T_Left_Paren; loop @@ -342,7 +341,7 @@ package body Ch2 is end if; end if; - Append (Assoc_Node, Pragma_Argument_Associations (Pragma_Node)); + Append (Assoc_Node, Pragma_Argument_Associations (Prag_Node)); exit when Token /= Tok_Comma; Scan; -- past comma end loop; @@ -352,7 +351,7 @@ package body Ch2 is -- statement, and an assignment statement is the most likely -- candidate for this error) - if Token = Tok_Colon_Equal and then Pragma_Name = Name_Debug then + if Token = Tok_Colon_Equal and then Prag_Name = Name_Debug then Error_Msg_SC ("argument for pragma Debug must be procedure call"); Resync_To_Semicolon; @@ -378,13 +377,13 @@ package body Ch2 is -- case of pragma Source_File_Name, which assume the semicolon -- is already scanned out. - if Chars (Pragma_Node) = Name_Style_Checks then - Result := Par.Prag (Pragma_Node, Semicolon_Loc); + if Prag_Name = Name_Style_Checks then + Result := Par.Prag (Prag_Node, Semicolon_Loc); Skip_Pragma_Semicolon; return Result; else Skip_Pragma_Semicolon; - return Par.Prag (Pragma_Node, Semicolon_Loc); + return Par.Prag (Prag_Node, Semicolon_Loc); end if; exception @@ -434,14 +433,18 @@ package body Ch2 is -- Error recovery: Cannot raise Error_Resync procedure P_Pragmas_Opt (List : List_Id) is - P : Node_Id; + P : Node_Id; begin while Token = Tok_Pragma loop P := P_Pragma; - if Chars (P) = Name_Assert or else Chars (P) = Name_Debug then - Error_Msg_Name_1 := Chars (P); + if Nkind (P) /= N_Error + and then (Pragma_Name (P) = Name_Assert + or else + Pragma_Name (P) = Name_Debug) + then + Error_Msg_Name_1 := Pragma_Name (P); Error_Msg_N ("pragma% must be in declaration/statement context", P); else diff --git a/gcc/ada/s-pooglo.ads b/gcc/ada/s-pooglo.ads index 734a1c12826..0cb0396754b 100644 --- a/gcc/ada/s-pooglo.ads +++ b/gcc/ada/s-pooglo.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2005 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2007, 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- -- @@ -31,6 +31,9 @@ -- -- ------------------------------------------------------------------------------ +-- Storage pool corresponding to default global storage pool used for +-- types for which no storage pool is specified. + with System; with System.Storage_Pools; with System.Storage_Elements; diff --git a/gcc/ada/s-pooloc.ads b/gcc/ada/s-pooloc.ads index c7fe93ed6b3..e9a975a59c9 100644 --- a/gcc/ada/s-pooloc.ads +++ b/gcc/ada/s-pooloc.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2005, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2007, 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- -- @@ -31,6 +31,8 @@ -- -- ------------------------------------------------------------------------------ +-- Storage pool for use with local objects with automatic reclaim + with System.Storage_Elements; with System.Pool_Global; diff --git a/gcc/ada/sem_elab.adb b/gcc/ada/sem_elab.adb index e3bd6897a1c..922a16d53ae 100644 --- a/gcc/ada/sem_elab.adb +++ b/gcc/ada/sem_elab.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1997-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1997-2008, 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- -- @@ -1654,12 +1654,6 @@ package body Sem_Elab is return; end if; - -- All OK if warnings suppressed on the entity - - if Warnings_Off (Ent) then - return; - end if; - -- All OK if all warnings suppressed if Warning_Mode = Suppress then @@ -1691,16 +1685,20 @@ package body Sem_Elab is -- Here is where we give the warning - Error_Msg_Sloc := Sloc (Ent); + -- All OK if warnings suppressed on the entity - Error_Msg_NE - ("?elaboration code may access& before it is initialized", - N, Ent); - Error_Msg_NE - ("\?suggest adding pragma Elaborate_Body to spec of &", - N, Scop); - Error_Msg_N - ("\?or an explicit initialization could be added #", N); + if not Has_Warnings_Off (Ent) then + Error_Msg_Sloc := Sloc (Ent); + + Error_Msg_NE + ("?elaboration code may access& before it is initialized", + N, Ent); + Error_Msg_NE + ("\?suggest adding pragma Elaborate_Body to spec of &", + N, Scop); + Error_Msg_N + ("\?or an explicit initialization could be added #", N); + end if; if not All_Errors_Mode then Set_Suppress_Elaboration_Warnings (Ent); @@ -3109,7 +3107,7 @@ package body Sem_Elab is Item := First (Context_Items (Cunit (Current_Sem_Unit))); while Present (Item) loop if Nkind (Item) = N_Pragma - and then Get_Pragma_Id (Chars (Item)) = Pragma_Elaborate_All + and then Pragma_Name (Item) = Name_Elaborate_All then -- Return if some previous error on the pragma itself diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index 58dbb536bb1..b48c8a95446 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2008, 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- -- @@ -440,6 +440,15 @@ package Sem_Util is -- which is the innermost visible entity with the given name. See the -- body of Sem_Ch8 for further details on handling of entity visibility. + function Get_Pragma_Id (N : Node_Id) return Pragma_Id; + pragma Inline (Get_Pragma_Id); + -- Obtains the Pragma_Id from the Chars field of Pragma_Identifier (N) + + function Get_Referenced_Object (N : Node_Id) return Node_Id; + -- Given a node, return the renamed object if the node represents a renamed + -- object, otherwise return the node unchanged. The node may represent an + -- arbitrary expression. + function Get_Renamed_Entity (E : Entity_Id) return Entity_Id; -- Given an entity for an exception, package, subprogram or generic unit, -- returns the ultimately renamed entity if this is a renaming. If this is @@ -452,11 +461,6 @@ package Sem_Util is -- related subprogram or entry and returns it, or if no subprogram can -- be found, returns Empty. - function Get_Referenced_Object (N : Node_Id) return Node_Id; - -- Given a node, return the renamed object if the node represents - -- a renamed object, otherwise return the node unchanged. The node - -- may represent an arbitrary expression. - function Get_Subprogram_Body (E : Entity_Id) return Node_Id; -- Given the entity for a subprogram (E_Function or E_Procedure), -- return the corresponding N_Subprogram_Body node. If the corresponding @@ -476,17 +480,18 @@ package Sem_Util is -- T contains access values (happens for generic formals in some -- cases), then False is returned. + function Has_Abstract_Interfaces + (T : Entity_Id; + Use_Full_View : Boolean := True) return Boolean; + -- Where T is a concurrent type or a record type, returns true if T covers + -- any abstract interface types. In case of private types the argument + -- Use_Full_View controls if the check is done using its full view (if + -- available). + type Alignment_Result is (Known_Compatible, Unknown, Known_Incompatible); -- Result of Has_Compatible_Alignment test, description found below. Note -- that the values are arranged in increasing order of problematicness. - function Has_Abstract_Interfaces - (Tagged_Type : Entity_Id; - Use_Full_View : Boolean := True) return Boolean; - -- Returns true if Tagged_Type implements some abstract interface. In case - -- private types the argument Use_Full_View controls if the check is done - -- using its full view (if available). - function Has_Compatible_Alignment (Obj : Entity_Id; Expr : Node_Id) return Alignment_Result; @@ -1028,6 +1033,14 @@ package Sem_Util is -- Establish the entity E as the currently visible definition of its -- associated name (i.e. the Node_Id associated with its name) + procedure Set_Debug_Info_Needed (T : Entity_Id); + -- Sets the Debug_Info_Needed flag on entity T , and also on any entities + -- that are needed by T (for an object, the type of the object is needed, + -- and for a type, various subsidiary types are needed -- see body for + -- details). Never has any effect on T if the Debug_Info_Off flag is set. + -- This routine should always be used instead of Set_Needs_Debug_Info to + -- ensure that subsidiary entities are properly handled. + procedure Set_Entity_With_Style_Check (N : Node_Id; Val : Entity_Id); -- This procedure has the same calling sequence as Set_Entity, but -- if Style_Check is set, then it calls a style checking routine which diff --git a/gcc/ada/sprint.adb b/gcc/ada/sprint.adb index e37ba36446c..7db69e479f4 100644 --- a/gcc/ada/sprint.adb +++ b/gcc/ada/sprint.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2008, 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- -- @@ -2387,7 +2387,7 @@ package body Sprint is when N_Pragma => Write_Indent_Str_Sloc ("pragma "); - Write_Name_With_Col_Check (Chars (Node)); + Write_Name_With_Col_Check (Pragma_Name (Node)); if Present (Pragma_Argument_Associations (Node)) then Sprint_Opt_Paren_Comma_List diff --git a/gcc/ada/tbuild.adb b/gcc/ada/tbuild.adb index ce9159bd675..b3ddd631946 100644 --- a/gcc/ada/tbuild.adb +++ b/gcc/ada/tbuild.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2008, 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- -- @@ -360,7 +360,6 @@ package body Tbuild is begin return Make_Pragma (Sloc, - Chars => Chars, Pragma_Argument_Associations => Pragma_Argument_Associations, Debug_Statement => Debug_Statement, Pragma_Identifier => Make_Identifier (Sloc, Chars)); diff --git a/gcc/ada/tbuild.ads b/gcc/ada/tbuild.ads index 886bb1cba6c..17be6272f7a 100644 --- a/gcc/ada/tbuild.ads +++ b/gcc/ada/tbuild.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2008, 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- -- diff --git a/gcc/ada/trans.c b/gcc/ada/trans.c index 8bec7759bea..8bf93d2e711 100644 --- a/gcc/ada/trans.c +++ b/gcc/ada/trans.c @@ -687,10 +687,11 @@ Pragma_to_gnu (Node_Id gnat_node) /* Check for (and ignore) unrecognized pragma and do nothing if we are just annotating types. */ - if (type_annotate_only || !Is_Pragma_Name (Chars (gnat_node))) + if (type_annotate_only + || !Is_Pragma_Name (Chars (Pragma_Identifier (gnat_node)))) return gnu_result; - switch (Get_Pragma_Id (Chars (gnat_node))) + switch (Get_Pragma_Id (Pragma_Identifier (Chars (gnat_node)))) { case Pragma_Inspection_Point: /* Do nothing at top level: all such variables are already viewable. */ -- 2.30.2