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