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-2020, 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 function Evaluation_Required (Nam : Node_Id) return Boolean; 105 -- Determines whether it is necessary to do static name evaluation for 106 -- renaming of Nam. It is considered necessary if evaluating the name 107 -- involves indexing a packed array, or extracting a component of a 108 -- record to which a component clause applies, or a subcomponent of an 109 -- atomic object. Note that we are only interested in these operations 110 -- if they occur as part of the name itself, subscripts are just values 111 -- that are computed as part of the evaluation, so they are unimportant. 112 -- In addition, always return True for Modify_Tree_For_C since the 113 -- code generator doesn't know how to handle renamings. 114 115 ------------------------- 116 -- Evaluation_Required -- 117 ------------------------- 118 119 function Evaluation_Required (Nam : Node_Id) return Boolean is 120 begin 121 if Modify_Tree_For_C then 122 return True; 123 124 elsif Nkind (Nam) in N_Indexed_Component | N_Slice then 125 if Is_Packed (Etype (Prefix (Nam))) then 126 return True; 127 128 elsif Is_Full_Access_Object (Prefix (Nam)) then 129 return True; 130 131 else 132 return Evaluation_Required (Prefix (Nam)); 133 end if; 134 135 elsif Nkind (Nam) = N_Selected_Component then 136 declare 137 Rec_Type : constant Entity_Id := Etype (Prefix (Nam)); 138 139 begin 140 if Present (Component_Clause (Entity (Selector_Name (Nam)))) 141 or else Has_Non_Standard_Rep (Rec_Type) 142 then 143 return True; 144 145 elsif Ekind (Entity (Selector_Name (Nam))) = E_Discriminant 146 and then Is_Record_Type (Rec_Type) 147 and then not Is_Concurrent_Record_Type (Rec_Type) 148 then 149 return True; 150 151 elsif Is_Full_Access_Object (Prefix (Nam)) then 152 return True; 153 154 else 155 return Evaluation_Required (Prefix (Nam)); 156 end if; 157 end; 158 159 else 160 return False; 161 end if; 162 end Evaluation_Required; 163 164 -- Local variables 165 166 Decl : Node_Id; 167 Nam : constant Node_Id := Name (N); 168 T : constant Entity_Id := Etype (Defining_Identifier (N)); 169 170 -- Start of processing for Expand_N_Object_Renaming_Declaration 171 172 begin 173 -- Perform name evaluation if required 174 175 if Evaluation_Required (Nam) then 176 Evaluate_Name (Nam); 177 Set_Is_Renaming_Of_Object (Defining_Identifier (N)); 178 end if; 179 180 -- Deal with construction of subtype in class-wide case 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 Set_Debug_Info_Defining_Id (N); 213 Decl := Debug_Renaming_Declaration (N); 214 215 if Present (Decl) then 216 Insert_Action (N, Decl); 217 end if; 218 end Expand_N_Object_Renaming_Declaration; 219 220 ------------------------------------------- 221 -- Expand_N_Package_Renaming_Declaration -- 222 ------------------------------------------- 223 224 procedure Expand_N_Package_Renaming_Declaration (N : Node_Id) is 225 Decl : Node_Id; 226 227 begin 228 Decl := Debug_Renaming_Declaration (N); 229 230 if Present (Decl) then 231 232 -- If we are in a compilation unit, then this is an outer 233 -- level declaration, and must have a scope of Standard 234 235 if Nkind (Parent (N)) = N_Compilation_Unit then 236 declare 237 Aux : constant Node_Id := Aux_Decls_Node (Parent (N)); 238 239 begin 240 Push_Scope (Standard_Standard); 241 242 if No (Actions (Aux)) then 243 Set_Actions (Aux, New_List (Decl)); 244 else 245 Append (Decl, Actions (Aux)); 246 end if; 247 248 Analyze (Decl); 249 250 -- Enter the debug variable in the qualification list, which 251 -- must be done at this point because auxiliary declarations 252 -- occur at the library level and aren't associated with a 253 -- normal scope. 254 255 Qualify_Entity_Names (Decl); 256 257 Pop_Scope; 258 end; 259 260 -- Otherwise, just insert after the package declaration 261 262 else 263 Insert_Action (N, Decl); 264 end if; 265 end if; 266 end Expand_N_Package_Renaming_Declaration; 267 268 ---------------------------------------------- 269 -- Expand_N_Subprogram_Renaming_Declaration -- 270 ---------------------------------------------- 271 272 procedure Expand_N_Subprogram_Renaming_Declaration (N : Node_Id) is 273 Loc : constant Source_Ptr := Sloc (N); 274 Id : constant Entity_Id := Defining_Entity (N); 275 276 function Build_Body_For_Renaming (Typ : Entity_Id) return Node_Id; 277 -- Build and return the body for the renaming declaration of an equality 278 -- or inequality operator of type Typ. 279 280 ----------------------------- 281 -- Build_Body_For_Renaming -- 282 ----------------------------- 283 284 function Build_Body_For_Renaming (Typ : Entity_Id) return Node_Id is 285 Left : constant Entity_Id := First_Formal (Id); 286 Right : constant Entity_Id := Next_Formal (Left); 287 Body_Id : Entity_Id; 288 Decl : Node_Id; 289 290 begin 291 Set_Alias (Id, Empty); 292 Set_Has_Completion (Id, False); 293 Rewrite (N, 294 Make_Subprogram_Declaration (Sloc (N), 295 Specification => Specification (N))); 296 Set_Has_Delayed_Freeze (Id); 297 298 Body_Id := Make_Defining_Identifier (Sloc (N), Chars (Id)); 299 Set_Debug_Info_Needed (Body_Id); 300 301 if Has_Variant_Part (Typ) then 302 Decl := 303 Build_Variant_Record_Equality 304 (Typ => Typ, 305 Body_Id => Body_Id, 306 Param_Specs => Copy_Parameter_List (Id)); 307 308 -- Build body for renamed equality, to capture its current meaning. 309 -- It may be redefined later, but the renaming is elaborated where 310 -- it occurs. This is technically known as Squirreling semantics. 311 -- Renaming is rewritten as a subprogram declaration, and the 312 -- generated body is inserted into the freeze actions for the 313 -- subprogram. 314 315 else 316 Decl := 317 Make_Subprogram_Body (Loc, 318 Specification => 319 Make_Function_Specification (Loc, 320 Defining_Unit_Name => Body_Id, 321 Parameter_Specifications => Copy_Parameter_List (Id), 322 Result_Definition => 323 New_Occurrence_Of (Standard_Boolean, Loc)), 324 Declarations => Empty_List, 325 Handled_Statement_Sequence => Empty); 326 327 Set_Handled_Statement_Sequence (Decl, 328 Make_Handled_Sequence_Of_Statements (Loc, 329 Statements => New_List ( 330 Make_Simple_Return_Statement (Loc, 331 Expression => 332 Expand_Record_Equality 333 (Id, 334 Typ => Typ, 335 Lhs => Make_Identifier (Loc, Chars (Left)), 336 Rhs => Make_Identifier (Loc, Chars (Right)), 337 Bodies => Declarations (Decl)))))); 338 end if; 339 340 return Decl; 341 end Build_Body_For_Renaming; 342 343 -- Local variables 344 345 Nam : constant Node_Id := Name (N); 346 347 -- Start of processing for Expand_N_Subprogram_Renaming_Declaration 348 349 begin 350 -- When the prefix of the name is a function call, we must force the 351 -- call to be made by removing side effects from the call, since we 352 -- must only call the function once. 353 354 if Nkind (Nam) = N_Selected_Component 355 and then Nkind (Prefix (Nam)) = N_Function_Call 356 then 357 Remove_Side_Effects (Prefix (Nam)); 358 359 -- For an explicit dereference, the prefix must be captured to prevent 360 -- reevaluation on calls through the renaming, which could result in 361 -- calling the wrong subprogram if the access value were to be changed. 362 363 elsif Nkind (Nam) = N_Explicit_Dereference then 364 Force_Evaluation (Prefix (Nam)); 365 end if; 366 367 -- Handle cases where we build a body for a renamed equality 368 369 if Is_Entity_Name (Nam) 370 and then Chars (Entity (Nam)) = Name_Op_Eq 371 and then Scope (Entity (Nam)) = Standard_Standard 372 then 373 declare 374 Typ : constant Entity_Id := Etype (First_Formal (Id)); 375 376 begin 377 -- Check whether this is a renaming of a predefined equality on an 378 -- untagged record type (AI05-0123). 379 380 if Ada_Version >= Ada_2012 381 and then Is_Record_Type (Typ) 382 and then not Is_Tagged_Type (Typ) 383 and then not Is_Frozen (Typ) 384 then 385 Append_Freeze_Action (Id, Build_Body_For_Renaming (Typ)); 386 end if; 387 end; 388 end if; 389 end Expand_N_Subprogram_Renaming_Declaration; 390 391end Exp_Ch8; 392