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-2022, 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 Einfo.Entities; use Einfo.Entities;
  28 with Nlists;         use Nlists;
  29 with Nmake;          use Nmake;
  30 with Opt;            use Opt;
  31 with Rtsfind;        use Rtsfind;
  32 with Sinfo;          use Sinfo;
  33 with Sinfo.Nodes;    use Sinfo.Nodes;
  34 with Snames;         use Snames;
  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,
  53           Identifier   => New_Occurrence_Of (Abr_Blk_Ent, Loc),
  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,
  62                     Defining_Identifier => Cln_Blk_Ent,
  63                     Label_Construct     => Blk),
  64                   Blk),
  65
  66               Exception_Handlers =>
  67                 New_List (Build_Abort_Block_Handler (Loc))));
  68    end Build_Abort_Block;
  69
  70    -------------------------------
  71    -- Build_Abort_Block_Handler --
  72    -------------------------------
  73
  74    function Build_Abort_Block_Handler (Loc : Source_Ptr) return Node_Id is
  75    begin
  76       return Make_Implicit_Exception_Handler (Loc,
  77         Exception_Choices =>
  78           New_List (New_Occurrence_Of (Stand.Abort_Signal, Loc)),
  79         Statements        => New_List (Make_Null_Statement (Loc)));
  80    end Build_Abort_Block_Handler;
  81
  82    -------------
  83    -- Build_B --
  84    -------------
  85
  86    function Build_B
  87      (Loc   : Source_Ptr;
  88       Decls : List_Id) return Entity_Id
  89    is
  90       B : constant Entity_Id := Make_Temporary (Loc, 'B');
  91    begin
  92       Append_To (Decls,
  93         Make_Object_Declaration (Loc,
  94           Defining_Identifier => B,
  95           Object_Definition   => New_Occurrence_Of (Standard_Boolean, Loc),
  96           Expression          => New_Occurrence_Of (Standard_False, Loc)));
  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
 108       C : constant Entity_Id := Make_Temporary (Loc, 'C');
 109    begin
 110       Append_To (Decls,
 111         Make_Object_Declaration (Loc,
 112           Defining_Identifier => C,
 113           Object_Definition   =>
 114             New_Occurrence_Of (RTE (RE_Prim_Op_Kind), Loc)));
 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,
 130                           Identifier                 =>
 131                             New_Occurrence_Of (Blk_Ent, Loc),
 132                           Declarations               => No_List,
 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
 153       K        : constant Entity_Id := Make_Temporary (Loc, 'K');
 154       Tag_Node : Node_Id;
 155
 156    begin
 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,
 162              Prefix         => Obj,
 163              Attribute_Name => Name_Tag);
 164       end if;
 165
 166       Append_To (Decls,
 167         Make_Object_Declaration (Loc,
 168           Defining_Identifier => K,
 169           Object_Definition   =>
 170             New_Occurrence_Of (RTE (RE_Tagged_Kind), Loc),
 171           Expression          =>
 172             Make_Function_Call (Loc,
 173               Name => New_Occurrence_Of (RTE (RE_Get_Tagged_Kind), Loc),
 174               Parameter_Associations => New_List (Tag_Node))));
 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
 186       S : constant Entity_Id := Make_Temporary (Loc, 'S');
 187    begin
 188       Append_To (Decls,
 189         Make_Object_Declaration (Loc,
 190           Defining_Identifier => S,
 191           Object_Definition   => New_Occurrence_Of (Standard_Integer, Loc)));
 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
 205       Typ : constant Entity_Id := Etype (Obj);
 206
 207    begin
 208       if Tagged_Type_Expansion then
 209          return
 210            Make_Assignment_Statement (Loc,
 211              Name       => New_Occurrence_Of (S, Loc),
 212              Expression =>
 213                Make_Function_Call (Loc,
 214                  Name => New_Occurrence_Of (RTE (RE_Get_Offset_Index), Loc),
 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,
 224              Name       => New_Occurrence_Of (S, Loc),
 225              Expression =>
 226                Make_Function_Call (Loc,
 227                  Name => New_Occurrence_Of (RTE (RE_Get_Offset_Index), Loc),
 228
 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,
 240                      Prefix => New_Occurrence_Of (Typ, Loc),
 241                      Attribute_Name => Name_Tag),
 242
 243                      --  Position
 244
 245                    Make_Integer_Literal (Loc, DT_Position (Call_Ent)))));
 246       end if;
 247    end Build_S_Assignment;
 248
 249 end Exp_Sel;