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