------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- T B U I L D -- -- -- -- B o d y -- -- -- -- Copyright (C) 1992-2004, 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- -- -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- -- 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. -- -- -- -- 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 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 ----------------------- -- Local Subprograms -- ----------------------- procedure Add_Unique_Serial_Number; -- Add a unique serialization to the string in the Name_Buffer. This -- consists of a unit specific serial number, and b/s for body/spec. ------------------------------ -- Add_Unique_Serial_Number -- ------------------------------ procedure Add_Unique_Serial_Number is 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 Add_Unique_Serial_Number; ---------------- -- Checks_Off -- ---------------- function Checks_Off (N : Node_Id) return Node_Id is begin return Make_Unchecked_Expression (Sloc (N), Expression => N); end Checks_Off; ---------------- -- Convert_To -- ---------------- function Convert_To (Typ : Entity_Id; Expr : Node_Id) return Node_Id is Result : Node_Id; begin if Present (Etype (Expr)) and then (Etype (Expr)) = Typ then return Relocate_Node (Expr); else Result := Make_Type_Conversion (Sloc (Expr), Subtype_Mark => New_Occurrence_Of (Typ, Sloc (Expr)), Expression => Relocate_Node (Expr)); Set_Etype (Result, Typ); return Result; 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_Byte_Aligned_Attribute_Reference (Sloc : Source_Ptr; Prefix : Node_Id; Attribute_Name : Name_Id) return Node_Id is N : constant Node_Id := Make_Attribute_Reference (Sloc, Prefix => Prefix, Attribute_Name => Attribute_Name); begin pragma Assert (Attribute_Name = Name_Address or else Attribute_Name = Name_Unrestricted_Access); Set_Must_Be_Byte_Aligned (N, True); return N; end Make_Byte_Aligned_Attribute_Reference; -------------------- -- Make_DT_Access -- -------------------- function Make_DT_Access (Loc : Source_Ptr; Rec : Node_Id; Typ : Entity_Id) return Node_Id is Full_Type : Entity_Id := Typ; begin if Is_Private_Type (Typ) then Full_Type := Underlying_Type (Typ); end if; return Unchecked_Convert_To ( New_Occurrence_Of (Etype (Access_Disp_Table (Full_Type)), Loc), Make_Selected_Component (Loc, Prefix => New_Copy (Rec), Selector_Name => New_Reference_To (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 -- -------------------------------- function Make_Implicit_If_Statement (Node : Node_Id; Condition : Node_Id; Then_Statements : List_Id; Elsif_Parts : List_Id := No_List; 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, Elsif_Parts, Else_Statements); end Make_Implicit_If_Statement; ------------------------------------- -- Make_Implicit_Label_Declaration -- ------------------------------------- function Make_Implicit_Label_Declaration (Loc : Source_Ptr; Defining_Identifier : 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; end Make_Implicit_Label_Declaration; ---------------------------------- -- Make_Implicit_Loop_Statement -- ---------------------------------- function Make_Implicit_Loop_Statement (Node : Node_Id; Statements : List_Id; Identifier : Node_Id := Empty; Iteration_Scheme : Node_Id := Empty; Has_Created_Identifier : Boolean := False; End_Label : Node_Id := Empty) return Node_Id is begin Check_Restriction (No_Implicit_Loops, Node); if Present (Iteration_Scheme) and then Present (Condition (Iteration_Scheme)) then Check_Restriction (No_Implicit_Conditionals, Node); end if; return Make_Loop_Statement (Sloc (Node), Identifier => Identifier, Iteration_Scheme => Iteration_Scheme, Statements => Statements, Has_Created_Identifier => Has_Created_Identifier, End_Label => End_Label); end Make_Implicit_Loop_Statement; -------------------------- -- Make_Integer_Literal -- --------------------------- function Make_Integer_Literal (Loc : Source_Ptr; Intval : Int) return Node_Id is begin return Make_Integer_Literal (Loc, UI_From_Int (Intval)); end Make_Integer_Literal; --------------------------------- -- Make_Raise_Constraint_Error -- --------------------------------- function Make_Raise_Constraint_Error (Sloc : Source_Ptr; Condition : Node_Id := Empty; Reason : RT_Exception_Code) return Node_Id is begin pragma Assert (Reason in RT_CE_Exceptions); return Make_Raise_Constraint_Error (Sloc, Condition => Condition, Reason => UI_From_Int (RT_Exception_Code'Pos (Reason))); end Make_Raise_Constraint_Error; ------------------------------ -- Make_Raise_Program_Error -- ------------------------------ function Make_Raise_Program_Error (Sloc : Source_Ptr; Condition : Node_Id := Empty; Reason : RT_Exception_Code) return Node_Id is begin pragma Assert (Reason in RT_PE_Exceptions); return Make_Raise_Program_Error (Sloc, Condition => Condition, Reason => UI_From_Int (RT_Exception_Code'Pos (Reason))); end Make_Raise_Program_Error; ------------------------------ -- Make_Raise_Storage_Error -- ------------------------------ function Make_Raise_Storage_Error (Sloc : Source_Ptr; Condition : Node_Id := Empty; Reason : RT_Exception_Code) return Node_Id is begin pragma Assert (Reason in RT_SE_Exceptions); return Make_Raise_Storage_Error (Sloc, Condition => Condition, Reason => 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 -- --------------------------- -- Generates the following expansion: -- declare -- pragma Suppress (); -- begin -- -- end; function Make_Unsuppress_Block (Loc : Source_Ptr; Check : Name_Id; Stmts : List_Id) return Node_Id is begin return Make_Block_Statement (Loc, Declarations => New_List ( Make_Pragma (Loc, Chars => Name_Suppress, Pragma_Argument_Associations => New_List ( Make_Pragma_Argument_Association (Loc, Expression => Make_Identifier (Loc, Check))))), Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, Statements => Stmts)); end Make_Unsuppress_Block; -------------------------- -- New_Constraint_Error -- -------------------------- function New_Constraint_Error (Loc : Source_Ptr) return Node_Id is Ident_Node : Node_Id; Raise_Node : Node_Id; begin Ident_Node := New_Node (N_Identifier, Loc); Set_Chars (Ident_Node, Chars (Standard_Entity (S_Constraint_Error))); Set_Entity (Ident_Node, Standard_Entity (S_Constraint_Error)); Raise_Node := New_Node (N_Raise_Statement, Loc); Set_Name (Raise_Node, Ident_Node); return Raise_Node; end New_Constraint_Error; ----------------------- -- New_External_Name -- ----------------------- function New_External_Name (Related_Id : Name_Id; Suffix : Character := ' '; Suffix_Index : Int := 0; Prefix : Character := ' ') return Name_Id is begin Get_Name_String (Related_Id); if Prefix /= ' ' then pragma Assert (Is_OK_Internal_Letter (Prefix)); for J in reverse 1 .. Name_Len loop Name_Buffer (J + 1) := Name_Buffer (J); end loop; Name_Len := Name_Len + 1; Name_Buffer (1) := Prefix; end if; if Suffix /= ' ' then pragma Assert (Is_OK_Internal_Letter (Suffix)); Name_Len := Name_Len + 1; Name_Buffer (Name_Len) := Suffix; end if; if Suffix_Index /= 0 then if Suffix_Index < 0 then Add_Unique_Serial_Number; else Add_Nat_To_Name_Buffer (Suffix_Index); end if; end if; return Name_Find; end New_External_Name; function New_External_Name (Related_Id : Name_Id; Suffix : String; Suffix_Index : Int := 0; Prefix : Character := ' ') return Name_Id is begin Get_Name_String (Related_Id); if Prefix /= ' ' then pragma Assert (Is_OK_Internal_Letter (Prefix)); for J in reverse 1 .. Name_Len loop Name_Buffer (J + 1) := Name_Buffer (J); end loop; Name_Len := Name_Len + 1; Name_Buffer (1) := Prefix; end if; if Suffix /= "" then Name_Buffer (Name_Len + 1 .. Name_Len + Suffix'Length) := Suffix; Name_Len := Name_Len + Suffix'Length; end if; if Suffix_Index /= 0 then if Suffix_Index < 0 then Add_Unique_Serial_Number; else Add_Nat_To_Name_Buffer (Suffix_Index); end if; end if; return Name_Find; end New_External_Name; function New_External_Name (Suffix : Character; Suffix_Index : Nat) return Name_Id is begin Name_Buffer (1) := Suffix; Name_Len := 1; Add_Nat_To_Name_Buffer (Suffix_Index); return Name_Find; end New_External_Name; ----------------------- -- New_Internal_Name -- ----------------------- function New_Internal_Name (Id_Char : Character) return Name_Id is begin pragma Assert (Is_OK_Internal_Letter (Id_Char)); Name_Buffer (1) := Id_Char; Name_Len := 1; Add_Unique_Serial_Number; return Name_Enter; end New_Internal_Name; ----------------------- -- New_Occurrence_Of -- ----------------------- function New_Occurrence_Of (Def_Id : Entity_Id; Loc : Source_Ptr) return Node_Id is Occurrence : Node_Id; begin Occurrence := New_Node (N_Identifier, Loc); Set_Chars (Occurrence, Chars (Def_Id)); Set_Entity (Occurrence, Def_Id); if Is_Type (Def_Id) then Set_Etype (Occurrence, Def_Id); else Set_Etype (Occurrence, Etype (Def_Id)); end if; return Occurrence; end New_Occurrence_Of; ---------------------- -- New_Reference_To -- ---------------------- function New_Reference_To (Def_Id : Entity_Id; Loc : Source_Ptr) return Node_Id is Occurrence : Node_Id; begin Occurrence := New_Node (N_Identifier, Loc); Set_Chars (Occurrence, Chars (Def_Id)); Set_Entity (Occurrence, Def_Id); return Occurrence; end New_Reference_To; ----------------------- -- New_Suffixed_Name -- ----------------------- function New_Suffixed_Name (Related_Id : Name_Id; Suffix : String) return Name_Id is begin Get_Name_String (Related_Id); Name_Len := Name_Len + 1; Name_Buffer (Name_Len) := '_'; Name_Buffer (Name_Len + 1 .. Name_Len + Suffix'Length) := Suffix; Name_Len := Name_Len + Suffix'Length; return Name_Find; end New_Suffixed_Name; ------------------- -- OK_Convert_To -- ------------------- function OK_Convert_To (Typ : Entity_Id; Expr : Node_Id) return Node_Id is Result : Node_Id; begin Result := Make_Type_Conversion (Sloc (Expr), Subtype_Mark => New_Occurrence_Of (Typ, Sloc (Expr)), Expression => Relocate_Node (Expr)); Set_Conversion_OK (Result, True); Set_Etype (Result, Typ); return Result; end OK_Convert_To; -------------------------- -- Unchecked_Convert_To -- -------------------------- function Unchecked_Convert_To (Typ : Entity_Id; Expr : Node_Id) return Node_Id is Loc : constant Source_Ptr := Sloc (Expr); Result : Node_Id; begin -- If the expression is already of the correct type, then nothing -- to do, except for relocating the node in case this is required. if Present (Etype (Expr)) and then (Base_Type (Etype (Expr)) = Typ or else Etype (Expr) = Typ) then return Relocate_Node (Expr); -- Cases where the inner expression is itself an unchecked conversion -- to the same type, and we can thus eliminate the outer conversion. elsif Nkind (Expr) = N_Unchecked_Type_Conversion and then Entity (Subtype_Mark (Expr)) = Typ 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 Result := Make_Unchecked_Type_Conversion (Loc, Subtype_Mark => New_Occurrence_Of (Typ, Loc), Expression => Relocate_Node (Expr)); end if; Set_Etype (Result, Typ); return Result; end Unchecked_Convert_To; end Tbuild;