-- --
-- B o d y --
-- --
--- $Revision$
--- --
--- Copyright (C) 1992-2002, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2005, 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. --
--- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- 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 Nmake; use Nmake;
with Restrict; use Restrict;
+with Rident; use Rident;
with Sinfo; use Sinfo;
with Snames; use Snames;
with Stand; use Stand;
+with Stringt; use Stringt;
with Uintp; use Uintp;
package body Tbuild is
end if;
end Convert_To;
+ ------------------
+ -- Discard_List --
+ ------------------
+
+ procedure Discard_List (L : List_Id) is
+ pragma Warnings (Off, L);
+ begin
+ null;
+ end Discard_List;
+
+ ------------------
+ -- Discard_Node --
+ ------------------
+
+ procedure Discard_Node (N : Node_Or_Entity_Id) is
+ pragma Warnings (Off, N);
+ begin
+ null;
+ end Discard_Node;
+
-------------------------------------------
-- Make_Byte_Aligned_Attribute_Reference --
-------------------------------------------
--------------------
function Make_DT_Access
- (Loc : Source_Ptr;
- Rec : Node_Id;
- Typ : Entity_Id)
- return Node_Id
+ (Loc : Source_Ptr;
+ Rec : Node_Id;
+ Typ : Entity_Id) return Node_Id
is
Full_Type : Entity_Id := Typ;
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 --
- -----------------------
-
- function Make_DT_Component
- (Loc : Source_Ptr;
- Typ : Entity_Id;
- I : Positive)
- return Node_Id
- is
- X : Node_Id;
- Full_Type : Entity_Id := Typ;
-
- 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;
-
--------------------------------
-- Make_Implicit_If_Statement --
--------------------------------
Condition : Node_Id;
Then_Statements : List_Id;
Elsif_Parts : List_Id := No_List;
- Else_Statements : List_Id := No_List)
- return Node_Id
+ Else_Statements : List_Id := No_List) return Node_Id
is
begin
Check_Restriction (No_Implicit_Conditionals, Node);
+
return Make_If_Statement (Sloc (Node),
Condition,
Then_Statements,
function Make_Implicit_Label_Declaration
(Loc : Source_Ptr;
Defining_Identifier : Node_Id;
- Label_Construct : Node_Id)
- return Node_Id
+ Label_Construct : Node_Id) return Node_Id
is
N : constant Node_Id :=
Make_Implicit_Label_Declaration (Loc, Defining_Identifier);
-
begin
Set_Label_Construct (N, Label_Construct);
return N;
Identifier : Node_Id := Empty;
Iteration_Scheme : Node_Id := Empty;
Has_Created_Identifier : Boolean := False;
- End_Label : Node_Id := Empty)
- return Node_Id
+ End_Label : Node_Id := Empty) return Node_Id
is
begin
Check_Restriction (No_Implicit_Loops, Node);
function Make_Integer_Literal
(Loc : Source_Ptr;
- Intval : Int)
- return Node_Id
+ Intval : Int) return Node_Id
is
begin
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 --
---------------------------------
function Make_Raise_Constraint_Error
(Sloc : Source_Ptr;
Condition : Node_Id := Empty;
- Reason : RT_Exception_Code)
- return Node_Id
+ Reason : RT_Exception_Code) return Node_Id
is
begin
pragma Assert (Reason in RT_CE_Exceptions);
function Make_Raise_Program_Error
(Sloc : Source_Ptr;
Condition : Node_Id := Empty;
- Reason : RT_Exception_Code)
- return Node_Id
+ Reason : RT_Exception_Code) return Node_Id
is
begin
pragma Assert (Reason in RT_PE_Exceptions);
function Make_Raise_Storage_Error
(Sloc : Source_Ptr;
Condition : Node_Id := Empty;
- Reason : RT_Exception_Code)
- return Node_Id
+ Reason : RT_Exception_Code) return Node_Id
is
begin
pragma Assert (Reason in RT_SE_Exceptions);
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 --
---------------------------
function Make_Unsuppress_Block
(Loc : Source_Ptr;
Check : Name_Id;
- Stmts : List_Id)
- return Node_Id
+ Stmts : List_Id) return Node_Id
is
begin
return
(Related_Id : Name_Id;
Suffix : Character := ' ';
Suffix_Index : Int := 0;
- Prefix : Character := ' ')
- return Name_Id
+ Prefix : Character := ' ') return Name_Id
is
begin
Get_Name_String (Related_Id);
(Related_Id : Name_Id;
Suffix : String;
Suffix_Index : Int := 0;
- Prefix : Character := ' ')
- return Name_Id
+ Prefix : Character := ' ') return Name_Id
is
begin
Get_Name_String (Related_Id);
function New_External_Name
(Suffix : Character;
- Suffix_Index : Nat)
- return Name_Id
+ Suffix_Index : Nat) return Name_Id
is
begin
Name_Buffer (1) := Suffix;
function New_Occurrence_Of
(Def_Id : Entity_Id;
- Loc : Source_Ptr)
- return Node_Id
+ Loc : Source_Ptr) return Node_Id
is
Occurrence : Node_Id;
function New_Reference_To
(Def_Id : Entity_Id;
- Loc : Source_Ptr)
- return Node_Id
+ Loc : Source_Ptr) return Node_Id
is
Occurrence : Node_Id;
function New_Suffixed_Name
(Related_Id : Name_Id;
- Suffix : String)
- return Name_Id
+ Suffix : String) return Name_Id
is
begin
Get_Name_String (Related_Id);
function OK_Convert_To (Typ : Entity_Id; Expr : Node_Id) return Node_Id is
Result : Node_Id;
-
begin
Result :=
Make_Type_Conversion (Sloc (Expr),
function Unchecked_Convert_To
(Typ : Entity_Id;
- Expr : Node_Id)
- return Node_Id
+ Expr : Node_Id) return Node_Id
is
Loc : constant Source_Ptr := Sloc (Expr);
Result : Node_Id;
then
Result := Relocate_Node (Expr);
+ elsif Nkind (Expr) = N_Null
+ and then Is_Access_Type (Typ)
+ then
+ -- No need for a conversion
+
+ Result := Relocate_Node (Expr);
+
-- All other cases
else
OSDN Git Service
