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 Uintp; use Uintp;
package body Tbuild is
procedure 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);
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;
function Checks_Off (N : Node_Id) return Node_Id is
begin
return
Make_Unchecked_Expression (Sloc (N),
Expression => N);
end Checks_Off;
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;
procedure Discard_List (L : List_Id) is
pragma Warnings (Off, L);
begin
null;
end Discard_List;
procedure Discard_Node (N : Node_Or_Entity_Id) is
pragma Warnings (Off, N);
begin
null;
end Discard_Node;
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;
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;
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;
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;
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;
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;
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;
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;
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;
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;
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;
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;
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;
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;
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;
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;
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;
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;
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 Present (Etype (Expr))
and then (Base_Type (Etype (Expr)) = Typ
or else Etype (Expr) = Typ)
then
return Relocate_Node (Expr);
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
Result := Relocate_Node (Expr);
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;