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-2024, 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 Einfo.Entities; use Einfo.Entities;
  28 with Nlists;         use Nlists;
  29 with Nmake;          use Nmake;
  30 with Rtsfind;        use Rtsfind;
  31 with Sem_Util;       use Sem_Util;
  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    begin
  74       return Make_Implicit_Exception_Handler (Loc,
  75         Exception_Choices =>
  76           New_List (New_Occurrence_Of (Stand.Abort_Signal, Loc)),
  77         Statements        => New_List (Make_Null_Statement (Loc)));
  78    end Build_Abort_Block_Handler;
  79
  80    -------------
  81    -- Build_B --
  82    -------------
  83
  84    function Build_B
  85      (Loc   : Source_Ptr;
  86       Decls : List_Id) return Entity_Id
  87    is
  88       B : constant Entity_Id := Make_Temporary (Loc, 'B');
  89    begin
  90       Append_To (Decls,
  91         Make_Object_Declaration (Loc,
  92           Defining_Identifier => B,
  93           Object_Definition   => New_Occurrence_Of (Standard_Boolean, Loc),
  94           Expression          => New_Occurrence_Of (Standard_False, Loc)));
  95       return B;
  96    end Build_B;
  97
  98    -------------
  99    -- Build_C --
 100    -------------
 101
 102    function Build_C
 103      (Loc   : Source_Ptr;
 104       Decls : List_Id) return Entity_Id
 105    is
 106       C : constant Entity_Id := Make_Temporary (Loc, 'C');
 107    begin
 108       Append_To (Decls,
 109         Make_Object_Declaration (Loc,
 110           Defining_Identifier => C,
 111           Object_Definition   =>
 112             New_Occurrence_Of (RTE (RE_Prim_Op_Kind), Loc)));
 113       return C;
 114    end Build_C;
 115
 116    -------------------------
 117    -- Build_Cleanup_Block --
 118    -------------------------
 119
 120    function Build_Cleanup_Block
 121      (Loc       : Source_Ptr;
 122       Blk_Ent   : Entity_Id;
 123       Stmts     : List_Id;
 124       Clean_Ent : Entity_Id) return Node_Id
 125    is
 126       Cleanup_Block : constant Node_Id :=
 127                         Make_Block_Statement (Loc,
 128                           Identifier                 =>
 129                             New_Occurrence_Of (Blk_Ent, Loc),
 130                           Declarations               => No_List,
 131                           Handled_Statement_Sequence =>
 132                             Make_Handled_Sequence_Of_Statements (Loc,
 133                               Statements => Stmts),
 134                           Is_Asynchronous_Call_Block => True);
 135
 136    begin
 137       Set_Entry_Cancel_Parameter (Blk_Ent, Clean_Ent);
 138
 139       return Cleanup_Block;
 140    end Build_Cleanup_Block;
 141
 142    -------------
 143    -- Build_K --
 144    -------------
 145
 146    function Build_K
 147      (Loc   : Source_Ptr;
 148       Decls : List_Id;
 149       Obj   : Entity_Id) return Entity_Id
 150    is
 151       K        : constant Entity_Id := Make_Temporary (Loc, 'K');
 152       Tag_Node : constant Node_Id   :=
 153         Make_Attribute_Reference (Loc,
 154           Prefix         => New_Copy_Tree (Obj),
 155           Attribute_Name => Name_Tag);
 156
 157    begin
 158       Append_To (Decls,
 159         Make_Object_Declaration (Loc,
 160           Defining_Identifier => K,
 161           Object_Definition   =>
 162             New_Occurrence_Of (RTE (RE_Tagged_Kind), Loc),
 163           Expression          =>
 164             Make_Function_Call (Loc,
 165               Name => New_Occurrence_Of (RTE (RE_Get_Tagged_Kind), Loc),
 166               Parameter_Associations => New_List (Tag_Node))));
 167
 168       return K;
 169    end Build_K;
 170
 171    -------------
 172    -- Build_S --
 173    -------------
 174
 175    function Build_S
 176      (Loc   : Source_Ptr;
 177       Decls : List_Id) return Entity_Id
 178    is
 179       S : constant Entity_Id := Make_Temporary (Loc, 'S');
 180    begin
 181       Append_To (Decls,
 182         Make_Object_Declaration (Loc,
 183           Defining_Identifier => S,
 184           Object_Definition   => New_Occurrence_Of (Standard_Integer, Loc)));
 185       return S;
 186    end Build_S;
 187
 188    ------------------------
 189    -- Build_S_Assignment --
 190    ------------------------
 191
 192    function Build_S_Assignment
 193      (Loc      : Source_Ptr;
 194       S        : Entity_Id;
 195       Obj      : Entity_Id;
 196       Call_Ent : Entity_Id) return Node_Id
 197    is
 198    begin
 199       return
 200         Make_Assignment_Statement (Loc,
 201           Name       => New_Occurrence_Of (S, Loc),
 202           Expression =>
 203             Make_Function_Call (Loc,
 204               Name => New_Occurrence_Of (RTE (RE_Get_Offset_Index), Loc),
 205               Parameter_Associations => New_List (
 206                 Make_Attribute_Reference (Loc,
 207                   Prefix => New_Copy_Tree (Obj),
 208                   Attribute_Name => Name_Tag),
 209                 Make_Integer_Literal (Loc, DT_Position (Call_Ent)))));
 210    end Build_S_Assignment;
 211
 212 end Exp_Sel;