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