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