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-2007, 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_Defining_Identifier (Loc,
  87                                   Chars => New_Internal_Name ('B'));
  88
  89    begin
  90       Append_To (Decls,
  91         Make_Object_Declaration (Loc,
  92           Defining_Identifier =>
  93             B,
  94           Object_Definition =>
  95             New_Reference_To (Standard_Boolean, Loc),
  96           Expression =>
  97             New_Reference_To (Standard_False, Loc)));
  98
  99       return B;
 100    end Build_B;
 101
 102    -------------
 103    -- Build_C --
 104    -------------
 105
 106    function Build_C
 107      (Loc   : Source_Ptr;
 108       Decls : List_Id) return Entity_Id
 109    is
 110       C : constant Entity_Id := Make_Defining_Identifier (Loc,
 111                                   Chars => New_Internal_Name ('C'));
 112
 113    begin
 114       Append_To (Decls,
 115         Make_Object_Declaration (Loc,
 116           Defining_Identifier =>
 117             C,
 118           Object_Definition =>
 119             New_Reference_To (RTE (RE_Prim_Op_Kind), Loc)));
 120
 121       return C;
 122    end Build_C;
 123
 124    -------------------------
 125    -- Build_Cleanup_Block --
 126    -------------------------
 127
 128    function Build_Cleanup_Block
 129      (Loc       : Source_Ptr;
 130       Blk_Ent   : Entity_Id;
 131       Stmts     : List_Id;
 132       Clean_Ent : Entity_Id) return Node_Id
 133    is
 134       Cleanup_Block : constant Node_Id :=
 135                         Make_Block_Statement (Loc,
 136                           Identifier   => New_Reference_To (Blk_Ent, Loc),
 137                           Declarations => No_List,
 138                           Handled_Statement_Sequence =>
 139                             Make_Handled_Sequence_Of_Statements (Loc,
 140                               Statements => Stmts),
 141                           Is_Asynchronous_Call_Block => True);
 142
 143    begin
 144       Set_Entry_Cancel_Parameter (Blk_Ent, Clean_Ent);
 145
 146       return Cleanup_Block;
 147    end Build_Cleanup_Block;
 148
 149    -------------
 150    -- Build_K --
 151    -------------
 152
 153    function Build_K
 154      (Loc   : Source_Ptr;
 155       Decls : List_Id;
 156       Obj   : Entity_Id) return Entity_Id
 157    is
 158       K : constant Entity_Id := Make_Defining_Identifier (Loc,
 159                                   Chars => New_Internal_Name ('K'));
 160
 161    begin
 162       Append_To (Decls,
 163         Make_Object_Declaration (Loc,
 164           Defining_Identifier => K,
 165           Object_Definition   =>
 166             New_Reference_To (RTE (RE_Tagged_Kind), Loc),
 167           Expression          =>
 168             Make_Function_Call (Loc,
 169               Name => New_Reference_To (RTE (RE_Get_Tagged_Kind), Loc),
 170               Parameter_Associations => New_List (
 171                 Unchecked_Convert_To (RTE (RE_Tag), Obj)))));
 172
 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_Defining_Identifier (Loc,
 185                                   Chars => New_Internal_Name ('S'));
 186
 187    begin
 188       Append_To (Decls,
 189         Make_Object_Declaration (Loc,
 190           Defining_Identifier => S,
 191           Object_Definition   =>
 192             New_Reference_To (Standard_Integer, Loc)));
 193
 194       return S;
 195    end Build_S;
 196
 197    ------------------------
 198    -- Build_S_Assignment --
 199    ------------------------
 200
 201    function Build_S_Assignment
 202      (Loc      : Source_Ptr;
 203       S        : Entity_Id;
 204       Obj      : Entity_Id;
 205       Call_Ent : Entity_Id) return Node_Id
 206    is
 207    begin
 208       return
 209         Make_Assignment_Statement (Loc,
 210           Name => New_Reference_To (S, Loc),
 211           Expression =>
 212             Make_Function_Call (Loc,
 213               Name => New_Reference_To (RTE (RE_Get_Offset_Index), Loc),
 214               Parameter_Associations => New_List (
 215                 Unchecked_Convert_To (RTE (RE_Tag), Obj),
 216                 Make_Integer_Literal (Loc, DT_Position (Call_Ent)))));
 217    end Build_S_Assignment;
 218
 219 end Exp_Sel;