-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2004, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2006, 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- --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
--- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
--- MA 02111-1307, USA. --
+-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
+-- Boston, MA 02110-1301, USA. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
with Atree; use Atree;
with Einfo; use Einfo;
+with Elists; use Elists;
with Lib; use Lib;
with Namet; use Namet;
with Nlists; use Nlists;
with Sinfo; use Sinfo;
with Snames; use Snames;
with Stand; use Stand;
+with Stringt; use Stringt;
with Uintp; use Uintp;
package body Tbuild is
-- Add_Unique_Serial_Number --
------------------------------
- procedure Add_Unique_Serial_Number is
- Unit_Node : constant Node_Id := Unit (Cunit (Current_Sem_Unit));
+ Config_Serial_Number : Nat := 0;
+ -- Counter for use in config pragmas, see comment below
+ procedure Add_Unique_Serial_Number is
begin
- Add_Nat_To_Name_Buffer (Increment_Serial_Number);
+ -- If we are analyzing configuration pragmas, Cunit (Main_Unit) will
+ -- not be set yet. This happens for example when analyzing static
+ -- string expressions in configuration pragmas. For this case, we
+ -- just maintain a local counter, defined above and we do not need
+ -- to add a b or s indication in this case.
- -- Add either b or s, depending on whether current unit is a spec
- -- or a body. This is needed because we may generate the same name
- -- in a spec and a body otherwise.
+ if No (Cunit (Current_Sem_Unit)) then
+ Config_Serial_Number := Config_Serial_Number + 1;
+ Add_Nat_To_Name_Buffer (Config_Serial_Number);
+ return;
- Name_Len := Name_Len + 1;
+ -- Normal case, within a unit
- if Nkind (Unit_Node) = N_Package_Declaration
- or else Nkind (Unit_Node) = N_Subprogram_Declaration
- or else Nkind (Unit_Node) in N_Generic_Declaration
- then
- Name_Buffer (Name_Len) := 's';
else
- Name_Buffer (Name_Len) := 'b';
+ declare
+ Unit_Node : constant Node_Id := Unit (Cunit (Current_Sem_Unit));
+
+ begin
+ Add_Nat_To_Name_Buffer (Increment_Serial_Number);
+
+ -- Add either b or s, depending on whether current unit is a spec
+ -- or a body. This is needed because we may generate the same name
+ -- in a spec and a body otherwise.
+
+ Name_Len := Name_Len + 1;
+
+ if Nkind (Unit_Node) = N_Package_Declaration
+ or else Nkind (Unit_Node) = N_Subprogram_Declaration
+ or else Nkind (Unit_Node) in N_Generic_Declaration
+ then
+ Name_Buffer (Name_Len) := 's';
+ else
+ Name_Buffer (Name_Len) := 'b';
+ end if;
+ end;
end if;
end Add_Unique_Serial_Number;
return
Unchecked_Convert_To (
- New_Occurrence_Of (Etype (Access_Disp_Table (Full_Type)), Loc),
+ New_Occurrence_Of
+ (Etype (Node (First_Elmt (Access_Disp_Table (Full_Type)))), Loc),
Make_Selected_Component (Loc,
Prefix => New_Copy (Rec),
Selector_Name =>
- New_Reference_To (Tag_Component (Full_Type), Loc)));
+ New_Reference_To (First_Tag_Component (Full_Type), Loc)));
end Make_DT_Access;
- -----------------------
- -- Make_DT_Component --
- -----------------------
+ -------------------------------------
+ -- Make_Implicit_Exception_Handler --
+ -------------------------------------
- function Make_DT_Component
- (Loc : Source_Ptr;
- Typ : Entity_Id;
- I : Positive) return Node_Id
+ function Make_Implicit_Exception_Handler
+ (Sloc : Source_Ptr;
+ Choice_Parameter : Node_Id := Empty;
+ Exception_Choices : List_Id;
+ Statements : List_Id) return Node_Id
is
- X : Node_Id;
- Full_Type : Entity_Id := Typ;
-
+ Handler : constant Node_Id :=
+ Make_Exception_Handler
+ (Sloc, Choice_Parameter, Exception_Choices, Statements);
begin
- if Is_Private_Type (Typ) then
- Full_Type := Underlying_Type (Typ);
- end if;
-
- X := First_Component (
- Designated_Type (Etype (Access_Disp_Table (Full_Type))));
-
- for J in 2 .. I loop
- X := Next_Component (X);
- end loop;
-
- return New_Reference_To (X, Loc);
- end Make_DT_Component;
+ Set_Local_Raise_Statements (Handler, No_Elist);
+ return Handler;
+ end Make_Implicit_Exception_Handler;
--------------------------------
-- Make_Implicit_If_Statement --
is
begin
Check_Restriction (No_Implicit_Conditionals, Node);
+
return Make_If_Statement (Sloc (Node),
Condition,
Then_Statements,
is
N : constant Node_Id :=
Make_Implicit_Label_Declaration (Loc, Defining_Identifier);
-
begin
Set_Label_Construct (N, Label_Construct);
return N;
return Make_Integer_Literal (Loc, UI_From_Int (Intval));
end Make_Integer_Literal;
+ --------------------------------
+ -- Make_Linker_Section_Pragma --
+ --------------------------------
+
+ function Make_Linker_Section_Pragma
+ (Ent : Entity_Id;
+ Loc : Source_Ptr;
+ Sec : String) return Node_Id
+ is
+ LS : Node_Id;
+
+ begin
+ LS :=
+ Make_Pragma
+ (Loc,
+ Name_Linker_Section,
+ New_List
+ (Make_Pragma_Argument_Association
+ (Sloc => Loc,
+ Expression => New_Occurrence_Of (Ent, Loc)),
+ Make_Pragma_Argument_Association
+ (Sloc => Loc,
+ Expression =>
+ Make_String_Literal
+ (Sloc => Loc,
+ Strval => Sec))));
+
+ Set_Has_Gigi_Rep_Item (Ent);
+ return LS;
+ end Make_Linker_Section_Pragma;
+
---------------------------------
-- Make_Raise_Constraint_Error --
---------------------------------
UI_From_Int (RT_Exception_Code'Pos (Reason)));
end Make_Raise_Storage_Error;
+ -------------------------
+ -- Make_String_Literal --
+ -------------------------
+
+ function Make_String_Literal
+ (Sloc : Source_Ptr;
+ Strval : String) return Node_Id
+ is
+ begin
+ Start_String;
+ Store_String_Chars (Strval);
+ return
+ Make_String_Literal (Sloc,
+ Strval => End_String);
+ end Make_String_Literal;
+
---------------------------
-- Make_Unsuppress_Block --
---------------------------
OSDN Git Service
