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-2006, 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 2,  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 COPYING.  If not, write --
  19 -- to  the  Free Software Foundation,  51  Franklin  Street,  Fifth  Floor, --
  20 -- Boston, MA 02110-1301, USA.                                              --
  21 --                                                                          --
  22 -- GNAT was originally developed  by the GNAT team at  New York University. --
  23 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  24 --                                                                          --
  25 ------------------------------------------------------------------------------
  26
  27 with Einfo;   use Einfo;
  28 with Nlists;  use Nlists;
  29 with Nmake;   use Nmake;
  30 with Rtsfind; use Rtsfind;
  31 with Stand;   use Stand;
  32 with Tbuild;  use Tbuild;
  33
  34 package body Exp_Sel is
  35
  36    -----------------------
  37    -- Build_Abort_Block --
  38    -----------------------
  39
  40    function Build_Abort_Block
  41      (Loc         : Source_Ptr;
  42       Abr_Blk_Ent : Entity_Id;
  43       Cln_Blk_Ent : Entity_Id;
  44       Blk         : Node_Id) return Node_Id
  45    is
  46    begin
  47       return
  48         Make_Block_Statement (Loc,
  49           Identifier   => New_Reference_To (Abr_Blk_Ent, Loc),
  50
  51           Declarations => No_List,
  52
  53           Handled_Statement_Sequence =>
  54             Make_Handled_Sequence_Of_Statements (Loc,
  55               Statements =>
  56                 New_List (
  57                   Make_Implicit_Label_Declaration (Loc,
  58                     Defining_Identifier =>
  59                       Cln_Blk_Ent,
  60                     Label_Construct =>
  61                       Blk),
  62                   Blk),
  63
  64               Exception_Handlers =>
  65                 New_List (
  66                   Make_Implicit_Exception_Handler (Loc,
  67                     Exception_Choices =>
  68                       New_List (
  69                         New_Reference_To (Stand.Abort_Signal, Loc)),
  70                     Statements =>
  71                       New_List (
  72                         Make_Procedure_Call_Statement (Loc,
  73                           Name =>
  74                             New_Reference_To (RTE (
  75                               RE_Abort_Undefer), Loc),
  76                           Parameter_Associations => No_List))))));
  77    end Build_Abort_Block;
  78
  79    -------------
  80    -- Build_B --
  81    -------------
  82
  83    function Build_B
  84      (Loc   : Source_Ptr;
  85       Decls : List_Id) return Entity_Id
  86    is
  87       B : constant Entity_Id := Make_Defining_Identifier (Loc,
  88                                   Chars => New_Internal_Name ('B'));
  89
  90    begin
  91       Append_To (Decls,
  92         Make_Object_Declaration (Loc,
  93           Defining_Identifier =>
  94             B,
  95           Object_Definition =>
  96             New_Reference_To (Standard_Boolean, Loc),
  97           Expression =>
  98             New_Reference_To (Standard_False, Loc)));
  99
 100       return B;
 101    end Build_B;
 102
 103    -------------
 104    -- Build_C --
 105    -------------
 106
 107    function Build_C
 108      (Loc   : Source_Ptr;
 109       Decls : List_Id) return Entity_Id
 110    is
 111       C : constant Entity_Id := Make_Defining_Identifier (Loc,
 112                                   Chars => New_Internal_Name ('C'));
 113
 114    begin
 115       Append_To (Decls,
 116         Make_Object_Declaration (Loc,
 117           Defining_Identifier =>
 118             C,
 119           Object_Definition =>
 120             New_Reference_To (RTE (RE_Prim_Op_Kind), Loc)));
 121
 122       return C;
 123    end Build_C;
 124
 125    -------------------------
 126    -- Build_Cleanup_Block --
 127    -------------------------
 128
 129    function Build_Cleanup_Block
 130      (Loc       : Source_Ptr;
 131       Blk_Ent   : Entity_Id;
 132       Stmts     : List_Id;
 133       Clean_Ent : Entity_Id) return Node_Id
 134    is
 135       Cleanup_Block : constant Node_Id :=
 136                         Make_Block_Statement (Loc,
 137                           Identifier   => New_Reference_To (Blk_Ent, Loc),
 138                           Declarations => No_List,
 139                           Handled_Statement_Sequence =>
 140                             Make_Handled_Sequence_Of_Statements (Loc,
 141                               Statements => Stmts),
 142                           Is_Asynchronous_Call_Block => True);
 143
 144    begin
 145       Set_Entry_Cancel_Parameter (Blk_Ent, Clean_Ent);
 146
 147       return Cleanup_Block;
 148    end Build_Cleanup_Block;
 149
 150    -------------
 151    -- Build_K --
 152    -------------
 153
 154    function Build_K
 155      (Loc   : Source_Ptr;
 156       Decls : List_Id;
 157       Obj   : Entity_Id) return Entity_Id
 158    is
 159       K : constant Entity_Id := Make_Defining_Identifier (Loc,
 160                                   Chars => New_Internal_Name ('K'));
 161
 162    begin
 163       Append_To (Decls,
 164         Make_Object_Declaration (Loc,
 165           Defining_Identifier => K,
 166           Object_Definition   =>
 167             New_Reference_To (RTE (RE_Tagged_Kind), Loc),
 168           Expression          =>
 169             Make_Function_Call (Loc,
 170               Name => New_Reference_To (RTE (RE_Get_Tagged_Kind), Loc),
 171               Parameter_Associations => New_List (
 172                 Unchecked_Convert_To (RTE (RE_Tag), Obj)))));
 173
 174       return K;
 175    end Build_K;
 176
 177    -------------
 178    -- Build_S --
 179    -------------
 180
 181    function Build_S
 182      (Loc   : Source_Ptr;
 183       Decls : List_Id) return Entity_Id
 184    is
 185       S : constant Entity_Id := Make_Defining_Identifier (Loc,
 186                                   Chars => New_Internal_Name ('S'));
 187
 188    begin
 189       Append_To (Decls,
 190         Make_Object_Declaration (Loc,
 191           Defining_Identifier => S,
 192           Object_Definition   =>
 193             New_Reference_To (Standard_Integer, Loc)));
 194
 195       return S;
 196    end Build_S;
 197
 198    ------------------------
 199    -- Build_S_Assignment --
 200    ------------------------
 201
 202    function Build_S_Assignment
 203      (Loc      : Source_Ptr;
 204       S        : Entity_Id;
 205       Obj      : Entity_Id;
 206       Call_Ent : Entity_Id) return Node_Id
 207    is
 208    begin
 209       return
 210         Make_Assignment_Statement (Loc,
 211           Name => New_Reference_To (S, Loc),
 212           Expression =>
 213             Make_Function_Call (Loc,
 214               Name => New_Reference_To (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    end Build_S_Assignment;
 219
 220 end Exp_Sel;