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