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