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-2010, 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 Rtsfind; use Rtsfind;
  30 with Stand;   use Stand;
  31 with Tbuild;  use Tbuild;
  32
  33 package body Exp_Sel is
  34
  35    -----------------------
  36    -- Build_Abort_Block --
  37    -----------------------
  38
  39    function Build_Abort_Block
  40      (Loc         : Source_Ptr;
  41       Abr_Blk_Ent : Entity_Id;
  42       Cln_Blk_Ent : Entity_Id;
  43       Blk         : Node_Id) return Node_Id
  44    is
  45    begin
  46       return
  47         Make_Block_Statement (Loc,
  48           Identifier   => New_Reference_To (Abr_Blk_Ent, Loc),
  49
  50           Declarations => No_List,
  51
  52           Handled_Statement_Sequence =>
  53             Make_Handled_Sequence_Of_Statements (Loc,
  54               Statements =>
  55                 New_List (
  56                   Make_Implicit_Label_Declaration (Loc,
  57                     Defining_Identifier =>
  58                       Cln_Blk_Ent,
  59                     Label_Construct =>
  60                       Blk),
  61                   Blk),
  62
  63               Exception_Handlers =>
  64                 New_List (
  65                   Make_Implicit_Exception_Handler (Loc,
  66                     Exception_Choices =>
  67                       New_List (
  68                         New_Reference_To (Stand.Abort_Signal, Loc)),
  69                     Statements =>
  70                       New_List (
  71                         Make_Procedure_Call_Statement (Loc,
  72                           Name =>
  73                             New_Reference_To (RTE (
  74                               RE_Abort_Undefer), Loc),
  75                           Parameter_Associations => No_List))))));
  76    end Build_Abort_Block;
  77
  78    -------------
  79    -- Build_B --
  80    -------------
  81
  82    function Build_B
  83      (Loc   : Source_Ptr;
  84       Decls : List_Id) return Entity_Id
  85    is
  86       B : constant Entity_Id := Make_Temporary (Loc, 'B');
  87    begin
  88       Append_To (Decls,
  89         Make_Object_Declaration (Loc,
  90           Defining_Identifier => B,
  91           Object_Definition   => New_Reference_To (Standard_Boolean, Loc),
  92           Expression          => New_Reference_To (Standard_False, Loc)));
  93       return B;
  94    end Build_B;
  95
  96    -------------
  97    -- Build_C --
  98    -------------
  99
 100    function Build_C
 101      (Loc   : Source_Ptr;
 102       Decls : List_Id) return Entity_Id
 103    is
 104       C : constant Entity_Id := Make_Temporary (Loc, 'C');
 105    begin
 106       Append_To (Decls,
 107         Make_Object_Declaration (Loc,
 108           Defining_Identifier => C,
 109           Object_Definition => New_Reference_To (RTE (RE_Prim_Op_Kind), Loc)));
 110       return C;
 111    end Build_C;
 112
 113    -------------------------
 114    -- Build_Cleanup_Block --
 115    -------------------------
 116
 117    function Build_Cleanup_Block
 118      (Loc       : Source_Ptr;
 119       Blk_Ent   : Entity_Id;
 120       Stmts     : List_Id;
 121       Clean_Ent : Entity_Id) return Node_Id
 122    is
 123       Cleanup_Block : constant Node_Id :=
 124                         Make_Block_Statement (Loc,
 125                           Identifier   => New_Reference_To (Blk_Ent, Loc),
 126                           Declarations => No_List,
 127                           Handled_Statement_Sequence =>
 128                             Make_Handled_Sequence_Of_Statements (Loc,
 129                               Statements => Stmts),
 130                           Is_Asynchronous_Call_Block => True);
 131
 132    begin
 133       Set_Entry_Cancel_Parameter (Blk_Ent, Clean_Ent);
 134
 135       return Cleanup_Block;
 136    end Build_Cleanup_Block;
 137
 138    -------------
 139    -- Build_K --
 140    -------------
 141
 142    function Build_K
 143      (Loc   : Source_Ptr;
 144       Decls : List_Id;
 145       Obj   : Entity_Id) return Entity_Id
 146    is
 147       K : constant Entity_Id := Make_Temporary (Loc, 'K');
 148    begin
 149       Append_To (Decls,
 150         Make_Object_Declaration (Loc,
 151           Defining_Identifier => K,
 152           Object_Definition   =>
 153             New_Reference_To (RTE (RE_Tagged_Kind), Loc),
 154           Expression          =>
 155             Make_Function_Call (Loc,
 156               Name => New_Reference_To (RTE (RE_Get_Tagged_Kind), Loc),
 157               Parameter_Associations => New_List (
 158                 Unchecked_Convert_To (RTE (RE_Tag), Obj)))));
 159       return K;
 160    end Build_K;
 161
 162    -------------
 163    -- Build_S --
 164    -------------
 165
 166    function Build_S
 167      (Loc   : Source_Ptr;
 168       Decls : List_Id) return Entity_Id
 169    is
 170       S : constant Entity_Id := Make_Temporary (Loc, 'S');
 171    begin
 172       Append_To (Decls,
 173         Make_Object_Declaration (Loc,
 174           Defining_Identifier => S,
 175           Object_Definition   => New_Reference_To (Standard_Integer, Loc)));
 176       return S;
 177    end Build_S;
 178
 179    ------------------------
 180    -- Build_S_Assignment --
 181    ------------------------
 182
 183    function Build_S_Assignment
 184      (Loc      : Source_Ptr;
 185       S        : Entity_Id;
 186       Obj      : Entity_Id;
 187       Call_Ent : Entity_Id) return Node_Id
 188    is
 189    begin
 190       return
 191         Make_Assignment_Statement (Loc,
 192           Name => New_Reference_To (S, Loc),
 193           Expression =>
 194             Make_Function_Call (Loc,
 195               Name => New_Reference_To (RTE (RE_Get_Offset_Index), Loc),
 196               Parameter_Associations => New_List (
 197                 Unchecked_Convert_To (RTE (RE_Tag), Obj),
 198                 Make_Integer_Literal (Loc, DT_Position (Call_Ent)))));
 199    end Build_S_Assignment;
 200
 201 end Exp_Sel;