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-2011, 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_Reference_To (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_Reference_To (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_Reference_To (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_Reference_To (Standard_Boolean, Loc), 111 Expression => New_Reference_To (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 => New_Reference_To (RTE (RE_Prim_Op_Kind), Loc))); 129 return C; 130 end Build_C; 131 132 ------------------------- 133 -- Build_Cleanup_Block -- 134 ------------------------- 135 136 function Build_Cleanup_Block 137 (Loc : Source_Ptr; 138 Blk_Ent : Entity_Id; 139 Stmts : List_Id; 140 Clean_Ent : Entity_Id) return Node_Id 141 is 142 Cleanup_Block : constant Node_Id := 143 Make_Block_Statement (Loc, 144 Identifier => 145 New_Reference_To (Blk_Ent, Loc), 146 Declarations => No_List, 147 Handled_Statement_Sequence => 148 Make_Handled_Sequence_Of_Statements (Loc, 149 Statements => Stmts), 150 Is_Asynchronous_Call_Block => True); 151 152 begin 153 Set_Entry_Cancel_Parameter (Blk_Ent, Clean_Ent); 154 155 return Cleanup_Block; 156 end Build_Cleanup_Block; 157 158 ------------- 159 -- Build_K -- 160 ------------- 161 162 function Build_K 163 (Loc : Source_Ptr; 164 Decls : List_Id; 165 Obj : Entity_Id) return Entity_Id 166 is 167 K : constant Entity_Id := Make_Temporary (Loc, 'K'); 168 Tag_Node : Node_Id; 169 170 begin 171 if Tagged_Type_Expansion then 172 Tag_Node := Unchecked_Convert_To (RTE (RE_Tag), Obj); 173 else 174 Tag_Node := 175 Make_Attribute_Reference (Loc, 176 Prefix => Obj, 177 Attribute_Name => Name_Tag); 178 end if; 179 180 Append_To (Decls, 181 Make_Object_Declaration (Loc, 182 Defining_Identifier => K, 183 Object_Definition => 184 New_Reference_To (RTE (RE_Tagged_Kind), Loc), 185 Expression => 186 Make_Function_Call (Loc, 187 Name => New_Reference_To (RTE (RE_Get_Tagged_Kind), Loc), 188 Parameter_Associations => New_List (Tag_Node)))); 189 return K; 190 end Build_K; 191 192 ------------- 193 -- Build_S -- 194 ------------- 195 196 function Build_S 197 (Loc : Source_Ptr; 198 Decls : List_Id) return Entity_Id 199 is 200 S : constant Entity_Id := Make_Temporary (Loc, 'S'); 201 begin 202 Append_To (Decls, 203 Make_Object_Declaration (Loc, 204 Defining_Identifier => S, 205 Object_Definition => New_Reference_To (Standard_Integer, Loc))); 206 return S; 207 end Build_S; 208 209 ------------------------ 210 -- Build_S_Assignment -- 211 ------------------------ 212 213 function Build_S_Assignment 214 (Loc : Source_Ptr; 215 S : Entity_Id; 216 Obj : Entity_Id; 217 Call_Ent : Entity_Id) return Node_Id 218 is 219 Typ : constant Entity_Id := Etype (Obj); 220 221 begin 222 if Tagged_Type_Expansion then 223 return 224 Make_Assignment_Statement (Loc, 225 Name => New_Reference_To (S, Loc), 226 Expression => 227 Make_Function_Call (Loc, 228 Name => New_Reference_To (RTE (RE_Get_Offset_Index), Loc), 229 Parameter_Associations => New_List ( 230 Unchecked_Convert_To (RTE (RE_Tag), Obj), 231 Make_Integer_Literal (Loc, DT_Position (Call_Ent))))); 232 233 -- VM targets 234 235 else 236 return 237 Make_Assignment_Statement (Loc, 238 Name => New_Reference_To (S, Loc), 239 Expression => 240 Make_Function_Call (Loc, 241 Name => New_Reference_To (RTE (RE_Get_Offset_Index), Loc), 242 243 Parameter_Associations => New_List ( 244 245 -- Obj_Typ 246 247 Make_Attribute_Reference (Loc, 248 Prefix => Obj, 249 Attribute_Name => Name_Tag), 250 251 -- Iface_Typ 252 253 Make_Attribute_Reference (Loc, 254 Prefix => New_Reference_To (Typ, Loc), 255 Attribute_Name => Name_Tag), 256 257 -- Position 258 259 Make_Integer_Literal (Loc, DT_Position (Call_Ent))))); 260 end if; 261 end Build_S_Assignment; 262 263end Exp_Sel; 264