1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- F R E E Z E -- 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 Aspects; use Aspects; 27with Atree; use Atree; 28with Checks; use Checks; 29with Contracts; use Contracts; 30with Debug; use Debug; 31with Einfo; use Einfo; 32with Elists; use Elists; 33with Errout; use Errout; 34with Exp_Ch3; use Exp_Ch3; 35with Exp_Ch7; use Exp_Ch7; 36with Exp_Pakd; use Exp_Pakd; 37with Exp_Util; use Exp_Util; 38with Exp_Tss; use Exp_Tss; 39with Ghost; use Ghost; 40with Layout; use Layout; 41with Lib; use Lib; 42with Namet; use Namet; 43with Nlists; use Nlists; 44with Nmake; use Nmake; 45with Opt; use Opt; 46with Restrict; use Restrict; 47with Rident; use Rident; 48with Rtsfind; use Rtsfind; 49with Sem; use Sem; 50with Sem_Aux; use Sem_Aux; 51with Sem_Cat; use Sem_Cat; 52with Sem_Ch3; use Sem_Ch3; 53with Sem_Ch6; use Sem_Ch6; 54with Sem_Ch7; use Sem_Ch7; 55with Sem_Ch8; use Sem_Ch8; 56with Sem_Ch13; use Sem_Ch13; 57with Sem_Eval; use Sem_Eval; 58with Sem_Mech; use Sem_Mech; 59with Sem_Prag; use Sem_Prag; 60with Sem_Res; use Sem_Res; 61with Sem_Util; use Sem_Util; 62with Sinfo; use Sinfo; 63with Snames; use Snames; 64with Stand; use Stand; 65with Stringt; use Stringt; 66with Targparm; use Targparm; 67with Tbuild; use Tbuild; 68with Ttypes; use Ttypes; 69with Uintp; use Uintp; 70with Urealp; use Urealp; 71with Warnsw; use Warnsw; 72 73package body Freeze is 74 75 ----------------------- 76 -- Local Subprograms -- 77 ----------------------- 78 79 procedure Adjust_Esize_For_Alignment (Typ : Entity_Id); 80 -- Typ is a type that is being frozen. If no size clause is given, 81 -- but a default Esize has been computed, then this default Esize is 82 -- adjusted up if necessary to be consistent with a given alignment, 83 -- but never to a value greater than System_Max_Integer_Size. This is 84 -- used for all discrete types and for fixed-point types. 85 86 procedure Build_And_Analyze_Renamed_Body 87 (Decl : Node_Id; 88 New_S : Entity_Id; 89 After : in out Node_Id); 90 -- Build body for a renaming declaration, insert in tree and analyze 91 92 procedure Check_Address_Clause (E : Entity_Id); 93 -- Apply legality checks to address clauses for object declarations, 94 -- at the point the object is frozen. Also ensure any initialization is 95 -- performed only after the object has been frozen. 96 97 procedure Check_Component_Storage_Order 98 (Encl_Type : Entity_Id; 99 Comp : Entity_Id; 100 ADC : Node_Id; 101 Comp_ADC_Present : out Boolean); 102 -- For an Encl_Type that has a Scalar_Storage_Order attribute definition 103 -- clause, verify that the component type has an explicit and compatible 104 -- attribute/aspect. For arrays, Comp is Empty; for records, it is the 105 -- entity of the component under consideration. For an Encl_Type that 106 -- does not have a Scalar_Storage_Order attribute definition clause, 107 -- verify that the component also does not have such a clause. 108 -- ADC is the attribute definition clause if present (or Empty). On return, 109 -- Comp_ADC_Present is set True if the component has a Scalar_Storage_Order 110 -- attribute definition clause. 111 112 procedure Check_Debug_Info_Needed (T : Entity_Id); 113 -- As each entity is frozen, this routine is called to deal with the 114 -- setting of Debug_Info_Needed for the entity. This flag is set if 115 -- the entity comes from source, or if we are in Debug_Generated_Code 116 -- mode or if the -gnatdV debug flag is set. However, it never sets 117 -- the flag if Debug_Info_Off is set. This procedure also ensures that 118 -- subsidiary entities have the flag set as required. 119 120 procedure Check_Expression_Function (N : Node_Id; Nam : Entity_Id); 121 -- When an expression function is frozen by a use of it, the expression 122 -- itself is frozen. Check that the expression does not include references 123 -- to deferred constants without completion. We report this at the freeze 124 -- point of the function, to provide a better error message. 125 -- 126 -- In most cases the expression itself is frozen by the time the function 127 -- itself is frozen, because the formals will be frozen by then. However, 128 -- Attribute references to outer types are freeze points for those types; 129 -- this routine generates the required freeze nodes for them. 130 131 procedure Check_Inherited_Conditions (R : Entity_Id); 132 -- For a tagged derived type, create wrappers for inherited operations 133 -- that have a class-wide condition, so it can be properly rewritten if 134 -- it involves calls to other overriding primitives. 135 136 procedure Check_Strict_Alignment (E : Entity_Id); 137 -- E is a base type. If E is tagged or has a component that is aliased 138 -- or tagged or contains something this is aliased or tagged, set 139 -- Strict_Alignment. 140 141 procedure Check_Unsigned_Type (E : Entity_Id); 142 pragma Inline (Check_Unsigned_Type); 143 -- If E is a fixed-point or discrete type, then all the necessary work 144 -- to freeze it is completed except for possible setting of the flag 145 -- Is_Unsigned_Type, which is done by this procedure. The call has no 146 -- effect if the entity E is not a discrete or fixed-point type. 147 148 procedure Freeze_And_Append 149 (Ent : Entity_Id; 150 N : Node_Id; 151 Result : in out List_Id); 152 -- Freezes Ent using Freeze_Entity, and appends the resulting list of 153 -- nodes to Result, modifying Result from No_List if necessary. N has 154 -- the same usage as in Freeze_Entity. 155 156 procedure Freeze_Enumeration_Type (Typ : Entity_Id); 157 -- Freeze enumeration type. The Esize field is set as processing 158 -- proceeds (i.e. set by default when the type is declared and then 159 -- adjusted by rep clauses. What this procedure does is to make sure 160 -- that if a foreign convention is specified, and no specific size 161 -- is given, then the size must be at least Integer'Size. 162 163 procedure Freeze_Static_Object (E : Entity_Id); 164 -- If an object is frozen which has Is_Statically_Allocated set, then 165 -- all referenced types must also be marked with this flag. This routine 166 -- is in charge of meeting this requirement for the object entity E. 167 168 procedure Freeze_Subprogram (E : Entity_Id); 169 -- Perform freezing actions for a subprogram (create extra formals, 170 -- and set proper default mechanism values). Note that this routine 171 -- is not called for internal subprograms, for which neither of these 172 -- actions is needed (or desirable, we do not want for example to have 173 -- these extra formals present in initialization procedures, where they 174 -- would serve no purpose). In this call E is either a subprogram or 175 -- a subprogram type (i.e. an access to a subprogram). 176 177 function Is_Fully_Defined (T : Entity_Id) return Boolean; 178 -- True if T is not private and has no private components, or has a full 179 -- view. Used to determine whether the designated type of an access type 180 -- should be frozen when the access type is frozen. This is done when an 181 -- allocator is frozen, or an expression that may involve attributes of 182 -- the designated type. Otherwise freezing the access type does not freeze 183 -- the designated type. 184 185 procedure Process_Default_Expressions 186 (E : Entity_Id; 187 After : in out Node_Id); 188 -- This procedure is called for each subprogram to complete processing of 189 -- default expressions at the point where all types are known to be frozen. 190 -- The expressions must be analyzed in full, to make sure that all error 191 -- processing is done (they have only been preanalyzed). If the expression 192 -- is not an entity or literal, its analysis may generate code which must 193 -- not be executed. In that case we build a function body to hold that 194 -- code. This wrapper function serves no other purpose (it used to be 195 -- called to evaluate the default, but now the default is inlined at each 196 -- point of call). 197 198 procedure Set_Component_Alignment_If_Not_Set (Typ : Entity_Id); 199 -- Typ is a record or array type that is being frozen. This routine sets 200 -- the default component alignment from the scope stack values if the 201 -- alignment is otherwise not specified. 202 203 procedure Set_SSO_From_Default (T : Entity_Id); 204 -- T is a record or array type that is being frozen. If it is a base type, 205 -- and if SSO_Set_Low/High_By_Default is set, then Reverse_Storage order 206 -- will be set appropriately. Note that an explicit occurrence of aspect 207 -- Scalar_Storage_Order or an explicit setting of this aspect with an 208 -- attribute definition clause occurs, then these two flags are reset in 209 -- any case, so call will have no effect. 210 211 procedure Undelay_Type (T : Entity_Id); 212 -- T is a type of a component that we know to be an Itype. We don't want 213 -- this to have a Freeze_Node, so ensure it doesn't. Do the same for any 214 -- Full_View or Corresponding_Record_Type. 215 216 procedure Warn_Overlay (Expr : Node_Id; Typ : Entity_Id; Nam : Node_Id); 217 -- Expr is the expression for an address clause for entity Nam whose type 218 -- is Typ. If Typ has a default initialization, and there is no explicit 219 -- initialization in the source declaration, check whether the address 220 -- clause might cause overlaying of an entity, and emit a warning on the 221 -- side effect that the initialization will cause. 222 223 ------------------------------- 224 -- Adjust_Esize_For_Alignment -- 225 ------------------------------- 226 227 procedure Adjust_Esize_For_Alignment (Typ : Entity_Id) is 228 Align : Uint; 229 230 begin 231 if Known_Esize (Typ) and then Known_Alignment (Typ) then 232 Align := Alignment_In_Bits (Typ); 233 234 if Align > Esize (Typ) and then Align <= System_Max_Integer_Size then 235 Set_Esize (Typ, Align); 236 end if; 237 end if; 238 end Adjust_Esize_For_Alignment; 239 240 ------------------------------------ 241 -- Build_And_Analyze_Renamed_Body -- 242 ------------------------------------ 243 244 procedure Build_And_Analyze_Renamed_Body 245 (Decl : Node_Id; 246 New_S : Entity_Id; 247 After : in out Node_Id) 248 is 249 Body_Decl : constant Node_Id := Unit_Declaration_Node (New_S); 250 Ent : constant Entity_Id := Defining_Entity (Decl); 251 Body_Node : Node_Id; 252 Renamed_Subp : Entity_Id; 253 254 begin 255 -- If the renamed subprogram is intrinsic, there is no need for a 256 -- wrapper body: we set the alias that will be called and expanded which 257 -- completes the declaration. This transformation is only legal if the 258 -- renamed entity has already been elaborated. 259 260 -- Note that it is legal for a renaming_as_body to rename an intrinsic 261 -- subprogram, as long as the renaming occurs before the new entity 262 -- is frozen (RM 8.5.4 (5)). 263 264 if Nkind (Body_Decl) = N_Subprogram_Renaming_Declaration 265 and then Is_Entity_Name (Name (Body_Decl)) 266 then 267 Renamed_Subp := Entity (Name (Body_Decl)); 268 else 269 Renamed_Subp := Empty; 270 end if; 271 272 if Present (Renamed_Subp) 273 and then Is_Intrinsic_Subprogram (Renamed_Subp) 274 and then 275 (not In_Same_Source_Unit (Renamed_Subp, Ent) 276 or else Sloc (Renamed_Subp) < Sloc (Ent)) 277 278 -- We can make the renaming entity intrinsic if the renamed function 279 -- has an interface name, or if it is one of the shift/rotate 280 -- operations known to the compiler. 281 282 and then 283 (Present (Interface_Name (Renamed_Subp)) 284 or else Chars (Renamed_Subp) in Name_Rotate_Left 285 | Name_Rotate_Right 286 | Name_Shift_Left 287 | Name_Shift_Right 288 | Name_Shift_Right_Arithmetic) 289 then 290 Set_Interface_Name (Ent, Interface_Name (Renamed_Subp)); 291 292 if Present (Alias (Renamed_Subp)) then 293 Set_Alias (Ent, Alias (Renamed_Subp)); 294 else 295 Set_Alias (Ent, Renamed_Subp); 296 end if; 297 298 Set_Is_Intrinsic_Subprogram (Ent); 299 Set_Has_Completion (Ent); 300 301 else 302 Body_Node := Build_Renamed_Body (Decl, New_S); 303 Insert_After (After, Body_Node); 304 Mark_Rewrite_Insertion (Body_Node); 305 Analyze (Body_Node); 306 After := Body_Node; 307 end if; 308 end Build_And_Analyze_Renamed_Body; 309 310 ------------------------ 311 -- Build_Renamed_Body -- 312 ------------------------ 313 314 function Build_Renamed_Body 315 (Decl : Node_Id; 316 New_S : Entity_Id) return Node_Id 317 is 318 Loc : constant Source_Ptr := Sloc (New_S); 319 -- We use for the source location of the renamed body, the location of 320 -- the spec entity. It might seem more natural to use the location of 321 -- the renaming declaration itself, but that would be wrong, since then 322 -- the body we create would look as though it was created far too late, 323 -- and this could cause problems with elaboration order analysis, 324 -- particularly in connection with instantiations. 325 326 N : constant Node_Id := Unit_Declaration_Node (New_S); 327 Nam : constant Node_Id := Name (N); 328 Old_S : Entity_Id; 329 Spec : constant Node_Id := New_Copy_Tree (Specification (Decl)); 330 Actuals : List_Id := No_List; 331 Call_Node : Node_Id; 332 Call_Name : Node_Id; 333 Body_Node : Node_Id; 334 Formal : Entity_Id; 335 O_Formal : Entity_Id; 336 Param_Spec : Node_Id; 337 338 Pref : Node_Id := Empty; 339 -- If the renamed entity is a primitive operation given in prefix form, 340 -- the prefix is the target object and it has to be added as the first 341 -- actual in the generated call. 342 343 begin 344 -- Determine the entity being renamed, which is the target of the call 345 -- statement. If the name is an explicit dereference, this is a renaming 346 -- of a subprogram type rather than a subprogram. The name itself is 347 -- fully analyzed. 348 349 if Nkind (Nam) = N_Selected_Component then 350 Old_S := Entity (Selector_Name (Nam)); 351 352 elsif Nkind (Nam) = N_Explicit_Dereference then 353 Old_S := Etype (Nam); 354 355 elsif Nkind (Nam) = N_Indexed_Component then 356 if Is_Entity_Name (Prefix (Nam)) then 357 Old_S := Entity (Prefix (Nam)); 358 else 359 Old_S := Entity (Selector_Name (Prefix (Nam))); 360 end if; 361 362 elsif Nkind (Nam) = N_Character_Literal then 363 Old_S := Etype (New_S); 364 365 else 366 Old_S := Entity (Nam); 367 end if; 368 369 if Is_Entity_Name (Nam) then 370 371 -- If the renamed entity is a predefined operator, retain full name 372 -- to ensure its visibility. 373 374 if Ekind (Old_S) = E_Operator 375 and then Nkind (Nam) = N_Expanded_Name 376 then 377 Call_Name := New_Copy (Name (N)); 378 else 379 Call_Name := New_Occurrence_Of (Old_S, Loc); 380 end if; 381 382 else 383 if Nkind (Nam) = N_Selected_Component 384 and then Present (First_Formal (Old_S)) 385 and then 386 (Is_Controlling_Formal (First_Formal (Old_S)) 387 or else Is_Class_Wide_Type (Etype (First_Formal (Old_S)))) 388 then 389 390 -- Retrieve the target object, to be added as a first actual 391 -- in the call. 392 393 Call_Name := New_Occurrence_Of (Old_S, Loc); 394 Pref := Prefix (Nam); 395 396 else 397 Call_Name := New_Copy (Name (N)); 398 end if; 399 400 -- Original name may have been overloaded, but is fully resolved now 401 402 Set_Is_Overloaded (Call_Name, False); 403 end if; 404 405 -- For simple renamings, subsequent calls can be expanded directly as 406 -- calls to the renamed entity. The body must be generated in any case 407 -- for calls that may appear elsewhere. This is not done in the case 408 -- where the subprogram is an instantiation because the actual proper 409 -- body has not been built yet. This is also not done in GNATprove mode 410 -- as we need to check other conditions for creating a body to inline 411 -- in that case, which are controlled in Analyze_Subprogram_Body_Helper. 412 413 if Ekind (Old_S) in E_Function | E_Procedure 414 and then Nkind (Decl) = N_Subprogram_Declaration 415 and then not Is_Generic_Instance (Old_S) 416 and then not GNATprove_Mode 417 then 418 Set_Body_To_Inline (Decl, Old_S); 419 end if; 420 421 -- Check whether the return type is a limited view. If the subprogram 422 -- is already frozen the generated body may have a non-limited view 423 -- of the type, that must be used, because it is the one in the spec 424 -- of the renaming declaration. 425 426 if Ekind (Old_S) = E_Function 427 and then Is_Entity_Name (Result_Definition (Spec)) 428 then 429 declare 430 Ret_Type : constant Entity_Id := Etype (Result_Definition (Spec)); 431 begin 432 if Has_Non_Limited_View (Ret_Type) then 433 Set_Result_Definition 434 (Spec, New_Occurrence_Of (Non_Limited_View (Ret_Type), Loc)); 435 end if; 436 end; 437 end if; 438 439 -- The body generated for this renaming is an internal artifact, and 440 -- does not constitute a freeze point for the called entity. 441 442 Set_Must_Not_Freeze (Call_Name); 443 444 Formal := First_Formal (Defining_Entity (Decl)); 445 446 if Present (Pref) then 447 declare 448 Pref_Type : constant Entity_Id := Etype (Pref); 449 Form_Type : constant Entity_Id := Etype (First_Formal (Old_S)); 450 451 begin 452 -- The controlling formal may be an access parameter, or the 453 -- actual may be an access value, so adjust accordingly. 454 455 if Is_Access_Type (Pref_Type) 456 and then not Is_Access_Type (Form_Type) 457 then 458 Actuals := New_List 459 (Make_Explicit_Dereference (Loc, Relocate_Node (Pref))); 460 461 elsif Is_Access_Type (Form_Type) 462 and then not Is_Access_Type (Pref) 463 then 464 Actuals := 465 New_List ( 466 Make_Attribute_Reference (Loc, 467 Attribute_Name => Name_Access, 468 Prefix => Relocate_Node (Pref))); 469 else 470 Actuals := New_List (Pref); 471 end if; 472 end; 473 474 elsif Present (Formal) then 475 Actuals := New_List; 476 477 else 478 Actuals := No_List; 479 end if; 480 481 if Present (Formal) then 482 while Present (Formal) loop 483 Append (New_Occurrence_Of (Formal, Loc), Actuals); 484 Next_Formal (Formal); 485 end loop; 486 end if; 487 488 -- If the renamed entity is an entry, inherit its profile. For other 489 -- renamings as bodies, both profiles must be subtype conformant, so it 490 -- is not necessary to replace the profile given in the declaration. 491 -- However, default values that are aggregates are rewritten when 492 -- partially analyzed, so we recover the original aggregate to insure 493 -- that subsequent conformity checking works. Similarly, if the default 494 -- expression was constant-folded, recover the original expression. 495 496 Formal := First_Formal (Defining_Entity (Decl)); 497 498 if Present (Formal) then 499 O_Formal := First_Formal (Old_S); 500 Param_Spec := First (Parameter_Specifications (Spec)); 501 while Present (Formal) loop 502 if Is_Entry (Old_S) then 503 if Nkind (Parameter_Type (Param_Spec)) /= 504 N_Access_Definition 505 then 506 Set_Etype (Formal, Etype (O_Formal)); 507 Set_Entity (Parameter_Type (Param_Spec), Etype (O_Formal)); 508 end if; 509 510 elsif Nkind (Default_Value (O_Formal)) = N_Aggregate 511 or else Nkind (Original_Node (Default_Value (O_Formal))) /= 512 Nkind (Default_Value (O_Formal)) 513 then 514 Set_Expression (Param_Spec, 515 New_Copy_Tree (Original_Node (Default_Value (O_Formal)))); 516 end if; 517 518 Next_Formal (Formal); 519 Next_Formal (O_Formal); 520 Next (Param_Spec); 521 end loop; 522 end if; 523 524 -- If the renamed entity is a function, the generated body contains a 525 -- return statement. Otherwise, build a procedure call. If the entity is 526 -- an entry, subsequent analysis of the call will transform it into the 527 -- proper entry or protected operation call. If the renamed entity is 528 -- a character literal, return it directly. 529 530 if Ekind (Old_S) = E_Function 531 or else Ekind (Old_S) = E_Operator 532 or else (Ekind (Old_S) = E_Subprogram_Type 533 and then Etype (Old_S) /= Standard_Void_Type) 534 then 535 Call_Node := 536 Make_Simple_Return_Statement (Loc, 537 Expression => 538 Make_Function_Call (Loc, 539 Name => Call_Name, 540 Parameter_Associations => Actuals)); 541 542 elsif Ekind (Old_S) = E_Enumeration_Literal then 543 Call_Node := 544 Make_Simple_Return_Statement (Loc, 545 Expression => New_Occurrence_Of (Old_S, Loc)); 546 547 elsif Nkind (Nam) = N_Character_Literal then 548 Call_Node := 549 Make_Simple_Return_Statement (Loc, Expression => Call_Name); 550 551 else 552 Call_Node := 553 Make_Procedure_Call_Statement (Loc, 554 Name => Call_Name, 555 Parameter_Associations => Actuals); 556 end if; 557 558 -- Create entities for subprogram body and formals 559 560 Set_Defining_Unit_Name (Spec, 561 Make_Defining_Identifier (Loc, Chars => Chars (New_S))); 562 563 Param_Spec := First (Parameter_Specifications (Spec)); 564 while Present (Param_Spec) loop 565 Set_Defining_Identifier (Param_Spec, 566 Make_Defining_Identifier (Loc, 567 Chars => Chars (Defining_Identifier (Param_Spec)))); 568 Next (Param_Spec); 569 end loop; 570 571 Body_Node := 572 Make_Subprogram_Body (Loc, 573 Specification => Spec, 574 Declarations => New_List, 575 Handled_Statement_Sequence => 576 Make_Handled_Sequence_Of_Statements (Loc, 577 Statements => New_List (Call_Node))); 578 579 if Nkind (Decl) /= N_Subprogram_Declaration then 580 Rewrite (N, 581 Make_Subprogram_Declaration (Loc, 582 Specification => Specification (N))); 583 end if; 584 585 -- Link the body to the entity whose declaration it completes. If 586 -- the body is analyzed when the renamed entity is frozen, it may 587 -- be necessary to restore the proper scope (see package Exp_Ch13). 588 589 if Nkind (N) = N_Subprogram_Renaming_Declaration 590 and then Present (Corresponding_Spec (N)) 591 then 592 Set_Corresponding_Spec (Body_Node, Corresponding_Spec (N)); 593 else 594 Set_Corresponding_Spec (Body_Node, New_S); 595 end if; 596 597 return Body_Node; 598 end Build_Renamed_Body; 599 600 -------------------------- 601 -- Check_Address_Clause -- 602 -------------------------- 603 604 procedure Check_Address_Clause (E : Entity_Id) is 605 Addr : constant Node_Id := Address_Clause (E); 606 Typ : constant Entity_Id := Etype (E); 607 Decl : Node_Id; 608 Expr : Node_Id; 609 Init : Node_Id; 610 Lhs : Node_Id; 611 Tag_Assign : Node_Id; 612 613 begin 614 if Present (Addr) then 615 616 -- For a deferred constant, the initialization value is on full view 617 618 if Ekind (E) = E_Constant and then Present (Full_View (E)) then 619 Decl := Declaration_Node (Full_View (E)); 620 else 621 Decl := Declaration_Node (E); 622 end if; 623 624 Expr := Expression (Addr); 625 626 if Needs_Constant_Address (Decl, Typ) then 627 Check_Constant_Address_Clause (Expr, E); 628 629 -- Has_Delayed_Freeze was set on E when the address clause was 630 -- analyzed, and must remain set because we want the address 631 -- clause to be elaborated only after any entity it references 632 -- has been elaborated. 633 end if; 634 635 -- If Rep_Clauses are to be ignored, remove address clause from 636 -- list attached to entity, because it may be illegal for gigi, 637 -- for example by breaking order of elaboration. 638 639 if Ignore_Rep_Clauses then 640 declare 641 Rep : Node_Id; 642 643 begin 644 Rep := First_Rep_Item (E); 645 646 if Rep = Addr then 647 Set_First_Rep_Item (E, Next_Rep_Item (Addr)); 648 649 else 650 while Present (Rep) 651 and then Next_Rep_Item (Rep) /= Addr 652 loop 653 Next_Rep_Item (Rep); 654 end loop; 655 end if; 656 657 if Present (Rep) then 658 Set_Next_Rep_Item (Rep, Next_Rep_Item (Addr)); 659 end if; 660 end; 661 662 -- And now remove the address clause 663 664 Kill_Rep_Clause (Addr); 665 666 elsif not Error_Posted (Expr) 667 and then not Needs_Finalization (Typ) 668 then 669 Warn_Overlay (Expr, Typ, Name (Addr)); 670 end if; 671 672 Init := Expression (Decl); 673 674 -- If a variable, or a non-imported constant, overlays a constant 675 -- object and has an initialization value, then the initialization 676 -- may end up writing into read-only memory. Detect the cases of 677 -- statically identical values and remove the initialization. In 678 -- the other cases, give a warning. We will give other warnings 679 -- later for the variable if it is assigned. 680 681 if (Ekind (E) = E_Variable 682 or else (Ekind (E) = E_Constant 683 and then not Is_Imported (E))) 684 and then Overlays_Constant (E) 685 and then Present (Init) 686 then 687 declare 688 O_Ent : Entity_Id; 689 Off : Boolean; 690 691 begin 692 Find_Overlaid_Entity (Addr, O_Ent, Off); 693 694 if Ekind (O_Ent) = E_Constant 695 and then Etype (O_Ent) = Typ 696 and then Present (Constant_Value (O_Ent)) 697 and then Compile_Time_Compare 698 (Init, 699 Constant_Value (O_Ent), 700 Assume_Valid => True) = EQ 701 then 702 Set_No_Initialization (Decl); 703 return; 704 705 elsif Comes_From_Source (Init) 706 and then Address_Clause_Overlay_Warnings 707 then 708 Error_Msg_Sloc := Sloc (Addr); 709 Error_Msg_NE 710 ("??constant& may be modified via address clause#", 711 Decl, O_Ent); 712 end if; 713 end; 714 end if; 715 716 -- Remove side effects from initial expression, except in the case of 717 -- limited build-in-place calls and aggregates, which have their own 718 -- expansion elsewhere. This exception is necessary to avoid copying 719 -- limited objects. 720 721 if Present (Init) 722 and then not Is_Limited_View (Typ) 723 then 724 -- Capture initialization value at point of declaration, and make 725 -- explicit assignment legal, because object may be a constant. 726 727 Remove_Side_Effects (Init); 728 Lhs := New_Occurrence_Of (E, Sloc (Decl)); 729 Set_Assignment_OK (Lhs); 730 731 -- Move initialization to freeze actions, once the object has 732 -- been frozen and the address clause alignment check has been 733 -- performed. 734 735 Append_Freeze_Action (E, 736 Make_Assignment_Statement (Sloc (Decl), 737 Name => Lhs, 738 Expression => Expression (Decl))); 739 740 Set_No_Initialization (Decl); 741 742 -- If the object is tagged, check whether the tag must be 743 -- reassigned explicitly. 744 745 Tag_Assign := Make_Tag_Assignment (Decl); 746 if Present (Tag_Assign) then 747 Append_Freeze_Action (E, Tag_Assign); 748 end if; 749 end if; 750 end if; 751 end Check_Address_Clause; 752 753 ----------------------------- 754 -- Check_Compile_Time_Size -- 755 ----------------------------- 756 757 procedure Check_Compile_Time_Size (T : Entity_Id) is 758 759 procedure Set_Small_Size (T : Entity_Id; S : Uint); 760 -- Sets the compile time known size in the RM_Size field of T, checking 761 -- for a size clause that was given which attempts to give a small size. 762 763 function Size_Known (T : Entity_Id) return Boolean; 764 -- Recursive function that does all the work 765 766 function Static_Discriminated_Components (T : Entity_Id) return Boolean; 767 -- If T is a constrained subtype, its size is not known if any of its 768 -- discriminant constraints is not static and it is not a null record. 769 -- The test is conservative and doesn't check that the components are 770 -- in fact constrained by non-static discriminant values. Could be made 771 -- more precise ??? 772 773 -------------------- 774 -- Set_Small_Size -- 775 -------------------- 776 777 procedure Set_Small_Size (T : Entity_Id; S : Uint) is 778 begin 779 if S > System_Max_Integer_Size then 780 return; 781 782 -- Check for bad size clause given 783 784 elsif Has_Size_Clause (T) then 785 if RM_Size (T) < S then 786 Error_Msg_Uint_1 := S; 787 Error_Msg_NE (Size_Too_Small_Message, Size_Clause (T), T); 788 end if; 789 790 -- Set size if not set already 791 792 elsif Unknown_RM_Size (T) then 793 Set_RM_Size (T, S); 794 end if; 795 end Set_Small_Size; 796 797 ---------------- 798 -- Size_Known -- 799 ---------------- 800 801 function Size_Known (T : Entity_Id) return Boolean is 802 Index : Entity_Id; 803 Comp : Entity_Id; 804 Ctyp : Entity_Id; 805 Low : Node_Id; 806 High : Node_Id; 807 808 begin 809 if Size_Known_At_Compile_Time (T) then 810 return True; 811 812 -- Always True for elementary types, even generic formal elementary 813 -- types. We used to return False in the latter case, but the size 814 -- is known at compile time, even in the template, we just do not 815 -- know the exact size but that's not the point of this routine. 816 817 elsif Is_Elementary_Type (T) or else Is_Task_Type (T) then 818 return True; 819 820 -- Array types 821 822 elsif Is_Array_Type (T) then 823 824 -- String literals always have known size, and we can set it 825 826 if Ekind (T) = E_String_Literal_Subtype then 827 Set_Small_Size 828 (T, Component_Size (T) * String_Literal_Length (T)); 829 return True; 830 831 -- Unconstrained types never have known at compile time size 832 833 elsif not Is_Constrained (T) then 834 return False; 835 836 -- Don't do any recursion on type with error posted, since we may 837 -- have a malformed type that leads us into a loop. 838 839 elsif Error_Posted (T) then 840 return False; 841 842 -- Otherwise if component size unknown, then array size unknown 843 844 elsif not Size_Known (Component_Type (T)) then 845 return False; 846 end if; 847 848 -- Check for all indexes static, and also compute possible size 849 -- (in case it is not greater than System_Max_Integer_Size and 850 -- thus may be packable). 851 852 declare 853 Size : Uint := Component_Size (T); 854 Dim : Uint; 855 856 begin 857 Index := First_Index (T); 858 while Present (Index) loop 859 if Nkind (Index) = N_Range then 860 Get_Index_Bounds (Index, Low, High); 861 862 elsif Error_Posted (Scalar_Range (Etype (Index))) then 863 return False; 864 865 else 866 Low := Type_Low_Bound (Etype (Index)); 867 High := Type_High_Bound (Etype (Index)); 868 end if; 869 870 if not Compile_Time_Known_Value (Low) 871 or else not Compile_Time_Known_Value (High) 872 or else Etype (Index) = Any_Type 873 then 874 return False; 875 876 else 877 Dim := Expr_Value (High) - Expr_Value (Low) + 1; 878 879 if Dim >= 0 then 880 Size := Size * Dim; 881 else 882 Size := Uint_0; 883 end if; 884 end if; 885 886 Next_Index (Index); 887 end loop; 888 889 Set_Small_Size (T, Size); 890 return True; 891 end; 892 893 -- For non-generic private types, go to underlying type if present 894 895 elsif Is_Private_Type (T) 896 and then not Is_Generic_Type (T) 897 and then Present (Underlying_Type (T)) 898 then 899 -- Don't do any recursion on type with error posted, since we may 900 -- have a malformed type that leads us into a loop. 901 902 if Error_Posted (T) then 903 return False; 904 else 905 return Size_Known (Underlying_Type (T)); 906 end if; 907 908 -- Record types 909 910 elsif Is_Record_Type (T) then 911 912 -- A class-wide type is never considered to have a known size 913 914 if Is_Class_Wide_Type (T) then 915 return False; 916 917 -- A subtype of a variant record must not have non-static 918 -- discriminated components. 919 920 elsif T /= Base_Type (T) 921 and then not Static_Discriminated_Components (T) 922 then 923 return False; 924 925 -- Don't do any recursion on type with error posted, since we may 926 -- have a malformed type that leads us into a loop. 927 928 elsif Error_Posted (T) then 929 return False; 930 end if; 931 932 -- Now look at the components of the record 933 934 declare 935 -- The following two variables are used to keep track of the 936 -- size of packed records if we can tell the size of the packed 937 -- record in the front end. Packed_Size_Known is True if so far 938 -- we can figure out the size. It is initialized to True for a 939 -- packed record, unless the record has either discriminants or 940 -- independent components, or is a strict-alignment type, since 941 -- it cannot be fully packed in this case. 942 943 -- The reason we eliminate the discriminated case is that 944 -- we don't know the way the back end lays out discriminated 945 -- packed records. If Packed_Size_Known is True, then 946 -- Packed_Size is the size in bits so far. 947 948 Packed_Size_Known : Boolean := 949 Is_Packed (T) 950 and then not Has_Discriminants (T) 951 and then not Has_Independent_Components (T) 952 and then not Strict_Alignment (T); 953 954 Packed_Size : Uint := Uint_0; 955 -- Size in bits so far 956 957 begin 958 -- Test for variant part present 959 960 if Has_Discriminants (T) 961 and then Present (Parent (T)) 962 and then Nkind (Parent (T)) = N_Full_Type_Declaration 963 and then Nkind (Type_Definition (Parent (T))) = 964 N_Record_Definition 965 and then not Null_Present (Type_Definition (Parent (T))) 966 and then 967 Present (Variant_Part 968 (Component_List (Type_Definition (Parent (T))))) 969 then 970 -- If variant part is present, and type is unconstrained, 971 -- then we must have defaulted discriminants, or a size 972 -- clause must be present for the type, or else the size 973 -- is definitely not known at compile time. 974 975 if not Is_Constrained (T) 976 and then 977 No (Discriminant_Default_Value (First_Discriminant (T))) 978 and then Unknown_RM_Size (T) 979 then 980 return False; 981 end if; 982 end if; 983 984 -- Loop through components 985 986 Comp := First_Component_Or_Discriminant (T); 987 while Present (Comp) loop 988 Ctyp := Etype (Comp); 989 990 -- We do not know the packed size if there is a component 991 -- clause present (we possibly could, but this would only 992 -- help in the case of a record with partial rep clauses. 993 -- That's because in the case of full rep clauses, the 994 -- size gets figured out anyway by a different circuit). 995 996 if Present (Component_Clause (Comp)) then 997 Packed_Size_Known := False; 998 end if; 999 1000 -- We do not know the packed size for an independent 1001 -- component or if it is of a strict-alignment type, 1002 -- since packing does not touch these (RM 13.2(7)). 1003 1004 if Is_Independent (Comp) 1005 or else Is_Independent (Ctyp) 1006 or else Strict_Alignment (Ctyp) 1007 then 1008 Packed_Size_Known := False; 1009 end if; 1010 1011 -- We need to identify a component that is an array where 1012 -- the index type is an enumeration type with non-standard 1013 -- representation, and some bound of the type depends on a 1014 -- discriminant. 1015 1016 -- This is because gigi computes the size by doing a 1017 -- substitution of the appropriate discriminant value in 1018 -- the size expression for the base type, and gigi is not 1019 -- clever enough to evaluate the resulting expression (which 1020 -- involves a call to rep_to_pos) at compile time. 1021 1022 -- It would be nice if gigi would either recognize that 1023 -- this expression can be computed at compile time, or 1024 -- alternatively figured out the size from the subtype 1025 -- directly, where all the information is at hand ??? 1026 1027 if Is_Array_Type (Etype (Comp)) 1028 and then Present (Packed_Array_Impl_Type (Etype (Comp))) 1029 then 1030 declare 1031 Ocomp : constant Entity_Id := 1032 Original_Record_Component (Comp); 1033 OCtyp : constant Entity_Id := Etype (Ocomp); 1034 Ind : Node_Id; 1035 Indtyp : Entity_Id; 1036 Lo, Hi : Node_Id; 1037 1038 begin 1039 Ind := First_Index (OCtyp); 1040 while Present (Ind) loop 1041 Indtyp := Etype (Ind); 1042 1043 if Is_Enumeration_Type (Indtyp) 1044 and then Has_Non_Standard_Rep (Indtyp) 1045 then 1046 Lo := Type_Low_Bound (Indtyp); 1047 Hi := Type_High_Bound (Indtyp); 1048 1049 if Is_Entity_Name (Lo) 1050 and then Ekind (Entity (Lo)) = E_Discriminant 1051 then 1052 return False; 1053 1054 elsif Is_Entity_Name (Hi) 1055 and then Ekind (Entity (Hi)) = E_Discriminant 1056 then 1057 return False; 1058 end if; 1059 end if; 1060 1061 Next_Index (Ind); 1062 end loop; 1063 end; 1064 end if; 1065 1066 -- Clearly size of record is not known if the size of one of 1067 -- the components is not known. 1068 1069 if not Size_Known (Ctyp) then 1070 return False; 1071 end if; 1072 1073 -- Accumulate packed size if possible 1074 1075 if Packed_Size_Known then 1076 1077 -- We can deal with elementary types, small packed arrays 1078 -- if the representation is a modular type and also small 1079 -- record types as checked by Set_Small_Size. 1080 1081 if Is_Elementary_Type (Ctyp) 1082 or else (Is_Array_Type (Ctyp) 1083 and then Present 1084 (Packed_Array_Impl_Type (Ctyp)) 1085 and then Is_Modular_Integer_Type 1086 (Packed_Array_Impl_Type (Ctyp))) 1087 or else Is_Record_Type (Ctyp) 1088 then 1089 -- If RM_Size is known and static, then we can keep 1090 -- accumulating the packed size. 1091 1092 if Known_Static_RM_Size (Ctyp) then 1093 1094 Packed_Size := Packed_Size + RM_Size (Ctyp); 1095 1096 -- If we have a field whose RM_Size is not known then 1097 -- we can't figure out the packed size here. 1098 1099 else 1100 Packed_Size_Known := False; 1101 end if; 1102 1103 -- For other types we can't figure out the packed size 1104 1105 else 1106 Packed_Size_Known := False; 1107 end if; 1108 end if; 1109 1110 Next_Component_Or_Discriminant (Comp); 1111 end loop; 1112 1113 if Packed_Size_Known then 1114 Set_Small_Size (T, Packed_Size); 1115 end if; 1116 1117 return True; 1118 end; 1119 1120 -- All other cases, size not known at compile time 1121 1122 else 1123 return False; 1124 end if; 1125 end Size_Known; 1126 1127 ------------------------------------- 1128 -- Static_Discriminated_Components -- 1129 ------------------------------------- 1130 1131 function Static_Discriminated_Components 1132 (T : Entity_Id) return Boolean 1133 is 1134 Constraint : Elmt_Id; 1135 1136 begin 1137 if Has_Discriminants (T) 1138 and then Present (Discriminant_Constraint (T)) 1139 and then Present (First_Component (T)) 1140 then 1141 Constraint := First_Elmt (Discriminant_Constraint (T)); 1142 while Present (Constraint) loop 1143 if not Compile_Time_Known_Value (Node (Constraint)) then 1144 return False; 1145 end if; 1146 1147 Next_Elmt (Constraint); 1148 end loop; 1149 end if; 1150 1151 return True; 1152 end Static_Discriminated_Components; 1153 1154 -- Start of processing for Check_Compile_Time_Size 1155 1156 begin 1157 Set_Size_Known_At_Compile_Time (T, Size_Known (T)); 1158 end Check_Compile_Time_Size; 1159 1160 ----------------------------------- 1161 -- Check_Component_Storage_Order -- 1162 ----------------------------------- 1163 1164 procedure Check_Component_Storage_Order 1165 (Encl_Type : Entity_Id; 1166 Comp : Entity_Id; 1167 ADC : Node_Id; 1168 Comp_ADC_Present : out Boolean) 1169 is 1170 Comp_Base : Entity_Id; 1171 Comp_ADC : Node_Id; 1172 Encl_Base : Entity_Id; 1173 Err_Node : Node_Id; 1174 1175 Component_Aliased : Boolean; 1176 1177 Comp_Byte_Aligned : Boolean := False; 1178 -- Set for the record case, True if Comp is aligned on byte boundaries 1179 -- (in which case it is allowed to have different storage order). 1180 1181 Comp_SSO_Differs : Boolean; 1182 -- Set True when the component is a nested composite, and it does not 1183 -- have the same scalar storage order as Encl_Type. 1184 1185 begin 1186 -- Record case 1187 1188 if Present (Comp) then 1189 Err_Node := Comp; 1190 Comp_Base := Etype (Comp); 1191 1192 if Is_Tag (Comp) then 1193 Comp_Byte_Aligned := True; 1194 Component_Aliased := False; 1195 1196 else 1197 -- If a component clause is present, check if the component starts 1198 -- and ends on byte boundaries. Otherwise conservatively assume it 1199 -- does so only in the case where the record is not packed. 1200 1201 if Present (Component_Clause (Comp)) then 1202 Comp_Byte_Aligned := 1203 (Normalized_First_Bit (Comp) mod System_Storage_Unit = 0) 1204 and then 1205 (Esize (Comp) mod System_Storage_Unit = 0); 1206 else 1207 Comp_Byte_Aligned := not Is_Packed (Encl_Type); 1208 end if; 1209 1210 Component_Aliased := Is_Aliased (Comp); 1211 end if; 1212 1213 -- Array case 1214 1215 else 1216 Err_Node := Encl_Type; 1217 Comp_Base := Component_Type (Encl_Type); 1218 1219 Component_Aliased := Has_Aliased_Components (Encl_Type); 1220 end if; 1221 1222 -- Note: the Reverse_Storage_Order flag is set on the base type, but 1223 -- the attribute definition clause is attached to the first subtype. 1224 -- Also, if the base type is incomplete or private, go to full view 1225 -- if known 1226 1227 Encl_Base := Base_Type (Encl_Type); 1228 if Present (Underlying_Type (Encl_Base)) then 1229 Encl_Base := Underlying_Type (Encl_Base); 1230 end if; 1231 1232 Comp_Base := Base_Type (Comp_Base); 1233 if Present (Underlying_Type (Comp_Base)) then 1234 Comp_Base := Underlying_Type (Comp_Base); 1235 end if; 1236 1237 Comp_ADC := 1238 Get_Attribute_Definition_Clause 1239 (First_Subtype (Comp_Base), Attribute_Scalar_Storage_Order); 1240 Comp_ADC_Present := Present (Comp_ADC); 1241 1242 -- Case of record or array component: check storage order compatibility. 1243 -- But, if the record has Complex_Representation, then it is treated as 1244 -- a scalar in the back end so the storage order is irrelevant. 1245 1246 if (Is_Record_Type (Comp_Base) 1247 and then not Has_Complex_Representation (Comp_Base)) 1248 or else Is_Array_Type (Comp_Base) 1249 then 1250 Comp_SSO_Differs := 1251 Reverse_Storage_Order (Encl_Base) /= 1252 Reverse_Storage_Order (Comp_Base); 1253 1254 -- Parent and extension must have same storage order 1255 1256 if Present (Comp) and then Chars (Comp) = Name_uParent then 1257 if Comp_SSO_Differs then 1258 Error_Msg_N 1259 ("record extension must have same scalar storage order as " 1260 & "parent", Err_Node); 1261 end if; 1262 1263 -- If component and composite SSO differs, check that component 1264 -- falls on byte boundaries and isn't bit packed. 1265 1266 elsif Comp_SSO_Differs then 1267 1268 -- Component SSO differs from enclosing composite: 1269 1270 -- Reject if composite is a bit-packed array, as it is rewritten 1271 -- into an array of scalars. 1272 1273 if Is_Bit_Packed_Array (Encl_Base) then 1274 Error_Msg_N 1275 ("type of packed array must have same scalar storage order " 1276 & "as component", Err_Node); 1277 1278 -- Reject if not byte aligned 1279 1280 elsif Is_Record_Type (Encl_Base) 1281 and then not Comp_Byte_Aligned 1282 then 1283 Error_Msg_N 1284 ("type of non-byte-aligned component must have same scalar " 1285 & "storage order as enclosing composite", Err_Node); 1286 1287 -- Warn if specified only for the outer composite 1288 1289 elsif Present (ADC) and then No (Comp_ADC) then 1290 Error_Msg_NE 1291 ("scalar storage order specified for & does not apply to " 1292 & "component?", Err_Node, Encl_Base); 1293 end if; 1294 end if; 1295 1296 -- Enclosing type has explicit SSO: non-composite component must not 1297 -- be aliased. 1298 1299 elsif Present (ADC) and then Component_Aliased then 1300 Error_Msg_N 1301 ("aliased component not permitted for type with explicit " 1302 & "Scalar_Storage_Order", Err_Node); 1303 end if; 1304 end Check_Component_Storage_Order; 1305 1306 ----------------------------- 1307 -- Check_Debug_Info_Needed -- 1308 ----------------------------- 1309 1310 procedure Check_Debug_Info_Needed (T : Entity_Id) is 1311 begin 1312 if Debug_Info_Off (T) then 1313 return; 1314 1315 elsif Comes_From_Source (T) 1316 or else Debug_Generated_Code 1317 or else Debug_Flag_VV 1318 or else Needs_Debug_Info (T) 1319 then 1320 Set_Debug_Info_Needed (T); 1321 end if; 1322 end Check_Debug_Info_Needed; 1323 1324 ------------------------------- 1325 -- Check_Expression_Function -- 1326 ------------------------------- 1327 1328 procedure Check_Expression_Function (N : Node_Id; Nam : Entity_Id) is 1329 function Find_Constant (Nod : Node_Id) return Traverse_Result; 1330 -- Function to search for deferred constant 1331 1332 ------------------- 1333 -- Find_Constant -- 1334 ------------------- 1335 1336 function Find_Constant (Nod : Node_Id) return Traverse_Result is 1337 begin 1338 -- When a constant is initialized with the result of a dispatching 1339 -- call, the constant declaration is rewritten as a renaming of the 1340 -- displaced function result. This scenario is not a premature use of 1341 -- a constant even though the Has_Completion flag is not set. 1342 1343 if Is_Entity_Name (Nod) 1344 and then Present (Entity (Nod)) 1345 and then Ekind (Entity (Nod)) = E_Constant 1346 and then Scope (Entity (Nod)) = Current_Scope 1347 and then Nkind (Declaration_Node (Entity (Nod))) = 1348 N_Object_Declaration 1349 and then not Is_Imported (Entity (Nod)) 1350 and then not Has_Completion (Entity (Nod)) 1351 and then not Is_Frozen (Entity (Nod)) 1352 then 1353 Error_Msg_NE 1354 ("premature use of& in call or instance", N, Entity (Nod)); 1355 1356 elsif Nkind (Nod) = N_Attribute_Reference then 1357 Analyze (Prefix (Nod)); 1358 1359 if Is_Entity_Name (Prefix (Nod)) 1360 and then Is_Type (Entity (Prefix (Nod))) 1361 then 1362 Freeze_Before (N, Entity (Prefix (Nod))); 1363 end if; 1364 end if; 1365 1366 return OK; 1367 end Find_Constant; 1368 1369 procedure Check_Deferred is new Traverse_Proc (Find_Constant); 1370 1371 -- Local variables 1372 1373 Decl : Node_Id; 1374 1375 -- Start of processing for Check_Expression_Function 1376 1377 begin 1378 Decl := Original_Node (Unit_Declaration_Node (Nam)); 1379 1380 -- The subprogram body created for the expression function is not 1381 -- itself a freeze point. 1382 1383 if Scope (Nam) = Current_Scope 1384 and then Nkind (Decl) = N_Expression_Function 1385 and then Nkind (N) /= N_Subprogram_Body 1386 then 1387 Check_Deferred (Expression (Decl)); 1388 end if; 1389 end Check_Expression_Function; 1390 1391 -------------------------------- 1392 -- Check_Inherited_Conditions -- 1393 -------------------------------- 1394 1395 procedure Check_Inherited_Conditions (R : Entity_Id) is 1396 Prim_Ops : constant Elist_Id := Primitive_Operations (R); 1397 Decls : List_Id; 1398 Needs_Wrapper : Boolean; 1399 Op_Node : Elmt_Id; 1400 Par_Prim : Entity_Id; 1401 Prim : Entity_Id; 1402 1403 procedure Build_Inherited_Condition_Pragmas (Subp : Entity_Id); 1404 -- Build corresponding pragmas for an operation whose ancestor has 1405 -- class-wide pre/postconditions. If the operation is inherited, the 1406 -- pragmas force the creation of a wrapper for the inherited operation. 1407 -- If the ancestor is being overridden, the pragmas are constructed only 1408 -- to verify their legality, in case they contain calls to other 1409 -- primitives that may haven been overridden. 1410 1411 --------------------------------------- 1412 -- Build_Inherited_Condition_Pragmas -- 1413 --------------------------------------- 1414 1415 procedure Build_Inherited_Condition_Pragmas (Subp : Entity_Id) is 1416 A_Post : Node_Id; 1417 A_Pre : Node_Id; 1418 New_Prag : Node_Id; 1419 1420 begin 1421 A_Pre := Get_Class_Wide_Pragma (Par_Prim, Pragma_Precondition); 1422 1423 if Present (A_Pre) then 1424 New_Prag := New_Copy_Tree (A_Pre); 1425 Build_Class_Wide_Expression 1426 (Prag => New_Prag, 1427 Subp => Prim, 1428 Par_Subp => Par_Prim, 1429 Adjust_Sloc => False, 1430 Needs_Wrapper => Needs_Wrapper); 1431 1432 if Needs_Wrapper 1433 and then not Comes_From_Source (Subp) 1434 and then Expander_Active 1435 then 1436 Append (New_Prag, Decls); 1437 end if; 1438 end if; 1439 1440 A_Post := Get_Class_Wide_Pragma (Par_Prim, Pragma_Postcondition); 1441 1442 if Present (A_Post) then 1443 New_Prag := New_Copy_Tree (A_Post); 1444 Build_Class_Wide_Expression 1445 (Prag => New_Prag, 1446 Subp => Prim, 1447 Par_Subp => Par_Prim, 1448 Adjust_Sloc => False, 1449 Needs_Wrapper => Needs_Wrapper); 1450 1451 if Needs_Wrapper 1452 and then not Comes_From_Source (Subp) 1453 and then Expander_Active 1454 then 1455 Append (New_Prag, Decls); 1456 end if; 1457 end if; 1458 end Build_Inherited_Condition_Pragmas; 1459 1460 -- Start of processing for Check_Inherited_Conditions 1461 1462 begin 1463 Op_Node := First_Elmt (Prim_Ops); 1464 while Present (Op_Node) loop 1465 Prim := Node (Op_Node); 1466 1467 -- Map the overridden primitive to the overriding one. This takes 1468 -- care of all overridings and is done only once. 1469 1470 if Present (Overridden_Operation (Prim)) 1471 and then Comes_From_Source (Prim) 1472 then 1473 Par_Prim := Overridden_Operation (Prim); 1474 Update_Primitives_Mapping (Par_Prim, Prim); 1475 end if; 1476 1477 Next_Elmt (Op_Node); 1478 end loop; 1479 1480 -- Perform validity checks on the inherited conditions of overriding 1481 -- operations, for conformance with LSP, and apply SPARK-specific 1482 -- restrictions on inherited conditions. 1483 1484 Op_Node := First_Elmt (Prim_Ops); 1485 while Present (Op_Node) loop 1486 Prim := Node (Op_Node); 1487 1488 if Present (Overridden_Operation (Prim)) 1489 and then Comes_From_Source (Prim) 1490 then 1491 Par_Prim := Overridden_Operation (Prim); 1492 1493 -- Analyze the contract items of the overridden operation, before 1494 -- they are rewritten as pragmas. 1495 1496 Analyze_Entry_Or_Subprogram_Contract (Par_Prim); 1497 1498 -- In GNATprove mode this is where we can collect the inherited 1499 -- conditions, because we do not create the Check pragmas that 1500 -- normally convey the modified class-wide conditions on 1501 -- overriding operations. 1502 1503 if GNATprove_Mode then 1504 Collect_Inherited_Class_Wide_Conditions (Prim); 1505 1506 -- Otherwise build the corresponding pragmas to check for legality 1507 -- of the inherited condition. 1508 1509 else 1510 Build_Inherited_Condition_Pragmas (Prim); 1511 end if; 1512 end if; 1513 1514 Next_Elmt (Op_Node); 1515 end loop; 1516 1517 -- Now examine the inherited operations to check whether they require 1518 -- a wrapper to handle inherited conditions that call other primitives, 1519 -- so that LSP can be verified/enforced. 1520 1521 Op_Node := First_Elmt (Prim_Ops); 1522 1523 while Present (Op_Node) loop 1524 Decls := Empty_List; 1525 Prim := Node (Op_Node); 1526 Needs_Wrapper := False; 1527 1528 if not Comes_From_Source (Prim) and then Present (Alias (Prim)) then 1529 Par_Prim := Alias (Prim); 1530 1531 -- Analyze the contract items of the parent operation, and 1532 -- determine whether a wrapper is needed. This is determined 1533 -- when the condition is rewritten in sem_prag, using the 1534 -- mapping between overridden and overriding operations built 1535 -- in the loop above. 1536 1537 Analyze_Entry_Or_Subprogram_Contract (Par_Prim); 1538 Build_Inherited_Condition_Pragmas (Prim); 1539 end if; 1540 1541 if Needs_Wrapper 1542 and then not Is_Abstract_Subprogram (Par_Prim) 1543 and then Expander_Active 1544 then 1545 -- We need to build a new primitive that overrides the inherited 1546 -- one, and whose inherited expression has been updated above. 1547 -- These expressions are the arguments of pragmas that are part 1548 -- of the declarations of the wrapper. The wrapper holds a single 1549 -- statement that is a call to the class-wide clone, where the 1550 -- controlling actuals are conversions to the corresponding type 1551 -- in the parent primitive: 1552 1553 -- procedure New_Prim (F1 : T1; ...); 1554 -- procedure New_Prim (F1 : T1; ...) is 1555 -- pragma Check (Precondition, Expr); 1556 -- begin 1557 -- Par_Prim_Clone (Par_Type (F1), ...); 1558 -- end; 1559 1560 -- If the primitive is a function the statement is a return 1561 -- statement with a call. 1562 1563 declare 1564 Loc : constant Source_Ptr := Sloc (R); 1565 Par_R : constant Node_Id := Parent (R); 1566 New_Body : Node_Id; 1567 New_Decl : Node_Id; 1568 New_Spec : Node_Id; 1569 1570 begin 1571 New_Spec := Build_Overriding_Spec (Par_Prim, R); 1572 New_Decl := 1573 Make_Subprogram_Declaration (Loc, 1574 Specification => New_Spec); 1575 1576 -- Insert the declaration and the body of the wrapper after 1577 -- type declaration that generates inherited operation. For 1578 -- a null procedure, the declaration implies a null body. 1579 1580 if Nkind (New_Spec) = N_Procedure_Specification 1581 and then Null_Present (New_Spec) 1582 then 1583 Insert_After_And_Analyze (Par_R, New_Decl); 1584 1585 else 1586 -- Build body as wrapper to a call to the already built 1587 -- class-wide clone. 1588 1589 New_Body := 1590 Build_Class_Wide_Clone_Call 1591 (Loc, Decls, Par_Prim, New_Spec); 1592 1593 Insert_List_After_And_Analyze 1594 (Par_R, New_List (New_Decl, New_Body)); 1595 end if; 1596 end; 1597 end if; 1598 1599 Next_Elmt (Op_Node); 1600 end loop; 1601 end Check_Inherited_Conditions; 1602 1603 ---------------------------- 1604 -- Check_Strict_Alignment -- 1605 ---------------------------- 1606 1607 procedure Check_Strict_Alignment (E : Entity_Id) is 1608 Comp : Entity_Id; 1609 1610 begin 1611 -- Bit-packed array types do not require strict alignment, even if they 1612 -- are by-reference types, because they are accessed in a special way. 1613 1614 if Is_By_Reference_Type (E) and then not Is_Bit_Packed_Array (E) then 1615 Set_Strict_Alignment (E); 1616 1617 elsif Is_Array_Type (E) then 1618 Set_Strict_Alignment (E, Strict_Alignment (Component_Type (E))); 1619 1620 -- ??? AI12-001: Any component of a packed type that contains an 1621 -- aliased part must be aligned according to the alignment of its 1622 -- subtype (RM 13.2(7)). This means that the following test: 1623 1624 -- if Has_Aliased_Components (E) then 1625 -- Set_Strict_Alignment (E); 1626 -- end if; 1627 1628 -- should be implemented here. Unfortunately it would break Florist, 1629 -- which has the bad habit of overaligning all the types it declares 1630 -- on 32-bit platforms. Other legacy codebases could also be affected 1631 -- because this check has historically been missing in GNAT. 1632 1633 elsif Is_Record_Type (E) then 1634 Comp := First_Component (E); 1635 while Present (Comp) loop 1636 if not Is_Type (Comp) 1637 and then (Is_Aliased (Comp) 1638 or else Strict_Alignment (Etype (Comp))) 1639 then 1640 Set_Strict_Alignment (E); 1641 return; 1642 end if; 1643 1644 Next_Component (Comp); 1645 end loop; 1646 end if; 1647 end Check_Strict_Alignment; 1648 1649 ------------------------- 1650 -- Check_Unsigned_Type -- 1651 ------------------------- 1652 1653 procedure Check_Unsigned_Type (E : Entity_Id) is 1654 Ancestor : Entity_Id; 1655 Lo_Bound : Node_Id; 1656 Btyp : Entity_Id; 1657 1658 begin 1659 if not Is_Discrete_Or_Fixed_Point_Type (E) then 1660 return; 1661 end if; 1662 1663 -- Do not attempt to analyze case where range was in error 1664 1665 if No (Scalar_Range (E)) or else Error_Posted (Scalar_Range (E)) then 1666 return; 1667 end if; 1668 1669 -- The situation that is nontrivial is something like: 1670 1671 -- subtype x1 is integer range -10 .. +10; 1672 -- subtype x2 is x1 range 0 .. V1; 1673 -- subtype x3 is x2 range V2 .. V3; 1674 -- subtype x4 is x3 range V4 .. V5; 1675 1676 -- where Vn are variables. Here the base type is signed, but we still 1677 -- know that x4 is unsigned because of the lower bound of x2. 1678 1679 -- The only way to deal with this is to look up the ancestor chain 1680 1681 Ancestor := E; 1682 loop 1683 if Ancestor = Any_Type or else Etype (Ancestor) = Any_Type then 1684 return; 1685 end if; 1686 1687 Lo_Bound := Type_Low_Bound (Ancestor); 1688 1689 if Compile_Time_Known_Value (Lo_Bound) then 1690 if Expr_Rep_Value (Lo_Bound) >= 0 then 1691 Set_Is_Unsigned_Type (E, True); 1692 end if; 1693 1694 return; 1695 1696 else 1697 Ancestor := Ancestor_Subtype (Ancestor); 1698 1699 -- If no ancestor had a static lower bound, go to base type 1700 1701 if No (Ancestor) then 1702 1703 -- Note: the reason we still check for a compile time known 1704 -- value for the base type is that at least in the case of 1705 -- generic formals, we can have bounds that fail this test, 1706 -- and there may be other cases in error situations. 1707 1708 Btyp := Base_Type (E); 1709 1710 if Btyp = Any_Type or else Etype (Btyp) = Any_Type then 1711 return; 1712 end if; 1713 1714 Lo_Bound := Type_Low_Bound (Base_Type (E)); 1715 1716 if Compile_Time_Known_Value (Lo_Bound) 1717 and then Expr_Rep_Value (Lo_Bound) >= 0 1718 then 1719 Set_Is_Unsigned_Type (E, True); 1720 end if; 1721 1722 return; 1723 end if; 1724 end if; 1725 end loop; 1726 end Check_Unsigned_Type; 1727 1728 ------------------------------ 1729 -- Is_Full_Access_Aggregate -- 1730 ------------------------------ 1731 1732 function Is_Full_Access_Aggregate (N : Node_Id) return Boolean is 1733 Loc : constant Source_Ptr := Sloc (N); 1734 New_N : Node_Id; 1735 Par : Node_Id; 1736 Temp : Entity_Id; 1737 Typ : Entity_Id; 1738 1739 begin 1740 Par := Parent (N); 1741 1742 -- Array may be qualified, so find outer context 1743 1744 if Nkind (Par) = N_Qualified_Expression then 1745 Par := Parent (Par); 1746 end if; 1747 1748 if not Comes_From_Source (Par) then 1749 return False; 1750 end if; 1751 1752 case Nkind (Par) is 1753 when N_Assignment_Statement => 1754 Typ := Etype (Name (Par)); 1755 1756 if not Is_Full_Access (Typ) 1757 and then not Is_Full_Access_Object (Name (Par)) 1758 then 1759 return False; 1760 end if; 1761 1762 when N_Object_Declaration => 1763 Typ := Etype (Defining_Identifier (Par)); 1764 1765 if not Is_Full_Access (Typ) 1766 and then not Is_Full_Access (Defining_Identifier (Par)) 1767 then 1768 return False; 1769 end if; 1770 1771 when others => 1772 return False; 1773 end case; 1774 1775 Temp := Make_Temporary (Loc, 'T', N); 1776 New_N := 1777 Make_Object_Declaration (Loc, 1778 Defining_Identifier => Temp, 1779 Constant_Present => True, 1780 Object_Definition => New_Occurrence_Of (Typ, Loc), 1781 Expression => Relocate_Node (N)); 1782 Insert_Before (Par, New_N); 1783 Analyze (New_N); 1784 1785 Set_Expression (Par, New_Occurrence_Of (Temp, Loc)); 1786 return True; 1787 end Is_Full_Access_Aggregate; 1788 1789 ----------------------------------------------- 1790 -- Explode_Initialization_Compound_Statement -- 1791 ----------------------------------------------- 1792 1793 procedure Explode_Initialization_Compound_Statement (E : Entity_Id) is 1794 Init_Stmts : constant Node_Id := Initialization_Statements (E); 1795 1796 begin 1797 if Present (Init_Stmts) 1798 and then Nkind (Init_Stmts) = N_Compound_Statement 1799 then 1800 Insert_List_Before (Init_Stmts, Actions (Init_Stmts)); 1801 1802 -- Note that we rewrite Init_Stmts into a NULL statement, rather than 1803 -- just removing it, because Freeze_All may rely on this particular 1804 -- Node_Id still being present in the enclosing list to know where to 1805 -- stop freezing. 1806 1807 Rewrite (Init_Stmts, Make_Null_Statement (Sloc (Init_Stmts))); 1808 1809 Set_Initialization_Statements (E, Empty); 1810 end if; 1811 end Explode_Initialization_Compound_Statement; 1812 1813 ---------------- 1814 -- Freeze_All -- 1815 ---------------- 1816 1817 -- Note: the easy coding for this procedure would be to just build a 1818 -- single list of freeze nodes and then insert them and analyze them 1819 -- all at once. This won't work, because the analysis of earlier freeze 1820 -- nodes may recursively freeze types which would otherwise appear later 1821 -- on in the freeze list. So we must analyze and expand the freeze nodes 1822 -- as they are generated. 1823 1824 procedure Freeze_All (From : Entity_Id; After : in out Node_Id) is 1825 procedure Freeze_All_Ent (From : Entity_Id; After : in out Node_Id); 1826 -- This is the internal recursive routine that does freezing of entities 1827 -- (but NOT the analysis of default expressions, which should not be 1828 -- recursive, we don't want to analyze those till we are sure that ALL 1829 -- the types are frozen). 1830 1831 -------------------- 1832 -- Freeze_All_Ent -- 1833 -------------------- 1834 1835 procedure Freeze_All_Ent (From : Entity_Id; After : in out Node_Id) is 1836 E : Entity_Id; 1837 Flist : List_Id; 1838 Lastn : Node_Id; 1839 1840 procedure Process_Flist; 1841 -- If freeze nodes are present, insert and analyze, and reset cursor 1842 -- for next insertion. 1843 1844 ------------------- 1845 -- Process_Flist -- 1846 ------------------- 1847 1848 procedure Process_Flist is 1849 begin 1850 if Is_Non_Empty_List (Flist) then 1851 Lastn := Next (After); 1852 Insert_List_After_And_Analyze (After, Flist); 1853 1854 if Present (Lastn) then 1855 After := Prev (Lastn); 1856 else 1857 After := Last (List_Containing (After)); 1858 end if; 1859 end if; 1860 end Process_Flist; 1861 1862 -- Start of processing for Freeze_All_Ent 1863 1864 begin 1865 E := From; 1866 while Present (E) loop 1867 1868 -- If the entity is an inner package which is not a package 1869 -- renaming, then its entities must be frozen at this point. Note 1870 -- that such entities do NOT get frozen at the end of the nested 1871 -- package itself (only library packages freeze). 1872 1873 -- Same is true for task declarations, where anonymous records 1874 -- created for entry parameters must be frozen. 1875 1876 if Ekind (E) = E_Package 1877 and then No (Renamed_Object (E)) 1878 and then not Is_Child_Unit (E) 1879 and then not Is_Frozen (E) 1880 then 1881 Push_Scope (E); 1882 1883 Install_Visible_Declarations (E); 1884 Install_Private_Declarations (E); 1885 Freeze_All (First_Entity (E), After); 1886 1887 End_Package_Scope (E); 1888 1889 if Is_Generic_Instance (E) 1890 and then Has_Delayed_Freeze (E) 1891 then 1892 Set_Has_Delayed_Freeze (E, False); 1893 Expand_N_Package_Declaration (Unit_Declaration_Node (E)); 1894 end if; 1895 1896 elsif Ekind (E) in Task_Kind 1897 and then Nkind (Parent (E)) in 1898 N_Single_Task_Declaration | N_Task_Type_Declaration 1899 then 1900 Push_Scope (E); 1901 Freeze_All (First_Entity (E), After); 1902 End_Scope; 1903 1904 -- For a derived tagged type, we must ensure that all the 1905 -- primitive operations of the parent have been frozen, so that 1906 -- their addresses will be in the parent's dispatch table at the 1907 -- point it is inherited. 1908 1909 elsif Ekind (E) = E_Record_Type 1910 and then Is_Tagged_Type (E) 1911 and then Is_Tagged_Type (Etype (E)) 1912 and then Is_Derived_Type (E) 1913 then 1914 declare 1915 Prim_List : constant Elist_Id := 1916 Primitive_Operations (Etype (E)); 1917 1918 Prim : Elmt_Id; 1919 Subp : Entity_Id; 1920 1921 begin 1922 Prim := First_Elmt (Prim_List); 1923 while Present (Prim) loop 1924 Subp := Node (Prim); 1925 1926 if Comes_From_Source (Subp) 1927 and then not Is_Frozen (Subp) 1928 then 1929 Flist := Freeze_Entity (Subp, After); 1930 Process_Flist; 1931 end if; 1932 1933 Next_Elmt (Prim); 1934 end loop; 1935 end; 1936 end if; 1937 1938 if not Is_Frozen (E) then 1939 Flist := Freeze_Entity (E, After); 1940 Process_Flist; 1941 1942 -- If already frozen, and there are delayed aspects, this is where 1943 -- we do the visibility check for these aspects (see Sem_Ch13 spec 1944 -- for a description of how we handle aspect visibility). 1945 1946 elsif Has_Delayed_Aspects (E) then 1947 declare 1948 Ritem : Node_Id; 1949 1950 begin 1951 Ritem := First_Rep_Item (E); 1952 while Present (Ritem) loop 1953 if Nkind (Ritem) = N_Aspect_Specification 1954 and then Entity (Ritem) = E 1955 and then Is_Delayed_Aspect (Ritem) 1956 then 1957 Check_Aspect_At_End_Of_Declarations (Ritem); 1958 end if; 1959 1960 Next_Rep_Item (Ritem); 1961 end loop; 1962 end; 1963 end if; 1964 1965 -- If an incomplete type is still not frozen, this may be a 1966 -- premature freezing because of a body declaration that follows. 1967 -- Indicate where the freezing took place. Freezing will happen 1968 -- if the body comes from source, but not if it is internally 1969 -- generated, for example as the body of a type invariant. 1970 1971 -- If the freezing is caused by the end of the current declarative 1972 -- part, it is a Taft Amendment type, and there is no error. 1973 1974 if not Is_Frozen (E) 1975 and then Ekind (E) = E_Incomplete_Type 1976 then 1977 declare 1978 Bod : constant Node_Id := Next (After); 1979 1980 begin 1981 -- The presence of a body freezes all entities previously 1982 -- declared in the current list of declarations, but this 1983 -- does not apply if the body does not come from source. 1984 -- A type invariant is transformed into a subprogram body 1985 -- which is placed at the end of the private part of the 1986 -- current package, but this body does not freeze incomplete 1987 -- types that may be declared in this private part. 1988 1989 if Comes_From_Source (Bod) 1990 and then Nkind (Bod) in N_Entry_Body 1991 | N_Package_Body 1992 | N_Protected_Body 1993 | N_Subprogram_Body 1994 | N_Task_Body 1995 | N_Body_Stub 1996 and then 1997 In_Same_List (After, Parent (E)) 1998 then 1999 Error_Msg_Sloc := Sloc (Next (After)); 2000 Error_Msg_NE 2001 ("type& is frozen# before its full declaration", 2002 Parent (E), E); 2003 end if; 2004 end; 2005 end if; 2006 2007 Next_Entity (E); 2008 end loop; 2009 end Freeze_All_Ent; 2010 2011 -- Local variables 2012 2013 Decl : Node_Id; 2014 E : Entity_Id; 2015 Item : Entity_Id; 2016 2017 -- Start of processing for Freeze_All 2018 2019 begin 2020 Freeze_All_Ent (From, After); 2021 2022 -- Now that all types are frozen, we can deal with default expressions 2023 -- that require us to build a default expression functions. This is the 2024 -- point at which such functions are constructed (after all types that 2025 -- might be used in such expressions have been frozen). 2026 2027 -- For subprograms that are renaming_as_body, we create the wrapper 2028 -- bodies as needed. 2029 2030 -- We also add finalization chains to access types whose designated 2031 -- types are controlled. This is normally done when freezing the type, 2032 -- but this misses recursive type definitions where the later members 2033 -- of the recursion introduce controlled components. 2034 2035 -- Loop through entities 2036 2037 E := From; 2038 while Present (E) loop 2039 if Is_Subprogram (E) then 2040 if not Default_Expressions_Processed (E) then 2041 Process_Default_Expressions (E, After); 2042 end if; 2043 2044 if not Has_Completion (E) then 2045 Decl := Unit_Declaration_Node (E); 2046 2047 if Nkind (Decl) = N_Subprogram_Renaming_Declaration then 2048 if Error_Posted (Decl) then 2049 Set_Has_Completion (E); 2050 else 2051 Build_And_Analyze_Renamed_Body (Decl, E, After); 2052 end if; 2053 2054 elsif Nkind (Decl) = N_Subprogram_Declaration 2055 and then Present (Corresponding_Body (Decl)) 2056 and then 2057 Nkind (Unit_Declaration_Node (Corresponding_Body (Decl))) = 2058 N_Subprogram_Renaming_Declaration 2059 then 2060 Build_And_Analyze_Renamed_Body 2061 (Decl, Corresponding_Body (Decl), After); 2062 end if; 2063 end if; 2064 2065 -- Freeze the default expressions of entries, entry families, and 2066 -- protected subprograms. 2067 2068 elsif Is_Concurrent_Type (E) then 2069 Item := First_Entity (E); 2070 while Present (Item) loop 2071 if (Is_Entry (Item) or else Is_Subprogram (Item)) 2072 and then not Default_Expressions_Processed (Item) 2073 then 2074 Process_Default_Expressions (Item, After); 2075 end if; 2076 2077 Next_Entity (Item); 2078 end loop; 2079 end if; 2080 2081 -- Historical note: We used to create a finalization master for an 2082 -- access type whose designated type is not controlled, but contains 2083 -- private controlled compoments. This form of postprocessing is no 2084 -- longer needed because the finalization master is now created when 2085 -- the access type is frozen (see Exp_Ch3.Freeze_Type). 2086 2087 Next_Entity (E); 2088 end loop; 2089 end Freeze_All; 2090 2091 ----------------------- 2092 -- Freeze_And_Append -- 2093 ----------------------- 2094 2095 procedure Freeze_And_Append 2096 (Ent : Entity_Id; 2097 N : Node_Id; 2098 Result : in out List_Id) 2099 is 2100 L : constant List_Id := Freeze_Entity (Ent, N); 2101 begin 2102 if Is_Non_Empty_List (L) then 2103 if Result = No_List then 2104 Result := L; 2105 else 2106 Append_List (L, Result); 2107 end if; 2108 end if; 2109 end Freeze_And_Append; 2110 2111 ------------------- 2112 -- Freeze_Before -- 2113 ------------------- 2114 2115 procedure Freeze_Before 2116 (N : Node_Id; 2117 T : Entity_Id; 2118 Do_Freeze_Profile : Boolean := True) 2119 is 2120 -- Freeze T, then insert the generated Freeze nodes before the node N. 2121 -- Flag Freeze_Profile is used when T is an overloadable entity, and 2122 -- indicates whether its profile should be frozen at the same time. 2123 2124 Freeze_Nodes : constant List_Id := 2125 Freeze_Entity (T, N, Do_Freeze_Profile); 2126 Pack : constant Entity_Id := Scope (T); 2127 2128 begin 2129 if Ekind (T) = E_Function then 2130 Check_Expression_Function (N, T); 2131 end if; 2132 2133 if Is_Non_Empty_List (Freeze_Nodes) then 2134 2135 -- If the entity is a type declared in an inner package, it may be 2136 -- frozen by an outer declaration before the package itself is 2137 -- frozen. Install the package scope to analyze the freeze nodes, 2138 -- which may include generated subprograms such as predicate 2139 -- functions, etc. 2140 2141 if Is_Type (T) and then From_Nested_Package (T) then 2142 Push_Scope (Pack); 2143 Install_Visible_Declarations (Pack); 2144 Install_Private_Declarations (Pack); 2145 Insert_Actions (N, Freeze_Nodes); 2146 End_Package_Scope (Pack); 2147 2148 else 2149 Insert_Actions (N, Freeze_Nodes); 2150 end if; 2151 end if; 2152 end Freeze_Before; 2153 2154 ------------------- 2155 -- Freeze_Entity -- 2156 ------------------- 2157 2158 -- WARNING: This routine manages Ghost regions. Return statements must be 2159 -- replaced by gotos which jump to the end of the routine and restore the 2160 -- Ghost mode. 2161 2162 function Freeze_Entity 2163 (E : Entity_Id; 2164 N : Node_Id; 2165 Do_Freeze_Profile : Boolean := True) return List_Id 2166 is 2167 Loc : constant Source_Ptr := Sloc (N); 2168 2169 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode; 2170 Saved_IGR : constant Node_Id := Ignored_Ghost_Region; 2171 -- Save the Ghost-related attributes to restore on exit 2172 2173 Atype : Entity_Id; 2174 Comp : Entity_Id; 2175 F_Node : Node_Id; 2176 Formal : Entity_Id; 2177 Indx : Node_Id; 2178 2179 Result : List_Id := No_List; 2180 -- List of freezing actions, left at No_List if none 2181 2182 Test_E : Entity_Id := E; 2183 -- This could use a comment ??? 2184 2185 procedure Add_To_Result (Fnod : Node_Id); 2186 -- Add freeze action Fnod to list Result 2187 2188 function After_Last_Declaration return Boolean; 2189 -- If Loc is a freeze_entity that appears after the last declaration 2190 -- in the scope, inhibit error messages on late completion. 2191 2192 procedure Check_Current_Instance (Comp_Decl : Node_Id); 2193 -- Check that an Access or Unchecked_Access attribute with a prefix 2194 -- which is the current instance type can only be applied when the type 2195 -- is limited. 2196 2197 procedure Check_Suspicious_Convention (Rec_Type : Entity_Id); 2198 -- Give a warning for pragma Convention with language C or C++ applied 2199 -- to a discriminated record type. This is suppressed for the unchecked 2200 -- union case, since the whole point in this case is interface C. We 2201 -- also do not generate this within instantiations, since we will have 2202 -- generated a message on the template. 2203 2204 procedure Check_Suspicious_Modulus (Utype : Entity_Id); 2205 -- Give warning for modulus of 8, 16, 32, 64 or 128 given as an explicit 2206 -- integer literal without an explicit corresponding size clause. The 2207 -- caller has checked that Utype is a modular integer type. 2208 2209 procedure Freeze_Array_Type (Arr : Entity_Id); 2210 -- Freeze array type, including freezing index and component types 2211 2212 procedure Freeze_Object_Declaration (E : Entity_Id); 2213 -- Perform checks and generate freeze node if needed for a constant or 2214 -- variable declared by an object declaration. 2215 2216 function Freeze_Generic_Entities (Pack : Entity_Id) return List_Id; 2217 -- Create Freeze_Generic_Entity nodes for types declared in a generic 2218 -- package. Recurse on inner generic packages. 2219 2220 function Freeze_Profile (E : Entity_Id) return Boolean; 2221 -- Freeze formals and return type of subprogram. If some type in the 2222 -- profile is incomplete and we are in an instance, freezing of the 2223 -- entity will take place elsewhere, and the function returns False. 2224 2225 procedure Freeze_Record_Type (Rec : Entity_Id); 2226 -- Freeze record type, including freezing component types, and freezing 2227 -- primitive operations if this is a tagged type. 2228 2229 function Has_Boolean_Aspect_Import (E : Entity_Id) return Boolean; 2230 -- Determine whether an arbitrary entity is subject to Boolean aspect 2231 -- Import and its value is specified as True. 2232 2233 procedure Inherit_Freeze_Node 2234 (Fnod : Node_Id; 2235 Typ : Entity_Id); 2236 -- Set type Typ's freeze node to refer to Fnode. This routine ensures 2237 -- that any attributes attached to Typ's original node are preserved. 2238 2239 procedure Wrap_Imported_Subprogram (E : Entity_Id); 2240 -- If E is an entity for an imported subprogram with pre/post-conditions 2241 -- then this procedure will create a wrapper to ensure that proper run- 2242 -- time checking of the pre/postconditions. See body for details. 2243 2244 ------------------- 2245 -- Add_To_Result -- 2246 ------------------- 2247 2248 procedure Add_To_Result (Fnod : Node_Id) is 2249 begin 2250 Append_New_To (Result, Fnod); 2251 end Add_To_Result; 2252 2253 ---------------------------- 2254 -- After_Last_Declaration -- 2255 ---------------------------- 2256 2257 function After_Last_Declaration return Boolean is 2258 Spec : constant Node_Id := Parent (Current_Scope); 2259 2260 begin 2261 if Nkind (Spec) = N_Package_Specification then 2262 if Present (Private_Declarations (Spec)) then 2263 return Loc >= Sloc (Last (Private_Declarations (Spec))); 2264 elsif Present (Visible_Declarations (Spec)) then 2265 return Loc >= Sloc (Last (Visible_Declarations (Spec))); 2266 else 2267 return False; 2268 end if; 2269 2270 else 2271 return False; 2272 end if; 2273 end After_Last_Declaration; 2274 2275 ---------------------------- 2276 -- Check_Current_Instance -- 2277 ---------------------------- 2278 2279 procedure Check_Current_Instance (Comp_Decl : Node_Id) is 2280 2281 function Is_Aliased_View_Of_Type (Typ : Entity_Id) return Boolean; 2282 -- Determine whether Typ is compatible with the rules for aliased 2283 -- views of types as defined in RM 3.10 in the various dialects. 2284 2285 function Process (N : Node_Id) return Traverse_Result; 2286 -- Process routine to apply check to given node 2287 2288 ----------------------------- 2289 -- Is_Aliased_View_Of_Type -- 2290 ----------------------------- 2291 2292 function Is_Aliased_View_Of_Type (Typ : Entity_Id) return Boolean is 2293 Typ_Decl : constant Node_Id := Parent (Typ); 2294 2295 begin 2296 -- Common case 2297 2298 if Nkind (Typ_Decl) = N_Full_Type_Declaration 2299 and then Limited_Present (Type_Definition (Typ_Decl)) 2300 then 2301 return True; 2302 2303 -- The following paragraphs describe what a legal aliased view of 2304 -- a type is in the various dialects of Ada. 2305 2306 -- Ada 95 2307 2308 -- The current instance of a limited type, and a formal parameter 2309 -- or generic formal object of a tagged type. 2310 2311 -- Ada 95 limited type 2312 -- * Type with reserved word "limited" 2313 -- * A protected or task type 2314 -- * A composite type with limited component 2315 2316 elsif Ada_Version <= Ada_95 then 2317 return Is_Limited_Type (Typ); 2318 2319 -- Ada 2005 2320 2321 -- The current instance of a limited tagged type, a protected 2322 -- type, a task type, or a type that has the reserved word 2323 -- "limited" in its full definition ... a formal parameter or 2324 -- generic formal object of a tagged type. 2325 2326 -- Ada 2005 limited type 2327 -- * Type with reserved word "limited", "synchronized", "task" 2328 -- or "protected" 2329 -- * A composite type with limited component 2330 -- * A derived type whose parent is a non-interface limited type 2331 2332 elsif Ada_Version = Ada_2005 then 2333 return 2334 (Is_Limited_Type (Typ) and then Is_Tagged_Type (Typ)) 2335 or else 2336 (Is_Derived_Type (Typ) 2337 and then not Is_Interface (Etype (Typ)) 2338 and then Is_Limited_Type (Etype (Typ))); 2339 2340 -- Ada 2012 and beyond 2341 2342 -- The current instance of an immutably limited type ... a formal 2343 -- parameter or generic formal object of a tagged type. 2344 2345 -- Ada 2012 limited type 2346 -- * Type with reserved word "limited", "synchronized", "task" 2347 -- or "protected" 2348 -- * A composite type with limited component 2349 -- * A derived type whose parent is a non-interface limited type 2350 -- * An incomplete view 2351 2352 -- Ada 2012 immutably limited type 2353 -- * Explicitly limited record type 2354 -- * Record extension with "limited" present 2355 -- * Non-formal limited private type that is either tagged 2356 -- or has at least one access discriminant with a default 2357 -- expression 2358 -- * Task type, protected type or synchronized interface 2359 -- * Type derived from immutably limited type 2360 2361 else 2362 return 2363 Is_Immutably_Limited_Type (Typ) 2364 or else Is_Incomplete_Type (Typ); 2365 end if; 2366 end Is_Aliased_View_Of_Type; 2367 2368 ------------- 2369 -- Process -- 2370 ------------- 2371 2372 function Process (N : Node_Id) return Traverse_Result is 2373 begin 2374 case Nkind (N) is 2375 when N_Attribute_Reference => 2376 if Attribute_Name (N) in Name_Access | Name_Unchecked_Access 2377 and then Is_Entity_Name (Prefix (N)) 2378 and then Is_Type (Entity (Prefix (N))) 2379 and then Entity (Prefix (N)) = E 2380 then 2381 if Ada_Version < Ada_2012 then 2382 Error_Msg_N 2383 ("current instance must be a limited type", 2384 Prefix (N)); 2385 else 2386 Error_Msg_N 2387 ("current instance must be an immutably limited " 2388 & "type (RM-2012, 7.5 (8.1/3))", Prefix (N)); 2389 end if; 2390 2391 return Abandon; 2392 2393 else 2394 return OK; 2395 end if; 2396 2397 when others => 2398 return OK; 2399 end case; 2400 end Process; 2401 2402 procedure Traverse is new Traverse_Proc (Process); 2403 2404 -- Local variables 2405 2406 Rec_Type : constant Entity_Id := 2407 Scope (Defining_Identifier (Comp_Decl)); 2408 2409 -- Start of processing for Check_Current_Instance 2410 2411 begin 2412 if not Is_Aliased_View_Of_Type (Rec_Type) then 2413 Traverse (Comp_Decl); 2414 end if; 2415 end Check_Current_Instance; 2416 2417 --------------------------------- 2418 -- Check_Suspicious_Convention -- 2419 --------------------------------- 2420 2421 procedure Check_Suspicious_Convention (Rec_Type : Entity_Id) is 2422 begin 2423 if Has_Discriminants (Rec_Type) 2424 and then Is_Base_Type (Rec_Type) 2425 and then not Is_Unchecked_Union (Rec_Type) 2426 and then (Convention (Rec_Type) = Convention_C 2427 or else 2428 Convention (Rec_Type) = Convention_CPP) 2429 and then Comes_From_Source (Rec_Type) 2430 and then not In_Instance 2431 and then not Has_Warnings_Off (Rec_Type) 2432 then 2433 declare 2434 Cprag : constant Node_Id := 2435 Get_Rep_Pragma (Rec_Type, Name_Convention); 2436 A2 : Node_Id; 2437 2438 begin 2439 if Present (Cprag) then 2440 A2 := Next (First (Pragma_Argument_Associations (Cprag))); 2441 2442 if Convention (Rec_Type) = Convention_C then 2443 Error_Msg_N 2444 ("?x?discriminated record has no direct equivalent in " 2445 & "C", A2); 2446 else 2447 Error_Msg_N 2448 ("?x?discriminated record has no direct equivalent in " 2449 & "C++", A2); 2450 end if; 2451 2452 Error_Msg_NE 2453 ("\?x?use of convention for type& is dubious", 2454 A2, Rec_Type); 2455 end if; 2456 end; 2457 end if; 2458 end Check_Suspicious_Convention; 2459 2460 ------------------------------ 2461 -- Check_Suspicious_Modulus -- 2462 ------------------------------ 2463 2464 procedure Check_Suspicious_Modulus (Utype : Entity_Id) is 2465 Decl : constant Node_Id := Declaration_Node (Underlying_Type (Utype)); 2466 2467 begin 2468 if not Warn_On_Suspicious_Modulus_Value then 2469 return; 2470 end if; 2471 2472 if Nkind (Decl) = N_Full_Type_Declaration then 2473 declare 2474 Tdef : constant Node_Id := Type_Definition (Decl); 2475 2476 begin 2477 if Nkind (Tdef) = N_Modular_Type_Definition then 2478 declare 2479 Modulus : constant Node_Id := 2480 Original_Node (Expression (Tdef)); 2481 2482 begin 2483 if Nkind (Modulus) = N_Integer_Literal then 2484 declare 2485 Modv : constant Uint := Intval (Modulus); 2486 Sizv : constant Uint := RM_Size (Utype); 2487 2488 begin 2489 -- First case, modulus and size are the same. This 2490 -- happens if you have something like mod 32, with 2491 -- an explicit size of 32, this is for sure a case 2492 -- where the warning is given, since it is seems 2493 -- very unlikely that someone would want e.g. a 2494 -- five bit type stored in 32 bits. It is much 2495 -- more likely they wanted a 32-bit type. 2496 2497 if Modv = Sizv then 2498 null; 2499 2500 -- Second case, the modulus is 32 or 64 and no 2501 -- size clause is present. This is a less clear 2502 -- case for giving the warning, but in the case 2503 -- of 32/64 (5-bit or 6-bit types) these seem rare 2504 -- enough that it is a likely error (and in any 2505 -- case using 2**5 or 2**6 in these cases seems 2506 -- clearer. We don't include 8 or 16 here, simply 2507 -- because in practice 3-bit and 4-bit types are 2508 -- more common and too many false positives if 2509 -- we warn in these cases. 2510 2511 elsif not Has_Size_Clause (Utype) 2512 and then (Modv = Uint_32 or else Modv = Uint_64) 2513 then 2514 null; 2515 2516 -- No warning needed 2517 2518 else 2519 return; 2520 end if; 2521 2522 -- If we fall through, give warning 2523 2524 Error_Msg_Uint_1 := Modv; 2525 Error_Msg_N 2526 ("?M?2 '*'*^' may have been intended here", 2527 Modulus); 2528 end; 2529 end if; 2530 end; 2531 end if; 2532 end; 2533 end if; 2534 end Check_Suspicious_Modulus; 2535 2536 ----------------------- 2537 -- Freeze_Array_Type -- 2538 ----------------------- 2539 2540 procedure Freeze_Array_Type (Arr : Entity_Id) is 2541 FS : constant Entity_Id := First_Subtype (Arr); 2542 Ctyp : constant Entity_Id := Component_Type (Arr); 2543 Clause : Entity_Id; 2544 2545 Non_Standard_Enum : Boolean := False; 2546 -- Set true if any of the index types is an enumeration type with a 2547 -- non-standard representation. 2548 2549 begin 2550 Freeze_And_Append (Ctyp, N, Result); 2551 2552 Indx := First_Index (Arr); 2553 while Present (Indx) loop 2554 Freeze_And_Append (Etype (Indx), N, Result); 2555 2556 if Is_Enumeration_Type (Etype (Indx)) 2557 and then Has_Non_Standard_Rep (Etype (Indx)) 2558 then 2559 Non_Standard_Enum := True; 2560 end if; 2561 2562 Next_Index (Indx); 2563 end loop; 2564 2565 -- Processing that is done only for base types 2566 2567 if Ekind (Arr) = E_Array_Type then 2568 2569 -- Deal with default setting of reverse storage order 2570 2571 Set_SSO_From_Default (Arr); 2572 2573 -- Propagate flags for component type 2574 2575 if Is_Controlled (Ctyp) 2576 or else Has_Controlled_Component (Ctyp) 2577 then 2578 Set_Has_Controlled_Component (Arr); 2579 end if; 2580 2581 if Has_Unchecked_Union (Ctyp) then 2582 Set_Has_Unchecked_Union (Arr); 2583 end if; 2584 2585 -- The array type requires its own invariant procedure in order to 2586 -- verify the component invariant over all elements. In GNATprove 2587 -- mode, the component invariants are checked by other means. They 2588 -- should not be added to the array type invariant procedure, so 2589 -- that the procedure can be used to check the array type 2590 -- invariants if any. 2591 2592 if Has_Invariants (Ctyp) 2593 and then not GNATprove_Mode 2594 then 2595 Set_Has_Own_Invariants (Arr); 2596 end if; 2597 2598 -- Warn for pragma Pack overriding foreign convention 2599 2600 if Has_Foreign_Convention (Ctyp) 2601 and then Has_Pragma_Pack (Arr) 2602 then 2603 declare 2604 CN : constant Name_Id := 2605 Get_Convention_Name (Convention (Ctyp)); 2606 PP : constant Node_Id := 2607 Get_Pragma (First_Subtype (Arr), Pragma_Pack); 2608 begin 2609 if Present (PP) then 2610 Error_Msg_Name_1 := CN; 2611 Error_Msg_Sloc := Sloc (Arr); 2612 Error_Msg_N 2613 ("pragma Pack affects convention % components #??", PP); 2614 Error_Msg_Name_1 := CN; 2615 Error_Msg_N 2616 ("\array components may not have % compatible " 2617 & "representation??", PP); 2618 end if; 2619 end; 2620 end if; 2621 2622 -- Check for Aliased or Atomic_Components or Full Access with 2623 -- unsuitable packing or explicit component size clause given. 2624 2625 if (Has_Aliased_Components (Arr) 2626 or else Has_Atomic_Components (Arr) 2627 or else Is_Full_Access (Ctyp)) 2628 and then 2629 (Has_Component_Size_Clause (Arr) or else Is_Packed (Arr)) 2630 then 2631 Alias_Atomic_Check : declare 2632 2633 procedure Complain_CS (T : String); 2634 -- Outputs error messages for incorrect CS clause or pragma 2635 -- Pack for aliased or full access components (T is either 2636 -- "aliased" or "atomic" or "volatile full access"); 2637 2638 ----------------- 2639 -- Complain_CS -- 2640 ----------------- 2641 2642 procedure Complain_CS (T : String) is 2643 begin 2644 if Has_Component_Size_Clause (Arr) then 2645 Clause := 2646 Get_Attribute_Definition_Clause 2647 (FS, Attribute_Component_Size); 2648 2649 Error_Msg_N 2650 ("incorrect component size for " 2651 & T & " components", Clause); 2652 Error_Msg_Uint_1 := Esize (Ctyp); 2653 Error_Msg_N 2654 ("\only allowed value is^", Clause); 2655 2656 else 2657 Error_Msg_N 2658 ("?cannot pack " & T & " components (RM 13.2(7))", 2659 Get_Rep_Pragma (FS, Name_Pack)); 2660 Set_Is_Packed (Arr, False); 2661 end if; 2662 end Complain_CS; 2663 2664 -- Start of processing for Alias_Atomic_Check 2665 2666 begin 2667 -- If object size of component type isn't known, we cannot 2668 -- be sure so we defer to the back end. 2669 2670 if not Known_Static_Esize (Ctyp) then 2671 null; 2672 2673 -- Case where component size has no effect. First check for 2674 -- object size of component type multiple of the storage 2675 -- unit size. 2676 2677 elsif Esize (Ctyp) mod System_Storage_Unit = 0 2678 2679 -- OK in both packing case and component size case if RM 2680 -- size is known and static and same as the object size. 2681 2682 and then 2683 ((Known_Static_RM_Size (Ctyp) 2684 and then Esize (Ctyp) = RM_Size (Ctyp)) 2685 2686 -- Or if we have an explicit component size clause and 2687 -- the component size and object size are equal. 2688 2689 or else 2690 (Has_Component_Size_Clause (Arr) 2691 and then Component_Size (Arr) = Esize (Ctyp))) 2692 then 2693 null; 2694 2695 elsif Has_Aliased_Components (Arr) then 2696 Complain_CS ("aliased"); 2697 2698 elsif Has_Atomic_Components (Arr) 2699 or else Is_Atomic (Ctyp) 2700 then 2701 Complain_CS ("atomic"); 2702 2703 elsif Is_Volatile_Full_Access (Ctyp) then 2704 Complain_CS ("volatile full access"); 2705 end if; 2706 end Alias_Atomic_Check; 2707 end if; 2708 2709 -- Check for Independent_Components/Independent with unsuitable 2710 -- packing or explicit component size clause given. 2711 2712 if (Has_Independent_Components (Arr) or else Is_Independent (Ctyp)) 2713 and then 2714 (Has_Component_Size_Clause (Arr) or else Is_Packed (Arr)) 2715 then 2716 begin 2717 -- If object size of component type isn't known, we cannot 2718 -- be sure so we defer to the back end. 2719 2720 if not Known_Static_Esize (Ctyp) then 2721 null; 2722 2723 -- Case where component size has no effect. First check for 2724 -- object size of component type multiple of the storage 2725 -- unit size. 2726 2727 elsif Esize (Ctyp) mod System_Storage_Unit = 0 2728 2729 -- OK in both packing case and component size case if RM 2730 -- size is known and multiple of the storage unit size. 2731 2732 and then 2733 ((Known_Static_RM_Size (Ctyp) 2734 and then RM_Size (Ctyp) mod System_Storage_Unit = 0) 2735 2736 -- Or if we have an explicit component size clause and 2737 -- the component size is larger than the object size. 2738 2739 or else 2740 (Has_Component_Size_Clause (Arr) 2741 and then Component_Size (Arr) >= Esize (Ctyp))) 2742 then 2743 null; 2744 2745 else 2746 if Has_Component_Size_Clause (Arr) then 2747 Clause := 2748 Get_Attribute_Definition_Clause 2749 (FS, Attribute_Component_Size); 2750 2751 Error_Msg_N 2752 ("incorrect component size for " 2753 & "independent components", Clause); 2754 Error_Msg_Uint_1 := Esize (Ctyp); 2755 Error_Msg_N 2756 ("\minimum allowed is^", Clause); 2757 2758 else 2759 Error_Msg_N 2760 ("?cannot pack independent components (RM 13.2(7))", 2761 Get_Rep_Pragma (FS, Name_Pack)); 2762 Set_Is_Packed (Arr, False); 2763 end if; 2764 end if; 2765 end; 2766 end if; 2767 2768 -- If packing was requested or if the component size was 2769 -- set explicitly, then see if bit packing is required. This 2770 -- processing is only done for base types, since all of the 2771 -- representation aspects involved are type-related. 2772 2773 -- This is not just an optimization, if we start processing the 2774 -- subtypes, they interfere with the settings on the base type 2775 -- (this is because Is_Packed has a slightly different meaning 2776 -- before and after freezing). 2777 2778 declare 2779 Csiz : Uint; 2780 Esiz : Uint; 2781 2782 begin 2783 if Is_Packed (Arr) 2784 and then Known_Static_RM_Size (Ctyp) 2785 and then not Has_Component_Size_Clause (Arr) 2786 then 2787 Csiz := UI_Max (RM_Size (Ctyp), 1); 2788 2789 elsif Known_Component_Size (Arr) then 2790 Csiz := Component_Size (Arr); 2791 2792 elsif not Known_Static_Esize (Ctyp) then 2793 Csiz := Uint_0; 2794 2795 else 2796 Esiz := Esize (Ctyp); 2797 2798 -- We can set the component size if it is less than 16, 2799 -- rounding it up to the next storage unit size. 2800 2801 if Esiz <= 8 then 2802 Csiz := Uint_8; 2803 elsif Esiz <= 16 then 2804 Csiz := Uint_16; 2805 else 2806 Csiz := Uint_0; 2807 end if; 2808 2809 -- Set component size up to match alignment if it would 2810 -- otherwise be less than the alignment. This deals with 2811 -- cases of types whose alignment exceeds their size (the 2812 -- padded type cases). 2813 2814 if Csiz /= 0 then 2815 declare 2816 A : constant Uint := Alignment_In_Bits (Ctyp); 2817 begin 2818 if Csiz < A then 2819 Csiz := A; 2820 end if; 2821 end; 2822 end if; 2823 end if; 2824 2825 -- Case of component size that may result in bit packing 2826 2827 if 1 <= Csiz and then Csiz <= System_Max_Integer_Size then 2828 declare 2829 Ent : constant Entity_Id := 2830 First_Subtype (Arr); 2831 Pack_Pragma : constant Node_Id := 2832 Get_Rep_Pragma (Ent, Name_Pack); 2833 Comp_Size_C : constant Node_Id := 2834 Get_Attribute_Definition_Clause 2835 (Ent, Attribute_Component_Size); 2836 2837 begin 2838 -- Warn if we have pack and component size so that the 2839 -- pack is ignored. 2840 2841 -- Note: here we must check for the presence of a 2842 -- component size before checking for a Pack pragma to 2843 -- deal with the case where the array type is a derived 2844 -- type whose parent is currently private. 2845 2846 if Present (Comp_Size_C) 2847 and then Has_Pragma_Pack (Ent) 2848 and then Warn_On_Redundant_Constructs 2849 then 2850 Error_Msg_Sloc := Sloc (Comp_Size_C); 2851 Error_Msg_NE 2852 ("?r?pragma Pack for& ignored!", Pack_Pragma, Ent); 2853 Error_Msg_N 2854 ("\?r?explicit component size given#!", Pack_Pragma); 2855 Set_Is_Packed (Base_Type (Ent), False); 2856 Set_Is_Bit_Packed_Array (Base_Type (Ent), False); 2857 end if; 2858 2859 -- Set component size if not already set by a component 2860 -- size clause. 2861 2862 if not Present (Comp_Size_C) then 2863 Set_Component_Size (Arr, Csiz); 2864 end if; 2865 2866 -- Check for base type of 8, 16, 32 bits, where an 2867 -- unsigned subtype has a length one less than the 2868 -- base type (e.g. Natural subtype of Integer). 2869 2870 -- In such cases, if a component size was not set 2871 -- explicitly, then generate a warning. 2872 2873 if Has_Pragma_Pack (Arr) 2874 and then not Present (Comp_Size_C) 2875 and then (Csiz = 7 or else Csiz = 15 or else Csiz = 31) 2876 and then Esize (Base_Type (Ctyp)) = Csiz + 1 2877 then 2878 Error_Msg_Uint_1 := Csiz; 2879 2880 if Present (Pack_Pragma) then 2881 Error_Msg_N 2882 ("??pragma Pack causes component size to be ^!", 2883 Pack_Pragma); 2884 Error_Msg_N 2885 ("\??use Component_Size to set desired value!", 2886 Pack_Pragma); 2887 end if; 2888 end if; 2889 2890 -- Bit packing is never needed for 8, 16, 32, 64 or 128 2891 2892 if Addressable (Csiz) then 2893 2894 -- If the Esize of the component is known and equal to 2895 -- the component size then even packing is not needed. 2896 2897 if Known_Static_Esize (Ctyp) 2898 and then Esize (Ctyp) = Csiz 2899 then 2900 -- Here the array was requested to be packed, but 2901 -- the packing request had no effect whatsoever, 2902 -- so flag Is_Packed is reset. 2903 2904 -- Note: semantically this means that we lose track 2905 -- of the fact that a derived type inherited pragma 2906 -- Pack that was non-effective, but that is fine. 2907 2908 -- We regard a Pack pragma as a request to set a 2909 -- representation characteristic, and this request 2910 -- may be ignored. 2911 2912 Set_Is_Packed (Base_Type (Arr), False); 2913 Set_Has_Non_Standard_Rep (Base_Type (Arr), False); 2914 else 2915 Set_Is_Packed (Base_Type (Arr), True); 2916 Set_Has_Non_Standard_Rep (Base_Type (Arr), True); 2917 end if; 2918 2919 Set_Is_Bit_Packed_Array (Base_Type (Arr), False); 2920 2921 -- Bit packing is not needed for multiples of the storage 2922 -- unit if the type is composite because the back end can 2923 -- byte pack composite types efficiently. That's not true 2924 -- for discrete types because every read would generate a 2925 -- lot of instructions, so we keep using the manipulation 2926 -- routines of the runtime for them. 2927 2928 elsif Csiz mod System_Storage_Unit = 0 2929 and then Is_Composite_Type (Ctyp) 2930 then 2931 Set_Is_Packed (Base_Type (Arr), True); 2932 Set_Has_Non_Standard_Rep (Base_Type (Arr), True); 2933 Set_Is_Bit_Packed_Array (Base_Type (Arr), False); 2934 2935 -- In all other cases, bit packing is needed 2936 2937 else 2938 Set_Is_Packed (Base_Type (Arr), True); 2939 Set_Has_Non_Standard_Rep (Base_Type (Arr), True); 2940 Set_Is_Bit_Packed_Array (Base_Type (Arr), True); 2941 end if; 2942 end; 2943 end if; 2944 end; 2945 2946 -- Warn for case of atomic type 2947 2948 Clause := Get_Rep_Pragma (FS, Name_Atomic); 2949 2950 if Present (Clause) 2951 and then not Addressable (Component_Size (FS)) 2952 then 2953 Error_Msg_NE 2954 ("non-atomic components of type& may not be " 2955 & "accessible by separate tasks??", Clause, Arr); 2956 2957 if Has_Component_Size_Clause (Arr) then 2958 Error_Msg_Sloc := Sloc (Get_Attribute_Definition_Clause 2959 (FS, Attribute_Component_Size)); 2960 Error_Msg_N ("\because of component size clause#??", Clause); 2961 2962 elsif Has_Pragma_Pack (Arr) then 2963 Error_Msg_Sloc := Sloc (Get_Rep_Pragma (FS, Name_Pack)); 2964 Error_Msg_N ("\because of pragma Pack#??", Clause); 2965 end if; 2966 end if; 2967 2968 -- Check for scalar storage order 2969 2970 declare 2971 Dummy : Boolean; 2972 begin 2973 Check_Component_Storage_Order 2974 (Encl_Type => Arr, 2975 Comp => Empty, 2976 ADC => Get_Attribute_Definition_Clause 2977 (First_Subtype (Arr), 2978 Attribute_Scalar_Storage_Order), 2979 Comp_ADC_Present => Dummy); 2980 end; 2981 2982 -- Processing that is done only for subtypes 2983 2984 else 2985 -- Acquire alignment from base type 2986 2987 if Unknown_Alignment (Arr) then 2988 Set_Alignment (Arr, Alignment (Base_Type (Arr))); 2989 Adjust_Esize_Alignment (Arr); 2990 end if; 2991 end if; 2992 2993 -- Specific checks for bit-packed arrays 2994 2995 if Is_Bit_Packed_Array (Arr) then 2996 2997 -- Check number of elements for bit-packed arrays that come from 2998 -- source and have compile time known ranges. The bit-packed 2999 -- arrays circuitry does not support arrays with more than 3000 -- Integer'Last + 1 elements, and when this restriction is 3001 -- violated, causes incorrect data access. 3002 3003 -- For the case where this is not compile time known, a run-time 3004 -- check should be generated??? 3005 3006 if Comes_From_Source (Arr) and then Is_Constrained (Arr) then 3007 declare 3008 Elmts : Uint; 3009 Index : Node_Id; 3010 Ilen : Node_Id; 3011 Ityp : Entity_Id; 3012 3013 begin 3014 Elmts := Uint_1; 3015 Index := First_Index (Arr); 3016 while Present (Index) loop 3017 Ityp := Etype (Index); 3018 3019 -- Never generate an error if any index is of a generic 3020 -- type. We will check this in instances. 3021 3022 if Is_Generic_Type (Ityp) then 3023 Elmts := Uint_0; 3024 exit; 3025 end if; 3026 3027 Ilen := 3028 Make_Attribute_Reference (Loc, 3029 Prefix => New_Occurrence_Of (Ityp, Loc), 3030 Attribute_Name => Name_Range_Length); 3031 Analyze_And_Resolve (Ilen); 3032 3033 -- No attempt is made to check number of elements if not 3034 -- compile time known. 3035 3036 if Nkind (Ilen) /= N_Integer_Literal then 3037 Elmts := Uint_0; 3038 exit; 3039 end if; 3040 3041 Elmts := Elmts * Intval (Ilen); 3042 Next_Index (Index); 3043 end loop; 3044 3045 if Elmts > Intval (High_Bound 3046 (Scalar_Range (Standard_Integer))) + 1 3047 then 3048 Error_Msg_N 3049 ("bit packed array type may not have " 3050 & "more than Integer''Last+1 elements", Arr); 3051 end if; 3052 end; 3053 end if; 3054 3055 -- Check size 3056 3057 if Known_RM_Size (Arr) then 3058 declare 3059 SizC : constant Node_Id := Size_Clause (Arr); 3060 Discard : Boolean; 3061 3062 begin 3063 -- It is not clear if it is possible to have no size clause 3064 -- at this stage, but it is not worth worrying about. Post 3065 -- error on the entity name in the size clause if present, 3066 -- else on the type entity itself. 3067 3068 if Present (SizC) then 3069 Check_Size (Name (SizC), Arr, RM_Size (Arr), Discard); 3070 else 3071 Check_Size (Arr, Arr, RM_Size (Arr), Discard); 3072 end if; 3073 end; 3074 end if; 3075 end if; 3076 3077 -- If any of the index types was an enumeration type with a non- 3078 -- standard rep clause, then we indicate that the array type is 3079 -- always packed (even if it is not bit-packed). 3080 3081 if Non_Standard_Enum then 3082 Set_Has_Non_Standard_Rep (Base_Type (Arr)); 3083 Set_Is_Packed (Base_Type (Arr)); 3084 end if; 3085 3086 Set_Component_Alignment_If_Not_Set (Arr); 3087 3088 -- If the array is packed and bit-packed or packed to eliminate holes 3089 -- in the non-contiguous enumeration index types, we must create the 3090 -- packed array type to be used to actually implement the type. This 3091 -- is only needed for real array types (not for string literal types, 3092 -- since they are present only for the front end). 3093 3094 if Is_Packed (Arr) 3095 and then (Is_Bit_Packed_Array (Arr) or else Non_Standard_Enum) 3096 and then Ekind (Arr) /= E_String_Literal_Subtype 3097 then 3098 Create_Packed_Array_Impl_Type (Arr); 3099 Freeze_And_Append (Packed_Array_Impl_Type (Arr), N, Result); 3100 3101 -- Make sure that we have the necessary routines to implement the 3102 -- packing, and complain now if not. Note that we only test this 3103 -- for constrained array types. 3104 3105 if Is_Constrained (Arr) 3106 and then Is_Bit_Packed_Array (Arr) 3107 and then Present (Packed_Array_Impl_Type (Arr)) 3108 and then Is_Array_Type (Packed_Array_Impl_Type (Arr)) 3109 then 3110 declare 3111 CS : constant Uint := Component_Size (Arr); 3112 RE : constant RE_Id := Get_Id (UI_To_Int (CS)); 3113 3114 begin 3115 if RE /= RE_Null 3116 and then not RTE_Available (RE) 3117 then 3118 Error_Msg_CRT 3119 ("packing of " & UI_Image (CS) & "-bit components", 3120 First_Subtype (Etype (Arr))); 3121 3122 -- Cancel the packing 3123 3124 Set_Is_Packed (Base_Type (Arr), False); 3125 Set_Is_Bit_Packed_Array (Base_Type (Arr), False); 3126 Set_Packed_Array_Impl_Type (Arr, Empty); 3127 goto Skip_Packed; 3128 end if; 3129 end; 3130 end if; 3131 3132 -- Size information of packed array type is copied to the array 3133 -- type, since this is really the representation. But do not 3134 -- override explicit existing size values. If the ancestor subtype 3135 -- is constrained the Packed_Array_Impl_Type will be inherited 3136 -- from it, but the size may have been provided already, and 3137 -- must not be overridden either. 3138 3139 if not Has_Size_Clause (Arr) 3140 and then 3141 (No (Ancestor_Subtype (Arr)) 3142 or else not Has_Size_Clause (Ancestor_Subtype (Arr))) 3143 then 3144 Set_Esize (Arr, Esize (Packed_Array_Impl_Type (Arr))); 3145 Set_RM_Size (Arr, RM_Size (Packed_Array_Impl_Type (Arr))); 3146 end if; 3147 3148 if not Has_Alignment_Clause (Arr) then 3149 Set_Alignment (Arr, Alignment (Packed_Array_Impl_Type (Arr))); 3150 end if; 3151 end if; 3152 3153 <<Skip_Packed>> 3154 3155 -- A Ghost type cannot have a component of protected or task type 3156 -- (SPARK RM 6.9(19)). 3157 3158 if Is_Ghost_Entity (Arr) and then Is_Concurrent_Type (Ctyp) then 3159 Error_Msg_N 3160 ("ghost array type & cannot have concurrent component type", 3161 Arr); 3162 end if; 3163 end Freeze_Array_Type; 3164 3165 ------------------------------- 3166 -- Freeze_Object_Declaration -- 3167 ------------------------------- 3168 3169 procedure Freeze_Object_Declaration (E : Entity_Id) is 3170 procedure Check_Large_Modular_Array (Typ : Entity_Id); 3171 -- Check that the size of array type Typ can be computed without 3172 -- overflow, and generates a Storage_Error otherwise. This is only 3173 -- relevant for array types whose index has System_Max_Integer_Size 3174 -- bits, where wrap-around arithmetic might yield a meaningless value 3175 -- for the length of the array, or its corresponding attribute. 3176 3177 procedure Check_Pragma_Thread_Local_Storage (Var_Id : Entity_Id); 3178 -- Ensure that the initialization state of variable Var_Id subject 3179 -- to pragma Thread_Local_Storage agrees with the semantics of the 3180 -- pragma. 3181 3182 function Has_Default_Initialization 3183 (Obj_Id : Entity_Id) return Boolean; 3184 -- Determine whether object Obj_Id default initialized 3185 3186 ------------------------------- 3187 -- Check_Large_Modular_Array -- 3188 ------------------------------- 3189 3190 procedure Check_Large_Modular_Array (Typ : Entity_Id) is 3191 Obj_Loc : constant Source_Ptr := Sloc (E); 3192 Idx_Typ : Entity_Id; 3193 3194 begin 3195 -- Nothing to do when expansion is disabled because this routine 3196 -- generates a runtime check. 3197 3198 if not Expander_Active then 3199 return; 3200 3201 -- Nothing to do for String literal subtypes because their index 3202 -- cannot be a modular type. 3203 3204 elsif Ekind (Typ) = E_String_Literal_Subtype then 3205 return; 3206 3207 -- Nothing to do for an imported object because the object will 3208 -- be created on the exporting side. 3209 3210 elsif Is_Imported (E) then 3211 return; 3212 3213 -- Nothing to do for unconstrained array types. This case arises 3214 -- when the object declaration is illegal. 3215 3216 elsif not Is_Constrained (Typ) then 3217 return; 3218 end if; 3219 3220 Idx_Typ := Etype (First_Index (Typ)); 3221 3222 -- To prevent arithmetic overflow with large values, we raise 3223 -- Storage_Error under the following guard: 3224 -- 3225 -- (Arr'Last / 2 - Arr'First / 2) > (2 ** 30) 3226 -- 3227 -- This takes care of the boundary case, but it is preferable to 3228 -- use a smaller limit, because even on 64-bit architectures an 3229 -- array of more than 2 ** 30 bytes is likely to raise 3230 -- Storage_Error. 3231 3232 if Is_Modular_Integer_Type (Idx_Typ) 3233 and then RM_Size (Idx_Typ) = RM_Size (Standard_Long_Long_Integer) 3234 then 3235 Insert_Action (Declaration_Node (E), 3236 Make_Raise_Storage_Error (Obj_Loc, 3237 Condition => 3238 Make_Op_Ge (Obj_Loc, 3239 Left_Opnd => 3240 Make_Op_Subtract (Obj_Loc, 3241 Left_Opnd => 3242 Make_Op_Divide (Obj_Loc, 3243 Left_Opnd => 3244 Make_Attribute_Reference (Obj_Loc, 3245 Prefix => 3246 New_Occurrence_Of (Typ, Obj_Loc), 3247 Attribute_Name => Name_Last), 3248 Right_Opnd => 3249 Make_Integer_Literal (Obj_Loc, Uint_2)), 3250 Right_Opnd => 3251 Make_Op_Divide (Obj_Loc, 3252 Left_Opnd => 3253 Make_Attribute_Reference (Obj_Loc, 3254 Prefix => 3255 New_Occurrence_Of (Typ, Obj_Loc), 3256 Attribute_Name => Name_First), 3257 Right_Opnd => 3258 Make_Integer_Literal (Obj_Loc, Uint_2))), 3259 Right_Opnd => 3260 Make_Integer_Literal (Obj_Loc, (Uint_2 ** 30))), 3261 Reason => SE_Object_Too_Large)); 3262 end if; 3263 end Check_Large_Modular_Array; 3264 3265 --------------------------------------- 3266 -- Check_Pragma_Thread_Local_Storage -- 3267 --------------------------------------- 3268 3269 procedure Check_Pragma_Thread_Local_Storage (Var_Id : Entity_Id) is 3270 function Has_Incompatible_Initialization 3271 (Var_Decl : Node_Id) return Boolean; 3272 -- Determine whether variable Var_Id with declaration Var_Decl is 3273 -- initialized with a value that violates the semantics of pragma 3274 -- Thread_Local_Storage. 3275 3276 ------------------------------------- 3277 -- Has_Incompatible_Initialization -- 3278 ------------------------------------- 3279 3280 function Has_Incompatible_Initialization 3281 (Var_Decl : Node_Id) return Boolean 3282 is 3283 Init_Expr : constant Node_Id := Expression (Var_Decl); 3284 3285 begin 3286 -- The variable is default-initialized. This directly violates 3287 -- the semantics of the pragma. 3288 3289 if Has_Default_Initialization (Var_Id) then 3290 return True; 3291 3292 -- The variable has explicit initialization. In this case only 3293 -- a handful of values satisfy the semantics of the pragma. 3294 3295 elsif Has_Init_Expression (Var_Decl) 3296 and then Present (Init_Expr) 3297 then 3298 -- "null" is a legal form of initialization 3299 3300 if Nkind (Init_Expr) = N_Null then 3301 return False; 3302 3303 -- A static expression is a legal form of initialization 3304 3305 elsif Is_Static_Expression (Init_Expr) then 3306 return False; 3307 3308 -- A static aggregate is a legal form of initialization 3309 3310 elsif Nkind (Init_Expr) = N_Aggregate 3311 and then Compile_Time_Known_Aggregate (Init_Expr) 3312 then 3313 return False; 3314 3315 -- All other initialization expressions violate the semantic 3316 -- of the pragma. 3317 3318 else 3319 return True; 3320 end if; 3321 3322 -- The variable lacks any kind of initialization, which agrees 3323 -- with the semantics of the pragma. 3324 3325 else 3326 return False; 3327 end if; 3328 end Has_Incompatible_Initialization; 3329 3330 -- Local declarations 3331 3332 Var_Decl : constant Node_Id := Declaration_Node (Var_Id); 3333 3334 -- Start of processing for Check_Pragma_Thread_Local_Storage 3335 3336 begin 3337 -- A variable whose initialization is suppressed lacks any kind of 3338 -- initialization. 3339 3340 if Suppress_Initialization (Var_Id) then 3341 null; 3342 3343 -- The variable has default initialization, or is explicitly 3344 -- initialized to a value other than null, static expression, 3345 -- or a static aggregate. 3346 3347 elsif Has_Incompatible_Initialization (Var_Decl) then 3348 Error_Msg_NE 3349 ("Thread_Local_Storage variable& is improperly initialized", 3350 Var_Decl, Var_Id); 3351 Error_Msg_NE 3352 ("\only allowed initialization is explicit NULL, static " 3353 & "expression or static aggregate", Var_Decl, Var_Id); 3354 end if; 3355 end Check_Pragma_Thread_Local_Storage; 3356 3357 -------------------------------- 3358 -- Has_Default_Initialization -- 3359 -------------------------------- 3360 3361 function Has_Default_Initialization 3362 (Obj_Id : Entity_Id) return Boolean 3363 is 3364 Obj_Decl : constant Node_Id := Declaration_Node (Obj_Id); 3365 Obj_Typ : constant Entity_Id := Etype (Obj_Id); 3366 3367 begin 3368 return 3369 Comes_From_Source (Obj_Id) 3370 and then not Is_Imported (Obj_Id) 3371 and then not Has_Init_Expression (Obj_Decl) 3372 and then 3373 ((Has_Non_Null_Base_Init_Proc (Obj_Typ) 3374 and then not No_Initialization (Obj_Decl) 3375 and then not Initialization_Suppressed (Obj_Typ)) 3376 or else 3377 (Needs_Simple_Initialization (Obj_Typ) 3378 and then not Is_Internal (Obj_Id))); 3379 end Has_Default_Initialization; 3380 3381 -- Local variables 3382 3383 Typ : constant Entity_Id := Etype (E); 3384 Def : Node_Id; 3385 3386 -- Start of processing for Freeze_Object_Declaration 3387 3388 begin 3389 -- Abstract type allowed only for C++ imported variables or constants 3390 3391 -- Note: we inhibit this check for objects that do not come from 3392 -- source because there is at least one case (the expansion of 3393 -- x'Class'Input where x is abstract) where we legitimately 3394 -- generate an abstract object. 3395 3396 if Is_Abstract_Type (Typ) 3397 and then Comes_From_Source (Parent (E)) 3398 and then not (Is_Imported (E) and then Is_CPP_Class (Typ)) 3399 then 3400 Def := Object_Definition (Parent (E)); 3401 3402 Error_Msg_N ("type of object cannot be abstract", Def); 3403 3404 if Is_CPP_Class (Etype (E)) then 3405 Error_Msg_NE ("\} may need a cpp_constructor", Def, Typ); 3406 3407 elsif Present (Expression (Parent (E))) then 3408 Error_Msg_N -- CODEFIX 3409 ("\maybe a class-wide type was meant", Def); 3410 end if; 3411 end if; 3412 3413 -- For object created by object declaration, perform required 3414 -- categorization (preelaborate and pure) checks. Defer these 3415 -- checks to freeze time since pragma Import inhibits default 3416 -- initialization and thus pragma Import affects these checks. 3417 3418 Validate_Object_Declaration (Declaration_Node (E)); 3419 3420 -- If there is an address clause, check that it is valid and if need 3421 -- be move initialization to the freeze node. 3422 3423 Check_Address_Clause (E); 3424 3425 -- Similar processing is needed for aspects that may affect object 3426 -- layout, like Address, if there is an initialization expression. 3427 -- We don't do this if there is a pragma Linker_Section, because it 3428 -- would prevent the back end from statically initializing the 3429 -- object; we don't want elaboration code in that case. 3430 3431 if Has_Delayed_Aspects (E) 3432 and then Expander_Active 3433 and then Is_Array_Type (Typ) 3434 and then Present (Expression (Declaration_Node (E))) 3435 and then No (Linker_Section_Pragma (E)) 3436 then 3437 declare 3438 Decl : constant Node_Id := Declaration_Node (E); 3439 Lhs : constant Node_Id := New_Occurrence_Of (E, Loc); 3440 3441 begin 3442 -- Capture initialization value at point of declaration, and 3443 -- make explicit assignment legal, because object may be a 3444 -- constant. 3445 3446 Remove_Side_Effects (Expression (Decl)); 3447 Set_Assignment_OK (Lhs); 3448 3449 -- Move initialization to freeze actions 3450 3451 Append_Freeze_Action (E, 3452 Make_Assignment_Statement (Loc, 3453 Name => Lhs, 3454 Expression => Expression (Decl))); 3455 3456 Set_No_Initialization (Decl); 3457 -- Set_Is_Frozen (E, False); 3458 end; 3459 end if; 3460 3461 -- Reset Is_True_Constant for non-constant aliased object. We 3462 -- consider that the fact that a non-constant object is aliased may 3463 -- indicate that some funny business is going on, e.g. an aliased 3464 -- object is passed by reference to a procedure which captures the 3465 -- address of the object, which is later used to assign a new value, 3466 -- even though the compiler thinks that it is not modified. Such 3467 -- code is highly dubious, but we choose to make it "work" for 3468 -- non-constant aliased objects. 3469 3470 -- Note that we used to do this for all aliased objects, whether or 3471 -- not constant, but this caused anomalies down the line because we 3472 -- ended up with static objects that were not Is_True_Constant. Not 3473 -- resetting Is_True_Constant for (aliased) constant objects ensures 3474 -- that this anomaly never occurs. 3475 3476 -- However, we don't do that for internal entities. We figure that if 3477 -- we deliberately set Is_True_Constant for an internal entity, e.g. 3478 -- a dispatch table entry, then we mean it. 3479 3480 if Ekind (E) /= E_Constant 3481 and then (Is_Aliased (E) or else Is_Aliased (Typ)) 3482 and then not Is_Internal_Name (Chars (E)) 3483 then 3484 Set_Is_True_Constant (E, False); 3485 end if; 3486 3487 -- If the object needs any kind of default initialization, an error 3488 -- must be issued if No_Default_Initialization applies. The check 3489 -- doesn't apply to imported objects, which are not ever default 3490 -- initialized, and is why the check is deferred until freezing, at 3491 -- which point we know if Import applies. Deferred constants are also 3492 -- exempted from this test because their completion is explicit, or 3493 -- through an import pragma. 3494 3495 if Ekind (E) = E_Constant and then Present (Full_View (E)) then 3496 null; 3497 3498 elsif Has_Default_Initialization (E) then 3499 Check_Restriction 3500 (No_Default_Initialization, Declaration_Node (E)); 3501 end if; 3502 3503 -- Ensure that a variable subject to pragma Thread_Local_Storage 3504 -- 3505 -- * Lacks default initialization, or 3506 -- 3507 -- * The initialization expression is either "null", a static 3508 -- constant, or a compile-time known aggregate. 3509 3510 if Has_Pragma_Thread_Local_Storage (E) then 3511 Check_Pragma_Thread_Local_Storage (E); 3512 end if; 3513 3514 -- For imported objects, set Is_Public unless there is also an 3515 -- address clause, which means that there is no external symbol 3516 -- needed for the Import (Is_Public may still be set for other 3517 -- unrelated reasons). Note that we delayed this processing 3518 -- till freeze time so that we can be sure not to set the flag 3519 -- if there is an address clause. If there is such a clause, 3520 -- then the only purpose of the Import pragma is to suppress 3521 -- implicit initialization. 3522 3523 if Is_Imported (E) and then No (Address_Clause (E)) then 3524 Set_Is_Public (E); 3525 end if; 3526 3527 -- For source objects that are not Imported and are library level, if 3528 -- no linker section pragma was given inherit the appropriate linker 3529 -- section from the corresponding type. 3530 3531 if Comes_From_Source (E) 3532 and then not Is_Imported (E) 3533 and then Is_Library_Level_Entity (E) 3534 and then No (Linker_Section_Pragma (E)) 3535 then 3536 Set_Linker_Section_Pragma (E, Linker_Section_Pragma (Typ)); 3537 end if; 3538 3539 -- For convention C objects of an enumeration type, warn if the size 3540 -- is not integer size and no explicit size given. Skip warning for 3541 -- Boolean and Character, and assume programmer expects 8-bit sizes 3542 -- for these cases. 3543 3544 if (Convention (E) = Convention_C 3545 or else 3546 Convention (E) = Convention_CPP) 3547 and then Is_Enumeration_Type (Typ) 3548 and then not Is_Character_Type (Typ) 3549 and then not Is_Boolean_Type (Typ) 3550 and then Esize (Typ) < Standard_Integer_Size 3551 and then not Has_Size_Clause (E) 3552 then 3553 Error_Msg_Uint_1 := UI_From_Int (Standard_Integer_Size); 3554 Error_Msg_N 3555 ("??convention C enumeration object has size less than ^", E); 3556 Error_Msg_N ("\??use explicit size clause to set size", E); 3557 end if; 3558 3559 -- Declaring too big an array in disabled ghost code is OK 3560 3561 if Is_Array_Type (Typ) and then not Is_Ignored_Ghost_Entity (E) then 3562 Check_Large_Modular_Array (Typ); 3563 end if; 3564 end Freeze_Object_Declaration; 3565 3566 ----------------------------- 3567 -- Freeze_Generic_Entities -- 3568 ----------------------------- 3569 3570 function Freeze_Generic_Entities (Pack : Entity_Id) return List_Id is 3571 E : Entity_Id; 3572 F : Node_Id; 3573 Flist : List_Id; 3574 3575 begin 3576 Flist := New_List; 3577 E := First_Entity (Pack); 3578 while Present (E) loop 3579 if Is_Type (E) and then not Is_Generic_Type (E) then 3580 F := Make_Freeze_Generic_Entity (Sloc (Pack)); 3581 Set_Entity (F, E); 3582 Append_To (Flist, F); 3583 3584 elsif Ekind (E) = E_Generic_Package then 3585 Append_List_To (Flist, Freeze_Generic_Entities (E)); 3586 end if; 3587 3588 Next_Entity (E); 3589 end loop; 3590 3591 return Flist; 3592 end Freeze_Generic_Entities; 3593 3594 -------------------- 3595 -- Freeze_Profile -- 3596 -------------------- 3597 3598 function Freeze_Profile (E : Entity_Id) return Boolean is 3599 F_Type : Entity_Id; 3600 R_Type : Entity_Id; 3601 Warn_Node : Node_Id; 3602 3603 begin 3604 -- Loop through formals 3605 3606 Formal := First_Formal (E); 3607 while Present (Formal) loop 3608 F_Type := Etype (Formal); 3609 3610 -- AI05-0151: incomplete types can appear in a profile. By the 3611 -- time the entity is frozen, the full view must be available, 3612 -- unless it is a limited view. 3613 3614 if Is_Incomplete_Type (F_Type) 3615 and then Present (Full_View (F_Type)) 3616 and then not From_Limited_With (F_Type) 3617 then 3618 F_Type := Full_View (F_Type); 3619 Set_Etype (Formal, F_Type); 3620 end if; 3621 3622 if not From_Limited_With (F_Type) then 3623 Freeze_And_Append (F_Type, N, Result); 3624 end if; 3625 3626 if Is_Private_Type (F_Type) 3627 and then Is_Private_Type (Base_Type (F_Type)) 3628 and then No (Full_View (Base_Type (F_Type))) 3629 and then not Is_Generic_Type (F_Type) 3630 and then not Is_Derived_Type (F_Type) 3631 then 3632 -- If the type of a formal is incomplete, subprogram is being 3633 -- frozen prematurely. Within an instance (but not within a 3634 -- wrapper package) this is an artifact of our need to regard 3635 -- the end of an instantiation as a freeze point. Otherwise it 3636 -- is a definite error. 3637 3638 if In_Instance then 3639 Set_Is_Frozen (E, False); 3640 Result := No_List; 3641 return False; 3642 3643 elsif not After_Last_Declaration 3644 and then not Freezing_Library_Level_Tagged_Type 3645 then 3646 Error_Msg_Node_1 := F_Type; 3647 Error_Msg 3648 ("type & must be fully defined before this point", Loc); 3649 end if; 3650 end if; 3651 3652 -- Check suspicious parameter for C function. These tests apply 3653 -- only to exported/imported subprograms. 3654 3655 if Warn_On_Export_Import 3656 and then Comes_From_Source (E) 3657 and then Convention (E) in Convention_C_Family 3658 and then (Is_Imported (E) or else Is_Exported (E)) 3659 and then Convention (E) /= Convention (Formal) 3660 and then not Has_Warnings_Off (E) 3661 and then not Has_Warnings_Off (F_Type) 3662 and then not Has_Warnings_Off (Formal) 3663 then 3664 -- Qualify mention of formals with subprogram name 3665 3666 Error_Msg_Qual_Level := 1; 3667 3668 -- Check suspicious use of fat C pointer, but do not emit 3669 -- a warning on an access to subprogram when unnesting is 3670 -- active. 3671 3672 if Is_Access_Type (F_Type) 3673 and then Esize (F_Type) > Ttypes.System_Address_Size 3674 and then (not Unnest_Subprogram_Mode 3675 or else not Is_Access_Subprogram_Type (F_Type)) 3676 then 3677 Error_Msg_N 3678 ("?x?type of & does not correspond to C pointer!", Formal); 3679 3680 -- Check suspicious return of boolean 3681 3682 elsif Root_Type (F_Type) = Standard_Boolean 3683 and then Convention (F_Type) = Convention_Ada 3684 and then not Has_Warnings_Off (F_Type) 3685 and then not Has_Size_Clause (F_Type) 3686 then 3687 Error_Msg_N 3688 ("& is an 8-bit Ada Boolean?x?", Formal); 3689 Error_Msg_N 3690 ("\use appropriate corresponding type in C " 3691 & "(e.g. char)?x?", Formal); 3692 3693 -- Check suspicious tagged type 3694 3695 elsif (Is_Tagged_Type (F_Type) 3696 or else 3697 (Is_Access_Type (F_Type) 3698 and then Is_Tagged_Type (Designated_Type (F_Type)))) 3699 and then Convention (E) = Convention_C 3700 then 3701 Error_Msg_N 3702 ("?x?& involves a tagged type which does not " 3703 & "correspond to any C type!", Formal); 3704 3705 -- Check wrong convention subprogram pointer 3706 3707 elsif Ekind (F_Type) = E_Access_Subprogram_Type 3708 and then not Has_Foreign_Convention (F_Type) 3709 then 3710 Error_Msg_N 3711 ("?x?subprogram pointer & should " 3712 & "have foreign convention!", Formal); 3713 Error_Msg_Sloc := Sloc (F_Type); 3714 Error_Msg_NE 3715 ("\?x?add Convention pragma to declaration of &#", 3716 Formal, F_Type); 3717 end if; 3718 3719 -- Turn off name qualification after message output 3720 3721 Error_Msg_Qual_Level := 0; 3722 end if; 3723 3724 -- Check for unconstrained array in exported foreign convention 3725 -- case. 3726 3727 if Has_Foreign_Convention (E) 3728 and then not Is_Imported (E) 3729 and then Is_Array_Type (F_Type) 3730 and then not Is_Constrained (F_Type) 3731 and then Warn_On_Export_Import 3732 then 3733 Error_Msg_Qual_Level := 1; 3734 3735 -- If this is an inherited operation, place the warning on 3736 -- the derived type declaration, rather than on the original 3737 -- subprogram. 3738 3739 if Nkind (Original_Node (Parent (E))) = N_Full_Type_Declaration 3740 then 3741 Warn_Node := Parent (E); 3742 3743 if Formal = First_Formal (E) then 3744 Error_Msg_NE ("??in inherited operation&", Warn_Node, E); 3745 end if; 3746 else 3747 Warn_Node := Formal; 3748 end if; 3749 3750 Error_Msg_NE ("?x?type of argument& is unconstrained array", 3751 Warn_Node, Formal); 3752 Error_Msg_NE ("?x?foreign caller must pass bounds explicitly", 3753 Warn_Node, Formal); 3754 Error_Msg_Qual_Level := 0; 3755 end if; 3756 3757 if not From_Limited_With (F_Type) then 3758 if Is_Access_Type (F_Type) then 3759 F_Type := Designated_Type (F_Type); 3760 end if; 3761 3762 -- If the formal is an anonymous_access_to_subprogram 3763 -- freeze the subprogram type as well, to prevent 3764 -- scope anomalies in gigi, because there is no other 3765 -- clear point at which it could be frozen. 3766 3767 if Is_Itype (Etype (Formal)) 3768 and then Ekind (F_Type) = E_Subprogram_Type 3769 then 3770 Freeze_And_Append (F_Type, N, Result); 3771 end if; 3772 end if; 3773 3774 Next_Formal (Formal); 3775 end loop; 3776 3777 -- Case of function: similar checks on return type 3778 3779 if Ekind (E) = E_Function then 3780 3781 -- Freeze return type 3782 3783 R_Type := Etype (E); 3784 3785 -- AI05-0151: the return type may have been incomplete at the 3786 -- point of declaration. Replace it with the full view, unless the 3787 -- current type is a limited view. In that case the full view is 3788 -- in a different unit, and gigi finds the non-limited view after 3789 -- the other unit is elaborated. 3790 3791 if Ekind (R_Type) = E_Incomplete_Type 3792 and then Present (Full_View (R_Type)) 3793 and then not From_Limited_With (R_Type) 3794 then 3795 R_Type := Full_View (R_Type); 3796 Set_Etype (E, R_Type); 3797 end if; 3798 3799 Freeze_And_Append (R_Type, N, Result); 3800 3801 -- Check suspicious return type for C function 3802 3803 if Warn_On_Export_Import 3804 and then Comes_From_Source (E) 3805 and then Convention (E) in Convention_C_Family 3806 and then (Is_Imported (E) or else Is_Exported (E)) 3807 then 3808 -- Check suspicious return of fat C pointer 3809 3810 if Is_Access_Type (R_Type) 3811 and then Esize (R_Type) > Ttypes.System_Address_Size 3812 and then not Has_Warnings_Off (E) 3813 and then not Has_Warnings_Off (R_Type) 3814 then 3815 Error_Msg_N 3816 ("?x?return type of& does not correspond to C pointer!", 3817 E); 3818 3819 -- Check suspicious return of boolean 3820 3821 elsif Root_Type (R_Type) = Standard_Boolean 3822 and then Convention (R_Type) = Convention_Ada 3823 and then not Has_Warnings_Off (E) 3824 and then not Has_Warnings_Off (R_Type) 3825 and then not Has_Size_Clause (R_Type) 3826 then 3827 declare 3828 N : constant Node_Id := 3829 Result_Definition (Declaration_Node (E)); 3830 begin 3831 Error_Msg_NE 3832 ("return type of & is an 8-bit Ada Boolean?x?", N, E); 3833 Error_Msg_NE 3834 ("\use appropriate corresponding type in C " 3835 & "(e.g. char)?x?", N, E); 3836 end; 3837 3838 -- Check suspicious return tagged type 3839 3840 elsif (Is_Tagged_Type (R_Type) 3841 or else (Is_Access_Type (R_Type) 3842 and then 3843 Is_Tagged_Type 3844 (Designated_Type (R_Type)))) 3845 and then Convention (E) = Convention_C 3846 and then not Has_Warnings_Off (E) 3847 and then not Has_Warnings_Off (R_Type) 3848 then 3849 Error_Msg_N ("?x?return type of & does not " 3850 & "correspond to C type!", E); 3851 3852 -- Check return of wrong convention subprogram pointer 3853 3854 elsif Ekind (R_Type) = E_Access_Subprogram_Type 3855 and then not Has_Foreign_Convention (R_Type) 3856 and then not Has_Warnings_Off (E) 3857 and then not Has_Warnings_Off (R_Type) 3858 then 3859 Error_Msg_N ("?x?& should return a foreign " 3860 & "convention subprogram pointer", E); 3861 Error_Msg_Sloc := Sloc (R_Type); 3862 Error_Msg_NE 3863 ("\?x?add Convention pragma to declaration of& #", 3864 E, R_Type); 3865 end if; 3866 end if; 3867 3868 -- Give warning for suspicious return of a result of an 3869 -- unconstrained array type in a foreign convention function. 3870 3871 if Has_Foreign_Convention (E) 3872 3873 -- We are looking for a return of unconstrained array 3874 3875 and then Is_Array_Type (R_Type) 3876 and then not Is_Constrained (R_Type) 3877 3878 -- Exclude imported routines, the warning does not belong on 3879 -- the import, but rather on the routine definition. 3880 3881 and then not Is_Imported (E) 3882 3883 -- Check that general warning is enabled, and that it is not 3884 -- suppressed for this particular case. 3885 3886 and then Warn_On_Export_Import 3887 and then not Has_Warnings_Off (E) 3888 and then not Has_Warnings_Off (R_Type) 3889 then 3890 Error_Msg_N 3891 ("?x?foreign convention function& should not return " 3892 & "unconstrained array!", E); 3893 end if; 3894 end if; 3895 3896 -- Check suspicious use of Import in pure unit (cases where the RM 3897 -- allows calls to be omitted). 3898 3899 if Is_Imported (E) 3900 3901 -- It might be suspicious if the compilation unit has the Pure 3902 -- aspect/pragma. 3903 3904 and then Has_Pragma_Pure (Cunit_Entity (Current_Sem_Unit)) 3905 3906 -- The RM allows omission of calls only in the case of 3907 -- library-level subprograms (see RM-10.2.1(18)). 3908 3909 and then Is_Library_Level_Entity (E) 3910 3911 -- Ignore internally generated entity. This happens in some cases 3912 -- of subprograms in specs, where we generate an implied body. 3913 3914 and then Comes_From_Source (Import_Pragma (E)) 3915 3916 -- Assume run-time knows what it is doing 3917 3918 and then not GNAT_Mode 3919 3920 -- Assume explicit Pure_Function means import is pure 3921 3922 and then not Has_Pragma_Pure_Function (E) 3923 3924 -- Don't need warning in relaxed semantics mode 3925 3926 and then not Relaxed_RM_Semantics 3927 3928 -- Assume convention Intrinsic is OK, since this is specialized. 3929 -- This deals with the DEC unit current_exception.ads 3930 3931 and then Convention (E) /= Convention_Intrinsic 3932 3933 -- Assume that ASM interface knows what it is doing. This deals 3934 -- with e.g. unsigned.ads in the AAMP back end. 3935 3936 and then Convention (E) /= Convention_Assembler 3937 then 3938 Error_Msg_N 3939 ("pragma Import in Pure unit??", Import_Pragma (E)); 3940 Error_Msg_NE 3941 ("\calls to & may be omitted (RM 10.2.1(18/3))??", 3942 Import_Pragma (E), E); 3943 end if; 3944 3945 return True; 3946 end Freeze_Profile; 3947 3948 ------------------------ 3949 -- Freeze_Record_Type -- 3950 ------------------------ 3951 3952 procedure Freeze_Record_Type (Rec : Entity_Id) is 3953 ADC : Node_Id; 3954 Comp : Entity_Id; 3955 IR : Node_Id; 3956 Prev : Entity_Id; 3957 3958 Junk : Boolean; 3959 pragma Warnings (Off, Junk); 3960 3961 Aliased_Component : Boolean := False; 3962 -- Set True if we find at least one component which is aliased. This 3963 -- is used to prevent Implicit_Packing of the record, since packing 3964 -- cannot modify the size of alignment of an aliased component. 3965 3966 All_Elem_Components : Boolean := True; 3967 -- True if all components are of a type whose underlying type is 3968 -- elementary. 3969 3970 All_Sized_Components : Boolean := True; 3971 -- True if all components have a known RM_Size 3972 3973 All_Storage_Unit_Components : Boolean := True; 3974 -- True if all components have an RM_Size that is a multiple of the 3975 -- storage unit. 3976 3977 Elem_Component_Total_Esize : Uint := Uint_0; 3978 -- Accumulates total Esize values of all elementary components. Used 3979 -- for processing of Implicit_Packing. 3980 3981 Placed_Component : Boolean := False; 3982 -- Set True if we find at least one component with a component 3983 -- clause (used to warn about useless Bit_Order pragmas, and also 3984 -- to detect cases where Implicit_Packing may have an effect). 3985 3986 Sized_Component_Total_RM_Size : Uint := Uint_0; 3987 -- Accumulates total RM_Size values of all sized components. Used 3988 -- for processing of Implicit_Packing. 3989 3990 Sized_Component_Total_Round_RM_Size : Uint := Uint_0; 3991 -- Accumulates total RM_Size values of all sized components, rounded 3992 -- individually to a multiple of the storage unit. 3993 3994 SSO_ADC : Node_Id; 3995 -- Scalar_Storage_Order attribute definition clause for the record 3996 3997 SSO_ADC_Component : Boolean := False; 3998 -- Set True if we find at least one component whose type has a 3999 -- Scalar_Storage_Order attribute definition clause. 4000 4001 Unplaced_Component : Boolean := False; 4002 -- Set True if we find at least one component with no component 4003 -- clause (used to warn about useless Pack pragmas). 4004 4005 function Check_Allocator (N : Node_Id) return Node_Id; 4006 -- If N is an allocator, possibly wrapped in one or more level of 4007 -- qualified expression(s), return the inner allocator node, else 4008 -- return Empty. 4009 4010 procedure Check_Itype (Typ : Entity_Id); 4011 -- If the component subtype is an access to a constrained subtype of 4012 -- an already frozen type, make the subtype frozen as well. It might 4013 -- otherwise be frozen in the wrong scope, and a freeze node on 4014 -- subtype has no effect. Similarly, if the component subtype is a 4015 -- regular (not protected) access to subprogram, set the anonymous 4016 -- subprogram type to frozen as well, to prevent an out-of-scope 4017 -- freeze node at some eventual point of call. Protected operations 4018 -- are handled elsewhere. 4019 4020 procedure Freeze_Choices_In_Variant_Part (VP : Node_Id); 4021 -- Make sure that all types mentioned in Discrete_Choices of the 4022 -- variants referenceed by the Variant_Part VP are frozen. This is 4023 -- a recursive routine to deal with nested variants. 4024 4025 --------------------- 4026 -- Check_Allocator -- 4027 --------------------- 4028 4029 function Check_Allocator (N : Node_Id) return Node_Id is 4030 Inner : Node_Id; 4031 begin 4032 Inner := N; 4033 loop 4034 if Nkind (Inner) = N_Allocator then 4035 return Inner; 4036 elsif Nkind (Inner) = N_Qualified_Expression then 4037 Inner := Expression (Inner); 4038 else 4039 return Empty; 4040 end if; 4041 end loop; 4042 end Check_Allocator; 4043 4044 ----------------- 4045 -- Check_Itype -- 4046 ----------------- 4047 4048 procedure Check_Itype (Typ : Entity_Id) is 4049 Desig : constant Entity_Id := Designated_Type (Typ); 4050 4051 begin 4052 if not Is_Frozen (Desig) 4053 and then Is_Frozen (Base_Type (Desig)) 4054 then 4055 Set_Is_Frozen (Desig); 4056 4057 -- In addition, add an Itype_Reference to ensure that the 4058 -- access subtype is elaborated early enough. This cannot be 4059 -- done if the subtype may depend on discriminants. 4060 4061 if Ekind (Comp) = E_Component 4062 and then Is_Itype (Etype (Comp)) 4063 and then not Has_Discriminants (Rec) 4064 then 4065 IR := Make_Itype_Reference (Sloc (Comp)); 4066 Set_Itype (IR, Desig); 4067 Add_To_Result (IR); 4068 end if; 4069 4070 elsif Ekind (Typ) = E_Anonymous_Access_Subprogram_Type 4071 and then Convention (Desig) /= Convention_Protected 4072 then 4073 Set_Is_Frozen (Desig); 4074 end if; 4075 end Check_Itype; 4076 4077 ------------------------------------ 4078 -- Freeze_Choices_In_Variant_Part -- 4079 ------------------------------------ 4080 4081 procedure Freeze_Choices_In_Variant_Part (VP : Node_Id) is 4082 pragma Assert (Nkind (VP) = N_Variant_Part); 4083 4084 Variant : Node_Id; 4085 Choice : Node_Id; 4086 CL : Node_Id; 4087 4088 begin 4089 -- Loop through variants 4090 4091 Variant := First_Non_Pragma (Variants (VP)); 4092 while Present (Variant) loop 4093 4094 -- Loop through choices, checking that all types are frozen 4095 4096 Choice := First_Non_Pragma (Discrete_Choices (Variant)); 4097 while Present (Choice) loop 4098 if Nkind (Choice) in N_Has_Etype 4099 and then Present (Etype (Choice)) 4100 then 4101 Freeze_And_Append (Etype (Choice), N, Result); 4102 end if; 4103 4104 Next_Non_Pragma (Choice); 4105 end loop; 4106 4107 -- Check for nested variant part to process 4108 4109 CL := Component_List (Variant); 4110 4111 if not Null_Present (CL) then 4112 if Present (Variant_Part (CL)) then 4113 Freeze_Choices_In_Variant_Part (Variant_Part (CL)); 4114 end if; 4115 end if; 4116 4117 Next_Non_Pragma (Variant); 4118 end loop; 4119 end Freeze_Choices_In_Variant_Part; 4120 4121 -- Start of processing for Freeze_Record_Type 4122 4123 begin 4124 -- Freeze components and embedded subtypes 4125 4126 Comp := First_Entity (Rec); 4127 Prev := Empty; 4128 while Present (Comp) loop 4129 if Is_Aliased (Comp) then 4130 Aliased_Component := True; 4131 end if; 4132 4133 -- Handle the component and discriminant case 4134 4135 if Ekind (Comp) in E_Component | E_Discriminant then 4136 declare 4137 CC : constant Node_Id := Component_Clause (Comp); 4138 4139 begin 4140 -- Freezing a record type freezes the type of each of its 4141 -- components. However, if the type of the component is 4142 -- part of this record, we do not want or need a separate 4143 -- Freeze_Node. Note that Is_Itype is wrong because that's 4144 -- also set in private type cases. We also can't check for 4145 -- the Scope being exactly Rec because of private types and 4146 -- record extensions. 4147 4148 if Is_Itype (Etype (Comp)) 4149 and then Is_Record_Type (Underlying_Type 4150 (Scope (Etype (Comp)))) 4151 then 4152 Undelay_Type (Etype (Comp)); 4153 end if; 4154 4155 Freeze_And_Append (Etype (Comp), N, Result); 4156 4157 -- Warn for pragma Pack overriding foreign convention 4158 4159 if Has_Foreign_Convention (Etype (Comp)) 4160 and then Has_Pragma_Pack (Rec) 4161 4162 -- Don't warn for aliased components, since override 4163 -- cannot happen in that case. 4164 4165 and then not Is_Aliased (Comp) 4166 then 4167 declare 4168 CN : constant Name_Id := 4169 Get_Convention_Name (Convention (Etype (Comp))); 4170 PP : constant Node_Id := 4171 Get_Pragma (Rec, Pragma_Pack); 4172 begin 4173 if Present (PP) then 4174 Error_Msg_Name_1 := CN; 4175 Error_Msg_Sloc := Sloc (Comp); 4176 Error_Msg_N 4177 ("pragma Pack affects convention % component#??", 4178 PP); 4179 Error_Msg_Name_1 := CN; 4180 Error_Msg_NE 4181 ("\component & may not have % compatible " 4182 & "representation??", PP, Comp); 4183 end if; 4184 end; 4185 end if; 4186 4187 -- Check for error of component clause given for variable 4188 -- sized type. We have to delay this test till this point, 4189 -- since the component type has to be frozen for us to know 4190 -- if it is variable length. 4191 4192 if Present (CC) then 4193 Placed_Component := True; 4194 4195 -- We omit this test in a generic context, it will be 4196 -- applied at instantiation time. 4197 4198 if Inside_A_Generic then 4199 null; 4200 4201 -- Also omit this test in CodePeer mode, since we do not 4202 -- have sufficient info on size and rep clauses. 4203 4204 elsif CodePeer_Mode then 4205 null; 4206 4207 -- Do the check 4208 4209 elsif not 4210 Size_Known_At_Compile_Time 4211 (Underlying_Type (Etype (Comp))) 4212 then 4213 Error_Msg_N 4214 ("component clause not allowed for variable " & 4215 "length component", CC); 4216 end if; 4217 4218 else 4219 Unplaced_Component := True; 4220 end if; 4221 4222 -- Case of component requires byte alignment 4223 4224 if Must_Be_On_Byte_Boundary (Etype (Comp)) then 4225 4226 -- Set the enclosing record to also require byte align 4227 4228 Set_Must_Be_On_Byte_Boundary (Rec); 4229 4230 -- Check for component clause that is inconsistent with 4231 -- the required byte boundary alignment. 4232 4233 if Present (CC) 4234 and then Normalized_First_Bit (Comp) mod 4235 System_Storage_Unit /= 0 4236 then 4237 Error_Msg_N 4238 ("component & must be byte aligned", 4239 Component_Name (Component_Clause (Comp))); 4240 end if; 4241 end if; 4242 end; 4243 end if; 4244 4245 -- Gather data for possible Implicit_Packing later. Note that at 4246 -- this stage we might be dealing with a real component, or with 4247 -- an implicit subtype declaration. 4248 4249 if Known_Static_RM_Size (Etype (Comp)) then 4250 declare 4251 Comp_Type : constant Entity_Id := Etype (Comp); 4252 Comp_Size : constant Uint := RM_Size (Comp_Type); 4253 SSU : constant Int := Ttypes.System_Storage_Unit; 4254 4255 begin 4256 Sized_Component_Total_RM_Size := 4257 Sized_Component_Total_RM_Size + Comp_Size; 4258 4259 Sized_Component_Total_Round_RM_Size := 4260 Sized_Component_Total_Round_RM_Size + 4261 (Comp_Size + SSU - 1) / SSU * SSU; 4262 4263 if Present (Underlying_Type (Comp_Type)) 4264 and then Is_Elementary_Type (Underlying_Type (Comp_Type)) 4265 then 4266 Elem_Component_Total_Esize := 4267 Elem_Component_Total_Esize + Esize (Comp_Type); 4268 else 4269 All_Elem_Components := False; 4270 4271 if Comp_Size mod SSU /= 0 then 4272 All_Storage_Unit_Components := False; 4273 end if; 4274 end if; 4275 end; 4276 else 4277 All_Sized_Components := False; 4278 end if; 4279 4280 -- If the component is an Itype with Delayed_Freeze and is either 4281 -- a record or array subtype and its base type has not yet been 4282 -- frozen, we must remove this from the entity list of this record 4283 -- and put it on the entity list of the scope of its base type. 4284 -- Note that we know that this is not the type of a component 4285 -- since we cleared Has_Delayed_Freeze for it in the previous 4286 -- loop. Thus this must be the Designated_Type of an access type, 4287 -- which is the type of a component. 4288 4289 if Is_Itype (Comp) 4290 and then Is_Type (Scope (Comp)) 4291 and then Is_Composite_Type (Comp) 4292 and then Base_Type (Comp) /= Comp 4293 and then Has_Delayed_Freeze (Comp) 4294 and then not Is_Frozen (Base_Type (Comp)) 4295 then 4296 declare 4297 Will_Be_Frozen : Boolean := False; 4298 S : Entity_Id; 4299 4300 begin 4301 -- We have a difficult case to handle here. Suppose Rec is 4302 -- subtype being defined in a subprogram that's created as 4303 -- part of the freezing of Rec'Base. In that case, we know 4304 -- that Comp'Base must have already been frozen by the time 4305 -- we get to elaborate this because Gigi doesn't elaborate 4306 -- any bodies until it has elaborated all of the declarative 4307 -- part. But Is_Frozen will not be set at this point because 4308 -- we are processing code in lexical order. 4309 4310 -- We detect this case by going up the Scope chain of Rec 4311 -- and seeing if we have a subprogram scope before reaching 4312 -- the top of the scope chain or that of Comp'Base. If we 4313 -- do, then mark that Comp'Base will actually be frozen. If 4314 -- so, we merely undelay it. 4315 4316 S := Scope (Rec); 4317 while Present (S) loop 4318 if Is_Subprogram (S) then 4319 Will_Be_Frozen := True; 4320 exit; 4321 elsif S = Scope (Base_Type (Comp)) then 4322 exit; 4323 end if; 4324 4325 S := Scope (S); 4326 end loop; 4327 4328 if Will_Be_Frozen then 4329 Undelay_Type (Comp); 4330 4331 else 4332 if Present (Prev) then 4333 Link_Entities (Prev, Next_Entity (Comp)); 4334 else 4335 Set_First_Entity (Rec, Next_Entity (Comp)); 4336 end if; 4337 4338 -- Insert in entity list of scope of base type (which 4339 -- must be an enclosing scope, because still unfrozen). 4340 4341 Append_Entity (Comp, Scope (Base_Type (Comp))); 4342 end if; 4343 end; 4344 4345 -- If the component is an access type with an allocator as default 4346 -- value, the designated type will be frozen by the corresponding 4347 -- expression in init_proc. In order to place the freeze node for 4348 -- the designated type before that for the current record type, 4349 -- freeze it now. 4350 4351 -- Same process if the component is an array of access types, 4352 -- initialized with an aggregate. If the designated type is 4353 -- private, it cannot contain allocators, and it is premature 4354 -- to freeze the type, so we check for this as well. 4355 4356 elsif Is_Access_Type (Etype (Comp)) 4357 and then Present (Parent (Comp)) 4358 and then Present (Expression (Parent (Comp))) 4359 then 4360 declare 4361 Alloc : constant Node_Id := 4362 Check_Allocator (Expression (Parent (Comp))); 4363 4364 begin 4365 if Present (Alloc) then 4366 4367 -- If component is pointer to a class-wide type, freeze 4368 -- the specific type in the expression being allocated. 4369 -- The expression may be a subtype indication, in which 4370 -- case freeze the subtype mark. 4371 4372 if Is_Class_Wide_Type 4373 (Designated_Type (Etype (Comp))) 4374 then 4375 if Is_Entity_Name (Expression (Alloc)) then 4376 Freeze_And_Append 4377 (Entity (Expression (Alloc)), N, Result); 4378 4379 elsif Nkind (Expression (Alloc)) = N_Subtype_Indication 4380 then 4381 Freeze_And_Append 4382 (Entity (Subtype_Mark (Expression (Alloc))), 4383 N, Result); 4384 end if; 4385 4386 elsif Is_Itype (Designated_Type (Etype (Comp))) then 4387 Check_Itype (Etype (Comp)); 4388 4389 else 4390 Freeze_And_Append 4391 (Designated_Type (Etype (Comp)), N, Result); 4392 end if; 4393 end if; 4394 end; 4395 4396 elsif Is_Access_Type (Etype (Comp)) 4397 and then Is_Itype (Designated_Type (Etype (Comp))) 4398 then 4399 Check_Itype (Etype (Comp)); 4400 4401 -- Freeze the designated type when initializing a component with 4402 -- an aggregate in case the aggregate contains allocators. 4403 4404 -- type T is ...; 4405 -- type T_Ptr is access all T; 4406 -- type T_Array is array ... of T_Ptr; 4407 4408 -- type Rec is record 4409 -- Comp : T_Array := (others => ...); 4410 -- end record; 4411 4412 elsif Is_Array_Type (Etype (Comp)) 4413 and then Is_Access_Type (Component_Type (Etype (Comp))) 4414 then 4415 declare 4416 Comp_Par : constant Node_Id := Parent (Comp); 4417 Desig_Typ : constant Entity_Id := 4418 Designated_Type 4419 (Component_Type (Etype (Comp))); 4420 4421 begin 4422 -- The only case when this sort of freezing is not done is 4423 -- when the designated type is class-wide and the root type 4424 -- is the record owning the component. This scenario results 4425 -- in a circularity because the class-wide type requires 4426 -- primitives that have not been created yet as the root 4427 -- type is in the process of being frozen. 4428 4429 -- type Rec is tagged; 4430 -- type Rec_Ptr is access all Rec'Class; 4431 -- type Rec_Array is array ... of Rec_Ptr; 4432 4433 -- type Rec is record 4434 -- Comp : Rec_Array := (others => ...); 4435 -- end record; 4436 4437 if Is_Class_Wide_Type (Desig_Typ) 4438 and then Root_Type (Desig_Typ) = Rec 4439 then 4440 null; 4441 4442 elsif Is_Fully_Defined (Desig_Typ) 4443 and then Present (Comp_Par) 4444 and then Nkind (Comp_Par) = N_Component_Declaration 4445 and then Present (Expression (Comp_Par)) 4446 and then Nkind (Expression (Comp_Par)) = N_Aggregate 4447 then 4448 Freeze_And_Append (Desig_Typ, N, Result); 4449 end if; 4450 end; 4451 end if; 4452 4453 Prev := Comp; 4454 Next_Entity (Comp); 4455 end loop; 4456 4457 SSO_ADC := 4458 Get_Attribute_Definition_Clause 4459 (Rec, Attribute_Scalar_Storage_Order); 4460 4461 -- If the record type has Complex_Representation, then it is treated 4462 -- as a scalar in the back end so the storage order is irrelevant. 4463 4464 if Has_Complex_Representation (Rec) then 4465 if Present (SSO_ADC) then 4466 Error_Msg_N 4467 ("??storage order has no effect with Complex_Representation", 4468 SSO_ADC); 4469 end if; 4470 4471 else 4472 -- Deal with default setting of reverse storage order 4473 4474 Set_SSO_From_Default (Rec); 4475 4476 -- Check consistent attribute setting on component types 4477 4478 declare 4479 Comp_ADC_Present : Boolean; 4480 begin 4481 Comp := First_Component (Rec); 4482 while Present (Comp) loop 4483 Check_Component_Storage_Order 4484 (Encl_Type => Rec, 4485 Comp => Comp, 4486 ADC => SSO_ADC, 4487 Comp_ADC_Present => Comp_ADC_Present); 4488 SSO_ADC_Component := SSO_ADC_Component or Comp_ADC_Present; 4489 Next_Component (Comp); 4490 end loop; 4491 end; 4492 4493 -- Now deal with reverse storage order/bit order issues 4494 4495 if Present (SSO_ADC) then 4496 4497 -- Check compatibility of Scalar_Storage_Order with Bit_Order, 4498 -- if the former is specified. 4499 4500 if Reverse_Bit_Order (Rec) /= Reverse_Storage_Order (Rec) then 4501 4502 -- Note: report error on Rec, not on SSO_ADC, as ADC may 4503 -- apply to some ancestor type. 4504 4505 Error_Msg_Sloc := Sloc (SSO_ADC); 4506 Error_Msg_N 4507 ("scalar storage order for& specified# inconsistent with " 4508 & "bit order", Rec); 4509 end if; 4510 4511 -- Warn if there is a Scalar_Storage_Order attribute definition 4512 -- clause but no component clause, no component that itself has 4513 -- such an attribute definition, and no pragma Pack. 4514 4515 if not (Placed_Component 4516 or else 4517 SSO_ADC_Component 4518 or else 4519 Is_Packed (Rec)) 4520 then 4521 Error_Msg_N 4522 ("??scalar storage order specified but no component " 4523 & "clause", SSO_ADC); 4524 end if; 4525 end if; 4526 end if; 4527 4528 -- Deal with Bit_Order aspect 4529 4530 ADC := Get_Attribute_Definition_Clause (Rec, Attribute_Bit_Order); 4531 4532 if Present (ADC) and then Base_Type (Rec) = Rec then 4533 if not (Placed_Component 4534 or else Present (SSO_ADC) 4535 or else Is_Packed (Rec)) 4536 then 4537 -- Warn if clause has no effect when no component clause is 4538 -- present, but suppress warning if the Bit_Order is required 4539 -- due to the presence of a Scalar_Storage_Order attribute. 4540 4541 Error_Msg_N 4542 ("??bit order specification has no effect", ADC); 4543 Error_Msg_N 4544 ("\??since no component clauses were specified", ADC); 4545 4546 -- Here is where we do the processing to adjust component clauses 4547 -- for reversed bit order, when not using reverse SSO. If an error 4548 -- has been reported on Rec already (such as SSO incompatible with 4549 -- bit order), don't bother adjusting as this may generate extra 4550 -- noise. 4551 4552 elsif Reverse_Bit_Order (Rec) 4553 and then not Reverse_Storage_Order (Rec) 4554 and then not Error_Posted (Rec) 4555 then 4556 Adjust_Record_For_Reverse_Bit_Order (Rec); 4557 4558 -- Case where we have both an explicit Bit_Order and the same 4559 -- Scalar_Storage_Order: leave record untouched, the back-end 4560 -- will take care of required layout conversions. 4561 4562 else 4563 null; 4564 4565 end if; 4566 end if; 4567 4568 -- Check for useless pragma Pack when all components placed. We only 4569 -- do this check for record types, not subtypes, since a subtype may 4570 -- have all its components placed, and it still makes perfectly good 4571 -- sense to pack other subtypes or the parent type. We do not give 4572 -- this warning if Optimize_Alignment is set to Space, since the 4573 -- pragma Pack does have an effect in this case (it always resets 4574 -- the alignment to one). 4575 4576 if Ekind (Rec) = E_Record_Type 4577 and then Is_Packed (Rec) 4578 and then not Unplaced_Component 4579 and then Optimize_Alignment /= 'S' 4580 then 4581 -- Reset packed status. Probably not necessary, but we do it so 4582 -- that there is no chance of the back end doing something strange 4583 -- with this redundant indication of packing. 4584 4585 Set_Is_Packed (Rec, False); 4586 4587 -- Give warning if redundant constructs warnings on 4588 4589 if Warn_On_Redundant_Constructs then 4590 Error_Msg_N -- CODEFIX 4591 ("??pragma Pack has no effect, no unplaced components", 4592 Get_Rep_Pragma (Rec, Name_Pack)); 4593 end if; 4594 end if; 4595 4596 -- If this is the record corresponding to a remote type, freeze the 4597 -- remote type here since that is what we are semantically freezing. 4598 -- This prevents the freeze node for that type in an inner scope. 4599 4600 if Ekind (Rec) = E_Record_Type then 4601 if Present (Corresponding_Remote_Type (Rec)) then 4602 Freeze_And_Append (Corresponding_Remote_Type (Rec), N, Result); 4603 end if; 4604 4605 -- Check for controlled components, unchecked unions, and type 4606 -- invariants. 4607 4608 Comp := First_Component (Rec); 4609 while Present (Comp) loop 4610 4611 -- Do not set Has_Controlled_Component on a class-wide 4612 -- equivalent type. See Make_CW_Equivalent_Type. 4613 4614 if not Is_Class_Wide_Equivalent_Type (Rec) 4615 and then 4616 (Has_Controlled_Component (Etype (Comp)) 4617 or else 4618 (Chars (Comp) /= Name_uParent 4619 and then Is_Controlled (Etype (Comp))) 4620 or else 4621 (Is_Protected_Type (Etype (Comp)) 4622 and then 4623 Present (Corresponding_Record_Type (Etype (Comp))) 4624 and then 4625 Has_Controlled_Component 4626 (Corresponding_Record_Type (Etype (Comp))))) 4627 then 4628 Set_Has_Controlled_Component (Rec); 4629 end if; 4630 4631 if Has_Unchecked_Union (Etype (Comp)) then 4632 Set_Has_Unchecked_Union (Rec); 4633 end if; 4634 4635 -- The record type requires its own invariant procedure in 4636 -- order to verify the invariant of each individual component. 4637 -- Do not consider internal components such as _parent because 4638 -- parent class-wide invariants are always inherited. 4639 -- In GNATprove mode, the component invariants are checked by 4640 -- other means. They should not be added to the record type 4641 -- invariant procedure, so that the procedure can be used to 4642 -- check the recordy type invariants if any. 4643 4644 if Comes_From_Source (Comp) 4645 and then Has_Invariants (Etype (Comp)) 4646 and then not GNATprove_Mode 4647 then 4648 Set_Has_Own_Invariants (Rec); 4649 end if; 4650 4651 -- Scan component declaration for likely misuses of current 4652 -- instance, either in a constraint or a default expression. 4653 4654 if Has_Per_Object_Constraint (Comp) then 4655 Check_Current_Instance (Parent (Comp)); 4656 end if; 4657 4658 Next_Component (Comp); 4659 end loop; 4660 end if; 4661 4662 -- Enforce the restriction that access attributes with a current 4663 -- instance prefix can only apply to limited types. This comment 4664 -- is floating here, but does not seem to belong here??? 4665 4666 -- Set component alignment if not otherwise already set 4667 4668 Set_Component_Alignment_If_Not_Set (Rec); 4669 4670 -- For first subtypes, check if there are any fixed-point fields with 4671 -- component clauses, where we must check the size. This is not done 4672 -- till the freeze point since for fixed-point types, we do not know 4673 -- the size until the type is frozen. Similar processing applies to 4674 -- bit-packed arrays. 4675 4676 if Is_First_Subtype (Rec) then 4677 Comp := First_Component (Rec); 4678 while Present (Comp) loop 4679 if Present (Component_Clause (Comp)) 4680 and then (Is_Fixed_Point_Type (Etype (Comp)) 4681 or else Is_Bit_Packed_Array (Etype (Comp))) 4682 then 4683 Check_Size 4684 (Component_Name (Component_Clause (Comp)), 4685 Etype (Comp), 4686 Esize (Comp), 4687 Junk); 4688 end if; 4689 4690 Next_Component (Comp); 4691 end loop; 4692 end if; 4693 4694 -- See if Size is too small as is (and implicit packing might help) 4695 4696 if not Is_Packed (Rec) 4697 4698 -- No implicit packing if even one component is explicitly placed 4699 4700 and then not Placed_Component 4701 4702 -- Or even one component is aliased 4703 4704 and then not Aliased_Component 4705 4706 -- Must have size clause and all sized components 4707 4708 and then Has_Size_Clause (Rec) 4709 and then All_Sized_Components 4710 4711 -- Do not try implicit packing on records with discriminants, too 4712 -- complicated, especially in the variant record case. 4713 4714 and then not Has_Discriminants (Rec) 4715 4716 -- We want to implicitly pack if the specified size of the record 4717 -- is less than the sum of the object sizes (no point in packing 4718 -- if this is not the case), if we can compute it, i.e. if we have 4719 -- only elementary components. Otherwise, we have at least one 4720 -- composite component and we want to implicitly pack only if bit 4721 -- packing is required for it, as we are sure in this case that 4722 -- the back end cannot do the expected layout without packing. 4723 4724 and then 4725 ((All_Elem_Components 4726 and then RM_Size (Rec) < Elem_Component_Total_Esize) 4727 or else 4728 (not All_Elem_Components 4729 and then not All_Storage_Unit_Components 4730 and then RM_Size (Rec) < Sized_Component_Total_Round_RM_Size)) 4731 4732 -- And the total RM size cannot be greater than the specified size 4733 -- since otherwise packing will not get us where we have to be. 4734 4735 and then Sized_Component_Total_RM_Size <= RM_Size (Rec) 4736 4737 -- Never do implicit packing in CodePeer or SPARK modes since 4738 -- we don't do any packing in these modes, since this generates 4739 -- over-complex code that confuses static analysis, and in 4740 -- general, neither CodePeer not GNATprove care about the 4741 -- internal representation of objects. 4742 4743 and then not (CodePeer_Mode or GNATprove_Mode) 4744 then 4745 -- If implicit packing enabled, do it 4746 4747 if Implicit_Packing then 4748 Set_Is_Packed (Rec); 4749 4750 -- Otherwise flag the size clause 4751 4752 else 4753 declare 4754 Sz : constant Node_Id := Size_Clause (Rec); 4755 begin 4756 Error_Msg_NE -- CODEFIX 4757 ("size given for& too small", Sz, Rec); 4758 Error_Msg_N -- CODEFIX 4759 ("\use explicit pragma Pack " 4760 & "or use pragma Implicit_Packing", Sz); 4761 end; 4762 end if; 4763 end if; 4764 4765 -- The following checks are relevant only when SPARK_Mode is on as 4766 -- they are not standard Ada legality rules. 4767 4768 if SPARK_Mode = On then 4769 4770 -- A discriminated type cannot be effectively volatile 4771 -- (SPARK RM 7.1.3(5)). 4772 4773 if Is_Effectively_Volatile (Rec) then 4774 if Has_Discriminants (Rec) then 4775 Error_Msg_N ("discriminated type & cannot be volatile", Rec); 4776 end if; 4777 4778 -- A non-effectively volatile record type cannot contain 4779 -- effectively volatile components (SPARK RM 7.1.3(6)). 4780 4781 else 4782 Comp := First_Component (Rec); 4783 while Present (Comp) loop 4784 if Comes_From_Source (Comp) 4785 and then Is_Effectively_Volatile (Etype (Comp)) 4786 then 4787 Error_Msg_Name_1 := Chars (Rec); 4788 Error_Msg_N 4789 ("component & of non-volatile type % cannot be " 4790 & "volatile", Comp); 4791 end if; 4792 4793 Next_Component (Comp); 4794 end loop; 4795 end if; 4796 4797 -- A type which does not yield a synchronized object cannot have 4798 -- a component that yields a synchronized object (SPARK RM 9.5). 4799 4800 if not Yields_Synchronized_Object (Rec) then 4801 Comp := First_Component (Rec); 4802 while Present (Comp) loop 4803 if Comes_From_Source (Comp) 4804 and then Yields_Synchronized_Object (Etype (Comp)) 4805 then 4806 Error_Msg_Name_1 := Chars (Rec); 4807 Error_Msg_N 4808 ("component & of non-synchronized type % cannot be " 4809 & "synchronized", Comp); 4810 end if; 4811 4812 Next_Component (Comp); 4813 end loop; 4814 end if; 4815 4816 -- A Ghost type cannot have a component of protected or task type 4817 -- (SPARK RM 6.9(19)). 4818 4819 if Is_Ghost_Entity (Rec) then 4820 Comp := First_Component (Rec); 4821 while Present (Comp) loop 4822 if Comes_From_Source (Comp) 4823 and then Is_Concurrent_Type (Etype (Comp)) 4824 then 4825 Error_Msg_Name_1 := Chars (Rec); 4826 Error_Msg_N 4827 ("component & of ghost type % cannot be concurrent", 4828 Comp); 4829 end if; 4830 4831 Next_Component (Comp); 4832 end loop; 4833 end if; 4834 end if; 4835 4836 -- Make sure that if we have an iterator aspect, then we have 4837 -- either Constant_Indexing or Variable_Indexing. 4838 4839 declare 4840 Iterator_Aspect : Node_Id; 4841 4842 begin 4843 Iterator_Aspect := Find_Aspect (Rec, Aspect_Iterator_Element); 4844 4845 if No (Iterator_Aspect) then 4846 Iterator_Aspect := Find_Aspect (Rec, Aspect_Default_Iterator); 4847 end if; 4848 4849 if Present (Iterator_Aspect) then 4850 if Has_Aspect (Rec, Aspect_Constant_Indexing) 4851 or else 4852 Has_Aspect (Rec, Aspect_Variable_Indexing) 4853 then 4854 null; 4855 else 4856 Error_Msg_N 4857 ("Iterator_Element requires indexing aspect", 4858 Iterator_Aspect); 4859 end if; 4860 end if; 4861 end; 4862 4863 -- All done if not a full record definition 4864 4865 if Ekind (Rec) /= E_Record_Type then 4866 return; 4867 end if; 4868 4869 -- Finally we need to check the variant part to make sure that 4870 -- all types within choices are properly frozen as part of the 4871 -- freezing of the record type. 4872 4873 Check_Variant_Part : declare 4874 D : constant Node_Id := Declaration_Node (Rec); 4875 T : Node_Id; 4876 C : Node_Id; 4877 4878 begin 4879 -- Find component list 4880 4881 C := Empty; 4882 4883 if Nkind (D) = N_Full_Type_Declaration then 4884 T := Type_Definition (D); 4885 4886 if Nkind (T) = N_Record_Definition then 4887 C := Component_List (T); 4888 4889 elsif Nkind (T) = N_Derived_Type_Definition 4890 and then Present (Record_Extension_Part (T)) 4891 then 4892 C := Component_List (Record_Extension_Part (T)); 4893 end if; 4894 end if; 4895 4896 -- Case of variant part present 4897 4898 if Present (C) and then Present (Variant_Part (C)) then 4899 Freeze_Choices_In_Variant_Part (Variant_Part (C)); 4900 end if; 4901 4902 -- Note: we used to call Check_Choices here, but it is too early, 4903 -- since predicated subtypes are frozen here, but their freezing 4904 -- actions are in Analyze_Freeze_Entity, which has not been called 4905 -- yet for entities frozen within this procedure, so we moved that 4906 -- call to the Analyze_Freeze_Entity for the record type. 4907 4908 end Check_Variant_Part; 4909 4910 -- Check that all the primitives of an interface type are abstract 4911 -- or null procedures. 4912 4913 if Is_Interface (Rec) 4914 and then not Error_Posted (Parent (Rec)) 4915 then 4916 declare 4917 Elmt : Elmt_Id; 4918 Subp : Entity_Id; 4919 4920 begin 4921 Elmt := First_Elmt (Primitive_Operations (Rec)); 4922 while Present (Elmt) loop 4923 Subp := Node (Elmt); 4924 4925 if not Is_Abstract_Subprogram (Subp) 4926 4927 -- Avoid reporting the error on inherited primitives 4928 4929 and then Comes_From_Source (Subp) 4930 then 4931 Error_Msg_Name_1 := Chars (Subp); 4932 4933 if Ekind (Subp) = E_Procedure then 4934 if not Null_Present (Parent (Subp)) then 4935 Error_Msg_N 4936 ("interface procedure % must be abstract or null", 4937 Parent (Subp)); 4938 end if; 4939 else 4940 Error_Msg_N 4941 ("interface function % must be abstract", 4942 Parent (Subp)); 4943 end if; 4944 end if; 4945 4946 Next_Elmt (Elmt); 4947 end loop; 4948 end; 4949 end if; 4950 4951 -- For a derived tagged type, check whether inherited primitives 4952 -- might require a wrapper to handle class-wide conditions. 4953 4954 if Is_Tagged_Type (Rec) and then Is_Derived_Type (Rec) then 4955 Check_Inherited_Conditions (Rec); 4956 end if; 4957 end Freeze_Record_Type; 4958 4959 ------------------------------- 4960 -- Has_Boolean_Aspect_Import -- 4961 ------------------------------- 4962 4963 function Has_Boolean_Aspect_Import (E : Entity_Id) return Boolean is 4964 Decl : constant Node_Id := Declaration_Node (E); 4965 Asp : Node_Id; 4966 Expr : Node_Id; 4967 4968 begin 4969 if Has_Aspects (Decl) then 4970 Asp := First (Aspect_Specifications (Decl)); 4971 while Present (Asp) loop 4972 Expr := Expression (Asp); 4973 4974 -- The value of aspect Import is True when the expression is 4975 -- either missing or it is explicitly set to True. 4976 4977 if Get_Aspect_Id (Asp) = Aspect_Import 4978 and then (No (Expr) 4979 or else (Compile_Time_Known_Value (Expr) 4980 and then Is_True (Expr_Value (Expr)))) 4981 then 4982 return True; 4983 end if; 4984 4985 Next (Asp); 4986 end loop; 4987 end if; 4988 4989 return False; 4990 end Has_Boolean_Aspect_Import; 4991 4992 ------------------------- 4993 -- Inherit_Freeze_Node -- 4994 ------------------------- 4995 4996 procedure Inherit_Freeze_Node 4997 (Fnod : Node_Id; 4998 Typ : Entity_Id) 4999 is 5000 Typ_Fnod : constant Node_Id := Freeze_Node (Typ); 5001 5002 begin 5003 Set_Freeze_Node (Typ, Fnod); 5004 Set_Entity (Fnod, Typ); 5005 5006 -- The input type had an existing node. Propagate relevant attributes 5007 -- from the old freeze node to the inherited freeze node. 5008 5009 -- ??? if both freeze nodes have attributes, would they differ? 5010 5011 if Present (Typ_Fnod) then 5012 5013 -- Attribute Access_Types_To_Process 5014 5015 if Present (Access_Types_To_Process (Typ_Fnod)) 5016 and then No (Access_Types_To_Process (Fnod)) 5017 then 5018 Set_Access_Types_To_Process (Fnod, 5019 Access_Types_To_Process (Typ_Fnod)); 5020 end if; 5021 5022 -- Attribute Actions 5023 5024 if Present (Actions (Typ_Fnod)) and then No (Actions (Fnod)) then 5025 Set_Actions (Fnod, Actions (Typ_Fnod)); 5026 end if; 5027 5028 -- Attribute First_Subtype_Link 5029 5030 if Present (First_Subtype_Link (Typ_Fnod)) 5031 and then No (First_Subtype_Link (Fnod)) 5032 then 5033 Set_First_Subtype_Link (Fnod, First_Subtype_Link (Typ_Fnod)); 5034 end if; 5035 5036 -- Attribute TSS_Elist 5037 5038 if Present (TSS_Elist (Typ_Fnod)) 5039 and then No (TSS_Elist (Fnod)) 5040 then 5041 Set_TSS_Elist (Fnod, TSS_Elist (Typ_Fnod)); 5042 end if; 5043 end if; 5044 end Inherit_Freeze_Node; 5045 5046 ------------------------------ 5047 -- Wrap_Imported_Subprogram -- 5048 ------------------------------ 5049 5050 -- The issue here is that our normal approach of checking preconditions 5051 -- and postconditions does not work for imported procedures, since we 5052 -- are not generating code for the body. To get around this we create 5053 -- a wrapper, as shown by the following example: 5054 5055 -- procedure K (A : Integer); 5056 -- pragma Import (C, K); 5057 5058 -- The spec is rewritten by removing the effects of pragma Import, but 5059 -- leaving the convention unchanged, as though the source had said: 5060 5061 -- procedure K (A : Integer); 5062 -- pragma Convention (C, K); 5063 5064 -- and we create a body, added to the entity K freeze actions, which 5065 -- looks like: 5066 5067 -- procedure K (A : Integer) is 5068 -- procedure K (A : Integer); 5069 -- pragma Import (C, K); 5070 -- begin 5071 -- K (A); 5072 -- end K; 5073 5074 -- Now the contract applies in the normal way to the outer procedure, 5075 -- and the inner procedure has no contracts, so there is no problem 5076 -- in just calling it to get the original effect. 5077 5078 -- In the case of a function, we create an appropriate return statement 5079 -- for the subprogram body that calls the inner procedure. 5080 5081 procedure Wrap_Imported_Subprogram (E : Entity_Id) is 5082 function Copy_Import_Pragma return Node_Id; 5083 -- Obtain a copy of the Import_Pragma which belongs to subprogram E 5084 5085 ------------------------ 5086 -- Copy_Import_Pragma -- 5087 ------------------------ 5088 5089 function Copy_Import_Pragma return Node_Id is 5090 5091 -- The subprogram should have an import pragma, otherwise it does 5092 -- need a wrapper. 5093 5094 Prag : constant Node_Id := Import_Pragma (E); 5095 pragma Assert (Present (Prag)); 5096 5097 -- Save all semantic fields of the pragma 5098 5099 Save_Asp : constant Node_Id := Corresponding_Aspect (Prag); 5100 Save_From : constant Boolean := From_Aspect_Specification (Prag); 5101 Save_Prag : constant Node_Id := Next_Pragma (Prag); 5102 Save_Rep : constant Node_Id := Next_Rep_Item (Prag); 5103 5104 Result : Node_Id; 5105 5106 begin 5107 -- Reset all semantic fields. This avoids a potential infinite 5108 -- loop when the pragma comes from an aspect as the duplication 5109 -- will copy the aspect, then copy the corresponding pragma and 5110 -- so on. 5111 5112 Set_Corresponding_Aspect (Prag, Empty); 5113 Set_From_Aspect_Specification (Prag, False); 5114 Set_Next_Pragma (Prag, Empty); 5115 Set_Next_Rep_Item (Prag, Empty); 5116 5117 Result := Copy_Separate_Tree (Prag); 5118 5119 -- Restore the original semantic fields 5120 5121 Set_Corresponding_Aspect (Prag, Save_Asp); 5122 Set_From_Aspect_Specification (Prag, Save_From); 5123 Set_Next_Pragma (Prag, Save_Prag); 5124 Set_Next_Rep_Item (Prag, Save_Rep); 5125 5126 return Result; 5127 end Copy_Import_Pragma; 5128 5129 -- Local variables 5130 5131 Loc : constant Source_Ptr := Sloc (E); 5132 CE : constant Name_Id := Chars (E); 5133 Bod : Node_Id; 5134 Forml : Entity_Id; 5135 Parms : List_Id; 5136 Prag : Node_Id; 5137 Spec : Node_Id; 5138 Stmt : Node_Id; 5139 5140 -- Start of processing for Wrap_Imported_Subprogram 5141 5142 begin 5143 -- Nothing to do if not imported 5144 5145 if not Is_Imported (E) then 5146 return; 5147 5148 -- Test enabling conditions for wrapping 5149 5150 elsif Is_Subprogram (E) 5151 and then Present (Contract (E)) 5152 and then Present (Pre_Post_Conditions (Contract (E))) 5153 and then not GNATprove_Mode 5154 then 5155 -- Here we do the wrap 5156 5157 -- Note on calls to Copy_Separate_Tree. The trees we are copying 5158 -- here are fully analyzed, but we definitely want fully syntactic 5159 -- unanalyzed trees in the body we construct, so that the analysis 5160 -- generates the right visibility, and that is exactly what the 5161 -- calls to Copy_Separate_Tree give us. 5162 5163 Prag := Copy_Import_Pragma; 5164 5165 -- Fix up spec so it is no longer imported and has convention Ada 5166 5167 Set_Has_Completion (E, False); 5168 Set_Import_Pragma (E, Empty); 5169 Set_Interface_Name (E, Empty); 5170 Set_Is_Imported (E, False); 5171 Set_Convention (E, Convention_Ada); 5172 5173 -- Grab the subprogram declaration and specification 5174 5175 Spec := Declaration_Node (E); 5176 5177 -- Build parameter list that we need 5178 5179 Parms := New_List; 5180 Forml := First_Formal (E); 5181 while Present (Forml) loop 5182 Append_To (Parms, Make_Identifier (Loc, Chars (Forml))); 5183 Next_Formal (Forml); 5184 end loop; 5185 5186 -- Build the call 5187 5188 -- An imported function whose result type is anonymous access 5189 -- creates a new anonymous access type when it is relocated into 5190 -- the declarations of the body generated below. As a result, the 5191 -- accessibility level of these two anonymous access types may not 5192 -- be compatible even though they are essentially the same type. 5193 -- Use an unchecked type conversion to reconcile this case. Note 5194 -- that the conversion is safe because in the named access type 5195 -- case, both the body and imported function utilize the same 5196 -- type. 5197 5198 if Ekind (E) in E_Function | E_Generic_Function then 5199 Stmt := 5200 Make_Simple_Return_Statement (Loc, 5201 Expression => 5202 Unchecked_Convert_To (Etype (E), 5203 Make_Function_Call (Loc, 5204 Name => Make_Identifier (Loc, CE), 5205 Parameter_Associations => Parms))); 5206 5207 else 5208 Stmt := 5209 Make_Procedure_Call_Statement (Loc, 5210 Name => Make_Identifier (Loc, CE), 5211 Parameter_Associations => Parms); 5212 end if; 5213 5214 -- Now build the body 5215 5216 Bod := 5217 Make_Subprogram_Body (Loc, 5218 Specification => 5219 Copy_Separate_Tree (Spec), 5220 Declarations => New_List ( 5221 Make_Subprogram_Declaration (Loc, 5222 Specification => Copy_Separate_Tree (Spec)), 5223 Prag), 5224 Handled_Statement_Sequence => 5225 Make_Handled_Sequence_Of_Statements (Loc, 5226 Statements => New_List (Stmt), 5227 End_Label => Make_Identifier (Loc, CE))); 5228 5229 -- Append the body to freeze result 5230 5231 Add_To_Result (Bod); 5232 return; 5233 5234 -- Case of imported subprogram that does not get wrapped 5235 5236 else 5237 -- Set Is_Public. All imported entities need an external symbol 5238 -- created for them since they are always referenced from another 5239 -- object file. Note this used to be set when we set Is_Imported 5240 -- back in Sem_Prag, but now we delay it to this point, since we 5241 -- don't want to set this flag if we wrap an imported subprogram. 5242 5243 Set_Is_Public (E); 5244 end if; 5245 end Wrap_Imported_Subprogram; 5246 5247 -- Start of processing for Freeze_Entity 5248 5249 begin 5250 -- The entity being frozen may be subject to pragma Ghost. Set the mode 5251 -- now to ensure that any nodes generated during freezing are properly 5252 -- flagged as Ghost. 5253 5254 Set_Ghost_Mode (E); 5255 5256 -- We are going to test for various reasons why this entity need not be 5257 -- frozen here, but in the case of an Itype that's defined within a 5258 -- record, that test actually applies to the record. 5259 5260 if Is_Itype (E) and then Is_Record_Type (Scope (E)) then 5261 Test_E := Scope (E); 5262 5263 elsif Is_Itype (E) and then Present (Underlying_Type (Scope (E))) 5264 and then Is_Record_Type (Underlying_Type (Scope (E))) 5265 then 5266 Test_E := Underlying_Type (Scope (E)); 5267 end if; 5268 5269 -- Do not freeze if already frozen since we only need one freeze node 5270 5271 if Is_Frozen (E) then 5272 Result := No_List; 5273 goto Leave; 5274 5275 -- Do not freeze if we are preanalyzing without freezing 5276 5277 elsif Inside_Preanalysis_Without_Freezing > 0 then 5278 Result := No_List; 5279 goto Leave; 5280 5281 elsif Ekind (E) = E_Generic_Package then 5282 Result := Freeze_Generic_Entities (E); 5283 goto Leave; 5284 5285 -- It is improper to freeze an external entity within a generic because 5286 -- its freeze node will appear in a non-valid context. The entity will 5287 -- be frozen in the proper scope after the current generic is analyzed. 5288 -- However, aspects must be analyzed because they may be queried later 5289 -- within the generic itself, and the corresponding pragma or attribute 5290 -- definition has not been analyzed yet. After this, indicate that the 5291 -- entity has no further delayed aspects, to prevent a later aspect 5292 -- analysis out of the scope of the generic. 5293 5294 elsif Inside_A_Generic and then External_Ref_In_Generic (Test_E) then 5295 if Has_Delayed_Aspects (E) then 5296 Analyze_Aspects_At_Freeze_Point (E); 5297 Set_Has_Delayed_Aspects (E, False); 5298 end if; 5299 5300 Result := No_List; 5301 goto Leave; 5302 5303 -- AI05-0213: A formal incomplete type does not freeze the actual. In 5304 -- the instance, the same applies to the subtype renaming the actual. 5305 5306 elsif Is_Private_Type (E) 5307 and then Is_Generic_Actual_Type (E) 5308 and then No (Full_View (Base_Type (E))) 5309 and then Ada_Version >= Ada_2012 5310 then 5311 Result := No_List; 5312 goto Leave; 5313 5314 -- Formal subprograms are never frozen 5315 5316 elsif Is_Formal_Subprogram (E) then 5317 Result := No_List; 5318 goto Leave; 5319 5320 -- Generic types are never frozen as they lack delayed semantic checks 5321 5322 elsif Is_Generic_Type (E) then 5323 Result := No_List; 5324 goto Leave; 5325 5326 -- Do not freeze a global entity within an inner scope created during 5327 -- expansion. A call to subprogram E within some internal procedure 5328 -- (a stream attribute for example) might require freezing E, but the 5329 -- freeze node must appear in the same declarative part as E itself. 5330 -- The two-pass elaboration mechanism in gigi guarantees that E will 5331 -- be frozen before the inner call is elaborated. We exclude constants 5332 -- from this test, because deferred constants may be frozen early, and 5333 -- must be diagnosed (e.g. in the case of a deferred constant being used 5334 -- in a default expression). If the enclosing subprogram comes from 5335 -- source, or is a generic instance, then the freeze point is the one 5336 -- mandated by the language, and we freeze the entity. A subprogram that 5337 -- is a child unit body that acts as a spec does not have a spec that 5338 -- comes from source, but can only come from source. 5339 5340 elsif In_Open_Scopes (Scope (Test_E)) 5341 and then Scope (Test_E) /= Current_Scope 5342 and then Ekind (Test_E) /= E_Constant 5343 then 5344 declare 5345 S : Entity_Id; 5346 5347 begin 5348 S := Current_Scope; 5349 while Present (S) loop 5350 if Is_Overloadable (S) then 5351 if Comes_From_Source (S) 5352 or else Is_Generic_Instance (S) 5353 or else Is_Child_Unit (S) 5354 then 5355 exit; 5356 else 5357 Result := No_List; 5358 goto Leave; 5359 end if; 5360 end if; 5361 5362 S := Scope (S); 5363 end loop; 5364 end; 5365 5366 -- Similarly, an inlined instance body may make reference to global 5367 -- entities, but these references cannot be the proper freezing point 5368 -- for them, and in the absence of inlining freezing will take place in 5369 -- their own scope. Normally instance bodies are analyzed after the 5370 -- enclosing compilation, and everything has been frozen at the proper 5371 -- place, but with front-end inlining an instance body is compiled 5372 -- before the end of the enclosing scope, and as a result out-of-order 5373 -- freezing must be prevented. 5374 5375 elsif Front_End_Inlining 5376 and then In_Instance_Body 5377 and then Present (Scope (Test_E)) 5378 then 5379 declare 5380 S : Entity_Id; 5381 5382 begin 5383 S := Scope (Test_E); 5384 while Present (S) loop 5385 if Is_Generic_Instance (S) then 5386 exit; 5387 else 5388 S := Scope (S); 5389 end if; 5390 end loop; 5391 5392 if No (S) then 5393 Result := No_List; 5394 goto Leave; 5395 end if; 5396 end; 5397 end if; 5398 5399 -- Add checks to detect proper initialization of scalars that may appear 5400 -- as subprogram parameters. 5401 5402 if Is_Subprogram (E) and then Check_Validity_Of_Parameters then 5403 Apply_Parameter_Validity_Checks (E); 5404 end if; 5405 5406 -- Deal with delayed aspect specifications. The analysis of the aspect 5407 -- is required to be delayed to the freeze point, thus we analyze the 5408 -- pragma or attribute definition clause in the tree at this point. We 5409 -- also analyze the aspect specification node at the freeze point when 5410 -- the aspect doesn't correspond to pragma/attribute definition clause. 5411 -- In addition, a derived type may have inherited aspects that were 5412 -- delayed in the parent, so these must also be captured now. 5413 5414 -- For a record type, we deal with the delayed aspect specifications on 5415 -- components first, which is consistent with the non-delayed case and 5416 -- makes it possible to have a single processing to detect conflicts. 5417 5418 if Is_Record_Type (E) then 5419 declare 5420 Comp : Entity_Id; 5421 5422 Rec_Pushed : Boolean := False; 5423 -- Set True if the record type E has been pushed on the scope 5424 -- stack. Needed for the analysis of delayed aspects specified 5425 -- to the components of Rec. 5426 5427 begin 5428 Comp := First_Entity (E); 5429 while Present (Comp) loop 5430 if Ekind (Comp) = E_Component 5431 and then Has_Delayed_Aspects (Comp) 5432 then 5433 if not Rec_Pushed then 5434 Push_Scope (E); 5435 Rec_Pushed := True; 5436 5437 -- The visibility to the discriminants must be restored 5438 -- in order to properly analyze the aspects. 5439 5440 if Has_Discriminants (E) then 5441 Install_Discriminants (E); 5442 end if; 5443 end if; 5444 5445 Analyze_Aspects_At_Freeze_Point (Comp); 5446 end if; 5447 5448 Next_Entity (Comp); 5449 end loop; 5450 5451 -- Pop the scope if Rec scope has been pushed on the scope stack 5452 -- during the delayed aspect analysis process. 5453 5454 if Rec_Pushed then 5455 if Has_Discriminants (E) then 5456 Uninstall_Discriminants (E); 5457 end if; 5458 5459 Pop_Scope; 5460 end if; 5461 end; 5462 end if; 5463 5464 if Has_Delayed_Aspects (E) 5465 or else May_Inherit_Delayed_Rep_Aspects (E) 5466 then 5467 Analyze_Aspects_At_Freeze_Point (E); 5468 end if; 5469 5470 -- Here to freeze the entity 5471 5472 Set_Is_Frozen (E); 5473 5474 -- Case of entity being frozen is other than a type 5475 5476 if not Is_Type (E) then 5477 5478 -- If entity is exported or imported and does not have an external 5479 -- name, now is the time to provide the appropriate default name. 5480 -- Skip this if the entity is stubbed, since we don't need a name 5481 -- for any stubbed routine. For the case on intrinsics, if no 5482 -- external name is specified, then calls will be handled in 5483 -- Exp_Intr.Expand_Intrinsic_Call, and no name is needed. If an 5484 -- external name is provided, then Expand_Intrinsic_Call leaves 5485 -- calls in place for expansion by GIGI. 5486 5487 if (Is_Imported (E) or else Is_Exported (E)) 5488 and then No (Interface_Name (E)) 5489 and then Convention (E) /= Convention_Stubbed 5490 and then Convention (E) /= Convention_Intrinsic 5491 then 5492 Set_Encoded_Interface_Name 5493 (E, Get_Default_External_Name (E)); 5494 5495 -- If entity is an atomic object appearing in a declaration and 5496 -- the expression is an aggregate, assign it to a temporary to 5497 -- ensure that the actual assignment is done atomically rather 5498 -- than component-wise (the assignment to the temp may be done 5499 -- component-wise, but that is harmless). 5500 5501 elsif Is_Full_Access (E) 5502 and then Nkind (Parent (E)) = N_Object_Declaration 5503 and then Present (Expression (Parent (E))) 5504 and then Nkind (Expression (Parent (E))) = N_Aggregate 5505 and then Is_Full_Access_Aggregate (Expression (Parent (E))) 5506 then 5507 null; 5508 end if; 5509 5510 -- Subprogram case 5511 5512 if Is_Subprogram (E) then 5513 5514 -- Check for needing to wrap imported subprogram 5515 5516 Wrap_Imported_Subprogram (E); 5517 5518 -- Freeze all parameter types and the return type (RM 13.14(14)). 5519 -- However skip this for internal subprograms. This is also where 5520 -- any extra formal parameters are created since we now know 5521 -- whether the subprogram will use a foreign convention. 5522 5523 -- In Ada 2012, freezing a subprogram does not always freeze the 5524 -- corresponding profile (see AI05-019). An attribute reference 5525 -- is not a freezing point of the profile. Flag Do_Freeze_Profile 5526 -- indicates whether the profile should be frozen now. 5527 -- Other constructs that should not freeze ??? 5528 5529 -- This processing doesn't apply to internal entities (see below) 5530 5531 if not Is_Internal (E) and then Do_Freeze_Profile then 5532 if not Freeze_Profile (E) then 5533 goto Leave; 5534 end if; 5535 end if; 5536 5537 -- Must freeze its parent first if it is a derived subprogram 5538 5539 if Present (Alias (E)) then 5540 Freeze_And_Append (Alias (E), N, Result); 5541 end if; 5542 5543 -- We don't freeze internal subprograms, because we don't normally 5544 -- want addition of extra formals or mechanism setting to happen 5545 -- for those. However we do pass through predefined dispatching 5546 -- cases, since extra formals may be needed in some cases, such as 5547 -- for the stream 'Input function (build-in-place formals). 5548 5549 if not Is_Internal (E) 5550 or else Is_Predefined_Dispatching_Operation (E) 5551 then 5552 Freeze_Subprogram (E); 5553 end if; 5554 5555 -- If warning on suspicious contracts then check for the case of 5556 -- a postcondition other than False for a No_Return subprogram. 5557 5558 if No_Return (E) 5559 and then Warn_On_Suspicious_Contract 5560 and then Present (Contract (E)) 5561 then 5562 declare 5563 Prag : Node_Id := Pre_Post_Conditions (Contract (E)); 5564 Exp : Node_Id; 5565 5566 begin 5567 while Present (Prag) loop 5568 if Pragma_Name_Unmapped (Prag) in Name_Post 5569 | Name_Postcondition 5570 | Name_Refined_Post 5571 then 5572 Exp := 5573 Expression 5574 (First (Pragma_Argument_Associations (Prag))); 5575 5576 if Nkind (Exp) /= N_Identifier 5577 or else Chars (Exp) /= Name_False 5578 then 5579 Error_Msg_NE 5580 ("useless postcondition, & is marked " 5581 & "No_Return?T?", Exp, E); 5582 end if; 5583 end if; 5584 5585 Prag := Next_Pragma (Prag); 5586 end loop; 5587 end; 5588 end if; 5589 5590 -- Here for other than a subprogram or type 5591 5592 else 5593 -- If entity has a type, and it is not a generic unit, then freeze 5594 -- it first (RM 13.14(10)). 5595 5596 if Present (Etype (E)) 5597 and then Ekind (E) /= E_Generic_Function 5598 then 5599 Freeze_And_Append (Etype (E), N, Result); 5600 5601 -- For an object of an anonymous array type, aspects on the 5602 -- object declaration apply to the type itself. This is the 5603 -- case for Atomic_Components, Volatile_Components, and 5604 -- Independent_Components. In these cases analysis of the 5605 -- generated pragma will mark the anonymous types accordingly, 5606 -- and the object itself does not require a freeze node. 5607 5608 if Ekind (E) = E_Variable 5609 and then Is_Itype (Etype (E)) 5610 and then Is_Array_Type (Etype (E)) 5611 and then Has_Delayed_Aspects (E) 5612 then 5613 Set_Has_Delayed_Aspects (E, False); 5614 Set_Has_Delayed_Freeze (E, False); 5615 Set_Freeze_Node (E, Empty); 5616 end if; 5617 end if; 5618 5619 -- Special processing for objects created by object declaration 5620 5621 if Nkind (Declaration_Node (E)) = N_Object_Declaration then 5622 Freeze_Object_Declaration (E); 5623 end if; 5624 5625 -- Check that a constant which has a pragma Volatile[_Components] 5626 -- or Atomic[_Components] also has a pragma Import (RM C.6(13)). 5627 5628 -- Note: Atomic[_Components] also sets Volatile[_Components] 5629 5630 if Ekind (E) = E_Constant 5631 and then (Has_Volatile_Components (E) or else Is_Volatile (E)) 5632 and then not Is_Imported (E) 5633 and then not Has_Boolean_Aspect_Import (E) 5634 then 5635 -- Make sure we actually have a pragma, and have not merely 5636 -- inherited the indication from elsewhere (e.g. an address 5637 -- clause, which is not good enough in RM terms). 5638 5639 if Has_Rep_Pragma (E, Name_Atomic) 5640 or else 5641 Has_Rep_Pragma (E, Name_Atomic_Components) 5642 then 5643 Error_Msg_N 5644 ("standalone atomic constant must be " & 5645 "imported (RM C.6(13))", E); 5646 5647 elsif Has_Rep_Pragma (E, Name_Volatile) 5648 or else 5649 Has_Rep_Pragma (E, Name_Volatile_Components) 5650 then 5651 Error_Msg_N 5652 ("standalone volatile constant must be " & 5653 "imported (RM C.6(13))", E); 5654 end if; 5655 end if; 5656 5657 -- Static objects require special handling 5658 5659 if (Ekind (E) = E_Constant or else Ekind (E) = E_Variable) 5660 and then Is_Statically_Allocated (E) 5661 then 5662 Freeze_Static_Object (E); 5663 end if; 5664 5665 -- Remaining step is to layout objects 5666 5667 if Ekind (E) in E_Variable | E_Constant | E_Loop_Parameter 5668 or else Is_Formal (E) 5669 then 5670 Layout_Object (E); 5671 end if; 5672 5673 -- For an object that does not have delayed freezing, and whose 5674 -- initialization actions have been captured in a compound 5675 -- statement, move them back now directly within the enclosing 5676 -- statement sequence. 5677 5678 if Ekind (E) in E_Constant | E_Variable 5679 and then not Has_Delayed_Freeze (E) 5680 then 5681 Explode_Initialization_Compound_Statement (E); 5682 end if; 5683 5684 -- Do not generate a freeze node for a generic unit 5685 5686 if Is_Generic_Unit (E) then 5687 Result := No_List; 5688 goto Leave; 5689 end if; 5690 end if; 5691 5692 -- Case of a type or subtype being frozen 5693 5694 else 5695 -- Verify several SPARK legality rules related to Ghost types now 5696 -- that the type is frozen. 5697 5698 Check_Ghost_Type (E); 5699 5700 -- We used to check here that a full type must have preelaborable 5701 -- initialization if it completes a private type specified with 5702 -- pragma Preelaborable_Initialization, but that missed cases where 5703 -- the types occur within a generic package, since the freezing 5704 -- that occurs within a containing scope generally skips traversal 5705 -- of a generic unit's declarations (those will be frozen within 5706 -- instances). This check was moved to Analyze_Package_Specification. 5707 5708 -- The type may be defined in a generic unit. This can occur when 5709 -- freezing a generic function that returns the type (which is 5710 -- defined in a parent unit). It is clearly meaningless to freeze 5711 -- this type. However, if it is a subtype, its size may be determi- 5712 -- nable and used in subsequent checks, so might as well try to 5713 -- compute it. 5714 5715 -- In Ada 2012, Freeze_Entities is also used in the front end to 5716 -- trigger the analysis of aspect expressions, so in this case we 5717 -- want to continue the freezing process. 5718 5719 -- Is_Generic_Unit (Scope (E)) is dubious here, do we want instead 5720 -- In_Generic_Scope (E)??? 5721 5722 if Present (Scope (E)) 5723 and then Is_Generic_Unit (Scope (E)) 5724 and then 5725 (not Has_Predicates (E) 5726 and then not Has_Delayed_Freeze (E)) 5727 then 5728 Check_Compile_Time_Size (E); 5729 Result := No_List; 5730 goto Leave; 5731 end if; 5732 5733 -- Check for error of Type_Invariant'Class applied to an untagged 5734 -- type (check delayed to freeze time when full type is available). 5735 5736 declare 5737 Prag : constant Node_Id := Get_Pragma (E, Pragma_Invariant); 5738 begin 5739 if Present (Prag) 5740 and then Class_Present (Prag) 5741 and then not Is_Tagged_Type (E) 5742 then 5743 Error_Msg_NE 5744 ("Type_Invariant''Class cannot be specified for &", Prag, E); 5745 Error_Msg_N 5746 ("\can only be specified for a tagged type", Prag); 5747 end if; 5748 end; 5749 5750 -- Deal with special cases of freezing for subtype 5751 5752 if E /= Base_Type (E) then 5753 5754 -- Before we do anything else, a specific test for the case of a 5755 -- size given for an array where the array would need to be packed 5756 -- in order for the size to be honored, but is not. This is the 5757 -- case where implicit packing may apply. The reason we do this so 5758 -- early is that, if we have implicit packing, the layout of the 5759 -- base type is affected, so we must do this before we freeze the 5760 -- base type. 5761 5762 -- We could do this processing only if implicit packing is enabled 5763 -- since in all other cases, the error would be caught by the back 5764 -- end. However, we choose to do the check even if we do not have 5765 -- implicit packing enabled, since this allows us to give a more 5766 -- useful error message (advising use of pragma Implicit_Packing 5767 -- or pragma Pack). 5768 5769 if Is_Array_Type (E) then 5770 declare 5771 Ctyp : constant Entity_Id := Component_Type (E); 5772 Rsiz : constant Uint := RM_Size (Ctyp); 5773 SZ : constant Node_Id := Size_Clause (E); 5774 Btyp : constant Entity_Id := Base_Type (E); 5775 5776 Lo : Node_Id; 5777 Hi : Node_Id; 5778 Indx : Node_Id; 5779 5780 Dim : Uint; 5781 Num_Elmts : Uint := Uint_1; 5782 -- Number of elements in array 5783 5784 begin 5785 -- Check enabling conditions. These are straightforward 5786 -- except for the test for a limited composite type. This 5787 -- eliminates the rare case of a array of limited components 5788 -- where there are issues of whether or not we can go ahead 5789 -- and pack the array (since we can't freely pack and unpack 5790 -- arrays if they are limited). 5791 5792 -- Note that we check the root type explicitly because the 5793 -- whole point is we are doing this test before we have had 5794 -- a chance to freeze the base type (and it is that freeze 5795 -- action that causes stuff to be inherited). 5796 5797 -- The conditions on the size are identical to those used in 5798 -- Freeze_Array_Type to set the Is_Packed flag. 5799 5800 if Has_Size_Clause (E) 5801 and then Known_Static_RM_Size (E) 5802 and then not Is_Packed (E) 5803 and then not Has_Pragma_Pack (E) 5804 and then not Has_Component_Size_Clause (E) 5805 and then Known_Static_RM_Size (Ctyp) 5806 and then Rsiz <= System_Max_Integer_Size 5807 and then not (Addressable (Rsiz) 5808 and then Known_Static_Esize (Ctyp) 5809 and then Esize (Ctyp) = Rsiz) 5810 and then not (Rsiz mod System_Storage_Unit = 0 5811 and then Is_Composite_Type (Ctyp)) 5812 and then not Is_Limited_Composite (E) 5813 and then not Is_Packed (Root_Type (E)) 5814 and then not Has_Component_Size_Clause (Root_Type (E)) 5815 and then not (CodePeer_Mode or GNATprove_Mode) 5816 then 5817 -- Compute number of elements in array 5818 5819 Indx := First_Index (E); 5820 while Present (Indx) loop 5821 Get_Index_Bounds (Indx, Lo, Hi); 5822 5823 if not (Compile_Time_Known_Value (Lo) 5824 and then 5825 Compile_Time_Known_Value (Hi)) 5826 then 5827 goto No_Implicit_Packing; 5828 end if; 5829 5830 Dim := Expr_Value (Hi) - Expr_Value (Lo) + 1; 5831 5832 if Dim >= 0 then 5833 Num_Elmts := Num_Elmts * Dim; 5834 else 5835 Num_Elmts := Uint_0; 5836 end if; 5837 5838 Next_Index (Indx); 5839 end loop; 5840 5841 -- What we are looking for here is the situation where 5842 -- the RM_Size given would be exactly right if there was 5843 -- a pragma Pack, resulting in the component size being 5844 -- the RM_Size of the component type. 5845 5846 if RM_Size (E) = Num_Elmts * Rsiz then 5847 5848 -- For implicit packing mode, just set the component 5849 -- size and Freeze_Array_Type will do the rest. 5850 5851 if Implicit_Packing then 5852 Set_Component_Size (Btyp, Rsiz); 5853 5854 -- Otherwise give an error message 5855 5856 else 5857 Error_Msg_NE 5858 ("size given for& too small", SZ, E); 5859 Error_Msg_N -- CODEFIX 5860 ("\use explicit pragma Pack or use pragma " 5861 & "Implicit_Packing", SZ); 5862 end if; 5863 end if; 5864 end if; 5865 end; 5866 end if; 5867 5868 <<No_Implicit_Packing>> 5869 5870 -- If ancestor subtype present, freeze that first. Note that this 5871 -- will also get the base type frozen. Need RM reference ??? 5872 5873 Atype := Ancestor_Subtype (E); 5874 5875 if Present (Atype) then 5876 Freeze_And_Append (Atype, N, Result); 5877 5878 -- No ancestor subtype present 5879 5880 else 5881 -- See if we have a nearest ancestor that has a predicate. 5882 -- That catches the case of derived type with a predicate. 5883 -- Need RM reference here ??? 5884 5885 Atype := Nearest_Ancestor (E); 5886 5887 if Present (Atype) and then Has_Predicates (Atype) then 5888 Freeze_And_Append (Atype, N, Result); 5889 end if; 5890 5891 -- Freeze base type before freezing the entity (RM 13.14(15)) 5892 5893 if E /= Base_Type (E) then 5894 Freeze_And_Append (Base_Type (E), N, Result); 5895 end if; 5896 end if; 5897 5898 -- A subtype inherits all the type-related representation aspects 5899 -- from its parents (RM 13.1(8)). 5900 5901 Inherit_Aspects_At_Freeze_Point (E); 5902 5903 -- For a derived type, freeze its parent type first (RM 13.14(15)) 5904 5905 elsif Is_Derived_Type (E) then 5906 Freeze_And_Append (Etype (E), N, Result); 5907 Freeze_And_Append (First_Subtype (Etype (E)), N, Result); 5908 5909 -- A derived type inherits each type-related representation aspect 5910 -- of its parent type that was directly specified before the 5911 -- declaration of the derived type (RM 13.1(15)). 5912 5913 Inherit_Aspects_At_Freeze_Point (E); 5914 end if; 5915 5916 -- Case of array type 5917 5918 if Is_Array_Type (E) then 5919 Freeze_Array_Type (E); 5920 end if; 5921 5922 -- Check for incompatible size and alignment for array/record type 5923 5924 if Warn_On_Size_Alignment 5925 and then (Is_Array_Type (E) or else Is_Record_Type (E)) 5926 and then Has_Size_Clause (E) 5927 and then Has_Alignment_Clause (E) 5928 5929 -- If explicit Object_Size clause given assume that the programmer 5930 -- knows what he is doing, and expects the compiler behavior. 5931 5932 and then not Has_Object_Size_Clause (E) 5933 5934 -- It does not really make sense to warn for the minimum alignment 5935 -- since the programmer could not get rid of the warning. 5936 5937 and then Alignment (E) > 1 5938 5939 -- Check for size not a multiple of alignment 5940 5941 and then RM_Size (E) mod (Alignment (E) * System_Storage_Unit) /= 0 5942 then 5943 declare 5944 SC : constant Node_Id := Size_Clause (E); 5945 AC : constant Node_Id := Alignment_Clause (E); 5946 Loc : Node_Id; 5947 Abits : constant Uint := Alignment (E) * System_Storage_Unit; 5948 5949 begin 5950 if Present (SC) and then Present (AC) then 5951 5952 -- Give a warning 5953 5954 if Sloc (SC) > Sloc (AC) then 5955 Loc := SC; 5956 Error_Msg_NE 5957 ("?Z?size is not a multiple of alignment for &", 5958 Loc, E); 5959 Error_Msg_Sloc := Sloc (AC); 5960 Error_Msg_Uint_1 := Alignment (E); 5961 Error_Msg_N ("\?Z?alignment of ^ specified #", Loc); 5962 5963 else 5964 Loc := AC; 5965 Error_Msg_NE 5966 ("?Z?size is not a multiple of alignment for &", 5967 Loc, E); 5968 Error_Msg_Sloc := Sloc (SC); 5969 Error_Msg_Uint_1 := RM_Size (E); 5970 Error_Msg_N ("\?Z?size of ^ specified #", Loc); 5971 end if; 5972 5973 Error_Msg_Uint_1 := ((RM_Size (E) / Abits) + 1) * Abits; 5974 Error_Msg_N ("\?Z?Object_Size will be increased to ^", Loc); 5975 end if; 5976 end; 5977 end if; 5978 5979 -- For a class-wide type, the corresponding specific type is 5980 -- frozen as well (RM 13.14(15)) 5981 5982 if Is_Class_Wide_Type (E) then 5983 Freeze_And_Append (Root_Type (E), N, Result); 5984 5985 -- If the base type of the class-wide type is still incomplete, 5986 -- the class-wide remains unfrozen as well. This is legal when 5987 -- E is the formal of a primitive operation of some other type 5988 -- which is being frozen. 5989 5990 if not Is_Frozen (Root_Type (E)) then 5991 Set_Is_Frozen (E, False); 5992 goto Leave; 5993 end if; 5994 5995 -- The equivalent type associated with a class-wide subtype needs 5996 -- to be frozen to ensure that its layout is done. 5997 5998 if Ekind (E) = E_Class_Wide_Subtype 5999 and then Present (Equivalent_Type (E)) 6000 then 6001 Freeze_And_Append (Equivalent_Type (E), N, Result); 6002 end if; 6003 6004 -- Generate an itype reference for a library-level class-wide type 6005 -- at the freeze point. Otherwise the first explicit reference to 6006 -- the type may appear in an inner scope which will be rejected by 6007 -- the back-end. 6008 6009 if Is_Itype (E) 6010 and then Is_Compilation_Unit (Scope (E)) 6011 then 6012 declare 6013 Ref : constant Node_Id := Make_Itype_Reference (Loc); 6014 6015 begin 6016 Set_Itype (Ref, E); 6017 6018 -- From a gigi point of view, a class-wide subtype derives 6019 -- from its record equivalent type. As a result, the itype 6020 -- reference must appear after the freeze node of the 6021 -- equivalent type or gigi will reject the reference. 6022 6023 if Ekind (E) = E_Class_Wide_Subtype 6024 and then Present (Equivalent_Type (E)) 6025 then 6026 Insert_After (Freeze_Node (Equivalent_Type (E)), Ref); 6027 else 6028 Add_To_Result (Ref); 6029 end if; 6030 end; 6031 end if; 6032 6033 -- For a record type or record subtype, freeze all component types 6034 -- (RM 13.14(15)). We test for E_Record_(sub)Type here, rather than 6035 -- using Is_Record_Type, because we don't want to attempt the freeze 6036 -- for the case of a private type with record extension (we will do 6037 -- that later when the full type is frozen). 6038 6039 elsif Ekind (E) in E_Record_Type | E_Record_Subtype then 6040 if not In_Generic_Scope (E) then 6041 Freeze_Record_Type (E); 6042 end if; 6043 6044 -- Report a warning if a discriminated record base type has a 6045 -- convention with language C or C++ applied to it. This check is 6046 -- done even within generic scopes (but not in instantiations), 6047 -- which is why we don't do it as part of Freeze_Record_Type. 6048 6049 Check_Suspicious_Convention (E); 6050 6051 -- For a concurrent type, freeze corresponding record type. This does 6052 -- not correspond to any specific rule in the RM, but the record type 6053 -- is essentially part of the concurrent type. Also freeze all local 6054 -- entities. This includes record types created for entry parameter 6055 -- blocks and whatever local entities may appear in the private part. 6056 6057 elsif Is_Concurrent_Type (E) then 6058 if Present (Corresponding_Record_Type (E)) then 6059 Freeze_And_Append (Corresponding_Record_Type (E), N, Result); 6060 end if; 6061 6062 Comp := First_Entity (E); 6063 while Present (Comp) loop 6064 if Is_Type (Comp) then 6065 Freeze_And_Append (Comp, N, Result); 6066 6067 elsif (Ekind (Comp)) /= E_Function then 6068 6069 -- The guard on the presence of the Etype seems to be needed 6070 -- for some CodePeer (-gnatcC) cases, but not clear why??? 6071 6072 if Present (Etype (Comp)) then 6073 if Is_Itype (Etype (Comp)) 6074 and then Underlying_Type (Scope (Etype (Comp))) = E 6075 then 6076 Undelay_Type (Etype (Comp)); 6077 end if; 6078 6079 Freeze_And_Append (Etype (Comp), N, Result); 6080 end if; 6081 end if; 6082 6083 Next_Entity (Comp); 6084 end loop; 6085 6086 -- Private types are required to point to the same freeze node as 6087 -- their corresponding full views. The freeze node itself has to 6088 -- point to the partial view of the entity (because from the partial 6089 -- view, we can retrieve the full view, but not the reverse). 6090 -- However, in order to freeze correctly, we need to freeze the full 6091 -- view. If we are freezing at the end of a scope (or within the 6092 -- scope) of the private type, the partial and full views will have 6093 -- been swapped, the full view appears first in the entity chain and 6094 -- the swapping mechanism ensures that the pointers are properly set 6095 -- (on scope exit). 6096 6097 -- If we encounter the partial view before the full view (e.g. when 6098 -- freezing from another scope), we freeze the full view, and then 6099 -- set the pointers appropriately since we cannot rely on swapping to 6100 -- fix things up (subtypes in an outer scope might not get swapped). 6101 6102 -- If the full view is itself private, the above requirements apply 6103 -- to the underlying full view instead of the full view. But there is 6104 -- no swapping mechanism for the underlying full view so we need to 6105 -- set the pointers appropriately in both cases. 6106 6107 elsif Is_Incomplete_Or_Private_Type (E) 6108 and then not Is_Generic_Type (E) 6109 then 6110 -- The construction of the dispatch table associated with library 6111 -- level tagged types forces freezing of all the primitives of the 6112 -- type, which may cause premature freezing of the partial view. 6113 -- For example: 6114 6115 -- package Pkg is 6116 -- type T is tagged private; 6117 -- type DT is new T with private; 6118 -- procedure Prim (X : in out T; Y : in out DT'Class); 6119 -- private 6120 -- type T is tagged null record; 6121 -- Obj : T; 6122 -- type DT is new T with null record; 6123 -- end; 6124 6125 -- In this case the type will be frozen later by the usual 6126 -- mechanism: an object declaration, an instantiation, or the 6127 -- end of a declarative part. 6128 6129 if Is_Library_Level_Tagged_Type (E) 6130 and then not Present (Full_View (E)) 6131 then 6132 Set_Is_Frozen (E, False); 6133 goto Leave; 6134 6135 -- Case of full view present 6136 6137 elsif Present (Full_View (E)) then 6138 6139 -- If full view has already been frozen, then no further 6140 -- processing is required 6141 6142 if Is_Frozen (Full_View (E)) then 6143 Set_Has_Delayed_Freeze (E, False); 6144 Set_Freeze_Node (E, Empty); 6145 6146 -- Otherwise freeze full view and patch the pointers so that 6147 -- the freeze node will elaborate both views in the back end. 6148 -- However, if full view is itself private, freeze underlying 6149 -- full view instead and patch the pointers so that the freeze 6150 -- node will elaborate the three views in the back end. 6151 6152 else 6153 declare 6154 Full : Entity_Id := Full_View (E); 6155 6156 begin 6157 if Is_Private_Type (Full) 6158 and then Present (Underlying_Full_View (Full)) 6159 then 6160 Full := Underlying_Full_View (Full); 6161 end if; 6162 6163 Freeze_And_Append (Full, N, Result); 6164 6165 if Full /= Full_View (E) 6166 and then Has_Delayed_Freeze (Full_View (E)) 6167 then 6168 F_Node := Freeze_Node (Full); 6169 6170 if Present (F_Node) then 6171 Inherit_Freeze_Node 6172 (Fnod => F_Node, Typ => Full_View (E)); 6173 else 6174 Set_Has_Delayed_Freeze (Full_View (E), False); 6175 Set_Freeze_Node (Full_View (E), Empty); 6176 end if; 6177 end if; 6178 6179 if Has_Delayed_Freeze (E) then 6180 F_Node := Freeze_Node (Full_View (E)); 6181 6182 if Present (F_Node) then 6183 Inherit_Freeze_Node (Fnod => F_Node, Typ => E); 6184 else 6185 -- {Incomplete,Private}_Subtypes with Full_Views 6186 -- constrained by discriminants. 6187 6188 Set_Has_Delayed_Freeze (E, False); 6189 Set_Freeze_Node (E, Empty); 6190 end if; 6191 end if; 6192 end; 6193 end if; 6194 6195 Check_Debug_Info_Needed (E); 6196 6197 -- AI-117 requires that the convention of a partial view be the 6198 -- same as the convention of the full view. Note that this is a 6199 -- recognized breach of privacy, but it's essential for logical 6200 -- consistency of representation, and the lack of a rule in 6201 -- RM95 was an oversight. 6202 6203 Set_Convention (E, Convention (Full_View (E))); 6204 6205 Set_Size_Known_At_Compile_Time (E, 6206 Size_Known_At_Compile_Time (Full_View (E))); 6207 6208 -- Size information is copied from the full view to the 6209 -- incomplete or private view for consistency. 6210 6211 -- We skip this is the full view is not a type. This is very 6212 -- strange of course, and can only happen as a result of 6213 -- certain illegalities, such as a premature attempt to derive 6214 -- from an incomplete type. 6215 6216 if Is_Type (Full_View (E)) then 6217 Set_Size_Info (E, Full_View (E)); 6218 Set_RM_Size (E, RM_Size (Full_View (E))); 6219 end if; 6220 6221 goto Leave; 6222 6223 -- Case of underlying full view present 6224 6225 elsif Is_Private_Type (E) 6226 and then Present (Underlying_Full_View (E)) 6227 then 6228 if not Is_Frozen (Underlying_Full_View (E)) then 6229 Freeze_And_Append (Underlying_Full_View (E), N, Result); 6230 end if; 6231 6232 -- Patch the pointers so that the freeze node will elaborate 6233 -- both views in the back end. 6234 6235 if Has_Delayed_Freeze (E) then 6236 F_Node := Freeze_Node (Underlying_Full_View (E)); 6237 6238 if Present (F_Node) then 6239 Inherit_Freeze_Node 6240 (Fnod => F_Node, 6241 Typ => E); 6242 else 6243 Set_Has_Delayed_Freeze (E, False); 6244 Set_Freeze_Node (E, Empty); 6245 end if; 6246 end if; 6247 6248 Check_Debug_Info_Needed (E); 6249 6250 goto Leave; 6251 6252 -- Case of no full view present. If entity is subtype or derived, 6253 -- it is safe to freeze, correctness depends on the frozen status 6254 -- of parent. Otherwise it is either premature usage, or a Taft 6255 -- amendment type, so diagnosis is at the point of use and the 6256 -- type might be frozen later. 6257 6258 elsif E /= Base_Type (E) then 6259 declare 6260 Btyp : constant Entity_Id := Base_Type (E); 6261 6262 begin 6263 -- However, if the base type is itself private and has no 6264 -- (underlying) full view either, wait until the full type 6265 -- declaration is seen and all the full views are created. 6266 6267 if Is_Private_Type (Btyp) 6268 and then No (Full_View (Btyp)) 6269 and then No (Underlying_Full_View (Btyp)) 6270 and then Has_Delayed_Freeze (Btyp) 6271 and then No (Freeze_Node (Btyp)) 6272 then 6273 Set_Is_Frozen (E, False); 6274 Result := No_List; 6275 goto Leave; 6276 end if; 6277 end; 6278 6279 elsif Is_Derived_Type (E) then 6280 null; 6281 6282 else 6283 Set_Is_Frozen (E, False); 6284 Result := No_List; 6285 goto Leave; 6286 end if; 6287 6288 -- For access subprogram, freeze types of all formals, the return 6289 -- type was already frozen, since it is the Etype of the function. 6290 -- Formal types can be tagged Taft amendment types, but otherwise 6291 -- they cannot be incomplete. 6292 6293 elsif Ekind (E) = E_Subprogram_Type then 6294 Formal := First_Formal (E); 6295 while Present (Formal) loop 6296 if Ekind (Etype (Formal)) = E_Incomplete_Type 6297 and then No (Full_View (Etype (Formal))) 6298 then 6299 if Is_Tagged_Type (Etype (Formal)) then 6300 null; 6301 6302 -- AI05-151: Incomplete types are allowed in access to 6303 -- subprogram specifications. 6304 6305 elsif Ada_Version < Ada_2012 then 6306 Error_Msg_NE 6307 ("invalid use of incomplete type&", E, Etype (Formal)); 6308 end if; 6309 end if; 6310 6311 Freeze_And_Append (Etype (Formal), N, Result); 6312 Next_Formal (Formal); 6313 end loop; 6314 6315 Freeze_Subprogram (E); 6316 6317 -- For access to a protected subprogram, freeze the equivalent type 6318 -- (however this is not set if we are not generating code or if this 6319 -- is an anonymous type used just for resolution). 6320 6321 elsif Is_Access_Protected_Subprogram_Type (E) then 6322 if Present (Equivalent_Type (E)) then 6323 Freeze_And_Append (Equivalent_Type (E), N, Result); 6324 end if; 6325 end if; 6326 6327 -- Generic types are never seen by the back-end, and are also not 6328 -- processed by the expander (since the expander is turned off for 6329 -- generic processing), so we never need freeze nodes for them. 6330 6331 if Is_Generic_Type (E) then 6332 goto Leave; 6333 end if; 6334 6335 -- Some special processing for non-generic types to complete 6336 -- representation details not known till the freeze point. 6337 6338 if Is_Fixed_Point_Type (E) then 6339 Freeze_Fixed_Point_Type (E); 6340 6341 elsif Is_Enumeration_Type (E) then 6342 Freeze_Enumeration_Type (E); 6343 6344 elsif Is_Integer_Type (E) then 6345 Adjust_Esize_For_Alignment (E); 6346 6347 if Is_Modular_Integer_Type (E) 6348 and then Warn_On_Suspicious_Modulus_Value 6349 then 6350 Check_Suspicious_Modulus (E); 6351 end if; 6352 6353 -- The pool applies to named and anonymous access types, but not 6354 -- to subprogram and to internal types generated for 'Access 6355 -- references. 6356 6357 elsif Is_Access_Object_Type (E) 6358 and then Ekind (E) /= E_Access_Attribute_Type 6359 then 6360 -- If a pragma Default_Storage_Pool applies, and this type has no 6361 -- Storage_Pool or Storage_Size clause (which must have occurred 6362 -- before the freezing point), then use the default. This applies 6363 -- only to base types. 6364 6365 -- None of this applies to access to subprograms, for which there 6366 -- are clearly no pools. 6367 6368 if Present (Default_Pool) 6369 and then Is_Base_Type (E) 6370 and then not Has_Storage_Size_Clause (E) 6371 and then No (Associated_Storage_Pool (E)) 6372 then 6373 -- Case of pragma Default_Storage_Pool (null) 6374 6375 if Nkind (Default_Pool) = N_Null then 6376 Set_No_Pool_Assigned (E); 6377 6378 -- Case of pragma Default_Storage_Pool (Standard) 6379 6380 elsif Entity (Default_Pool) = Standard_Standard then 6381 Set_Associated_Storage_Pool (E, RTE (RE_Global_Pool_Object)); 6382 6383 -- Case of pragma Default_Storage_Pool (storage_pool_NAME) 6384 6385 else 6386 Set_Associated_Storage_Pool (E, Entity (Default_Pool)); 6387 end if; 6388 end if; 6389 6390 -- Check restriction for standard storage pool 6391 6392 if No (Associated_Storage_Pool (E)) then 6393 Check_Restriction (No_Standard_Storage_Pools, E); 6394 end if; 6395 6396 -- Deal with error message for pure access type. This is not an 6397 -- error in Ada 2005 if there is no pool (see AI-366). 6398 6399 if Is_Pure_Unit_Access_Type (E) 6400 and then (Ada_Version < Ada_2005 6401 or else not No_Pool_Assigned (E)) 6402 and then not Is_Generic_Unit (Scope (E)) 6403 then 6404 Error_Msg_N ("named access type not allowed in pure unit", E); 6405 6406 if Ada_Version >= Ada_2005 then 6407 Error_Msg_N 6408 ("\would be legal if Storage_Size of 0 given??", E); 6409 6410 elsif No_Pool_Assigned (E) then 6411 Error_Msg_N 6412 ("\would be legal in Ada 2005??", E); 6413 6414 else 6415 Error_Msg_N 6416 ("\would be legal in Ada 2005 if " 6417 & "Storage_Size of 0 given??", E); 6418 end if; 6419 end if; 6420 end if; 6421 6422 -- Case of composite types 6423 6424 if Is_Composite_Type (E) then 6425 6426 -- AI-117 requires that all new primitives of a tagged type must 6427 -- inherit the convention of the full view of the type. Inherited 6428 -- and overriding operations are defined to inherit the convention 6429 -- of their parent or overridden subprogram (also specified in 6430 -- AI-117), which will have occurred earlier (in Derive_Subprogram 6431 -- and New_Overloaded_Entity). Here we set the convention of 6432 -- primitives that are still convention Ada, which will ensure 6433 -- that any new primitives inherit the type's convention. Class- 6434 -- wide types can have a foreign convention inherited from their 6435 -- specific type, but are excluded from this since they don't have 6436 -- any associated primitives. 6437 6438 if Is_Tagged_Type (E) 6439 and then not Is_Class_Wide_Type (E) 6440 and then Convention (E) /= Convention_Ada 6441 then 6442 declare 6443 Prim_List : constant Elist_Id := Primitive_Operations (E); 6444 Prim : Elmt_Id; 6445 6446 begin 6447 Prim := First_Elmt (Prim_List); 6448 while Present (Prim) loop 6449 if Convention (Node (Prim)) = Convention_Ada then 6450 Set_Convention (Node (Prim), Convention (E)); 6451 end if; 6452 6453 Next_Elmt (Prim); 6454 end loop; 6455 end; 6456 end if; 6457 6458 -- If the type is a simple storage pool type, then this is where 6459 -- we attempt to locate and validate its Allocate, Deallocate, and 6460 -- Storage_Size operations (the first is required, and the latter 6461 -- two are optional). We also verify that the full type for a 6462 -- private type is allowed to be a simple storage pool type. 6463 6464 if Present (Get_Rep_Pragma (E, Name_Simple_Storage_Pool_Type)) 6465 and then (Is_Base_Type (E) or else Has_Private_Declaration (E)) 6466 then 6467 -- If the type is marked Has_Private_Declaration, then this is 6468 -- a full type for a private type that was specified with the 6469 -- pragma Simple_Storage_Pool_Type, and here we ensure that the 6470 -- pragma is allowed for the full type (for example, it can't 6471 -- be an array type, or a nonlimited record type). 6472 6473 if Has_Private_Declaration (E) then 6474 if (not Is_Record_Type (E) or else not Is_Limited_View (E)) 6475 and then not Is_Private_Type (E) 6476 then 6477 Error_Msg_Name_1 := Name_Simple_Storage_Pool_Type; 6478 Error_Msg_N 6479 ("pragma% can only apply to full type that is an " & 6480 "explicitly limited type", E); 6481 end if; 6482 end if; 6483 6484 Validate_Simple_Pool_Ops : declare 6485 Pool_Type : Entity_Id renames E; 6486 Address_Type : constant Entity_Id := RTE (RE_Address); 6487 Stg_Cnt_Type : constant Entity_Id := RTE (RE_Storage_Count); 6488 6489 procedure Validate_Simple_Pool_Op_Formal 6490 (Pool_Op : Entity_Id; 6491 Pool_Op_Formal : in out Entity_Id; 6492 Expected_Mode : Formal_Kind; 6493 Expected_Type : Entity_Id; 6494 Formal_Name : String; 6495 OK_Formal : in out Boolean); 6496 -- Validate one formal Pool_Op_Formal of the candidate pool 6497 -- operation Pool_Op. The formal must be of Expected_Type 6498 -- and have mode Expected_Mode. OK_Formal will be set to 6499 -- False if the formal doesn't match. If OK_Formal is False 6500 -- on entry, then the formal will effectively be ignored 6501 -- (because validation of the pool op has already failed). 6502 -- Upon return, Pool_Op_Formal will be updated to the next 6503 -- formal, if any. 6504 6505 procedure Validate_Simple_Pool_Operation 6506 (Op_Name : Name_Id); 6507 -- Search for and validate a simple pool operation with the 6508 -- name Op_Name. If the name is Allocate, then there must be 6509 -- exactly one such primitive operation for the simple pool 6510 -- type. If the name is Deallocate or Storage_Size, then 6511 -- there can be at most one such primitive operation. The 6512 -- profile of the located primitive must conform to what 6513 -- is expected for each operation. 6514 6515 ------------------------------------ 6516 -- Validate_Simple_Pool_Op_Formal -- 6517 ------------------------------------ 6518 6519 procedure Validate_Simple_Pool_Op_Formal 6520 (Pool_Op : Entity_Id; 6521 Pool_Op_Formal : in out Entity_Id; 6522 Expected_Mode : Formal_Kind; 6523 Expected_Type : Entity_Id; 6524 Formal_Name : String; 6525 OK_Formal : in out Boolean) 6526 is 6527 begin 6528 -- If OK_Formal is False on entry, then simply ignore 6529 -- the formal, because an earlier formal has already 6530 -- been flagged. 6531 6532 if not OK_Formal then 6533 return; 6534 6535 -- If no formal is passed in, then issue an error for a 6536 -- missing formal. 6537 6538 elsif not Present (Pool_Op_Formal) then 6539 Error_Msg_NE 6540 ("simple storage pool op missing formal " & 6541 Formal_Name & " of type&", Pool_Op, Expected_Type); 6542 OK_Formal := False; 6543 6544 return; 6545 end if; 6546 6547 if Etype (Pool_Op_Formal) /= Expected_Type then 6548 6549 -- If the pool type was expected for this formal, then 6550 -- this will not be considered a candidate operation 6551 -- for the simple pool, so we unset OK_Formal so that 6552 -- the op and any later formals will be ignored. 6553 6554 if Expected_Type = Pool_Type then 6555 OK_Formal := False; 6556 6557 return; 6558 6559 else 6560 Error_Msg_NE 6561 ("wrong type for formal " & Formal_Name & 6562 " of simple storage pool op; expected type&", 6563 Pool_Op_Formal, Expected_Type); 6564 end if; 6565 end if; 6566 6567 -- Issue error if formal's mode is not the expected one 6568 6569 if Ekind (Pool_Op_Formal) /= Expected_Mode then 6570 Error_Msg_N 6571 ("wrong mode for formal of simple storage pool op", 6572 Pool_Op_Formal); 6573 end if; 6574 6575 -- Advance to the next formal 6576 6577 Next_Formal (Pool_Op_Formal); 6578 end Validate_Simple_Pool_Op_Formal; 6579 6580 ------------------------------------ 6581 -- Validate_Simple_Pool_Operation -- 6582 ------------------------------------ 6583 6584 procedure Validate_Simple_Pool_Operation 6585 (Op_Name : Name_Id) 6586 is 6587 Op : Entity_Id; 6588 Found_Op : Entity_Id := Empty; 6589 Formal : Entity_Id; 6590 Is_OK : Boolean; 6591 6592 begin 6593 pragma Assert 6594 (Op_Name in Name_Allocate 6595 | Name_Deallocate 6596 | Name_Storage_Size); 6597 6598 Error_Msg_Name_1 := Op_Name; 6599 6600 -- For each homonym declared immediately in the scope 6601 -- of the simple storage pool type, determine whether 6602 -- the homonym is an operation of the pool type, and, 6603 -- if so, check that its profile is as expected for 6604 -- a simple pool operation of that name. 6605 6606 Op := Get_Name_Entity_Id (Op_Name); 6607 while Present (Op) loop 6608 if Ekind (Op) in E_Function | E_Procedure 6609 and then Scope (Op) = Current_Scope 6610 then 6611 Formal := First_Entity (Op); 6612 6613 Is_OK := True; 6614 6615 -- The first parameter must be of the pool type 6616 -- in order for the operation to qualify. 6617 6618 if Op_Name = Name_Storage_Size then 6619 Validate_Simple_Pool_Op_Formal 6620 (Op, Formal, E_In_Parameter, Pool_Type, 6621 "Pool", Is_OK); 6622 else 6623 Validate_Simple_Pool_Op_Formal 6624 (Op, Formal, E_In_Out_Parameter, Pool_Type, 6625 "Pool", Is_OK); 6626 end if; 6627 6628 -- If another operation with this name has already 6629 -- been located for the type, then flag an error, 6630 -- since we only allow the type to have a single 6631 -- such primitive. 6632 6633 if Present (Found_Op) and then Is_OK then 6634 Error_Msg_NE 6635 ("only one % operation allowed for " & 6636 "simple storage pool type&", Op, Pool_Type); 6637 end if; 6638 6639 -- In the case of Allocate and Deallocate, a formal 6640 -- of type System.Address is required. 6641 6642 if Op_Name = Name_Allocate then 6643 Validate_Simple_Pool_Op_Formal 6644 (Op, Formal, E_Out_Parameter, 6645 Address_Type, "Storage_Address", Is_OK); 6646 6647 elsif Op_Name = Name_Deallocate then 6648 Validate_Simple_Pool_Op_Formal 6649 (Op, Formal, E_In_Parameter, 6650 Address_Type, "Storage_Address", Is_OK); 6651 end if; 6652 6653 -- In the case of Allocate and Deallocate, formals 6654 -- of type Storage_Count are required as the third 6655 -- and fourth parameters. 6656 6657 if Op_Name /= Name_Storage_Size then 6658 Validate_Simple_Pool_Op_Formal 6659 (Op, Formal, E_In_Parameter, 6660 Stg_Cnt_Type, "Size_In_Storage_Units", Is_OK); 6661 Validate_Simple_Pool_Op_Formal 6662 (Op, Formal, E_In_Parameter, 6663 Stg_Cnt_Type, "Alignment", Is_OK); 6664 end if; 6665 6666 -- If no mismatched formals have been found (Is_OK) 6667 -- and no excess formals are present, then this 6668 -- operation has been validated, so record it. 6669 6670 if not Present (Formal) and then Is_OK then 6671 Found_Op := Op; 6672 end if; 6673 end if; 6674 6675 Op := Homonym (Op); 6676 end loop; 6677 6678 -- There must be a valid Allocate operation for the type, 6679 -- so issue an error if none was found. 6680 6681 if Op_Name = Name_Allocate 6682 and then not Present (Found_Op) 6683 then 6684 Error_Msg_N ("missing % operation for simple " & 6685 "storage pool type", Pool_Type); 6686 6687 elsif Present (Found_Op) then 6688 6689 -- Simple pool operations can't be abstract 6690 6691 if Is_Abstract_Subprogram (Found_Op) then 6692 Error_Msg_N 6693 ("simple storage pool operation must not be " & 6694 "abstract", Found_Op); 6695 end if; 6696 6697 -- The Storage_Size operation must be a function with 6698 -- Storage_Count as its result type. 6699 6700 if Op_Name = Name_Storage_Size then 6701 if Ekind (Found_Op) = E_Procedure then 6702 Error_Msg_N 6703 ("% operation must be a function", Found_Op); 6704 6705 elsif Etype (Found_Op) /= Stg_Cnt_Type then 6706 Error_Msg_NE 6707 ("wrong result type for%, expected type&", 6708 Found_Op, Stg_Cnt_Type); 6709 end if; 6710 6711 -- Allocate and Deallocate must be procedures 6712 6713 elsif Ekind (Found_Op) = E_Function then 6714 Error_Msg_N 6715 ("% operation must be a procedure", Found_Op); 6716 end if; 6717 end if; 6718 end Validate_Simple_Pool_Operation; 6719 6720 -- Start of processing for Validate_Simple_Pool_Ops 6721 6722 begin 6723 Validate_Simple_Pool_Operation (Name_Allocate); 6724 Validate_Simple_Pool_Operation (Name_Deallocate); 6725 Validate_Simple_Pool_Operation (Name_Storage_Size); 6726 end Validate_Simple_Pool_Ops; 6727 end if; 6728 end if; 6729 6730 -- Now that all types from which E may depend are frozen, see if 6731 -- strict alignment is required, a component clause on a record 6732 -- is correct, the size is known at compile time and if it must 6733 -- be unsigned, in that order. 6734 6735 if Base_Type (E) = E then 6736 Check_Strict_Alignment (E); 6737 end if; 6738 6739 if Ekind (E) in E_Record_Type | E_Record_Subtype then 6740 declare 6741 RC : constant Node_Id := Get_Record_Representation_Clause (E); 6742 begin 6743 if Present (RC) then 6744 Check_Record_Representation_Clause (RC); 6745 end if; 6746 end; 6747 end if; 6748 6749 Check_Compile_Time_Size (E); 6750 6751 Check_Unsigned_Type (E); 6752 6753 -- Do not allow a size clause for a type which does not have a size 6754 -- that is known at compile time 6755 6756 if (Has_Size_Clause (E) or else Has_Object_Size_Clause (E)) 6757 and then not Size_Known_At_Compile_Time (E) 6758 then 6759 -- Suppress this message if errors posted on E, even if we are 6760 -- in all errors mode, since this is often a junk message 6761 6762 if not Error_Posted (E) then 6763 Error_Msg_N 6764 ("size clause not allowed for variable length type", 6765 Size_Clause (E)); 6766 end if; 6767 end if; 6768 6769 -- Now we set/verify the representation information, in particular 6770 -- the size and alignment values. This processing is not required for 6771 -- generic types, since generic types do not play any part in code 6772 -- generation, and so the size and alignment values for such types 6773 -- are irrelevant. Ditto for types declared within a generic unit, 6774 -- which may have components that depend on generic parameters, and 6775 -- that will be recreated in an instance. 6776 6777 if Inside_A_Generic then 6778 null; 6779 6780 -- Otherwise we call the layout procedure 6781 6782 else 6783 Layout_Type (E); 6784 end if; 6785 6786 -- If this is an access to subprogram whose designated type is itself 6787 -- a subprogram type, the return type of this anonymous subprogram 6788 -- type must be decorated as well. 6789 6790 if Ekind (E) = E_Anonymous_Access_Subprogram_Type 6791 and then Ekind (Designated_Type (E)) = E_Subprogram_Type 6792 then 6793 Layout_Type (Etype (Designated_Type (E))); 6794 end if; 6795 6796 -- If the type has a Defaut_Value/Default_Component_Value aspect, 6797 -- this is where we analyze the expression (after the type is frozen, 6798 -- since in the case of Default_Value, we are analyzing with the 6799 -- type itself, and we treat Default_Component_Value similarly for 6800 -- the sake of uniformity). 6801 6802 if Is_First_Subtype (E) and then Has_Default_Aspect (E) then 6803 declare 6804 Nam : Name_Id; 6805 Exp : Node_Id; 6806 Typ : Entity_Id; 6807 6808 begin 6809 if Is_Scalar_Type (E) then 6810 Nam := Name_Default_Value; 6811 Typ := E; 6812 Exp := Default_Aspect_Value (Typ); 6813 else 6814 Nam := Name_Default_Component_Value; 6815 Typ := Component_Type (E); 6816 Exp := Default_Aspect_Component_Value (E); 6817 end if; 6818 6819 Analyze_And_Resolve (Exp, Typ); 6820 6821 if Etype (Exp) /= Any_Type then 6822 if not Is_OK_Static_Expression (Exp) then 6823 Error_Msg_Name_1 := Nam; 6824 Flag_Non_Static_Expr 6825 ("aspect% requires static expression", Exp); 6826 end if; 6827 end if; 6828 end; 6829 end if; 6830 6831 -- End of freeze processing for type entities 6832 end if; 6833 6834 -- Here is where we logically freeze the current entity. If it has a 6835 -- freeze node, then this is the point at which the freeze node is 6836 -- linked into the result list. 6837 6838 if Has_Delayed_Freeze (E) then 6839 6840 -- If a freeze node is already allocated, use it, otherwise allocate 6841 -- a new one. The preallocation happens in the case of anonymous base 6842 -- types, where we preallocate so that we can set First_Subtype_Link. 6843 -- Note that we reset the Sloc to the current freeze location. 6844 6845 if Present (Freeze_Node (E)) then 6846 F_Node := Freeze_Node (E); 6847 Set_Sloc (F_Node, Loc); 6848 6849 else 6850 F_Node := New_Node (N_Freeze_Entity, Loc); 6851 Set_Freeze_Node (E, F_Node); 6852 Set_Access_Types_To_Process (F_Node, No_Elist); 6853 Set_TSS_Elist (F_Node, No_Elist); 6854 Set_Actions (F_Node, No_List); 6855 end if; 6856 6857 Set_Entity (F_Node, E); 6858 Add_To_Result (F_Node); 6859 6860 -- A final pass over record types with discriminants. If the type 6861 -- has an incomplete declaration, there may be constrained access 6862 -- subtypes declared elsewhere, which do not depend on the discrimi- 6863 -- nants of the type, and which are used as component types (i.e. 6864 -- the full view is a recursive type). The designated types of these 6865 -- subtypes can only be elaborated after the type itself, and they 6866 -- need an itype reference. 6867 6868 if Ekind (E) = E_Record_Type and then Has_Discriminants (E) then 6869 declare 6870 Comp : Entity_Id; 6871 IR : Node_Id; 6872 Typ : Entity_Id; 6873 6874 begin 6875 Comp := First_Component (E); 6876 while Present (Comp) loop 6877 Typ := Etype (Comp); 6878 6879 if Ekind (Comp) = E_Component 6880 and then Is_Access_Type (Typ) 6881 and then Scope (Typ) /= E 6882 and then Base_Type (Designated_Type (Typ)) = E 6883 and then Is_Itype (Designated_Type (Typ)) 6884 then 6885 IR := Make_Itype_Reference (Sloc (Comp)); 6886 Set_Itype (IR, Designated_Type (Typ)); 6887 Append (IR, Result); 6888 end if; 6889 6890 Next_Component (Comp); 6891 end loop; 6892 end; 6893 end if; 6894 end if; 6895 6896 -- When a type is frozen, the first subtype of the type is frozen as 6897 -- well (RM 13.14(15)). This has to be done after freezing the type, 6898 -- since obviously the first subtype depends on its own base type. 6899 6900 if Is_Type (E) then 6901 Freeze_And_Append (First_Subtype (E), N, Result); 6902 6903 -- If we just froze a tagged non-class wide record, then freeze the 6904 -- corresponding class-wide type. This must be done after the tagged 6905 -- type itself is frozen, because the class-wide type refers to the 6906 -- tagged type which generates the class. 6907 6908 if Is_Tagged_Type (E) 6909 and then not Is_Class_Wide_Type (E) 6910 and then Present (Class_Wide_Type (E)) 6911 then 6912 Freeze_And_Append (Class_Wide_Type (E), N, Result); 6913 end if; 6914 end if; 6915 6916 Check_Debug_Info_Needed (E); 6917 6918 -- If subprogram has address clause then reset Is_Public flag, since we 6919 -- do not want the backend to generate external references. 6920 6921 if Is_Subprogram (E) 6922 and then Present (Address_Clause (E)) 6923 and then not Is_Library_Level_Entity (E) 6924 then 6925 Set_Is_Public (E, False); 6926 end if; 6927 6928 -- The Ghost mode of the enclosing context is ignored, while the 6929 -- entity being frozen is living. Insert the freezing action prior 6930 -- to the start of the enclosing ignored Ghost region. As a result 6931 -- the freezeing action will be preserved when the ignored Ghost 6932 -- context is eliminated. The insertion must take place even when 6933 -- the context is a spec expression, otherwise "Handling of Default 6934 -- and Per-Object Expressions" will suppress the insertion, and the 6935 -- freeze node will be dropped on the floor. 6936 6937 if Saved_GM = Ignore 6938 and then Ghost_Mode /= Ignore 6939 and then Present (Ignored_Ghost_Region) 6940 then 6941 Insert_Actions 6942 (Assoc_Node => Ignored_Ghost_Region, 6943 Ins_Actions => Result, 6944 Spec_Expr_OK => True); 6945 6946 Result := No_List; 6947 end if; 6948 6949 <<Leave>> 6950 Restore_Ghost_Region (Saved_GM, Saved_IGR); 6951 6952 return Result; 6953 end Freeze_Entity; 6954 6955 ----------------------------- 6956 -- Freeze_Enumeration_Type -- 6957 ----------------------------- 6958 6959 procedure Freeze_Enumeration_Type (Typ : Entity_Id) is 6960 begin 6961 -- By default, if no size clause is present, an enumeration type with 6962 -- Convention C is assumed to interface to a C enum and has integer 6963 -- size, except for a boolean type because it is assumed to interface 6964 -- to _Bool introduced in C99. This applies to types. For subtypes, 6965 -- verify that its base type has no size clause either. Treat other 6966 -- foreign conventions in the same way, and also make sure alignment 6967 -- is set right. 6968 6969 if Has_Foreign_Convention (Typ) 6970 and then not Is_Boolean_Type (Typ) 6971 and then not Has_Size_Clause (Typ) 6972 and then not Has_Size_Clause (Base_Type (Typ)) 6973 and then Esize (Typ) < Standard_Integer_Size 6974 6975 -- Don't do this if Short_Enums on target 6976 6977 and then not Target_Short_Enums 6978 then 6979 Init_Esize (Typ, Standard_Integer_Size); 6980 Set_Alignment (Typ, Alignment (Standard_Integer)); 6981 6982 -- Normal Ada case or size clause present or not Long_C_Enums on target 6983 6984 else 6985 -- If the enumeration type interfaces to C, and it has a size clause 6986 -- that specifies less than int size, it warrants a warning. The 6987 -- user may intend the C type to be an enum or a char, so this is 6988 -- not by itself an error that the Ada compiler can detect, but it 6989 -- it is a worth a heads-up. For Boolean and Character types we 6990 -- assume that the programmer has the proper C type in mind. 6991 6992 if Convention (Typ) = Convention_C 6993 and then Has_Size_Clause (Typ) 6994 and then Esize (Typ) /= Esize (Standard_Integer) 6995 and then not Is_Boolean_Type (Typ) 6996 and then not Is_Character_Type (Typ) 6997 6998 -- Don't do this if Short_Enums on target 6999 7000 and then not Target_Short_Enums 7001 then 7002 Error_Msg_N 7003 ("C enum types have the size of a C int??", Size_Clause (Typ)); 7004 end if; 7005 7006 Adjust_Esize_For_Alignment (Typ); 7007 end if; 7008 end Freeze_Enumeration_Type; 7009 7010 ----------------------- 7011 -- Freeze_Expression -- 7012 ----------------------- 7013 7014 procedure Freeze_Expression (N : Node_Id) is 7015 7016 function Find_Aggregate_Component_Desig_Type return Entity_Id; 7017 -- If the expression is an array aggregate, the type of the component 7018 -- expressions is also frozen. If the component type is an access type 7019 -- and the expressions include allocators, the designed type is frozen 7020 -- as well. 7021 7022 function In_Expanded_Body (N : Node_Id) return Boolean; 7023 -- Given an N_Handled_Sequence_Of_Statements node, determines whether it 7024 -- is the statement sequence of an expander-generated subprogram: body 7025 -- created for an expression function, for a predicate function, an init 7026 -- proc, a stream subprogram, or a renaming as body. If so, this is not 7027 -- a freezing context and the entity will be frozen at a later point. 7028 7029 function Has_Decl_In_List 7030 (E : Entity_Id; 7031 N : Node_Id; 7032 L : List_Id) return Boolean; 7033 -- Determines whether an entity E referenced in node N is declared in 7034 -- the list L. 7035 7036 ----------------------------------------- 7037 -- Find_Aggregate_Component_Desig_Type -- 7038 ----------------------------------------- 7039 7040 function Find_Aggregate_Component_Desig_Type return Entity_Id is 7041 Assoc : Node_Id; 7042 Exp : Node_Id; 7043 7044 begin 7045 if Present (Expressions (N)) then 7046 Exp := First (Expressions (N)); 7047 while Present (Exp) loop 7048 if Nkind (Exp) = N_Allocator then 7049 return Designated_Type (Component_Type (Etype (N))); 7050 end if; 7051 7052 Next (Exp); 7053 end loop; 7054 end if; 7055 7056 if Present (Component_Associations (N)) then 7057 Assoc := First (Component_Associations (N)); 7058 while Present (Assoc) loop 7059 if Nkind (Expression (Assoc)) = N_Allocator then 7060 return Designated_Type (Component_Type (Etype (N))); 7061 end if; 7062 7063 Next (Assoc); 7064 end loop; 7065 end if; 7066 7067 return Empty; 7068 end Find_Aggregate_Component_Desig_Type; 7069 7070 ---------------------- 7071 -- In_Expanded_Body -- 7072 ---------------------- 7073 7074 function In_Expanded_Body (N : Node_Id) return Boolean is 7075 P : constant Node_Id := Parent (N); 7076 Id : Entity_Id; 7077 7078 begin 7079 if Nkind (P) /= N_Subprogram_Body then 7080 return False; 7081 7082 -- AI12-0157: An expression function that is a completion is a freeze 7083 -- point. If the body is the result of expansion, it is not. 7084 7085 elsif Was_Expression_Function (P) then 7086 return not Comes_From_Source (P); 7087 7088 -- This is the body of a generated predicate function 7089 7090 elsif Present (Corresponding_Spec (P)) 7091 and then Is_Predicate_Function (Corresponding_Spec (P)) 7092 then 7093 return True; 7094 7095 else 7096 Id := Defining_Unit_Name (Specification (P)); 7097 7098 -- The following are expander-created bodies, or bodies that 7099 -- are not freeze points. 7100 7101 if Nkind (Id) = N_Defining_Identifier 7102 and then (Is_Init_Proc (Id) 7103 or else Is_TSS (Id, TSS_Stream_Input) 7104 or else Is_TSS (Id, TSS_Stream_Output) 7105 or else Is_TSS (Id, TSS_Stream_Read) 7106 or else Is_TSS (Id, TSS_Stream_Write) 7107 or else Nkind (Original_Node (P)) = 7108 N_Subprogram_Renaming_Declaration) 7109 then 7110 return True; 7111 else 7112 return False; 7113 end if; 7114 end if; 7115 end In_Expanded_Body; 7116 7117 ---------------------- 7118 -- Has_Decl_In_List -- 7119 ---------------------- 7120 7121 function Has_Decl_In_List 7122 (E : Entity_Id; 7123 N : Node_Id; 7124 L : List_Id) return Boolean 7125 is 7126 Decl_Node : Node_Id; 7127 7128 begin 7129 -- If E is an itype, pretend that it is declared in N 7130 7131 if Is_Itype (E) then 7132 Decl_Node := N; 7133 else 7134 Decl_Node := Declaration_Node (E); 7135 end if; 7136 7137 return Is_List_Member (Decl_Node) 7138 and then List_Containing (Decl_Node) = L; 7139 end Has_Decl_In_List; 7140 7141 -- Local variables 7142 7143 In_Spec_Exp : constant Boolean := In_Spec_Expression; 7144 7145 Desig_Typ : Entity_Id; 7146 Nam : Entity_Id; 7147 P : Node_Id; 7148 Parent_P : Node_Id; 7149 Typ : Entity_Id; 7150 7151 Allocator_Typ : Entity_Id := Empty; 7152 7153 Freeze_Outside : Boolean := False; 7154 -- This flag is set true if the entity must be frozen outside the 7155 -- current subprogram. This happens in the case of expander generated 7156 -- subprograms (_Init_Proc, _Input, _Output, _Read, _Write) which do 7157 -- not freeze all entities like other bodies, but which nevertheless 7158 -- may reference entities that have to be frozen before the body and 7159 -- obviously cannot be frozen inside the body. 7160 7161 Freeze_Outside_Subp : Entity_Id := Empty; 7162 -- This entity is set if we are inside a subprogram body and the frozen 7163 -- entity is defined in the enclosing scope of this subprogram. In such 7164 -- case we must skip the subprogram body when climbing the parents chain 7165 -- to locate the correct placement for the freezing node. 7166 7167 -- Start of processing for Freeze_Expression 7168 7169 begin 7170 -- Immediate return if freezing is inhibited. This flag is set by the 7171 -- analyzer to stop freezing on generated expressions that would cause 7172 -- freezing if they were in the source program, but which are not 7173 -- supposed to freeze, since they are created. 7174 7175 if Must_Not_Freeze (N) then 7176 return; 7177 end if; 7178 7179 -- If expression is non-static, then it does not freeze in a default 7180 -- expression, see section "Handling of Default Expressions" in the 7181 -- spec of package Sem for further details. Note that we have to make 7182 -- sure that we actually have a real expression (if we have a subtype 7183 -- indication, we can't test Is_OK_Static_Expression). However, we 7184 -- exclude the case of the prefix of an attribute of a static scalar 7185 -- subtype from this early return, because static subtype attributes 7186 -- should always cause freezing, even in default expressions, but 7187 -- the attribute may not have been marked as static yet (because in 7188 -- Resolve_Attribute, the call to Eval_Attribute follows the call of 7189 -- Freeze_Expression on the prefix). 7190 7191 if In_Spec_Exp 7192 and then Nkind (N) in N_Subexpr 7193 and then not Is_OK_Static_Expression (N) 7194 and then (Nkind (Parent (N)) /= N_Attribute_Reference 7195 or else not (Is_Entity_Name (N) 7196 and then Is_Type (Entity (N)) 7197 and then Is_OK_Static_Subtype (Entity (N)))) 7198 then 7199 return; 7200 end if; 7201 7202 -- Freeze type of expression if not frozen already 7203 7204 Typ := Empty; 7205 7206 if Nkind (N) in N_Has_Etype then 7207 if not Is_Frozen (Etype (N)) then 7208 Typ := Etype (N); 7209 7210 -- Base type may be an derived numeric type that is frozen at the 7211 -- point of declaration, but first_subtype is still unfrozen. 7212 7213 elsif not Is_Frozen (First_Subtype (Etype (N))) then 7214 Typ := First_Subtype (Etype (N)); 7215 end if; 7216 end if; 7217 7218 -- For entity name, freeze entity if not frozen already. A special 7219 -- exception occurs for an identifier that did not come from source. 7220 -- We don't let such identifiers freeze a non-internal entity, i.e. 7221 -- an entity that did come from source, since such an identifier was 7222 -- generated by the expander, and cannot have any semantic effect on 7223 -- the freezing semantics. For example, this stops the parameter of 7224 -- an initialization procedure from freezing the variable. 7225 7226 if Is_Entity_Name (N) 7227 and then not Is_Frozen (Entity (N)) 7228 and then (Nkind (N) /= N_Identifier 7229 or else Comes_From_Source (N) 7230 or else not Comes_From_Source (Entity (N))) 7231 then 7232 Nam := Entity (N); 7233 7234 if Present (Nam) and then Ekind (Nam) = E_Function then 7235 Check_Expression_Function (N, Nam); 7236 end if; 7237 7238 else 7239 Nam := Empty; 7240 end if; 7241 7242 -- For an allocator freeze designated type if not frozen already 7243 7244 -- For an aggregate whose component type is an access type, freeze the 7245 -- designated type now, so that its freeze does not appear within the 7246 -- loop that might be created in the expansion of the aggregate. If the 7247 -- designated type is a private type without full view, the expression 7248 -- cannot contain an allocator, so the type is not frozen. 7249 7250 -- For a function, we freeze the entity when the subprogram declaration 7251 -- is frozen, but a function call may appear in an initialization proc. 7252 -- before the declaration is frozen. We need to generate the extra 7253 -- formals, if any, to ensure that the expansion of the call includes 7254 -- the proper actuals. This only applies to Ada subprograms, not to 7255 -- imported ones. 7256 7257 Desig_Typ := Empty; 7258 7259 case Nkind (N) is 7260 when N_Allocator => 7261 Desig_Typ := Designated_Type (Etype (N)); 7262 7263 if Nkind (Expression (N)) = N_Qualified_Expression then 7264 Allocator_Typ := Entity (Subtype_Mark (Expression (N))); 7265 end if; 7266 7267 when N_Aggregate => 7268 if Is_Array_Type (Etype (N)) 7269 and then Is_Access_Type (Component_Type (Etype (N))) 7270 then 7271 -- Check whether aggregate includes allocators 7272 7273 Desig_Typ := Find_Aggregate_Component_Desig_Type; 7274 end if; 7275 7276 when N_Indexed_Component 7277 | N_Selected_Component 7278 | N_Slice 7279 => 7280 if Is_Access_Type (Etype (Prefix (N))) then 7281 Desig_Typ := Designated_Type (Etype (Prefix (N))); 7282 end if; 7283 7284 when N_Identifier => 7285 if Present (Nam) 7286 and then Ekind (Nam) = E_Function 7287 and then Nkind (Parent (N)) = N_Function_Call 7288 and then Convention (Nam) = Convention_Ada 7289 then 7290 Create_Extra_Formals (Nam); 7291 end if; 7292 7293 when others => 7294 null; 7295 end case; 7296 7297 if Desig_Typ /= Empty 7298 and then (Is_Frozen (Desig_Typ) 7299 or else (not Is_Fully_Defined (Desig_Typ))) 7300 then 7301 Desig_Typ := Empty; 7302 end if; 7303 7304 -- All done if nothing needs freezing 7305 7306 if No (Typ) 7307 and then No (Nam) 7308 and then No (Desig_Typ) 7309 and then No (Allocator_Typ) 7310 then 7311 return; 7312 end if; 7313 7314 -- Check if we are inside a subprogram body and the frozen entity is 7315 -- defined in the enclosing scope of this subprogram. In such case we 7316 -- must skip the subprogram when climbing the parents chain to locate 7317 -- the correct placement for the freezing node. 7318 7319 -- This is not needed for default expressions and other spec expressions 7320 -- in generic units since the Move_Freeze_Nodes mechanism (sem_ch12.adb) 7321 -- takes care of placing them at the proper place, after the generic 7322 -- unit. 7323 7324 if Present (Nam) 7325 and then Scope (Nam) /= Current_Scope 7326 and then not (In_Spec_Exp and then Inside_A_Generic) 7327 then 7328 declare 7329 S : Entity_Id := Current_Scope; 7330 7331 begin 7332 while Present (S) 7333 and then In_Same_Source_Unit (Nam, S) 7334 loop 7335 if Scope (S) = Scope (Nam) then 7336 if Is_Subprogram (S) and then Has_Completion (S) then 7337 Freeze_Outside_Subp := S; 7338 end if; 7339 7340 exit; 7341 end if; 7342 7343 S := Scope (S); 7344 end loop; 7345 end; 7346 end if; 7347 7348 -- Examine the enclosing context by climbing the parent chain 7349 7350 -- If we identified that we must freeze the entity outside of a given 7351 -- subprogram then we just climb up to that subprogram checking if some 7352 -- enclosing node is marked as Must_Not_Freeze (since in such case we 7353 -- must not freeze yet this entity). 7354 7355 P := N; 7356 7357 if Present (Freeze_Outside_Subp) then 7358 loop 7359 -- Do not freeze the current expression if another expression in 7360 -- the chain of parents must not be frozen. 7361 7362 if Nkind (P) in N_Subexpr and then Must_Not_Freeze (P) then 7363 return; 7364 end if; 7365 7366 Parent_P := Parent (P); 7367 7368 -- If we don't have a parent, then we are not in a well-formed 7369 -- tree. This is an unusual case, but there are some legitimate 7370 -- situations in which this occurs, notably when the expressions 7371 -- in the range of a type declaration are resolved. We simply 7372 -- ignore the freeze request in this case. 7373 7374 if No (Parent_P) then 7375 return; 7376 end if; 7377 7378 -- If the parent is a subprogram body, the candidate insertion 7379 -- point is just ahead of it. 7380 7381 if Nkind (Parent_P) = N_Subprogram_Body 7382 and then Unique_Defining_Entity (Parent_P) = 7383 Freeze_Outside_Subp 7384 then 7385 P := Parent_P; 7386 exit; 7387 end if; 7388 7389 P := Parent_P; 7390 end loop; 7391 7392 -- Otherwise the traversal serves two purposes - to detect scenarios 7393 -- where freezeing is not needed and to find the proper insertion point 7394 -- for the freeze nodes. Although somewhat similar to Insert_Actions, 7395 -- this traversal is freezing semantics-sensitive. Inserting freeze 7396 -- nodes blindly in the tree may result in types being frozen too early. 7397 7398 else 7399 loop 7400 -- Do not freeze the current expression if another expression in 7401 -- the chain of parents must not be frozen. 7402 7403 if Nkind (P) in N_Subexpr and then Must_Not_Freeze (P) then 7404 return; 7405 end if; 7406 7407 Parent_P := Parent (P); 7408 7409 -- If we don't have a parent, then we are not in a well-formed 7410 -- tree. This is an unusual case, but there are some legitimate 7411 -- situations in which this occurs, notably when the expressions 7412 -- in the range of a type declaration are resolved. We simply 7413 -- ignore the freeze request in this case. Is this right ??? 7414 7415 if No (Parent_P) then 7416 return; 7417 end if; 7418 7419 -- See if we have got to an appropriate point in the tree 7420 7421 case Nkind (Parent_P) is 7422 7423 -- A special test for the exception of (RM 13.14(8)) for the 7424 -- case of per-object expressions (RM 3.8(18)) occurring in 7425 -- component definition or a discrete subtype definition. Note 7426 -- that we test for a component declaration which includes both 7427 -- cases we are interested in, and furthermore the tree does 7428 -- not have explicit nodes for either of these two constructs. 7429 7430 when N_Component_Declaration => 7431 7432 -- The case we want to test for here is an identifier that 7433 -- is a per-object expression, this is either a discriminant 7434 -- that appears in a context other than the component 7435 -- declaration or it is a reference to the type of the 7436 -- enclosing construct. 7437 7438 -- For either of these cases, we skip the freezing 7439 7440 if not In_Spec_Expression 7441 and then Nkind (N) = N_Identifier 7442 and then (Present (Entity (N))) 7443 then 7444 -- We recognize the discriminant case by just looking for 7445 -- a reference to a discriminant. It can only be one for 7446 -- the enclosing construct. Skip freezing in this case. 7447 7448 if Ekind (Entity (N)) = E_Discriminant then 7449 return; 7450 7451 -- For the case of a reference to the enclosing record, 7452 -- (or task or protected type), we look for a type that 7453 -- matches the current scope. 7454 7455 elsif Entity (N) = Current_Scope then 7456 return; 7457 end if; 7458 end if; 7459 7460 -- If we have an enumeration literal that appears as the choice 7461 -- in the aggregate of an enumeration representation clause, 7462 -- then freezing does not occur (RM 13.14(10)). 7463 7464 when N_Enumeration_Representation_Clause => 7465 7466 -- The case we are looking for is an enumeration literal 7467 7468 if Nkind (N) in N_Identifier | N_Character_Literal 7469 and then Is_Enumeration_Type (Etype (N)) 7470 then 7471 -- If enumeration literal appears directly as the choice, 7472 -- do not freeze (this is the normal non-overloaded case) 7473 7474 if Nkind (Parent (N)) = N_Component_Association 7475 and then First (Choices (Parent (N))) = N 7476 then 7477 return; 7478 7479 -- If enumeration literal appears as the name of function 7480 -- which is the choice, then also do not freeze. This 7481 -- happens in the overloaded literal case, where the 7482 -- enumeration literal is temporarily changed to a 7483 -- function call for overloading analysis purposes. 7484 7485 elsif Nkind (Parent (N)) = N_Function_Call 7486 and then Nkind (Parent (Parent (N))) = 7487 N_Component_Association 7488 and then First (Choices (Parent (Parent (N)))) = 7489 Parent (N) 7490 then 7491 return; 7492 end if; 7493 end if; 7494 7495 -- Normally if the parent is a handled sequence of statements, 7496 -- then the current node must be a statement, and that is an 7497 -- appropriate place to insert a freeze node. 7498 7499 when N_Handled_Sequence_Of_Statements => 7500 7501 -- An exception occurs when the sequence of statements is 7502 -- for an expander generated body that did not do the usual 7503 -- freeze all operation. In this case we usually want to 7504 -- freeze outside this body, not inside it, and we skip 7505 -- past the subprogram body that we are inside. 7506 7507 if In_Expanded_Body (Parent_P) then 7508 declare 7509 Subp_Body : constant Node_Id := Parent (Parent_P); 7510 Spec_Id : Entity_Id; 7511 7512 begin 7513 -- Freeze the entity only when it is declared inside 7514 -- the body of the expander generated procedure. This 7515 -- case is recognized by the subprogram scope of the 7516 -- entity or its type, which is either the spec of an 7517 -- enclosing body, or (in the case of init_procs for 7518 -- which there is no separate spec) the current scope. 7519 7520 if Nkind (Subp_Body) = N_Subprogram_Body then 7521 declare 7522 S : Entity_Id; 7523 7524 begin 7525 Spec_Id := Corresponding_Spec (Subp_Body); 7526 7527 if Present (Typ) then 7528 S := Scope (Typ); 7529 elsif Present (Nam) then 7530 S := Scope (Nam); 7531 else 7532 S := Standard_Standard; 7533 end if; 7534 7535 while S /= Standard_Standard 7536 and then not Is_Subprogram (S) 7537 loop 7538 S := Scope (S); 7539 end loop; 7540 7541 if S = Spec_Id then 7542 exit; 7543 7544 elsif Present (Typ) 7545 and then Scope (Typ) = Current_Scope 7546 and then 7547 Defining_Entity (Subp_Body) = Current_Scope 7548 then 7549 exit; 7550 end if; 7551 end; 7552 end if; 7553 7554 -- If the entity is not frozen by an expression 7555 -- function that is not a completion, continue 7556 -- climbing the tree. 7557 7558 if Nkind (Subp_Body) = N_Subprogram_Body 7559 and then Was_Expression_Function (Subp_Body) 7560 then 7561 null; 7562 7563 -- Freeze outside the body 7564 7565 else 7566 Parent_P := Parent (Parent_P); 7567 Freeze_Outside := True; 7568 end if; 7569 end; 7570 7571 -- Here if normal case where we are in handled statement 7572 -- sequence and want to do the insertion right there. 7573 7574 else 7575 exit; 7576 end if; 7577 7578 -- If parent is a body or a spec or a block, then the current 7579 -- node is a statement or declaration and we can insert the 7580 -- freeze node before it. 7581 7582 when N_Block_Statement 7583 | N_Entry_Body 7584 | N_Package_Body 7585 | N_Package_Specification 7586 | N_Protected_Body 7587 | N_Subprogram_Body 7588 | N_Task_Body 7589 => 7590 exit; 7591 7592 -- The expander is allowed to define types in any statements 7593 -- list, so any of the following parent nodes also mark a 7594 -- freezing point if the actual node is in a list of 7595 -- statements or declarations. 7596 7597 when N_Abortable_Part 7598 | N_Accept_Alternative 7599 | N_Case_Statement_Alternative 7600 | N_Compilation_Unit_Aux 7601 | N_Conditional_Entry_Call 7602 | N_Delay_Alternative 7603 | N_Elsif_Part 7604 | N_Entry_Call_Alternative 7605 | N_Exception_Handler 7606 | N_Extended_Return_Statement 7607 | N_Freeze_Entity 7608 | N_If_Statement 7609 | N_Selective_Accept 7610 | N_Triggering_Alternative 7611 => 7612 exit when Is_List_Member (P); 7613 7614 -- The freeze nodes produced by an expression coming from the 7615 -- Actions list of an N_Expression_With_Actions, short-circuit 7616 -- expression or N_Case_Expression_Alternative node must remain 7617 -- within the Actions list if they freeze an entity declared in 7618 -- this list, as inserting the freeze nodes further up the tree 7619 -- may lead to use before declaration issues for the entity. 7620 7621 when N_Case_Expression_Alternative 7622 | N_Expression_With_Actions 7623 | N_Short_Circuit 7624 => 7625 exit when (Present (Nam) 7626 and then 7627 Has_Decl_In_List (Nam, P, Actions (Parent_P))) 7628 or else (Present (Typ) 7629 and then 7630 Has_Decl_In_List (Typ, P, Actions (Parent_P))); 7631 7632 -- Likewise for an N_If_Expression and its two Actions list 7633 7634 when N_If_Expression => 7635 declare 7636 L1 : constant List_Id := Then_Actions (Parent_P); 7637 L2 : constant List_Id := Else_Actions (Parent_P); 7638 7639 begin 7640 exit when (Present (Nam) 7641 and then 7642 Has_Decl_In_List (Nam, P, L1)) 7643 or else (Present (Typ) 7644 and then 7645 Has_Decl_In_List (Typ, P, L1)) 7646 or else (Present (Nam) 7647 and then 7648 Has_Decl_In_List (Nam, P, L2)) 7649 or else (Present (Typ) 7650 and then 7651 Has_Decl_In_List (Typ, P, L2)); 7652 end; 7653 7654 -- N_Loop_Statement is a special case: a type that appears in 7655 -- the source can never be frozen in a loop (this occurs only 7656 -- because of a loop expanded by the expander), so we keep on 7657 -- going. Otherwise we terminate the search. Same is true of 7658 -- any entity which comes from source (if it has a predefined 7659 -- type, this type does not appear to come from source, but the 7660 -- entity should not be frozen here). 7661 7662 when N_Loop_Statement => 7663 exit when not Comes_From_Source (Etype (N)) 7664 and then (No (Nam) or else not Comes_From_Source (Nam)); 7665 7666 -- For all other cases, keep looking at parents 7667 7668 when others => 7669 null; 7670 end case; 7671 7672 -- We fall through the case if we did not yet find the proper 7673 -- place in the free for inserting the freeze node, so climb. 7674 7675 P := Parent_P; 7676 end loop; 7677 end if; 7678 7679 -- If the expression appears in a record or an initialization procedure, 7680 -- the freeze nodes are collected and attached to the current scope, to 7681 -- be inserted and analyzed on exit from the scope, to insure that 7682 -- generated entities appear in the correct scope. If the expression is 7683 -- a default for a discriminant specification, the scope is still void. 7684 -- The expression can also appear in the discriminant part of a private 7685 -- or concurrent type. 7686 7687 -- If the expression appears in a constrained subcomponent of an 7688 -- enclosing record declaration, the freeze nodes must be attached to 7689 -- the outer record type so they can eventually be placed in the 7690 -- enclosing declaration list. 7691 7692 -- The other case requiring this special handling is if we are in a 7693 -- default expression, since in that case we are about to freeze a 7694 -- static type, and the freeze scope needs to be the outer scope, not 7695 -- the scope of the subprogram with the default parameter. 7696 7697 -- For default expressions and other spec expressions in generic units, 7698 -- the Move_Freeze_Nodes mechanism (see sem_ch12.adb) takes care of 7699 -- placing them at the proper place, after the generic unit. 7700 7701 if (In_Spec_Exp and not Inside_A_Generic) 7702 or else Freeze_Outside 7703 or else (Is_Type (Current_Scope) 7704 and then (not Is_Concurrent_Type (Current_Scope) 7705 or else not Has_Completion (Current_Scope))) 7706 or else Ekind (Current_Scope) = E_Void 7707 then 7708 declare 7709 Freeze_Nodes : List_Id := No_List; 7710 Pos : Int := Scope_Stack.Last; 7711 7712 begin 7713 if Present (Desig_Typ) then 7714 Freeze_And_Append (Desig_Typ, N, Freeze_Nodes); 7715 end if; 7716 7717 if Present (Typ) then 7718 Freeze_And_Append (Typ, N, Freeze_Nodes); 7719 end if; 7720 7721 if Present (Nam) then 7722 Freeze_And_Append (Nam, N, Freeze_Nodes); 7723 end if; 7724 7725 -- The current scope may be that of a constrained component of 7726 -- an enclosing record declaration, or of a loop of an enclosing 7727 -- quantified expression, which is above the current scope in the 7728 -- scope stack. Indeed in the context of a quantified expression, 7729 -- a scope is created and pushed above the current scope in order 7730 -- to emulate the loop-like behavior of the quantified expression. 7731 -- If the expression is within a top-level pragma, as for a pre- 7732 -- condition on a library-level subprogram, nothing to do. 7733 7734 if not Is_Compilation_Unit (Current_Scope) 7735 and then (Is_Record_Type (Scope (Current_Scope)) 7736 or else Nkind (Parent (Current_Scope)) = 7737 N_Quantified_Expression) 7738 then 7739 Pos := Pos - 1; 7740 end if; 7741 7742 if Is_Non_Empty_List (Freeze_Nodes) then 7743 7744 -- When the current scope is transient, insert the freeze nodes 7745 -- prior to the expression that produced them. Transient scopes 7746 -- may create additional declarations when finalizing objects 7747 -- or managing the secondary stack. Inserting the freeze nodes 7748 -- of those constructs prior to the scope would result in a 7749 -- freeze-before-declaration, therefore the freeze node must 7750 -- remain interleaved with their constructs. 7751 7752 if Scope_Is_Transient then 7753 Insert_Actions (N, Freeze_Nodes); 7754 7755 elsif No (Scope_Stack.Table (Pos).Pending_Freeze_Actions) then 7756 Scope_Stack.Table (Pos).Pending_Freeze_Actions := 7757 Freeze_Nodes; 7758 else 7759 Append_List (Freeze_Nodes, 7760 Scope_Stack.Table (Pos).Pending_Freeze_Actions); 7761 end if; 7762 end if; 7763 end; 7764 7765 return; 7766 end if; 7767 7768 -- Now we have the right place to do the freezing. First, a special 7769 -- adjustment, if we are in spec-expression analysis mode, these freeze 7770 -- actions must not be thrown away (normally all inserted actions are 7771 -- thrown away in this mode. However, the freeze actions are from static 7772 -- expressions and one of the important reasons we are doing this 7773 -- special analysis is to get these freeze actions. Therefore we turn 7774 -- off the In_Spec_Expression mode to propagate these freeze actions. 7775 -- This also means they get properly analyzed and expanded. 7776 7777 In_Spec_Expression := False; 7778 7779 -- Freeze the subtype mark before a qualified expression on an 7780 -- allocator as per AARM 13.14(4.a). This is needed in particular to 7781 -- generate predicate functions. 7782 7783 if Present (Allocator_Typ) then 7784 Freeze_Before (P, Allocator_Typ); 7785 end if; 7786 7787 -- Freeze the designated type of an allocator (RM 13.14(13)) 7788 7789 if Present (Desig_Typ) then 7790 Freeze_Before (P, Desig_Typ); 7791 end if; 7792 7793 -- Freeze type of expression (RM 13.14(10)). Note that we took care of 7794 -- the enumeration representation clause exception in the loop above. 7795 7796 if Present (Typ) then 7797 Freeze_Before (P, Typ); 7798 end if; 7799 7800 -- Freeze name if one is present (RM 13.14(11)) 7801 7802 if Present (Nam) then 7803 Freeze_Before (P, Nam); 7804 end if; 7805 7806 -- Restore In_Spec_Expression flag 7807 7808 In_Spec_Expression := In_Spec_Exp; 7809 end Freeze_Expression; 7810 7811 ----------------------- 7812 -- Freeze_Expr_Types -- 7813 ----------------------- 7814 7815 procedure Freeze_Expr_Types 7816 (Def_Id : Entity_Id; 7817 Typ : Entity_Id; 7818 Expr : Node_Id; 7819 N : Node_Id) 7820 is 7821 function Cloned_Expression return Node_Id; 7822 -- Build a duplicate of the expression of the return statement that has 7823 -- no defining entities shared with the original expression. 7824 7825 function Freeze_Type_Refs (Node : Node_Id) return Traverse_Result; 7826 -- Freeze all types referenced in the subtree rooted at Node 7827 7828 ----------------------- 7829 -- Cloned_Expression -- 7830 ----------------------- 7831 7832 function Cloned_Expression return Node_Id is 7833 function Clone_Id (Node : Node_Id) return Traverse_Result; 7834 -- Tree traversal routine that clones the defining identifier of 7835 -- iterator and loop parameter specification nodes. 7836 7837 -------------- 7838 -- Clone_Id -- 7839 -------------- 7840 7841 function Clone_Id (Node : Node_Id) return Traverse_Result is 7842 begin 7843 if Nkind (Node) in 7844 N_Iterator_Specification | N_Loop_Parameter_Specification 7845 then 7846 Set_Defining_Identifier 7847 (Node, New_Copy (Defining_Identifier (Node))); 7848 end if; 7849 7850 return OK; 7851 end Clone_Id; 7852 7853 procedure Clone_Def_Ids is new Traverse_Proc (Clone_Id); 7854 7855 -- Local variable 7856 7857 Dup_Expr : constant Node_Id := New_Copy_Tree (Expr); 7858 7859 -- Start of processing for Cloned_Expression 7860 7861 begin 7862 -- We must duplicate the expression with semantic information to 7863 -- inherit the decoration of global entities in generic instances. 7864 -- Set the parent of the new node to be the parent of the original 7865 -- to get the proper context, which is needed for complete error 7866 -- reporting and for semantic analysis. 7867 7868 Set_Parent (Dup_Expr, Parent (Expr)); 7869 7870 -- Replace the defining identifier of iterators and loop param 7871 -- specifications by a clone to ensure that the cloned expression 7872 -- and the original expression don't have shared identifiers; 7873 -- otherwise, as part of the preanalysis of the expression, these 7874 -- shared identifiers may be left decorated with itypes which 7875 -- will not be available in the tree passed to the backend. 7876 7877 Clone_Def_Ids (Dup_Expr); 7878 7879 return Dup_Expr; 7880 end Cloned_Expression; 7881 7882 ---------------------- 7883 -- Freeze_Type_Refs -- 7884 ---------------------- 7885 7886 function Freeze_Type_Refs (Node : Node_Id) return Traverse_Result is 7887 procedure Check_And_Freeze_Type (Typ : Entity_Id); 7888 -- Check that Typ is fully declared and freeze it if so 7889 7890 --------------------------- 7891 -- Check_And_Freeze_Type -- 7892 --------------------------- 7893 7894 procedure Check_And_Freeze_Type (Typ : Entity_Id) is 7895 begin 7896 -- Skip Itypes created by the preanalysis, and itypes whose 7897 -- scope is another type (i.e. component subtypes that depend 7898 -- on a discriminant), 7899 7900 if Is_Itype (Typ) 7901 and then (Scope_Within_Or_Same (Scope (Typ), Def_Id) 7902 or else Is_Type (Scope (Typ))) 7903 then 7904 return; 7905 end if; 7906 7907 -- This provides a better error message than generating primitives 7908 -- whose compilation fails much later. Refine the error message if 7909 -- possible. 7910 7911 Check_Fully_Declared (Typ, Node); 7912 7913 if Error_Posted (Node) then 7914 if Has_Private_Component (Typ) 7915 and then not Is_Private_Type (Typ) 7916 then 7917 Error_Msg_NE ("\type& has private component", Node, Typ); 7918 end if; 7919 7920 else 7921 Freeze_Before (N, Typ); 7922 end if; 7923 end Check_And_Freeze_Type; 7924 7925 -- Start of processing for Freeze_Type_Refs 7926 7927 begin 7928 -- Check that a type referenced by an entity can be frozen 7929 7930 if Is_Entity_Name (Node) and then Present (Entity (Node)) then 7931 -- The entity itself may be a type, as in a membership test 7932 -- or an attribute reference. Freezing its own type would be 7933 -- incomplete if the entity is derived or an extension. 7934 7935 if Is_Type (Entity (Node)) then 7936 Check_And_Freeze_Type (Entity (Node)); 7937 7938 else 7939 Check_And_Freeze_Type (Etype (Entity (Node))); 7940 end if; 7941 7942 -- Check that the enclosing record type can be frozen 7943 7944 if Ekind (Entity (Node)) in E_Component | E_Discriminant then 7945 Check_And_Freeze_Type (Scope (Entity (Node))); 7946 end if; 7947 7948 -- Freezing an access type does not freeze the designated type, but 7949 -- freezing conversions between access to interfaces requires that 7950 -- the interface types themselves be frozen, so that dispatch table 7951 -- entities are properly created. 7952 7953 -- Unclear whether a more general rule is needed ??? 7954 7955 elsif Nkind (Node) = N_Type_Conversion 7956 and then Is_Access_Type (Etype (Node)) 7957 and then Is_Interface (Designated_Type (Etype (Node))) 7958 then 7959 Check_And_Freeze_Type (Designated_Type (Etype (Node))); 7960 end if; 7961 7962 -- An implicit dereference freezes the designated type. In the case 7963 -- of a dispatching call whose controlling argument is an access 7964 -- type, the dereference is not made explicit, so we must check for 7965 -- such a call and freeze the designated type. 7966 7967 if Nkind (Node) in N_Has_Etype 7968 and then Present (Etype (Node)) 7969 and then Is_Access_Type (Etype (Node)) 7970 then 7971 if Nkind (Parent (Node)) = N_Function_Call 7972 and then Node = Controlling_Argument (Parent (Node)) 7973 then 7974 Check_And_Freeze_Type (Designated_Type (Etype (Node))); 7975 7976 -- An explicit dereference freezes the designated type as well, 7977 -- even though that type is not attached to an entity in the 7978 -- expression. 7979 7980 elsif Nkind (Parent (Node)) = N_Explicit_Dereference then 7981 Check_And_Freeze_Type (Designated_Type (Etype (Node))); 7982 end if; 7983 7984 -- An iterator specification freezes the iterator type, even though 7985 -- that type is not attached to an entity in the construct. 7986 7987 elsif Nkind (Node) in N_Has_Etype 7988 and then Nkind (Parent (Node)) = N_Iterator_Specification 7989 and then Node = Name (Parent (Node)) 7990 then 7991 declare 7992 Iter : constant Node_Id := 7993 Find_Value_Of_Aspect (Etype (Node), Aspect_Default_Iterator); 7994 7995 begin 7996 if Present (Iter) then 7997 Check_And_Freeze_Type (Etype (Iter)); 7998 end if; 7999 end; 8000 end if; 8001 8002 -- No point in posting several errors on the same expression 8003 8004 if Serious_Errors_Detected > 0 then 8005 return Abandon; 8006 else 8007 return OK; 8008 end if; 8009 end Freeze_Type_Refs; 8010 8011 procedure Freeze_References is new Traverse_Proc (Freeze_Type_Refs); 8012 8013 -- Local variables 8014 8015 Saved_First_Entity : constant Entity_Id := First_Entity (Def_Id); 8016 Saved_Last_Entity : constant Entity_Id := Last_Entity (Def_Id); 8017 Dup_Expr : constant Node_Id := Cloned_Expression; 8018 8019 -- Start of processing for Freeze_Expr_Types 8020 8021 begin 8022 -- Preanalyze a duplicate of the expression to have available the 8023 -- minimum decoration needed to locate referenced unfrozen types 8024 -- without adding any decoration to the function expression. 8025 8026 -- This routine is also applied to expressions in the contract for 8027 -- the subprogram. If that happens when expanding the code for 8028 -- pre/postconditions during expansion of the subprogram body, the 8029 -- subprogram is already installed. 8030 8031 if Def_Id /= Current_Scope then 8032 Push_Scope (Def_Id); 8033 Install_Formals (Def_Id); 8034 8035 Preanalyze_Spec_Expression (Dup_Expr, Typ); 8036 End_Scope; 8037 else 8038 Preanalyze_Spec_Expression (Dup_Expr, Typ); 8039 end if; 8040 8041 -- Restore certain attributes of Def_Id since the preanalysis may 8042 -- have introduced itypes to this scope, thus modifying attributes 8043 -- First_Entity and Last_Entity. 8044 8045 Set_First_Entity (Def_Id, Saved_First_Entity); 8046 Set_Last_Entity (Def_Id, Saved_Last_Entity); 8047 8048 if Present (Last_Entity (Def_Id)) then 8049 Set_Next_Entity (Last_Entity (Def_Id), Empty); 8050 end if; 8051 8052 -- Freeze all types referenced in the expression 8053 8054 Freeze_References (Dup_Expr); 8055 end Freeze_Expr_Types; 8056 8057 ----------------------------- 8058 -- Freeze_Fixed_Point_Type -- 8059 ----------------------------- 8060 8061 -- Certain fixed-point types and subtypes, including implicit base types 8062 -- and declared first subtypes, have not yet set up a range. This is 8063 -- because the range cannot be set until the Small and Size values are 8064 -- known, and these are not known till the type is frozen. 8065 8066 -- To signal this case, Scalar_Range contains an unanalyzed syntactic range 8067 -- whose bounds are unanalyzed real literals. This routine will recognize 8068 -- this case, and transform this range node into a properly typed range 8069 -- with properly analyzed and resolved values. 8070 8071 procedure Freeze_Fixed_Point_Type (Typ : Entity_Id) is 8072 Rng : constant Node_Id := Scalar_Range (Typ); 8073 Lo : constant Node_Id := Low_Bound (Rng); 8074 Hi : constant Node_Id := High_Bound (Rng); 8075 Btyp : constant Entity_Id := Base_Type (Typ); 8076 Brng : constant Node_Id := Scalar_Range (Btyp); 8077 BLo : constant Node_Id := Low_Bound (Brng); 8078 BHi : constant Node_Id := High_Bound (Brng); 8079 Par : constant Entity_Id := First_Subtype (Typ); 8080 Small : constant Ureal := Small_Value (Typ); 8081 Loval : Ureal; 8082 Hival : Ureal; 8083 Atype : Entity_Id; 8084 8085 Orig_Lo : Ureal; 8086 Orig_Hi : Ureal; 8087 -- Save original bounds (for shaving tests) 8088 8089 Actual_Size : Nat; 8090 -- Actual size chosen 8091 8092 function Fsize (Lov, Hiv : Ureal) return Nat; 8093 -- Returns size of type with given bounds. Also leaves these 8094 -- bounds set as the current bounds of the Typ. 8095 8096 function Larger (A, B : Ureal) return Boolean; 8097 -- Returns true if A > B with a margin of Typ'Small 8098 8099 function Smaller (A, B : Ureal) return Boolean; 8100 -- Returns true if A < B with a margin of Typ'Small 8101 8102 ----------- 8103 -- Fsize -- 8104 ----------- 8105 8106 function Fsize (Lov, Hiv : Ureal) return Nat is 8107 begin 8108 Set_Realval (Lo, Lov); 8109 Set_Realval (Hi, Hiv); 8110 return Minimum_Size (Typ); 8111 end Fsize; 8112 8113 ------------ 8114 -- Larger -- 8115 ------------ 8116 8117 function Larger (A, B : Ureal) return Boolean is 8118 begin 8119 return A > B and then A - Small > B; 8120 end Larger; 8121 8122 ------------- 8123 -- Smaller -- 8124 ------------- 8125 8126 function Smaller (A, B : Ureal) return Boolean is 8127 begin 8128 return A < B and then A + Small < B; 8129 end Smaller; 8130 8131 -- Start of processing for Freeze_Fixed_Point_Type 8132 8133 begin 8134 -- The type, or its first subtype if we are freezing the anonymous 8135 -- base, may have a delayed Small aspect. It must be analyzed now, 8136 -- so that all characteristics of the type (size, bounds) can be 8137 -- computed and validated in the call to Minimum_Size that follows. 8138 8139 if Has_Delayed_Aspects (First_Subtype (Typ)) then 8140 Analyze_Aspects_At_Freeze_Point (First_Subtype (Typ)); 8141 Set_Has_Delayed_Aspects (First_Subtype (Typ), False); 8142 end if; 8143 8144 -- If Esize of a subtype has not previously been set, set it now 8145 8146 if Unknown_Esize (Typ) then 8147 Atype := Ancestor_Subtype (Typ); 8148 8149 if Present (Atype) then 8150 Set_Esize (Typ, Esize (Atype)); 8151 else 8152 Set_Esize (Typ, Esize (Btyp)); 8153 end if; 8154 end if; 8155 8156 -- The 'small attribute may have been specified with an aspect, 8157 -- in which case it is processed after a subtype declaration, so 8158 -- inherit now the specified value. 8159 8160 if Typ /= Par 8161 and then Present (Find_Aspect (Par, Aspect_Small)) 8162 then 8163 Set_Small_Value (Typ, Small_Value (Par)); 8164 end if; 8165 8166 -- Immediate return if the range is already analyzed. This means that 8167 -- the range is already set, and does not need to be computed by this 8168 -- routine. 8169 8170 if Analyzed (Rng) then 8171 return; 8172 end if; 8173 8174 -- Immediate return if either of the bounds raises Constraint_Error 8175 8176 if Raises_Constraint_Error (Lo) 8177 or else Raises_Constraint_Error (Hi) 8178 then 8179 return; 8180 end if; 8181 8182 Loval := Realval (Lo); 8183 Hival := Realval (Hi); 8184 8185 Orig_Lo := Loval; 8186 Orig_Hi := Hival; 8187 8188 -- Ordinary fixed-point case 8189 8190 if Is_Ordinary_Fixed_Point_Type (Typ) then 8191 8192 -- For the ordinary fixed-point case, we are allowed to fudge the 8193 -- end-points up or down by small. Generally we prefer to fudge up, 8194 -- i.e. widen the bounds for non-model numbers so that the end points 8195 -- are included. However there are cases in which this cannot be 8196 -- done, and indeed cases in which we may need to narrow the bounds. 8197 -- The following circuit makes the decision. 8198 8199 -- Note: our terminology here is that Incl_EP means that the bounds 8200 -- are widened by Small if necessary to include the end points, and 8201 -- Excl_EP means that the bounds are narrowed by Small to exclude the 8202 -- end-points if this reduces the size. 8203 8204 -- Note that in the Incl case, all we care about is including the 8205 -- end-points. In the Excl case, we want to narrow the bounds as 8206 -- much as permitted by the RM, to give the smallest possible size. 8207 8208 Fudge : declare 8209 Loval_Incl_EP : Ureal; 8210 Hival_Incl_EP : Ureal; 8211 8212 Loval_Excl_EP : Ureal; 8213 Hival_Excl_EP : Ureal; 8214 8215 Size_Incl_EP : Nat; 8216 Size_Excl_EP : Nat; 8217 8218 Model_Num : Ureal; 8219 First_Subt : Entity_Id; 8220 Actual_Lo : Ureal; 8221 Actual_Hi : Ureal; 8222 8223 begin 8224 -- First step. Base types are required to be symmetrical. Right 8225 -- now, the base type range is a copy of the first subtype range. 8226 -- This will be corrected before we are done, but right away we 8227 -- need to deal with the case where both bounds are non-negative. 8228 -- In this case, we set the low bound to the negative of the high 8229 -- bound, to make sure that the size is computed to include the 8230 -- required sign. Note that we do not need to worry about the 8231 -- case of both bounds negative, because the sign will be dealt 8232 -- with anyway. Furthermore we can't just go making such a bound 8233 -- symmetrical, since in a twos-complement system, there is an 8234 -- extra negative value which could not be accommodated on the 8235 -- positive side. 8236 8237 if Typ = Btyp 8238 and then not UR_Is_Negative (Loval) 8239 and then Hival > Loval 8240 then 8241 Loval := -Hival; 8242 Set_Realval (Lo, Loval); 8243 end if; 8244 8245 -- Compute the fudged bounds. If the bound is a model number, (or 8246 -- greater if given low bound, smaller if high bound) then we do 8247 -- nothing to include it, but we are allowed to backoff to the 8248 -- next adjacent model number when we exclude it. If it is not a 8249 -- model number then we straddle the two values with the model 8250 -- numbers on either side. 8251 8252 Model_Num := UR_Trunc (Loval / Small) * Small; 8253 8254 if UR_Ge (Loval, Model_Num) then 8255 Loval_Incl_EP := Model_Num; 8256 else 8257 Loval_Incl_EP := Model_Num - Small; 8258 end if; 8259 8260 -- The low value excluding the end point is Small greater, but 8261 -- we do not do this exclusion if the low value is positive, 8262 -- since it can't help the size and could actually hurt by 8263 -- crossing the high bound. 8264 8265 if UR_Is_Negative (Loval_Incl_EP) then 8266 Loval_Excl_EP := Loval_Incl_EP + Small; 8267 8268 -- If the value went from negative to zero, then we have the 8269 -- case where Loval_Incl_EP is the model number just below 8270 -- zero, so we want to stick to the negative value for the 8271 -- base type to maintain the condition that the size will 8272 -- include signed values. 8273 8274 if Typ = Btyp 8275 and then UR_Is_Zero (Loval_Excl_EP) 8276 then 8277 Loval_Excl_EP := Loval_Incl_EP; 8278 end if; 8279 8280 else 8281 Loval_Excl_EP := Loval_Incl_EP; 8282 end if; 8283 8284 -- Similar processing for upper bound and high value 8285 8286 Model_Num := UR_Trunc (Hival / Small) * Small; 8287 8288 if UR_Le (Hival, Model_Num) then 8289 Hival_Incl_EP := Model_Num; 8290 else 8291 Hival_Incl_EP := Model_Num + Small; 8292 end if; 8293 8294 if UR_Is_Positive (Hival_Incl_EP) then 8295 Hival_Excl_EP := Hival_Incl_EP - Small; 8296 else 8297 Hival_Excl_EP := Hival_Incl_EP; 8298 end if; 8299 8300 -- One further adjustment is needed. In the case of subtypes, we 8301 -- cannot go outside the range of the base type, or we get 8302 -- peculiarities, and the base type range is already set. This 8303 -- only applies to the Incl values, since clearly the Excl values 8304 -- are already as restricted as they are allowed to be. 8305 8306 if Typ /= Btyp then 8307 Loval_Incl_EP := UR_Max (Loval_Incl_EP, Realval (BLo)); 8308 Hival_Incl_EP := UR_Min (Hival_Incl_EP, Realval (BHi)); 8309 end if; 8310 8311 -- Get size including and excluding end points 8312 8313 Size_Incl_EP := Fsize (Loval_Incl_EP, Hival_Incl_EP); 8314 Size_Excl_EP := Fsize (Loval_Excl_EP, Hival_Excl_EP); 8315 8316 -- No need to exclude end-points if it does not reduce size 8317 8318 if Fsize (Loval_Incl_EP, Hival_Excl_EP) = Size_Excl_EP then 8319 Loval_Excl_EP := Loval_Incl_EP; 8320 end if; 8321 8322 if Fsize (Loval_Excl_EP, Hival_Incl_EP) = Size_Excl_EP then 8323 Hival_Excl_EP := Hival_Incl_EP; 8324 end if; 8325 8326 -- Now we set the actual size to be used. We want to use the 8327 -- bounds fudged up to include the end-points but only if this 8328 -- can be done without violating a specifically given size 8329 -- size clause or causing an unacceptable increase in size. 8330 8331 -- Case of size clause given 8332 8333 if Has_Size_Clause (Typ) then 8334 8335 -- Use the inclusive size only if it is consistent with 8336 -- the explicitly specified size. 8337 8338 if Size_Incl_EP <= RM_Size (Typ) then 8339 Actual_Lo := Loval_Incl_EP; 8340 Actual_Hi := Hival_Incl_EP; 8341 Actual_Size := Size_Incl_EP; 8342 8343 -- If the inclusive size is too large, we try excluding 8344 -- the end-points (will be caught later if does not work). 8345 8346 else 8347 Actual_Lo := Loval_Excl_EP; 8348 Actual_Hi := Hival_Excl_EP; 8349 Actual_Size := Size_Excl_EP; 8350 end if; 8351 8352 -- Case of size clause not given 8353 8354 else 8355 -- If we have a base type whose corresponding first subtype 8356 -- has an explicit size that is large enough to include our 8357 -- end-points, then do so. There is no point in working hard 8358 -- to get a base type whose size is smaller than the specified 8359 -- size of the first subtype. 8360 8361 First_Subt := First_Subtype (Typ); 8362 8363 if Has_Size_Clause (First_Subt) 8364 and then Size_Incl_EP <= Esize (First_Subt) 8365 then 8366 Actual_Size := Size_Incl_EP; 8367 Actual_Lo := Loval_Incl_EP; 8368 Actual_Hi := Hival_Incl_EP; 8369 8370 -- If excluding the end-points makes the size smaller and 8371 -- results in a size of 8,16,32,64, then we take the smaller 8372 -- size. For the 64 case, this is compulsory. For the other 8373 -- cases, it seems reasonable. We like to include end points 8374 -- if we can, but not at the expense of moving to the next 8375 -- natural boundary of size. 8376 8377 elsif Size_Incl_EP /= Size_Excl_EP 8378 and then Addressable (Size_Excl_EP) 8379 then 8380 Actual_Size := Size_Excl_EP; 8381 Actual_Lo := Loval_Excl_EP; 8382 Actual_Hi := Hival_Excl_EP; 8383 8384 -- Otherwise we can definitely include the end points 8385 8386 else 8387 Actual_Size := Size_Incl_EP; 8388 Actual_Lo := Loval_Incl_EP; 8389 Actual_Hi := Hival_Incl_EP; 8390 end if; 8391 8392 -- One pathological case: normally we never fudge a low bound 8393 -- down, since it would seem to increase the size (if it has 8394 -- any effect), but for ranges containing single value, or no 8395 -- values, the high bound can be small too large. Consider: 8396 8397 -- type t is delta 2.0**(-14) 8398 -- range 131072.0 .. 0; 8399 8400 -- That lower bound is *just* outside the range of 32 bits, and 8401 -- does need fudging down in this case. Note that the bounds 8402 -- will always have crossed here, since the high bound will be 8403 -- fudged down if necessary, as in the case of: 8404 8405 -- type t is delta 2.0**(-14) 8406 -- range 131072.0 .. 131072.0; 8407 8408 -- So we detect the situation by looking for crossed bounds, 8409 -- and if the bounds are crossed, and the low bound is greater 8410 -- than zero, we will always back it off by small, since this 8411 -- is completely harmless. 8412 8413 if Actual_Lo > Actual_Hi then 8414 if UR_Is_Positive (Actual_Lo) then 8415 Actual_Lo := Loval_Incl_EP - Small; 8416 Actual_Size := Fsize (Actual_Lo, Actual_Hi); 8417 8418 -- And of course, we need to do exactly the same parallel 8419 -- fudge for flat ranges in the negative region. 8420 8421 elsif UR_Is_Negative (Actual_Hi) then 8422 Actual_Hi := Hival_Incl_EP + Small; 8423 Actual_Size := Fsize (Actual_Lo, Actual_Hi); 8424 end if; 8425 end if; 8426 end if; 8427 8428 Set_Realval (Lo, Actual_Lo); 8429 Set_Realval (Hi, Actual_Hi); 8430 end Fudge; 8431 8432 -- Enforce some limitations for ordinary fixed-point types. They come 8433 -- from an exact algorithm used to implement Text_IO.Fixed_IO and the 8434 -- Fore, Image and Value attributes. The requirement on the Small is 8435 -- to lie in the range 2**(-(Siz - 1)) .. 2**(Siz - 1) for a type of 8436 -- Siz bits (Siz=32,64,128) and the requirement on the bounds is to 8437 -- be smaller in magnitude than 10.0**N * 2**(Siz - 1), where N is 8438 -- given by the formula N = floor ((Siz - 1) * log 2 / log 10). 8439 8440 -- If the bounds of a 32-bit type are too large, force 64-bit type 8441 8442 if Actual_Size <= 32 8443 and then Small <= Ureal_2_31 8444 and then (Smaller (Expr_Value_R (Lo), Ureal_M_2_10_18) 8445 or else Larger (Expr_Value_R (Hi), Ureal_2_10_18)) 8446 then 8447 Actual_Size := 33; 8448 end if; 8449 8450 -- If the bounds of a 64-bit type are too large, force 128-bit type 8451 8452 if System_Max_Integer_Size = 128 8453 and then Actual_Size <= 64 8454 and then Small <= Ureal_2_63 8455 and then (Smaller (Expr_Value_R (Lo), Ureal_M_9_10_36) 8456 or else Larger (Expr_Value_R (Hi), Ureal_9_10_36)) 8457 then 8458 Actual_Size := 65; 8459 end if; 8460 8461 -- Give error messages for first subtypes and not base types, as the 8462 -- bounds of base types are always maximum for their size, see below. 8463 8464 if System_Max_Integer_Size < 128 and then Typ /= Btyp then 8465 8466 -- See the 128-bit case below for the reason why we cannot test 8467 -- against the 2**(-63) .. 2**63 range. This quirk should have 8468 -- been kludged around as in the 128-bit case below, but it was 8469 -- not and we end up with a ludicrous range as a result??? 8470 8471 if Small < Ureal_2_M_80 then 8472 Error_Msg_Name_1 := Name_Small; 8473 Error_Msg_N 8474 ("`&''%` too small, minimum allowed is 2.0'*'*(-80)", Typ); 8475 8476 elsif Small > Ureal_2_80 then 8477 Error_Msg_Name_1 := Name_Small; 8478 Error_Msg_N 8479 ("`&''%` too large, maximum allowed is 2.0'*'*80", Typ); 8480 end if; 8481 8482 if Smaller (Expr_Value_R (Lo), Ureal_M_9_10_36) then 8483 Error_Msg_Name_1 := Name_First; 8484 Error_Msg_N 8485 ("`&''%` too small, minimum allowed is -9.0E+36", Typ); 8486 end if; 8487 8488 if Larger (Expr_Value_R (Hi), Ureal_9_10_36) then 8489 Error_Msg_Name_1 := Name_Last; 8490 Error_Msg_N 8491 ("`&''%` too large, maximum allowed is 9.0E+36", Typ); 8492 end if; 8493 8494 elsif System_Max_Integer_Size = 128 and then Typ /= Btyp then 8495 8496 -- ACATS c35902d tests a delta equal to 2**(-(Max_Mantissa + 1)) 8497 -- but we cannot really support anything smaller than Fine_Delta 8498 -- because of the way we implement I/O for fixed point types??? 8499 8500 if Small = Ureal_2_M_128 then 8501 null; 8502 8503 elsif Small < Ureal_2_M_127 then 8504 Error_Msg_Name_1 := Name_Small; 8505 Error_Msg_N 8506 ("`&''%` too small, minimum allowed is 2.0'*'*(-127)", Typ); 8507 8508 elsif Small > Ureal_2_127 then 8509 Error_Msg_Name_1 := Name_Small; 8510 Error_Msg_N 8511 ("`&''%` too large, maximum allowed is 2.0'*'*127", Typ); 8512 end if; 8513 8514 if Actual_Size > 64 8515 and then (Norm_Num (Small) > Uint_2 ** 127 8516 or else Norm_Den (Small) > Uint_2 ** 127) 8517 and then Small /= Ureal_2_M_128 8518 then 8519 Error_Msg_Name_1 := Name_Small; 8520 Error_Msg_N 8521 ("`&''%` not the ratio of two 128-bit integers", Typ); 8522 end if; 8523 8524 if Smaller (Expr_Value_R (Lo), Ureal_M_10_76) then 8525 Error_Msg_Name_1 := Name_First; 8526 Error_Msg_N 8527 ("`&''%` too small, minimum allowed is -1.0E+76", Typ); 8528 end if; 8529 8530 if Larger (Expr_Value_R (Hi), Ureal_10_76) then 8531 Error_Msg_Name_1 := Name_Last; 8532 Error_Msg_N 8533 ("`&''%` too large, maximum allowed is 1.0E+76", Typ); 8534 end if; 8535 end if; 8536 8537 -- For the decimal case, none of this fudging is required, since there 8538 -- are no end-point problems in the decimal case (the end-points are 8539 -- always included). 8540 8541 else 8542 Actual_Size := Fsize (Loval, Hival); 8543 end if; 8544 8545 -- At this stage, the actual size has been calculated and the proper 8546 -- required bounds are stored in the low and high bounds. 8547 8548 if Actual_Size > System_Max_Integer_Size then 8549 Error_Msg_Uint_1 := UI_From_Int (Actual_Size); 8550 Error_Msg_Uint_2 := UI_From_Int (System_Max_Integer_Size); 8551 Error_Msg_N 8552 ("size required (^) for type& too large, maximum allowed is ^", 8553 Typ); 8554 Actual_Size := System_Max_Integer_Size; 8555 end if; 8556 8557 -- Check size against explicit given size 8558 8559 if Has_Size_Clause (Typ) then 8560 if Actual_Size > RM_Size (Typ) then 8561 Error_Msg_Uint_1 := RM_Size (Typ); 8562 Error_Msg_Uint_2 := UI_From_Int (Actual_Size); 8563 Error_Msg_NE 8564 ("size given (^) for type& too small, minimum allowed is ^", 8565 Size_Clause (Typ), Typ); 8566 8567 else 8568 Actual_Size := UI_To_Int (Esize (Typ)); 8569 end if; 8570 8571 -- Increase size to next natural boundary if no size clause given 8572 8573 else 8574 if Actual_Size <= 8 then 8575 Actual_Size := 8; 8576 elsif Actual_Size <= 16 then 8577 Actual_Size := 16; 8578 elsif Actual_Size <= 32 then 8579 Actual_Size := 32; 8580 elsif Actual_Size <= 64 then 8581 Actual_Size := 64; 8582 else 8583 Actual_Size := 128; 8584 end if; 8585 8586 Init_Esize (Typ, Actual_Size); 8587 Adjust_Esize_For_Alignment (Typ); 8588 end if; 8589 8590 -- If we have a base type, then expand the bounds so that they extend to 8591 -- the full width of the allocated size in bits, to avoid junk range 8592 -- checks on intermediate computations. 8593 8594 if Typ = Btyp then 8595 Set_Realval (Lo, -(Small * (Uint_2 ** (Actual_Size - 1)))); 8596 Set_Realval (Hi, (Small * (Uint_2 ** (Actual_Size - 1) - 1))); 8597 end if; 8598 8599 -- Final step is to reanalyze the bounds using the proper type 8600 -- and set the Corresponding_Integer_Value fields of the literals. 8601 8602 Set_Etype (Lo, Empty); 8603 Set_Analyzed (Lo, False); 8604 Analyze (Lo); 8605 8606 -- Resolve with universal fixed if the base type, and with the base 8607 -- type if we are freezing a subtype. Note we can't resolve the base 8608 -- type with itself, that would be a reference before definition. 8609 -- The resolution of the bounds of a subtype, if they are given by real 8610 -- literals, includes the setting of the Corresponding_Integer_Value, 8611 -- as for other literals of a fixed-point type. 8612 8613 if Typ = Btyp then 8614 Resolve (Lo, Universal_Fixed); 8615 Set_Corresponding_Integer_Value 8616 (Lo, UR_To_Uint (Realval (Lo) / Small)); 8617 else 8618 Resolve (Lo, Btyp); 8619 end if; 8620 8621 -- Similar processing for high bound 8622 8623 Set_Etype (Hi, Empty); 8624 Set_Analyzed (Hi, False); 8625 Analyze (Hi); 8626 8627 if Typ = Btyp then 8628 Resolve (Hi, Universal_Fixed); 8629 Set_Corresponding_Integer_Value 8630 (Hi, UR_To_Uint (Realval (Hi) / Small)); 8631 else 8632 Resolve (Hi, Btyp); 8633 end if; 8634 8635 -- Set type of range to correspond to bounds 8636 8637 Set_Etype (Rng, Etype (Lo)); 8638 8639 -- Set Esize to calculated size if not set already 8640 8641 if Unknown_Esize (Typ) then 8642 Init_Esize (Typ, Actual_Size); 8643 end if; 8644 8645 -- Set RM_Size if not already set. If already set, check value 8646 8647 declare 8648 Minsiz : constant Uint := UI_From_Int (Minimum_Size (Typ)); 8649 8650 begin 8651 if RM_Size (Typ) /= Uint_0 then 8652 if RM_Size (Typ) < Minsiz then 8653 Error_Msg_Uint_1 := RM_Size (Typ); 8654 Error_Msg_Uint_2 := Minsiz; 8655 Error_Msg_NE 8656 ("size given (^) for type& too small, minimum allowed is ^", 8657 Size_Clause (Typ), Typ); 8658 end if; 8659 8660 else 8661 Set_RM_Size (Typ, Minsiz); 8662 end if; 8663 end; 8664 8665 -- Check for shaving 8666 8667 if Comes_From_Source (Typ) then 8668 8669 -- In SPARK mode the given bounds must be strictly representable 8670 8671 if SPARK_Mode = On then 8672 if Orig_Lo < Expr_Value_R (Lo) then 8673 Error_Msg_NE 8674 ("declared low bound of type & is outside type range", 8675 Lo, Typ); 8676 end if; 8677 8678 if Orig_Hi > Expr_Value_R (Hi) then 8679 Error_Msg_NE 8680 ("declared high bound of type & is outside type range", 8681 Hi, Typ); 8682 end if; 8683 8684 else 8685 if Orig_Lo < Expr_Value_R (Lo) then 8686 Error_Msg_N 8687 ("declared low bound of type & is outside type range??", Typ); 8688 Error_Msg_N 8689 ("\low bound adjusted up by delta (RM 3.5.9(13))??", Typ); 8690 end if; 8691 8692 if Orig_Hi > Expr_Value_R (Hi) then 8693 Error_Msg_N 8694 ("declared high bound of type & is outside type range??", 8695 Typ); 8696 Error_Msg_N 8697 ("\high bound adjusted down by delta (RM 3.5.9(13))??", Typ); 8698 end if; 8699 end if; 8700 end if; 8701 end Freeze_Fixed_Point_Type; 8702 8703 ------------------ 8704 -- Freeze_Itype -- 8705 ------------------ 8706 8707 procedure Freeze_Itype (T : Entity_Id; N : Node_Id) is 8708 L : List_Id; 8709 8710 begin 8711 Set_Has_Delayed_Freeze (T); 8712 L := Freeze_Entity (T, N); 8713 8714 if Is_Non_Empty_List (L) then 8715 Insert_Actions (N, L); 8716 end if; 8717 end Freeze_Itype; 8718 8719 -------------------------- 8720 -- Freeze_Static_Object -- 8721 -------------------------- 8722 8723 procedure Freeze_Static_Object (E : Entity_Id) is 8724 8725 Cannot_Be_Static : exception; 8726 -- Exception raised if the type of a static object cannot be made 8727 -- static. This happens if the type depends on non-global objects. 8728 8729 procedure Ensure_Expression_Is_SA (N : Node_Id); 8730 -- Called to ensure that an expression used as part of a type definition 8731 -- is statically allocatable, which means that the expression type is 8732 -- statically allocatable, and the expression is either static, or a 8733 -- reference to a library level constant. 8734 8735 procedure Ensure_Type_Is_SA (Typ : Entity_Id); 8736 -- Called to mark a type as static, checking that it is possible 8737 -- to set the type as static. If it is not possible, then the 8738 -- exception Cannot_Be_Static is raised. 8739 8740 ----------------------------- 8741 -- Ensure_Expression_Is_SA -- 8742 ----------------------------- 8743 8744 procedure Ensure_Expression_Is_SA (N : Node_Id) is 8745 Ent : Entity_Id; 8746 8747 begin 8748 Ensure_Type_Is_SA (Etype (N)); 8749 8750 if Is_OK_Static_Expression (N) then 8751 return; 8752 8753 elsif Nkind (N) = N_Identifier then 8754 Ent := Entity (N); 8755 8756 if Present (Ent) 8757 and then Ekind (Ent) = E_Constant 8758 and then Is_Library_Level_Entity (Ent) 8759 then 8760 return; 8761 end if; 8762 end if; 8763 8764 raise Cannot_Be_Static; 8765 end Ensure_Expression_Is_SA; 8766 8767 ----------------------- 8768 -- Ensure_Type_Is_SA -- 8769 ----------------------- 8770 8771 procedure Ensure_Type_Is_SA (Typ : Entity_Id) is 8772 N : Node_Id; 8773 C : Entity_Id; 8774 8775 begin 8776 -- If type is library level, we are all set 8777 8778 if Is_Library_Level_Entity (Typ) then 8779 return; 8780 end if; 8781 8782 -- We are also OK if the type already marked as statically allocated, 8783 -- which means we processed it before. 8784 8785 if Is_Statically_Allocated (Typ) then 8786 return; 8787 end if; 8788 8789 -- Mark type as statically allocated 8790 8791 Set_Is_Statically_Allocated (Typ); 8792 8793 -- Check that it is safe to statically allocate this type 8794 8795 if Is_Scalar_Type (Typ) or else Is_Real_Type (Typ) then 8796 Ensure_Expression_Is_SA (Type_Low_Bound (Typ)); 8797 Ensure_Expression_Is_SA (Type_High_Bound (Typ)); 8798 8799 elsif Is_Array_Type (Typ) then 8800 N := First_Index (Typ); 8801 while Present (N) loop 8802 Ensure_Type_Is_SA (Etype (N)); 8803 Next_Index (N); 8804 end loop; 8805 8806 Ensure_Type_Is_SA (Component_Type (Typ)); 8807 8808 elsif Is_Access_Type (Typ) then 8809 if Ekind (Designated_Type (Typ)) = E_Subprogram_Type then 8810 8811 declare 8812 F : Entity_Id; 8813 T : constant Entity_Id := Etype (Designated_Type (Typ)); 8814 8815 begin 8816 if T /= Standard_Void_Type then 8817 Ensure_Type_Is_SA (T); 8818 end if; 8819 8820 F := First_Formal (Designated_Type (Typ)); 8821 while Present (F) loop 8822 Ensure_Type_Is_SA (Etype (F)); 8823 Next_Formal (F); 8824 end loop; 8825 end; 8826 8827 else 8828 Ensure_Type_Is_SA (Designated_Type (Typ)); 8829 end if; 8830 8831 elsif Is_Record_Type (Typ) then 8832 C := First_Entity (Typ); 8833 while Present (C) loop 8834 if Ekind (C) = E_Discriminant 8835 or else Ekind (C) = E_Component 8836 then 8837 Ensure_Type_Is_SA (Etype (C)); 8838 8839 elsif Is_Type (C) then 8840 Ensure_Type_Is_SA (C); 8841 end if; 8842 8843 Next_Entity (C); 8844 end loop; 8845 8846 elsif Ekind (Typ) = E_Subprogram_Type then 8847 Ensure_Type_Is_SA (Etype (Typ)); 8848 8849 C := First_Formal (Typ); 8850 while Present (C) loop 8851 Ensure_Type_Is_SA (Etype (C)); 8852 Next_Formal (C); 8853 end loop; 8854 8855 else 8856 raise Cannot_Be_Static; 8857 end if; 8858 end Ensure_Type_Is_SA; 8859 8860 -- Start of processing for Freeze_Static_Object 8861 8862 begin 8863 Ensure_Type_Is_SA (Etype (E)); 8864 8865 exception 8866 when Cannot_Be_Static => 8867 8868 -- If the object that cannot be static is imported or exported, then 8869 -- issue an error message saying that this object cannot be imported 8870 -- or exported. If it has an address clause it is an overlay in the 8871 -- current partition and the static requirement is not relevant. 8872 -- Do not issue any error message when ignoring rep clauses. 8873 8874 if Ignore_Rep_Clauses then 8875 null; 8876 8877 elsif Is_Imported (E) then 8878 if No (Address_Clause (E)) then 8879 Error_Msg_N 8880 ("& cannot be imported (local type is not constant)", E); 8881 end if; 8882 8883 -- Otherwise must be exported, something is wrong if compiler 8884 -- is marking something as statically allocated which cannot be). 8885 8886 else pragma Assert (Is_Exported (E)); 8887 Error_Msg_N 8888 ("& cannot be exported (local type is not constant)", E); 8889 end if; 8890 end Freeze_Static_Object; 8891 8892 ----------------------- 8893 -- Freeze_Subprogram -- 8894 ----------------------- 8895 8896 procedure Freeze_Subprogram (E : Entity_Id) is 8897 function Check_Extra_Formals (E : Entity_Id) return Boolean; 8898 -- Return True if the decoration of the attributes associated with extra 8899 -- formals are properly set. 8900 8901 procedure Set_Profile_Convention (Subp_Id : Entity_Id); 8902 -- Set the conventions of all anonymous access-to-subprogram formals and 8903 -- result subtype of subprogram Subp_Id to the convention of Subp_Id. 8904 8905 ------------------------- 8906 -- Check_Extra_Formals -- 8907 ------------------------- 8908 8909 function Check_Extra_Formals (E : Entity_Id) return Boolean is 8910 Last_Formal : Entity_Id := Empty; 8911 Formal : Entity_Id; 8912 Has_Extra_Formals : Boolean := False; 8913 8914 begin 8915 -- No check required if expansion is disabled because extra 8916 -- formals are only generated when we are generating code. 8917 -- See Create_Extra_Formals. 8918 8919 if not Expander_Active then 8920 return True; 8921 end if; 8922 8923 -- Check attribute Extra_Formal: If available, it must be set only 8924 -- on the last formal of E. 8925 8926 Formal := First_Formal (E); 8927 while Present (Formal) loop 8928 if Present (Extra_Formal (Formal)) then 8929 if Has_Extra_Formals then 8930 return False; 8931 end if; 8932 8933 Has_Extra_Formals := True; 8934 end if; 8935 8936 Last_Formal := Formal; 8937 Next_Formal (Formal); 8938 end loop; 8939 8940 -- Check attribute Extra_Accessibility_Of_Result 8941 8942 if Ekind (E) in E_Function | E_Subprogram_Type 8943 and then Needs_Result_Accessibility_Level (E) 8944 and then No (Extra_Accessibility_Of_Result (E)) 8945 then 8946 return False; 8947 end if; 8948 8949 -- Check attribute Extra_Formals: If E has extra formals, then this 8950 -- attribute must point to the first extra formal of E. 8951 8952 if Has_Extra_Formals then 8953 return Present (Extra_Formals (E)) 8954 and then Present (Extra_Formal (Last_Formal)) 8955 and then Extra_Formal (Last_Formal) = Extra_Formals (E); 8956 8957 -- When E has no formals, the first extra formal is available through 8958 -- the Extra_Formals attribute. 8959 8960 elsif Present (Extra_Formals (E)) then 8961 return No (First_Formal (E)); 8962 8963 else 8964 return True; 8965 end if; 8966 end Check_Extra_Formals; 8967 8968 ---------------------------- 8969 -- Set_Profile_Convention -- 8970 ---------------------------- 8971 8972 procedure Set_Profile_Convention (Subp_Id : Entity_Id) is 8973 Conv : constant Convention_Id := Convention (Subp_Id); 8974 8975 procedure Set_Type_Convention (Typ : Entity_Id); 8976 -- Set the convention of anonymous access-to-subprogram type Typ and 8977 -- its designated type to Conv. 8978 8979 ------------------------- 8980 -- Set_Type_Convention -- 8981 ------------------------- 8982 8983 procedure Set_Type_Convention (Typ : Entity_Id) is 8984 begin 8985 -- Set the convention on both the anonymous access-to-subprogram 8986 -- type and the subprogram type it points to because both types 8987 -- participate in conformance-related checks. 8988 8989 if Ekind (Typ) = E_Anonymous_Access_Subprogram_Type then 8990 Set_Convention (Typ, Conv); 8991 Set_Convention (Designated_Type (Typ), Conv); 8992 end if; 8993 end Set_Type_Convention; 8994 8995 -- Local variables 8996 8997 Formal : Entity_Id; 8998 8999 -- Start of processing for Set_Profile_Convention 9000 9001 begin 9002 Formal := First_Formal (Subp_Id); 9003 while Present (Formal) loop 9004 Set_Type_Convention (Etype (Formal)); 9005 Next_Formal (Formal); 9006 end loop; 9007 9008 if Ekind (Subp_Id) = E_Function then 9009 Set_Type_Convention (Etype (Subp_Id)); 9010 end if; 9011 end Set_Profile_Convention; 9012 9013 -- Local variables 9014 9015 F : Entity_Id; 9016 Retype : Entity_Id; 9017 9018 -- Start of processing for Freeze_Subprogram 9019 9020 begin 9021 -- Subprogram may not have an address clause unless it is imported 9022 9023 if Present (Address_Clause (E)) then 9024 if not Is_Imported (E) then 9025 Error_Msg_N 9026 ("address clause can only be given for imported subprogram", 9027 Name (Address_Clause (E))); 9028 end if; 9029 end if; 9030 9031 -- Reset the Pure indication on an imported subprogram unless an 9032 -- explicit Pure_Function pragma was present or the subprogram is an 9033 -- intrinsic. We do this because otherwise it is an insidious error 9034 -- to call a non-pure function from pure unit and have calls 9035 -- mysteriously optimized away. What happens here is that the Import 9036 -- can bypass the normal check to ensure that pure units call only pure 9037 -- subprograms. 9038 9039 -- The reason for the intrinsic exception is that in general, intrinsic 9040 -- functions (such as shifts) are pure anyway. The only exceptions are 9041 -- the intrinsics in GNAT.Source_Info, and that unit is not marked Pure 9042 -- in any case, so no problem arises. 9043 9044 if Is_Imported (E) 9045 and then Is_Pure (E) 9046 and then not Has_Pragma_Pure_Function (E) 9047 and then not Is_Intrinsic_Subprogram (E) 9048 then 9049 Set_Is_Pure (E, False); 9050 end if; 9051 9052 -- For C++ constructors check that their external name has been given 9053 -- (either in pragma CPP_Constructor or in a pragma import). 9054 9055 if Is_Constructor (E) 9056 and then Convention (E) = Convention_CPP 9057 and then 9058 (No (Interface_Name (E)) 9059 or else String_Equal 9060 (L => Strval (Interface_Name (E)), 9061 R => Strval (Get_Default_External_Name (E)))) 9062 then 9063 Error_Msg_N 9064 ("'C++ constructor must have external name or link name", E); 9065 end if; 9066 9067 -- We also reset the Pure indication on a subprogram with an Address 9068 -- parameter, because the parameter may be used as a pointer and the 9069 -- referenced data may change even if the address value does not. 9070 9071 -- Note that if the programmer gave an explicit Pure_Function pragma, 9072 -- then we believe the programmer, and leave the subprogram Pure. We 9073 -- also suppress this check on run-time files. 9074 9075 if Is_Pure (E) 9076 and then Is_Subprogram (E) 9077 and then not Has_Pragma_Pure_Function (E) 9078 and then not Is_Internal_Unit (Current_Sem_Unit) 9079 then 9080 Check_Function_With_Address_Parameter (E); 9081 end if; 9082 9083 -- Ensure that all anonymous access-to-subprogram types inherit the 9084 -- convention of their related subprogram (RM 6.3.1 13.1/3). This is 9085 -- not done for a defaulted convention Ada because those types also 9086 -- default to Ada. Convention Protected must not be propagated when 9087 -- the subprogram is an entry because this would be illegal. The only 9088 -- way to force convention Protected on these kinds of types is to 9089 -- include keyword "protected" in the access definition. 9090 9091 if Convention (E) /= Convention_Ada 9092 and then Convention (E) /= Convention_Protected 9093 then 9094 Set_Profile_Convention (E); 9095 end if; 9096 9097 -- For non-foreign convention subprograms, this is where we create 9098 -- the extra formals (for accessibility level and constrained bit 9099 -- information). We delay this till the freeze point precisely so 9100 -- that we know the convention. 9101 9102 if not Has_Foreign_Convention (E) then 9103 if No (Extra_Formals (E)) then 9104 9105 -- Extra formals are shared by derived subprograms; therefore, if 9106 -- the ultimate alias of E has been frozen before E then the extra 9107 -- formals have been added, but the attribute Extra_Formals is 9108 -- still unset (and must be set now). 9109 9110 if Present (Alias (E)) 9111 and then Is_Frozen (Ultimate_Alias (E)) 9112 and then Present (Extra_Formals (Ultimate_Alias (E))) 9113 and then Last_Formal (Ultimate_Alias (E)) = Last_Formal (E) 9114 then 9115 Set_Extra_Formals (E, Extra_Formals (Ultimate_Alias (E))); 9116 9117 if Ekind (E) = E_Function then 9118 Set_Extra_Accessibility_Of_Result (E, 9119 Extra_Accessibility_Of_Result (Ultimate_Alias (E))); 9120 end if; 9121 else 9122 Create_Extra_Formals (E); 9123 end if; 9124 end if; 9125 9126 pragma Assert (Check_Extra_Formals (E)); 9127 Set_Mechanisms (E); 9128 9129 -- If this is convention Ada and a Valued_Procedure, that's odd 9130 9131 if Ekind (E) = E_Procedure 9132 and then Is_Valued_Procedure (E) 9133 and then Convention (E) = Convention_Ada 9134 and then Warn_On_Export_Import 9135 then 9136 Error_Msg_N 9137 ("??Valued_Procedure has no effect for convention Ada", E); 9138 Set_Is_Valued_Procedure (E, False); 9139 end if; 9140 9141 -- Case of foreign convention 9142 9143 else 9144 Set_Mechanisms (E); 9145 9146 -- For foreign conventions, warn about return of unconstrained array 9147 9148 if Ekind (E) = E_Function then 9149 Retype := Underlying_Type (Etype (E)); 9150 9151 -- If no return type, probably some other error, e.g. a 9152 -- missing full declaration, so ignore. 9153 9154 if No (Retype) then 9155 null; 9156 9157 -- If the return type is generic, we have emitted a warning 9158 -- earlier on, and there is nothing else to check here. Specific 9159 -- instantiations may lead to erroneous behavior. 9160 9161 elsif Is_Generic_Type (Etype (E)) then 9162 null; 9163 9164 -- Display warning if returning unconstrained array 9165 9166 elsif Is_Array_Type (Retype) 9167 and then not Is_Constrained (Retype) 9168 9169 -- Check appropriate warning is enabled (should we check for 9170 -- Warnings (Off) on specific entities here, probably so???) 9171 9172 and then Warn_On_Export_Import 9173 then 9174 Error_Msg_N 9175 ("?x?foreign convention function& should not return " & 9176 "unconstrained array", E); 9177 return; 9178 end if; 9179 end if; 9180 9181 -- If any of the formals for an exported foreign convention 9182 -- subprogram have defaults, then emit an appropriate warning since 9183 -- this is odd (default cannot be used from non-Ada code) 9184 9185 if Is_Exported (E) then 9186 F := First_Formal (E); 9187 while Present (F) loop 9188 if Warn_On_Export_Import 9189 and then Present (Default_Value (F)) 9190 then 9191 Error_Msg_N 9192 ("?x?parameter cannot be defaulted in non-Ada call", 9193 Default_Value (F)); 9194 end if; 9195 9196 Next_Formal (F); 9197 end loop; 9198 end if; 9199 end if; 9200 9201 -- Pragma Inline_Always is disallowed for dispatching subprograms 9202 -- because the address of such subprograms is saved in the dispatch 9203 -- table to support dispatching calls, and dispatching calls cannot 9204 -- be inlined. This is consistent with the restriction against using 9205 -- 'Access or 'Address on an Inline_Always subprogram. 9206 9207 if Is_Dispatching_Operation (E) 9208 and then Has_Pragma_Inline_Always (E) 9209 then 9210 Error_Msg_N 9211 ("pragma Inline_Always not allowed for dispatching subprograms", E); 9212 end if; 9213 9214 -- Because of the implicit representation of inherited predefined 9215 -- operators in the front-end, the overriding status of the operation 9216 -- may be affected when a full view of a type is analyzed, and this is 9217 -- not captured by the analysis of the corresponding type declaration. 9218 -- Therefore the correctness of a not-overriding indicator must be 9219 -- rechecked when the subprogram is frozen. 9220 9221 if Nkind (E) = N_Defining_Operator_Symbol 9222 and then not Error_Posted (Parent (E)) 9223 then 9224 Check_Overriding_Indicator (E, Empty, Is_Primitive (E)); 9225 end if; 9226 9227 Retype := Get_Fullest_View (Etype (E)); 9228 9229 if Transform_Function_Array 9230 and then Nkind (Parent (E)) = N_Function_Specification 9231 and then Is_Array_Type (Retype) 9232 and then Is_Constrained (Retype) 9233 and then not Is_Unchecked_Conversion_Instance (E) 9234 and then not Rewritten_For_C (E) 9235 then 9236 Build_Procedure_Form (Unit_Declaration_Node (E)); 9237 end if; 9238 end Freeze_Subprogram; 9239 9240 ---------------------- 9241 -- Is_Fully_Defined -- 9242 ---------------------- 9243 9244 function Is_Fully_Defined (T : Entity_Id) return Boolean is 9245 begin 9246 if Ekind (T) = E_Class_Wide_Type then 9247 return Is_Fully_Defined (Etype (T)); 9248 9249 elsif Is_Array_Type (T) then 9250 return Is_Fully_Defined (Component_Type (T)); 9251 9252 elsif Is_Record_Type (T) 9253 and not Is_Private_Type (T) 9254 then 9255 -- Verify that the record type has no components with private types 9256 -- without completion. 9257 9258 declare 9259 Comp : Entity_Id; 9260 9261 begin 9262 Comp := First_Component (T); 9263 while Present (Comp) loop 9264 if not Is_Fully_Defined (Etype (Comp)) then 9265 return False; 9266 end if; 9267 9268 Next_Component (Comp); 9269 end loop; 9270 return True; 9271 end; 9272 9273 -- For the designated type of an access to subprogram, all types in 9274 -- the profile must be fully defined. 9275 9276 elsif Ekind (T) = E_Subprogram_Type then 9277 declare 9278 F : Entity_Id; 9279 9280 begin 9281 F := First_Formal (T); 9282 while Present (F) loop 9283 if not Is_Fully_Defined (Etype (F)) then 9284 return False; 9285 end if; 9286 9287 Next_Formal (F); 9288 end loop; 9289 9290 return Is_Fully_Defined (Etype (T)); 9291 end; 9292 9293 else 9294 return not Is_Private_Type (T) 9295 or else Present (Full_View (Base_Type (T))); 9296 end if; 9297 end Is_Fully_Defined; 9298 9299 --------------------------------- 9300 -- Process_Default_Expressions -- 9301 --------------------------------- 9302 9303 procedure Process_Default_Expressions 9304 (E : Entity_Id; 9305 After : in out Node_Id) 9306 is 9307 Loc : constant Source_Ptr := Sloc (E); 9308 Dbody : Node_Id; 9309 Formal : Node_Id; 9310 Dcopy : Node_Id; 9311 Dnam : Entity_Id; 9312 9313 begin 9314 Set_Default_Expressions_Processed (E); 9315 9316 -- A subprogram instance and its associated anonymous subprogram share 9317 -- their signature. The default expression functions are defined in the 9318 -- wrapper packages for the anonymous subprogram, and should not be 9319 -- generated again for the instance. 9320 9321 if Is_Generic_Instance (E) 9322 and then Present (Alias (E)) 9323 and then Default_Expressions_Processed (Alias (E)) 9324 then 9325 return; 9326 end if; 9327 9328 Formal := First_Formal (E); 9329 while Present (Formal) loop 9330 if Present (Default_Value (Formal)) then 9331 9332 -- We work with a copy of the default expression because we 9333 -- do not want to disturb the original, since this would mess 9334 -- up the conformance checking. 9335 9336 Dcopy := New_Copy_Tree (Default_Value (Formal)); 9337 9338 -- The analysis of the expression may generate insert actions, 9339 -- which of course must not be executed. We wrap those actions 9340 -- in a procedure that is not called, and later on eliminated. 9341 -- The following cases have no side effects, and are analyzed 9342 -- directly. 9343 9344 if Nkind (Dcopy) = N_Identifier 9345 or else Nkind (Dcopy) in N_Expanded_Name 9346 | N_Integer_Literal 9347 | N_Character_Literal 9348 | N_String_Literal 9349 | N_Real_Literal 9350 or else (Nkind (Dcopy) = N_Attribute_Reference 9351 and then Attribute_Name (Dcopy) = Name_Null_Parameter) 9352 or else Known_Null (Dcopy) 9353 then 9354 -- If there is no default function, we must still do a full 9355 -- analyze call on the default value, to ensure that all error 9356 -- checks are performed, e.g. those associated with static 9357 -- evaluation. Note: this branch will always be taken if the 9358 -- analyzer is turned off (but we still need the error checks). 9359 9360 -- Note: the setting of parent here is to meet the requirement 9361 -- that we can only analyze the expression while attached to 9362 -- the tree. Really the requirement is that the parent chain 9363 -- be set, we don't actually need to be in the tree. 9364 9365 Set_Parent (Dcopy, Declaration_Node (Formal)); 9366 Analyze (Dcopy); 9367 9368 -- Default expressions are resolved with their own type if the 9369 -- context is generic, to avoid anomalies with private types. 9370 9371 if Ekind (Scope (E)) = E_Generic_Package then 9372 Resolve (Dcopy); 9373 else 9374 Resolve (Dcopy, Etype (Formal)); 9375 end if; 9376 9377 -- If that resolved expression will raise constraint error, 9378 -- then flag the default value as raising constraint error. 9379 -- This allows a proper error message on the calls. 9380 9381 if Raises_Constraint_Error (Dcopy) then 9382 Set_Raises_Constraint_Error (Default_Value (Formal)); 9383 end if; 9384 9385 -- If the default is a parameterless call, we use the name of 9386 -- the called function directly, and there is no body to build. 9387 9388 elsif Nkind (Dcopy) = N_Function_Call 9389 and then No (Parameter_Associations (Dcopy)) 9390 then 9391 null; 9392 9393 -- Else construct and analyze the body of a wrapper procedure 9394 -- that contains an object declaration to hold the expression. 9395 -- Given that this is done only to complete the analysis, it is 9396 -- simpler to build a procedure than a function which might 9397 -- involve secondary stack expansion. 9398 9399 else 9400 Dnam := Make_Temporary (Loc, 'D'); 9401 9402 Dbody := 9403 Make_Subprogram_Body (Loc, 9404 Specification => 9405 Make_Procedure_Specification (Loc, 9406 Defining_Unit_Name => Dnam), 9407 9408 Declarations => New_List ( 9409 Make_Object_Declaration (Loc, 9410 Defining_Identifier => Make_Temporary (Loc, 'T'), 9411 Object_Definition => 9412 New_Occurrence_Of (Etype (Formal), Loc), 9413 Expression => New_Copy_Tree (Dcopy))), 9414 9415 Handled_Statement_Sequence => 9416 Make_Handled_Sequence_Of_Statements (Loc, 9417 Statements => Empty_List)); 9418 9419 Set_Scope (Dnam, Scope (E)); 9420 Set_Assignment_OK (First (Declarations (Dbody))); 9421 Set_Is_Eliminated (Dnam); 9422 Insert_After (After, Dbody); 9423 Analyze (Dbody); 9424 After := Dbody; 9425 end if; 9426 end if; 9427 9428 Next_Formal (Formal); 9429 end loop; 9430 end Process_Default_Expressions; 9431 9432 ---------------------------------------- 9433 -- Set_Component_Alignment_If_Not_Set -- 9434 ---------------------------------------- 9435 9436 procedure Set_Component_Alignment_If_Not_Set (Typ : Entity_Id) is 9437 begin 9438 -- Ignore if not base type, subtypes don't need anything 9439 9440 if Typ /= Base_Type (Typ) then 9441 return; 9442 end if; 9443 9444 -- Do not override existing representation 9445 9446 if Is_Packed (Typ) then 9447 return; 9448 9449 elsif Has_Specified_Layout (Typ) then 9450 return; 9451 9452 elsif Component_Alignment (Typ) /= Calign_Default then 9453 return; 9454 9455 else 9456 Set_Component_Alignment 9457 (Typ, Scope_Stack.Table 9458 (Scope_Stack.Last).Component_Alignment_Default); 9459 end if; 9460 end Set_Component_Alignment_If_Not_Set; 9461 9462 -------------------------- 9463 -- Set_SSO_From_Default -- 9464 -------------------------- 9465 9466 procedure Set_SSO_From_Default (T : Entity_Id) is 9467 Reversed : Boolean; 9468 9469 begin 9470 -- Set default SSO for an array or record base type, except in case of 9471 -- a type extension (which always inherits the SSO of its parent type). 9472 9473 if Is_Base_Type (T) 9474 and then (Is_Array_Type (T) 9475 or else (Is_Record_Type (T) 9476 and then not (Is_Tagged_Type (T) 9477 and then Is_Derived_Type (T)))) 9478 then 9479 Reversed := 9480 (Bytes_Big_Endian and then SSO_Set_Low_By_Default (T)) 9481 or else 9482 (not Bytes_Big_Endian and then SSO_Set_High_By_Default (T)); 9483 9484 if (SSO_Set_Low_By_Default (T) or else SSO_Set_High_By_Default (T)) 9485 9486 -- For a record type, if bit order is specified explicitly, 9487 -- then do not set SSO from default if not consistent. Note that 9488 -- we do not want to look at a Bit_Order attribute definition 9489 -- for a parent: if we were to inherit Bit_Order, then both 9490 -- SSO_Set_*_By_Default flags would have been cleared already 9491 -- (by Inherit_Aspects_At_Freeze_Point). 9492 9493 and then not 9494 (Is_Record_Type (T) 9495 and then 9496 Has_Rep_Item (T, Name_Bit_Order, Check_Parents => False) 9497 and then Reverse_Bit_Order (T) /= Reversed) 9498 then 9499 -- If flags cause reverse storage order, then set the result. Note 9500 -- that we would have ignored the pragma setting the non default 9501 -- storage order in any case, hence the assertion at this point. 9502 9503 pragma Assert 9504 (not Reversed or else Support_Nondefault_SSO_On_Target); 9505 9506 Set_Reverse_Storage_Order (T, Reversed); 9507 9508 -- For a record type, also set reversed bit order. Note: if a bit 9509 -- order has been specified explicitly, then this is a no-op. 9510 9511 if Is_Record_Type (T) then 9512 Set_Reverse_Bit_Order (T, Reversed); 9513 end if; 9514 end if; 9515 end if; 9516 end Set_SSO_From_Default; 9517 9518 ------------------ 9519 -- Undelay_Type -- 9520 ------------------ 9521 9522 procedure Undelay_Type (T : Entity_Id) is 9523 begin 9524 Set_Has_Delayed_Freeze (T, False); 9525 Set_Freeze_Node (T, Empty); 9526 9527 -- Since we don't want T to have a Freeze_Node, we don't want its 9528 -- Full_View or Corresponding_Record_Type to have one either. 9529 9530 -- ??? Fundamentally, this whole handling is unpleasant. What we really 9531 -- want is to be sure that for an Itype that's part of record R and is a 9532 -- subtype of type T, that it's frozen after the later of the freeze 9533 -- points of R and T. We have no way of doing that directly, so what we 9534 -- do is force most such Itypes to be frozen as part of freezing R via 9535 -- this procedure and only delay the ones that need to be delayed 9536 -- (mostly the designated types of access types that are defined as part 9537 -- of the record). 9538 9539 if Is_Private_Type (T) 9540 and then Present (Full_View (T)) 9541 and then Is_Itype (Full_View (T)) 9542 and then Is_Record_Type (Scope (Full_View (T))) 9543 then 9544 Undelay_Type (Full_View (T)); 9545 end if; 9546 9547 if Is_Concurrent_Type (T) 9548 and then Present (Corresponding_Record_Type (T)) 9549 and then Is_Itype (Corresponding_Record_Type (T)) 9550 and then Is_Record_Type (Scope (Corresponding_Record_Type (T))) 9551 then 9552 Undelay_Type (Corresponding_Record_Type (T)); 9553 end if; 9554 end Undelay_Type; 9555 9556 ------------------ 9557 -- Warn_Overlay -- 9558 ------------------ 9559 9560 procedure Warn_Overlay (Expr : Node_Id; Typ : Entity_Id; Nam : Entity_Id) is 9561 Ent : constant Entity_Id := Entity (Nam); 9562 -- The object to which the address clause applies 9563 9564 Init : Node_Id; 9565 Old : Entity_Id := Empty; 9566 Decl : Node_Id; 9567 9568 begin 9569 -- No warning if address clause overlay warnings are off 9570 9571 if not Address_Clause_Overlay_Warnings then 9572 return; 9573 end if; 9574 9575 -- No warning if there is an explicit initialization 9576 9577 Init := Original_Node (Expression (Declaration_Node (Ent))); 9578 9579 if Present (Init) and then Comes_From_Source (Init) then 9580 return; 9581 end if; 9582 9583 -- We only give the warning for non-imported entities of a type for 9584 -- which a non-null base init proc is defined, or for objects of access 9585 -- types with implicit null initialization, or when Normalize_Scalars 9586 -- applies and the type is scalar or a string type (the latter being 9587 -- tested for because predefined String types are initialized by inline 9588 -- code rather than by an init_proc). Note that we do not give the 9589 -- warning for Initialize_Scalars, since we suppressed initialization 9590 -- in this case. Also, do not warn if Suppress_Initialization is set 9591 -- either on the type, or on the object via pragma or aspect. 9592 9593 if Present (Expr) 9594 and then not Is_Imported (Ent) 9595 and then not Initialization_Suppressed (Typ) 9596 and then not (Ekind (Ent) = E_Variable 9597 and then Initialization_Suppressed (Ent)) 9598 and then (Has_Non_Null_Base_Init_Proc (Typ) 9599 or else Is_Access_Type (Typ) 9600 or else (Normalize_Scalars 9601 and then (Is_Scalar_Type (Typ) 9602 or else Is_String_Type (Typ)))) 9603 then 9604 if Nkind (Expr) = N_Attribute_Reference 9605 and then Is_Entity_Name (Prefix (Expr)) 9606 then 9607 Old := Entity (Prefix (Expr)); 9608 9609 elsif Is_Entity_Name (Expr) 9610 and then Ekind (Entity (Expr)) = E_Constant 9611 then 9612 Decl := Declaration_Node (Entity (Expr)); 9613 9614 if Nkind (Decl) = N_Object_Declaration 9615 and then Present (Expression (Decl)) 9616 and then Nkind (Expression (Decl)) = N_Attribute_Reference 9617 and then Is_Entity_Name (Prefix (Expression (Decl))) 9618 then 9619 Old := Entity (Prefix (Expression (Decl))); 9620 9621 elsif Nkind (Expr) = N_Function_Call then 9622 return; 9623 end if; 9624 9625 -- A function call (most likely to To_Address) is probably not an 9626 -- overlay, so skip warning. Ditto if the function call was inlined 9627 -- and transformed into an entity. 9628 9629 elsif Nkind (Original_Node (Expr)) = N_Function_Call then 9630 return; 9631 end if; 9632 9633 -- If a pragma Import follows, we assume that it is for the current 9634 -- target of the address clause, and skip the warning. There may be 9635 -- a source pragma or an aspect that specifies import and generates 9636 -- the corresponding pragma. These will indicate that the entity is 9637 -- imported and that is checked above so that the spurious warning 9638 -- (generated when the entity is frozen) will be suppressed. The 9639 -- pragma may be attached to the aspect, so it is not yet a list 9640 -- member. 9641 9642 if Is_List_Member (Parent (Expr)) then 9643 Decl := Next (Parent (Expr)); 9644 9645 if Present (Decl) 9646 and then Nkind (Decl) = N_Pragma 9647 and then Pragma_Name (Decl) = Name_Import 9648 then 9649 return; 9650 end if; 9651 end if; 9652 9653 -- Otherwise give warning message 9654 9655 if Present (Old) then 9656 Error_Msg_Node_2 := Old; 9657 Error_Msg_N 9658 ("default initialization of & may modify &??", 9659 Nam); 9660 else 9661 Error_Msg_N 9662 ("default initialization of & may modify overlaid storage??", 9663 Nam); 9664 end if; 9665 9666 -- Add friendly warning if initialization comes from a packed array 9667 -- component. 9668 9669 if Is_Record_Type (Typ) then 9670 declare 9671 Comp : Entity_Id; 9672 9673 begin 9674 Comp := First_Component (Typ); 9675 while Present (Comp) loop 9676 if Nkind (Parent (Comp)) = N_Component_Declaration 9677 and then Present (Expression (Parent (Comp))) 9678 then 9679 exit; 9680 elsif Is_Array_Type (Etype (Comp)) 9681 and then Present (Packed_Array_Impl_Type (Etype (Comp))) 9682 then 9683 Error_Msg_NE 9684 ("\packed array component& " & 9685 "will be initialized to zero??", 9686 Nam, Comp); 9687 exit; 9688 else 9689 Next_Component (Comp); 9690 end if; 9691 end loop; 9692 end; 9693 end if; 9694 9695 Error_Msg_N 9696 ("\use pragma Import for & to " & 9697 "suppress initialization (RM B.1(24))??", 9698 Nam); 9699 end if; 9700 end Warn_Overlay; 9701 9702end Freeze; 9703