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