1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- E X P _ C H 8 -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1992-2018, 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 Atree; use Atree; 27with Einfo; use Einfo; 28with Exp_Ch4; use Exp_Ch4; 29with Exp_Ch6; use Exp_Ch6; 30with Exp_Dbug; use Exp_Dbug; 31with Exp_Util; use Exp_Util; 32with Freeze; use Freeze; 33with Namet; use Namet; 34with Nmake; use Nmake; 35with Nlists; use Nlists; 36with Opt; use Opt; 37with Sem; use Sem; 38with Sem_Ch8; use Sem_Ch8; 39with Sem_Util; use Sem_Util; 40with Sinfo; use Sinfo; 41with Snames; use Snames; 42with Stand; use Stand; 43with Tbuild; use Tbuild; 44 45package body Exp_Ch8 is 46 47 --------------------------------------------- 48 -- Expand_N_Exception_Renaming_Declaration -- 49 --------------------------------------------- 50 51 procedure Expand_N_Exception_Renaming_Declaration (N : Node_Id) is 52 Decl : Node_Id; 53 54 begin 55 Decl := Debug_Renaming_Declaration (N); 56 57 if Present (Decl) then 58 Insert_Action (N, Decl); 59 end if; 60 end Expand_N_Exception_Renaming_Declaration; 61 62 ------------------------------------------ 63 -- Expand_N_Object_Renaming_Declaration -- 64 ------------------------------------------ 65 66 -- Most object renaming cases can be done by just capturing the address 67 -- of the renamed object. The cases in which this is not true are when 68 -- this address is not computable, since it involves extraction of a 69 -- packed array element, or of a record component to which a component 70 -- clause applies (that can specify an arbitrary bit boundary), or where 71 -- the enclosing record itself has a non-standard representation. 72 73 -- In these two cases, we pre-evaluate the renaming expression, by 74 -- extracting and freezing the values of any subscripts, and then we 75 -- set the flag Is_Renaming_Of_Object which means that any reference 76 -- to the object will be handled by macro substitution in the front 77 -- end, and the back end will know to ignore the renaming declaration. 78 79 -- An additional odd case that requires processing by expansion is 80 -- the renaming of a discriminant of a mutable record type. The object 81 -- is a constant because it renames something that cannot be assigned to, 82 -- but in fact the underlying value can change and must be reevaluated 83 -- at each reference. Gigi does have a notion of a "constant view" of 84 -- an object, and therefore the front-end must perform the expansion. 85 -- For simplicity, and to bypass some obscure code-generation problem, 86 -- we use macro substitution for all renamed discriminants, whether the 87 -- enclosing type is constrained or not. 88 89 -- The other special processing required is for the case of renaming 90 -- of an object of a class wide type, where it is necessary to build 91 -- the appropriate subtype for the renamed object. 92 -- More comments needed for this para ??? 93 94 procedure Expand_N_Object_Renaming_Declaration (N : Node_Id) is 95 Nam : constant Node_Id := Name (N); 96 Decl : Node_Id; 97 T : Entity_Id; 98 99 function Evaluation_Required (Nam : Node_Id) return Boolean; 100 -- Determines whether it is necessary to do static name evaluation for 101 -- renaming of Nam. It is considered necessary if evaluating the name 102 -- involves indexing a packed array, or extracting a component of a 103 -- record to which a component clause applies. Note that we are only 104 -- interested in these operations if they occur as part of the name 105 -- itself, subscripts are just values that are computed as part of the 106 -- evaluation, so their form is unimportant. 107 -- In addition, always return True for Modify_Tree_For_C since the 108 -- code generator doesn't know how to handle renamings. 109 110 ------------------------- 111 -- Evaluation_Required -- 112 ------------------------- 113 114 function Evaluation_Required (Nam : Node_Id) return Boolean is 115 begin 116 if Modify_Tree_For_C then 117 return True; 118 119 elsif Nkind_In (Nam, N_Indexed_Component, N_Slice) then 120 if Is_Packed (Etype (Prefix (Nam))) then 121 return True; 122 else 123 return Evaluation_Required (Prefix (Nam)); 124 end if; 125 126 elsif Nkind (Nam) = N_Selected_Component then 127 declare 128 Rec_Type : constant Entity_Id := Etype (Prefix (Nam)); 129 130 begin 131 if Present (Component_Clause (Entity (Selector_Name (Nam)))) 132 or else Has_Non_Standard_Rep (Rec_Type) 133 then 134 return True; 135 136 elsif Ekind (Entity (Selector_Name (Nam))) = E_Discriminant 137 and then Is_Record_Type (Rec_Type) 138 and then not Is_Concurrent_Record_Type (Rec_Type) 139 then 140 return True; 141 142 else 143 return Evaluation_Required (Prefix (Nam)); 144 end if; 145 end; 146 147 else 148 return False; 149 end if; 150 end Evaluation_Required; 151 152 -- Start of processing for Expand_N_Object_Renaming_Declaration 153 154 begin 155 -- Perform name evaluation if required 156 157 if Evaluation_Required (Nam) then 158 Evaluate_Name (Nam); 159 Set_Is_Renaming_Of_Object (Defining_Identifier (N)); 160 end if; 161 162 -- Deal with construction of subtype in class-wide case 163 164 T := Etype (Defining_Identifier (N)); 165 166 if Is_Class_Wide_Type (T) then 167 Expand_Subtype_From_Expr (N, T, Subtype_Mark (N), Name (N)); 168 Find_Type (Subtype_Mark (N)); 169 Set_Etype (Defining_Identifier (N), Entity (Subtype_Mark (N))); 170 171 -- Freeze the class-wide subtype here to ensure that the subtype 172 -- and equivalent type are frozen before the renaming. 173 174 Freeze_Before (N, Entity (Subtype_Mark (N))); 175 end if; 176 177 -- Ada 2005 (AI-318-02): If the renamed object is a call to a build-in- 178 -- place function, then a temporary return object needs to be created 179 -- and access to it must be passed to the function. 180 181 if Is_Build_In_Place_Function_Call (Nam) then 182 Make_Build_In_Place_Call_In_Anonymous_Context (Nam); 183 184 -- Ada 2005 (AI-318-02): Specialization of previous case for renaming 185 -- containing build-in-place function calls whose returned object covers 186 -- interface types. 187 188 elsif Present (Unqual_BIP_Iface_Function_Call (Nam)) then 189 Make_Build_In_Place_Iface_Call_In_Anonymous_Context (Nam); 190 end if; 191 192 -- Create renaming entry for debug information. Mark the entity as 193 -- needing debug info if it comes from sources because the current 194 -- setting in Freeze_Entity occurs too late. ??? 195 196 if Comes_From_Source (Defining_Identifier (N)) then 197 Set_Debug_Info_Needed (Defining_Identifier (N)); 198 end if; 199 200 Decl := Debug_Renaming_Declaration (N); 201 202 if Present (Decl) then 203 Insert_Action (N, Decl); 204 end if; 205 end Expand_N_Object_Renaming_Declaration; 206 207 ------------------------------------------- 208 -- Expand_N_Package_Renaming_Declaration -- 209 ------------------------------------------- 210 211 procedure Expand_N_Package_Renaming_Declaration (N : Node_Id) is 212 Decl : Node_Id; 213 214 begin 215 Decl := Debug_Renaming_Declaration (N); 216 217 if Present (Decl) then 218 219 -- If we are in a compilation unit, then this is an outer 220 -- level declaration, and must have a scope of Standard 221 222 if Nkind (Parent (N)) = N_Compilation_Unit then 223 declare 224 Aux : constant Node_Id := Aux_Decls_Node (Parent (N)); 225 226 begin 227 Push_Scope (Standard_Standard); 228 229 if No (Actions (Aux)) then 230 Set_Actions (Aux, New_List (Decl)); 231 else 232 Append (Decl, Actions (Aux)); 233 end if; 234 235 Analyze (Decl); 236 237 -- Enter the debug variable in the qualification list, which 238 -- must be done at this point because auxiliary declarations 239 -- occur at the library level and aren't associated with a 240 -- normal scope. 241 242 Qualify_Entity_Names (Decl); 243 244 Pop_Scope; 245 end; 246 247 -- Otherwise, just insert after the package declaration 248 249 else 250 Insert_Action (N, Decl); 251 end if; 252 end if; 253 end Expand_N_Package_Renaming_Declaration; 254 255 ---------------------------------------------- 256 -- Expand_N_Subprogram_Renaming_Declaration -- 257 ---------------------------------------------- 258 259 procedure Expand_N_Subprogram_Renaming_Declaration (N : Node_Id) is 260 Loc : constant Source_Ptr := Sloc (N); 261 Id : constant Entity_Id := Defining_Entity (N); 262 263 function Build_Body_For_Renaming return Node_Id; 264 -- Build and return the body for the renaming declaration of an equality 265 -- or inequality operator. 266 267 ----------------------------- 268 -- Build_Body_For_Renaming -- 269 ----------------------------- 270 271 function Build_Body_For_Renaming return Node_Id is 272 Body_Id : Entity_Id; 273 Decl : Node_Id; 274 275 begin 276 Set_Alias (Id, Empty); 277 Set_Has_Completion (Id, False); 278 Rewrite (N, 279 Make_Subprogram_Declaration (Sloc (N), 280 Specification => Specification (N))); 281 Set_Has_Delayed_Freeze (Id); 282 283 Body_Id := Make_Defining_Identifier (Sloc (N), Chars (Id)); 284 Set_Debug_Info_Needed (Body_Id); 285 286 Decl := 287 Make_Subprogram_Body (Loc, 288 Specification => 289 Make_Function_Specification (Loc, 290 Defining_Unit_Name => Body_Id, 291 Parameter_Specifications => Copy_Parameter_List (Id), 292 Result_Definition => 293 New_Occurrence_Of (Standard_Boolean, Loc)), 294 Declarations => Empty_List, 295 Handled_Statement_Sequence => Empty); 296 297 return Decl; 298 end Build_Body_For_Renaming; 299 300 -- Local variables 301 302 Nam : constant Node_Id := Name (N); 303 304 -- Start of processing for Expand_N_Subprogram_Renaming_Declaration 305 306 begin 307 -- When the prefix of the name is a function call, we must force the 308 -- call to be made by removing side effects from the call, since we 309 -- must only call the function once. 310 311 if Nkind (Nam) = N_Selected_Component 312 and then Nkind (Prefix (Nam)) = N_Function_Call 313 then 314 Remove_Side_Effects (Prefix (Nam)); 315 316 -- For an explicit dereference, the prefix must be captured to prevent 317 -- reevaluation on calls through the renaming, which could result in 318 -- calling the wrong subprogram if the access value were to be changed. 319 320 elsif Nkind (Nam) = N_Explicit_Dereference then 321 Force_Evaluation (Prefix (Nam)); 322 end if; 323 324 -- Handle cases where we build a body for a renamed equality 325 326 if Is_Entity_Name (Nam) 327 and then Chars (Entity (Nam)) = Name_Op_Eq 328 and then Scope (Entity (Nam)) = Standard_Standard 329 then 330 declare 331 Left : constant Entity_Id := First_Formal (Id); 332 Right : constant Entity_Id := Next_Formal (Left); 333 Typ : constant Entity_Id := Etype (Left); 334 Decl : Node_Id; 335 336 begin 337 -- Check whether this is a renaming of a predefined equality on an 338 -- untagged record type (AI05-0123). 339 340 if Ada_Version >= Ada_2012 341 and then Is_Record_Type (Typ) 342 and then not Is_Tagged_Type (Typ) 343 and then not Is_Frozen (Typ) 344 then 345 -- Build body for renamed equality, to capture its current 346 -- meaning. It may be redefined later, but the renaming is 347 -- elaborated where it occurs. This is technically known as 348 -- Squirreling semantics. Renaming is rewritten as a subprogram 349 -- declaration, and the generated body is inserted into the 350 -- freeze actions for the subprogram. 351 352 Decl := Build_Body_For_Renaming; 353 354 Set_Handled_Statement_Sequence (Decl, 355 Make_Handled_Sequence_Of_Statements (Loc, 356 Statements => New_List ( 357 Make_Simple_Return_Statement (Loc, 358 Expression => 359 Expand_Record_Equality 360 (Id, 361 Typ => Typ, 362 Lhs => Make_Identifier (Loc, Chars (Left)), 363 Rhs => Make_Identifier (Loc, Chars (Right)), 364 Bodies => Declarations (Decl)))))); 365 366 Append_Freeze_Action (Id, Decl); 367 end if; 368 end; 369 end if; 370 end Expand_N_Subprogram_Renaming_Declaration; 371 372end Exp_Ch8; 373