blob: 7140015ea33b2a9235281f6bc95b0921bd84037a [file] [log] [blame]
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- E X P _ S E L --
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2021, 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 3, 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 COPYING3. If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
with Einfo; use Einfo;
with Einfo.Entities; use Einfo.Entities;
with Nlists; use Nlists;
with Nmake; use Nmake;
with Opt; use Opt;
with Rtsfind; use Rtsfind;
with Sinfo; use Sinfo;
with Sinfo.Nodes; use Sinfo.Nodes;
with Snames; use Snames;
with Stand; use Stand;
with Tbuild; use Tbuild;
package body Exp_Sel is
-----------------------
-- Build_Abort_Block --
-----------------------
function Build_Abort_Block
(Loc : Source_Ptr;
Abr_Blk_Ent : Entity_Id;
Cln_Blk_Ent : Entity_Id;
Blk : Node_Id) return Node_Id
is
begin
return
Make_Block_Statement (Loc,
Identifier => New_Occurrence_Of (Abr_Blk_Ent, Loc),
Declarations => No_List,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements =>
New_List (
Make_Implicit_Label_Declaration (Loc,
Defining_Identifier => Cln_Blk_Ent,
Label_Construct => Blk),
Blk),
Exception_Handlers =>
New_List (Build_Abort_Block_Handler (Loc))));
end Build_Abort_Block;
-------------------------------
-- Build_Abort_Block_Handler --
-------------------------------
function Build_Abort_Block_Handler (Loc : Source_Ptr) return Node_Id is
begin
return Make_Implicit_Exception_Handler (Loc,
Exception_Choices =>
New_List (New_Occurrence_Of (Stand.Abort_Signal, Loc)),
Statements => New_List (Make_Null_Statement (Loc)));
end Build_Abort_Block_Handler;
-------------
-- Build_B --
-------------
function Build_B
(Loc : Source_Ptr;
Decls : List_Id) return Entity_Id
is
B : constant Entity_Id := Make_Temporary (Loc, 'B');
begin
Append_To (Decls,
Make_Object_Declaration (Loc,
Defining_Identifier => B,
Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc),
Expression => New_Occurrence_Of (Standard_False, Loc)));
return B;
end Build_B;
-------------
-- Build_C --
-------------
function Build_C
(Loc : Source_Ptr;
Decls : List_Id) return Entity_Id
is
C : constant Entity_Id := Make_Temporary (Loc, 'C');
begin
Append_To (Decls,
Make_Object_Declaration (Loc,
Defining_Identifier => C,
Object_Definition =>
New_Occurrence_Of (RTE (RE_Prim_Op_Kind), Loc)));
return C;
end Build_C;
-------------------------
-- Build_Cleanup_Block --
-------------------------
function Build_Cleanup_Block
(Loc : Source_Ptr;
Blk_Ent : Entity_Id;
Stmts : List_Id;
Clean_Ent : Entity_Id) return Node_Id
is
Cleanup_Block : constant Node_Id :=
Make_Block_Statement (Loc,
Identifier =>
New_Occurrence_Of (Blk_Ent, Loc),
Declarations => No_List,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => Stmts),
Is_Asynchronous_Call_Block => True);
begin
Set_Entry_Cancel_Parameter (Blk_Ent, Clean_Ent);
return Cleanup_Block;
end Build_Cleanup_Block;
-------------
-- Build_K --
-------------
function Build_K
(Loc : Source_Ptr;
Decls : List_Id;
Obj : Entity_Id) return Entity_Id
is
K : constant Entity_Id := Make_Temporary (Loc, 'K');
Tag_Node : Node_Id;
begin
if Tagged_Type_Expansion then
Tag_Node := Unchecked_Convert_To (RTE (RE_Tag), Obj);
else
Tag_Node :=
Make_Attribute_Reference (Loc,
Prefix => Obj,
Attribute_Name => Name_Tag);
end if;
Append_To (Decls,
Make_Object_Declaration (Loc,
Defining_Identifier => K,
Object_Definition =>
New_Occurrence_Of (RTE (RE_Tagged_Kind), Loc),
Expression =>
Make_Function_Call (Loc,
Name => New_Occurrence_Of (RTE (RE_Get_Tagged_Kind), Loc),
Parameter_Associations => New_List (Tag_Node))));
return K;
end Build_K;
-------------
-- Build_S --
-------------
function Build_S
(Loc : Source_Ptr;
Decls : List_Id) return Entity_Id
is
S : constant Entity_Id := Make_Temporary (Loc, 'S');
begin
Append_To (Decls,
Make_Object_Declaration (Loc,
Defining_Identifier => S,
Object_Definition => New_Occurrence_Of (Standard_Integer, Loc)));
return S;
end Build_S;
------------------------
-- Build_S_Assignment --
------------------------
function Build_S_Assignment
(Loc : Source_Ptr;
S : Entity_Id;
Obj : Entity_Id;
Call_Ent : Entity_Id) return Node_Id
is
Typ : constant Entity_Id := Etype (Obj);
begin
if Tagged_Type_Expansion then
return
Make_Assignment_Statement (Loc,
Name => New_Occurrence_Of (S, Loc),
Expression =>
Make_Function_Call (Loc,
Name => New_Occurrence_Of (RTE (RE_Get_Offset_Index), Loc),
Parameter_Associations => New_List (
Unchecked_Convert_To (RTE (RE_Tag), Obj),
Make_Integer_Literal (Loc, DT_Position (Call_Ent)))));
-- VM targets
else
return
Make_Assignment_Statement (Loc,
Name => New_Occurrence_Of (S, Loc),
Expression =>
Make_Function_Call (Loc,
Name => New_Occurrence_Of (RTE (RE_Get_Offset_Index), Loc),
Parameter_Associations => New_List (
-- Obj_Typ
Make_Attribute_Reference (Loc,
Prefix => Obj,
Attribute_Name => Name_Tag),
-- Iface_Typ
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Typ, Loc),
Attribute_Name => Name_Tag),
-- Position
Make_Integer_Literal (Loc, DT_Position (Call_Ent)))));
end if;
end Build_S_Assignment;
end Exp_Sel;