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