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-2013, 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 Stmt : Node_Id; 74 75 begin 76 if Exception_Mechanism = Back_End_Exceptions then 77 78 -- With ZCX, aborts are not defered in handlers 79 80 Stmt := Make_Null_Statement (Loc); 81 else 82 -- With FE SJLJ, aborts are defered at the beginning of Abort_Signal 83 -- handlers. 84 85 Stmt := 86 Make_Procedure_Call_Statement (Loc, 87 Name => New_Occurrence_Of (RTE (RE_Abort_Undefer), Loc), 88 Parameter_Associations => No_List); 89 end if; 90 91 return Make_Implicit_Exception_Handler (Loc, 92 Exception_Choices => 93 New_List (New_Occurrence_Of (Stand.Abort_Signal, Loc)), 94 Statements => New_List (Stmt)); 95 end Build_Abort_Block_Handler; 96 97 ------------- 98 -- Build_B -- 99 ------------- 100 101 function Build_B 102 (Loc : Source_Ptr; 103 Decls : List_Id) return Entity_Id 104 is 105 B : constant Entity_Id := Make_Temporary (Loc, 'B'); 106 begin 107 Append_To (Decls, 108 Make_Object_Declaration (Loc, 109 Defining_Identifier => B, 110 Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc), 111 Expression => New_Occurrence_Of (Standard_False, Loc))); 112 return B; 113 end Build_B; 114 115 ------------- 116 -- Build_C -- 117 ------------- 118 119 function Build_C 120 (Loc : Source_Ptr; 121 Decls : List_Id) return Entity_Id 122 is 123 C : constant Entity_Id := Make_Temporary (Loc, 'C'); 124 begin 125 Append_To (Decls, 126 Make_Object_Declaration (Loc, 127 Defining_Identifier => C, 128 Object_Definition => 129 New_Occurrence_Of (RTE (RE_Prim_Op_Kind), Loc))); 130 return C; 131 end Build_C; 132 133 ------------------------- 134 -- Build_Cleanup_Block -- 135 ------------------------- 136 137 function Build_Cleanup_Block 138 (Loc : Source_Ptr; 139 Blk_Ent : Entity_Id; 140 Stmts : List_Id; 141 Clean_Ent : Entity_Id) return Node_Id 142 is 143 Cleanup_Block : constant Node_Id := 144 Make_Block_Statement (Loc, 145 Identifier => 146 New_Occurrence_Of (Blk_Ent, Loc), 147 Declarations => No_List, 148 Handled_Statement_Sequence => 149 Make_Handled_Sequence_Of_Statements (Loc, 150 Statements => Stmts), 151 Is_Asynchronous_Call_Block => True); 152 153 begin 154 Set_Entry_Cancel_Parameter (Blk_Ent, Clean_Ent); 155 156 return Cleanup_Block; 157 end Build_Cleanup_Block; 158 159 ------------- 160 -- Build_K -- 161 ------------- 162 163 function Build_K 164 (Loc : Source_Ptr; 165 Decls : List_Id; 166 Obj : Entity_Id) return Entity_Id 167 is 168 K : constant Entity_Id := Make_Temporary (Loc, 'K'); 169 Tag_Node : Node_Id; 170 171 begin 172 if Tagged_Type_Expansion then 173 Tag_Node := Unchecked_Convert_To (RTE (RE_Tag), Obj); 174 else 175 Tag_Node := 176 Make_Attribute_Reference (Loc, 177 Prefix => Obj, 178 Attribute_Name => Name_Tag); 179 end if; 180 181 Append_To (Decls, 182 Make_Object_Declaration (Loc, 183 Defining_Identifier => K, 184 Object_Definition => 185 New_Occurrence_Of (RTE (RE_Tagged_Kind), Loc), 186 Expression => 187 Make_Function_Call (Loc, 188 Name => New_Occurrence_Of (RTE (RE_Get_Tagged_Kind), Loc), 189 Parameter_Associations => New_List (Tag_Node)))); 190 return K; 191 end Build_K; 192 193 ------------- 194 -- Build_S -- 195 ------------- 196 197 function Build_S 198 (Loc : Source_Ptr; 199 Decls : List_Id) return Entity_Id 200 is 201 S : constant Entity_Id := Make_Temporary (Loc, 'S'); 202 begin 203 Append_To (Decls, 204 Make_Object_Declaration (Loc, 205 Defining_Identifier => S, 206 Object_Definition => New_Occurrence_Of (Standard_Integer, Loc))); 207 return S; 208 end Build_S; 209 210 ------------------------ 211 -- Build_S_Assignment -- 212 ------------------------ 213 214 function Build_S_Assignment 215 (Loc : Source_Ptr; 216 S : Entity_Id; 217 Obj : Entity_Id; 218 Call_Ent : Entity_Id) return Node_Id 219 is 220 Typ : constant Entity_Id := Etype (Obj); 221 222 begin 223 if Tagged_Type_Expansion then 224 return 225 Make_Assignment_Statement (Loc, 226 Name => New_Occurrence_Of (S, Loc), 227 Expression => 228 Make_Function_Call (Loc, 229 Name => New_Occurrence_Of (RTE (RE_Get_Offset_Index), Loc), 230 Parameter_Associations => New_List ( 231 Unchecked_Convert_To (RTE (RE_Tag), Obj), 232 Make_Integer_Literal (Loc, DT_Position (Call_Ent))))); 233 234 -- VM targets 235 236 else 237 return 238 Make_Assignment_Statement (Loc, 239 Name => New_Occurrence_Of (S, Loc), 240 Expression => 241 Make_Function_Call (Loc, 242 Name => New_Occurrence_Of (RTE (RE_Get_Offset_Index), Loc), 243 244 Parameter_Associations => New_List ( 245 246 -- Obj_Typ 247 248 Make_Attribute_Reference (Loc, 249 Prefix => Obj, 250 Attribute_Name => Name_Tag), 251 252 -- Iface_Typ 253 254 Make_Attribute_Reference (Loc, 255 Prefix => New_Occurrence_Of (Typ, Loc), 256 Attribute_Name => Name_Tag), 257 258 -- Position 259 260 Make_Integer_Literal (Loc, DT_Position (Call_Ent))))); 261 end if; 262 end Build_S_Assignment; 263 264end Exp_Sel; 265