1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- E X P _ C H 1 3 -- 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 Checks; use Checks; 28with Einfo; use Einfo; 29with Exp_Ch3; use Exp_Ch3; 30with Exp_Ch6; use Exp_Ch6; 31with Exp_Imgv; use Exp_Imgv; 32with Exp_Tss; use Exp_Tss; 33with Exp_Util; use Exp_Util; 34with Namet; use Namet; 35with Nlists; use Nlists; 36with Nmake; use Nmake; 37with Opt; use Opt; 38with Restrict; use Restrict; 39with Rident; use Rident; 40with Rtsfind; use Rtsfind; 41with Sem; use Sem; 42with Sem_Aux; use Sem_Aux; 43with Sem_Ch7; use Sem_Ch7; 44with Sem_Ch8; use Sem_Ch8; 45with Sem_Eval; use Sem_Eval; 46with Sem_Util; use Sem_Util; 47with Sinfo; use Sinfo; 48with Snames; use Snames; 49with Targparm; use Targparm; 50with Tbuild; use Tbuild; 51with Uintp; use Uintp; 52with Validsw; use Validsw; 53 54package body Exp_Ch13 is 55 56 ------------------------------------------ 57 -- Expand_N_Attribute_Definition_Clause -- 58 ------------------------------------------ 59 60 -- Expansion action depends on attribute involved 61 62 procedure Expand_N_Attribute_Definition_Clause (N : Node_Id) is 63 Loc : constant Source_Ptr := Sloc (N); 64 Exp : constant Node_Id := Expression (N); 65 Ent : Entity_Id; 66 V : Node_Id; 67 68 begin 69 Ent := Entity (Name (N)); 70 71 if Is_Type (Ent) then 72 Ent := Underlying_Type (Ent); 73 end if; 74 75 case Get_Attribute_Id (Chars (N)) is 76 77 ------------- 78 -- Address -- 79 ------------- 80 81 when Attribute_Address => 82 83 -- If there is an initialization which did not come from the 84 -- source program, then it is an artifact of our expansion, and we 85 -- suppress it. The case we are most concerned about here is the 86 -- initialization of a packed array to all false, which seems 87 -- inappropriate for variable to which an address clause is 88 -- applied. The expression may itself have been rewritten if the 89 -- type is packed array, so we need to examine whether the 90 -- original node is in the source. An exception though is the case 91 -- of an access variable which is default initialized to null, and 92 -- such initialization is retained. 93 94 -- Furthermore, if the initialization is the equivalent aggregate 95 -- of the type initialization procedure, it replaces an implicit 96 -- call to the init proc, and must be respected. Note that for 97 -- packed types we do not build equivalent aggregates. 98 99 -- Also, if Init_Or_Norm_Scalars applies, then we need to retain 100 -- any default initialization for objects of scalar types and 101 -- types with scalar components. Normally a composite type will 102 -- have an init_proc in the presence of Init_Or_Norm_Scalars, 103 -- so when that flag is set we have just have to do a test for 104 -- scalar and string types (the predefined string types such as 105 -- String and Wide_String don't have an init_proc). 106 107 declare 108 Decl : constant Node_Id := Declaration_Node (Ent); 109 Typ : constant Entity_Id := Etype (Ent); 110 111 begin 112 if Nkind (Decl) = N_Object_Declaration 113 and then Present (Expression (Decl)) 114 and then Nkind (Expression (Decl)) /= N_Null 115 and then 116 not Comes_From_Source (Original_Node (Expression (Decl))) 117 then 118 if Present (Base_Init_Proc (Typ)) 119 and then 120 Present (Static_Initialization (Base_Init_Proc (Typ))) 121 then 122 null; 123 124 elsif Init_Or_Norm_Scalars 125 and then 126 (Is_Scalar_Type (Typ) or else Is_String_Type (Typ)) 127 then 128 null; 129 130 else 131 Set_Expression (Decl, Empty); 132 end if; 133 134 -- An object declaration to which an address clause applies 135 -- has a delayed freeze, but the address expression itself 136 -- must be elaborated at the point it appears. If the object 137 -- is controlled, additional checks apply elsewhere. 138 139 elsif Nkind (Decl) = N_Object_Declaration 140 and then not Needs_Constant_Address (Decl, Typ) 141 then 142 Remove_Side_Effects (Exp); 143 end if; 144 end; 145 146 --------------- 147 -- Alignment -- 148 --------------- 149 150 when Attribute_Alignment => 151 152 -- As required by Gigi, we guarantee that the operand is an 153 -- integer literal (this simplifies things in Gigi). 154 155 if Nkind (Exp) /= N_Integer_Literal then 156 Rewrite 157 (Exp, Make_Integer_Literal (Loc, Expr_Value (Exp))); 158 end if; 159 160 ------------------ 161 -- Storage_Size -- 162 ------------------ 163 164 when Attribute_Storage_Size => 165 166 -- If the type is a task type, then assign the value of the 167 -- storage size to the Size variable associated with the task. 168 -- Insert the assignment right after the declaration of the Size 169 -- variable. 170 171 -- Generate: 172 173 -- task_typeZ := expression 174 175 if Ekind (Ent) = E_Task_Type then 176 declare 177 Assign : Node_Id; 178 179 begin 180 Assign := 181 Make_Assignment_Statement (Loc, 182 Name => 183 New_Reference_To (Storage_Size_Variable (Ent), Loc), 184 Expression => 185 Convert_To (RTE (RE_Size_Type), Expression (N))); 186 187 Insert_After 188 (Parent (Storage_Size_Variable (Entity (N))), Assign); 189 190 Analyze (Assign); 191 end; 192 193 -- For Storage_Size for an access type, create a variable to hold 194 -- the value of the specified size with name typeV and expand an 195 -- assignment statement to initialize this value. 196 197 elsif Is_Access_Type (Ent) then 198 199 -- We don't need the variable for a storage size of zero 200 201 if not No_Pool_Assigned (Ent) then 202 V := 203 Make_Defining_Identifier (Loc, 204 Chars => New_External_Name (Chars (Ent), 'V')); 205 206 -- Insert the declaration of the object 207 208 Insert_Action (N, 209 Make_Object_Declaration (Loc, 210 Defining_Identifier => V, 211 Object_Definition => 212 New_Reference_To (RTE (RE_Storage_Offset), Loc), 213 Expression => 214 Convert_To (RTE (RE_Storage_Offset), Expression (N)))); 215 216 Set_Storage_Size_Variable (Ent, Entity_Id (V)); 217 end if; 218 end if; 219 220 -- Other attributes require no expansion 221 222 when others => 223 null; 224 225 end case; 226 end Expand_N_Attribute_Definition_Clause; 227 228 ----------------------------- 229 -- Expand_N_Free_Statement -- 230 ----------------------------- 231 232 procedure Expand_N_Free_Statement (N : Node_Id) is 233 Expr : constant Node_Id := Expression (N); 234 Typ : Entity_Id; 235 236 begin 237 -- Certain run-time configurations and targets do not provide support 238 -- for controlled types. 239 240 if Restriction_Active (No_Finalization) then 241 return; 242 243 -- Do not create a specialized Deallocate since .NET/JVM compilers do 244 -- not support pools and address arithmetic. 245 246 elsif VM_Target /= No_VM then 247 return; 248 end if; 249 250 -- Use the base type to perform the check for finalization master 251 252 Typ := Etype (Expr); 253 254 if Ekind (Typ) = E_Access_Subtype then 255 Typ := Etype (Typ); 256 end if; 257 258 -- Handle private access types 259 260 if Is_Private_Type (Typ) 261 and then Present (Full_View (Typ)) 262 then 263 Typ := Full_View (Typ); 264 end if; 265 266 -- Do not create a custom Deallocate when freeing an object with 267 -- suppressed finalization. In such cases the object is never attached 268 -- to a master, so it does not need to be detached. Use a regular free 269 -- statement instead. 270 271 if No (Finalization_Master (Typ)) then 272 return; 273 end if; 274 275 -- Use a temporary to store the result of a complex expression. Perform 276 -- the following transformation: 277 -- 278 -- Free (Complex_Expression); 279 -- 280 -- Temp : constant Type_Of_Expression := Complex_Expression; 281 -- Free (Temp); 282 283 if Nkind (Expr) /= N_Identifier then 284 declare 285 Expr_Typ : constant Entity_Id := Etype (Expr); 286 Loc : constant Source_Ptr := Sloc (N); 287 New_Expr : Node_Id; 288 Temp_Id : Entity_Id; 289 290 begin 291 Temp_Id := Make_Temporary (Loc, 'T'); 292 Insert_Action (N, 293 Make_Object_Declaration (Loc, 294 Defining_Identifier => Temp_Id, 295 Object_Definition => 296 New_Reference_To (Expr_Typ, Loc), 297 Expression => 298 Relocate_Node (Expr))); 299 300 New_Expr := New_Reference_To (Temp_Id, Loc); 301 Set_Etype (New_Expr, Expr_Typ); 302 303 Set_Expression (N, New_Expr); 304 end; 305 end if; 306 307 -- Create a custom Deallocate for a controlled object. This routine 308 -- ensures that the hidden list header will be deallocated along with 309 -- the actual object. 310 311 Build_Allocate_Deallocate_Proc (N, Is_Allocate => False); 312 end Expand_N_Free_Statement; 313 314 ---------------------------- 315 -- Expand_N_Freeze_Entity -- 316 ---------------------------- 317 318 procedure Expand_N_Freeze_Entity (N : Node_Id) is 319 E : constant Entity_Id := Entity (N); 320 E_Scope : Entity_Id; 321 In_Other_Scope : Boolean; 322 In_Outer_Scope : Boolean; 323 Decl : Node_Id; 324 Delete : Boolean := False; 325 326 begin 327 -- If there are delayed aspect specifications, we insert them just 328 -- before the freeze node. They are already analyzed so we don't need 329 -- to reanalyze them (they were analyzed before the type was frozen), 330 -- but we want them in the tree for the back end, and so that the 331 -- listing from sprint is clearer on where these occur logically. 332 333 if Has_Delayed_Aspects (E) then 334 declare 335 Aitem : Node_Id; 336 Ritem : Node_Id; 337 338 begin 339 -- Look for aspect specs for this entity 340 341 Ritem := First_Rep_Item (E); 342 while Present (Ritem) loop 343 if Nkind (Ritem) = N_Aspect_Specification 344 and then Entity (Ritem) = E 345 then 346 Aitem := Aspect_Rep_Item (Ritem); 347 348 -- Skip this for aspects (e.g. Current_Value) for which 349 -- there is no corresponding pragma or attribute. 350 351 if Present (Aitem) then 352 pragma Assert (Is_Delayed_Aspect (Aitem)); 353 Insert_Before (N, Aitem); 354 end if; 355 end if; 356 357 Next_Rep_Item (Ritem); 358 end loop; 359 end; 360 end if; 361 362 -- Processing for objects with address clauses 363 364 if Is_Object (E) and then Present (Address_Clause (E)) then 365 Apply_Address_Clause_Check (E, N); 366 return; 367 368 -- Only other items requiring any front end action are types and 369 -- subprograms. 370 371 elsif not Is_Type (E) and then not Is_Subprogram (E) then 372 return; 373 end if; 374 375 -- Here E is a type or a subprogram 376 377 E_Scope := Scope (E); 378 379 -- This is an error protection against previous errors 380 381 if No (E_Scope) then 382 Check_Error_Detected; 383 return; 384 end if; 385 386 -- Remember that we are processing a freezing entity and its freezing 387 -- nodes. This flag (non-zero = set) is used to avoid the need of 388 -- climbing through the tree while processing the freezing actions (ie. 389 -- to avoid generating spurious warnings or to avoid killing constant 390 -- indications while processing the code associated with freezing 391 -- actions). We use a counter to deal with nesting. 392 393 Inside_Freezing_Actions := Inside_Freezing_Actions + 1; 394 395 -- If we are freezing entities defined in protected types, they belong 396 -- in the enclosing scope, given that the original type has been 397 -- expanded away. The same is true for entities in task types, in 398 -- particular the parameter records of entries (Entities in bodies are 399 -- all frozen within the body). If we are in the task body, this is a 400 -- proper scope. If we are within a subprogram body, the proper scope 401 -- is the corresponding spec. This may happen for itypes generated in 402 -- the bodies of protected operations. 403 404 if Ekind (E_Scope) = E_Protected_Type 405 or else (Ekind (E_Scope) = E_Task_Type 406 and then not Has_Completion (E_Scope)) 407 then 408 E_Scope := Scope (E_Scope); 409 410 elsif Ekind (E_Scope) = E_Subprogram_Body then 411 E_Scope := Corresponding_Spec (Unit_Declaration_Node (E_Scope)); 412 end if; 413 414 -- If the scope of the entity is in open scopes, it is the current one 415 -- or an enclosing one, including a loop, a block, or a subprogram. 416 417 if In_Open_Scopes (E_Scope) then 418 In_Other_Scope := False; 419 In_Outer_Scope := E_Scope /= Current_Scope; 420 421 -- Otherwise it is a local package or a different compilation unit 422 423 else 424 In_Other_Scope := True; 425 In_Outer_Scope := False; 426 end if; 427 428 -- If the entity being frozen is defined in a scope that is not 429 -- currently on the scope stack, we must establish the proper 430 -- visibility before freezing the entity and related subprograms. 431 432 if In_Other_Scope then 433 Push_Scope (E_Scope); 434 435 -- Finalizers are little odd in terms of freezing. The spec of the 436 -- procedure appears in the declarations while the body appears in 437 -- the statement part of a single construct. Since the finalizer must 438 -- be called by the At_End handler of the construct, the spec is 439 -- manually frozen right after its declaration. The only side effect 440 -- of this action appears in contexts where the construct is not in 441 -- its final resting place. These contexts are: 442 443 -- * Entry bodies - The declarations and statements are moved to 444 -- the procedure equivalen of the entry. 445 -- * Protected subprograms - The declarations and statements are 446 -- moved to the non-protected version of the subprogram. 447 -- * Task bodies - The declarations and statements are moved to the 448 -- task body procedure. 449 450 -- Visible declarations do not need to be installed in these three 451 -- cases since it does not make semantic sense to do so. All entities 452 -- referenced by a finalizer are visible and already resolved, plus 453 -- the enclosing scope may not have visible declarations at all. 454 455 if Ekind (E) = E_Procedure 456 and then Is_Finalizer (E) 457 and then 458 (Is_Entry (E_Scope) 459 or else (Is_Subprogram (E_Scope) 460 and then Is_Protected_Type (Scope (E_Scope))) 461 or else Is_Task_Type (E_Scope)) 462 then 463 null; 464 else 465 Install_Visible_Declarations (E_Scope); 466 end if; 467 468 if Is_Package_Or_Generic_Package (E_Scope) or else 469 Is_Protected_Type (E_Scope) or else 470 Is_Task_Type (E_Scope) 471 then 472 Install_Private_Declarations (E_Scope); 473 end if; 474 475 -- If the entity is in an outer scope, then that scope needs to 476 -- temporarily become the current scope so that operations created 477 -- during type freezing will be declared in the right scope and 478 -- can properly override any corresponding inherited operations. 479 480 elsif In_Outer_Scope then 481 Push_Scope (E_Scope); 482 end if; 483 484 -- If type, freeze the type 485 486 if Is_Type (E) then 487 Delete := Freeze_Type (N); 488 489 -- And for enumeration type, build the enumeration tables 490 491 if Is_Enumeration_Type (E) then 492 Build_Enumeration_Image_Tables (E, N); 493 end if; 494 495 -- If subprogram, freeze the subprogram 496 497 elsif Is_Subprogram (E) then 498 Freeze_Subprogram (N); 499 500 -- Ada 2005 (AI-251): Remove the freezing node associated with the 501 -- entities internally used by the frontend to register primitives 502 -- covering abstract interfaces. The call to Freeze_Subprogram has 503 -- already expanded the code that fills the corresponding entry in 504 -- its secondary dispatch table and therefore the code generator 505 -- has nothing else to do with this freezing node. 506 507 Delete := Present (Interface_Alias (E)); 508 end if; 509 510 -- Analyze actions generated by freezing. The init_proc contains source 511 -- expressions that may raise Constraint_Error, and the assignment 512 -- procedure for complex types needs checks on individual component 513 -- assignments, but all other freezing actions should be compiled with 514 -- all checks off. 515 516 if Present (Actions (N)) then 517 Decl := First (Actions (N)); 518 while Present (Decl) loop 519 if Nkind (Decl) = N_Subprogram_Body 520 and then (Is_Init_Proc (Defining_Entity (Decl)) 521 or else 522 Chars (Defining_Entity (Decl)) = Name_uAssign) 523 then 524 Analyze (Decl); 525 526 -- A subprogram body created for a renaming_as_body completes 527 -- a previous declaration, which may be in a different scope. 528 -- Establish the proper scope before analysis. 529 530 elsif Nkind (Decl) = N_Subprogram_Body 531 and then Present (Corresponding_Spec (Decl)) 532 and then Scope (Corresponding_Spec (Decl)) /= Current_Scope 533 then 534 Push_Scope (Scope (Corresponding_Spec (Decl))); 535 Analyze (Decl, Suppress => All_Checks); 536 Pop_Scope; 537 538 -- We treat generated equality specially, if validity checks are 539 -- enabled, in order to detect components default-initialized 540 -- with invalid values. 541 542 elsif Nkind (Decl) = N_Subprogram_Body 543 and then Chars (Defining_Entity (Decl)) = Name_Op_Eq 544 and then Validity_Checks_On 545 and then Initialize_Scalars 546 then 547 declare 548 Save_Force : constant Boolean := Force_Validity_Checks; 549 begin 550 Force_Validity_Checks := True; 551 Analyze (Decl); 552 Force_Validity_Checks := Save_Force; 553 end; 554 555 else 556 Analyze (Decl, Suppress => All_Checks); 557 end if; 558 559 Next (Decl); 560 end loop; 561 end if; 562 563 -- If we are to delete this N_Freeze_Entity, do so by rewriting so that 564 -- a loop on all nodes being inserted will work propertly. 565 566 if Delete then 567 Rewrite (N, Make_Null_Statement (Sloc (N))); 568 end if; 569 570 -- Pop scope if we installed one for the analysis 571 572 if In_Other_Scope then 573 if Ekind (Current_Scope) = E_Package then 574 End_Package_Scope (E_Scope); 575 else 576 End_Scope; 577 end if; 578 579 elsif In_Outer_Scope then 580 Pop_Scope; 581 end if; 582 583 -- Restore previous value of the nesting-level counter that records 584 -- whether we are inside a (possibly nested) call to this procedure. 585 586 Inside_Freezing_Actions := Inside_Freezing_Actions - 1; 587 end Expand_N_Freeze_Entity; 588 589 ------------------------------------------- 590 -- Expand_N_Record_Representation_Clause -- 591 ------------------------------------------- 592 593 -- The only expansion required is for the case of a mod clause present, 594 -- which is removed, and translated into an alignment representation 595 -- clause inserted immediately after the record rep clause with any 596 -- initial pragmas inserted at the start of the component clause list. 597 598 procedure Expand_N_Record_Representation_Clause (N : Node_Id) is 599 Loc : constant Source_Ptr := Sloc (N); 600 Rectype : constant Entity_Id := Entity (Identifier (N)); 601 Mod_Val : Uint; 602 Citems : List_Id; 603 Repitem : Node_Id; 604 AtM_Nod : Node_Id; 605 606 begin 607 if Present (Mod_Clause (N)) and then not Ignore_Rep_Clauses then 608 Mod_Val := Expr_Value (Expression (Mod_Clause (N))); 609 Citems := Pragmas_Before (Mod_Clause (N)); 610 611 if Present (Citems) then 612 Append_List_To (Citems, Component_Clauses (N)); 613 Set_Component_Clauses (N, Citems); 614 end if; 615 616 AtM_Nod := 617 Make_Attribute_Definition_Clause (Loc, 618 Name => New_Reference_To (Base_Type (Rectype), Loc), 619 Chars => Name_Alignment, 620 Expression => Make_Integer_Literal (Loc, Mod_Val)); 621 622 Set_From_At_Mod (AtM_Nod); 623 Insert_After (N, AtM_Nod); 624 Set_Mod_Clause (N, Empty); 625 end if; 626 627 -- If the record representation clause has no components, then 628 -- completely remove it. Note that we also have to remove 629 -- ourself from the Rep Item list. 630 631 if Is_Empty_List (Component_Clauses (N)) then 632 if First_Rep_Item (Rectype) = N then 633 Set_First_Rep_Item (Rectype, Next_Rep_Item (N)); 634 else 635 Repitem := First_Rep_Item (Rectype); 636 while Present (Next_Rep_Item (Repitem)) loop 637 if Next_Rep_Item (Repitem) = N then 638 Set_Next_Rep_Item (Repitem, Next_Rep_Item (N)); 639 exit; 640 end if; 641 642 Next_Rep_Item (Repitem); 643 end loop; 644 end if; 645 646 Rewrite (N, 647 Make_Null_Statement (Loc)); 648 end if; 649 end Expand_N_Record_Representation_Clause; 650 651end Exp_Ch13; 652