| ------------------------------------------------------------------------------ |
| -- -- |
| -- GNAT COMPILER COMPONENTS -- |
| -- -- |
| -- T B U I L D -- |
| -- -- |
| -- B o d y -- |
| -- -- |
| -- Copyright (C) 1992-2003, 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 Sinfo; use Sinfo; |
| with Snames; use Snames; |
| with Stand; use Stand; |
| 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_Unsuppress_Block -- |
| --------------------------- |
| |
| -- Generates the following expansion: |
| |
| -- declare |
| -- pragma Suppress (<check>); |
| -- begin |
| -- <stmts> |
| -- 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 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; |