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-2015, 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       Stmt : Node_Id;
  74
  75    begin
  76
  77       --  With ZCX exceptions, aborts are not defered in handlers. With SJLJ,
  78       --  they are deferred at the beginning of Abort_Signal handlers.
  79
  80       if ZCX_Exceptions then
  81          Stmt := Make_Null_Statement (Loc);
  82
  83       else
  84          Stmt :=
  85            Make_Procedure_Call_Statement (Loc,
  86              Name => New_Occurrence_Of (RTE (RE_Abort_Undefer), Loc),
  87              Parameter_Associations => No_List);
  88       end if;
  89
  90       return Make_Implicit_Exception_Handler (Loc,
  91         Exception_Choices =>
  92           New_List (New_Occurrence_Of (Stand.Abort_Signal, Loc)),
  93         Statements        => New_List (Stmt));
  94    end Build_Abort_Block_Handler;
  95
  96    -------------
  97    -- Build_B --
  98    -------------
  99
 100    function Build_B
 101      (Loc   : Source_Ptr;
 102       Decls : List_Id) return Entity_Id
 103    is
 104       B : constant Entity_Id := Make_Temporary (Loc, 'B');
 105    begin
 106       Append_To (Decls,
 107         Make_Object_Declaration (Loc,
 108           Defining_Identifier => B,
 109           Object_Definition   => New_Occurrence_Of (Standard_Boolean, Loc),
 110           Expression          => New_Occurrence_Of (Standard_False, Loc)));
 111       return B;
 112    end Build_B;
 113
 114    -------------
 115    -- Build_C --
 116    -------------
 117
 118    function Build_C
 119      (Loc   : Source_Ptr;
 120       Decls : List_Id) return Entity_Id
 121    is
 122       C : constant Entity_Id := Make_Temporary (Loc, 'C');
 123    begin
 124       Append_To (Decls,
 125         Make_Object_Declaration (Loc,
 126           Defining_Identifier => C,
 127           Object_Definition   =>
 128             New_Occurrence_Of (RTE (RE_Prim_Op_Kind), Loc)));
 129       return C;
 130    end Build_C;
 131
 132    -------------------------
 133    -- Build_Cleanup_Block --
 134    -------------------------
 135
 136    function Build_Cleanup_Block
 137      (Loc       : Source_Ptr;
 138       Blk_Ent   : Entity_Id;
 139       Stmts     : List_Id;
 140       Clean_Ent : Entity_Id) return Node_Id
 141    is
 142       Cleanup_Block : constant Node_Id :=
 143                         Make_Block_Statement (Loc,
 144                           Identifier                 =>
 145                             New_Occurrence_Of (Blk_Ent, Loc),
 146                           Declarations               => No_List,
 147                           Handled_Statement_Sequence =>
 148                             Make_Handled_Sequence_Of_Statements (Loc,
 149                               Statements => Stmts),
 150                           Is_Asynchronous_Call_Block => True);
 151
 152    begin
 153       Set_Entry_Cancel_Parameter (Blk_Ent, Clean_Ent);
 154
 155       return Cleanup_Block;
 156    end Build_Cleanup_Block;
 157
 158    -------------
 159    -- Build_K --
 160    -------------
 161
 162    function Build_K
 163      (Loc   : Source_Ptr;
 164       Decls : List_Id;
 165       Obj   : Entity_Id) return Entity_Id
 166    is
 167       K        : constant Entity_Id := Make_Temporary (Loc, 'K');
 168       Tag_Node : Node_Id;
 169
 170    begin
 171       if Tagged_Type_Expansion then
 172          Tag_Node := Unchecked_Convert_To (RTE (RE_Tag), Obj);
 173       else
 174          Tag_Node :=
 175            Make_Attribute_Reference (Loc,
 176              Prefix         => Obj,
 177              Attribute_Name => Name_Tag);
 178       end if;
 179
 180       Append_To (Decls,
 181         Make_Object_Declaration (Loc,
 182           Defining_Identifier => K,
 183           Object_Definition   =>
 184             New_Occurrence_Of (RTE (RE_Tagged_Kind), Loc),
 185           Expression          =>
 186             Make_Function_Call (Loc,
 187               Name => New_Occurrence_Of (RTE (RE_Get_Tagged_Kind), Loc),
 188               Parameter_Associations => New_List (Tag_Node))));
 189       return K;
 190    end Build_K;
 191
 192    -------------
 193    -- Build_S --
 194    -------------
 195
 196    function Build_S
 197      (Loc   : Source_Ptr;
 198       Decls : List_Id) return Entity_Id
 199    is
 200       S : constant Entity_Id := Make_Temporary (Loc, 'S');
 201    begin
 202       Append_To (Decls,
 203         Make_Object_Declaration (Loc,
 204           Defining_Identifier => S,
 205           Object_Definition   => New_Occurrence_Of (Standard_Integer, Loc)));
 206       return S;
 207    end Build_S;
 208
 209    ------------------------
 210    -- Build_S_Assignment --
 211    ------------------------
 212
 213    function Build_S_Assignment
 214      (Loc      : Source_Ptr;
 215       S        : Entity_Id;
 216       Obj      : Entity_Id;
 217       Call_Ent : Entity_Id) return Node_Id
 218    is
 219       Typ : constant Entity_Id := Etype (Obj);
 220
 221    begin
 222       if Tagged_Type_Expansion then
 223          return
 224            Make_Assignment_Statement (Loc,
 225              Name       => New_Occurrence_Of (S, Loc),
 226              Expression =>
 227                Make_Function_Call (Loc,
 228                  Name => New_Occurrence_Of (RTE (RE_Get_Offset_Index), Loc),
 229                  Parameter_Associations => New_List (
 230                    Unchecked_Convert_To (RTE (RE_Tag), Obj),
 231                    Make_Integer_Literal (Loc, DT_Position (Call_Ent)))));
 232
 233       --  VM targets
 234
 235       else
 236          return
 237            Make_Assignment_Statement (Loc,
 238              Name       => New_Occurrence_Of (S, Loc),
 239              Expression =>
 240                Make_Function_Call (Loc,
 241                  Name => New_Occurrence_Of (RTE (RE_Get_Offset_Index), Loc),
 242
 243                  Parameter_Associations => New_List (
 244
 245                      --  Obj_Typ
 246
 247                    Make_Attribute_Reference (Loc,
 248                      Prefix => Obj,
 249                      Attribute_Name => Name_Tag),
 250
 251                      --  Iface_Typ
 252
 253                    Make_Attribute_Reference (Loc,
 254                      Prefix => New_Occurrence_Of (Typ, Loc),
 255                      Attribute_Name => Name_Tag),
 256
 257                      --  Position
 258
 259                    Make_Integer_Literal (Loc, DT_Position (Call_Ent)))));
 260       end if;
 261    end Build_S_Assignment;
 262
 263 end Exp_Sel;