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-2013, Free Software Foundation, Inc. -- 10-- -- 11-- GNAT is free software; you can redistribute it and/or modify it under -- 12-- terms of the GNU General Public License as published by the Free Soft- -- 13-- ware Foundation; either version 3, or (at your option) any later ver- -- 14-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 15-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 16-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- 17-- for more details. You should have received a copy of the GNU General -- 18-- Public License distributed with GNAT; see file COPYING3. If not, go to -- 19-- http://www.gnu.org/licenses for a complete copy of the license. -- 20-- -- 21-- GNAT was originally developed by the GNAT team at New York University. -- 22-- Extensive contributions were provided by Ada Core Technologies Inc. -- 23-- -- 24------------------------------------------------------------------------------ 25 26with Atree; use Atree; 27with Checks; use Checks; 28with Debug; use Debug; 29with Einfo; use Einfo; 30with Elists; use Elists; 31with Errout; use Errout; 32with Exp_Ch3; use Exp_Ch3; 33with Exp_Ch7; use Exp_Ch7; 34with Exp_Disp; use Exp_Disp; 35with Exp_Pakd; use Exp_Pakd; 36with Exp_Util; use Exp_Util; 37with Exp_Tss; use Exp_Tss; 38with Layout; use Layout; 39with Lib; use Lib; 40with Namet; use Namet; 41with Nlists; use Nlists; 42with Nmake; use Nmake; 43with Opt; use Opt; 44with Restrict; use Restrict; 45with Rident; use Rident; 46with Rtsfind; use Rtsfind; 47with Sem; use Sem; 48with Sem_Aux; use Sem_Aux; 49with Sem_Cat; use Sem_Cat; 50with Sem_Ch6; use Sem_Ch6; 51with Sem_Ch7; use Sem_Ch7; 52with Sem_Ch8; use Sem_Ch8; 53with Sem_Ch9; use Sem_Ch9; 54with Sem_Ch13; use Sem_Ch13; 55with Sem_Eval; use Sem_Eval; 56with Sem_Mech; use Sem_Mech; 57with Sem_Prag; use Sem_Prag; 58with Sem_Res; use Sem_Res; 59with Sem_Util; use Sem_Util; 60with Sinfo; use Sinfo; 61with Snames; use Snames; 62with Stand; use Stand; 63with Targparm; use Targparm; 64with Tbuild; use Tbuild; 65with Ttypes; use Ttypes; 66with Uintp; use Uintp; 67with Urealp; use Urealp; 68 69package body Freeze is 70 71 ----------------------- 72 -- Local Subprograms -- 73 ----------------------- 74 75 procedure Adjust_Esize_For_Alignment (Typ : Entity_Id); 76 -- Typ is a type that is being frozen. If no size clause is given, 77 -- but a default Esize has been computed, then this default Esize is 78 -- adjusted up if necessary to be consistent with a given alignment, 79 -- but never to a value greater than Long_Long_Integer'Size. This 80 -- is used for all discrete types and for fixed-point types. 81 82 procedure Build_And_Analyze_Renamed_Body 83 (Decl : Node_Id; 84 New_S : Entity_Id; 85 After : in out Node_Id); 86 -- Build body for a renaming declaration, insert in tree and analyze 87 88 procedure Check_Address_Clause (E : Entity_Id); 89 -- Apply legality checks to address clauses for object declarations, 90 -- at the point the object is frozen. Also ensure any initialization is 91 -- performed only after the object has been frozen. 92 93 procedure Check_Component_Storage_Order 94 (Encl_Type : Entity_Id; 95 Comp : Entity_Id; 96 ADC : Node_Id); 97 -- For an Encl_Type that has a Scalar_Storage_Order attribute definition 98 -- clause, verify that the component type has an explicit and compatible 99 -- attribute/aspect. For arrays, Comp is Empty; for records, it is the 100 -- entity of the component under consideration. For an Encl_Type that 101 -- does not have a Scalar_Storage_Order attribute definition clause, 102 -- verify that the component also does not have such a clause. 103 -- ADC is the attribute definition clause if present (or Empty). 104 105 procedure Check_Strict_Alignment (E : Entity_Id); 106 -- E is a base type. If E is tagged or has a component that is aliased 107 -- or tagged or contains something this is aliased or tagged, set 108 -- Strict_Alignment. 109 110 procedure Check_Unsigned_Type (E : Entity_Id); 111 pragma Inline (Check_Unsigned_Type); 112 -- If E is a fixed-point or discrete type, then all the necessary work 113 -- to freeze it is completed except for possible setting of the flag 114 -- Is_Unsigned_Type, which is done by this procedure. The call has no 115 -- effect if the entity E is not a discrete or fixed-point type. 116 117 procedure Freeze_And_Append 118 (Ent : Entity_Id; 119 N : Node_Id; 120 Result : in out List_Id); 121 -- Freezes Ent using Freeze_Entity, and appends the resulting list of 122 -- nodes to Result, modifying Result from No_List if necessary. N has 123 -- the same usage as in Freeze_Entity. 124 125 procedure Freeze_Enumeration_Type (Typ : Entity_Id); 126 -- Freeze enumeration type. The Esize field is set as processing 127 -- proceeds (i.e. set by default when the type is declared and then 128 -- adjusted by rep clauses. What this procedure does is to make sure 129 -- that if a foreign convention is specified, and no specific size 130 -- is given, then the size must be at least Integer'Size. 131 132 procedure Freeze_Static_Object (E : Entity_Id); 133 -- If an object is frozen which has Is_Statically_Allocated set, then 134 -- all referenced types must also be marked with this flag. This routine 135 -- is in charge of meeting this requirement for the object entity E. 136 137 procedure Freeze_Subprogram (E : Entity_Id); 138 -- Perform freezing actions for a subprogram (create extra formals, 139 -- and set proper default mechanism values). Note that this routine 140 -- is not called for internal subprograms, for which neither of these 141 -- actions is needed (or desirable, we do not want for example to have 142 -- these extra formals present in initialization procedures, where they 143 -- would serve no purpose). In this call E is either a subprogram or 144 -- a subprogram type (i.e. an access to a subprogram). 145 146 function Is_Fully_Defined (T : Entity_Id) return Boolean; 147 -- True if T is not private and has no private components, or has a full 148 -- view. Used to determine whether the designated type of an access type 149 -- should be frozen when the access type is frozen. This is done when an 150 -- allocator is frozen, or an expression that may involve attributes of 151 -- the designated type. Otherwise freezing the access type does not freeze 152 -- the designated type. 153 154 procedure Process_Default_Expressions 155 (E : Entity_Id; 156 After : in out Node_Id); 157 -- This procedure is called for each subprogram to complete processing of 158 -- default expressions at the point where all types are known to be frozen. 159 -- The expressions must be analyzed in full, to make sure that all error 160 -- processing is done (they have only been pre-analyzed). If the expression 161 -- is not an entity or literal, its analysis may generate code which must 162 -- not be executed. In that case we build a function body to hold that 163 -- code. This wrapper function serves no other purpose (it used to be 164 -- called to evaluate the default, but now the default is inlined at each 165 -- point of call). 166 167 procedure Set_Component_Alignment_If_Not_Set (Typ : Entity_Id); 168 -- Typ is a record or array type that is being frozen. This routine sets 169 -- the default component alignment from the scope stack values if the 170 -- alignment is otherwise not specified. 171 172 procedure Check_Debug_Info_Needed (T : Entity_Id); 173 -- As each entity is frozen, this routine is called to deal with the 174 -- setting of Debug_Info_Needed for the entity. This flag is set if 175 -- the entity comes from source, or if we are in Debug_Generated_Code 176 -- mode or if the -gnatdV debug flag is set. However, it never sets 177 -- the flag if Debug_Info_Off is set. This procedure also ensures that 178 -- subsidiary entities have the flag set as required. 179 180 procedure Undelay_Type (T : Entity_Id); 181 -- T is a type of a component that we know to be an Itype. We don't want 182 -- this to have a Freeze_Node, so ensure it doesn't. Do the same for any 183 -- Full_View or Corresponding_Record_Type. 184 185 procedure Warn_Overlay 186 (Expr : Node_Id; 187 Typ : Entity_Id; 188 Nam : Node_Id); 189 -- Expr is the expression for an address clause for entity Nam whose type 190 -- is Typ. If Typ has a default initialization, and there is no explicit 191 -- initialization in the source declaration, check whether the address 192 -- clause might cause overlaying of an entity, and emit a warning on the 193 -- side effect that the initialization will cause. 194 195 ------------------------------- 196 -- Adjust_Esize_For_Alignment -- 197 ------------------------------- 198 199 procedure Adjust_Esize_For_Alignment (Typ : Entity_Id) is 200 Align : Uint; 201 202 begin 203 if Known_Esize (Typ) and then Known_Alignment (Typ) then 204 Align := Alignment_In_Bits (Typ); 205 206 if Align > Esize (Typ) 207 and then Align <= Standard_Long_Long_Integer_Size 208 then 209 Set_Esize (Typ, Align); 210 end if; 211 end if; 212 end Adjust_Esize_For_Alignment; 213 214 ------------------------------------ 215 -- Build_And_Analyze_Renamed_Body -- 216 ------------------------------------ 217 218 procedure Build_And_Analyze_Renamed_Body 219 (Decl : Node_Id; 220 New_S : Entity_Id; 221 After : in out Node_Id) 222 is 223 Body_Decl : constant Node_Id := Unit_Declaration_Node (New_S); 224 Ent : constant Entity_Id := Defining_Entity (Decl); 225 Body_Node : Node_Id; 226 Renamed_Subp : Entity_Id; 227 228 begin 229 -- If the renamed subprogram is intrinsic, there is no need for a 230 -- wrapper body: we set the alias that will be called and expanded which 231 -- completes the declaration. This transformation is only legal if the 232 -- renamed entity has already been elaborated. 233 234 -- Note that it is legal for a renaming_as_body to rename an intrinsic 235 -- subprogram, as long as the renaming occurs before the new entity 236 -- is frozen (RM 8.5.4 (5)). 237 238 if Nkind (Body_Decl) = N_Subprogram_Renaming_Declaration 239 and then Is_Entity_Name (Name (Body_Decl)) 240 then 241 Renamed_Subp := Entity (Name (Body_Decl)); 242 else 243 Renamed_Subp := Empty; 244 end if; 245 246 if Present (Renamed_Subp) 247 and then Is_Intrinsic_Subprogram (Renamed_Subp) 248 and then 249 (not In_Same_Source_Unit (Renamed_Subp, Ent) 250 or else Sloc (Renamed_Subp) < Sloc (Ent)) 251 252 -- We can make the renaming entity intrinsic if the renamed function 253 -- has an interface name, or if it is one of the shift/rotate 254 -- operations known to the compiler. 255 256 and then 257 (Present (Interface_Name (Renamed_Subp)) 258 or else Nam_In (Chars (Renamed_Subp), Name_Rotate_Left, 259 Name_Rotate_Right, 260 Name_Shift_Left, 261 Name_Shift_Right, 262 Name_Shift_Right_Arithmetic)) 263 then 264 Set_Interface_Name (Ent, Interface_Name (Renamed_Subp)); 265 266 if Present (Alias (Renamed_Subp)) then 267 Set_Alias (Ent, Alias (Renamed_Subp)); 268 else 269 Set_Alias (Ent, Renamed_Subp); 270 end if; 271 272 Set_Is_Intrinsic_Subprogram (Ent); 273 Set_Has_Completion (Ent); 274 275 else 276 Body_Node := Build_Renamed_Body (Decl, New_S); 277 Insert_After (After, Body_Node); 278 Mark_Rewrite_Insertion (Body_Node); 279 Analyze (Body_Node); 280 After := Body_Node; 281 end if; 282 end Build_And_Analyze_Renamed_Body; 283 284 ------------------------ 285 -- Build_Renamed_Body -- 286 ------------------------ 287 288 function Build_Renamed_Body 289 (Decl : Node_Id; 290 New_S : Entity_Id) return Node_Id 291 is 292 Loc : constant Source_Ptr := Sloc (New_S); 293 -- We use for the source location of the renamed body, the location of 294 -- the spec entity. It might seem more natural to use the location of 295 -- the renaming declaration itself, but that would be wrong, since then 296 -- the body we create would look as though it was created far too late, 297 -- and this could cause problems with elaboration order analysis, 298 -- particularly in connection with instantiations. 299 300 N : constant Node_Id := Unit_Declaration_Node (New_S); 301 Nam : constant Node_Id := Name (N); 302 Old_S : Entity_Id; 303 Spec : constant Node_Id := New_Copy_Tree (Specification (Decl)); 304 Actuals : List_Id := No_List; 305 Call_Node : Node_Id; 306 Call_Name : Node_Id; 307 Body_Node : Node_Id; 308 Formal : Entity_Id; 309 O_Formal : Entity_Id; 310 Param_Spec : Node_Id; 311 312 Pref : Node_Id := Empty; 313 -- If the renamed entity is a primitive operation given in prefix form, 314 -- the prefix is the target object and it has to be added as the first 315 -- actual in the generated call. 316 317 begin 318 -- Determine the entity being renamed, which is the target of the call 319 -- statement. If the name is an explicit dereference, this is a renaming 320 -- of a subprogram type rather than a subprogram. The name itself is 321 -- fully analyzed. 322 323 if Nkind (Nam) = N_Selected_Component then 324 Old_S := Entity (Selector_Name (Nam)); 325 326 elsif Nkind (Nam) = N_Explicit_Dereference then 327 Old_S := Etype (Nam); 328 329 elsif Nkind (Nam) = N_Indexed_Component then 330 if Is_Entity_Name (Prefix (Nam)) then 331 Old_S := Entity (Prefix (Nam)); 332 else 333 Old_S := Entity (Selector_Name (Prefix (Nam))); 334 end if; 335 336 elsif Nkind (Nam) = N_Character_Literal then 337 Old_S := Etype (New_S); 338 339 else 340 Old_S := Entity (Nam); 341 end if; 342 343 if Is_Entity_Name (Nam) then 344 345 -- If the renamed entity is a predefined operator, retain full name 346 -- to ensure its visibility. 347 348 if Ekind (Old_S) = E_Operator 349 and then Nkind (Nam) = N_Expanded_Name 350 then 351 Call_Name := New_Copy (Name (N)); 352 else 353 Call_Name := New_Occurrence_Of (Old_S, Loc); 354 end if; 355 356 else 357 if Nkind (Nam) = N_Selected_Component 358 and then Present (First_Formal (Old_S)) 359 and then 360 (Is_Controlling_Formal (First_Formal (Old_S)) 361 or else Is_Class_Wide_Type (Etype (First_Formal (Old_S)))) 362 then 363 364 -- Retrieve the target object, to be added as a first actual 365 -- in the call. 366 367 Call_Name := New_Occurrence_Of (Old_S, Loc); 368 Pref := Prefix (Nam); 369 370 else 371 Call_Name := New_Copy (Name (N)); 372 end if; 373 374 -- Original name may have been overloaded, but is fully resolved now 375 376 Set_Is_Overloaded (Call_Name, False); 377 end if; 378 379 -- For simple renamings, subsequent calls can be expanded directly as 380 -- calls to the renamed entity. The body must be generated in any case 381 -- for calls that may appear elsewhere. This is not done in the case 382 -- where the subprogram is an instantiation because the actual proper 383 -- body has not been built yet. 384 385 if Ekind_In (Old_S, E_Function, E_Procedure) 386 and then Nkind (Decl) = N_Subprogram_Declaration 387 and then not Is_Generic_Instance (Old_S) 388 then 389 Set_Body_To_Inline (Decl, Old_S); 390 end if; 391 392 -- The body generated for this renaming is an internal artifact, and 393 -- does not constitute a freeze point for the called entity. 394 395 Set_Must_Not_Freeze (Call_Name); 396 397 Formal := First_Formal (Defining_Entity (Decl)); 398 399 if Present (Pref) then 400 declare 401 Pref_Type : constant Entity_Id := Etype (Pref); 402 Form_Type : constant Entity_Id := Etype (First_Formal (Old_S)); 403 404 begin 405 -- The controlling formal may be an access parameter, or the 406 -- actual may be an access value, so adjust accordingly. 407 408 if Is_Access_Type (Pref_Type) 409 and then not Is_Access_Type (Form_Type) 410 then 411 Actuals := New_List 412 (Make_Explicit_Dereference (Loc, Relocate_Node (Pref))); 413 414 elsif Is_Access_Type (Form_Type) 415 and then not Is_Access_Type (Pref) 416 then 417 Actuals := New_List 418 (Make_Attribute_Reference (Loc, 419 Attribute_Name => Name_Access, 420 Prefix => Relocate_Node (Pref))); 421 else 422 Actuals := New_List (Pref); 423 end if; 424 end; 425 426 elsif Present (Formal) then 427 Actuals := New_List; 428 429 else 430 Actuals := No_List; 431 end if; 432 433 if Present (Formal) then 434 while Present (Formal) loop 435 Append (New_Occurrence_Of (Formal, Loc), Actuals); 436 Next_Formal (Formal); 437 end loop; 438 end if; 439 440 -- If the renamed entity is an entry, inherit its profile. For other 441 -- renamings as bodies, both profiles must be subtype conformant, so it 442 -- is not necessary to replace the profile given in the declaration. 443 -- However, default values that are aggregates are rewritten when 444 -- partially analyzed, so we recover the original aggregate to insure 445 -- that subsequent conformity checking works. Similarly, if the default 446 -- expression was constant-folded, recover the original expression. 447 448 Formal := First_Formal (Defining_Entity (Decl)); 449 450 if Present (Formal) then 451 O_Formal := First_Formal (Old_S); 452 Param_Spec := First (Parameter_Specifications (Spec)); 453 while Present (Formal) loop 454 if Is_Entry (Old_S) then 455 if Nkind (Parameter_Type (Param_Spec)) /= 456 N_Access_Definition 457 then 458 Set_Etype (Formal, Etype (O_Formal)); 459 Set_Entity (Parameter_Type (Param_Spec), Etype (O_Formal)); 460 end if; 461 462 elsif Nkind (Default_Value (O_Formal)) = N_Aggregate 463 or else Nkind (Original_Node (Default_Value (O_Formal))) /= 464 Nkind (Default_Value (O_Formal)) 465 then 466 Set_Expression (Param_Spec, 467 New_Copy_Tree (Original_Node (Default_Value (O_Formal)))); 468 end if; 469 470 Next_Formal (Formal); 471 Next_Formal (O_Formal); 472 Next (Param_Spec); 473 end loop; 474 end if; 475 476 -- If the renamed entity is a function, the generated body contains a 477 -- return statement. Otherwise, build a procedure call. If the entity is 478 -- an entry, subsequent analysis of the call will transform it into the 479 -- proper entry or protected operation call. If the renamed entity is 480 -- a character literal, return it directly. 481 482 if Ekind (Old_S) = E_Function 483 or else Ekind (Old_S) = E_Operator 484 or else (Ekind (Old_S) = E_Subprogram_Type 485 and then Etype (Old_S) /= Standard_Void_Type) 486 then 487 Call_Node := 488 Make_Simple_Return_Statement (Loc, 489 Expression => 490 Make_Function_Call (Loc, 491 Name => Call_Name, 492 Parameter_Associations => Actuals)); 493 494 elsif Ekind (Old_S) = E_Enumeration_Literal then 495 Call_Node := 496 Make_Simple_Return_Statement (Loc, 497 Expression => New_Occurrence_Of (Old_S, Loc)); 498 499 elsif Nkind (Nam) = N_Character_Literal then 500 Call_Node := 501 Make_Simple_Return_Statement (Loc, 502 Expression => Call_Name); 503 504 else 505 Call_Node := 506 Make_Procedure_Call_Statement (Loc, 507 Name => Call_Name, 508 Parameter_Associations => Actuals); 509 end if; 510 511 -- Create entities for subprogram body and formals 512 513 Set_Defining_Unit_Name (Spec, 514 Make_Defining_Identifier (Loc, Chars => Chars (New_S))); 515 516 Param_Spec := First (Parameter_Specifications (Spec)); 517 while Present (Param_Spec) loop 518 Set_Defining_Identifier (Param_Spec, 519 Make_Defining_Identifier (Loc, 520 Chars => Chars (Defining_Identifier (Param_Spec)))); 521 Next (Param_Spec); 522 end loop; 523 524 Body_Node := 525 Make_Subprogram_Body (Loc, 526 Specification => Spec, 527 Declarations => New_List, 528 Handled_Statement_Sequence => 529 Make_Handled_Sequence_Of_Statements (Loc, 530 Statements => New_List (Call_Node))); 531 532 if Nkind (Decl) /= N_Subprogram_Declaration then 533 Rewrite (N, 534 Make_Subprogram_Declaration (Loc, 535 Specification => Specification (N))); 536 end if; 537 538 -- Link the body to the entity whose declaration it completes. If 539 -- the body is analyzed when the renamed entity is frozen, it may 540 -- be necessary to restore the proper scope (see package Exp_Ch13). 541 542 if Nkind (N) = N_Subprogram_Renaming_Declaration 543 and then Present (Corresponding_Spec (N)) 544 then 545 Set_Corresponding_Spec (Body_Node, Corresponding_Spec (N)); 546 else 547 Set_Corresponding_Spec (Body_Node, New_S); 548 end if; 549 550 return Body_Node; 551 end Build_Renamed_Body; 552 553 -------------------------- 554 -- Check_Address_Clause -- 555 -------------------------- 556 557 procedure Check_Address_Clause (E : Entity_Id) is 558 Addr : constant Node_Id := Address_Clause (E); 559 Expr : Node_Id; 560 Decl : constant Node_Id := Declaration_Node (E); 561 Loc : constant Source_Ptr := Sloc (Decl); 562 Typ : constant Entity_Id := Etype (E); 563 564 begin 565 if Present (Addr) then 566 Expr := Expression (Addr); 567 568 if Needs_Constant_Address (Decl, Typ) then 569 Check_Constant_Address_Clause (Expr, E); 570 571 -- Has_Delayed_Freeze was set on E when the address clause was 572 -- analyzed, and must remain set because we want the address 573 -- clause to be elaborated only after any entity it references 574 -- has been elaborated. 575 end if; 576 577 -- If Rep_Clauses are to be ignored, remove address clause from 578 -- list attached to entity, because it may be illegal for gigi, 579 -- for example by breaking order of elaboration.. 580 581 if Ignore_Rep_Clauses then 582 declare 583 Rep : Node_Id; 584 585 begin 586 Rep := First_Rep_Item (E); 587 588 if Rep = Addr then 589 Set_First_Rep_Item (E, Next_Rep_Item (Addr)); 590 591 else 592 while Present (Rep) 593 and then Next_Rep_Item (Rep) /= Addr 594 loop 595 Rep := Next_Rep_Item (Rep); 596 end loop; 597 end if; 598 599 if Present (Rep) then 600 Set_Next_Rep_Item (Rep, Next_Rep_Item (Addr)); 601 end if; 602 end; 603 604 Rewrite (Addr, Make_Null_Statement (Sloc (E))); 605 606 elsif not Error_Posted (Expr) 607 and then not Needs_Finalization (Typ) 608 then 609 Warn_Overlay (Expr, Typ, Name (Addr)); 610 end if; 611 612 if Present (Expression (Decl)) then 613 614 -- Capture initialization value at point of declaration 615 616 Remove_Side_Effects (Expression (Decl)); 617 618 -- Move initialization to freeze actions (once the object has 619 -- been frozen, and the address clause alignment check has been 620 -- performed. 621 622 Append_Freeze_Action (E, 623 Make_Assignment_Statement (Loc, 624 Name => New_Occurrence_Of (E, Loc), 625 Expression => Expression (Decl))); 626 627 Set_No_Initialization (Decl); 628 end if; 629 end if; 630 end Check_Address_Clause; 631 632 ----------------------------- 633 -- Check_Compile_Time_Size -- 634 ----------------------------- 635 636 procedure Check_Compile_Time_Size (T : Entity_Id) is 637 638 procedure Set_Small_Size (T : Entity_Id; S : Uint); 639 -- Sets the compile time known size (32 bits or less) in the Esize 640 -- field, of T checking for a size clause that was given which attempts 641 -- to give a smaller size, and also checking for an alignment clause. 642 643 function Size_Known (T : Entity_Id) return Boolean; 644 -- Recursive function that does all the work 645 646 function Static_Discriminated_Components (T : Entity_Id) return Boolean; 647 -- If T is a constrained subtype, its size is not known if any of its 648 -- discriminant constraints is not static and it is not a null record. 649 -- The test is conservative and doesn't check that the components are 650 -- in fact constrained by non-static discriminant values. Could be made 651 -- more precise ??? 652 653 -------------------- 654 -- Set_Small_Size -- 655 -------------------- 656 657 procedure Set_Small_Size (T : Entity_Id; S : Uint) is 658 begin 659 if S > 32 then 660 return; 661 662 -- Check for bad size clause given 663 664 elsif Has_Size_Clause (T) then 665 if RM_Size (T) < S then 666 Error_Msg_Uint_1 := S; 667 Error_Msg_NE 668 ("size for& too small, minimum allowed is ^", 669 Size_Clause (T), T); 670 end if; 671 672 -- Set size if not set already 673 674 elsif Unknown_RM_Size (T) then 675 Set_RM_Size (T, S); 676 end if; 677 end Set_Small_Size; 678 679 ---------------- 680 -- Size_Known -- 681 ---------------- 682 683 function Size_Known (T : Entity_Id) return Boolean is 684 Index : Entity_Id; 685 Comp : Entity_Id; 686 Ctyp : Entity_Id; 687 Low : Node_Id; 688 High : Node_Id; 689 690 begin 691 if Size_Known_At_Compile_Time (T) then 692 return True; 693 694 -- Always True for scalar types. This is true even for generic formal 695 -- scalar types. We used to return False in the latter case, but the 696 -- size is known at compile time, even in the template, we just do 697 -- not know the exact size but that's not the point of this routine. 698 699 elsif Is_Scalar_Type (T) 700 or else Is_Task_Type (T) 701 then 702 return True; 703 704 -- Array types 705 706 elsif Is_Array_Type (T) then 707 708 -- String literals always have known size, and we can set it 709 710 if Ekind (T) = E_String_Literal_Subtype then 711 Set_Small_Size (T, Component_Size (T) 712 * String_Literal_Length (T)); 713 return True; 714 715 -- Unconstrained types never have known at compile time size 716 717 elsif not Is_Constrained (T) then 718 return False; 719 720 -- Don't do any recursion on type with error posted, since we may 721 -- have a malformed type that leads us into a loop. 722 723 elsif Error_Posted (T) then 724 return False; 725 726 -- Otherwise if component size unknown, then array size unknown 727 728 elsif not Size_Known (Component_Type (T)) then 729 return False; 730 end if; 731 732 -- Check for all indexes static, and also compute possible size 733 -- (in case it is less than 32 and may be packable). 734 735 declare 736 Esiz : Uint := Component_Size (T); 737 Dim : Uint; 738 739 begin 740 Index := First_Index (T); 741 while Present (Index) loop 742 if Nkind (Index) = N_Range then 743 Get_Index_Bounds (Index, Low, High); 744 745 elsif Error_Posted (Scalar_Range (Etype (Index))) then 746 return False; 747 748 else 749 Low := Type_Low_Bound (Etype (Index)); 750 High := Type_High_Bound (Etype (Index)); 751 end if; 752 753 if not Compile_Time_Known_Value (Low) 754 or else not Compile_Time_Known_Value (High) 755 or else Etype (Index) = Any_Type 756 then 757 return False; 758 759 else 760 Dim := Expr_Value (High) - Expr_Value (Low) + 1; 761 762 if Dim >= 0 then 763 Esiz := Esiz * Dim; 764 else 765 Esiz := Uint_0; 766 end if; 767 end if; 768 769 Next_Index (Index); 770 end loop; 771 772 Set_Small_Size (T, Esiz); 773 return True; 774 end; 775 776 -- Access types always have known at compile time sizes 777 778 elsif Is_Access_Type (T) then 779 return True; 780 781 -- For non-generic private types, go to underlying type if present 782 783 elsif Is_Private_Type (T) 784 and then not Is_Generic_Type (T) 785 and then Present (Underlying_Type (T)) 786 then 787 -- Don't do any recursion on type with error posted, since we may 788 -- have a malformed type that leads us into a loop. 789 790 if Error_Posted (T) then 791 return False; 792 else 793 return Size_Known (Underlying_Type (T)); 794 end if; 795 796 -- Record types 797 798 elsif Is_Record_Type (T) then 799 800 -- A class-wide type is never considered to have a known size 801 802 if Is_Class_Wide_Type (T) then 803 return False; 804 805 -- A subtype of a variant record must not have non-static 806 -- discriminated components. 807 808 elsif T /= Base_Type (T) 809 and then not Static_Discriminated_Components (T) 810 then 811 return False; 812 813 -- Don't do any recursion on type with error posted, since we may 814 -- have a malformed type that leads us into a loop. 815 816 elsif Error_Posted (T) then 817 return False; 818 end if; 819 820 -- Now look at the components of the record 821 822 declare 823 -- The following two variables are used to keep track of the 824 -- size of packed records if we can tell the size of the packed 825 -- record in the front end. Packed_Size_Known is True if so far 826 -- we can figure out the size. It is initialized to True for a 827 -- packed record, unless the record has discriminants or atomic 828 -- components or independent components. 829 830 -- The reason we eliminate the discriminated case is that 831 -- we don't know the way the back end lays out discriminated 832 -- packed records. If Packed_Size_Known is True, then 833 -- Packed_Size is the size in bits so far. 834 835 Packed_Size_Known : Boolean := 836 Is_Packed (T) 837 and then not Has_Discriminants (T) 838 and then not Has_Atomic_Components (T) 839 and then not Has_Independent_Components (T); 840 841 Packed_Size : Uint := Uint_0; 842 -- Size in bits so far 843 844 begin 845 -- Test for variant part present 846 847 if Has_Discriminants (T) 848 and then Present (Parent (T)) 849 and then Nkind (Parent (T)) = N_Full_Type_Declaration 850 and then Nkind (Type_Definition (Parent (T))) = 851 N_Record_Definition 852 and then not Null_Present (Type_Definition (Parent (T))) 853 and then 854 Present (Variant_Part 855 (Component_List (Type_Definition (Parent (T))))) 856 then 857 -- If variant part is present, and type is unconstrained, 858 -- then we must have defaulted discriminants, or a size 859 -- clause must be present for the type, or else the size 860 -- is definitely not known at compile time. 861 862 if not Is_Constrained (T) 863 and then 864 No (Discriminant_Default_Value (First_Discriminant (T))) 865 and then Unknown_RM_Size (T) 866 then 867 return False; 868 end if; 869 end if; 870 871 -- Loop through components 872 873 Comp := First_Component_Or_Discriminant (T); 874 while Present (Comp) loop 875 Ctyp := Etype (Comp); 876 877 -- We do not know the packed size if there is a component 878 -- clause present (we possibly could, but this would only 879 -- help in the case of a record with partial rep clauses. 880 -- That's because in the case of full rep clauses, the 881 -- size gets figured out anyway by a different circuit). 882 883 if Present (Component_Clause (Comp)) then 884 Packed_Size_Known := False; 885 end if; 886 887 -- We do not know the packed size if we have a by reference 888 -- type, or an atomic type or an atomic component, or an 889 -- aliased component (because packing does not touch these). 890 891 if Is_Atomic (Ctyp) 892 or else Is_Atomic (Comp) 893 or else Is_By_Reference_Type (Ctyp) 894 or else Is_Aliased (Comp) 895 then 896 Packed_Size_Known := False; 897 end if; 898 899 -- We need to identify a component that is an array where 900 -- the index type is an enumeration type with non-standard 901 -- representation, and some bound of the type depends on a 902 -- discriminant. 903 904 -- This is because gigi computes the size by doing a 905 -- substitution of the appropriate discriminant value in 906 -- the size expression for the base type, and gigi is not 907 -- clever enough to evaluate the resulting expression (which 908 -- involves a call to rep_to_pos) at compile time. 909 910 -- It would be nice if gigi would either recognize that 911 -- this expression can be computed at compile time, or 912 -- alternatively figured out the size from the subtype 913 -- directly, where all the information is at hand ??? 914 915 if Is_Array_Type (Etype (Comp)) 916 and then Present (Packed_Array_Type (Etype (Comp))) 917 then 918 declare 919 Ocomp : constant Entity_Id := 920 Original_Record_Component (Comp); 921 OCtyp : constant Entity_Id := Etype (Ocomp); 922 Ind : Node_Id; 923 Indtyp : Entity_Id; 924 Lo, Hi : Node_Id; 925 926 begin 927 Ind := First_Index (OCtyp); 928 while Present (Ind) loop 929 Indtyp := Etype (Ind); 930 931 if Is_Enumeration_Type (Indtyp) 932 and then Has_Non_Standard_Rep (Indtyp) 933 then 934 Lo := Type_Low_Bound (Indtyp); 935 Hi := Type_High_Bound (Indtyp); 936 937 if Is_Entity_Name (Lo) 938 and then Ekind (Entity (Lo)) = E_Discriminant 939 then 940 return False; 941 942 elsif Is_Entity_Name (Hi) 943 and then Ekind (Entity (Hi)) = E_Discriminant 944 then 945 return False; 946 end if; 947 end if; 948 949 Next_Index (Ind); 950 end loop; 951 end; 952 end if; 953 954 -- Clearly size of record is not known if the size of one of 955 -- the components is not known. 956 957 if not Size_Known (Ctyp) then 958 return False; 959 end if; 960 961 -- Accumulate packed size if possible 962 963 if Packed_Size_Known then 964 965 -- We can only deal with elementary types, since for 966 -- non-elementary components, alignment enters into the 967 -- picture, and we don't know enough to handle proper 968 -- alignment in this context. Packed arrays count as 969 -- elementary if the representation is a modular type. 970 971 if Is_Elementary_Type (Ctyp) 972 or else (Is_Array_Type (Ctyp) 973 and then Present (Packed_Array_Type (Ctyp)) 974 and then Is_Modular_Integer_Type 975 (Packed_Array_Type (Ctyp))) 976 then 977 -- Packed size unknown if we have an atomic type 978 -- or a by reference type, since the back end 979 -- knows how these are layed out. 980 981 if Is_Atomic (Ctyp) 982 or else Is_By_Reference_Type (Ctyp) 983 then 984 Packed_Size_Known := False; 985 986 -- If RM_Size is known and static, then we can keep 987 -- accumulating the packed size 988 989 elsif Known_Static_RM_Size (Ctyp) then 990 991 -- A little glitch, to be removed sometime ??? 992 -- gigi does not understand zero sizes yet. 993 994 if RM_Size (Ctyp) = Uint_0 then 995 Packed_Size_Known := False; 996 997 -- Normal case where we can keep accumulating the 998 -- packed array size. 999 1000 else 1001 Packed_Size := Packed_Size + RM_Size (Ctyp); 1002 end if; 1003 1004 -- If we have a field whose RM_Size is not known then 1005 -- we can't figure out the packed size here. 1006 1007 else 1008 Packed_Size_Known := False; 1009 end if; 1010 1011 -- If we have a non-elementary type we can't figure out 1012 -- the packed array size (alignment issues). 1013 1014 else 1015 Packed_Size_Known := False; 1016 end if; 1017 end if; 1018 1019 Next_Component_Or_Discriminant (Comp); 1020 end loop; 1021 1022 if Packed_Size_Known then 1023 Set_Small_Size (T, Packed_Size); 1024 end if; 1025 1026 return True; 1027 end; 1028 1029 -- All other cases, size not known at compile time 1030 1031 else 1032 return False; 1033 end if; 1034 end Size_Known; 1035 1036 ------------------------------------- 1037 -- Static_Discriminated_Components -- 1038 ------------------------------------- 1039 1040 function Static_Discriminated_Components 1041 (T : Entity_Id) return Boolean 1042 is 1043 Constraint : Elmt_Id; 1044 1045 begin 1046 if Has_Discriminants (T) 1047 and then Present (Discriminant_Constraint (T)) 1048 and then Present (First_Component (T)) 1049 then 1050 Constraint := First_Elmt (Discriminant_Constraint (T)); 1051 while Present (Constraint) loop 1052 if not Compile_Time_Known_Value (Node (Constraint)) then 1053 return False; 1054 end if; 1055 1056 Next_Elmt (Constraint); 1057 end loop; 1058 end if; 1059 1060 return True; 1061 end Static_Discriminated_Components; 1062 1063 -- Start of processing for Check_Compile_Time_Size 1064 1065 begin 1066 Set_Size_Known_At_Compile_Time (T, Size_Known (T)); 1067 end Check_Compile_Time_Size; 1068 1069 ----------------------------------- 1070 -- Check_Component_Storage_Order -- 1071 ----------------------------------- 1072 1073 procedure Check_Component_Storage_Order 1074 (Encl_Type : Entity_Id; 1075 Comp : Entity_Id; 1076 ADC : Node_Id) 1077 is 1078 Comp_Type : Entity_Id; 1079 Comp_ADC : Node_Id; 1080 Err_Node : Node_Id; 1081 1082 Comp_Byte_Aligned : Boolean; 1083 -- Set True for the record case, when Comp starts on a byte boundary 1084 -- (in which case it is allowed to have different storage order). 1085 1086 Comp_SSO_Differs : Boolean; 1087 -- Set True when the component is a nested composite, and it does not 1088 -- have the same scalar storage order as Encl_Type. 1089 1090 Component_Aliased : Boolean; 1091 1092 begin 1093 -- Record case 1094 1095 if Present (Comp) then 1096 Err_Node := Comp; 1097 Comp_Type := Etype (Comp); 1098 1099 if Is_Tag (Comp) then 1100 Comp_Byte_Aligned := True; 1101 Component_Aliased := False; 1102 1103 else 1104 Comp_Byte_Aligned := 1105 Present (Component_Clause (Comp)) 1106 and then 1107 Normalized_First_Bit (Comp) mod System_Storage_Unit = 0; 1108 Component_Aliased := Is_Aliased (Comp); 1109 end if; 1110 1111 -- Array case 1112 1113 else 1114 Err_Node := Encl_Type; 1115 Comp_Type := Component_Type (Encl_Type); 1116 1117 Comp_Byte_Aligned := False; 1118 Component_Aliased := Has_Aliased_Components (Encl_Type); 1119 end if; 1120 1121 -- Note: the Reverse_Storage_Order flag is set on the base type, but 1122 -- the attribute definition clause is attached to the first subtype. 1123 1124 Comp_Type := Base_Type (Comp_Type); 1125 Comp_ADC := Get_Attribute_Definition_Clause 1126 (First_Subtype (Comp_Type), 1127 Attribute_Scalar_Storage_Order); 1128 1129 -- Case of enclosing type not having explicit SSO: component cannot 1130 -- have it either. 1131 1132 if No (ADC) then 1133 if Present (Comp_ADC) then 1134 Error_Msg_N 1135 ("composite type must have explicit scalar storage order", 1136 Err_Node); 1137 end if; 1138 1139 -- Case of enclosing type having explicit SSO: check compatible 1140 -- attribute on Comp_Type if composite. 1141 1142 elsif Is_Record_Type (Comp_Type) or else Is_Array_Type (Comp_Type) then 1143 Comp_SSO_Differs := 1144 Reverse_Storage_Order (Encl_Type) 1145 /= 1146 Reverse_Storage_Order (Comp_Type); 1147 1148 if Present (Comp) and then Chars (Comp) = Name_uParent then 1149 if Comp_SSO_Differs then 1150 Error_Msg_N 1151 ("record extension must have same scalar storage order as " 1152 & "parent", Err_Node); 1153 end if; 1154 1155 elsif No (Comp_ADC) then 1156 Error_Msg_N ("nested composite must have explicit scalar " 1157 & "storage order", Err_Node); 1158 1159 elsif Comp_SSO_Differs then 1160 1161 -- Component SSO differs from enclosing composite: 1162 1163 -- Reject if component is a packed array, as it may be represented 1164 -- as a scalar internally. 1165 1166 if Is_Packed (Comp_Type) then 1167 Error_Msg_N 1168 ("type of packed component must have same scalar " 1169 & "storage order as enclosing composite", Err_Node); 1170 1171 -- Reject if not byte aligned 1172 1173 elsif not Comp_Byte_Aligned then 1174 Error_Msg_N 1175 ("type of non-byte-aligned component must have same scalar " 1176 & "storage order as enclosing composite", Err_Node); 1177 end if; 1178 end if; 1179 1180 -- Enclosing type has explicit SSO, non-composite component must not 1181 -- be aliased. 1182 1183 elsif Component_Aliased then 1184 Error_Msg_N 1185 ("aliased component not permitted for type with " 1186 & "explicit Scalar_Storage_Order", Err_Node); 1187 end if; 1188 end Check_Component_Storage_Order; 1189 1190 ----------------------------- 1191 -- Check_Debug_Info_Needed -- 1192 ----------------------------- 1193 1194 procedure Check_Debug_Info_Needed (T : Entity_Id) is 1195 begin 1196 if Debug_Info_Off (T) then 1197 return; 1198 1199 elsif Comes_From_Source (T) 1200 or else Debug_Generated_Code 1201 or else Debug_Flag_VV 1202 or else Needs_Debug_Info (T) 1203 then 1204 Set_Debug_Info_Needed (T); 1205 end if; 1206 end Check_Debug_Info_Needed; 1207 1208 ---------------------------- 1209 -- Check_Strict_Alignment -- 1210 ---------------------------- 1211 1212 procedure Check_Strict_Alignment (E : Entity_Id) is 1213 Comp : Entity_Id; 1214 1215 begin 1216 if Is_Tagged_Type (E) or else Is_Concurrent_Type (E) then 1217 Set_Strict_Alignment (E); 1218 1219 elsif Is_Array_Type (E) then 1220 Set_Strict_Alignment (E, Strict_Alignment (Component_Type (E))); 1221 1222 elsif Is_Record_Type (E) then 1223 if Is_Limited_Record (E) then 1224 Set_Strict_Alignment (E); 1225 return; 1226 end if; 1227 1228 Comp := First_Component (E); 1229 while Present (Comp) loop 1230 if not Is_Type (Comp) 1231 and then (Strict_Alignment (Etype (Comp)) 1232 or else Is_Aliased (Comp)) 1233 then 1234 Set_Strict_Alignment (E); 1235 return; 1236 end if; 1237 1238 Next_Component (Comp); 1239 end loop; 1240 end if; 1241 end Check_Strict_Alignment; 1242 1243 ------------------------- 1244 -- Check_Unsigned_Type -- 1245 ------------------------- 1246 1247 procedure Check_Unsigned_Type (E : Entity_Id) is 1248 Ancestor : Entity_Id; 1249 Lo_Bound : Node_Id; 1250 Btyp : Entity_Id; 1251 1252 begin 1253 if not Is_Discrete_Or_Fixed_Point_Type (E) then 1254 return; 1255 end if; 1256 1257 -- Do not attempt to analyze case where range was in error 1258 1259 if No (Scalar_Range (E)) or else Error_Posted (Scalar_Range (E)) then 1260 return; 1261 end if; 1262 1263 -- The situation that is non trivial is something like 1264 1265 -- subtype x1 is integer range -10 .. +10; 1266 -- subtype x2 is x1 range 0 .. V1; 1267 -- subtype x3 is x2 range V2 .. V3; 1268 -- subtype x4 is x3 range V4 .. V5; 1269 1270 -- where Vn are variables. Here the base type is signed, but we still 1271 -- know that x4 is unsigned because of the lower bound of x2. 1272 1273 -- The only way to deal with this is to look up the ancestor chain 1274 1275 Ancestor := E; 1276 loop 1277 if Ancestor = Any_Type or else Etype (Ancestor) = Any_Type then 1278 return; 1279 end if; 1280 1281 Lo_Bound := Type_Low_Bound (Ancestor); 1282 1283 if Compile_Time_Known_Value (Lo_Bound) then 1284 if Expr_Rep_Value (Lo_Bound) >= 0 then 1285 Set_Is_Unsigned_Type (E, True); 1286 end if; 1287 1288 return; 1289 1290 else 1291 Ancestor := Ancestor_Subtype (Ancestor); 1292 1293 -- If no ancestor had a static lower bound, go to base type 1294 1295 if No (Ancestor) then 1296 1297 -- Note: the reason we still check for a compile time known 1298 -- value for the base type is that at least in the case of 1299 -- generic formals, we can have bounds that fail this test, 1300 -- and there may be other cases in error situations. 1301 1302 Btyp := Base_Type (E); 1303 1304 if Btyp = Any_Type or else Etype (Btyp) = Any_Type then 1305 return; 1306 end if; 1307 1308 Lo_Bound := Type_Low_Bound (Base_Type (E)); 1309 1310 if Compile_Time_Known_Value (Lo_Bound) 1311 and then Expr_Rep_Value (Lo_Bound) >= 0 1312 then 1313 Set_Is_Unsigned_Type (E, True); 1314 end if; 1315 1316 return; 1317 end if; 1318 end if; 1319 end loop; 1320 end Check_Unsigned_Type; 1321 1322 ------------------------- 1323 -- Is_Atomic_Aggregate -- 1324 ------------------------- 1325 1326 function Is_Atomic_Aggregate 1327 (E : Entity_Id; 1328 Typ : Entity_Id) return Boolean 1329 is 1330 Loc : constant Source_Ptr := Sloc (E); 1331 New_N : Node_Id; 1332 Par : Node_Id; 1333 Temp : Entity_Id; 1334 1335 begin 1336 Par := Parent (E); 1337 1338 -- Array may be qualified, so find outer context 1339 1340 if Nkind (Par) = N_Qualified_Expression then 1341 Par := Parent (Par); 1342 end if; 1343 1344 if Nkind_In (Par, N_Object_Declaration, N_Assignment_Statement) 1345 and then Comes_From_Source (Par) 1346 then 1347 Temp := Make_Temporary (Loc, 'T', E); 1348 New_N := 1349 Make_Object_Declaration (Loc, 1350 Defining_Identifier => Temp, 1351 Object_Definition => New_Occurrence_Of (Typ, Loc), 1352 Expression => Relocate_Node (E)); 1353 Insert_Before (Par, New_N); 1354 Analyze (New_N); 1355 1356 Set_Expression (Par, New_Occurrence_Of (Temp, Loc)); 1357 return True; 1358 1359 else 1360 return False; 1361 end if; 1362 end Is_Atomic_Aggregate; 1363 1364 ---------------- 1365 -- Freeze_All -- 1366 ---------------- 1367 1368 -- Note: the easy coding for this procedure would be to just build a 1369 -- single list of freeze nodes and then insert them and analyze them 1370 -- all at once. This won't work, because the analysis of earlier freeze 1371 -- nodes may recursively freeze types which would otherwise appear later 1372 -- on in the freeze list. So we must analyze and expand the freeze nodes 1373 -- as they are generated. 1374 1375 procedure Freeze_All (From : Entity_Id; After : in out Node_Id) is 1376 E : Entity_Id; 1377 Decl : Node_Id; 1378 1379 procedure Freeze_All_Ent (From : Entity_Id; After : in out Node_Id); 1380 -- This is the internal recursive routine that does freezing of entities 1381 -- (but NOT the analysis of default expressions, which should not be 1382 -- recursive, we don't want to analyze those till we are sure that ALL 1383 -- the types are frozen). 1384 1385 -------------------- 1386 -- Freeze_All_Ent -- 1387 -------------------- 1388 1389 procedure Freeze_All_Ent (From : Entity_Id; After : in out Node_Id) is 1390 E : Entity_Id; 1391 Flist : List_Id; 1392 Lastn : Node_Id; 1393 1394 procedure Process_Flist; 1395 -- If freeze nodes are present, insert and analyze, and reset cursor 1396 -- for next insertion. 1397 1398 ------------------- 1399 -- Process_Flist -- 1400 ------------------- 1401 1402 procedure Process_Flist is 1403 begin 1404 if Is_Non_Empty_List (Flist) then 1405 Lastn := Next (After); 1406 Insert_List_After_And_Analyze (After, Flist); 1407 1408 if Present (Lastn) then 1409 After := Prev (Lastn); 1410 else 1411 After := Last (List_Containing (After)); 1412 end if; 1413 end if; 1414 end Process_Flist; 1415 1416 -- Start or processing for Freeze_All_Ent 1417 1418 begin 1419 E := From; 1420 while Present (E) loop 1421 1422 -- If the entity is an inner package which is not a package 1423 -- renaming, then its entities must be frozen at this point. Note 1424 -- that such entities do NOT get frozen at the end of the nested 1425 -- package itself (only library packages freeze). 1426 1427 -- Same is true for task declarations, where anonymous records 1428 -- created for entry parameters must be frozen. 1429 1430 if Ekind (E) = E_Package 1431 and then No (Renamed_Object (E)) 1432 and then not Is_Child_Unit (E) 1433 and then not Is_Frozen (E) 1434 then 1435 Push_Scope (E); 1436 Install_Visible_Declarations (E); 1437 Install_Private_Declarations (E); 1438 1439 Freeze_All (First_Entity (E), After); 1440 1441 End_Package_Scope (E); 1442 1443 if Is_Generic_Instance (E) 1444 and then Has_Delayed_Freeze (E) 1445 then 1446 Set_Has_Delayed_Freeze (E, False); 1447 Expand_N_Package_Declaration (Unit_Declaration_Node (E)); 1448 end if; 1449 1450 elsif Ekind (E) in Task_Kind 1451 and then Nkind_In (Parent (E), N_Task_Type_Declaration, 1452 N_Single_Task_Declaration) 1453 then 1454 Push_Scope (E); 1455 Freeze_All (First_Entity (E), After); 1456 End_Scope; 1457 1458 -- For a derived tagged type, we must ensure that all the 1459 -- primitive operations of the parent have been frozen, so that 1460 -- their addresses will be in the parent's dispatch table at the 1461 -- point it is inherited. 1462 1463 elsif Ekind (E) = E_Record_Type 1464 and then Is_Tagged_Type (E) 1465 and then Is_Tagged_Type (Etype (E)) 1466 and then Is_Derived_Type (E) 1467 then 1468 declare 1469 Prim_List : constant Elist_Id := 1470 Primitive_Operations (Etype (E)); 1471 1472 Prim : Elmt_Id; 1473 Subp : Entity_Id; 1474 1475 begin 1476 Prim := First_Elmt (Prim_List); 1477 while Present (Prim) loop 1478 Subp := Node (Prim); 1479 1480 if Comes_From_Source (Subp) 1481 and then not Is_Frozen (Subp) 1482 then 1483 Flist := Freeze_Entity (Subp, After); 1484 Process_Flist; 1485 end if; 1486 1487 Next_Elmt (Prim); 1488 end loop; 1489 end; 1490 end if; 1491 1492 if not Is_Frozen (E) then 1493 Flist := Freeze_Entity (E, After); 1494 Process_Flist; 1495 1496 -- If already frozen, and there are delayed aspects, this is where 1497 -- we do the visibility check for these aspects (see Sem_Ch13 spec 1498 -- for a description of how we handle aspect visibility). 1499 1500 elsif Has_Delayed_Aspects (E) then 1501 1502 -- Retrieve the visibility to the discriminants in order to 1503 -- analyze properly the aspects. 1504 1505 Push_Scope_And_Install_Discriminants (E); 1506 1507 declare 1508 Ritem : Node_Id; 1509 1510 begin 1511 Ritem := First_Rep_Item (E); 1512 while Present (Ritem) loop 1513 if Nkind (Ritem) = N_Aspect_Specification 1514 and then Entity (Ritem) = E 1515 and then Is_Delayed_Aspect (Ritem) 1516 then 1517 Check_Aspect_At_End_Of_Declarations (Ritem); 1518 end if; 1519 1520 Ritem := Next_Rep_Item (Ritem); 1521 end loop; 1522 end; 1523 1524 Uninstall_Discriminants_And_Pop_Scope (E); 1525 end if; 1526 1527 -- If an incomplete type is still not frozen, this may be a 1528 -- premature freezing because of a body declaration that follows. 1529 -- Indicate where the freezing took place. Freezing will happen 1530 -- if the body comes from source, but not if it is internally 1531 -- generated, for example as the body of a type invariant. 1532 1533 -- If the freezing is caused by the end of the current declarative 1534 -- part, it is a Taft Amendment type, and there is no error. 1535 1536 if not Is_Frozen (E) 1537 and then Ekind (E) = E_Incomplete_Type 1538 then 1539 declare 1540 Bod : constant Node_Id := Next (After); 1541 1542 begin 1543 -- The presence of a body freezes all entities previously 1544 -- declared in the current list of declarations, but this 1545 -- does not apply if the body does not come from source. 1546 -- A type invariant is transformed into a subprogram body 1547 -- which is placed at the end of the private part of the 1548 -- current package, but this body does not freeze incomplete 1549 -- types that may be declared in this private part. 1550 1551 if (Nkind_In (Bod, N_Subprogram_Body, 1552 N_Entry_Body, 1553 N_Package_Body, 1554 N_Protected_Body, 1555 N_Task_Body) 1556 or else Nkind (Bod) in N_Body_Stub) 1557 and then 1558 List_Containing (After) = List_Containing (Parent (E)) 1559 and then Comes_From_Source (Bod) 1560 then 1561 Error_Msg_Sloc := Sloc (Next (After)); 1562 Error_Msg_NE 1563 ("type& is frozen# before its full declaration", 1564 Parent (E), E); 1565 end if; 1566 end; 1567 end if; 1568 1569 Next_Entity (E); 1570 end loop; 1571 end Freeze_All_Ent; 1572 1573 -- Start of processing for Freeze_All 1574 1575 begin 1576 Freeze_All_Ent (From, After); 1577 1578 -- Now that all types are frozen, we can deal with default expressions 1579 -- that require us to build a default expression functions. This is the 1580 -- point at which such functions are constructed (after all types that 1581 -- might be used in such expressions have been frozen). 1582 1583 -- For subprograms that are renaming_as_body, we create the wrapper 1584 -- bodies as needed. 1585 1586 -- We also add finalization chains to access types whose designated 1587 -- types are controlled. This is normally done when freezing the type, 1588 -- but this misses recursive type definitions where the later members 1589 -- of the recursion introduce controlled components. 1590 1591 -- Loop through entities 1592 1593 E := From; 1594 while Present (E) loop 1595 if Is_Subprogram (E) then 1596 1597 if not Default_Expressions_Processed (E) then 1598 Process_Default_Expressions (E, After); 1599 end if; 1600 1601 if not Has_Completion (E) then 1602 Decl := Unit_Declaration_Node (E); 1603 1604 if Nkind (Decl) = N_Subprogram_Renaming_Declaration then 1605 if Error_Posted (Decl) then 1606 Set_Has_Completion (E); 1607 else 1608 Build_And_Analyze_Renamed_Body (Decl, E, After); 1609 end if; 1610 1611 elsif Nkind (Decl) = N_Subprogram_Declaration 1612 and then Present (Corresponding_Body (Decl)) 1613 and then 1614 Nkind (Unit_Declaration_Node (Corresponding_Body (Decl))) 1615 = N_Subprogram_Renaming_Declaration 1616 then 1617 Build_And_Analyze_Renamed_Body 1618 (Decl, Corresponding_Body (Decl), After); 1619 end if; 1620 end if; 1621 1622 elsif Ekind (E) in Task_Kind 1623 and then Nkind_In (Parent (E), N_Task_Type_Declaration, 1624 N_Single_Task_Declaration) 1625 then 1626 declare 1627 Ent : Entity_Id; 1628 1629 begin 1630 Ent := First_Entity (E); 1631 while Present (Ent) loop 1632 if Is_Entry (Ent) 1633 and then not Default_Expressions_Processed (Ent) 1634 then 1635 Process_Default_Expressions (Ent, After); 1636 end if; 1637 1638 Next_Entity (Ent); 1639 end loop; 1640 end; 1641 1642 -- We add finalization masters to access types whose designated types 1643 -- require finalization. This is normally done when freezing the 1644 -- type, but this misses recursive type definitions where the later 1645 -- members of the recursion introduce controlled components (such as 1646 -- can happen when incomplete types are involved), as well cases 1647 -- where a component type is private and the controlled full type 1648 -- occurs after the access type is frozen. Cases that don't need a 1649 -- finalization master are generic formal types (the actual type will 1650 -- have it) and types derived from them, and types with Java and CIL 1651 -- conventions, since those are used for API bindings. 1652 -- (Are there any other cases that should be excluded here???) 1653 1654 elsif Is_Access_Type (E) 1655 and then Comes_From_Source (E) 1656 and then not Is_Generic_Type (Root_Type (E)) 1657 and then Needs_Finalization (Designated_Type (E)) 1658 then 1659 Build_Finalization_Master (E); 1660 end if; 1661 1662 Next_Entity (E); 1663 end loop; 1664 end Freeze_All; 1665 1666 ----------------------- 1667 -- Freeze_And_Append -- 1668 ----------------------- 1669 1670 procedure Freeze_And_Append 1671 (Ent : Entity_Id; 1672 N : Node_Id; 1673 Result : in out List_Id) 1674 is 1675 L : constant List_Id := Freeze_Entity (Ent, N); 1676 begin 1677 if Is_Non_Empty_List (L) then 1678 if Result = No_List then 1679 Result := L; 1680 else 1681 Append_List (L, Result); 1682 end if; 1683 end if; 1684 end Freeze_And_Append; 1685 1686 ------------------- 1687 -- Freeze_Before -- 1688 ------------------- 1689 1690 procedure Freeze_Before (N : Node_Id; T : Entity_Id) is 1691 Freeze_Nodes : constant List_Id := Freeze_Entity (T, N); 1692 begin 1693 if Is_Non_Empty_List (Freeze_Nodes) then 1694 Insert_Actions (N, Freeze_Nodes); 1695 end if; 1696 end Freeze_Before; 1697 1698 ------------------- 1699 -- Freeze_Entity -- 1700 ------------------- 1701 1702 function Freeze_Entity (E : Entity_Id; N : Node_Id) return List_Id is 1703 Loc : constant Source_Ptr := Sloc (N); 1704 Test_E : Entity_Id := E; 1705 Comp : Entity_Id; 1706 F_Node : Node_Id; 1707 Indx : Node_Id; 1708 Formal : Entity_Id; 1709 Atype : Entity_Id; 1710 1711 Result : List_Id := No_List; 1712 -- List of freezing actions, left at No_List if none 1713 1714 Has_Default_Initialization : Boolean := False; 1715 -- This flag gets set to true for a variable with default initialization 1716 1717 procedure Add_To_Result (N : Node_Id); 1718 -- N is a freezing action to be appended to the Result 1719 1720 function After_Last_Declaration return Boolean; 1721 -- If Loc is a freeze_entity that appears after the last declaration 1722 -- in the scope, inhibit error messages on late completion. 1723 1724 procedure Check_Current_Instance (Comp_Decl : Node_Id); 1725 -- Check that an Access or Unchecked_Access attribute with a prefix 1726 -- which is the current instance type can only be applied when the type 1727 -- is limited. 1728 1729 procedure Check_Suspicious_Modulus (Utype : Entity_Id); 1730 -- Give warning for modulus of 8, 16, 32, or 64 given as an explicit 1731 -- integer literal without an explicit corresponding size clause. The 1732 -- caller has checked that Utype is a modular integer type. 1733 1734 procedure Freeze_Array_Type (Arr : Entity_Id); 1735 -- Freeze array type, including freezing index and component types 1736 1737 function Freeze_Generic_Entities (Pack : Entity_Id) return List_Id; 1738 -- Create Freeze_Generic_Entity nodes for types declared in a generic 1739 -- package. Recurse on inner generic packages. 1740 1741 procedure Freeze_Record_Type (Rec : Entity_Id); 1742 -- Freeze record type, including freezing component types, and freezing 1743 -- primitive operations if this is a tagged type. 1744 1745 procedure Wrap_Imported_Subprogram (E : Entity_Id); 1746 -- If E is an entity for an imported subprogram with pre/post-conditions 1747 -- then this procedure will create a wrapper to ensure that proper run- 1748 -- time checking of the pre/postconditions. See body for details. 1749 1750 ------------------- 1751 -- Add_To_Result -- 1752 ------------------- 1753 1754 procedure Add_To_Result (N : Node_Id) is 1755 begin 1756 if No (Result) then 1757 Result := New_List (N); 1758 else 1759 Append (N, Result); 1760 end if; 1761 end Add_To_Result; 1762 1763 ---------------------------- 1764 -- After_Last_Declaration -- 1765 ---------------------------- 1766 1767 function After_Last_Declaration return Boolean is 1768 Spec : constant Node_Id := Parent (Current_Scope); 1769 begin 1770 if Nkind (Spec) = N_Package_Specification then 1771 if Present (Private_Declarations (Spec)) then 1772 return Loc >= Sloc (Last (Private_Declarations (Spec))); 1773 elsif Present (Visible_Declarations (Spec)) then 1774 return Loc >= Sloc (Last (Visible_Declarations (Spec))); 1775 else 1776 return False; 1777 end if; 1778 else 1779 return False; 1780 end if; 1781 end After_Last_Declaration; 1782 1783 ---------------------------- 1784 -- Check_Current_Instance -- 1785 ---------------------------- 1786 1787 procedure Check_Current_Instance (Comp_Decl : Node_Id) is 1788 1789 function Is_Aliased_View_Of_Type (Typ : Entity_Id) return Boolean; 1790 -- Determine whether Typ is compatible with the rules for aliased 1791 -- views of types as defined in RM 3.10 in the various dialects. 1792 1793 function Process (N : Node_Id) return Traverse_Result; 1794 -- Process routine to apply check to given node 1795 1796 ----------------------------- 1797 -- Is_Aliased_View_Of_Type -- 1798 ----------------------------- 1799 1800 function Is_Aliased_View_Of_Type (Typ : Entity_Id) return Boolean is 1801 Typ_Decl : constant Node_Id := Parent (Typ); 1802 1803 begin 1804 -- Common case 1805 1806 if Nkind (Typ_Decl) = N_Full_Type_Declaration 1807 and then Limited_Present (Type_Definition (Typ_Decl)) 1808 then 1809 return True; 1810 1811 -- The following paragraphs describe what a legal aliased view of 1812 -- a type is in the various dialects of Ada. 1813 1814 -- Ada 95 1815 1816 -- The current instance of a limited type, and a formal parameter 1817 -- or generic formal object of a tagged type. 1818 1819 -- Ada 95 limited type 1820 -- * Type with reserved word "limited" 1821 -- * A protected or task type 1822 -- * A composite type with limited component 1823 1824 elsif Ada_Version <= Ada_95 then 1825 return Is_Limited_Type (Typ); 1826 1827 -- Ada 2005 1828 1829 -- The current instance of a limited tagged type, a protected 1830 -- type, a task type, or a type that has the reserved word 1831 -- "limited" in its full definition ... a formal parameter or 1832 -- generic formal object of a tagged type. 1833 1834 -- Ada 2005 limited type 1835 -- * Type with reserved word "limited", "synchronized", "task" 1836 -- or "protected" 1837 -- * A composite type with limited component 1838 -- * A derived type whose parent is a non-interface limited type 1839 1840 elsif Ada_Version = Ada_2005 then 1841 return 1842 (Is_Limited_Type (Typ) and then Is_Tagged_Type (Typ)) 1843 or else 1844 (Is_Derived_Type (Typ) 1845 and then not Is_Interface (Etype (Typ)) 1846 and then Is_Limited_Type (Etype (Typ))); 1847 1848 -- Ada 2012 and beyond 1849 1850 -- The current instance of an immutably limited type ... a formal 1851 -- parameter or generic formal object of a tagged type. 1852 1853 -- Ada 2012 limited type 1854 -- * Type with reserved word "limited", "synchronized", "task" 1855 -- or "protected" 1856 -- * A composite type with limited component 1857 -- * A derived type whose parent is a non-interface limited type 1858 -- * An incomplete view 1859 1860 -- Ada 2012 immutably limited type 1861 -- * Explicitly limited record type 1862 -- * Record extension with "limited" present 1863 -- * Non-formal limited private type that is either tagged 1864 -- or has at least one access discriminant with a default 1865 -- expression 1866 -- * Task type, protected type or synchronized interface 1867 -- * Type derived from immutably limited type 1868 1869 else 1870 return 1871 Is_Immutably_Limited_Type (Typ) 1872 or else Is_Incomplete_Type (Typ); 1873 end if; 1874 end Is_Aliased_View_Of_Type; 1875 1876 ------------- 1877 -- Process -- 1878 ------------- 1879 1880 function Process (N : Node_Id) return Traverse_Result is 1881 begin 1882 case Nkind (N) is 1883 when N_Attribute_Reference => 1884 if Nam_In (Attribute_Name (N), Name_Access, 1885 Name_Unchecked_Access) 1886 and then Is_Entity_Name (Prefix (N)) 1887 and then Is_Type (Entity (Prefix (N))) 1888 and then Entity (Prefix (N)) = E 1889 then 1890 if Ada_Version < Ada_2012 then 1891 Error_Msg_N 1892 ("current instance must be a limited type", 1893 Prefix (N)); 1894 else 1895 Error_Msg_N 1896 ("current instance must be an immutably limited " 1897 & "type (RM-2012, 7.5 (8.1/3))", 1898 Prefix (N)); 1899 end if; 1900 1901 return Abandon; 1902 1903 else 1904 return OK; 1905 end if; 1906 1907 when others => return OK; 1908 end case; 1909 end Process; 1910 1911 procedure Traverse is new Traverse_Proc (Process); 1912 1913 -- Local variables 1914 1915 Rec_Type : constant Entity_Id := 1916 Scope (Defining_Identifier (Comp_Decl)); 1917 1918 -- Start of processing for Check_Current_Instance 1919 1920 begin 1921 if not Is_Aliased_View_Of_Type (Rec_Type) then 1922 Traverse (Comp_Decl); 1923 end if; 1924 end Check_Current_Instance; 1925 1926 ------------------------------ 1927 -- Check_Suspicious_Modulus -- 1928 ------------------------------ 1929 1930 procedure Check_Suspicious_Modulus (Utype : Entity_Id) is 1931 Decl : constant Node_Id := Declaration_Node (Underlying_Type (Utype)); 1932 1933 begin 1934 if not Warn_On_Suspicious_Modulus_Value then 1935 return; 1936 end if; 1937 1938 if Nkind (Decl) = N_Full_Type_Declaration then 1939 declare 1940 Tdef : constant Node_Id := Type_Definition (Decl); 1941 1942 begin 1943 if Nkind (Tdef) = N_Modular_Type_Definition then 1944 declare 1945 Modulus : constant Node_Id := 1946 Original_Node (Expression (Tdef)); 1947 1948 begin 1949 if Nkind (Modulus) = N_Integer_Literal then 1950 declare 1951 Modv : constant Uint := Intval (Modulus); 1952 Sizv : constant Uint := RM_Size (Utype); 1953 1954 begin 1955 -- First case, modulus and size are the same. This 1956 -- happens if you have something like mod 32, with 1957 -- an explicit size of 32, this is for sure a case 1958 -- where the warning is given, since it is seems 1959 -- very unlikely that someone would want e.g. a 1960 -- five bit type stored in 32 bits. It is much 1961 -- more likely they wanted a 32-bit type. 1962 1963 if Modv = Sizv then 1964 null; 1965 1966 -- Second case, the modulus is 32 or 64 and no 1967 -- size clause is present. This is a less clear 1968 -- case for giving the warning, but in the case 1969 -- of 32/64 (5-bit or 6-bit types) these seem rare 1970 -- enough that it is a likely error (and in any 1971 -- case using 2**5 or 2**6 in these cases seems 1972 -- clearer. We don't include 8 or 16 here, simply 1973 -- because in practice 3-bit and 4-bit types are 1974 -- more common and too many false positives if 1975 -- we warn in these cases. 1976 1977 elsif not Has_Size_Clause (Utype) 1978 and then (Modv = Uint_32 or else Modv = Uint_64) 1979 then 1980 null; 1981 1982 -- No warning needed 1983 1984 else 1985 return; 1986 end if; 1987 1988 -- If we fall through, give warning 1989 1990 Error_Msg_Uint_1 := Modv; 1991 Error_Msg_N 1992 ("?M?2 '*'*^' may have been intended here", 1993 Modulus); 1994 end; 1995 end if; 1996 end; 1997 end if; 1998 end; 1999 end if; 2000 end Check_Suspicious_Modulus; 2001 2002 ----------------------- 2003 -- Freeze_Array_Type -- 2004 ----------------------- 2005 2006 procedure Freeze_Array_Type (Arr : Entity_Id) is 2007 FS : constant Entity_Id := First_Subtype (Arr); 2008 Ctyp : constant Entity_Id := Component_Type (Arr); 2009 Clause : Entity_Id; 2010 2011 Non_Standard_Enum : Boolean := False; 2012 -- Set true if any of the index types is an enumeration type with a 2013 -- non-standard representation. 2014 2015 begin 2016 Freeze_And_Append (Ctyp, N, Result); 2017 2018 Indx := First_Index (Arr); 2019 while Present (Indx) loop 2020 Freeze_And_Append (Etype (Indx), N, Result); 2021 2022 if Is_Enumeration_Type (Etype (Indx)) 2023 and then Has_Non_Standard_Rep (Etype (Indx)) 2024 then 2025 Non_Standard_Enum := True; 2026 end if; 2027 2028 Next_Index (Indx); 2029 end loop; 2030 2031 -- Processing that is done only for base types 2032 2033 if Ekind (Arr) = E_Array_Type then 2034 2035 -- Propagate flags for component type 2036 2037 if Is_Controlled (Component_Type (Arr)) 2038 or else Has_Controlled_Component (Ctyp) 2039 then 2040 Set_Has_Controlled_Component (Arr); 2041 end if; 2042 2043 if Has_Unchecked_Union (Component_Type (Arr)) then 2044 Set_Has_Unchecked_Union (Arr); 2045 end if; 2046 2047 -- Warn for pragma Pack overriding foreign convention 2048 2049 if Has_Foreign_Convention (Ctyp) 2050 and then Has_Pragma_Pack (Arr) 2051 then 2052 declare 2053 CN : constant Name_Id := 2054 Get_Convention_Name (Convention (Ctyp)); 2055 PP : constant Node_Id := 2056 Get_Pragma (First_Subtype (Arr), Pragma_Pack); 2057 begin 2058 if Present (PP) then 2059 Error_Msg_Name_1 := CN; 2060 Error_Msg_Sloc := Sloc (Arr); 2061 Error_Msg_N 2062 ("pragma Pack affects convention % components #??", 2063 PP); 2064 Error_Msg_Name_1 := CN; 2065 Error_Msg_N 2066 ("\array components may not have % compatible " 2067 & "representation??", PP); 2068 end if; 2069 end; 2070 end if; 2071 2072 -- If packing was requested or if the component size was 2073 -- set explicitly, then see if bit packing is required. This 2074 -- processing is only done for base types, since all of the 2075 -- representation aspects involved are type-related. 2076 2077 -- This is not just an optimization, if we start processing the 2078 -- subtypes, they interfere with the settings on the base type 2079 -- (this is because Is_Packed has a slightly different meaning 2080 -- before and after freezing). 2081 2082 declare 2083 Csiz : Uint; 2084 Esiz : Uint; 2085 2086 begin 2087 if (Is_Packed (Arr) or else Has_Pragma_Pack (Arr)) 2088 and then Known_Static_RM_Size (Ctyp) 2089 and then not Has_Component_Size_Clause (Arr) 2090 then 2091 Csiz := UI_Max (RM_Size (Ctyp), 1); 2092 2093 elsif Known_Component_Size (Arr) then 2094 Csiz := Component_Size (Arr); 2095 2096 elsif not Known_Static_Esize (Ctyp) then 2097 Csiz := Uint_0; 2098 2099 else 2100 Esiz := Esize (Ctyp); 2101 2102 -- We can set the component size if it is less than 16, 2103 -- rounding it up to the next storage unit size. 2104 2105 if Esiz <= 8 then 2106 Csiz := Uint_8; 2107 elsif Esiz <= 16 then 2108 Csiz := Uint_16; 2109 else 2110 Csiz := Uint_0; 2111 end if; 2112 2113 -- Set component size up to match alignment if it would 2114 -- otherwise be less than the alignment. This deals with 2115 -- cases of types whose alignment exceeds their size (the 2116 -- padded type cases). 2117 2118 if Csiz /= 0 then 2119 declare 2120 A : constant Uint := Alignment_In_Bits (Ctyp); 2121 begin 2122 if Csiz < A then 2123 Csiz := A; 2124 end if; 2125 end; 2126 end if; 2127 end if; 2128 2129 -- Case of component size that may result in packing 2130 2131 if 1 <= Csiz and then Csiz <= 64 then 2132 declare 2133 Ent : constant Entity_Id := 2134 First_Subtype (Arr); 2135 Pack_Pragma : constant Node_Id := 2136 Get_Rep_Pragma (Ent, Name_Pack); 2137 Comp_Size_C : constant Node_Id := 2138 Get_Attribute_Definition_Clause 2139 (Ent, Attribute_Component_Size); 2140 begin 2141 -- Warn if we have pack and component size so that the 2142 -- pack is ignored. 2143 2144 -- Note: here we must check for the presence of a 2145 -- component size before checking for a Pack pragma to 2146 -- deal with the case where the array type is a derived 2147 -- type whose parent is currently private. 2148 2149 if Present (Comp_Size_C) 2150 and then Has_Pragma_Pack (Ent) 2151 and then Warn_On_Redundant_Constructs 2152 then 2153 Error_Msg_Sloc := Sloc (Comp_Size_C); 2154 Error_Msg_NE 2155 ("?r?pragma Pack for& ignored!", Pack_Pragma, Ent); 2156 Error_Msg_N 2157 ("\?r?explicit component size given#!", Pack_Pragma); 2158 Set_Is_Packed (Base_Type (Ent), False); 2159 Set_Is_Bit_Packed_Array (Base_Type (Ent), False); 2160 end if; 2161 2162 -- Set component size if not already set by a component 2163 -- size clause. 2164 2165 if not Present (Comp_Size_C) then 2166 Set_Component_Size (Arr, Csiz); 2167 end if; 2168 2169 -- Check for base type of 8, 16, 32 bits, where an 2170 -- unsigned subtype has a length one less than the 2171 -- base type (e.g. Natural subtype of Integer). 2172 2173 -- In such cases, if a component size was not set 2174 -- explicitly, then generate a warning. 2175 2176 if Has_Pragma_Pack (Arr) 2177 and then not Present (Comp_Size_C) 2178 and then 2179 (Csiz = 7 or else Csiz = 15 or else Csiz = 31) 2180 and then Esize (Base_Type (Ctyp)) = Csiz + 1 2181 then 2182 Error_Msg_Uint_1 := Csiz; 2183 2184 if Present (Pack_Pragma) then 2185 Error_Msg_N 2186 ("??pragma Pack causes component size " 2187 & "to be ^!", Pack_Pragma); 2188 Error_Msg_N 2189 ("\??use Component_Size to set " 2190 & "desired value!", Pack_Pragma); 2191 end if; 2192 end if; 2193 2194 -- Actual packing is not needed for 8, 16, 32, 64. Also 2195 -- not needed for 24 if alignment is 1. 2196 2197 if Csiz = 8 2198 or else Csiz = 16 2199 or else Csiz = 32 2200 or else Csiz = 64 2201 or else (Csiz = 24 and then Alignment (Ctyp) = 1) 2202 then 2203 -- Here the array was requested to be packed, but 2204 -- the packing request had no effect, so Is_Packed 2205 -- is reset. 2206 2207 -- Note: semantically this means that we lose track 2208 -- of the fact that a derived type inherited a pragma 2209 -- Pack that was non- effective, but that seems fine. 2210 2211 -- We regard a Pack pragma as a request to set a 2212 -- representation characteristic, and this request 2213 -- may be ignored. 2214 2215 Set_Is_Packed (Base_Type (Arr), False); 2216 Set_Is_Bit_Packed_Array (Base_Type (Arr), False); 2217 2218 if Known_Static_Esize (Component_Type (Arr)) 2219 and then Esize (Component_Type (Arr)) = Csiz 2220 then 2221 Set_Has_Non_Standard_Rep 2222 (Base_Type (Arr), False); 2223 end if; 2224 2225 -- In all other cases, packing is indeed needed 2226 2227 else 2228 Set_Has_Non_Standard_Rep (Base_Type (Arr), True); 2229 Set_Is_Bit_Packed_Array (Base_Type (Arr), True); 2230 Set_Is_Packed (Base_Type (Arr), True); 2231 end if; 2232 end; 2233 end if; 2234 end; 2235 2236 -- Check for Atomic_Components or Aliased with unsuitable packing 2237 -- or explicit component size clause given. 2238 2239 if (Has_Atomic_Components (Arr) 2240 or else 2241 Has_Aliased_Components (Arr)) 2242 and then 2243 (Has_Component_Size_Clause (Arr) or else Is_Packed (Arr)) 2244 then 2245 Alias_Atomic_Check : declare 2246 2247 procedure Complain_CS (T : String); 2248 -- Outputs error messages for incorrect CS clause or pragma 2249 -- Pack for aliased or atomic components (T is "aliased" or 2250 -- "atomic"); 2251 2252 ----------------- 2253 -- Complain_CS -- 2254 ----------------- 2255 2256 procedure Complain_CS (T : String) is 2257 begin 2258 if Has_Component_Size_Clause (Arr) then 2259 Clause := 2260 Get_Attribute_Definition_Clause 2261 (FS, Attribute_Component_Size); 2262 2263 if Known_Static_Esize (Ctyp) then 2264 Error_Msg_N 2265 ("incorrect component size for " 2266 & T & " components", Clause); 2267 Error_Msg_Uint_1 := Esize (Ctyp); 2268 Error_Msg_N 2269 ("\only allowed value is^", Clause); 2270 2271 else 2272 Error_Msg_N 2273 ("component size cannot be given for " 2274 & T & " components", Clause); 2275 end if; 2276 2277 else 2278 Error_Msg_N 2279 ("cannot pack " & T & " components", 2280 Get_Rep_Pragma (FS, Name_Pack)); 2281 end if; 2282 2283 return; 2284 end Complain_CS; 2285 2286 -- Start of processing for Alias_Atomic_Check 2287 2288 begin 2289 -- If object size of component type isn't known, we cannot 2290 -- be sure so we defer to the back end. 2291 2292 if not Known_Static_Esize (Ctyp) then 2293 null; 2294 2295 -- Case where component size has no effect. First check for 2296 -- object size of component type multiple of the storage 2297 -- unit size. 2298 2299 elsif Esize (Ctyp) mod System_Storage_Unit = 0 2300 2301 -- OK in both packing case and component size case if RM 2302 -- size is known and static and same as the object size. 2303 2304 and then 2305 ((Known_Static_RM_Size (Ctyp) 2306 and then Esize (Ctyp) = RM_Size (Ctyp)) 2307 2308 -- Or if we have an explicit component size clause and 2309 -- the component size and object size are equal. 2310 2311 or else 2312 (Has_Component_Size_Clause (Arr) 2313 and then Component_Size (Arr) = Esize (Ctyp))) 2314 then 2315 null; 2316 2317 elsif Has_Aliased_Components (Arr) 2318 or else Is_Aliased (Ctyp) 2319 then 2320 Complain_CS ("aliased"); 2321 2322 elsif Has_Atomic_Components (Arr) 2323 or else Is_Atomic (Ctyp) 2324 then 2325 Complain_CS ("atomic"); 2326 end if; 2327 end Alias_Atomic_Check; 2328 end if; 2329 2330 -- Warn for case of atomic type 2331 2332 Clause := Get_Rep_Pragma (FS, Name_Atomic); 2333 2334 if Present (Clause) 2335 and then not Addressable (Component_Size (FS)) 2336 then 2337 Error_Msg_NE 2338 ("non-atomic components of type& may not be " 2339 & "accessible by separate tasks??", Clause, Arr); 2340 2341 if Has_Component_Size_Clause (Arr) then 2342 Error_Msg_Sloc := Sloc (Get_Attribute_Definition_Clause 2343 (FS, Attribute_Component_Size)); 2344 Error_Msg_N ("\because of component size clause#??", Clause); 2345 2346 elsif Has_Pragma_Pack (Arr) then 2347 Error_Msg_Sloc := Sloc (Get_Rep_Pragma (FS, Name_Pack)); 2348 Error_Msg_N ("\because of pragma Pack#??", Clause); 2349 end if; 2350 end if; 2351 2352 -- Check for scalar storage order 2353 2354 Check_Component_Storage_Order 2355 (Encl_Type => Arr, 2356 Comp => Empty, 2357 ADC => Get_Attribute_Definition_Clause 2358 (First_Subtype (Arr), 2359 Attribute_Scalar_Storage_Order)); 2360 2361 -- Processing that is done only for subtypes 2362 2363 else 2364 -- Acquire alignment from base type 2365 2366 if Unknown_Alignment (Arr) then 2367 Set_Alignment (Arr, Alignment (Base_Type (Arr))); 2368 Adjust_Esize_Alignment (Arr); 2369 end if; 2370 end if; 2371 2372 -- Specific checks for bit-packed arrays 2373 2374 if Is_Bit_Packed_Array (Arr) then 2375 2376 -- Check number of elements for bit packed arrays that come from 2377 -- source and have compile time known ranges. The bit-packed 2378 -- arrays circuitry does not support arrays with more than 2379 -- Integer'Last + 1 elements, and when this restriction is 2380 -- violated, causes incorrect data access. 2381 2382 -- For the case where this is not compile time known, a run-time 2383 -- check should be generated??? 2384 2385 if Comes_From_Source (Arr) and then Is_Constrained (Arr) then 2386 declare 2387 Elmts : Uint; 2388 Index : Node_Id; 2389 Ilen : Node_Id; 2390 Ityp : Entity_Id; 2391 2392 begin 2393 Elmts := Uint_1; 2394 Index := First_Index (Arr); 2395 while Present (Index) loop 2396 Ityp := Etype (Index); 2397 2398 -- Never generate an error if any index is of a generic 2399 -- type. We will check this in instances. 2400 2401 if Is_Generic_Type (Ityp) then 2402 Elmts := Uint_0; 2403 exit; 2404 end if; 2405 2406 Ilen := 2407 Make_Attribute_Reference (Loc, 2408 Prefix => 2409 New_Occurrence_Of (Ityp, Loc), 2410 Attribute_Name => Name_Range_Length); 2411 Analyze_And_Resolve (Ilen); 2412 2413 -- No attempt is made to check number of elements 2414 -- if not compile time known. 2415 2416 if Nkind (Ilen) /= N_Integer_Literal then 2417 Elmts := Uint_0; 2418 exit; 2419 end if; 2420 2421 Elmts := Elmts * Intval (Ilen); 2422 Next_Index (Index); 2423 end loop; 2424 2425 if Elmts > Intval (High_Bound 2426 (Scalar_Range (Standard_Integer))) + 1 2427 then 2428 Error_Msg_N 2429 ("bit packed array type may not have " 2430 & "more than Integer''Last+1 elements", Arr); 2431 end if; 2432 end; 2433 end if; 2434 2435 -- Check size 2436 2437 if Known_RM_Size (Arr) then 2438 declare 2439 SizC : constant Node_Id := Size_Clause (Arr); 2440 2441 Discard : Boolean; 2442 pragma Warnings (Off, Discard); 2443 2444 begin 2445 -- It is not clear if it is possible to have no size clause 2446 -- at this stage, but it is not worth worrying about. Post 2447 -- error on the entity name in the size clause if present, 2448 -- else on the type entity itself. 2449 2450 if Present (SizC) then 2451 Check_Size (Name (SizC), Arr, RM_Size (Arr), Discard); 2452 else 2453 Check_Size (Arr, Arr, RM_Size (Arr), Discard); 2454 end if; 2455 end; 2456 end if; 2457 end if; 2458 2459 -- If any of the index types was an enumeration type with a 2460 -- non-standard rep clause, then we indicate that the array type 2461 -- is always packed (even if it is not bit packed). 2462 2463 if Non_Standard_Enum then 2464 Set_Has_Non_Standard_Rep (Base_Type (Arr)); 2465 Set_Is_Packed (Base_Type (Arr)); 2466 end if; 2467 2468 Set_Component_Alignment_If_Not_Set (Arr); 2469 2470 -- If the array is packed, we must create the packed array type to be 2471 -- used to actually implement the type. This is only needed for real 2472 -- array types (not for string literal types, since they are present 2473 -- only for the front end). 2474 2475 if Is_Packed (Arr) 2476 and then Ekind (Arr) /= E_String_Literal_Subtype 2477 then 2478 Create_Packed_Array_Type (Arr); 2479 Freeze_And_Append (Packed_Array_Type (Arr), N, Result); 2480 2481 -- Size information of packed array type is copied to the array 2482 -- type, since this is really the representation. But do not 2483 -- override explicit existing size values. If the ancestor subtype 2484 -- is constrained the packed_array_type will be inherited from it, 2485 -- but the size may have been provided already, and must not be 2486 -- overridden either. 2487 2488 if not Has_Size_Clause (Arr) 2489 and then 2490 (No (Ancestor_Subtype (Arr)) 2491 or else not Has_Size_Clause (Ancestor_Subtype (Arr))) 2492 then 2493 Set_Esize (Arr, Esize (Packed_Array_Type (Arr))); 2494 Set_RM_Size (Arr, RM_Size (Packed_Array_Type (Arr))); 2495 end if; 2496 2497 if not Has_Alignment_Clause (Arr) then 2498 Set_Alignment (Arr, Alignment (Packed_Array_Type (Arr))); 2499 end if; 2500 end if; 2501 2502 -- For non-packed arrays set the alignment of the array to the 2503 -- alignment of the component type if it is unknown. Skip this 2504 -- in atomic case (atomic arrays may need larger alignments). 2505 2506 if not Is_Packed (Arr) 2507 and then Unknown_Alignment (Arr) 2508 and then Known_Alignment (Ctyp) 2509 and then Known_Static_Component_Size (Arr) 2510 and then Known_Static_Esize (Ctyp) 2511 and then Esize (Ctyp) = Component_Size (Arr) 2512 and then not Is_Atomic (Arr) 2513 then 2514 Set_Alignment (Arr, Alignment (Component_Type (Arr))); 2515 end if; 2516 end Freeze_Array_Type; 2517 2518 ----------------------------- 2519 -- Freeze_Generic_Entities -- 2520 ----------------------------- 2521 2522 function Freeze_Generic_Entities (Pack : Entity_Id) return List_Id is 2523 E : Entity_Id; 2524 F : Node_Id; 2525 Flist : List_Id; 2526 2527 begin 2528 Flist := New_List; 2529 E := First_Entity (Pack); 2530 while Present (E) loop 2531 if Is_Type (E) and then not Is_Generic_Type (E) then 2532 F := Make_Freeze_Generic_Entity (Sloc (Pack)); 2533 Set_Entity (F, E); 2534 Append_To (Flist, F); 2535 2536 elsif Ekind (E) = E_Generic_Package then 2537 Append_List_To (Flist, Freeze_Generic_Entities (E)); 2538 end if; 2539 2540 Next_Entity (E); 2541 end loop; 2542 2543 return Flist; 2544 end Freeze_Generic_Entities; 2545 2546 ------------------------ 2547 -- Freeze_Record_Type -- 2548 ------------------------ 2549 2550 procedure Freeze_Record_Type (Rec : Entity_Id) is 2551 Comp : Entity_Id; 2552 IR : Node_Id; 2553 ADC : Node_Id; 2554 Prev : Entity_Id; 2555 2556 Junk : Boolean; 2557 pragma Warnings (Off, Junk); 2558 2559 Rec_Pushed : Boolean := False; 2560 -- Set True if the record type scope Rec has been pushed on the scope 2561 -- stack. Needed for the analysis of delayed aspects specified to the 2562 -- components of Rec. 2563 2564 Unplaced_Component : Boolean := False; 2565 -- Set True if we find at least one component with no component 2566 -- clause (used to warn about useless Pack pragmas). 2567 2568 Placed_Component : Boolean := False; 2569 -- Set True if we find at least one component with a component 2570 -- clause (used to warn about useless Bit_Order pragmas, and also 2571 -- to detect cases where Implicit_Packing may have an effect). 2572 2573 Aliased_Component : Boolean := False; 2574 -- Set True if we find at least one component which is aliased. This 2575 -- is used to prevent Implicit_Packing of the record, since packing 2576 -- cannot modify the size of alignment of an aliased component. 2577 2578 All_Scalar_Components : Boolean := True; 2579 -- Set False if we encounter a component of a non-scalar type 2580 2581 Scalar_Component_Total_RM_Size : Uint := Uint_0; 2582 Scalar_Component_Total_Esize : Uint := Uint_0; 2583 -- Accumulates total RM_Size values and total Esize values of all 2584 -- scalar components. Used for processing of Implicit_Packing. 2585 2586 function Check_Allocator (N : Node_Id) return Node_Id; 2587 -- If N is an allocator, possibly wrapped in one or more level of 2588 -- qualified expression(s), return the inner allocator node, else 2589 -- return Empty. 2590 2591 procedure Check_Itype (Typ : Entity_Id); 2592 -- If the component subtype is an access to a constrained subtype of 2593 -- an already frozen type, make the subtype frozen as well. It might 2594 -- otherwise be frozen in the wrong scope, and a freeze node on 2595 -- subtype has no effect. Similarly, if the component subtype is a 2596 -- regular (not protected) access to subprogram, set the anonymous 2597 -- subprogram type to frozen as well, to prevent an out-of-scope 2598 -- freeze node at some eventual point of call. Protected operations 2599 -- are handled elsewhere. 2600 2601 procedure Freeze_Choices_In_Variant_Part (VP : Node_Id); 2602 -- Make sure that all types mentioned in Discrete_Choices of the 2603 -- variants referenceed by the Variant_Part VP are frozen. This is 2604 -- a recursive routine to deal with nested variants. 2605 2606 --------------------- 2607 -- Check_Allocator -- 2608 --------------------- 2609 2610 function Check_Allocator (N : Node_Id) return Node_Id is 2611 Inner : Node_Id; 2612 begin 2613 Inner := N; 2614 loop 2615 if Nkind (Inner) = N_Allocator then 2616 return Inner; 2617 elsif Nkind (Inner) = N_Qualified_Expression then 2618 Inner := Expression (Inner); 2619 else 2620 return Empty; 2621 end if; 2622 end loop; 2623 end Check_Allocator; 2624 2625 ----------------- 2626 -- Check_Itype -- 2627 ----------------- 2628 2629 procedure Check_Itype (Typ : Entity_Id) is 2630 Desig : constant Entity_Id := Designated_Type (Typ); 2631 2632 begin 2633 if not Is_Frozen (Desig) 2634 and then Is_Frozen (Base_Type (Desig)) 2635 then 2636 Set_Is_Frozen (Desig); 2637 2638 -- In addition, add an Itype_Reference to ensure that the 2639 -- access subtype is elaborated early enough. This cannot be 2640 -- done if the subtype may depend on discriminants. 2641 2642 if Ekind (Comp) = E_Component 2643 and then Is_Itype (Etype (Comp)) 2644 and then not Has_Discriminants (Rec) 2645 then 2646 IR := Make_Itype_Reference (Sloc (Comp)); 2647 Set_Itype (IR, Desig); 2648 Add_To_Result (IR); 2649 end if; 2650 2651 elsif Ekind (Typ) = E_Anonymous_Access_Subprogram_Type 2652 and then Convention (Desig) /= Convention_Protected 2653 then 2654 Set_Is_Frozen (Desig); 2655 end if; 2656 end Check_Itype; 2657 2658 ------------------------------------ 2659 -- Freeze_Choices_In_Variant_Part -- 2660 ------------------------------------ 2661 2662 procedure Freeze_Choices_In_Variant_Part (VP : Node_Id) is 2663 pragma Assert (Nkind (VP) = N_Variant_Part); 2664 2665 Variant : Node_Id; 2666 Choice : Node_Id; 2667 CL : Node_Id; 2668 2669 begin 2670 -- Loop through variants 2671 2672 Variant := First_Non_Pragma (Variants (VP)); 2673 while Present (Variant) loop 2674 2675 -- Loop through choices, checking that all types are frozen 2676 2677 Choice := First_Non_Pragma (Discrete_Choices (Variant)); 2678 while Present (Choice) loop 2679 if Nkind (Choice) in N_Has_Etype 2680 and then Present (Etype (Choice)) 2681 then 2682 Freeze_And_Append (Etype (Choice), N, Result); 2683 end if; 2684 2685 Next_Non_Pragma (Choice); 2686 end loop; 2687 2688 -- Check for nested variant part to process 2689 2690 CL := Component_List (Variant); 2691 2692 if not Null_Present (CL) then 2693 if Present (Variant_Part (CL)) then 2694 Freeze_Choices_In_Variant_Part (Variant_Part (CL)); 2695 end if; 2696 end if; 2697 2698 Next_Non_Pragma (Variant); 2699 end loop; 2700 end Freeze_Choices_In_Variant_Part; 2701 2702 -- Start of processing for Freeze_Record_Type 2703 2704 begin 2705 -- Deal with delayed aspect specifications for components. The 2706 -- analysis of the aspect is required to be delayed to the freeze 2707 -- point, thus we analyze the pragma or attribute definition 2708 -- clause in the tree at this point. We also analyze the aspect 2709 -- specification node at the freeze point when the aspect doesn't 2710 -- correspond to pragma/attribute definition clause. 2711 2712 Comp := First_Entity (Rec); 2713 while Present (Comp) loop 2714 if Ekind (Comp) = E_Component 2715 and then Has_Delayed_Aspects (Comp) 2716 then 2717 if not Rec_Pushed then 2718 Push_Scope (Rec); 2719 Rec_Pushed := True; 2720 2721 -- The visibility to the discriminants must be restored in 2722 -- order to properly analyze the aspects. 2723 2724 if Has_Discriminants (Rec) then 2725 Install_Discriminants (Rec); 2726 end if; 2727 end if; 2728 2729 Analyze_Aspects_At_Freeze_Point (Comp); 2730 end if; 2731 2732 Next_Entity (Comp); 2733 end loop; 2734 2735 -- Pop the scope if Rec scope has been pushed on the scope stack 2736 -- during the delayed aspect analysis process. 2737 2738 if Rec_Pushed then 2739 if Has_Discriminants (Rec) then 2740 Uninstall_Discriminants (Rec); 2741 end if; 2742 2743 Pop_Scope; 2744 end if; 2745 2746 -- Freeze components and embedded subtypes 2747 2748 Comp := First_Entity (Rec); 2749 Prev := Empty; 2750 while Present (Comp) loop 2751 if Is_Aliased (Comp) then 2752 Aliased_Component := True; 2753 end if; 2754 2755 -- Handle the component and discriminant case 2756 2757 if Ekind_In (Comp, E_Component, E_Discriminant) then 2758 declare 2759 CC : constant Node_Id := Component_Clause (Comp); 2760 2761 begin 2762 -- Freezing a record type freezes the type of each of its 2763 -- components. However, if the type of the component is 2764 -- part of this record, we do not want or need a separate 2765 -- Freeze_Node. Note that Is_Itype is wrong because that's 2766 -- also set in private type cases. We also can't check for 2767 -- the Scope being exactly Rec because of private types and 2768 -- record extensions. 2769 2770 if Is_Itype (Etype (Comp)) 2771 and then Is_Record_Type (Underlying_Type 2772 (Scope (Etype (Comp)))) 2773 then 2774 Undelay_Type (Etype (Comp)); 2775 end if; 2776 2777 Freeze_And_Append (Etype (Comp), N, Result); 2778 2779 -- Warn for pragma Pack overriding foreign convention 2780 2781 if Has_Foreign_Convention (Etype (Comp)) 2782 and then Has_Pragma_Pack (Rec) 2783 2784 -- Don't warn for aliased components, since override 2785 -- cannot happen in that case. 2786 2787 and then not Is_Aliased (Comp) 2788 then 2789 declare 2790 CN : constant Name_Id := 2791 Get_Convention_Name (Convention (Etype (Comp))); 2792 PP : constant Node_Id := 2793 Get_Pragma (Rec, Pragma_Pack); 2794 begin 2795 if Present (PP) then 2796 Error_Msg_Name_1 := CN; 2797 Error_Msg_Sloc := Sloc (Comp); 2798 Error_Msg_N 2799 ("pragma Pack affects convention % component#??", 2800 PP); 2801 Error_Msg_Name_1 := CN; 2802 Error_Msg_NE 2803 ("\component & may not have % compatible " 2804 & "representation??", PP, Comp); 2805 end if; 2806 end; 2807 end if; 2808 2809 -- Check for error of component clause given for variable 2810 -- sized type. We have to delay this test till this point, 2811 -- since the component type has to be frozen for us to know 2812 -- if it is variable length. 2813 2814 if Present (CC) then 2815 Placed_Component := True; 2816 2817 -- We omit this test in a generic context, it will be 2818 -- applied at instantiation time. 2819 2820 if Inside_A_Generic then 2821 null; 2822 2823 -- Also omit this test in CodePeer mode, since we do not 2824 -- have sufficient info on size and rep clauses. 2825 2826 elsif CodePeer_Mode then 2827 null; 2828 2829 -- Do the check 2830 2831 elsif not 2832 Size_Known_At_Compile_Time 2833 (Underlying_Type (Etype (Comp))) 2834 then 2835 Error_Msg_N 2836 ("component clause not allowed for variable " & 2837 "length component", CC); 2838 end if; 2839 2840 else 2841 Unplaced_Component := True; 2842 end if; 2843 2844 -- Case of component requires byte alignment 2845 2846 if Must_Be_On_Byte_Boundary (Etype (Comp)) then 2847 2848 -- Set the enclosing record to also require byte align 2849 2850 Set_Must_Be_On_Byte_Boundary (Rec); 2851 2852 -- Check for component clause that is inconsistent with 2853 -- the required byte boundary alignment. 2854 2855 if Present (CC) 2856 and then Normalized_First_Bit (Comp) mod 2857 System_Storage_Unit /= 0 2858 then 2859 Error_Msg_N 2860 ("component & must be byte aligned", 2861 Component_Name (Component_Clause (Comp))); 2862 end if; 2863 end if; 2864 end; 2865 end if; 2866 2867 -- Gather data for possible Implicit_Packing later. Note that at 2868 -- this stage we might be dealing with a real component, or with 2869 -- an implicit subtype declaration. 2870 2871 if not Is_Scalar_Type (Etype (Comp)) then 2872 All_Scalar_Components := False; 2873 else 2874 Scalar_Component_Total_RM_Size := 2875 Scalar_Component_Total_RM_Size + RM_Size (Etype (Comp)); 2876 Scalar_Component_Total_Esize := 2877 Scalar_Component_Total_Esize + Esize (Etype (Comp)); 2878 end if; 2879 2880 -- If the component is an Itype with Delayed_Freeze and is either 2881 -- a record or array subtype and its base type has not yet been 2882 -- frozen, we must remove this from the entity list of this record 2883 -- and put it on the entity list of the scope of its base type. 2884 -- Note that we know that this is not the type of a component 2885 -- since we cleared Has_Delayed_Freeze for it in the previous 2886 -- loop. Thus this must be the Designated_Type of an access type, 2887 -- which is the type of a component. 2888 2889 if Is_Itype (Comp) 2890 and then Is_Type (Scope (Comp)) 2891 and then Is_Composite_Type (Comp) 2892 and then Base_Type (Comp) /= Comp 2893 and then Has_Delayed_Freeze (Comp) 2894 and then not Is_Frozen (Base_Type (Comp)) 2895 then 2896 declare 2897 Will_Be_Frozen : Boolean := False; 2898 S : Entity_Id; 2899 2900 begin 2901 -- We have a pretty bad kludge here. Suppose Rec is subtype 2902 -- being defined in a subprogram that's created as part of 2903 -- the freezing of Rec'Base. In that case, we know that 2904 -- Comp'Base must have already been frozen by the time we 2905 -- get to elaborate this because Gigi doesn't elaborate any 2906 -- bodies until it has elaborated all of the declarative 2907 -- part. But Is_Frozen will not be set at this point because 2908 -- we are processing code in lexical order. 2909 2910 -- We detect this case by going up the Scope chain of Rec 2911 -- and seeing if we have a subprogram scope before reaching 2912 -- the top of the scope chain or that of Comp'Base. If we 2913 -- do, then mark that Comp'Base will actually be frozen. If 2914 -- so, we merely undelay it. 2915 2916 S := Scope (Rec); 2917 while Present (S) loop 2918 if Is_Subprogram (S) then 2919 Will_Be_Frozen := True; 2920 exit; 2921 elsif S = Scope (Base_Type (Comp)) then 2922 exit; 2923 end if; 2924 2925 S := Scope (S); 2926 end loop; 2927 2928 if Will_Be_Frozen then 2929 Undelay_Type (Comp); 2930 else 2931 if Present (Prev) then 2932 Set_Next_Entity (Prev, Next_Entity (Comp)); 2933 else 2934 Set_First_Entity (Rec, Next_Entity (Comp)); 2935 end if; 2936 2937 -- Insert in entity list of scope of base type (which 2938 -- must be an enclosing scope, because still unfrozen). 2939 2940 Append_Entity (Comp, Scope (Base_Type (Comp))); 2941 end if; 2942 end; 2943 2944 -- If the component is an access type with an allocator as default 2945 -- value, the designated type will be frozen by the corresponding 2946 -- expression in init_proc. In order to place the freeze node for 2947 -- the designated type before that for the current record type, 2948 -- freeze it now. 2949 2950 -- Same process if the component is an array of access types, 2951 -- initialized with an aggregate. If the designated type is 2952 -- private, it cannot contain allocators, and it is premature 2953 -- to freeze the type, so we check for this as well. 2954 2955 elsif Is_Access_Type (Etype (Comp)) 2956 and then Present (Parent (Comp)) 2957 and then Present (Expression (Parent (Comp))) 2958 then 2959 declare 2960 Alloc : constant Node_Id := 2961 Check_Allocator (Expression (Parent (Comp))); 2962 2963 begin 2964 if Present (Alloc) then 2965 2966 -- If component is pointer to a class-wide type, freeze 2967 -- the specific type in the expression being allocated. 2968 -- The expression may be a subtype indication, in which 2969 -- case freeze the subtype mark. 2970 2971 if Is_Class_Wide_Type 2972 (Designated_Type (Etype (Comp))) 2973 then 2974 if Is_Entity_Name (Expression (Alloc)) then 2975 Freeze_And_Append 2976 (Entity (Expression (Alloc)), N, Result); 2977 elsif 2978 Nkind (Expression (Alloc)) = N_Subtype_Indication 2979 then 2980 Freeze_And_Append 2981 (Entity (Subtype_Mark (Expression (Alloc))), 2982 N, Result); 2983 end if; 2984 2985 elsif Is_Itype (Designated_Type (Etype (Comp))) then 2986 Check_Itype (Etype (Comp)); 2987 2988 else 2989 Freeze_And_Append 2990 (Designated_Type (Etype (Comp)), N, Result); 2991 end if; 2992 end if; 2993 end; 2994 2995 elsif Is_Access_Type (Etype (Comp)) 2996 and then Is_Itype (Designated_Type (Etype (Comp))) 2997 then 2998 Check_Itype (Etype (Comp)); 2999 3000 elsif Is_Array_Type (Etype (Comp)) 3001 and then Is_Access_Type (Component_Type (Etype (Comp))) 3002 and then Present (Parent (Comp)) 3003 and then Nkind (Parent (Comp)) = N_Component_Declaration 3004 and then Present (Expression (Parent (Comp))) 3005 and then Nkind (Expression (Parent (Comp))) = N_Aggregate 3006 and then Is_Fully_Defined 3007 (Designated_Type (Component_Type (Etype (Comp)))) 3008 then 3009 Freeze_And_Append 3010 (Designated_Type 3011 (Component_Type (Etype (Comp))), N, Result); 3012 end if; 3013 3014 Prev := Comp; 3015 Next_Entity (Comp); 3016 end loop; 3017 3018 ADC := Get_Attribute_Definition_Clause 3019 (Rec, Attribute_Scalar_Storage_Order); 3020 3021 if Present (ADC) then 3022 3023 -- Check compatibility of Scalar_Storage_Order with Bit_Order, if 3024 -- the former is specified. 3025 3026 if Reverse_Bit_Order (Rec) /= Reverse_Storage_Order (Rec) then 3027 3028 -- Note: report error on Rec, not on ADC, as ADC may apply to 3029 -- an ancestor type. 3030 3031 Error_Msg_Sloc := Sloc (ADC); 3032 Error_Msg_N 3033 ("scalar storage order for& specified# inconsistent with " 3034 & "bit order", Rec); 3035 end if; 3036 3037 -- Warn if there is a Scalar_Storage_Order but no component clause 3038 -- (or pragma Pack). 3039 3040 if not (Placed_Component or else Is_Packed (Rec)) then 3041 Error_Msg_N 3042 ("??scalar storage order specified but no component clause", 3043 ADC); 3044 end if; 3045 end if; 3046 3047 -- Check consistent attribute setting on component types 3048 3049 Comp := First_Component (Rec); 3050 while Present (Comp) loop 3051 Check_Component_Storage_Order 3052 (Encl_Type => Rec, Comp => Comp, ADC => ADC); 3053 Next_Component (Comp); 3054 end loop; 3055 3056 -- Deal with Bit_Order aspect specifying a non-default bit order 3057 3058 ADC := Get_Attribute_Definition_Clause (Rec, Attribute_Bit_Order); 3059 3060 if Present (ADC) and then Base_Type (Rec) = Rec then 3061 if not (Placed_Component or else Is_Packed (Rec)) then 3062 Error_Msg_N 3063 ("??bit order specification has no effect", ADC); 3064 Error_Msg_N 3065 ("\??since no component clauses were specified", ADC); 3066 3067 -- Here is where we do the processing for reversed bit order 3068 3069 elsif Reverse_Bit_Order (Rec) 3070 and then not Reverse_Storage_Order (Rec) 3071 then 3072 Adjust_Record_For_Reverse_Bit_Order (Rec); 3073 3074 -- Case where we have both an explicit Bit_Order and the same 3075 -- Scalar_Storage_Order: leave record untouched, the back-end 3076 -- will take care of required layout conversions. 3077 3078 else 3079 null; 3080 3081 end if; 3082 end if; 3083 3084 -- Complete error checking on record representation clause (e.g. 3085 -- overlap of components). This is called after adjusting the 3086 -- record for reverse bit order. 3087 3088 declare 3089 RRC : constant Node_Id := Get_Record_Representation_Clause (Rec); 3090 begin 3091 if Present (RRC) then 3092 Check_Record_Representation_Clause (RRC); 3093 end if; 3094 end; 3095 3096 -- Set OK_To_Reorder_Components depending on debug flags 3097 3098 if Is_Base_Type (Rec) and then Convention (Rec) = Convention_Ada then 3099 if (Has_Discriminants (Rec) and then Debug_Flag_Dot_V) 3100 or else 3101 (not Has_Discriminants (Rec) and then Debug_Flag_Dot_R) 3102 then 3103 Set_OK_To_Reorder_Components (Rec); 3104 end if; 3105 end if; 3106 3107 -- Check for useless pragma Pack when all components placed. We only 3108 -- do this check for record types, not subtypes, since a subtype may 3109 -- have all its components placed, and it still makes perfectly good 3110 -- sense to pack other subtypes or the parent type. We do not give 3111 -- this warning if Optimize_Alignment is set to Space, since the 3112 -- pragma Pack does have an effect in this case (it always resets 3113 -- the alignment to one). 3114 3115 if Ekind (Rec) = E_Record_Type 3116 and then Is_Packed (Rec) 3117 and then not Unplaced_Component 3118 and then Optimize_Alignment /= 'S' 3119 then 3120 -- Reset packed status. Probably not necessary, but we do it so 3121 -- that there is no chance of the back end doing something strange 3122 -- with this redundant indication of packing. 3123 3124 Set_Is_Packed (Rec, False); 3125 3126 -- Give warning if redundant constructs warnings on 3127 3128 if Warn_On_Redundant_Constructs then 3129 Error_Msg_N -- CODEFIX 3130 ("??pragma Pack has no effect, no unplaced components", 3131 Get_Rep_Pragma (Rec, Name_Pack)); 3132 end if; 3133 end if; 3134 3135 -- If this is the record corresponding to a remote type, freeze the 3136 -- remote type here since that is what we are semantically freezing. 3137 -- This prevents the freeze node for that type in an inner scope. 3138 3139 if Ekind (Rec) = E_Record_Type then 3140 if Present (Corresponding_Remote_Type (Rec)) then 3141 Freeze_And_Append (Corresponding_Remote_Type (Rec), N, Result); 3142 end if; 3143 3144 -- Check for controlled components and unchecked unions. 3145 3146 Comp := First_Component (Rec); 3147 while Present (Comp) loop 3148 3149 -- Do not set Has_Controlled_Component on a class-wide 3150 -- equivalent type. See Make_CW_Equivalent_Type. 3151 3152 if not Is_Class_Wide_Equivalent_Type (Rec) 3153 and then 3154 (Has_Controlled_Component (Etype (Comp)) 3155 or else 3156 (Chars (Comp) /= Name_uParent 3157 and then Is_Controlled (Etype (Comp))) 3158 or else 3159 (Is_Protected_Type (Etype (Comp)) 3160 and then 3161 Present (Corresponding_Record_Type (Etype (Comp))) 3162 and then 3163 Has_Controlled_Component 3164 (Corresponding_Record_Type (Etype (Comp))))) 3165 then 3166 Set_Has_Controlled_Component (Rec); 3167 end if; 3168 3169 if Has_Unchecked_Union (Etype (Comp)) then 3170 Set_Has_Unchecked_Union (Rec); 3171 end if; 3172 3173 -- Scan component declaration for likely misuses of current 3174 -- instance, either in a constraint or a default expression. 3175 3176 if Has_Per_Object_Constraint (Comp) then 3177 Check_Current_Instance (Parent (Comp)); 3178 end if; 3179 3180 Next_Component (Comp); 3181 end loop; 3182 end if; 3183 3184 -- Enforce the restriction that access attributes with a current 3185 -- instance prefix can only apply to limited types. This comment 3186 -- is floating here, but does not seem to belong here??? 3187 3188 -- Set component alignment if not otherwise already set 3189 3190 Set_Component_Alignment_If_Not_Set (Rec); 3191 3192 -- For first subtypes, check if there are any fixed-point fields with 3193 -- component clauses, where we must check the size. This is not done 3194 -- till the freeze point since for fixed-point types, we do not know 3195 -- the size until the type is frozen. Similar processing applies to 3196 -- bit packed arrays. 3197 3198 if Is_First_Subtype (Rec) then 3199 Comp := First_Component (Rec); 3200 while Present (Comp) loop 3201 if Present (Component_Clause (Comp)) 3202 and then (Is_Fixed_Point_Type (Etype (Comp)) 3203 or else 3204 Is_Bit_Packed_Array (Etype (Comp))) 3205 then 3206 Check_Size 3207 (Component_Name (Component_Clause (Comp)), 3208 Etype (Comp), 3209 Esize (Comp), 3210 Junk); 3211 end if; 3212 3213 Next_Component (Comp); 3214 end loop; 3215 end if; 3216 3217 -- Generate warning for applying C or C++ convention to a record 3218 -- with discriminants. This is suppressed for the unchecked union 3219 -- case, since the whole point in this case is interface C. We also 3220 -- do not generate this within instantiations, since we will have 3221 -- generated a message on the template. 3222 3223 if Has_Discriminants (E) 3224 and then not Is_Unchecked_Union (E) 3225 and then (Convention (E) = Convention_C 3226 or else 3227 Convention (E) = Convention_CPP) 3228 and then Comes_From_Source (E) 3229 and then not In_Instance 3230 and then not Has_Warnings_Off (E) 3231 and then not Has_Warnings_Off (Base_Type (E)) 3232 then 3233 declare 3234 Cprag : constant Node_Id := Get_Rep_Pragma (E, Name_Convention); 3235 A2 : Node_Id; 3236 3237 begin 3238 if Present (Cprag) then 3239 A2 := Next (First (Pragma_Argument_Associations (Cprag))); 3240 3241 if Convention (E) = Convention_C then 3242 Error_Msg_N 3243 ("?x?variant record has no direct equivalent in C", 3244 A2); 3245 else 3246 Error_Msg_N 3247 ("?x?variant record has no direct equivalent in C++", 3248 A2); 3249 end if; 3250 3251 Error_Msg_NE 3252 ("\?x?use of convention for type& is dubious", A2, E); 3253 end if; 3254 end; 3255 end if; 3256 3257 -- See if Size is too small as is (and implicit packing might help) 3258 3259 if not Is_Packed (Rec) 3260 3261 -- No implicit packing if even one component is explicitly placed 3262 3263 and then not Placed_Component 3264 3265 -- Or even one component is aliased 3266 3267 and then not Aliased_Component 3268 3269 -- Must have size clause and all scalar components 3270 3271 and then Has_Size_Clause (Rec) 3272 and then All_Scalar_Components 3273 3274 -- Do not try implicit packing on records with discriminants, too 3275 -- complicated, especially in the variant record case. 3276 3277 and then not Has_Discriminants (Rec) 3278 3279 -- We can implicitly pack if the specified size of the record is 3280 -- less than the sum of the object sizes (no point in packing if 3281 -- this is not the case). 3282 3283 and then RM_Size (Rec) < Scalar_Component_Total_Esize 3284 3285 -- And the total RM size cannot be greater than the specified size 3286 -- since otherwise packing will not get us where we have to be. 3287 3288 and then RM_Size (Rec) >= Scalar_Component_Total_RM_Size 3289 3290 -- Never do implicit packing in CodePeer or SPARK modes since 3291 -- we don't do any packing in these modes, since this generates 3292 -- over-complex code that confuses static analysis, and in 3293 -- general, neither CodePeer not GNATprove care about the 3294 -- internal representation of objects. 3295 3296 and then not (CodePeer_Mode or GNATprove_Mode) 3297 then 3298 -- If implicit packing enabled, do it 3299 3300 if Implicit_Packing then 3301 Set_Is_Packed (Rec); 3302 3303 -- Otherwise flag the size clause 3304 3305 else 3306 declare 3307 Sz : constant Node_Id := Size_Clause (Rec); 3308 begin 3309 Error_Msg_NE -- CODEFIX 3310 ("size given for& too small", Sz, Rec); 3311 Error_Msg_N -- CODEFIX 3312 ("\use explicit pragma Pack " 3313 & "or use pragma Implicit_Packing", Sz); 3314 end; 3315 end if; 3316 end if; 3317 3318 -- All done if not a full record definition 3319 3320 if Ekind (Rec) /= E_Record_Type then 3321 return; 3322 end if; 3323 3324 -- Finally we need to check the variant part to make sure that 3325 -- all types within choices are properly frozen as part of the 3326 -- freezing of the record type. 3327 3328 Check_Variant_Part : declare 3329 D : constant Node_Id := Declaration_Node (Rec); 3330 T : Node_Id; 3331 C : Node_Id; 3332 3333 begin 3334 -- Find component list 3335 3336 C := Empty; 3337 3338 if Nkind (D) = N_Full_Type_Declaration then 3339 T := Type_Definition (D); 3340 3341 if Nkind (T) = N_Record_Definition then 3342 C := Component_List (T); 3343 3344 elsif Nkind (T) = N_Derived_Type_Definition 3345 and then Present (Record_Extension_Part (T)) 3346 then 3347 C := Component_List (Record_Extension_Part (T)); 3348 end if; 3349 end if; 3350 3351 -- Case of variant part present 3352 3353 if Present (C) and then Present (Variant_Part (C)) then 3354 Freeze_Choices_In_Variant_Part (Variant_Part (C)); 3355 end if; 3356 3357 -- Note: we used to call Check_Choices here, but it is too early, 3358 -- since predicated subtypes are frozen here, but their freezing 3359 -- actions are in Analyze_Freeze_Entity, which has not been called 3360 -- yet for entities frozen within this procedure, so we moved that 3361 -- call to the Analyze_Freeze_Entity for the record type. 3362 3363 end Check_Variant_Part; 3364 end Freeze_Record_Type; 3365 3366 ------------------------------ 3367 -- Wrap_Imported_Subprogram -- 3368 ------------------------------ 3369 3370 -- The issue here is that our normal approach of checking preconditions 3371 -- and postconditions does not work for imported procedures, since we 3372 -- are not generating code for the body. To get around this we create 3373 -- a wrapper, as shown by the following example: 3374 3375 -- procedure K (A : Integer); 3376 -- pragma Import (C, K); 3377 3378 -- The spec is rewritten by removing the effects of pragma Import, but 3379 -- leaving the convention unchanged, as though the source had said: 3380 3381 -- procedure K (A : Integer); 3382 -- pragma Convention (C, K); 3383 3384 -- and we create a body, added to the entity K freeze actions, which 3385 -- looks like: 3386 3387 -- procedure K (A : Integer) is 3388 -- procedure K (A : Integer); 3389 -- pragma Import (C, K); 3390 -- begin 3391 -- K (A); 3392 -- end K; 3393 3394 -- Now the contract applies in the normal way to the outer procedure, 3395 -- and the inner procedure has no contracts, so there is no problem 3396 -- in just calling it to get the original effect. 3397 3398 -- In the case of a function, we create an appropriate return statement 3399 -- for the subprogram body that calls the inner procedure. 3400 3401 procedure Wrap_Imported_Subprogram (E : Entity_Id) is 3402 Loc : constant Source_Ptr := Sloc (E); 3403 CE : constant Name_Id := Chars (E); 3404 Spec : Node_Id; 3405 Parms : List_Id; 3406 Stmt : Node_Id; 3407 Iprag : Node_Id; 3408 Bod : Node_Id; 3409 Forml : Entity_Id; 3410 3411 begin 3412 -- Nothing to do if not imported 3413 3414 if not Is_Imported (E) then 3415 return; 3416 3417 -- Test enabling conditions for wrapping 3418 3419 elsif Is_Subprogram (E) 3420 and then Present (Contract (E)) 3421 and then Present (Pre_Post_Conditions (Contract (E))) 3422 and then not GNATprove_Mode 3423 then 3424 -- Here we do the wrap 3425 3426 -- Note on calls to Copy_Separate_Tree. The trees we are copying 3427 -- here are fully analyzed, but we definitely want fully syntactic 3428 -- unanalyzed trees in the body we construct, so that the analysis 3429 -- generates the right visibility, and that is exactly what the 3430 -- calls to Copy_Separate_Tree give us. 3431 3432 -- Acquire copy of Inline pragma 3433 3434 Iprag := 3435 Copy_Separate_Tree (Import_Pragma (E)); 3436 3437 -- Fix up spec to be not imported any more 3438 3439 Set_Is_Imported (E, False); 3440 Set_Interface_Name (E, Empty); 3441 Set_Has_Completion (E, False); 3442 Set_Import_Pragma (E, Empty); 3443 3444 -- Grab the subprogram declaration and specification 3445 3446 Spec := Declaration_Node (E); 3447 3448 -- Build parameter list that we need 3449 3450 Parms := New_List; 3451 Forml := First_Formal (E); 3452 while Present (Forml) loop 3453 Append_To (Parms, Make_Identifier (Loc, Chars (Forml))); 3454 Next_Formal (Forml); 3455 end loop; 3456 3457 -- Build the call 3458 3459 if Ekind_In (E, E_Function, E_Generic_Function) then 3460 Stmt := 3461 Make_Simple_Return_Statement (Loc, 3462 Expression => 3463 Make_Function_Call (Loc, 3464 Name => Make_Identifier (Loc, CE), 3465 Parameter_Associations => Parms)); 3466 3467 else 3468 Stmt := 3469 Make_Procedure_Call_Statement (Loc, 3470 Name => Make_Identifier (Loc, CE), 3471 Parameter_Associations => Parms); 3472 end if; 3473 3474 -- Now build the body 3475 3476 Bod := 3477 Make_Subprogram_Body (Loc, 3478 Specification => 3479 Copy_Separate_Tree (Spec), 3480 Declarations => New_List ( 3481 Make_Subprogram_Declaration (Loc, 3482 Specification => 3483 Copy_Separate_Tree (Spec)), 3484 Iprag), 3485 Handled_Statement_Sequence => 3486 Make_Handled_Sequence_Of_Statements (Loc, 3487 Statements => New_List (Stmt), 3488 End_Label => Make_Identifier (Loc, CE))); 3489 3490 -- Append the body to freeze result 3491 3492 Add_To_Result (Bod); 3493 return; 3494 3495 -- Case of imported subprogram that does not get wrapped 3496 3497 else 3498 -- Set Is_Public. All imported entities need an external symbol 3499 -- created for them since they are always referenced from another 3500 -- object file. Note this used to be set when we set Is_Imported 3501 -- back in Sem_Prag, but now we delay it to this point, since we 3502 -- don't want to set this flag if we wrap an imported subprogram. 3503 3504 Set_Is_Public (E); 3505 end if; 3506 end Wrap_Imported_Subprogram; 3507 3508 -- Start of processing for Freeze_Entity 3509 3510 begin 3511 -- We are going to test for various reasons why this entity need not be 3512 -- frozen here, but in the case of an Itype that's defined within a 3513 -- record, that test actually applies to the record. 3514 3515 if Is_Itype (E) and then Is_Record_Type (Scope (E)) then 3516 Test_E := Scope (E); 3517 elsif Is_Itype (E) and then Present (Underlying_Type (Scope (E))) 3518 and then Is_Record_Type (Underlying_Type (Scope (E))) 3519 then 3520 Test_E := Underlying_Type (Scope (E)); 3521 end if; 3522 3523 -- Do not freeze if already frozen since we only need one freeze node 3524 3525 if Is_Frozen (E) then 3526 return No_List; 3527 3528 -- It is improper to freeze an external entity within a generic because 3529 -- its freeze node will appear in a non-valid context. The entity will 3530 -- be frozen in the proper scope after the current generic is analyzed. 3531 -- However, aspects must be analyzed because they may be queried later 3532 -- within the generic itself, and the corresponding pragma or attribute 3533 -- definition has not been analyzed yet. 3534 3535 elsif Inside_A_Generic and then External_Ref_In_Generic (Test_E) then 3536 if Has_Delayed_Aspects (E) then 3537 Analyze_Aspects_At_Freeze_Point (E); 3538 end if; 3539 3540 return No_List; 3541 3542 -- AI05-0213: A formal incomplete type does not freeze the actual. In 3543 -- the instance, the same applies to the subtype renaming the actual. 3544 3545 elsif Is_Private_Type (E) 3546 and then Is_Generic_Actual_Type (E) 3547 and then No (Full_View (Base_Type (E))) 3548 and then Ada_Version >= Ada_2012 3549 then 3550 return No_List; 3551 3552 -- Generic types need no freeze node and have no delayed semantic 3553 -- checks. 3554 3555 elsif Is_Generic_Type (E) then 3556 return No_List; 3557 3558 -- Do not freeze a global entity within an inner scope created during 3559 -- expansion. A call to subprogram E within some internal procedure 3560 -- (a stream attribute for example) might require freezing E, but the 3561 -- freeze node must appear in the same declarative part as E itself. 3562 -- The two-pass elaboration mechanism in gigi guarantees that E will 3563 -- be frozen before the inner call is elaborated. We exclude constants 3564 -- from this test, because deferred constants may be frozen early, and 3565 -- must be diagnosed (e.g. in the case of a deferred constant being used 3566 -- in a default expression). If the enclosing subprogram comes from 3567 -- source, or is a generic instance, then the freeze point is the one 3568 -- mandated by the language, and we freeze the entity. A subprogram that 3569 -- is a child unit body that acts as a spec does not have a spec that 3570 -- comes from source, but can only come from source. 3571 3572 elsif In_Open_Scopes (Scope (Test_E)) 3573 and then Scope (Test_E) /= Current_Scope 3574 and then Ekind (Test_E) /= E_Constant 3575 then 3576 declare 3577 S : Entity_Id; 3578 3579 begin 3580 S := Current_Scope; 3581 while Present (S) loop 3582 if Is_Overloadable (S) then 3583 if Comes_From_Source (S) 3584 or else Is_Generic_Instance (S) 3585 or else Is_Child_Unit (S) 3586 then 3587 exit; 3588 else 3589 return No_List; 3590 end if; 3591 end if; 3592 3593 S := Scope (S); 3594 end loop; 3595 end; 3596 3597 -- Similarly, an inlined instance body may make reference to global 3598 -- entities, but these references cannot be the proper freezing point 3599 -- for them, and in the absence of inlining freezing will take place in 3600 -- their own scope. Normally instance bodies are analyzed after the 3601 -- enclosing compilation, and everything has been frozen at the proper 3602 -- place, but with front-end inlining an instance body is compiled 3603 -- before the end of the enclosing scope, and as a result out-of-order 3604 -- freezing must be prevented. 3605 3606 elsif Front_End_Inlining 3607 and then In_Instance_Body 3608 and then Present (Scope (Test_E)) 3609 then 3610 declare 3611 S : Entity_Id; 3612 3613 begin 3614 S := Scope (Test_E); 3615 while Present (S) loop 3616 if Is_Generic_Instance (S) then 3617 exit; 3618 else 3619 S := Scope (S); 3620 end if; 3621 end loop; 3622 3623 if No (S) then 3624 return No_List; 3625 end if; 3626 end; 3627 3628 elsif Ekind (E) = E_Generic_Package then 3629 return Freeze_Generic_Entities (E); 3630 end if; 3631 3632 -- Add checks to detect proper initialization of scalars that may appear 3633 -- as subprogram parameters. 3634 3635 if Is_Subprogram (E) and then Check_Validity_Of_Parameters then 3636 Apply_Parameter_Validity_Checks (E); 3637 end if; 3638 3639 -- Deal with delayed aspect specifications. The analysis of the aspect 3640 -- is required to be delayed to the freeze point, thus we analyze the 3641 -- pragma or attribute definition clause in the tree at this point. We 3642 -- also analyze the aspect specification node at the freeze point when 3643 -- the aspect doesn't correspond to pragma/attribute definition clause. 3644 3645 if Has_Delayed_Aspects (E) then 3646 Analyze_Aspects_At_Freeze_Point (E); 3647 end if; 3648 3649 -- Here to freeze the entity 3650 3651 Set_Is_Frozen (E); 3652 3653 -- Case of entity being frozen is other than a type 3654 3655 if not Is_Type (E) then 3656 3657 -- If entity is exported or imported and does not have an external 3658 -- name, now is the time to provide the appropriate default name. 3659 -- Skip this if the entity is stubbed, since we don't need a name 3660 -- for any stubbed routine. For the case on intrinsics, if no 3661 -- external name is specified, then calls will be handled in 3662 -- Exp_Intr.Expand_Intrinsic_Call, and no name is needed. If an 3663 -- external name is provided, then Expand_Intrinsic_Call leaves 3664 -- calls in place for expansion by GIGI. 3665 3666 if (Is_Imported (E) or else Is_Exported (E)) 3667 and then No (Interface_Name (E)) 3668 and then Convention (E) /= Convention_Stubbed 3669 and then Convention (E) /= Convention_Intrinsic 3670 then 3671 Set_Encoded_Interface_Name 3672 (E, Get_Default_External_Name (E)); 3673 3674 -- If entity is an atomic object appearing in a declaration and 3675 -- the expression is an aggregate, assign it to a temporary to 3676 -- ensure that the actual assignment is done atomically rather 3677 -- than component-wise (the assignment to the temp may be done 3678 -- component-wise, but that is harmless). 3679 3680 elsif Is_Atomic (E) 3681 and then Nkind (Parent (E)) = N_Object_Declaration 3682 and then Present (Expression (Parent (E))) 3683 and then Nkind (Expression (Parent (E))) = N_Aggregate 3684 and then Is_Atomic_Aggregate (Expression (Parent (E)), Etype (E)) 3685 then 3686 null; 3687 end if; 3688 3689 -- Subprogram case 3690 3691 if Is_Subprogram (E) then 3692 3693 -- Check for needing to wrap imported subprogram 3694 3695 Wrap_Imported_Subprogram (E); 3696 3697 -- Freeze all parameter types and the return type (RM 13.14(14)). 3698 -- However skip this for internal subprograms. This is also where 3699 -- any extra formal parameters are created since we now know 3700 -- whether the subprogram will use a foreign convention. 3701 3702 if not Is_Internal (E) then 3703 declare 3704 F_Type : Entity_Id; 3705 R_Type : Entity_Id; 3706 Warn_Node : Node_Id; 3707 3708 begin 3709 -- Loop through formals 3710 3711 Formal := First_Formal (E); 3712 while Present (Formal) loop 3713 F_Type := Etype (Formal); 3714 3715 -- AI05-0151 : incomplete types can appear in a profile. 3716 -- By the time the entity is frozen, the full view must 3717 -- be available, unless it is a limited view. 3718 3719 if Is_Incomplete_Type (F_Type) 3720 and then Present (Full_View (F_Type)) 3721 and then not From_Limited_With (F_Type) 3722 then 3723 F_Type := Full_View (F_Type); 3724 Set_Etype (Formal, F_Type); 3725 end if; 3726 3727 Freeze_And_Append (F_Type, N, Result); 3728 3729 if Is_Private_Type (F_Type) 3730 and then Is_Private_Type (Base_Type (F_Type)) 3731 and then No (Full_View (Base_Type (F_Type))) 3732 and then not Is_Generic_Type (F_Type) 3733 and then not Is_Derived_Type (F_Type) 3734 then 3735 -- If the type of a formal is incomplete, subprogram 3736 -- is being frozen prematurely. Within an instance 3737 -- (but not within a wrapper package) this is an 3738 -- artifact of our need to regard the end of an 3739 -- instantiation as a freeze point. Otherwise it is 3740 -- a definite error. 3741 3742 if In_Instance then 3743 Set_Is_Frozen (E, False); 3744 return No_List; 3745 3746 elsif not After_Last_Declaration 3747 and then not Freezing_Library_Level_Tagged_Type 3748 then 3749 Error_Msg_Node_1 := F_Type; 3750 Error_Msg 3751 ("type& must be fully defined before this point", 3752 Loc); 3753 end if; 3754 end if; 3755 3756 -- Check suspicious parameter for C function. These tests 3757 -- apply only to exported/imported subprograms. 3758 3759 if Warn_On_Export_Import 3760 and then Comes_From_Source (E) 3761 and then (Convention (E) = Convention_C 3762 or else 3763 Convention (E) = Convention_CPP) 3764 and then (Is_Imported (E) or else Is_Exported (E)) 3765 and then Convention (E) /= Convention (Formal) 3766 and then not Has_Warnings_Off (E) 3767 and then not Has_Warnings_Off (F_Type) 3768 and then not Has_Warnings_Off (Formal) 3769 then 3770 -- Qualify mention of formals with subprogram name 3771 3772 Error_Msg_Qual_Level := 1; 3773 3774 -- Check suspicious use of fat C pointer 3775 3776 if Is_Access_Type (F_Type) 3777 and then Esize (F_Type) > Ttypes.System_Address_Size 3778 then 3779 Error_Msg_N 3780 ("?x?type of & does not correspond to C pointer!", 3781 Formal); 3782 3783 -- Check suspicious return of boolean 3784 3785 elsif Root_Type (F_Type) = Standard_Boolean 3786 and then Convention (F_Type) = Convention_Ada 3787 and then not Has_Warnings_Off (F_Type) 3788 and then not Has_Size_Clause (F_Type) 3789 and then VM_Target = No_VM 3790 then 3791 Error_Msg_N 3792 ("& is an 8-bit Ada Boolean?x?", Formal); 3793 Error_Msg_N 3794 ("\use appropriate corresponding type in C " 3795 & "(e.g. char)?x?", Formal); 3796 3797 -- Check suspicious tagged type 3798 3799 elsif (Is_Tagged_Type (F_Type) 3800 or else (Is_Access_Type (F_Type) 3801 and then 3802 Is_Tagged_Type 3803 (Designated_Type (F_Type)))) 3804 and then Convention (E) = Convention_C 3805 then 3806 Error_Msg_N 3807 ("?x?& involves a tagged type which does not " 3808 & "correspond to any C type!", Formal); 3809 3810 -- Check wrong convention subprogram pointer 3811 3812 elsif Ekind (F_Type) = E_Access_Subprogram_Type 3813 and then not Has_Foreign_Convention (F_Type) 3814 then 3815 Error_Msg_N 3816 ("?x?subprogram pointer & should " 3817 & "have foreign convention!", Formal); 3818 Error_Msg_Sloc := Sloc (F_Type); 3819 Error_Msg_NE 3820 ("\?x?add Convention pragma to declaration of &#", 3821 Formal, F_Type); 3822 end if; 3823 3824 -- Turn off name qualification after message output 3825 3826 Error_Msg_Qual_Level := 0; 3827 end if; 3828 3829 -- Check for unconstrained array in exported foreign 3830 -- convention case. 3831 3832 if Has_Foreign_Convention (E) 3833 and then not Is_Imported (E) 3834 and then Is_Array_Type (F_Type) 3835 and then not Is_Constrained (F_Type) 3836 and then Warn_On_Export_Import 3837 3838 -- Exclude VM case, since both .NET and JVM can handle 3839 -- unconstrained arrays without a problem. 3840 3841 and then VM_Target = No_VM 3842 then 3843 Error_Msg_Qual_Level := 1; 3844 3845 -- If this is an inherited operation, place the 3846 -- warning on the derived type declaration, rather 3847 -- than on the original subprogram. 3848 3849 if Nkind (Original_Node (Parent (E))) = 3850 N_Full_Type_Declaration 3851 then 3852 Warn_Node := Parent (E); 3853 3854 if Formal = First_Formal (E) then 3855 Error_Msg_NE 3856 ("??in inherited operation&", Warn_Node, E); 3857 end if; 3858 else 3859 Warn_Node := Formal; 3860 end if; 3861 3862 Error_Msg_NE 3863 ("?x?type of argument& is unconstrained array", 3864 Warn_Node, Formal); 3865 Error_Msg_NE 3866 ("?x?foreign caller must pass bounds explicitly", 3867 Warn_Node, Formal); 3868 Error_Msg_Qual_Level := 0; 3869 end if; 3870 3871 if not From_Limited_With (F_Type) then 3872 if Is_Access_Type (F_Type) then 3873 F_Type := Designated_Type (F_Type); 3874 end if; 3875 3876 -- If the formal is an anonymous_access_to_subprogram 3877 -- freeze the subprogram type as well, to prevent 3878 -- scope anomalies in gigi, because there is no other 3879 -- clear point at which it could be frozen. 3880 3881 if Is_Itype (Etype (Formal)) 3882 and then Ekind (F_Type) = E_Subprogram_Type 3883 then 3884 Freeze_And_Append (F_Type, N, Result); 3885 end if; 3886 end if; 3887 3888 Next_Formal (Formal); 3889 end loop; 3890 3891 -- Case of function: similar checks on return type 3892 3893 if Ekind (E) = E_Function then 3894 3895 -- Freeze return type 3896 3897 R_Type := Etype (E); 3898 3899 -- AI05-0151: the return type may have been incomplete 3900 -- at the point of declaration. Replace it with the full 3901 -- view, unless the current type is a limited view. In 3902 -- that case the full view is in a different unit, and 3903 -- gigi finds the non-limited view after the other unit 3904 -- is elaborated. 3905 3906 if Ekind (R_Type) = E_Incomplete_Type 3907 and then Present (Full_View (R_Type)) 3908 and then not From_Limited_With (R_Type) 3909 then 3910 R_Type := Full_View (R_Type); 3911 Set_Etype (E, R_Type); 3912 3913 -- If the return type is a limited view and the non- 3914 -- limited view is still incomplete, the function has 3915 -- to be frozen at a later time. 3916 3917 elsif Ekind (R_Type) = E_Incomplete_Type 3918 and then From_Limited_With (R_Type) 3919 and then 3920 Ekind (Non_Limited_View (R_Type)) = E_Incomplete_Type 3921 then 3922 Set_Is_Frozen (E, False); 3923 return Result; 3924 end if; 3925 3926 Freeze_And_Append (R_Type, N, Result); 3927 3928 -- Check suspicious return type for C function 3929 3930 if Warn_On_Export_Import 3931 and then (Convention (E) = Convention_C 3932 or else 3933 Convention (E) = Convention_CPP) 3934 and then (Is_Imported (E) or else Is_Exported (E)) 3935 then 3936 -- Check suspicious return of fat C pointer 3937 3938 if Is_Access_Type (R_Type) 3939 and then Esize (R_Type) > Ttypes.System_Address_Size 3940 and then not Has_Warnings_Off (E) 3941 and then not Has_Warnings_Off (R_Type) 3942 then 3943 Error_Msg_N 3944 ("?x?return type of& does not " 3945 & "correspond to C pointer!", E); 3946 3947 -- Check suspicious return of boolean 3948 3949 elsif Root_Type (R_Type) = Standard_Boolean 3950 and then Convention (R_Type) = Convention_Ada 3951 and then VM_Target = No_VM 3952 and then not Has_Warnings_Off (E) 3953 and then not Has_Warnings_Off (R_Type) 3954 and then not Has_Size_Clause (R_Type) 3955 then 3956 declare 3957 N : constant Node_Id := 3958 Result_Definition (Declaration_Node (E)); 3959 begin 3960 Error_Msg_NE 3961 ("return type of & is an 8-bit Ada Boolean?x?", 3962 N, E); 3963 Error_Msg_NE 3964 ("\use appropriate corresponding type in C " 3965 & "(e.g. char)?x?", N, E); 3966 end; 3967 3968 -- Check suspicious return tagged type 3969 3970 elsif (Is_Tagged_Type (R_Type) 3971 or else (Is_Access_Type (R_Type) 3972 and then 3973 Is_Tagged_Type 3974 (Designated_Type (R_Type)))) 3975 and then Convention (E) = Convention_C 3976 and then not Has_Warnings_Off (E) 3977 and then not Has_Warnings_Off (R_Type) 3978 then 3979 Error_Msg_N 3980 ("?x?return type of & does not " 3981 & "correspond to C type!", E); 3982 3983 -- Check return of wrong convention subprogram pointer 3984 3985 elsif Ekind (R_Type) = E_Access_Subprogram_Type 3986 and then not Has_Foreign_Convention (R_Type) 3987 and then not Has_Warnings_Off (E) 3988 and then not Has_Warnings_Off (R_Type) 3989 then 3990 Error_Msg_N 3991 ("?x?& should return a foreign " 3992 & "convention subprogram pointer", E); 3993 Error_Msg_Sloc := Sloc (R_Type); 3994 Error_Msg_NE 3995 ("\?x?add Convention pragma to declaration of& #", 3996 E, R_Type); 3997 end if; 3998 end if; 3999 4000 -- Give warning for suspicious return of a result of an 4001 -- unconstrained array type in a foreign convention 4002 -- function. 4003 4004 if Has_Foreign_Convention (E) 4005 4006 -- We are looking for a return of unconstrained array 4007 4008 and then Is_Array_Type (R_Type) 4009 and then not Is_Constrained (R_Type) 4010 4011 -- Exclude imported routines, the warning does not 4012 -- belong on the import, but rather on the routine 4013 -- definition. 4014 4015 and then not Is_Imported (E) 4016 4017 -- Exclude VM case, since both .NET and JVM can handle 4018 -- return of unconstrained arrays without a problem. 4019 4020 and then VM_Target = No_VM 4021 4022 -- Check that general warning is enabled, and that it 4023 -- is not suppressed for this particular case. 4024 4025 and then Warn_On_Export_Import 4026 and then not Has_Warnings_Off (E) 4027 and then not Has_Warnings_Off (R_Type) 4028 then 4029 Error_Msg_N 4030 ("?x?foreign convention function& should not " & 4031 "return unconstrained array!", E); 4032 end if; 4033 end if; 4034 end; 4035 end if; 4036 4037 -- Must freeze its parent first if it is a derived subprogram 4038 4039 if Present (Alias (E)) then 4040 Freeze_And_Append (Alias (E), N, Result); 4041 end if; 4042 4043 -- We don't freeze internal subprograms, because we don't normally 4044 -- want addition of extra formals or mechanism setting to happen 4045 -- for those. However we do pass through predefined dispatching 4046 -- cases, since extra formals may be needed in some cases, such as 4047 -- for the stream 'Input function (build-in-place formals). 4048 4049 if not Is_Internal (E) 4050 or else Is_Predefined_Dispatching_Operation (E) 4051 then 4052 Freeze_Subprogram (E); 4053 end if; 4054 4055 -- Here for other than a subprogram or type 4056 4057 else 4058 -- If entity has a type, and it is not a generic unit, then 4059 -- freeze it first (RM 13.14(10)). 4060 4061 if Present (Etype (E)) 4062 and then Ekind (E) /= E_Generic_Function 4063 then 4064 Freeze_And_Append (Etype (E), N, Result); 4065 end if; 4066 4067 -- Special processing for objects created by object declaration 4068 4069 if Nkind (Declaration_Node (E)) = N_Object_Declaration then 4070 4071 -- Abstract type allowed only for C++ imported variables or 4072 -- constants. 4073 4074 -- Note: we inhibit this check for objects that do not come 4075 -- from source because there is at least one case (the 4076 -- expansion of x'Class'Input where x is abstract) where we 4077 -- legitimately generate an abstract object. 4078 4079 if Is_Abstract_Type (Etype (E)) 4080 and then Comes_From_Source (Parent (E)) 4081 and then not (Is_Imported (E) 4082 and then Is_CPP_Class (Etype (E))) 4083 then 4084 Error_Msg_N ("type of object cannot be abstract", 4085 Object_Definition (Parent (E))); 4086 4087 if Is_CPP_Class (Etype (E)) then 4088 Error_Msg_NE 4089 ("\} may need a cpp_constructor", 4090 Object_Definition (Parent (E)), Etype (E)); 4091 end if; 4092 end if; 4093 4094 -- For object created by object declaration, perform required 4095 -- categorization (preelaborate and pure) checks. Defer these 4096 -- checks to freeze time since pragma Import inhibits default 4097 -- initialization and thus pragma Import affects these checks. 4098 4099 Validate_Object_Declaration (Declaration_Node (E)); 4100 4101 -- If there is an address clause, check that it is valid 4102 4103 Check_Address_Clause (E); 4104 4105 -- Reset Is_True_Constant for aliased object. We consider that 4106 -- the fact that something is aliased may indicate that some 4107 -- funny business is going on, e.g. an aliased object is passed 4108 -- by reference to a procedure which captures the address of 4109 -- the object, which is later used to assign a new value. Such 4110 -- code is highly dubious, but we choose to make it "work" for 4111 -- aliased objects. 4112 4113 -- However, we don't do that for internal entities. We figure 4114 -- that if we deliberately set Is_True_Constant for an internal 4115 -- entity, e.g. a dispatch table entry, then we mean it. 4116 4117 if (Is_Aliased (E) or else Is_Aliased (Etype (E))) 4118 and then not Is_Internal_Name (Chars (E)) 4119 then 4120 Set_Is_True_Constant (E, False); 4121 end if; 4122 4123 -- If the object needs any kind of default initialization, an 4124 -- error must be issued if No_Default_Initialization applies. 4125 -- The check doesn't apply to imported objects, which are not 4126 -- ever default initialized, and is why the check is deferred 4127 -- until freezing, at which point we know if Import applies. 4128 -- Deferred constants are also exempted from this test because 4129 -- their completion is explicit, or through an import pragma. 4130 4131 if Ekind (E) = E_Constant 4132 and then Present (Full_View (E)) 4133 then 4134 null; 4135 4136 elsif Comes_From_Source (E) 4137 and then not Is_Imported (E) 4138 and then not Has_Init_Expression (Declaration_Node (E)) 4139 and then 4140 ((Has_Non_Null_Base_Init_Proc (Etype (E)) 4141 and then not No_Initialization (Declaration_Node (E)) 4142 and then not Is_Value_Type (Etype (E)) 4143 and then not Initialization_Suppressed (Etype (E))) 4144 or else 4145 (Needs_Simple_Initialization (Etype (E)) 4146 and then not Is_Internal (E))) 4147 then 4148 Has_Default_Initialization := True; 4149 Check_Restriction 4150 (No_Default_Initialization, Declaration_Node (E)); 4151 end if; 4152 4153 -- Check that a Thread_Local_Storage variable does not have 4154 -- default initialization, and any explicit initialization must 4155 -- either be the null constant or a static constant. 4156 4157 if Has_Pragma_Thread_Local_Storage (E) then 4158 declare 4159 Decl : constant Node_Id := Declaration_Node (E); 4160 begin 4161 if Has_Default_Initialization 4162 or else 4163 (Has_Init_Expression (Decl) 4164 and then 4165 (No (Expression (Decl)) 4166 or else not 4167 (Is_Static_Expression (Expression (Decl)) 4168 or else 4169 Nkind (Expression (Decl)) = N_Null))) 4170 then 4171 Error_Msg_NE 4172 ("Thread_Local_Storage variable& is " 4173 & "improperly initialized", Decl, E); 4174 Error_Msg_NE 4175 ("\only allowed initialization is explicit " 4176 & "NULL or static expression", Decl, E); 4177 end if; 4178 end; 4179 end if; 4180 4181 -- For imported objects, set Is_Public unless there is also an 4182 -- address clause, which means that there is no external symbol 4183 -- needed for the Import (Is_Public may still be set for other 4184 -- unrelated reasons). Note that we delayed this processing 4185 -- till freeze time so that we can be sure not to set the flag 4186 -- if there is an address clause. If there is such a clause, 4187 -- then the only purpose of the Import pragma is to suppress 4188 -- implicit initialization. 4189 4190 if Is_Imported (E) and then No (Address_Clause (E)) then 4191 Set_Is_Public (E); 4192 end if; 4193 4194 -- For source objects that are not Imported and are library 4195 -- level, if no linker section pragma was given inherit the 4196 -- appropriate linker section from the corresponding type. 4197 4198 if Comes_From_Source (E) 4199 and then not Is_Imported (E) 4200 and then Is_Library_Level_Entity (E) 4201 and then No (Linker_Section_Pragma (E)) 4202 then 4203 Set_Linker_Section_Pragma 4204 (E, Linker_Section_Pragma (Etype (E))); 4205 end if; 4206 4207 -- For convention C objects of an enumeration type, warn if 4208 -- the size is not integer size and no explicit size given. 4209 -- Skip warning for Boolean, and Character, assume programmer 4210 -- expects 8-bit sizes for these cases. 4211 4212 if (Convention (E) = Convention_C 4213 or else 4214 Convention (E) = Convention_CPP) 4215 and then Is_Enumeration_Type (Etype (E)) 4216 and then not Is_Character_Type (Etype (E)) 4217 and then not Is_Boolean_Type (Etype (E)) 4218 and then Esize (Etype (E)) < Standard_Integer_Size 4219 and then not Has_Size_Clause (E) 4220 then 4221 Error_Msg_Uint_1 := UI_From_Int (Standard_Integer_Size); 4222 Error_Msg_N 4223 ("??convention C enumeration object has size less than ^", 4224 E); 4225 Error_Msg_N ("\?use explicit size clause to set size", E); 4226 end if; 4227 end if; 4228 4229 -- Check that a constant which has a pragma Volatile[_Components] 4230 -- or Atomic[_Components] also has a pragma Import (RM C.6(13)). 4231 4232 -- Note: Atomic[_Components] also sets Volatile[_Components] 4233 4234 if Ekind (E) = E_Constant 4235 and then (Has_Volatile_Components (E) or else Is_Volatile (E)) 4236 and then not Is_Imported (E) 4237 then 4238 -- Make sure we actually have a pragma, and have not merely 4239 -- inherited the indication from elsewhere (e.g. an address 4240 -- clause, which is not good enough in RM terms). 4241 4242 if Has_Rep_Pragma (E, Name_Atomic) 4243 or else 4244 Has_Rep_Pragma (E, Name_Atomic_Components) 4245 then 4246 Error_Msg_N 4247 ("stand alone atomic constant must be " & 4248 "imported (RM C.6(13))", E); 4249 4250 elsif Has_Rep_Pragma (E, Name_Volatile) 4251 or else 4252 Has_Rep_Pragma (E, Name_Volatile_Components) 4253 then 4254 Error_Msg_N 4255 ("stand alone volatile constant must be " & 4256 "imported (RM C.6(13))", E); 4257 end if; 4258 end if; 4259 4260 -- Static objects require special handling 4261 4262 if (Ekind (E) = E_Constant or else Ekind (E) = E_Variable) 4263 and then Is_Statically_Allocated (E) 4264 then 4265 Freeze_Static_Object (E); 4266 end if; 4267 4268 -- Remaining step is to layout objects 4269 4270 if Ekind_In (E, E_Variable, E_Constant, E_Loop_Parameter) 4271 or else Is_Formal (E) 4272 then 4273 Layout_Object (E); 4274 end if; 4275 4276 -- If initialization statements were captured in an expression 4277 -- with actions with null expression, and the object does not 4278 -- have delayed freezing, move them back now directly within the 4279 -- enclosing statement sequence. 4280 4281 if Ekind_In (E, E_Constant, E_Variable) 4282 and then not Has_Delayed_Freeze (E) 4283 then 4284 declare 4285 Init_Stmts : constant Node_Id := 4286 Initialization_Statements (E); 4287 begin 4288 if Present (Init_Stmts) 4289 and then Nkind (Init_Stmts) = N_Expression_With_Actions 4290 and then Nkind (Expression (Init_Stmts)) = N_Null_Statement 4291 then 4292 Insert_List_Before (Init_Stmts, Actions (Init_Stmts)); 4293 4294 -- Note that we rewrite Init_Stmts into a NULL statement, 4295 -- rather than just removing it, because Freeze_All may 4296 -- depend on this particular Node_Id still being present 4297 -- in the enclosing list to signal where to stop 4298 -- freezing. 4299 4300 Rewrite (Init_Stmts, 4301 Make_Null_Statement (Sloc (Init_Stmts))); 4302 4303 Set_Initialization_Statements (E, Empty); 4304 end if; 4305 end; 4306 end if; 4307 end if; 4308 4309 -- Case of a type or subtype being frozen 4310 4311 else 4312 -- We used to check here that a full type must have preelaborable 4313 -- initialization if it completes a private type specified with 4314 -- pragma Preelaborable_Initialization, but that missed cases where 4315 -- the types occur within a generic package, since the freezing 4316 -- that occurs within a containing scope generally skips traversal 4317 -- of a generic unit's declarations (those will be frozen within 4318 -- instances). This check was moved to Analyze_Package_Specification. 4319 4320 -- The type may be defined in a generic unit. This can occur when 4321 -- freezing a generic function that returns the type (which is 4322 -- defined in a parent unit). It is clearly meaningless to freeze 4323 -- this type. However, if it is a subtype, its size may be determi- 4324 -- nable and used in subsequent checks, so might as well try to 4325 -- compute it. 4326 4327 -- In Ada 2012, Freeze_Entities is also used in the front end to 4328 -- trigger the analysis of aspect expressions, so in this case we 4329 -- want to continue the freezing process. 4330 4331 if Present (Scope (E)) 4332 and then Is_Generic_Unit (Scope (E)) 4333 and then 4334 (not Has_Predicates (E) 4335 and then not Has_Delayed_Freeze (E)) 4336 then 4337 Check_Compile_Time_Size (E); 4338 return No_List; 4339 end if; 4340 4341 -- Deal with special cases of freezing for subtype 4342 4343 if E /= Base_Type (E) then 4344 4345 -- Before we do anything else, a specialized test for the case of 4346 -- a size given for an array where the array needs to be packed, 4347 -- but was not so the size cannot be honored. This is the case 4348 -- where implicit packing may apply. The reason we do this so 4349 -- early is that if we have implicit packing, the layout of the 4350 -- base type is affected, so we must do this before we freeze 4351 -- the base type. 4352 4353 -- We could do this processing only if implicit packing is enabled 4354 -- since in all other cases, the error would be caught by the back 4355 -- end. However, we choose to do the check even if we do not have 4356 -- implicit packing enabled, since this allows us to give a more 4357 -- useful error message (advising use of pragmas Implicit_Packing 4358 -- or Pack). 4359 4360 if Is_Array_Type (E) then 4361 declare 4362 Ctyp : constant Entity_Id := Component_Type (E); 4363 Rsiz : constant Uint := RM_Size (Ctyp); 4364 SZ : constant Node_Id := Size_Clause (E); 4365 Btyp : constant Entity_Id := Base_Type (E); 4366 4367 Lo : Node_Id; 4368 Hi : Node_Id; 4369 Indx : Node_Id; 4370 4371 Num_Elmts : Uint; 4372 -- Number of elements in array 4373 4374 begin 4375 -- Check enabling conditions. These are straightforward 4376 -- except for the test for a limited composite type. This 4377 -- eliminates the rare case of a array of limited components 4378 -- where there are issues of whether or not we can go ahead 4379 -- and pack the array (since we can't freely pack and unpack 4380 -- arrays if they are limited). 4381 4382 -- Note that we check the root type explicitly because the 4383 -- whole point is we are doing this test before we have had 4384 -- a chance to freeze the base type (and it is that freeze 4385 -- action that causes stuff to be inherited). 4386 4387 if Has_Size_Clause (E) 4388 and then Known_Static_RM_Size (E) 4389 and then not Is_Packed (E) 4390 and then not Has_Pragma_Pack (E) 4391 and then not Has_Component_Size_Clause (E) 4392 and then Known_Static_RM_Size (Ctyp) 4393 and then RM_Size (Ctyp) < 64 4394 and then not Is_Limited_Composite (E) 4395 and then not Is_Packed (Root_Type (E)) 4396 and then not Has_Component_Size_Clause (Root_Type (E)) 4397 and then not (CodePeer_Mode or GNATprove_Mode) 4398 then 4399 -- Compute number of elements in array 4400 4401 Num_Elmts := Uint_1; 4402 Indx := First_Index (E); 4403 while Present (Indx) loop 4404 Get_Index_Bounds (Indx, Lo, Hi); 4405 4406 if not (Compile_Time_Known_Value (Lo) 4407 and then 4408 Compile_Time_Known_Value (Hi)) 4409 then 4410 goto No_Implicit_Packing; 4411 end if; 4412 4413 Num_Elmts := 4414 Num_Elmts * 4415 UI_Max (Uint_0, 4416 Expr_Value (Hi) - Expr_Value (Lo) + 1); 4417 Next_Index (Indx); 4418 end loop; 4419 4420 -- What we are looking for here is the situation where 4421 -- the RM_Size given would be exactly right if there was 4422 -- a pragma Pack (resulting in the component size being 4423 -- the same as the RM_Size). Furthermore, the component 4424 -- type size must be an odd size (not a multiple of 4425 -- storage unit). If the component RM size is an exact 4426 -- number of storage units that is a power of two, the 4427 -- array is not packed and has a standard representation. 4428 4429 if RM_Size (E) = Num_Elmts * Rsiz 4430 and then Rsiz mod System_Storage_Unit /= 0 4431 then 4432 -- For implicit packing mode, just set the component 4433 -- size silently. 4434 4435 if Implicit_Packing then 4436 Set_Component_Size (Btyp, Rsiz); 4437 Set_Is_Bit_Packed_Array (Btyp); 4438 Set_Is_Packed (Btyp); 4439 Set_Has_Non_Standard_Rep (Btyp); 4440 4441 -- Otherwise give an error message 4442 4443 else 4444 Error_Msg_NE 4445 ("size given for& too small", SZ, E); 4446 Error_Msg_N -- CODEFIX 4447 ("\use explicit pragma Pack " 4448 & "or use pragma Implicit_Packing", SZ); 4449 end if; 4450 4451 elsif RM_Size (E) = Num_Elmts * Rsiz 4452 and then Implicit_Packing 4453 and then 4454 (Rsiz / System_Storage_Unit = 1 4455 or else 4456 Rsiz / System_Storage_Unit = 2 4457 or else 4458 Rsiz / System_Storage_Unit = 4) 4459 then 4460 -- Not a packed array, but indicate the desired 4461 -- component size, for the back-end. 4462 4463 Set_Component_Size (Btyp, Rsiz); 4464 end if; 4465 end if; 4466 end; 4467 end if; 4468 4469 <<No_Implicit_Packing>> 4470 4471 -- If ancestor subtype present, freeze that first. Note that this 4472 -- will also get the base type frozen. Need RM reference ??? 4473 4474 Atype := Ancestor_Subtype (E); 4475 4476 if Present (Atype) then 4477 Freeze_And_Append (Atype, N, Result); 4478 4479 -- No ancestor subtype present 4480 4481 else 4482 -- See if we have a nearest ancestor that has a predicate. 4483 -- That catches the case of derived type with a predicate. 4484 -- Need RM reference here ??? 4485 4486 Atype := Nearest_Ancestor (E); 4487 4488 if Present (Atype) and then Has_Predicates (Atype) then 4489 Freeze_And_Append (Atype, N, Result); 4490 end if; 4491 4492 -- Freeze base type before freezing the entity (RM 13.14(15)) 4493 4494 if E /= Base_Type (E) then 4495 Freeze_And_Append (Base_Type (E), N, Result); 4496 end if; 4497 end if; 4498 4499 -- A subtype inherits all the type-related representation aspects 4500 -- from its parents (RM 13.1(8)). 4501 4502 Inherit_Aspects_At_Freeze_Point (E); 4503 4504 -- For a derived type, freeze its parent type first (RM 13.14(15)) 4505 4506 elsif Is_Derived_Type (E) then 4507 Freeze_And_Append (Etype (E), N, Result); 4508 Freeze_And_Append (First_Subtype (Etype (E)), N, Result); 4509 4510 -- A derived type inherits each type-related representation aspect 4511 -- of its parent type that was directly specified before the 4512 -- declaration of the derived type (RM 13.1(15)). 4513 4514 Inherit_Aspects_At_Freeze_Point (E); 4515 end if; 4516 4517 -- Array type 4518 4519 if Is_Array_Type (E) then 4520 Freeze_Array_Type (E); 4521 4522 -- For a class-wide type, the corresponding specific type is 4523 -- frozen as well (RM 13.14(15)) 4524 4525 elsif Is_Class_Wide_Type (E) then 4526 Freeze_And_Append (Root_Type (E), N, Result); 4527 4528 -- If the base type of the class-wide type is still incomplete, 4529 -- the class-wide remains unfrozen as well. This is legal when 4530 -- E is the formal of a primitive operation of some other type 4531 -- which is being frozen. 4532 4533 if not Is_Frozen (Root_Type (E)) then 4534 Set_Is_Frozen (E, False); 4535 return Result; 4536 end if; 4537 4538 -- The equivalent type associated with a class-wide subtype needs 4539 -- to be frozen to ensure that its layout is done. 4540 4541 if Ekind (E) = E_Class_Wide_Subtype 4542 and then Present (Equivalent_Type (E)) 4543 then 4544 Freeze_And_Append (Equivalent_Type (E), N, Result); 4545 end if; 4546 4547 -- Generate an itype reference for a library-level class-wide type 4548 -- at the freeze point. Otherwise the first explicit reference to 4549 -- the type may appear in an inner scope which will be rejected by 4550 -- the back-end. 4551 4552 if Is_Itype (E) 4553 and then Is_Compilation_Unit (Scope (E)) 4554 then 4555 declare 4556 Ref : constant Node_Id := Make_Itype_Reference (Loc); 4557 4558 begin 4559 Set_Itype (Ref, E); 4560 4561 -- From a gigi point of view, a class-wide subtype derives 4562 -- from its record equivalent type. As a result, the itype 4563 -- reference must appear after the freeze node of the 4564 -- equivalent type or gigi will reject the reference. 4565 4566 if Ekind (E) = E_Class_Wide_Subtype 4567 and then Present (Equivalent_Type (E)) 4568 then 4569 Insert_After (Freeze_Node (Equivalent_Type (E)), Ref); 4570 else 4571 Add_To_Result (Ref); 4572 end if; 4573 end; 4574 end if; 4575 4576 -- For a record type or record subtype, freeze all component types 4577 -- (RM 13.14(15)). We test for E_Record_(sub)Type here, rather than 4578 -- using Is_Record_Type, because we don't want to attempt the freeze 4579 -- for the case of a private type with record extension (we will do 4580 -- that later when the full type is frozen). 4581 4582 elsif Ekind_In (E, E_Record_Type, E_Record_Subtype) 4583 and then not Is_Generic_Unit (Scope (E)) 4584 then 4585 Freeze_Record_Type (E); 4586 4587 -- For a concurrent type, freeze corresponding record type. This 4588 -- does not correspond to any specific rule in the RM, but the 4589 -- record type is essentially part of the concurrent type. 4590 -- Freeze as well all local entities. This includes record types 4591 -- created for entry parameter blocks, and whatever local entities 4592 -- may appear in the private part. 4593 4594 elsif Is_Concurrent_Type (E) then 4595 if Present (Corresponding_Record_Type (E)) then 4596 Freeze_And_Append (Corresponding_Record_Type (E), N, Result); 4597 end if; 4598 4599 Comp := First_Entity (E); 4600 while Present (Comp) loop 4601 if Is_Type (Comp) then 4602 Freeze_And_Append (Comp, N, Result); 4603 4604 elsif (Ekind (Comp)) /= E_Function then 4605 if Is_Itype (Etype (Comp)) 4606 and then Underlying_Type (Scope (Etype (Comp))) = E 4607 then 4608 Undelay_Type (Etype (Comp)); 4609 end if; 4610 4611 Freeze_And_Append (Etype (Comp), N, Result); 4612 end if; 4613 4614 Next_Entity (Comp); 4615 end loop; 4616 4617 -- Private types are required to point to the same freeze node as 4618 -- their corresponding full views. The freeze node itself has to 4619 -- point to the partial view of the entity (because from the partial 4620 -- view, we can retrieve the full view, but not the reverse). 4621 -- However, in order to freeze correctly, we need to freeze the full 4622 -- view. If we are freezing at the end of a scope (or within the 4623 -- scope of the private type), the partial and full views will have 4624 -- been swapped, the full view appears first in the entity chain and 4625 -- the swapping mechanism ensures that the pointers are properly set 4626 -- (on scope exit). 4627 4628 -- If we encounter the partial view before the full view (e.g. when 4629 -- freezing from another scope), we freeze the full view, and then 4630 -- set the pointers appropriately since we cannot rely on swapping to 4631 -- fix things up (subtypes in an outer scope might not get swapped). 4632 4633 elsif Is_Incomplete_Or_Private_Type (E) 4634 and then not Is_Generic_Type (E) 4635 then 4636 -- The construction of the dispatch table associated with library 4637 -- level tagged types forces freezing of all the primitives of the 4638 -- type, which may cause premature freezing of the partial view. 4639 -- For example: 4640 4641 -- package Pkg is 4642 -- type T is tagged private; 4643 -- type DT is new T with private; 4644 -- procedure Prim (X : in out T; Y : in out DT'Class); 4645 -- private 4646 -- type T is tagged null record; 4647 -- Obj : T; 4648 -- type DT is new T with null record; 4649 -- end; 4650 4651 -- In this case the type will be frozen later by the usual 4652 -- mechanism: an object declaration, an instantiation, or the 4653 -- end of a declarative part. 4654 4655 if Is_Library_Level_Tagged_Type (E) 4656 and then not Present (Full_View (E)) 4657 then 4658 Set_Is_Frozen (E, False); 4659 return Result; 4660 4661 -- Case of full view present 4662 4663 elsif Present (Full_View (E)) then 4664 4665 -- If full view has already been frozen, then no further 4666 -- processing is required 4667 4668 if Is_Frozen (Full_View (E)) then 4669 Set_Has_Delayed_Freeze (E, False); 4670 Set_Freeze_Node (E, Empty); 4671 Check_Debug_Info_Needed (E); 4672 4673 -- Otherwise freeze full view and patch the pointers so that 4674 -- the freeze node will elaborate both views in the back-end. 4675 4676 else 4677 declare 4678 Full : constant Entity_Id := Full_View (E); 4679 4680 begin 4681 if Is_Private_Type (Full) 4682 and then Present (Underlying_Full_View (Full)) 4683 then 4684 Freeze_And_Append 4685 (Underlying_Full_View (Full), N, Result); 4686 end if; 4687 4688 Freeze_And_Append (Full, N, Result); 4689 4690 if Has_Delayed_Freeze (E) then 4691 F_Node := Freeze_Node (Full); 4692 4693 if Present (F_Node) then 4694 Set_Freeze_Node (E, F_Node); 4695 Set_Entity (F_Node, E); 4696 4697 else 4698 -- {Incomplete,Private}_Subtypes with Full_Views 4699 -- constrained by discriminants. 4700 4701 Set_Has_Delayed_Freeze (E, False); 4702 Set_Freeze_Node (E, Empty); 4703 end if; 4704 end if; 4705 end; 4706 4707 Check_Debug_Info_Needed (E); 4708 end if; 4709 4710 -- AI-117 requires that the convention of a partial view be the 4711 -- same as the convention of the full view. Note that this is a 4712 -- recognized breach of privacy, but it's essential for logical 4713 -- consistency of representation, and the lack of a rule in 4714 -- RM95 was an oversight. 4715 4716 Set_Convention (E, Convention (Full_View (E))); 4717 4718 Set_Size_Known_At_Compile_Time (E, 4719 Size_Known_At_Compile_Time (Full_View (E))); 4720 4721 -- Size information is copied from the full view to the 4722 -- incomplete or private view for consistency. 4723 4724 -- We skip this is the full view is not a type. This is very 4725 -- strange of course, and can only happen as a result of 4726 -- certain illegalities, such as a premature attempt to derive 4727 -- from an incomplete type. 4728 4729 if Is_Type (Full_View (E)) then 4730 Set_Size_Info (E, Full_View (E)); 4731 Set_RM_Size (E, RM_Size (Full_View (E))); 4732 end if; 4733 4734 return Result; 4735 4736 -- Case of no full view present. If entity is derived or subtype, 4737 -- it is safe to freeze, correctness depends on the frozen status 4738 -- of parent. Otherwise it is either premature usage, or a Taft 4739 -- amendment type, so diagnosis is at the point of use and the 4740 -- type might be frozen later. 4741 4742 elsif E /= Base_Type (E) or else Is_Derived_Type (E) then 4743 null; 4744 4745 else 4746 Set_Is_Frozen (E, False); 4747 return No_List; 4748 end if; 4749 4750 -- For access subprogram, freeze types of all formals, the return 4751 -- type was already frozen, since it is the Etype of the function. 4752 -- Formal types can be tagged Taft amendment types, but otherwise 4753 -- they cannot be incomplete. 4754 4755 elsif Ekind (E) = E_Subprogram_Type then 4756 Formal := First_Formal (E); 4757 while Present (Formal) loop 4758 if Ekind (Etype (Formal)) = E_Incomplete_Type 4759 and then No (Full_View (Etype (Formal))) 4760 and then not Is_Value_Type (Etype (Formal)) 4761 then 4762 if Is_Tagged_Type (Etype (Formal)) then 4763 null; 4764 4765 -- AI05-151: Incomplete types are allowed in access to 4766 -- subprogram specifications. 4767 4768 elsif Ada_Version < Ada_2012 then 4769 Error_Msg_NE 4770 ("invalid use of incomplete type&", E, Etype (Formal)); 4771 end if; 4772 end if; 4773 4774 Freeze_And_Append (Etype (Formal), N, Result); 4775 Next_Formal (Formal); 4776 end loop; 4777 4778 Freeze_Subprogram (E); 4779 4780 -- For access to a protected subprogram, freeze the equivalent type 4781 -- (however this is not set if we are not generating code or if this 4782 -- is an anonymous type used just for resolution). 4783 4784 elsif Is_Access_Protected_Subprogram_Type (E) then 4785 if Present (Equivalent_Type (E)) then 4786 Freeze_And_Append (Equivalent_Type (E), N, Result); 4787 end if; 4788 end if; 4789 4790 -- Generic types are never seen by the back-end, and are also not 4791 -- processed by the expander (since the expander is turned off for 4792 -- generic processing), so we never need freeze nodes for them. 4793 4794 if Is_Generic_Type (E) then 4795 return Result; 4796 end if; 4797 4798 -- Some special processing for non-generic types to complete 4799 -- representation details not known till the freeze point. 4800 4801 if Is_Fixed_Point_Type (E) then 4802 Freeze_Fixed_Point_Type (E); 4803 4804 -- Some error checks required for ordinary fixed-point type. Defer 4805 -- these till the freeze-point since we need the small and range 4806 -- values. We only do these checks for base types 4807 4808 if Is_Ordinary_Fixed_Point_Type (E) and then Is_Base_Type (E) then 4809 if Small_Value (E) < Ureal_2_M_80 then 4810 Error_Msg_Name_1 := Name_Small; 4811 Error_Msg_N 4812 ("`&''%` too small, minimum allowed is 2.0'*'*(-80)", E); 4813 4814 elsif Small_Value (E) > Ureal_2_80 then 4815 Error_Msg_Name_1 := Name_Small; 4816 Error_Msg_N 4817 ("`&''%` too large, maximum allowed is 2.0'*'*80", E); 4818 end if; 4819 4820 if Expr_Value_R (Type_Low_Bound (E)) < Ureal_M_10_36 then 4821 Error_Msg_Name_1 := Name_First; 4822 Error_Msg_N 4823 ("`&''%` too small, minimum allowed is -10.0'*'*36", E); 4824 end if; 4825 4826 if Expr_Value_R (Type_High_Bound (E)) > Ureal_10_36 then 4827 Error_Msg_Name_1 := Name_Last; 4828 Error_Msg_N 4829 ("`&''%` too large, maximum allowed is 10.0'*'*36", E); 4830 end if; 4831 end if; 4832 4833 elsif Is_Enumeration_Type (E) then 4834 Freeze_Enumeration_Type (E); 4835 4836 elsif Is_Integer_Type (E) then 4837 Adjust_Esize_For_Alignment (E); 4838 4839 if Is_Modular_Integer_Type (E) 4840 and then Warn_On_Suspicious_Modulus_Value 4841 then 4842 Check_Suspicious_Modulus (E); 4843 end if; 4844 4845 elsif Is_Access_Type (E) 4846 and then not Is_Access_Subprogram_Type (E) 4847 then 4848 -- If a pragma Default_Storage_Pool applies, and this type has no 4849 -- Storage_Pool or Storage_Size clause (which must have occurred 4850 -- before the freezing point), then use the default. This applies 4851 -- only to base types. 4852 4853 -- None of this applies to access to subprograms, for which there 4854 -- are clearly no pools. 4855 4856 if Present (Default_Pool) 4857 and then Is_Base_Type (E) 4858 and then not Has_Storage_Size_Clause (E) 4859 and then No (Associated_Storage_Pool (E)) 4860 then 4861 -- Case of pragma Default_Storage_Pool (null) 4862 4863 if Nkind (Default_Pool) = N_Null then 4864 Set_No_Pool_Assigned (E); 4865 4866 -- Case of pragma Default_Storage_Pool (storage_pool_NAME) 4867 4868 else 4869 Set_Associated_Storage_Pool (E, Entity (Default_Pool)); 4870 end if; 4871 end if; 4872 4873 -- Check restriction for standard storage pool 4874 4875 if No (Associated_Storage_Pool (E)) then 4876 Check_Restriction (No_Standard_Storage_Pools, E); 4877 end if; 4878 4879 -- Deal with error message for pure access type. This is not an 4880 -- error in Ada 2005 if there is no pool (see AI-366). 4881 4882 if Is_Pure_Unit_Access_Type (E) 4883 and then (Ada_Version < Ada_2005 4884 or else not No_Pool_Assigned (E)) 4885 and then not Is_Generic_Unit (Scope (E)) 4886 then 4887 Error_Msg_N ("named access type not allowed in pure unit", E); 4888 4889 if Ada_Version >= Ada_2005 then 4890 Error_Msg_N 4891 ("\would be legal if Storage_Size of 0 given??", E); 4892 4893 elsif No_Pool_Assigned (E) then 4894 Error_Msg_N 4895 ("\would be legal in Ada 2005??", E); 4896 4897 else 4898 Error_Msg_N 4899 ("\would be legal in Ada 2005 if " 4900 & "Storage_Size of 0 given??", E); 4901 end if; 4902 end if; 4903 end if; 4904 4905 -- Case of composite types 4906 4907 if Is_Composite_Type (E) then 4908 4909 -- AI-117 requires that all new primitives of a tagged type must 4910 -- inherit the convention of the full view of the type. Inherited 4911 -- and overriding operations are defined to inherit the convention 4912 -- of their parent or overridden subprogram (also specified in 4913 -- AI-117), which will have occurred earlier (in Derive_Subprogram 4914 -- and New_Overloaded_Entity). Here we set the convention of 4915 -- primitives that are still convention Ada, which will ensure 4916 -- that any new primitives inherit the type's convention. Class- 4917 -- wide types can have a foreign convention inherited from their 4918 -- specific type, but are excluded from this since they don't have 4919 -- any associated primitives. 4920 4921 if Is_Tagged_Type (E) 4922 and then not Is_Class_Wide_Type (E) 4923 and then Convention (E) /= Convention_Ada 4924 then 4925 declare 4926 Prim_List : constant Elist_Id := Primitive_Operations (E); 4927 Prim : Elmt_Id; 4928 4929 begin 4930 Prim := First_Elmt (Prim_List); 4931 while Present (Prim) loop 4932 if Convention (Node (Prim)) = Convention_Ada then 4933 Set_Convention (Node (Prim), Convention (E)); 4934 end if; 4935 4936 Next_Elmt (Prim); 4937 end loop; 4938 end; 4939 end if; 4940 4941 -- If the type is a simple storage pool type, then this is where 4942 -- we attempt to locate and validate its Allocate, Deallocate, and 4943 -- Storage_Size operations (the first is required, and the latter 4944 -- two are optional). We also verify that the full type for a 4945 -- private type is allowed to be a simple storage pool type. 4946 4947 if Present (Get_Rep_Pragma (E, Name_Simple_Storage_Pool_Type)) 4948 and then (Is_Base_Type (E) or else Has_Private_Declaration (E)) 4949 then 4950 -- If the type is marked Has_Private_Declaration, then this is 4951 -- a full type for a private type that was specified with the 4952 -- pragma Simple_Storage_Pool_Type, and here we ensure that the 4953 -- pragma is allowed for the full type (for example, it can't 4954 -- be an array type, or a nonlimited record type). 4955 4956 if Has_Private_Declaration (E) then 4957 if (not Is_Record_Type (E) or else not Is_Limited_View (E)) 4958 and then not Is_Private_Type (E) 4959 then 4960 Error_Msg_Name_1 := Name_Simple_Storage_Pool_Type; 4961 Error_Msg_N 4962 ("pragma% can only apply to full type that is an " & 4963 "explicitly limited type", E); 4964 end if; 4965 end if; 4966 4967 Validate_Simple_Pool_Ops : declare 4968 Pool_Type : Entity_Id renames E; 4969 Address_Type : constant Entity_Id := RTE (RE_Address); 4970 Stg_Cnt_Type : constant Entity_Id := RTE (RE_Storage_Count); 4971 4972 procedure Validate_Simple_Pool_Op_Formal 4973 (Pool_Op : Entity_Id; 4974 Pool_Op_Formal : in out Entity_Id; 4975 Expected_Mode : Formal_Kind; 4976 Expected_Type : Entity_Id; 4977 Formal_Name : String; 4978 OK_Formal : in out Boolean); 4979 -- Validate one formal Pool_Op_Formal of the candidate pool 4980 -- operation Pool_Op. The formal must be of Expected_Type 4981 -- and have mode Expected_Mode. OK_Formal will be set to 4982 -- False if the formal doesn't match. If OK_Formal is False 4983 -- on entry, then the formal will effectively be ignored 4984 -- (because validation of the pool op has already failed). 4985 -- Upon return, Pool_Op_Formal will be updated to the next 4986 -- formal, if any. 4987 4988 procedure Validate_Simple_Pool_Operation 4989 (Op_Name : Name_Id); 4990 -- Search for and validate a simple pool operation with the 4991 -- name Op_Name. If the name is Allocate, then there must be 4992 -- exactly one such primitive operation for the simple pool 4993 -- type. If the name is Deallocate or Storage_Size, then 4994 -- there can be at most one such primitive operation. The 4995 -- profile of the located primitive must conform to what 4996 -- is expected for each operation. 4997 4998 ------------------------------------ 4999 -- Validate_Simple_Pool_Op_Formal -- 5000 ------------------------------------ 5001 5002 procedure Validate_Simple_Pool_Op_Formal 5003 (Pool_Op : Entity_Id; 5004 Pool_Op_Formal : in out Entity_Id; 5005 Expected_Mode : Formal_Kind; 5006 Expected_Type : Entity_Id; 5007 Formal_Name : String; 5008 OK_Formal : in out Boolean) 5009 is 5010 begin 5011 -- If OK_Formal is False on entry, then simply ignore 5012 -- the formal, because an earlier formal has already 5013 -- been flagged. 5014 5015 if not OK_Formal then 5016 return; 5017 5018 -- If no formal is passed in, then issue an error for a 5019 -- missing formal. 5020 5021 elsif not Present (Pool_Op_Formal) then 5022 Error_Msg_NE 5023 ("simple storage pool op missing formal " & 5024 Formal_Name & " of type&", Pool_Op, Expected_Type); 5025 OK_Formal := False; 5026 5027 return; 5028 end if; 5029 5030 if Etype (Pool_Op_Formal) /= Expected_Type then 5031 5032 -- If the pool type was expected for this formal, then 5033 -- this will not be considered a candidate operation 5034 -- for the simple pool, so we unset OK_Formal so that 5035 -- the op and any later formals will be ignored. 5036 5037 if Expected_Type = Pool_Type then 5038 OK_Formal := False; 5039 5040 return; 5041 5042 else 5043 Error_Msg_NE 5044 ("wrong type for formal " & Formal_Name & 5045 " of simple storage pool op; expected type&", 5046 Pool_Op_Formal, Expected_Type); 5047 end if; 5048 end if; 5049 5050 -- Issue error if formal's mode is not the expected one 5051 5052 if Ekind (Pool_Op_Formal) /= Expected_Mode then 5053 Error_Msg_N 5054 ("wrong mode for formal of simple storage pool op", 5055 Pool_Op_Formal); 5056 end if; 5057 5058 -- Advance to the next formal 5059 5060 Next_Formal (Pool_Op_Formal); 5061 end Validate_Simple_Pool_Op_Formal; 5062 5063 ------------------------------------ 5064 -- Validate_Simple_Pool_Operation -- 5065 ------------------------------------ 5066 5067 procedure Validate_Simple_Pool_Operation 5068 (Op_Name : Name_Id) 5069 is 5070 Op : Entity_Id; 5071 Found_Op : Entity_Id := Empty; 5072 Formal : Entity_Id; 5073 Is_OK : Boolean; 5074 5075 begin 5076 pragma Assert 5077 (Nam_In (Op_Name, Name_Allocate, 5078 Name_Deallocate, 5079 Name_Storage_Size)); 5080 5081 Error_Msg_Name_1 := Op_Name; 5082 5083 -- For each homonym declared immediately in the scope 5084 -- of the simple storage pool type, determine whether 5085 -- the homonym is an operation of the pool type, and, 5086 -- if so, check that its profile is as expected for 5087 -- a simple pool operation of that name. 5088 5089 Op := Get_Name_Entity_Id (Op_Name); 5090 while Present (Op) loop 5091 if Ekind_In (Op, E_Function, E_Procedure) 5092 and then Scope (Op) = Current_Scope 5093 then 5094 Formal := First_Entity (Op); 5095 5096 Is_OK := True; 5097 5098 -- The first parameter must be of the pool type 5099 -- in order for the operation to qualify. 5100 5101 if Op_Name = Name_Storage_Size then 5102 Validate_Simple_Pool_Op_Formal 5103 (Op, Formal, E_In_Parameter, Pool_Type, 5104 "Pool", Is_OK); 5105 else 5106 Validate_Simple_Pool_Op_Formal 5107 (Op, Formal, E_In_Out_Parameter, Pool_Type, 5108 "Pool", Is_OK); 5109 end if; 5110 5111 -- If another operation with this name has already 5112 -- been located for the type, then flag an error, 5113 -- since we only allow the type to have a single 5114 -- such primitive. 5115 5116 if Present (Found_Op) and then Is_OK then 5117 Error_Msg_NE 5118 ("only one % operation allowed for " & 5119 "simple storage pool type&", Op, Pool_Type); 5120 end if; 5121 5122 -- In the case of Allocate and Deallocate, a formal 5123 -- of type System.Address is required. 5124 5125 if Op_Name = Name_Allocate then 5126 Validate_Simple_Pool_Op_Formal 5127 (Op, Formal, E_Out_Parameter, 5128 Address_Type, "Storage_Address", Is_OK); 5129 5130 elsif Op_Name = Name_Deallocate then 5131 Validate_Simple_Pool_Op_Formal 5132 (Op, Formal, E_In_Parameter, 5133 Address_Type, "Storage_Address", Is_OK); 5134 end if; 5135 5136 -- In the case of Allocate and Deallocate, formals 5137 -- of type Storage_Count are required as the third 5138 -- and fourth parameters. 5139 5140 if Op_Name /= Name_Storage_Size then 5141 Validate_Simple_Pool_Op_Formal 5142 (Op, Formal, E_In_Parameter, 5143 Stg_Cnt_Type, "Size_In_Storage_Units", Is_OK); 5144 Validate_Simple_Pool_Op_Formal 5145 (Op, Formal, E_In_Parameter, 5146 Stg_Cnt_Type, "Alignment", Is_OK); 5147 end if; 5148 5149 -- If no mismatched formals have been found (Is_OK) 5150 -- and no excess formals are present, then this 5151 -- operation has been validated, so record it. 5152 5153 if not Present (Formal) and then Is_OK then 5154 Found_Op := Op; 5155 end if; 5156 end if; 5157 5158 Op := Homonym (Op); 5159 end loop; 5160 5161 -- There must be a valid Allocate operation for the type, 5162 -- so issue an error if none was found. 5163 5164 if Op_Name = Name_Allocate 5165 and then not Present (Found_Op) 5166 then 5167 Error_Msg_N ("missing % operation for simple " & 5168 "storage pool type", Pool_Type); 5169 5170 elsif Present (Found_Op) then 5171 5172 -- Simple pool operations can't be abstract 5173 5174 if Is_Abstract_Subprogram (Found_Op) then 5175 Error_Msg_N 5176 ("simple storage pool operation must not be " & 5177 "abstract", Found_Op); 5178 end if; 5179 5180 -- The Storage_Size operation must be a function with 5181 -- Storage_Count as its result type. 5182 5183 if Op_Name = Name_Storage_Size then 5184 if Ekind (Found_Op) = E_Procedure then 5185 Error_Msg_N 5186 ("% operation must be a function", Found_Op); 5187 5188 elsif Etype (Found_Op) /= Stg_Cnt_Type then 5189 Error_Msg_NE 5190 ("wrong result type for%, expected type&", 5191 Found_Op, Stg_Cnt_Type); 5192 end if; 5193 5194 -- Allocate and Deallocate must be procedures 5195 5196 elsif Ekind (Found_Op) = E_Function then 5197 Error_Msg_N 5198 ("% operation must be a procedure", Found_Op); 5199 end if; 5200 end if; 5201 end Validate_Simple_Pool_Operation; 5202 5203 -- Start of processing for Validate_Simple_Pool_Ops 5204 5205 begin 5206 Validate_Simple_Pool_Operation (Name_Allocate); 5207 Validate_Simple_Pool_Operation (Name_Deallocate); 5208 Validate_Simple_Pool_Operation (Name_Storage_Size); 5209 end Validate_Simple_Pool_Ops; 5210 end if; 5211 end if; 5212 5213 -- Now that all types from which E may depend are frozen, see if the 5214 -- size is known at compile time, if it must be unsigned, or if 5215 -- strict alignment is required 5216 5217 Check_Compile_Time_Size (E); 5218 Check_Unsigned_Type (E); 5219 5220 if Base_Type (E) = E then 5221 Check_Strict_Alignment (E); 5222 end if; 5223 5224 -- Do not allow a size clause for a type which does not have a size 5225 -- that is known at compile time 5226 5227 if Has_Size_Clause (E) 5228 and then not Size_Known_At_Compile_Time (E) 5229 then 5230 -- Suppress this message if errors posted on E, even if we are 5231 -- in all errors mode, since this is often a junk message 5232 5233 if not Error_Posted (E) then 5234 Error_Msg_N 5235 ("size clause not allowed for variable length type", 5236 Size_Clause (E)); 5237 end if; 5238 end if; 5239 5240 -- Now we set/verify the representation information, in particular 5241 -- the size and alignment values. This processing is not required for 5242 -- generic types, since generic types do not play any part in code 5243 -- generation, and so the size and alignment values for such types 5244 -- are irrelevant. Ditto for types declared within a generic unit, 5245 -- which may have components that depend on generic parameters, and 5246 -- that will be recreated in an instance. 5247 5248 if Inside_A_Generic then 5249 null; 5250 5251 -- Otherwise we call the layout procedure 5252 5253 else 5254 Layout_Type (E); 5255 end if; 5256 5257 -- If this is an access to subprogram whose designated type is itself 5258 -- a subprogram type, the return type of this anonymous subprogram 5259 -- type must be decorated as well. 5260 5261 if Ekind (E) = E_Anonymous_Access_Subprogram_Type 5262 and then Ekind (Designated_Type (E)) = E_Subprogram_Type 5263 then 5264 Layout_Type (Etype (Designated_Type (E))); 5265 end if; 5266 5267 -- If the type has a Defaut_Value/Default_Component_Value aspect, 5268 -- this is where we analye the expression (after the type is frozen, 5269 -- since in the case of Default_Value, we are analyzing with the 5270 -- type itself, and we treat Default_Component_Value similarly for 5271 -- the sake of uniformity). 5272 5273 if Is_First_Subtype (E) and then Has_Default_Aspect (E) then 5274 declare 5275 Nam : Name_Id; 5276 Exp : Node_Id; 5277 Typ : Entity_Id; 5278 5279 begin 5280 if Is_Scalar_Type (E) then 5281 Nam := Name_Default_Value; 5282 Typ := E; 5283 Exp := Default_Aspect_Value (Typ); 5284 else 5285 Nam := Name_Default_Component_Value; 5286 Typ := Component_Type (E); 5287 Exp := Default_Aspect_Component_Value (E); 5288 end if; 5289 5290 Analyze_And_Resolve (Exp, Typ); 5291 5292 if Etype (Exp) /= Any_Type then 5293 if not Is_Static_Expression (Exp) then 5294 Error_Msg_Name_1 := Nam; 5295 Flag_Non_Static_Expr 5296 ("aspect% requires static expression", Exp); 5297 end if; 5298 end if; 5299 end; 5300 end if; 5301 5302 -- End of freeze processing for type entities 5303 end if; 5304 5305 -- Here is where we logically freeze the current entity. If it has a 5306 -- freeze node, then this is the point at which the freeze node is 5307 -- linked into the result list. 5308 5309 if Has_Delayed_Freeze (E) then 5310 5311 -- If a freeze node is already allocated, use it, otherwise allocate 5312 -- a new one. The preallocation happens in the case of anonymous base 5313 -- types, where we preallocate so that we can set First_Subtype_Link. 5314 -- Note that we reset the Sloc to the current freeze location. 5315 5316 if Present (Freeze_Node (E)) then 5317 F_Node := Freeze_Node (E); 5318 Set_Sloc (F_Node, Loc); 5319 5320 else 5321 F_Node := New_Node (N_Freeze_Entity, Loc); 5322 Set_Freeze_Node (E, F_Node); 5323 Set_Access_Types_To_Process (F_Node, No_Elist); 5324 Set_TSS_Elist (F_Node, No_Elist); 5325 Set_Actions (F_Node, No_List); 5326 end if; 5327 5328 Set_Entity (F_Node, E); 5329 Add_To_Result (F_Node); 5330 5331 -- A final pass over record types with discriminants. If the type 5332 -- has an incomplete declaration, there may be constrained access 5333 -- subtypes declared elsewhere, which do not depend on the discrimi- 5334 -- nants of the type, and which are used as component types (i.e. 5335 -- the full view is a recursive type). The designated types of these 5336 -- subtypes can only be elaborated after the type itself, and they 5337 -- need an itype reference. 5338 5339 if Ekind (E) = E_Record_Type 5340 and then Has_Discriminants (E) 5341 then 5342 declare 5343 Comp : Entity_Id; 5344 IR : Node_Id; 5345 Typ : Entity_Id; 5346 5347 begin 5348 Comp := First_Component (E); 5349 while Present (Comp) loop 5350 Typ := Etype (Comp); 5351 5352 if Ekind (Comp) = E_Component 5353 and then Is_Access_Type (Typ) 5354 and then Scope (Typ) /= E 5355 and then Base_Type (Designated_Type (Typ)) = E 5356 and then Is_Itype (Designated_Type (Typ)) 5357 then 5358 IR := Make_Itype_Reference (Sloc (Comp)); 5359 Set_Itype (IR, Designated_Type (Typ)); 5360 Append (IR, Result); 5361 end if; 5362 5363 Next_Component (Comp); 5364 end loop; 5365 end; 5366 end if; 5367 end if; 5368 5369 -- When a type is frozen, the first subtype of the type is frozen as 5370 -- well (RM 13.14(15)). This has to be done after freezing the type, 5371 -- since obviously the first subtype depends on its own base type. 5372 5373 if Is_Type (E) then 5374 Freeze_And_Append (First_Subtype (E), N, Result); 5375 5376 -- If we just froze a tagged non-class wide record, then freeze the 5377 -- corresponding class-wide type. This must be done after the tagged 5378 -- type itself is frozen, because the class-wide type refers to the 5379 -- tagged type which generates the class. 5380 5381 if Is_Tagged_Type (E) 5382 and then not Is_Class_Wide_Type (E) 5383 and then Present (Class_Wide_Type (E)) 5384 then 5385 Freeze_And_Append (Class_Wide_Type (E), N, Result); 5386 end if; 5387 end if; 5388 5389 Check_Debug_Info_Needed (E); 5390 5391 -- Special handling for subprograms 5392 5393 if Is_Subprogram (E) then 5394 5395 -- If subprogram has address clause then reset Is_Public flag, since 5396 -- we do not want the backend to generate external references. 5397 5398 if Present (Address_Clause (E)) 5399 and then not Is_Library_Level_Entity (E) 5400 then 5401 Set_Is_Public (E, False); 5402 end if; 5403 end if; 5404 5405 return Result; 5406 end Freeze_Entity; 5407 5408 ----------------------------- 5409 -- Freeze_Enumeration_Type -- 5410 ----------------------------- 5411 5412 procedure Freeze_Enumeration_Type (Typ : Entity_Id) is 5413 begin 5414 -- By default, if no size clause is present, an enumeration type with 5415 -- Convention C is assumed to interface to a C enum, and has integer 5416 -- size. This applies to types. For subtypes, verify that its base 5417 -- type has no size clause either. Treat other foreign conventions 5418 -- in the same way, and also make sure alignment is set right. 5419 5420 if Has_Foreign_Convention (Typ) 5421 and then not Has_Size_Clause (Typ) 5422 and then not Has_Size_Clause (Base_Type (Typ)) 5423 and then Esize (Typ) < Standard_Integer_Size 5424 5425 -- Don't do this if Short_Enums on target 5426 5427 and then not Target_Short_Enums 5428 then 5429 Init_Esize (Typ, Standard_Integer_Size); 5430 Set_Alignment (Typ, Alignment (Standard_Integer)); 5431 5432 -- Normal Ada case or size clause present or not Long_C_Enums on target 5433 5434 else 5435 -- If the enumeration type interfaces to C, and it has a size clause 5436 -- that specifies less than int size, it warrants a warning. The 5437 -- user may intend the C type to be an enum or a char, so this is 5438 -- not by itself an error that the Ada compiler can detect, but it 5439 -- it is a worth a heads-up. For Boolean and Character types we 5440 -- assume that the programmer has the proper C type in mind. 5441 5442 if Convention (Typ) = Convention_C 5443 and then Has_Size_Clause (Typ) 5444 and then Esize (Typ) /= Esize (Standard_Integer) 5445 and then not Is_Boolean_Type (Typ) 5446 and then not Is_Character_Type (Typ) 5447 5448 -- Don't do this if Short_Enums on target 5449 5450 and then not Target_Short_Enums 5451 then 5452 Error_Msg_N 5453 ("C enum types have the size of a C int??", Size_Clause (Typ)); 5454 end if; 5455 5456 Adjust_Esize_For_Alignment (Typ); 5457 end if; 5458 end Freeze_Enumeration_Type; 5459 5460 ----------------------- 5461 -- Freeze_Expression -- 5462 ----------------------- 5463 5464 procedure Freeze_Expression (N : Node_Id) is 5465 In_Spec_Exp : constant Boolean := In_Spec_Expression; 5466 Typ : Entity_Id; 5467 Nam : Entity_Id; 5468 Desig_Typ : Entity_Id; 5469 P : Node_Id; 5470 Parent_P : Node_Id; 5471 5472 Freeze_Outside : Boolean := False; 5473 -- This flag is set true if the entity must be frozen outside the 5474 -- current subprogram. This happens in the case of expander generated 5475 -- subprograms (_Init_Proc, _Input, _Output, _Read, _Write) which do 5476 -- not freeze all entities like other bodies, but which nevertheless 5477 -- may reference entities that have to be frozen before the body and 5478 -- obviously cannot be frozen inside the body. 5479 5480 function In_Exp_Body (N : Node_Id) return Boolean; 5481 -- Given an N_Handled_Sequence_Of_Statements node N, determines whether 5482 -- it is the handled statement sequence of an expander-generated 5483 -- subprogram (init proc, stream subprogram, or renaming as body). 5484 -- If so, this is not a freezing context. 5485 5486 ----------------- 5487 -- In_Exp_Body -- 5488 ----------------- 5489 5490 function In_Exp_Body (N : Node_Id) return Boolean is 5491 P : Node_Id; 5492 Id : Entity_Id; 5493 5494 begin 5495 if Nkind (N) = N_Subprogram_Body then 5496 P := N; 5497 else 5498 P := Parent (N); 5499 end if; 5500 5501 if Nkind (P) /= N_Subprogram_Body then 5502 return False; 5503 5504 else 5505 Id := Defining_Unit_Name (Specification (P)); 5506 5507 -- Following complex conditional could use comments ??? 5508 5509 if Nkind (Id) = N_Defining_Identifier 5510 and then (Is_Init_Proc (Id) 5511 or else Is_TSS (Id, TSS_Stream_Input) 5512 or else Is_TSS (Id, TSS_Stream_Output) 5513 or else Is_TSS (Id, TSS_Stream_Read) 5514 or else Is_TSS (Id, TSS_Stream_Write) 5515 or else Nkind_In (Original_Node (P), 5516 N_Subprogram_Renaming_Declaration, 5517 N_Expression_Function)) 5518 then 5519 return True; 5520 else 5521 return False; 5522 end if; 5523 end if; 5524 end In_Exp_Body; 5525 5526 -- Start of processing for Freeze_Expression 5527 5528 begin 5529 -- Immediate return if freezing is inhibited. This flag is set by the 5530 -- analyzer to stop freezing on generated expressions that would cause 5531 -- freezing if they were in the source program, but which are not 5532 -- supposed to freeze, since they are created. 5533 5534 if Must_Not_Freeze (N) then 5535 return; 5536 end if; 5537 5538 -- If expression is non-static, then it does not freeze in a default 5539 -- expression, see section "Handling of Default Expressions" in the 5540 -- spec of package Sem for further details. Note that we have to make 5541 -- sure that we actually have a real expression (if we have a subtype 5542 -- indication, we can't test Is_Static_Expression). However, we exclude 5543 -- the case of the prefix of an attribute of a static scalar subtype 5544 -- from this early return, because static subtype attributes should 5545 -- always cause freezing, even in default expressions, but the attribute 5546 -- may not have been marked as static yet (because in Resolve_Attribute, 5547 -- the call to Eval_Attribute follows the call of Freeze_Expression on 5548 -- the prefix). 5549 5550 if In_Spec_Exp 5551 and then Nkind (N) in N_Subexpr 5552 and then not Is_Static_Expression (N) 5553 and then (Nkind (Parent (N)) /= N_Attribute_Reference 5554 or else not (Is_Entity_Name (N) 5555 and then Is_Type (Entity (N)) 5556 and then Is_Static_Subtype (Entity (N)))) 5557 then 5558 return; 5559 end if; 5560 5561 -- Freeze type of expression if not frozen already 5562 5563 Typ := Empty; 5564 5565 if Nkind (N) in N_Has_Etype then 5566 if not Is_Frozen (Etype (N)) then 5567 Typ := Etype (N); 5568 5569 -- Base type may be an derived numeric type that is frozen at 5570 -- the point of declaration, but first_subtype is still unfrozen. 5571 5572 elsif not Is_Frozen (First_Subtype (Etype (N))) then 5573 Typ := First_Subtype (Etype (N)); 5574 end if; 5575 end if; 5576 5577 -- For entity name, freeze entity if not frozen already. A special 5578 -- exception occurs for an identifier that did not come from source. 5579 -- We don't let such identifiers freeze a non-internal entity, i.e. 5580 -- an entity that did come from source, since such an identifier was 5581 -- generated by the expander, and cannot have any semantic effect on 5582 -- the freezing semantics. For example, this stops the parameter of 5583 -- an initialization procedure from freezing the variable. 5584 5585 if Is_Entity_Name (N) 5586 and then not Is_Frozen (Entity (N)) 5587 and then (Nkind (N) /= N_Identifier 5588 or else Comes_From_Source (N) 5589 or else not Comes_From_Source (Entity (N))) 5590 then 5591 Nam := Entity (N); 5592 else 5593 Nam := Empty; 5594 end if; 5595 5596 -- For an allocator freeze designated type if not frozen already 5597 5598 -- For an aggregate whose component type is an access type, freeze the 5599 -- designated type now, so that its freeze does not appear within the 5600 -- loop that might be created in the expansion of the aggregate. If the 5601 -- designated type is a private type without full view, the expression 5602 -- cannot contain an allocator, so the type is not frozen. 5603 5604 -- For a function, we freeze the entity when the subprogram declaration 5605 -- is frozen, but a function call may appear in an initialization proc. 5606 -- before the declaration is frozen. We need to generate the extra 5607 -- formals, if any, to ensure that the expansion of the call includes 5608 -- the proper actuals. This only applies to Ada subprograms, not to 5609 -- imported ones. 5610 5611 Desig_Typ := Empty; 5612 5613 case Nkind (N) is 5614 when N_Allocator => 5615 Desig_Typ := Designated_Type (Etype (N)); 5616 5617 when N_Aggregate => 5618 if Is_Array_Type (Etype (N)) 5619 and then Is_Access_Type (Component_Type (Etype (N))) 5620 then 5621 Desig_Typ := Designated_Type (Component_Type (Etype (N))); 5622 end if; 5623 5624 when N_Selected_Component | 5625 N_Indexed_Component | 5626 N_Slice => 5627 5628 if Is_Access_Type (Etype (Prefix (N))) then 5629 Desig_Typ := Designated_Type (Etype (Prefix (N))); 5630 end if; 5631 5632 when N_Identifier => 5633 if Present (Nam) 5634 and then Ekind (Nam) = E_Function 5635 and then Nkind (Parent (N)) = N_Function_Call 5636 and then Convention (Nam) = Convention_Ada 5637 then 5638 Create_Extra_Formals (Nam); 5639 end if; 5640 5641 when others => 5642 null; 5643 end case; 5644 5645 if Desig_Typ /= Empty 5646 and then (Is_Frozen (Desig_Typ) 5647 or else (not Is_Fully_Defined (Desig_Typ))) 5648 then 5649 Desig_Typ := Empty; 5650 end if; 5651 5652 -- All done if nothing needs freezing 5653 5654 if No (Typ) 5655 and then No (Nam) 5656 and then No (Desig_Typ) 5657 then 5658 return; 5659 end if; 5660 5661 -- Loop for looking at the right place to insert the freeze nodes, 5662 -- exiting from the loop when it is appropriate to insert the freeze 5663 -- node before the current node P. 5664 5665 -- Also checks some special exceptions to the freezing rules. These 5666 -- cases result in a direct return, bypassing the freeze action. 5667 5668 P := N; 5669 loop 5670 Parent_P := Parent (P); 5671 5672 -- If we don't have a parent, then we are not in a well-formed tree. 5673 -- This is an unusual case, but there are some legitimate situations 5674 -- in which this occurs, notably when the expressions in the range of 5675 -- a type declaration are resolved. We simply ignore the freeze 5676 -- request in this case. Is this right ??? 5677 5678 if No (Parent_P) then 5679 return; 5680 end if; 5681 5682 -- See if we have got to an appropriate point in the tree 5683 5684 case Nkind (Parent_P) is 5685 5686 -- A special test for the exception of (RM 13.14(8)) for the case 5687 -- of per-object expressions (RM 3.8(18)) occurring in component 5688 -- definition or a discrete subtype definition. Note that we test 5689 -- for a component declaration which includes both cases we are 5690 -- interested in, and furthermore the tree does not have explicit 5691 -- nodes for either of these two constructs. 5692 5693 when N_Component_Declaration => 5694 5695 -- The case we want to test for here is an identifier that is 5696 -- a per-object expression, this is either a discriminant that 5697 -- appears in a context other than the component declaration 5698 -- or it is a reference to the type of the enclosing construct. 5699 5700 -- For either of these cases, we skip the freezing 5701 5702 if not In_Spec_Expression 5703 and then Nkind (N) = N_Identifier 5704 and then (Present (Entity (N))) 5705 then 5706 -- We recognize the discriminant case by just looking for 5707 -- a reference to a discriminant. It can only be one for 5708 -- the enclosing construct. Skip freezing in this case. 5709 5710 if Ekind (Entity (N)) = E_Discriminant then 5711 return; 5712 5713 -- For the case of a reference to the enclosing record, 5714 -- (or task or protected type), we look for a type that 5715 -- matches the current scope. 5716 5717 elsif Entity (N) = Current_Scope then 5718 return; 5719 end if; 5720 end if; 5721 5722 -- If we have an enumeration literal that appears as the choice in 5723 -- the aggregate of an enumeration representation clause, then 5724 -- freezing does not occur (RM 13.14(10)). 5725 5726 when N_Enumeration_Representation_Clause => 5727 5728 -- The case we are looking for is an enumeration literal 5729 5730 if (Nkind (N) = N_Identifier or Nkind (N) = N_Character_Literal) 5731 and then Is_Enumeration_Type (Etype (N)) 5732 then 5733 -- If enumeration literal appears directly as the choice, 5734 -- do not freeze (this is the normal non-overloaded case) 5735 5736 if Nkind (Parent (N)) = N_Component_Association 5737 and then First (Choices (Parent (N))) = N 5738 then 5739 return; 5740 5741 -- If enumeration literal appears as the name of function 5742 -- which is the choice, then also do not freeze. This 5743 -- happens in the overloaded literal case, where the 5744 -- enumeration literal is temporarily changed to a function 5745 -- call for overloading analysis purposes. 5746 5747 elsif Nkind (Parent (N)) = N_Function_Call 5748 and then 5749 Nkind (Parent (Parent (N))) = N_Component_Association 5750 and then 5751 First (Choices (Parent (Parent (N)))) = Parent (N) 5752 then 5753 return; 5754 end if; 5755 end if; 5756 5757 -- Normally if the parent is a handled sequence of statements, 5758 -- then the current node must be a statement, and that is an 5759 -- appropriate place to insert a freeze node. 5760 5761 when N_Handled_Sequence_Of_Statements => 5762 5763 -- An exception occurs when the sequence of statements is for 5764 -- an expander generated body that did not do the usual freeze 5765 -- all operation. In this case we usually want to freeze 5766 -- outside this body, not inside it, and we skip past the 5767 -- subprogram body that we are inside. 5768 5769 if In_Exp_Body (Parent_P) then 5770 declare 5771 Subp : constant Node_Id := Parent (Parent_P); 5772 Spec : Entity_Id; 5773 5774 begin 5775 -- Freeze the entity only when it is declared inside the 5776 -- body of the expander generated procedure. This case 5777 -- is recognized by the scope of the entity or its type, 5778 -- which is either the spec for some enclosing body, or 5779 -- (in the case of init_procs, for which there are no 5780 -- separate specs) the current scope. 5781 5782 if Nkind (Subp) = N_Subprogram_Body then 5783 Spec := Corresponding_Spec (Subp); 5784 5785 if (Present (Typ) and then Scope (Typ) = Spec) 5786 or else 5787 (Present (Nam) and then Scope (Nam) = Spec) 5788 then 5789 exit; 5790 5791 elsif Present (Typ) 5792 and then Scope (Typ) = Current_Scope 5793 and then Defining_Entity (Subp) = Current_Scope 5794 then 5795 exit; 5796 end if; 5797 end if; 5798 5799 -- An expression function may act as a completion of 5800 -- a function declaration. As such, it can reference 5801 -- entities declared between the two views: 5802 5803 -- Hidden []; -- 1 5804 -- function F return ...; 5805 -- private 5806 -- function Hidden return ...; 5807 -- function F return ... is (Hidden); -- 2 5808 5809 -- Refering to the example above, freezing the expression 5810 -- of F (2) would place Hidden's freeze node (1) in the 5811 -- wrong place. Avoid explicit freezing and let the usual 5812 -- scenarios do the job - for example, reaching the end 5813 -- of the private declarations. 5814 5815 if Nkind (Original_Node (Subp)) = 5816 N_Expression_Function 5817 then 5818 null; 5819 5820 -- Freeze outside the body 5821 5822 else 5823 Parent_P := Parent (Parent_P); 5824 Freeze_Outside := True; 5825 end if; 5826 end; 5827 5828 -- Here if normal case where we are in handled statement 5829 -- sequence and want to do the insertion right there. 5830 5831 else 5832 exit; 5833 end if; 5834 5835 -- If parent is a body or a spec or a block, then the current node 5836 -- is a statement or declaration and we can insert the freeze node 5837 -- before it. 5838 5839 when N_Block_Statement | 5840 N_Entry_Body | 5841 N_Package_Body | 5842 N_Package_Specification | 5843 N_Protected_Body | 5844 N_Subprogram_Body | 5845 N_Task_Body => exit; 5846 5847 -- The expander is allowed to define types in any statements list, 5848 -- so any of the following parent nodes also mark a freezing point 5849 -- if the actual node is in a list of statements or declarations. 5850 5851 when N_Abortable_Part | 5852 N_Accept_Alternative | 5853 N_And_Then | 5854 N_Case_Statement_Alternative | 5855 N_Compilation_Unit_Aux | 5856 N_Conditional_Entry_Call | 5857 N_Delay_Alternative | 5858 N_Elsif_Part | 5859 N_Entry_Call_Alternative | 5860 N_Exception_Handler | 5861 N_Extended_Return_Statement | 5862 N_Freeze_Entity | 5863 N_If_Statement | 5864 N_Or_Else | 5865 N_Selective_Accept | 5866 N_Triggering_Alternative => 5867 5868 exit when Is_List_Member (P); 5869 5870 -- Note: The N_Loop_Statement is a special case. A type that 5871 -- appears in the source can never be frozen in a loop (this 5872 -- occurs only because of a loop expanded by the expander), so we 5873 -- keep on going. Otherwise we terminate the search. Same is true 5874 -- of any entity which comes from source. (if they have predefined 5875 -- type, that type does not appear to come from source, but the 5876 -- entity should not be frozen here). 5877 5878 when N_Loop_Statement => 5879 exit when not Comes_From_Source (Etype (N)) 5880 and then (No (Nam) or else not Comes_From_Source (Nam)); 5881 5882 -- For all other cases, keep looking at parents 5883 5884 when others => 5885 null; 5886 end case; 5887 5888 -- We fall through the case if we did not yet find the proper 5889 -- place in the free for inserting the freeze node, so climb. 5890 5891 P := Parent_P; 5892 end loop; 5893 5894 -- If the expression appears in a record or an initialization procedure, 5895 -- the freeze nodes are collected and attached to the current scope, to 5896 -- be inserted and analyzed on exit from the scope, to insure that 5897 -- generated entities appear in the correct scope. If the expression is 5898 -- a default for a discriminant specification, the scope is still void. 5899 -- The expression can also appear in the discriminant part of a private 5900 -- or concurrent type. 5901 5902 -- If the expression appears in a constrained subcomponent of an 5903 -- enclosing record declaration, the freeze nodes must be attached to 5904 -- the outer record type so they can eventually be placed in the 5905 -- enclosing declaration list. 5906 5907 -- The other case requiring this special handling is if we are in a 5908 -- default expression, since in that case we are about to freeze a 5909 -- static type, and the freeze scope needs to be the outer scope, not 5910 -- the scope of the subprogram with the default parameter. 5911 5912 -- For default expressions and other spec expressions in generic units, 5913 -- the Move_Freeze_Nodes mechanism (see sem_ch12.adb) takes care of 5914 -- placing them at the proper place, after the generic unit. 5915 5916 if (In_Spec_Exp and not Inside_A_Generic) 5917 or else Freeze_Outside 5918 or else (Is_Type (Current_Scope) 5919 and then (not Is_Concurrent_Type (Current_Scope) 5920 or else not Has_Completion (Current_Scope))) 5921 or else Ekind (Current_Scope) = E_Void 5922 then 5923 declare 5924 N : constant Node_Id := Current_Scope; 5925 Freeze_Nodes : List_Id := No_List; 5926 Pos : Int := Scope_Stack.Last; 5927 5928 begin 5929 if Present (Desig_Typ) then 5930 Freeze_And_Append (Desig_Typ, N, Freeze_Nodes); 5931 end if; 5932 5933 if Present (Typ) then 5934 Freeze_And_Append (Typ, N, Freeze_Nodes); 5935 end if; 5936 5937 if Present (Nam) then 5938 Freeze_And_Append (Nam, N, Freeze_Nodes); 5939 end if; 5940 5941 -- The current scope may be that of a constrained component of 5942 -- an enclosing record declaration, or of a loop of an enclosing 5943 -- quantified expression, which is above the current scope in the 5944 -- scope stack. Indeed in the context of a quantified expression, 5945 -- a scope is created and pushed above the current scope in order 5946 -- to emulate the loop-like behavior of the quantified expression. 5947 -- If the expression is within a top-level pragma, as for a pre- 5948 -- condition on a library-level subprogram, nothing to do. 5949 5950 if not Is_Compilation_Unit (Current_Scope) 5951 and then (Is_Record_Type (Scope (Current_Scope)) 5952 or else Nkind (Parent (Current_Scope)) = 5953 N_Quantified_Expression) 5954 then 5955 Pos := Pos - 1; 5956 end if; 5957 5958 if Is_Non_Empty_List (Freeze_Nodes) then 5959 if No (Scope_Stack.Table (Pos).Pending_Freeze_Actions) then 5960 Scope_Stack.Table (Pos).Pending_Freeze_Actions := 5961 Freeze_Nodes; 5962 else 5963 Append_List (Freeze_Nodes, 5964 Scope_Stack.Table (Pos).Pending_Freeze_Actions); 5965 end if; 5966 end if; 5967 end; 5968 5969 return; 5970 end if; 5971 5972 -- Now we have the right place to do the freezing. First, a special 5973 -- adjustment, if we are in spec-expression analysis mode, these freeze 5974 -- actions must not be thrown away (normally all inserted actions are 5975 -- thrown away in this mode. However, the freeze actions are from static 5976 -- expressions and one of the important reasons we are doing this 5977 -- special analysis is to get these freeze actions. Therefore we turn 5978 -- off the In_Spec_Expression mode to propagate these freeze actions. 5979 -- This also means they get properly analyzed and expanded. 5980 5981 In_Spec_Expression := False; 5982 5983 -- Freeze the designated type of an allocator (RM 13.14(13)) 5984 5985 if Present (Desig_Typ) then 5986 Freeze_Before (P, Desig_Typ); 5987 end if; 5988 5989 -- Freeze type of expression (RM 13.14(10)). Note that we took care of 5990 -- the enumeration representation clause exception in the loop above. 5991 5992 if Present (Typ) then 5993 Freeze_Before (P, Typ); 5994 end if; 5995 5996 -- Freeze name if one is present (RM 13.14(11)) 5997 5998 if Present (Nam) then 5999 Freeze_Before (P, Nam); 6000 end if; 6001 6002 -- Restore In_Spec_Expression flag 6003 6004 In_Spec_Expression := In_Spec_Exp; 6005 end Freeze_Expression; 6006 6007 ----------------------------- 6008 -- Freeze_Fixed_Point_Type -- 6009 ----------------------------- 6010 6011 -- Certain fixed-point types and subtypes, including implicit base types 6012 -- and declared first subtypes, have not yet set up a range. This is 6013 -- because the range cannot be set until the Small and Size values are 6014 -- known, and these are not known till the type is frozen. 6015 6016 -- To signal this case, Scalar_Range contains an unanalyzed syntactic range 6017 -- whose bounds are unanalyzed real literals. This routine will recognize 6018 -- this case, and transform this range node into a properly typed range 6019 -- with properly analyzed and resolved values. 6020 6021 procedure Freeze_Fixed_Point_Type (Typ : Entity_Id) is 6022 Rng : constant Node_Id := Scalar_Range (Typ); 6023 Lo : constant Node_Id := Low_Bound (Rng); 6024 Hi : constant Node_Id := High_Bound (Rng); 6025 Btyp : constant Entity_Id := Base_Type (Typ); 6026 Brng : constant Node_Id := Scalar_Range (Btyp); 6027 BLo : constant Node_Id := Low_Bound (Brng); 6028 BHi : constant Node_Id := High_Bound (Brng); 6029 Small : constant Ureal := Small_Value (Typ); 6030 Loval : Ureal; 6031 Hival : Ureal; 6032 Atype : Entity_Id; 6033 6034 Actual_Size : Nat; 6035 6036 function Fsize (Lov, Hiv : Ureal) return Nat; 6037 -- Returns size of type with given bounds. Also leaves these 6038 -- bounds set as the current bounds of the Typ. 6039 6040 ----------- 6041 -- Fsize -- 6042 ----------- 6043 6044 function Fsize (Lov, Hiv : Ureal) return Nat is 6045 begin 6046 Set_Realval (Lo, Lov); 6047 Set_Realval (Hi, Hiv); 6048 return Minimum_Size (Typ); 6049 end Fsize; 6050 6051 -- Start of processing for Freeze_Fixed_Point_Type 6052 6053 begin 6054 -- If Esize of a subtype has not previously been set, set it now 6055 6056 if Unknown_Esize (Typ) then 6057 Atype := Ancestor_Subtype (Typ); 6058 6059 if Present (Atype) then 6060 Set_Esize (Typ, Esize (Atype)); 6061 else 6062 Set_Esize (Typ, Esize (Base_Type (Typ))); 6063 end if; 6064 end if; 6065 6066 -- Immediate return if the range is already analyzed. This means that 6067 -- the range is already set, and does not need to be computed by this 6068 -- routine. 6069 6070 if Analyzed (Rng) then 6071 return; 6072 end if; 6073 6074 -- Immediate return if either of the bounds raises Constraint_Error 6075 6076 if Raises_Constraint_Error (Lo) 6077 or else Raises_Constraint_Error (Hi) 6078 then 6079 return; 6080 end if; 6081 6082 Loval := Realval (Lo); 6083 Hival := Realval (Hi); 6084 6085 -- Ordinary fixed-point case 6086 6087 if Is_Ordinary_Fixed_Point_Type (Typ) then 6088 6089 -- For the ordinary fixed-point case, we are allowed to fudge the 6090 -- end-points up or down by small. Generally we prefer to fudge up, 6091 -- i.e. widen the bounds for non-model numbers so that the end points 6092 -- are included. However there are cases in which this cannot be 6093 -- done, and indeed cases in which we may need to narrow the bounds. 6094 -- The following circuit makes the decision. 6095 6096 -- Note: our terminology here is that Incl_EP means that the bounds 6097 -- are widened by Small if necessary to include the end points, and 6098 -- Excl_EP means that the bounds are narrowed by Small to exclude the 6099 -- end-points if this reduces the size. 6100 6101 -- Note that in the Incl case, all we care about is including the 6102 -- end-points. In the Excl case, we want to narrow the bounds as 6103 -- much as permitted by the RM, to give the smallest possible size. 6104 6105 Fudge : declare 6106 Loval_Incl_EP : Ureal; 6107 Hival_Incl_EP : Ureal; 6108 6109 Loval_Excl_EP : Ureal; 6110 Hival_Excl_EP : Ureal; 6111 6112 Size_Incl_EP : Nat; 6113 Size_Excl_EP : Nat; 6114 6115 Model_Num : Ureal; 6116 First_Subt : Entity_Id; 6117 Actual_Lo : Ureal; 6118 Actual_Hi : Ureal; 6119 6120 begin 6121 -- First step. Base types are required to be symmetrical. Right 6122 -- now, the base type range is a copy of the first subtype range. 6123 -- This will be corrected before we are done, but right away we 6124 -- need to deal with the case where both bounds are non-negative. 6125 -- In this case, we set the low bound to the negative of the high 6126 -- bound, to make sure that the size is computed to include the 6127 -- required sign. Note that we do not need to worry about the 6128 -- case of both bounds negative, because the sign will be dealt 6129 -- with anyway. Furthermore we can't just go making such a bound 6130 -- symmetrical, since in a twos-complement system, there is an 6131 -- extra negative value which could not be accommodated on the 6132 -- positive side. 6133 6134 if Typ = Btyp 6135 and then not UR_Is_Negative (Loval) 6136 and then Hival > Loval 6137 then 6138 Loval := -Hival; 6139 Set_Realval (Lo, Loval); 6140 end if; 6141 6142 -- Compute the fudged bounds. If the number is a model number, 6143 -- then we do nothing to include it, but we are allowed to backoff 6144 -- to the next adjacent model number when we exclude it. If it is 6145 -- not a model number then we straddle the two values with the 6146 -- model numbers on either side. 6147 6148 Model_Num := UR_Trunc (Loval / Small) * Small; 6149 6150 if Loval = Model_Num then 6151 Loval_Incl_EP := Model_Num; 6152 else 6153 Loval_Incl_EP := Model_Num - Small; 6154 end if; 6155 6156 -- The low value excluding the end point is Small greater, but 6157 -- we do not do this exclusion if the low value is positive, 6158 -- since it can't help the size and could actually hurt by 6159 -- crossing the high bound. 6160 6161 if UR_Is_Negative (Loval_Incl_EP) then 6162 Loval_Excl_EP := Loval_Incl_EP + Small; 6163 6164 -- If the value went from negative to zero, then we have the 6165 -- case where Loval_Incl_EP is the model number just below 6166 -- zero, so we want to stick to the negative value for the 6167 -- base type to maintain the condition that the size will 6168 -- include signed values. 6169 6170 if Typ = Btyp 6171 and then UR_Is_Zero (Loval_Excl_EP) 6172 then 6173 Loval_Excl_EP := Loval_Incl_EP; 6174 end if; 6175 6176 else 6177 Loval_Excl_EP := Loval_Incl_EP; 6178 end if; 6179 6180 -- Similar processing for upper bound and high value 6181 6182 Model_Num := UR_Trunc (Hival / Small) * Small; 6183 6184 if Hival = Model_Num then 6185 Hival_Incl_EP := Model_Num; 6186 else 6187 Hival_Incl_EP := Model_Num + Small; 6188 end if; 6189 6190 if UR_Is_Positive (Hival_Incl_EP) then 6191 Hival_Excl_EP := Hival_Incl_EP - Small; 6192 else 6193 Hival_Excl_EP := Hival_Incl_EP; 6194 end if; 6195 6196 -- One further adjustment is needed. In the case of subtypes, we 6197 -- cannot go outside the range of the base type, or we get 6198 -- peculiarities, and the base type range is already set. This 6199 -- only applies to the Incl values, since clearly the Excl values 6200 -- are already as restricted as they are allowed to be. 6201 6202 if Typ /= Btyp then 6203 Loval_Incl_EP := UR_Max (Loval_Incl_EP, Realval (BLo)); 6204 Hival_Incl_EP := UR_Min (Hival_Incl_EP, Realval (BHi)); 6205 end if; 6206 6207 -- Get size including and excluding end points 6208 6209 Size_Incl_EP := Fsize (Loval_Incl_EP, Hival_Incl_EP); 6210 Size_Excl_EP := Fsize (Loval_Excl_EP, Hival_Excl_EP); 6211 6212 -- No need to exclude end-points if it does not reduce size 6213 6214 if Fsize (Loval_Incl_EP, Hival_Excl_EP) = Size_Excl_EP then 6215 Loval_Excl_EP := Loval_Incl_EP; 6216 end if; 6217 6218 if Fsize (Loval_Excl_EP, Hival_Incl_EP) = Size_Excl_EP then 6219 Hival_Excl_EP := Hival_Incl_EP; 6220 end if; 6221 6222 -- Now we set the actual size to be used. We want to use the 6223 -- bounds fudged up to include the end-points but only if this 6224 -- can be done without violating a specifically given size 6225 -- size clause or causing an unacceptable increase in size. 6226 6227 -- Case of size clause given 6228 6229 if Has_Size_Clause (Typ) then 6230 6231 -- Use the inclusive size only if it is consistent with 6232 -- the explicitly specified size. 6233 6234 if Size_Incl_EP <= RM_Size (Typ) then 6235 Actual_Lo := Loval_Incl_EP; 6236 Actual_Hi := Hival_Incl_EP; 6237 Actual_Size := Size_Incl_EP; 6238 6239 -- If the inclusive size is too large, we try excluding 6240 -- the end-points (will be caught later if does not work). 6241 6242 else 6243 Actual_Lo := Loval_Excl_EP; 6244 Actual_Hi := Hival_Excl_EP; 6245 Actual_Size := Size_Excl_EP; 6246 end if; 6247 6248 -- Case of size clause not given 6249 6250 else 6251 -- If we have a base type whose corresponding first subtype 6252 -- has an explicit size that is large enough to include our 6253 -- end-points, then do so. There is no point in working hard 6254 -- to get a base type whose size is smaller than the specified 6255 -- size of the first subtype. 6256 6257 First_Subt := First_Subtype (Typ); 6258 6259 if Has_Size_Clause (First_Subt) 6260 and then Size_Incl_EP <= Esize (First_Subt) 6261 then 6262 Actual_Size := Size_Incl_EP; 6263 Actual_Lo := Loval_Incl_EP; 6264 Actual_Hi := Hival_Incl_EP; 6265 6266 -- If excluding the end-points makes the size smaller and 6267 -- results in a size of 8,16,32,64, then we take the smaller 6268 -- size. For the 64 case, this is compulsory. For the other 6269 -- cases, it seems reasonable. We like to include end points 6270 -- if we can, but not at the expense of moving to the next 6271 -- natural boundary of size. 6272 6273 elsif Size_Incl_EP /= Size_Excl_EP 6274 and then Addressable (Size_Excl_EP) 6275 then 6276 Actual_Size := Size_Excl_EP; 6277 Actual_Lo := Loval_Excl_EP; 6278 Actual_Hi := Hival_Excl_EP; 6279 6280 -- Otherwise we can definitely include the end points 6281 6282 else 6283 Actual_Size := Size_Incl_EP; 6284 Actual_Lo := Loval_Incl_EP; 6285 Actual_Hi := Hival_Incl_EP; 6286 end if; 6287 6288 -- One pathological case: normally we never fudge a low bound 6289 -- down, since it would seem to increase the size (if it has 6290 -- any effect), but for ranges containing single value, or no 6291 -- values, the high bound can be small too large. Consider: 6292 6293 -- type t is delta 2.0**(-14) 6294 -- range 131072.0 .. 0; 6295 6296 -- That lower bound is *just* outside the range of 32 bits, and 6297 -- does need fudging down in this case. Note that the bounds 6298 -- will always have crossed here, since the high bound will be 6299 -- fudged down if necessary, as in the case of: 6300 6301 -- type t is delta 2.0**(-14) 6302 -- range 131072.0 .. 131072.0; 6303 6304 -- So we detect the situation by looking for crossed bounds, 6305 -- and if the bounds are crossed, and the low bound is greater 6306 -- than zero, we will always back it off by small, since this 6307 -- is completely harmless. 6308 6309 if Actual_Lo > Actual_Hi then 6310 if UR_Is_Positive (Actual_Lo) then 6311 Actual_Lo := Loval_Incl_EP - Small; 6312 Actual_Size := Fsize (Actual_Lo, Actual_Hi); 6313 6314 -- And of course, we need to do exactly the same parallel 6315 -- fudge for flat ranges in the negative region. 6316 6317 elsif UR_Is_Negative (Actual_Hi) then 6318 Actual_Hi := Hival_Incl_EP + Small; 6319 Actual_Size := Fsize (Actual_Lo, Actual_Hi); 6320 end if; 6321 end if; 6322 end if; 6323 6324 Set_Realval (Lo, Actual_Lo); 6325 Set_Realval (Hi, Actual_Hi); 6326 end Fudge; 6327 6328 -- For the decimal case, none of this fudging is required, since there 6329 -- are no end-point problems in the decimal case (the end-points are 6330 -- always included). 6331 6332 else 6333 Actual_Size := Fsize (Loval, Hival); 6334 end if; 6335 6336 -- At this stage, the actual size has been calculated and the proper 6337 -- required bounds are stored in the low and high bounds. 6338 6339 if Actual_Size > 64 then 6340 Error_Msg_Uint_1 := UI_From_Int (Actual_Size); 6341 Error_Msg_N 6342 ("size required (^) for type& too large, maximum allowed is 64", 6343 Typ); 6344 Actual_Size := 64; 6345 end if; 6346 6347 -- Check size against explicit given size 6348 6349 if Has_Size_Clause (Typ) then 6350 if Actual_Size > RM_Size (Typ) then 6351 Error_Msg_Uint_1 := RM_Size (Typ); 6352 Error_Msg_Uint_2 := UI_From_Int (Actual_Size); 6353 Error_Msg_NE 6354 ("size given (^) for type& too small, minimum allowed is ^", 6355 Size_Clause (Typ), Typ); 6356 6357 else 6358 Actual_Size := UI_To_Int (Esize (Typ)); 6359 end if; 6360 6361 -- Increase size to next natural boundary if no size clause given 6362 6363 else 6364 if Actual_Size <= 8 then 6365 Actual_Size := 8; 6366 elsif Actual_Size <= 16 then 6367 Actual_Size := 16; 6368 elsif Actual_Size <= 32 then 6369 Actual_Size := 32; 6370 else 6371 Actual_Size := 64; 6372 end if; 6373 6374 Init_Esize (Typ, Actual_Size); 6375 Adjust_Esize_For_Alignment (Typ); 6376 end if; 6377 6378 -- If we have a base type, then expand the bounds so that they extend to 6379 -- the full width of the allocated size in bits, to avoid junk range 6380 -- checks on intermediate computations. 6381 6382 if Base_Type (Typ) = Typ then 6383 Set_Realval (Lo, -(Small * (Uint_2 ** (Actual_Size - 1)))); 6384 Set_Realval (Hi, (Small * (Uint_2 ** (Actual_Size - 1) - 1))); 6385 end if; 6386 6387 -- Final step is to reanalyze the bounds using the proper type 6388 -- and set the Corresponding_Integer_Value fields of the literals. 6389 6390 Set_Etype (Lo, Empty); 6391 Set_Analyzed (Lo, False); 6392 Analyze (Lo); 6393 6394 -- Resolve with universal fixed if the base type, and the base type if 6395 -- it is a subtype. Note we can't resolve the base type with itself, 6396 -- that would be a reference before definition. 6397 6398 if Typ = Btyp then 6399 Resolve (Lo, Universal_Fixed); 6400 else 6401 Resolve (Lo, Btyp); 6402 end if; 6403 6404 -- Set corresponding integer value for bound 6405 6406 Set_Corresponding_Integer_Value 6407 (Lo, UR_To_Uint (Realval (Lo) / Small)); 6408 6409 -- Similar processing for high bound 6410 6411 Set_Etype (Hi, Empty); 6412 Set_Analyzed (Hi, False); 6413 Analyze (Hi); 6414 6415 if Typ = Btyp then 6416 Resolve (Hi, Universal_Fixed); 6417 else 6418 Resolve (Hi, Btyp); 6419 end if; 6420 6421 Set_Corresponding_Integer_Value 6422 (Hi, UR_To_Uint (Realval (Hi) / Small)); 6423 6424 -- Set type of range to correspond to bounds 6425 6426 Set_Etype (Rng, Etype (Lo)); 6427 6428 -- Set Esize to calculated size if not set already 6429 6430 if Unknown_Esize (Typ) then 6431 Init_Esize (Typ, Actual_Size); 6432 end if; 6433 6434 -- Set RM_Size if not already set. If already set, check value 6435 6436 declare 6437 Minsiz : constant Uint := UI_From_Int (Minimum_Size (Typ)); 6438 6439 begin 6440 if RM_Size (Typ) /= Uint_0 then 6441 if RM_Size (Typ) < Minsiz then 6442 Error_Msg_Uint_1 := RM_Size (Typ); 6443 Error_Msg_Uint_2 := Minsiz; 6444 Error_Msg_NE 6445 ("size given (^) for type& too small, minimum allowed is ^", 6446 Size_Clause (Typ), Typ); 6447 end if; 6448 6449 else 6450 Set_RM_Size (Typ, Minsiz); 6451 end if; 6452 end; 6453 end Freeze_Fixed_Point_Type; 6454 6455 ------------------ 6456 -- Freeze_Itype -- 6457 ------------------ 6458 6459 procedure Freeze_Itype (T : Entity_Id; N : Node_Id) is 6460 L : List_Id; 6461 6462 begin 6463 Set_Has_Delayed_Freeze (T); 6464 L := Freeze_Entity (T, N); 6465 6466 if Is_Non_Empty_List (L) then 6467 Insert_Actions (N, L); 6468 end if; 6469 end Freeze_Itype; 6470 6471 -------------------------- 6472 -- Freeze_Static_Object -- 6473 -------------------------- 6474 6475 procedure Freeze_Static_Object (E : Entity_Id) is 6476 6477 Cannot_Be_Static : exception; 6478 -- Exception raised if the type of a static object cannot be made 6479 -- static. This happens if the type depends on non-global objects. 6480 6481 procedure Ensure_Expression_Is_SA (N : Node_Id); 6482 -- Called to ensure that an expression used as part of a type definition 6483 -- is statically allocatable, which means that the expression type is 6484 -- statically allocatable, and the expression is either static, or a 6485 -- reference to a library level constant. 6486 6487 procedure Ensure_Type_Is_SA (Typ : Entity_Id); 6488 -- Called to mark a type as static, checking that it is possible 6489 -- to set the type as static. If it is not possible, then the 6490 -- exception Cannot_Be_Static is raised. 6491 6492 ----------------------------- 6493 -- Ensure_Expression_Is_SA -- 6494 ----------------------------- 6495 6496 procedure Ensure_Expression_Is_SA (N : Node_Id) is 6497 Ent : Entity_Id; 6498 6499 begin 6500 Ensure_Type_Is_SA (Etype (N)); 6501 6502 if Is_Static_Expression (N) then 6503 return; 6504 6505 elsif Nkind (N) = N_Identifier then 6506 Ent := Entity (N); 6507 6508 if Present (Ent) 6509 and then Ekind (Ent) = E_Constant 6510 and then Is_Library_Level_Entity (Ent) 6511 then 6512 return; 6513 end if; 6514 end if; 6515 6516 raise Cannot_Be_Static; 6517 end Ensure_Expression_Is_SA; 6518 6519 ----------------------- 6520 -- Ensure_Type_Is_SA -- 6521 ----------------------- 6522 6523 procedure Ensure_Type_Is_SA (Typ : Entity_Id) is 6524 N : Node_Id; 6525 C : Entity_Id; 6526 6527 begin 6528 -- If type is library level, we are all set 6529 6530 if Is_Library_Level_Entity (Typ) then 6531 return; 6532 end if; 6533 6534 -- We are also OK if the type already marked as statically allocated, 6535 -- which means we processed it before. 6536 6537 if Is_Statically_Allocated (Typ) then 6538 return; 6539 end if; 6540 6541 -- Mark type as statically allocated 6542 6543 Set_Is_Statically_Allocated (Typ); 6544 6545 -- Check that it is safe to statically allocate this type 6546 6547 if Is_Scalar_Type (Typ) or else Is_Real_Type (Typ) then 6548 Ensure_Expression_Is_SA (Type_Low_Bound (Typ)); 6549 Ensure_Expression_Is_SA (Type_High_Bound (Typ)); 6550 6551 elsif Is_Array_Type (Typ) then 6552 N := First_Index (Typ); 6553 while Present (N) loop 6554 Ensure_Type_Is_SA (Etype (N)); 6555 Next_Index (N); 6556 end loop; 6557 6558 Ensure_Type_Is_SA (Component_Type (Typ)); 6559 6560 elsif Is_Access_Type (Typ) then 6561 if Ekind (Designated_Type (Typ)) = E_Subprogram_Type then 6562 6563 declare 6564 F : Entity_Id; 6565 T : constant Entity_Id := Etype (Designated_Type (Typ)); 6566 6567 begin 6568 if T /= Standard_Void_Type then 6569 Ensure_Type_Is_SA (T); 6570 end if; 6571 6572 F := First_Formal (Designated_Type (Typ)); 6573 while Present (F) loop 6574 Ensure_Type_Is_SA (Etype (F)); 6575 Next_Formal (F); 6576 end loop; 6577 end; 6578 6579 else 6580 Ensure_Type_Is_SA (Designated_Type (Typ)); 6581 end if; 6582 6583 elsif Is_Record_Type (Typ) then 6584 C := First_Entity (Typ); 6585 while Present (C) loop 6586 if Ekind (C) = E_Discriminant 6587 or else Ekind (C) = E_Component 6588 then 6589 Ensure_Type_Is_SA (Etype (C)); 6590 6591 elsif Is_Type (C) then 6592 Ensure_Type_Is_SA (C); 6593 end if; 6594 6595 Next_Entity (C); 6596 end loop; 6597 6598 elsif Ekind (Typ) = E_Subprogram_Type then 6599 Ensure_Type_Is_SA (Etype (Typ)); 6600 6601 C := First_Formal (Typ); 6602 while Present (C) loop 6603 Ensure_Type_Is_SA (Etype (C)); 6604 Next_Formal (C); 6605 end loop; 6606 6607 else 6608 raise Cannot_Be_Static; 6609 end if; 6610 end Ensure_Type_Is_SA; 6611 6612 -- Start of processing for Freeze_Static_Object 6613 6614 begin 6615 Ensure_Type_Is_SA (Etype (E)); 6616 6617 exception 6618 when Cannot_Be_Static => 6619 6620 -- If the object that cannot be static is imported or exported, then 6621 -- issue an error message saying that this object cannot be imported 6622 -- or exported. If it has an address clause it is an overlay in the 6623 -- current partition and the static requirement is not relevant. 6624 -- Do not issue any error message when ignoring rep clauses. 6625 6626 if Ignore_Rep_Clauses then 6627 null; 6628 6629 elsif Is_Imported (E) then 6630 if No (Address_Clause (E)) then 6631 Error_Msg_N 6632 ("& cannot be imported (local type is not constant)", E); 6633 end if; 6634 6635 -- Otherwise must be exported, something is wrong if compiler 6636 -- is marking something as statically allocated which cannot be). 6637 6638 else pragma Assert (Is_Exported (E)); 6639 Error_Msg_N 6640 ("& cannot be exported (local type is not constant)", E); 6641 end if; 6642 end Freeze_Static_Object; 6643 6644 ----------------------- 6645 -- Freeze_Subprogram -- 6646 ----------------------- 6647 6648 procedure Freeze_Subprogram (E : Entity_Id) is 6649 Retype : Entity_Id; 6650 F : Entity_Id; 6651 6652 begin 6653 -- Subprogram may not have an address clause unless it is imported 6654 6655 if Present (Address_Clause (E)) then 6656 if not Is_Imported (E) then 6657 Error_Msg_N 6658 ("address clause can only be given " & 6659 "for imported subprogram", 6660 Name (Address_Clause (E))); 6661 end if; 6662 end if; 6663 6664 -- Reset the Pure indication on an imported subprogram unless an 6665 -- explicit Pure_Function pragma was present or the subprogram is an 6666 -- intrinsic. We do this because otherwise it is an insidious error 6667 -- to call a non-pure function from pure unit and have calls 6668 -- mysteriously optimized away. What happens here is that the Import 6669 -- can bypass the normal check to ensure that pure units call only pure 6670 -- subprograms. 6671 6672 -- The reason for the intrinsic exception is that in general, intrinsic 6673 -- functions (such as shifts) are pure anyway. The only exceptions are 6674 -- the intrinsics in GNAT.Source_Info, and that unit is not marked Pure 6675 -- in any case, so no problem arises. 6676 6677 if Is_Imported (E) 6678 and then Is_Pure (E) 6679 and then not Has_Pragma_Pure_Function (E) 6680 and then not Is_Intrinsic_Subprogram (E) 6681 then 6682 Set_Is_Pure (E, False); 6683 end if; 6684 6685 -- For non-foreign convention subprograms, this is where we create 6686 -- the extra formals (for accessibility level and constrained bit 6687 -- information). We delay this till the freeze point precisely so 6688 -- that we know the convention. 6689 6690 if not Has_Foreign_Convention (E) then 6691 Create_Extra_Formals (E); 6692 Set_Mechanisms (E); 6693 6694 -- If this is convention Ada and a Valued_Procedure, that's odd 6695 6696 if Ekind (E) = E_Procedure 6697 and then Is_Valued_Procedure (E) 6698 and then Convention (E) = Convention_Ada 6699 and then Warn_On_Export_Import 6700 then 6701 Error_Msg_N 6702 ("??Valued_Procedure has no effect for convention Ada", E); 6703 Set_Is_Valued_Procedure (E, False); 6704 end if; 6705 6706 -- Case of foreign convention 6707 6708 else 6709 Set_Mechanisms (E); 6710 6711 -- For foreign conventions, warn about return of an 6712 -- unconstrained array. 6713 6714 -- Note: we *do* allow a return by descriptor for the VMS case, 6715 -- though here there is probably more to be done ??? 6716 6717 if Ekind (E) = E_Function then 6718 Retype := Underlying_Type (Etype (E)); 6719 6720 -- If no return type, probably some other error, e.g. a 6721 -- missing full declaration, so ignore. 6722 6723 if No (Retype) then 6724 null; 6725 6726 -- If the return type is generic, we have emitted a warning 6727 -- earlier on, and there is nothing else to check here. Specific 6728 -- instantiations may lead to erroneous behavior. 6729 6730 elsif Is_Generic_Type (Etype (E)) then 6731 null; 6732 6733 -- Display warning if returning unconstrained array 6734 6735 elsif Is_Array_Type (Retype) 6736 and then not Is_Constrained (Retype) 6737 6738 -- Exclude cases where descriptor mechanism is set, since the 6739 -- VMS descriptor mechanisms allow such unconstrained returns. 6740 6741 and then Mechanism (E) not in Descriptor_Codes 6742 6743 -- Check appropriate warning is enabled (should we check for 6744 -- Warnings (Off) on specific entities here, probably so???) 6745 6746 and then Warn_On_Export_Import 6747 6748 -- Exclude the VM case, since return of unconstrained arrays 6749 -- is properly handled in both the JVM and .NET cases. 6750 6751 and then VM_Target = No_VM 6752 then 6753 Error_Msg_N 6754 ("?x?foreign convention function& should not return " & 6755 "unconstrained array", E); 6756 return; 6757 end if; 6758 end if; 6759 6760 -- If any of the formals for an exported foreign convention 6761 -- subprogram have defaults, then emit an appropriate warning since 6762 -- this is odd (default cannot be used from non-Ada code) 6763 6764 if Is_Exported (E) then 6765 F := First_Formal (E); 6766 while Present (F) loop 6767 if Warn_On_Export_Import 6768 and then Present (Default_Value (F)) 6769 then 6770 Error_Msg_N 6771 ("?x?parameter cannot be defaulted in non-Ada call", 6772 Default_Value (F)); 6773 end if; 6774 6775 Next_Formal (F); 6776 end loop; 6777 end if; 6778 end if; 6779 6780 -- For VMS, descriptor mechanisms for parameters are allowed only for 6781 -- imported/exported subprograms. Moreover, the NCA descriptor is not 6782 -- allowed for parameters of exported subprograms. 6783 6784 if OpenVMS_On_Target then 6785 if Is_Exported (E) then 6786 F := First_Formal (E); 6787 while Present (F) loop 6788 if Mechanism (F) = By_Descriptor_NCA then 6789 Error_Msg_N 6790 ("'N'C'A' descriptor for parameter not permitted", F); 6791 Error_Msg_N 6792 ("\can only be used for imported subprogram", F); 6793 end if; 6794 6795 Next_Formal (F); 6796 end loop; 6797 6798 elsif not Is_Imported (E) then 6799 F := First_Formal (E); 6800 while Present (F) loop 6801 if Mechanism (F) in Descriptor_Codes then 6802 Error_Msg_N 6803 ("descriptor mechanism for parameter not permitted", F); 6804 Error_Msg_N 6805 ("\can only be used for imported/exported subprogram", F); 6806 end if; 6807 6808 Next_Formal (F); 6809 end loop; 6810 end if; 6811 end if; 6812 6813 -- Pragma Inline_Always is disallowed for dispatching subprograms 6814 -- because the address of such subprograms is saved in the dispatch 6815 -- table to support dispatching calls, and dispatching calls cannot 6816 -- be inlined. This is consistent with the restriction against using 6817 -- 'Access or 'Address on an Inline_Always subprogram. 6818 6819 if Is_Dispatching_Operation (E) 6820 and then Has_Pragma_Inline_Always (E) 6821 then 6822 Error_Msg_N 6823 ("pragma Inline_Always not allowed for dispatching subprograms", E); 6824 end if; 6825 6826 -- Because of the implicit representation of inherited predefined 6827 -- operators in the front-end, the overriding status of the operation 6828 -- may be affected when a full view of a type is analyzed, and this is 6829 -- not captured by the analysis of the corresponding type declaration. 6830 -- Therefore the correctness of a not-overriding indicator must be 6831 -- rechecked when the subprogram is frozen. 6832 6833 if Nkind (E) = N_Defining_Operator_Symbol 6834 and then not Error_Posted (Parent (E)) 6835 then 6836 Check_Overriding_Indicator (E, Empty, Is_Primitive (E)); 6837 end if; 6838 end Freeze_Subprogram; 6839 6840 ---------------------- 6841 -- Is_Fully_Defined -- 6842 ---------------------- 6843 6844 function Is_Fully_Defined (T : Entity_Id) return Boolean is 6845 begin 6846 if Ekind (T) = E_Class_Wide_Type then 6847 return Is_Fully_Defined (Etype (T)); 6848 6849 elsif Is_Array_Type (T) then 6850 return Is_Fully_Defined (Component_Type (T)); 6851 6852 elsif Is_Record_Type (T) 6853 and not Is_Private_Type (T) 6854 then 6855 -- Verify that the record type has no components with private types 6856 -- without completion. 6857 6858 declare 6859 Comp : Entity_Id; 6860 6861 begin 6862 Comp := First_Component (T); 6863 while Present (Comp) loop 6864 if not Is_Fully_Defined (Etype (Comp)) then 6865 return False; 6866 end if; 6867 6868 Next_Component (Comp); 6869 end loop; 6870 return True; 6871 end; 6872 6873 -- For the designated type of an access to subprogram, all types in 6874 -- the profile must be fully defined. 6875 6876 elsif Ekind (T) = E_Subprogram_Type then 6877 declare 6878 F : Entity_Id; 6879 6880 begin 6881 F := First_Formal (T); 6882 while Present (F) loop 6883 if not Is_Fully_Defined (Etype (F)) then 6884 return False; 6885 end if; 6886 6887 Next_Formal (F); 6888 end loop; 6889 6890 return Is_Fully_Defined (Etype (T)); 6891 end; 6892 6893 else 6894 return not Is_Private_Type (T) 6895 or else Present (Full_View (Base_Type (T))); 6896 end if; 6897 end Is_Fully_Defined; 6898 6899 --------------------------------- 6900 -- Process_Default_Expressions -- 6901 --------------------------------- 6902 6903 procedure Process_Default_Expressions 6904 (E : Entity_Id; 6905 After : in out Node_Id) 6906 is 6907 Loc : constant Source_Ptr := Sloc (E); 6908 Dbody : Node_Id; 6909 Formal : Node_Id; 6910 Dcopy : Node_Id; 6911 Dnam : Entity_Id; 6912 6913 begin 6914 Set_Default_Expressions_Processed (E); 6915 6916 -- A subprogram instance and its associated anonymous subprogram share 6917 -- their signature. The default expression functions are defined in the 6918 -- wrapper packages for the anonymous subprogram, and should not be 6919 -- generated again for the instance. 6920 6921 if Is_Generic_Instance (E) 6922 and then Present (Alias (E)) 6923 and then Default_Expressions_Processed (Alias (E)) 6924 then 6925 return; 6926 end if; 6927 6928 Formal := First_Formal (E); 6929 while Present (Formal) loop 6930 if Present (Default_Value (Formal)) then 6931 6932 -- We work with a copy of the default expression because we 6933 -- do not want to disturb the original, since this would mess 6934 -- up the conformance checking. 6935 6936 Dcopy := New_Copy_Tree (Default_Value (Formal)); 6937 6938 -- The analysis of the expression may generate insert actions, 6939 -- which of course must not be executed. We wrap those actions 6940 -- in a procedure that is not called, and later on eliminated. 6941 -- The following cases have no side-effects, and are analyzed 6942 -- directly. 6943 6944 if Nkind (Dcopy) = N_Identifier 6945 or else Nkind_In (Dcopy, N_Expanded_Name, 6946 N_Integer_Literal, 6947 N_Character_Literal, 6948 N_String_Literal) 6949 or else (Nkind (Dcopy) = N_Real_Literal 6950 and then not Vax_Float (Etype (Dcopy))) 6951 or else (Nkind (Dcopy) = N_Attribute_Reference 6952 and then Attribute_Name (Dcopy) = Name_Null_Parameter) 6953 or else Known_Null (Dcopy) 6954 then 6955 -- If there is no default function, we must still do a full 6956 -- analyze call on the default value, to ensure that all error 6957 -- checks are performed, e.g. those associated with static 6958 -- evaluation. Note: this branch will always be taken if the 6959 -- analyzer is turned off (but we still need the error checks). 6960 6961 -- Note: the setting of parent here is to meet the requirement 6962 -- that we can only analyze the expression while attached to 6963 -- the tree. Really the requirement is that the parent chain 6964 -- be set, we don't actually need to be in the tree. 6965 6966 Set_Parent (Dcopy, Declaration_Node (Formal)); 6967 Analyze (Dcopy); 6968 6969 -- Default expressions are resolved with their own type if the 6970 -- context is generic, to avoid anomalies with private types. 6971 6972 if Ekind (Scope (E)) = E_Generic_Package then 6973 Resolve (Dcopy); 6974 else 6975 Resolve (Dcopy, Etype (Formal)); 6976 end if; 6977 6978 -- If that resolved expression will raise constraint error, 6979 -- then flag the default value as raising constraint error. 6980 -- This allows a proper error message on the calls. 6981 6982 if Raises_Constraint_Error (Dcopy) then 6983 Set_Raises_Constraint_Error (Default_Value (Formal)); 6984 end if; 6985 6986 -- If the default is a parameterless call, we use the name of 6987 -- the called function directly, and there is no body to build. 6988 6989 elsif Nkind (Dcopy) = N_Function_Call 6990 and then No (Parameter_Associations (Dcopy)) 6991 then 6992 null; 6993 6994 -- Else construct and analyze the body of a wrapper procedure 6995 -- that contains an object declaration to hold the expression. 6996 -- Given that this is done only to complete the analysis, it 6997 -- simpler to build a procedure than a function which might 6998 -- involve secondary stack expansion. 6999 7000 else 7001 Dnam := Make_Temporary (Loc, 'D'); 7002 7003 Dbody := 7004 Make_Subprogram_Body (Loc, 7005 Specification => 7006 Make_Procedure_Specification (Loc, 7007 Defining_Unit_Name => Dnam), 7008 7009 Declarations => New_List ( 7010 Make_Object_Declaration (Loc, 7011 Defining_Identifier => Make_Temporary (Loc, 'T'), 7012 Object_Definition => 7013 New_Occurrence_Of (Etype (Formal), Loc), 7014 Expression => New_Copy_Tree (Dcopy))), 7015 7016 Handled_Statement_Sequence => 7017 Make_Handled_Sequence_Of_Statements (Loc, 7018 Statements => Empty_List)); 7019 7020 Set_Scope (Dnam, Scope (E)); 7021 Set_Assignment_OK (First (Declarations (Dbody))); 7022 Set_Is_Eliminated (Dnam); 7023 Insert_After (After, Dbody); 7024 Analyze (Dbody); 7025 After := Dbody; 7026 end if; 7027 end if; 7028 7029 Next_Formal (Formal); 7030 end loop; 7031 end Process_Default_Expressions; 7032 7033 ---------------------------------------- 7034 -- Set_Component_Alignment_If_Not_Set -- 7035 ---------------------------------------- 7036 7037 procedure Set_Component_Alignment_If_Not_Set (Typ : Entity_Id) is 7038 begin 7039 -- Ignore if not base type, subtypes don't need anything 7040 7041 if Typ /= Base_Type (Typ) then 7042 return; 7043 end if; 7044 7045 -- Do not override existing representation 7046 7047 if Is_Packed (Typ) then 7048 return; 7049 7050 elsif Has_Specified_Layout (Typ) then 7051 return; 7052 7053 elsif Component_Alignment (Typ) /= Calign_Default then 7054 return; 7055 7056 else 7057 Set_Component_Alignment 7058 (Typ, Scope_Stack.Table 7059 (Scope_Stack.Last).Component_Alignment_Default); 7060 end if; 7061 end Set_Component_Alignment_If_Not_Set; 7062 7063 ------------------ 7064 -- Undelay_Type -- 7065 ------------------ 7066 7067 procedure Undelay_Type (T : Entity_Id) is 7068 begin 7069 Set_Has_Delayed_Freeze (T, False); 7070 Set_Freeze_Node (T, Empty); 7071 7072 -- Since we don't want T to have a Freeze_Node, we don't want its 7073 -- Full_View or Corresponding_Record_Type to have one either. 7074 7075 -- ??? Fundamentally, this whole handling is a kludge. What we really 7076 -- want is to be sure that for an Itype that's part of record R and is a 7077 -- subtype of type T, that it's frozen after the later of the freeze 7078 -- points of R and T. We have no way of doing that directly, so what we 7079 -- do is force most such Itypes to be frozen as part of freezing R via 7080 -- this procedure and only delay the ones that need to be delayed 7081 -- (mostly the designated types of access types that are defined as part 7082 -- of the record). 7083 7084 if Is_Private_Type (T) 7085 and then Present (Full_View (T)) 7086 and then Is_Itype (Full_View (T)) 7087 and then Is_Record_Type (Scope (Full_View (T))) 7088 then 7089 Undelay_Type (Full_View (T)); 7090 end if; 7091 7092 if Is_Concurrent_Type (T) 7093 and then Present (Corresponding_Record_Type (T)) 7094 and then Is_Itype (Corresponding_Record_Type (T)) 7095 and then Is_Record_Type (Scope (Corresponding_Record_Type (T))) 7096 then 7097 Undelay_Type (Corresponding_Record_Type (T)); 7098 end if; 7099 end Undelay_Type; 7100 7101 ------------------ 7102 -- Warn_Overlay -- 7103 ------------------ 7104 7105 procedure Warn_Overlay 7106 (Expr : Node_Id; 7107 Typ : Entity_Id; 7108 Nam : Entity_Id) 7109 is 7110 Ent : constant Entity_Id := Entity (Nam); 7111 -- The object to which the address clause applies 7112 7113 Init : Node_Id; 7114 Old : Entity_Id := Empty; 7115 Decl : Node_Id; 7116 7117 begin 7118 -- No warning if address clause overlay warnings are off 7119 7120 if not Address_Clause_Overlay_Warnings then 7121 return; 7122 end if; 7123 7124 -- No warning if there is an explicit initialization 7125 7126 Init := Original_Node (Expression (Declaration_Node (Ent))); 7127 7128 if Present (Init) and then Comes_From_Source (Init) then 7129 return; 7130 end if; 7131 7132 -- We only give the warning for non-imported entities of a type for 7133 -- which a non-null base init proc is defined, or for objects of access 7134 -- types with implicit null initialization, or when Normalize_Scalars 7135 -- applies and the type is scalar or a string type (the latter being 7136 -- tested for because predefined String types are initialized by inline 7137 -- code rather than by an init_proc). Note that we do not give the 7138 -- warning for Initialize_Scalars, since we suppressed initialization 7139 -- in this case. Also, do not warn if Suppress_Initialization is set. 7140 7141 if Present (Expr) 7142 and then not Is_Imported (Ent) 7143 and then not Initialization_Suppressed (Typ) 7144 and then (Has_Non_Null_Base_Init_Proc (Typ) 7145 or else Is_Access_Type (Typ) 7146 or else (Normalize_Scalars 7147 and then (Is_Scalar_Type (Typ) 7148 or else Is_String_Type (Typ)))) 7149 then 7150 if Nkind (Expr) = N_Attribute_Reference 7151 and then Is_Entity_Name (Prefix (Expr)) 7152 then 7153 Old := Entity (Prefix (Expr)); 7154 7155 elsif Is_Entity_Name (Expr) 7156 and then Ekind (Entity (Expr)) = E_Constant 7157 then 7158 Decl := Declaration_Node (Entity (Expr)); 7159 7160 if Nkind (Decl) = N_Object_Declaration 7161 and then Present (Expression (Decl)) 7162 and then Nkind (Expression (Decl)) = N_Attribute_Reference 7163 and then Is_Entity_Name (Prefix (Expression (Decl))) 7164 then 7165 Old := Entity (Prefix (Expression (Decl))); 7166 7167 elsif Nkind (Expr) = N_Function_Call then 7168 return; 7169 end if; 7170 7171 -- A function call (most likely to To_Address) is probably not an 7172 -- overlay, so skip warning. Ditto if the function call was inlined 7173 -- and transformed into an entity. 7174 7175 elsif Nkind (Original_Node (Expr)) = N_Function_Call then 7176 return; 7177 end if; 7178 7179 Decl := Next (Parent (Expr)); 7180 7181 -- If a pragma Import follows, we assume that it is for the current 7182 -- target of the address clause, and skip the warning. 7183 7184 if Present (Decl) 7185 and then Nkind (Decl) = N_Pragma 7186 and then Pragma_Name (Decl) = Name_Import 7187 then 7188 return; 7189 end if; 7190 7191 if Present (Old) then 7192 Error_Msg_Node_2 := Old; 7193 Error_Msg_N 7194 ("default initialization of & may modify &??", 7195 Nam); 7196 else 7197 Error_Msg_N 7198 ("default initialization of & may modify overlaid storage??", 7199 Nam); 7200 end if; 7201 7202 -- Add friendly warning if initialization comes from a packed array 7203 -- component. 7204 7205 if Is_Record_Type (Typ) then 7206 declare 7207 Comp : Entity_Id; 7208 7209 begin 7210 Comp := First_Component (Typ); 7211 while Present (Comp) loop 7212 if Nkind (Parent (Comp)) = N_Component_Declaration 7213 and then Present (Expression (Parent (Comp))) 7214 then 7215 exit; 7216 elsif Is_Array_Type (Etype (Comp)) 7217 and then Present (Packed_Array_Type (Etype (Comp))) 7218 then 7219 Error_Msg_NE 7220 ("\packed array component& " & 7221 "will be initialized to zero??", 7222 Nam, Comp); 7223 exit; 7224 else 7225 Next_Component (Comp); 7226 end if; 7227 end loop; 7228 end; 7229 end if; 7230 7231 Error_Msg_N 7232 ("\use pragma Import for & to " & 7233 "suppress initialization (RM B.1(24))??", 7234 Nam); 7235 end if; 7236 end Warn_Overlay; 7237 7238end Freeze; 7239