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