(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;
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));
}
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.
-- --
-- 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- --
---------------------
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
-- 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);
-- Insert the pragma
Insert_After_And_Analyze (N,
-
Make_Pragma (Loc,
Chars => Name_Machine_Attribute,
Pragma_Argument_Associations => New_List (
-- 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;
-- --
-- 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- --
-- 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;
-- 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;
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;
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
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;
-- 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;
-- 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
-- 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
-- --
-- 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- --
-- --
------------------------------------------------------------------------------
+-- 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;
-- --
-- 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- --
-- --
------------------------------------------------------------------------------
+-- Storage pool for use with local objects with automatic reclaim
+
with System.Storage_Elements;
with System.Pool_Global;
-- --
-- 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- --
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
-- 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);
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
-- --
-- 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- --
-- 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
-- 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
-- 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;
-- 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
-- --
-- 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- --
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
-- --
-- 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- --
begin
return
Make_Pragma (Sloc,
- Chars => Chars,
Pragma_Argument_Associations => Pragma_Argument_Associations,
Debug_Statement => Debug_Statement,
Pragma_Identifier => Make_Identifier (Sloc, Chars));
-- --
-- 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- --
/* 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. */
projects / gcc.git / commitdiff