gcc/ada/exp_sel.adb

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