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-2020, 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 26with Einfo; use Einfo; 27with Nlists; use Nlists; 28with Nmake; use Nmake; 29with Opt; use Opt; 30with Rtsfind; use Rtsfind; 31with Sinfo; use Sinfo; 32with Snames; use Snames; 33with Stand; use Stand; 34with Tbuild; use Tbuild; 35 36package 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 : Node_Id; 153 154 begin 155 if Tagged_Type_Expansion then 156 Tag_Node := Unchecked_Convert_To (RTE (RE_Tag), Obj); 157 else 158 Tag_Node := 159 Make_Attribute_Reference (Loc, 160 Prefix => Obj, 161 Attribute_Name => Name_Tag); 162 end if; 163 164 Append_To (Decls, 165 Make_Object_Declaration (Loc, 166 Defining_Identifier => K, 167 Object_Definition => 168 New_Occurrence_Of (RTE (RE_Tagged_Kind), Loc), 169 Expression => 170 Make_Function_Call (Loc, 171 Name => New_Occurrence_Of (RTE (RE_Get_Tagged_Kind), Loc), 172 Parameter_Associations => New_List (Tag_Node)))); 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_Temporary (Loc, 'S'); 185 begin 186 Append_To (Decls, 187 Make_Object_Declaration (Loc, 188 Defining_Identifier => S, 189 Object_Definition => New_Occurrence_Of (Standard_Integer, Loc))); 190 return S; 191 end Build_S; 192 193 ------------------------ 194 -- Build_S_Assignment -- 195 ------------------------ 196 197 function Build_S_Assignment 198 (Loc : Source_Ptr; 199 S : Entity_Id; 200 Obj : Entity_Id; 201 Call_Ent : Entity_Id) return Node_Id 202 is 203 Typ : constant Entity_Id := Etype (Obj); 204 205 begin 206 if Tagged_Type_Expansion then 207 return 208 Make_Assignment_Statement (Loc, 209 Name => New_Occurrence_Of (S, Loc), 210 Expression => 211 Make_Function_Call (Loc, 212 Name => New_Occurrence_Of (RTE (RE_Get_Offset_Index), Loc), 213 Parameter_Associations => New_List ( 214 Unchecked_Convert_To (RTE (RE_Tag), Obj), 215 Make_Integer_Literal (Loc, DT_Position (Call_Ent))))); 216 217 -- VM targets 218 219 else 220 return 221 Make_Assignment_Statement (Loc, 222 Name => New_Occurrence_Of (S, Loc), 223 Expression => 224 Make_Function_Call (Loc, 225 Name => New_Occurrence_Of (RTE (RE_Get_Offset_Index), Loc), 226 227 Parameter_Associations => New_List ( 228 229 -- Obj_Typ 230 231 Make_Attribute_Reference (Loc, 232 Prefix => Obj, 233 Attribute_Name => Name_Tag), 234 235 -- Iface_Typ 236 237 Make_Attribute_Reference (Loc, 238 Prefix => New_Occurrence_Of (Typ, Loc), 239 Attribute_Name => Name_Tag), 240 241 -- Position 242 243 Make_Integer_Literal (Loc, DT_Position (Call_Ent))))); 244 end if; 245 end Build_S_Assignment; 246 247end Exp_Sel; 248