[thirdparty/gcc.git] / gcc / ada / exp_sel.adb

------------------------------------------------------------------------------
--                                                                          --
--                         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;
Commit	Line	Data
4d744221 JM	1	------------------------------------------------------------------------------
	2	-- --
	3	-- GNAT COMPILER COMPONENTS --
	4	-- --
	5	-- E X P _ S E L --
	6	-- --
	7	-- B o d y --
	8	-- --
8d0d46f4	9	-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
4d744221 JM	10	-- --
	11	-- GNAT is free software; you can redistribute it and/or modify it under --
	12	-- terms of the GNU General Public License as published by the Free Soft- --
b5c84c3c	13	-- ware Foundation; either version 3, or (at your option) any later ver- --
4d744221 JM	14	-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
	15	-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
	16	-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
	17	-- for more details. You should have received a copy of the GNU General --
b5c84c3c RD	18	-- Public License distributed with GNAT; see file COPYING3. If not, go to --
b5c84c3c RD	19	-- http://www.gnu.org/licenses for a complete copy of the license. --
4d744221 JM	20	-- --
	21	-- GNAT was originally developed by the GNAT team at New York University. --
	22	-- Extensive contributions were provided by Ada Core Technologies Inc. --
	23	-- --
	24	------------------------------------------------------------------------------
	25
76f9c7f4 BD	26	with Einfo; use Einfo;
76f9c7f4 BD	27	with Einfo.Entities; use Einfo.Entities;
4d744221 JM	28	with Nlists; use Nlists;
4d744221 JM	29	with Nmake; use Nmake;
4fbad0ba	30	with Opt; use Opt;
4d744221	31	with Rtsfind; use Rtsfind;
76f9c7f4 BD	32	with Sinfo; use Sinfo;
76f9c7f4 BD	33	with Sinfo.Nodes; use Sinfo.Nodes;
4fbad0ba	34	with Snames; use Snames;
4d744221 JM	35	with Stand; use Stand;
	36	with Tbuild; use Tbuild;
	37
	38	package body Exp_Sel is
	39
	40	-----------------------
	41	-- Build_Abort_Block --
	42	-----------------------
	43
	44	function Build_Abort_Block
	45	(Loc : Source_Ptr;
	46	Abr_Blk_Ent : Entity_Id;
	47	Cln_Blk_Ent : Entity_Id;
	48	Blk : Node_Id) return Node_Id
	49	is
	50	begin
	51	return
	52	Make_Block_Statement (Loc,
e4494292	53	Identifier => New_Occurrence_Of (Abr_Blk_Ent, Loc),
4d744221 JM	54
	55	Declarations => No_List,
	56
	57	Handled_Statement_Sequence =>
	58	Make_Handled_Sequence_Of_Statements (Loc,
	59	Statements =>
	60	New_List (
	61	Make_Implicit_Label_Declaration (Loc,
cb25faf8 AC	62	Defining_Identifier => Cln_Blk_Ent,
cb25faf8 AC	63	Label_Construct => Blk),
4d744221 JM	64	Blk),
	65
	66	Exception_Handlers =>
1d10f669	67	New_List (Build_Abort_Block_Handler (Loc))));
4d744221 JM	68	end Build_Abort_Block;
4d744221 JM	69
1d10f669 AC	70	-------------------------------
	71	-- Build_Abort_Block_Handler --
	72	-------------------------------
	73
cb25faf8	74	function Build_Abort_Block_Handler (Loc : Source_Ptr) return Node_Id is
1d10f669	75	begin
1d10f669 AC	76	return Make_Implicit_Exception_Handler (Loc,
1d10f669 AC	77	Exception_Choices =>
e4494292	78	New_List (New_Occurrence_Of (Stand.Abort_Signal, Loc)),
05e59503	79	Statements => New_List (Make_Null_Statement (Loc)));
1d10f669 AC	80	end Build_Abort_Block_Handler;
1d10f669 AC	81
4d744221 JM	82	-------------
	83	-- Build_B --
	84	-------------
	85
	86	function Build_B
	87	(Loc : Source_Ptr;
	88	Decls : List_Id) return Entity_Id
	89	is
092ef350	90	B : constant Entity_Id := Make_Temporary (Loc, 'B');
4d744221 JM	91	begin
	92	Append_To (Decls,
	93	Make_Object_Declaration (Loc,
092ef350	94	Defining_Identifier => B,
e4494292 RD	95	Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc),
e4494292 RD	96	Expression => New_Occurrence_Of (Standard_False, Loc)));
4d744221 JM	97	return B;
	98	end Build_B;
	99
	100	-------------
	101	-- Build_C --
	102	-------------
	103
	104	function Build_C
	105	(Loc : Source_Ptr;
	106	Decls : List_Id) return Entity_Id
	107	is
092ef350	108	C : constant Entity_Id := Make_Temporary (Loc, 'C');
4d744221 JM	109	begin
	110	Append_To (Decls,
	111	Make_Object_Declaration (Loc,
092ef350	112	Defining_Identifier => C,
e4494292 RD	113	Object_Definition =>
e4494292 RD	114	New_Occurrence_Of (RTE (RE_Prim_Op_Kind), Loc)));
4d744221 JM	115	return C;
	116	end Build_C;
	117
	118	-------------------------
	119	-- Build_Cleanup_Block --
	120	-------------------------
	121
	122	function Build_Cleanup_Block
	123	(Loc : Source_Ptr;
	124	Blk_Ent : Entity_Id;
	125	Stmts : List_Id;
	126	Clean_Ent : Entity_Id) return Node_Id
	127	is
	128	Cleanup_Block : constant Node_Id :=
	129	Make_Block_Statement (Loc,
cb25faf8	130	Identifier =>
e4494292	131	New_Occurrence_Of (Blk_Ent, Loc),
cb25faf8	132	Declarations => No_List,
4d744221 JM	133	Handled_Statement_Sequence =>
	134	Make_Handled_Sequence_Of_Statements (Loc,
	135	Statements => Stmts),
	136	Is_Asynchronous_Call_Block => True);
	137
	138	begin
	139	Set_Entry_Cancel_Parameter (Blk_Ent, Clean_Ent);
	140
	141	return Cleanup_Block;
	142	end Build_Cleanup_Block;
	143
	144	-------------
	145	-- Build_K --
	146	-------------
	147
	148	function Build_K
	149	(Loc : Source_Ptr;
	150	Decls : List_Id;
	151	Obj : Entity_Id) return Entity_Id
	152	is
4fbad0ba AC	153	K : constant Entity_Id := Make_Temporary (Loc, 'K');
	154	Tag_Node : Node_Id;
	155
4d744221	156	begin
4fbad0ba AC	157	if Tagged_Type_Expansion then
	158	Tag_Node := Unchecked_Convert_To (RTE (RE_Tag), Obj);
	159	else
	160	Tag_Node :=
	161	Make_Attribute_Reference (Loc,
052e0603	162	Prefix => Obj,
4fbad0ba AC	163	Attribute_Name => Name_Tag);
	164	end if;
	165
4d744221 JM	166	Append_To (Decls,
	167	Make_Object_Declaration (Loc,
	168	Defining_Identifier => K,
	169	Object_Definition =>
e4494292	170	New_Occurrence_Of (RTE (RE_Tagged_Kind), Loc),
4d744221 JM	171	Expression =>
4d744221 JM	172	Make_Function_Call (Loc,
e4494292	173	Name => New_Occurrence_Of (RTE (RE_Get_Tagged_Kind), Loc),
4fbad0ba	174	Parameter_Associations => New_List (Tag_Node))));
4d744221 JM	175	return K;
	176	end Build_K;
	177
	178	-------------
	179	-- Build_S --
	180	-------------
	181
	182	function Build_S
	183	(Loc : Source_Ptr;
	184	Decls : List_Id) return Entity_Id
	185	is
092ef350	186	S : constant Entity_Id := Make_Temporary (Loc, 'S');
4d744221 JM	187	begin
	188	Append_To (Decls,
	189	Make_Object_Declaration (Loc,
	190	Defining_Identifier => S,
e4494292	191	Object_Definition => New_Occurrence_Of (Standard_Integer, Loc)));
4d744221 JM	192	return S;
	193	end Build_S;
	194
	195	------------------------
	196	-- Build_S_Assignment --
	197	------------------------
	198
	199	function Build_S_Assignment
	200	(Loc : Source_Ptr;
	201	S : Entity_Id;
	202	Obj : Entity_Id;
	203	Call_Ent : Entity_Id) return Node_Id
	204	is
4fbad0ba AC	205	Typ : constant Entity_Id := Etype (Obj);
4fbad0ba AC	206
4d744221	207	begin
4fbad0ba AC	208	if Tagged_Type_Expansion then
	209	return
	210	Make_Assignment_Statement (Loc,
e4494292	211	Name => New_Occurrence_Of (S, Loc),
4fbad0ba AC	212	Expression =>
4fbad0ba AC	213	Make_Function_Call (Loc,
e4494292	214	Name => New_Occurrence_Of (RTE (RE_Get_Offset_Index), Loc),
4fbad0ba AC	215	Parameter_Associations => New_List (
	216	Unchecked_Convert_To (RTE (RE_Tag), Obj),
	217	Make_Integer_Literal (Loc, DT_Position (Call_Ent)))));
	218
	219	-- VM targets
	220
	221	else
	222	return
	223	Make_Assignment_Statement (Loc,
e4494292	224	Name => New_Occurrence_Of (S, Loc),
4fbad0ba AC	225	Expression =>
4fbad0ba AC	226	Make_Function_Call (Loc,
e4494292	227	Name => New_Occurrence_Of (RTE (RE_Get_Offset_Index), Loc),
052e0603	228
4fbad0ba AC	229	Parameter_Associations => New_List (
	230
	231	-- Obj_Typ
	232
	233	Make_Attribute_Reference (Loc,
	234	Prefix => Obj,
	235	Attribute_Name => Name_Tag),
	236
	237	-- Iface_Typ
	238
	239	Make_Attribute_Reference (Loc,
e4494292	240	Prefix => New_Occurrence_Of (Typ, Loc),
4fbad0ba AC	241	Attribute_Name => Name_Tag),
	242
	243	-- Position
	244
	245	Make_Integer_Literal (Loc, DT_Position (Call_Ent)))));
	246	end if;
4d744221 JM	247	end Build_S_Assignment;
	248
	249	end Exp_Sel;