248 lines
8.2 KiB
Ada
248 lines
8.2 KiB
Ada
------------------------------------------------------------------------------
|
|
-- --
|
|
-- GNAT COMPILER COMPONENTS --
|
|
-- --
|
|
-- E X P _ S E L --
|
|
-- --
|
|
-- B o d y --
|
|
-- --
|
|
-- Copyright (C) 1992-2020, 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 Nlists; use Nlists;
|
|
with Nmake; use Nmake;
|
|
with Opt; use Opt;
|
|
with Rtsfind; use Rtsfind;
|
|
with Sinfo; use Sinfo;
|
|
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;
|