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-2004, 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 2, 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 COPYING. If not, write -- 19-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- 20-- MA 02111-1307, USA. -- 21-- -- 22-- GNAT was originally developed by the GNAT team at New York University. -- 23-- Extensive contributions were provided by Ada Core Technologies Inc. -- 24-- -- 25------------------------------------------------------------------------------ 26 27with Atree; use Atree; 28with Debug; use Debug; 29with Einfo; use Einfo; 30with Elists; use Elists; 31with Errout; use Errout; 32with Exp_Ch7; use Exp_Ch7; 33with Exp_Ch11; use Exp_Ch11; 34with Exp_Pakd; use Exp_Pakd; 35with Exp_Util; use Exp_Util; 36with Exp_Tss; use Exp_Tss; 37with Layout; use Layout; 38with Lib.Xref; use Lib.Xref; 39with Nlists; use Nlists; 40with Nmake; use Nmake; 41with Opt; use Opt; 42with Restrict; use Restrict; 43with Sem; use Sem; 44with Sem_Cat; use Sem_Cat; 45with Sem_Ch6; use Sem_Ch6; 46with Sem_Ch7; use Sem_Ch7; 47with Sem_Ch8; use Sem_Ch8; 48with Sem_Ch13; use Sem_Ch13; 49with Sem_Eval; use Sem_Eval; 50with Sem_Mech; use Sem_Mech; 51with Sem_Prag; use Sem_Prag; 52with Sem_Res; use Sem_Res; 53with Sem_Util; use Sem_Util; 54with Sinfo; use Sinfo; 55with Snames; use Snames; 56with Stand; use Stand; 57with Targparm; use Targparm; 58with Tbuild; use Tbuild; 59with Ttypes; use Ttypes; 60with Uintp; use Uintp; 61with Urealp; use Urealp; 62 63package body Freeze is 64 65 ----------------------- 66 -- Local Subprograms -- 67 ----------------------- 68 69 procedure Adjust_Esize_For_Alignment (Typ : Entity_Id); 70 -- Typ is a type that is being frozen. If no size clause is given, 71 -- but a default Esize has been computed, then this default Esize is 72 -- adjusted up if necessary to be consistent with a given alignment, 73 -- but never to a value greater than Long_Long_Integer'Size. This 74 -- is used for all discrete types and for fixed-point types. 75 76 procedure Build_And_Analyze_Renamed_Body 77 (Decl : Node_Id; 78 New_S : Entity_Id; 79 After : in out Node_Id); 80 -- Build body for a renaming declaration, insert in tree and analyze. 81 82 procedure Check_Address_Clause (E : Entity_Id); 83 -- Apply legality checks to address clauses for object declarations, 84 -- at the point the object is frozen. 85 86 procedure Check_Strict_Alignment (E : Entity_Id); 87 -- E is a base type. If E is tagged or has a component that is aliased 88 -- or tagged or contains something this is aliased or tagged, set 89 -- Strict_Alignment. 90 91 procedure Check_Unsigned_Type (E : Entity_Id); 92 pragma Inline (Check_Unsigned_Type); 93 -- If E is a fixed-point or discrete type, then all the necessary work 94 -- to freeze it is completed except for possible setting of the flag 95 -- Is_Unsigned_Type, which is done by this procedure. The call has no 96 -- effect if the entity E is not a discrete or fixed-point type. 97 98 procedure Freeze_And_Append 99 (Ent : Entity_Id; 100 Loc : Source_Ptr; 101 Result : in out List_Id); 102 -- Freezes Ent using Freeze_Entity, and appends the resulting list of 103 -- nodes to Result, modifying Result from No_List if necessary. 104 105 procedure Freeze_Enumeration_Type (Typ : Entity_Id); 106 -- Freeze enumeration type. The Esize field is set as processing 107 -- proceeds (i.e. set by default when the type is declared and then 108 -- adjusted by rep clauses. What this procedure does is to make sure 109 -- that if a foreign convention is specified, and no specific size 110 -- is given, then the size must be at least Integer'Size. 111 112 procedure Freeze_Static_Object (E : Entity_Id); 113 -- If an object is frozen which has Is_Statically_Allocated set, then 114 -- all referenced types must also be marked with this flag. This routine 115 -- is in charge of meeting this requirement for the object entity E. 116 117 procedure Freeze_Subprogram (E : Entity_Id); 118 -- Perform freezing actions for a subprogram (create extra formals, 119 -- and set proper default mechanism values). Note that this routine 120 -- is not called for internal subprograms, for which neither of these 121 -- actions is needed (or desirable, we do not want for example to have 122 -- these extra formals present in initialization procedures, where they 123 -- would serve no purpose). In this call E is either a subprogram or 124 -- a subprogram type (i.e. an access to a subprogram). 125 126 function Is_Fully_Defined (T : Entity_Id) return Boolean; 127 -- True if T is not private and has no private components, or has a full 128 -- view. Used to determine whether the designated type of an access type 129 -- should be frozen when the access type is frozen. This is done when an 130 -- allocator is frozen, or an expression that may involve attributes of 131 -- the designated type. Otherwise freezing the access type does not freeze 132 -- the designated type. 133 134 procedure Process_Default_Expressions 135 (E : Entity_Id; 136 After : in out Node_Id); 137 -- This procedure is called for each subprogram to complete processing 138 -- of default expressions at the point where all types are known to be 139 -- frozen. The expressions must be analyzed in full, to make sure that 140 -- all error processing is done (they have only been pre-analyzed). If 141 -- the expression is not an entity or literal, its analysis may generate 142 -- code which must not be executed. In that case we build a function 143 -- body to hold that code. This wrapper function serves no other purpose 144 -- (it used to be called to evaluate the default, but now the default is 145 -- inlined at each point of call). 146 147 procedure Set_Component_Alignment_If_Not_Set (Typ : Entity_Id); 148 -- Typ is a record or array type that is being frozen. This routine 149 -- sets the default component alignment from the scope stack values 150 -- if the alignment is otherwise not specified. 151 152 procedure Check_Debug_Info_Needed (T : Entity_Id); 153 -- As each entity is frozen, this routine is called to deal with the 154 -- setting of Debug_Info_Needed for the entity. This flag is set if 155 -- the entity comes from source, or if we are in Debug_Generated_Code 156 -- mode or if the -gnatdV debug flag is set. However, it never sets 157 -- the flag if Debug_Info_Off is set. 158 159 procedure Set_Debug_Info_Needed (T : Entity_Id); 160 -- Sets the Debug_Info_Needed flag on entity T if not already set, and 161 -- also on any entities that are needed by T (for an object, the type 162 -- of the object is needed, and for a type, the subsidiary types are 163 -- needed -- see body for details). Never has any effect on T if the 164 -- Debug_Info_Off flag is set. 165 166 procedure Warn_Overlay 167 (Expr : Node_Id; 168 Typ : Entity_Id; 169 Nam : Node_Id); 170 -- Expr is the expression for an address clause for entity Nam whose type 171 -- is Typ. If Typ has a default initialization, and there is no explicit 172 -- initialization in the source declaration, check whether the address 173 -- clause might cause overlaying of an entity, and emit a warning on the 174 -- side effect that the initialization will cause. 175 176 ------------------------------- 177 -- Adjust_Esize_For_Alignment -- 178 ------------------------------- 179 180 procedure Adjust_Esize_For_Alignment (Typ : Entity_Id) is 181 Align : Uint; 182 183 begin 184 if Known_Esize (Typ) and then Known_Alignment (Typ) then 185 Align := Alignment_In_Bits (Typ); 186 187 if Align > Esize (Typ) 188 and then Align <= Standard_Long_Long_Integer_Size 189 then 190 Set_Esize (Typ, Align); 191 end if; 192 end if; 193 end Adjust_Esize_For_Alignment; 194 195 ------------------------------------ 196 -- Build_And_Analyze_Renamed_Body -- 197 ------------------------------------ 198 199 procedure Build_And_Analyze_Renamed_Body 200 (Decl : Node_Id; 201 New_S : Entity_Id; 202 After : in out Node_Id) 203 is 204 Body_Node : constant Node_Id := Build_Renamed_Body (Decl, New_S); 205 206 begin 207 Insert_After (After, Body_Node); 208 Mark_Rewrite_Insertion (Body_Node); 209 Analyze (Body_Node); 210 After := Body_Node; 211 end Build_And_Analyze_Renamed_Body; 212 213 ------------------------ 214 -- Build_Renamed_Body -- 215 ------------------------ 216 217 function Build_Renamed_Body 218 (Decl : Node_Id; 219 New_S : Entity_Id) return Node_Id 220 is 221 Loc : constant Source_Ptr := Sloc (New_S); 222 -- We use for the source location of the renamed body, the location 223 -- of the spec entity. It might seem more natural to use the location 224 -- of the renaming declaration itself, but that would be wrong, since 225 -- then the body we create would look as though it was created far 226 -- too late, and this could cause problems with elaboration order 227 -- analysis, particularly in connection with instantiations. 228 229 N : constant Node_Id := Unit_Declaration_Node (New_S); 230 Nam : constant Node_Id := Name (N); 231 Old_S : Entity_Id; 232 Spec : constant Node_Id := New_Copy_Tree (Specification (Decl)); 233 Actuals : List_Id := No_List; 234 Call_Node : Node_Id; 235 Call_Name : Node_Id; 236 Body_Node : Node_Id; 237 Formal : Entity_Id; 238 O_Formal : Entity_Id; 239 Param_Spec : Node_Id; 240 241 begin 242 -- Determine the entity being renamed, which is the target of the 243 -- call statement. If the name is an explicit dereference, this is 244 -- a renaming of a subprogram type rather than a subprogram. The 245 -- name itself is fully analyzed. 246 247 if Nkind (Nam) = N_Selected_Component then 248 Old_S := Entity (Selector_Name (Nam)); 249 250 elsif Nkind (Nam) = N_Explicit_Dereference then 251 Old_S := Etype (Nam); 252 253 elsif Nkind (Nam) = N_Indexed_Component then 254 if Is_Entity_Name (Prefix (Nam)) then 255 Old_S := Entity (Prefix (Nam)); 256 else 257 Old_S := Entity (Selector_Name (Prefix (Nam))); 258 end if; 259 260 elsif Nkind (Nam) = N_Character_Literal then 261 Old_S := Etype (New_S); 262 263 else 264 Old_S := Entity (Nam); 265 end if; 266 267 if Is_Entity_Name (Nam) then 268 269 -- If the renamed entity is a predefined operator, retain full 270 -- name to ensure its visibility. 271 272 if Ekind (Old_S) = E_Operator 273 and then Nkind (Nam) = N_Expanded_Name 274 then 275 Call_Name := New_Copy (Name (N)); 276 else 277 Call_Name := New_Reference_To (Old_S, Loc); 278 end if; 279 280 else 281 Call_Name := New_Copy (Name (N)); 282 283 -- The original name may have been overloaded, but 284 -- is fully resolved now. 285 286 Set_Is_Overloaded (Call_Name, False); 287 end if; 288 289 -- For simple renamings, subsequent calls can be expanded directly 290 -- as called to the renamed entity. The body must be generated in 291 -- any case for calls they may appear elsewhere. 292 293 if (Ekind (Old_S) = E_Function 294 or else Ekind (Old_S) = E_Procedure) 295 and then Nkind (Decl) = N_Subprogram_Declaration 296 then 297 Set_Body_To_Inline (Decl, Old_S); 298 end if; 299 300 -- The body generated for this renaming is an internal artifact, and 301 -- does not constitute a freeze point for the called entity. 302 303 Set_Must_Not_Freeze (Call_Name); 304 305 Formal := First_Formal (Defining_Entity (Decl)); 306 307 if Present (Formal) then 308 Actuals := New_List; 309 310 while Present (Formal) loop 311 Append (New_Reference_To (Formal, Loc), Actuals); 312 Next_Formal (Formal); 313 end loop; 314 end if; 315 316 -- If the renamed entity is an entry, inherit its profile. For 317 -- other renamings as bodies, both profiles must be subtype 318 -- conformant, so it is not necessary to replace the profile given 319 -- in the declaration. However, default values that are aggregates 320 -- are rewritten when partially analyzed, so we recover the original 321 -- aggregate to insure that subsequent conformity checking works. 322 -- Similarly, if the default expression was constant-folded, recover 323 -- the original expression. 324 325 Formal := First_Formal (Defining_Entity (Decl)); 326 327 if Present (Formal) then 328 O_Formal := First_Formal (Old_S); 329 Param_Spec := First (Parameter_Specifications (Spec)); 330 331 while Present (Formal) loop 332 if Is_Entry (Old_S) then 333 334 if Nkind (Parameter_Type (Param_Spec)) /= 335 N_Access_Definition 336 then 337 Set_Etype (Formal, Etype (O_Formal)); 338 Set_Entity (Parameter_Type (Param_Spec), Etype (O_Formal)); 339 end if; 340 341 elsif Nkind (Default_Value (O_Formal)) = N_Aggregate 342 or else Nkind (Original_Node (Default_Value (O_Formal))) /= 343 Nkind (Default_Value (O_Formal)) 344 then 345 Set_Expression (Param_Spec, 346 New_Copy_Tree (Original_Node (Default_Value (O_Formal)))); 347 end if; 348 349 Next_Formal (Formal); 350 Next_Formal (O_Formal); 351 Next (Param_Spec); 352 end loop; 353 end if; 354 355 -- If the renamed entity is a function, the generated body contains a 356 -- return statement. Otherwise, build a procedure call. If the entity is 357 -- an entry, subsequent analysis of the call will transform it into the 358 -- proper entry or protected operation call. If the renamed entity is 359 -- a character literal, return it directly. 360 361 if Ekind (Old_S) = E_Function 362 or else Ekind (Old_S) = E_Operator 363 or else (Ekind (Old_S) = E_Subprogram_Type 364 and then Etype (Old_S) /= Standard_Void_Type) 365 then 366 Call_Node := 367 Make_Return_Statement (Loc, 368 Expression => 369 Make_Function_Call (Loc, 370 Name => Call_Name, 371 Parameter_Associations => Actuals)); 372 373 elsif Ekind (Old_S) = E_Enumeration_Literal then 374 Call_Node := 375 Make_Return_Statement (Loc, 376 Expression => New_Occurrence_Of (Old_S, Loc)); 377 378 elsif Nkind (Nam) = N_Character_Literal then 379 Call_Node := 380 Make_Return_Statement (Loc, 381 Expression => Call_Name); 382 383 else 384 Call_Node := 385 Make_Procedure_Call_Statement (Loc, 386 Name => Call_Name, 387 Parameter_Associations => Actuals); 388 end if; 389 390 -- Create entities for subprogram body and formals. 391 392 Set_Defining_Unit_Name (Spec, 393 Make_Defining_Identifier (Loc, Chars => Chars (New_S))); 394 395 Param_Spec := First (Parameter_Specifications (Spec)); 396 397 while Present (Param_Spec) loop 398 Set_Defining_Identifier (Param_Spec, 399 Make_Defining_Identifier (Loc, 400 Chars => Chars (Defining_Identifier (Param_Spec)))); 401 Next (Param_Spec); 402 end loop; 403 404 Body_Node := 405 Make_Subprogram_Body (Loc, 406 Specification => Spec, 407 Declarations => New_List, 408 Handled_Statement_Sequence => 409 Make_Handled_Sequence_Of_Statements (Loc, 410 Statements => New_List (Call_Node))); 411 412 if Nkind (Decl) /= N_Subprogram_Declaration then 413 Rewrite (N, 414 Make_Subprogram_Declaration (Loc, 415 Specification => Specification (N))); 416 end if; 417 418 -- Link the body to the entity whose declaration it completes. If 419 -- the body is analyzed when the renamed entity is frozen, it may be 420 -- necessary to restore the proper scope (see package Exp_Ch13). 421 422 if Nkind (N) = N_Subprogram_Renaming_Declaration 423 and then Present (Corresponding_Spec (N)) 424 then 425 Set_Corresponding_Spec (Body_Node, Corresponding_Spec (N)); 426 else 427 Set_Corresponding_Spec (Body_Node, New_S); 428 end if; 429 430 return Body_Node; 431 end Build_Renamed_Body; 432 433 -------------------------- 434 -- Check_Address_Clause -- 435 -------------------------- 436 437 procedure Check_Address_Clause (E : Entity_Id) is 438 Addr : constant Node_Id := Address_Clause (E); 439 Expr : Node_Id; 440 Decl : constant Node_Id := Declaration_Node (E); 441 Typ : constant Entity_Id := Etype (E); 442 443 begin 444 if Present (Addr) then 445 Expr := Expression (Addr); 446 447 -- If we have no initialization of any kind, then we don't 448 -- need to place any restrictions on the address clause, because 449 -- the object will be elaborated after the address clause is 450 -- evaluated. This happens if the declaration has no initial 451 -- expression, or the type has no implicit initialization, or 452 -- the object is imported. 453 454 -- The same holds for all initialized scalar types and all 455 -- access types. Packed bit arrays of size up to 64 are 456 -- represented using a modular type with an initialization 457 -- (to zero) and can be processed like other initialized 458 -- scalar types. 459 460 -- If the type is controlled, code to attach the object to a 461 -- finalization chain is generated at the point of declaration, 462 -- and therefore the elaboration of the object cannot be delayed: 463 -- the address expression must be a constant. 464 465 if (No (Expression (Decl)) 466 and then not Controlled_Type (Typ) 467 and then 468 (not Has_Non_Null_Base_Init_Proc (Typ) 469 or else Is_Imported (E))) 470 471 or else 472 (Present (Expression (Decl)) 473 and then Is_Scalar_Type (Typ)) 474 475 or else 476 Is_Access_Type (Typ) 477 478 or else 479 (Is_Bit_Packed_Array (Typ) 480 and then 481 Is_Modular_Integer_Type (Packed_Array_Type (Typ))) 482 then 483 null; 484 485 -- Otherwise, we require the address clause to be constant 486 -- because the call to the initialization procedure (or the 487 -- attach code) has to happen at the point of the declaration. 488 489 else 490 Check_Constant_Address_Clause (Expr, E); 491 Set_Has_Delayed_Freeze (E, False); 492 end if; 493 494 if not Error_Posted (Expr) 495 and then not Controlled_Type (Typ) 496 then 497 Warn_Overlay (Expr, Typ, Name (Addr)); 498 end if; 499 end if; 500 end Check_Address_Clause; 501 502 ----------------------------- 503 -- Check_Compile_Time_Size -- 504 ----------------------------- 505 506 procedure Check_Compile_Time_Size (T : Entity_Id) is 507 508 procedure Set_Small_Size (S : Uint); 509 -- Sets the compile time known size (32 bits or less) in the Esize 510 -- field, checking for a size clause that was given which attempts 511 -- to give a smaller size. 512 513 function Size_Known (T : Entity_Id) return Boolean; 514 -- Recursive function that does all the work 515 516 function Static_Discriminated_Components (T : Entity_Id) return Boolean; 517 -- If T is a constrained subtype, its size is not known if any of its 518 -- discriminant constraints is not static and it is not a null record. 519 -- The test is conservative and doesn't check that the components are 520 -- in fact constrained by non-static discriminant values. Could be made 521 -- more precise ??? 522 523 -------------------- 524 -- Set_Small_Size -- 525 -------------------- 526 527 procedure Set_Small_Size (S : Uint) is 528 begin 529 if S > 32 then 530 return; 531 532 elsif Has_Size_Clause (T) then 533 if RM_Size (T) < S then 534 Error_Msg_Uint_1 := S; 535 Error_Msg_NE 536 ("size for & is too small, minimum is ^", 537 Size_Clause (T), T); 538 539 elsif Unknown_Esize (T) then 540 Set_Esize (T, S); 541 end if; 542 543 -- Set sizes if not set already 544 545 else 546 if Unknown_Esize (T) then 547 Set_Esize (T, S); 548 end if; 549 550 if Unknown_RM_Size (T) then 551 Set_RM_Size (T, S); 552 end if; 553 end if; 554 end Set_Small_Size; 555 556 ---------------- 557 -- Size_Known -- 558 ---------------- 559 560 function Size_Known (T : Entity_Id) return Boolean is 561 Index : Entity_Id; 562 Comp : Entity_Id; 563 Ctyp : Entity_Id; 564 Low : Node_Id; 565 High : Node_Id; 566 567 begin 568 if Size_Known_At_Compile_Time (T) then 569 return True; 570 571 elsif Is_Scalar_Type (T) 572 or else Is_Task_Type (T) 573 then 574 return not Is_Generic_Type (T); 575 576 elsif Is_Array_Type (T) then 577 if Ekind (T) = E_String_Literal_Subtype then 578 Set_Small_Size (Component_Size (T) * String_Literal_Length (T)); 579 return True; 580 581 elsif not Is_Constrained (T) then 582 return False; 583 584 -- Don't do any recursion on type with error posted, since 585 -- we may have a malformed type that leads us into a loop 586 587 elsif Error_Posted (T) then 588 return False; 589 590 elsif not Size_Known (Component_Type (T)) then 591 return False; 592 end if; 593 594 -- Check for all indexes static, and also compute possible 595 -- size (in case it is less than 32 and may be packable). 596 597 declare 598 Esiz : Uint := Component_Size (T); 599 Dim : Uint; 600 601 begin 602 Index := First_Index (T); 603 604 while Present (Index) loop 605 if Nkind (Index) = N_Range then 606 Get_Index_Bounds (Index, Low, High); 607 608 elsif Error_Posted (Scalar_Range (Etype (Index))) then 609 return False; 610 611 else 612 Low := Type_Low_Bound (Etype (Index)); 613 High := Type_High_Bound (Etype (Index)); 614 end if; 615 616 if not Compile_Time_Known_Value (Low) 617 or else not Compile_Time_Known_Value (High) 618 or else Etype (Index) = Any_Type 619 then 620 return False; 621 622 else 623 Dim := Expr_Value (High) - Expr_Value (Low) + 1; 624 625 if Dim >= 0 then 626 Esiz := Esiz * Dim; 627 else 628 Esiz := Uint_0; 629 end if; 630 end if; 631 632 Next_Index (Index); 633 end loop; 634 635 Set_Small_Size (Esiz); 636 return True; 637 end; 638 639 elsif Is_Access_Type (T) then 640 return True; 641 642 elsif Is_Private_Type (T) 643 and then not Is_Generic_Type (T) 644 and then Present (Underlying_Type (T)) 645 then 646 -- Don't do any recursion on type with error posted, since 647 -- we may have a malformed type that leads us into a loop 648 649 if Error_Posted (T) then 650 return False; 651 else 652 return Size_Known (Underlying_Type (T)); 653 end if; 654 655 elsif Is_Record_Type (T) then 656 657 -- A class-wide type is never considered to have a known size 658 659 if Is_Class_Wide_Type (T) then 660 return False; 661 662 -- A subtype of a variant record must not have non-static 663 -- discriminanted components. 664 665 elsif T /= Base_Type (T) 666 and then not Static_Discriminated_Components (T) 667 then 668 return False; 669 670 -- Don't do any recursion on type with error posted, since 671 -- we may have a malformed type that leads us into a loop 672 673 elsif Error_Posted (T) then 674 return False; 675 end if; 676 677 -- Now look at the components of the record 678 679 declare 680 -- The following two variables are used to keep track of 681 -- the size of packed records if we can tell the size of 682 -- the packed record in the front end. Packed_Size_Known 683 -- is True if so far we can figure out the size. It is 684 -- initialized to True for a packed record, unless the 685 -- record has discriminants. The reason we eliminate the 686 -- discriminated case is that we don't know the way the 687 -- back end lays out discriminated packed records. If 688 -- Packed_Size_Known is True, then Packed_Size is the 689 -- size in bits so far. 690 691 Packed_Size_Known : Boolean := 692 Is_Packed (T) 693 and then not Has_Discriminants (T); 694 695 Packed_Size : Uint := Uint_0; 696 697 begin 698 -- Test for variant part present 699 700 if Has_Discriminants (T) 701 and then Present (Parent (T)) 702 and then Nkind (Parent (T)) = N_Full_Type_Declaration 703 and then Nkind (Type_Definition (Parent (T))) = 704 N_Record_Definition 705 and then not Null_Present (Type_Definition (Parent (T))) 706 and then Present (Variant_Part 707 (Component_List (Type_Definition (Parent (T))))) 708 then 709 -- If variant part is present, and type is unconstrained, 710 -- then we must have defaulted discriminants, or a size 711 -- clause must be present for the type, or else the size 712 -- is definitely not known at compile time. 713 714 if not Is_Constrained (T) 715 and then 716 No (Discriminant_Default_Value 717 (First_Discriminant (T))) 718 and then Unknown_Esize (T) 719 then 720 return False; 721 end if; 722 end if; 723 724 -- Loop through components 725 726 Comp := First_Entity (T); 727 while Present (Comp) loop 728 if Ekind (Comp) = E_Component 729 or else 730 Ekind (Comp) = E_Discriminant 731 then 732 Ctyp := Etype (Comp); 733 734 -- We do not know the packed size if there is a 735 -- component clause present (we possibly could, 736 -- but this would only help in the case of a record 737 -- with partial rep clauses. That's because in the 738 -- case of full rep clauses, the size gets figured 739 -- out anyway by a different circuit). 740 741 if Present (Component_Clause (Comp)) then 742 Packed_Size_Known := False; 743 end if; 744 745 -- We need to identify a component that is an array 746 -- where the index type is an enumeration type with 747 -- non-standard representation, and some bound of the 748 -- type depends on a discriminant. 749 750 -- This is because gigi computes the size by doing a 751 -- substituation of the appropriate discriminant value 752 -- in the size expression for the base type, and gigi 753 -- is not clever enough to evaluate the resulting 754 -- expression (which involves a call to rep_to_pos) 755 -- at compile time. 756 757 -- It would be nice if gigi would either recognize that 758 -- this expression can be computed at compile time, or 759 -- alternatively figured out the size from the subtype 760 -- directly, where all the information is at hand ??? 761 762 if Is_Array_Type (Etype (Comp)) 763 and then Present (Packed_Array_Type (Etype (Comp))) 764 then 765 declare 766 Ocomp : constant Entity_Id := 767 Original_Record_Component (Comp); 768 OCtyp : constant Entity_Id := Etype (Ocomp); 769 Ind : Node_Id; 770 Indtyp : Entity_Id; 771 Lo, Hi : Node_Id; 772 773 begin 774 Ind := First_Index (OCtyp); 775 while Present (Ind) loop 776 Indtyp := Etype (Ind); 777 778 if Is_Enumeration_Type (Indtyp) 779 and then Has_Non_Standard_Rep (Indtyp) 780 then 781 Lo := Type_Low_Bound (Indtyp); 782 Hi := Type_High_Bound (Indtyp); 783 784 if Is_Entity_Name (Lo) 785 and then 786 Ekind (Entity (Lo)) = E_Discriminant 787 then 788 return False; 789 790 elsif Is_Entity_Name (Hi) 791 and then 792 Ekind (Entity (Hi)) = E_Discriminant 793 then 794 return False; 795 end if; 796 end if; 797 798 Next_Index (Ind); 799 end loop; 800 end; 801 end if; 802 803 -- Clearly size of record is not known if the size of 804 -- one of the components is not known. 805 806 if not Size_Known (Ctyp) then 807 return False; 808 end if; 809 810 -- Accumulate packed size if possible 811 812 if Packed_Size_Known then 813 814 -- We can only deal with elementary types, since for 815 -- non-elementary components, alignment enters into 816 -- the picture, and we don't know enough to handle 817 -- proper alignment in this context. Packed arrays 818 -- count as elementary if the representation is a 819 -- modular type. 820 821 if Is_Elementary_Type (Ctyp) 822 or else (Is_Array_Type (Ctyp) 823 and then 824 Present (Packed_Array_Type (Ctyp)) 825 and then 826 Is_Modular_Integer_Type 827 (Packed_Array_Type (Ctyp))) 828 then 829 -- If RM_Size is known and static, then we can 830 -- keep accumulating the packed size. 831 832 if Known_Static_RM_Size (Ctyp) then 833 834 -- A little glitch, to be removed sometime ??? 835 -- gigi does not understand zero sizes yet. 836 837 if RM_Size (Ctyp) = Uint_0 then 838 Packed_Size_Known := False; 839 840 -- Normal case where we can keep accumulating 841 -- the packed array size. 842 843 else 844 Packed_Size := Packed_Size + RM_Size (Ctyp); 845 end if; 846 847 -- If we have a field whose RM_Size is not known 848 -- then we can't figure out the packed size here. 849 850 else 851 Packed_Size_Known := False; 852 end if; 853 854 -- If we have a non-elementary type we can't figure 855 -- out the packed array size (alignment issues). 856 857 else 858 Packed_Size_Known := False; 859 end if; 860 end if; 861 end if; 862 863 Next_Entity (Comp); 864 end loop; 865 866 if Packed_Size_Known then 867 Set_Small_Size (Packed_Size); 868 end if; 869 870 return True; 871 end; 872 873 else 874 return False; 875 end if; 876 end Size_Known; 877 878 ------------------------------------- 879 -- Static_Discriminated_Components -- 880 ------------------------------------- 881 882 function Static_Discriminated_Components 883 (T : Entity_Id) 884 return Boolean 885 is 886 Constraint : Elmt_Id; 887 888 begin 889 if Has_Discriminants (T) 890 and then Present (Discriminant_Constraint (T)) 891 and then Present (First_Component (T)) 892 then 893 Constraint := First_Elmt (Discriminant_Constraint (T)); 894 while Present (Constraint) loop 895 if not Compile_Time_Known_Value (Node (Constraint)) then 896 return False; 897 end if; 898 899 Next_Elmt (Constraint); 900 end loop; 901 end if; 902 903 return True; 904 end Static_Discriminated_Components; 905 906 -- Start of processing for Check_Compile_Time_Size 907 908 begin 909 Set_Size_Known_At_Compile_Time (T, Size_Known (T)); 910 end Check_Compile_Time_Size; 911 912 ----------------------------- 913 -- Check_Debug_Info_Needed -- 914 ----------------------------- 915 916 procedure Check_Debug_Info_Needed (T : Entity_Id) is 917 begin 918 if Needs_Debug_Info (T) or else Debug_Info_Off (T) then 919 return; 920 921 elsif Comes_From_Source (T) 922 or else Debug_Generated_Code 923 or else Debug_Flag_VV 924 then 925 Set_Debug_Info_Needed (T); 926 end if; 927 end Check_Debug_Info_Needed; 928 929 ---------------------------- 930 -- Check_Strict_Alignment -- 931 ---------------------------- 932 933 procedure Check_Strict_Alignment (E : Entity_Id) is 934 Comp : Entity_Id; 935 936 begin 937 if Is_Tagged_Type (E) or else Is_Concurrent_Type (E) then 938 Set_Strict_Alignment (E); 939 940 elsif Is_Array_Type (E) then 941 Set_Strict_Alignment (E, Strict_Alignment (Component_Type (E))); 942 943 elsif Is_Record_Type (E) then 944 if Is_Limited_Record (E) then 945 Set_Strict_Alignment (E); 946 return; 947 end if; 948 949 Comp := First_Component (E); 950 951 while Present (Comp) loop 952 if not Is_Type (Comp) 953 and then (Strict_Alignment (Etype (Comp)) 954 or else Is_Aliased (Comp)) 955 then 956 Set_Strict_Alignment (E); 957 return; 958 end if; 959 960 Next_Component (Comp); 961 end loop; 962 end if; 963 end Check_Strict_Alignment; 964 965 ------------------------- 966 -- Check_Unsigned_Type -- 967 ------------------------- 968 969 procedure Check_Unsigned_Type (E : Entity_Id) is 970 Ancestor : Entity_Id; 971 Lo_Bound : Node_Id; 972 Btyp : Entity_Id; 973 974 begin 975 if not Is_Discrete_Or_Fixed_Point_Type (E) then 976 return; 977 end if; 978 979 -- Do not attempt to analyze case where range was in error 980 981 if Error_Posted (Scalar_Range (E)) then 982 return; 983 end if; 984 985 -- The situation that is non trivial is something like 986 987 -- subtype x1 is integer range -10 .. +10; 988 -- subtype x2 is x1 range 0 .. V1; 989 -- subtype x3 is x2 range V2 .. V3; 990 -- subtype x4 is x3 range V4 .. V5; 991 992 -- where Vn are variables. Here the base type is signed, but we still 993 -- know that x4 is unsigned because of the lower bound of x2. 994 995 -- The only way to deal with this is to look up the ancestor chain 996 997 Ancestor := E; 998 loop 999 if Ancestor = Any_Type or else Etype (Ancestor) = Any_Type then 1000 return; 1001 end if; 1002 1003 Lo_Bound := Type_Low_Bound (Ancestor); 1004 1005 if Compile_Time_Known_Value (Lo_Bound) then 1006 1007 if Expr_Rep_Value (Lo_Bound) >= 0 then 1008 Set_Is_Unsigned_Type (E, True); 1009 end if; 1010 1011 return; 1012 1013 else 1014 Ancestor := Ancestor_Subtype (Ancestor); 1015 1016 -- If no ancestor had a static lower bound, go to base type 1017 1018 if No (Ancestor) then 1019 1020 -- Note: the reason we still check for a compile time known 1021 -- value for the base type is that at least in the case of 1022 -- generic formals, we can have bounds that fail this test, 1023 -- and there may be other cases in error situations. 1024 1025 Btyp := Base_Type (E); 1026 1027 if Btyp = Any_Type or else Etype (Btyp) = Any_Type then 1028 return; 1029 end if; 1030 1031 Lo_Bound := Type_Low_Bound (Base_Type (E)); 1032 1033 if Compile_Time_Known_Value (Lo_Bound) 1034 and then Expr_Rep_Value (Lo_Bound) >= 0 1035 then 1036 Set_Is_Unsigned_Type (E, True); 1037 end if; 1038 1039 return; 1040 end if; 1041 end if; 1042 end loop; 1043 end Check_Unsigned_Type; 1044 1045 ----------------------------- 1046 -- Expand_Atomic_Aggregate -- 1047 ----------------------------- 1048 1049 procedure Expand_Atomic_Aggregate (E : Entity_Id; Typ : Entity_Id) is 1050 Loc : constant Source_Ptr := Sloc (E); 1051 New_N : Node_Id; 1052 Temp : Entity_Id; 1053 1054 begin 1055 if (Nkind (Parent (E)) = N_Object_Declaration 1056 or else Nkind (Parent (E)) = N_Assignment_Statement) 1057 and then Comes_From_Source (Parent (E)) 1058 and then Nkind (E) = N_Aggregate 1059 then 1060 Temp := 1061 Make_Defining_Identifier (Loc, 1062 New_Internal_Name ('T')); 1063 1064 New_N := 1065 Make_Object_Declaration (Loc, 1066 Defining_Identifier => Temp, 1067 Object_definition => New_Occurrence_Of (Typ, Loc), 1068 Expression => Relocate_Node (E)); 1069 Insert_Before (Parent (E), New_N); 1070 Analyze (New_N); 1071 1072 Set_Expression (Parent (E), New_Occurrence_Of (Temp, Loc)); 1073 1074 -- To prevent the temporary from being constant-folded (which 1075 -- would lead to the same piecemeal assignment on the original 1076 -- target) indicate to the back-end that the temporary is a 1077 -- variable with real storage. See description of this flag 1078 -- in Einfo, and the notes on N_Assignment_Statement and 1079 -- N_Object_Declaration in Sinfo. 1080 1081 Set_Is_True_Constant (Temp, False); 1082 end if; 1083 end Expand_Atomic_Aggregate; 1084 1085 ---------------- 1086 -- Freeze_All -- 1087 ---------------- 1088 1089 -- Note: the easy coding for this procedure would be to just build a 1090 -- single list of freeze nodes and then insert them and analyze them 1091 -- all at once. This won't work, because the analysis of earlier freeze 1092 -- nodes may recursively freeze types which would otherwise appear later 1093 -- on in the freeze list. So we must analyze and expand the freeze nodes 1094 -- as they are generated. 1095 1096 procedure Freeze_All (From : Entity_Id; After : in out Node_Id) is 1097 Loc : constant Source_Ptr := Sloc (After); 1098 E : Entity_Id; 1099 Decl : Node_Id; 1100 1101 procedure Freeze_All_Ent (From : Entity_Id; After : in out Node_Id); 1102 -- This is the internal recursive routine that does freezing of 1103 -- entities (but NOT the analysis of default expressions, which 1104 -- should not be recursive, we don't want to analyze those till 1105 -- we are sure that ALL the types are frozen). 1106 1107 -------------------- 1108 -- Freeze_All_Ent -- 1109 -------------------- 1110 1111 procedure Freeze_All_Ent 1112 (From : Entity_Id; 1113 After : in out Node_Id) 1114 is 1115 E : Entity_Id; 1116 Flist : List_Id; 1117 Lastn : Node_Id; 1118 1119 procedure Process_Flist; 1120 -- If freeze nodes are present, insert and analyze, and reset 1121 -- cursor for next insertion. 1122 1123 ------------------- 1124 -- Process_Flist -- 1125 ------------------- 1126 1127 procedure Process_Flist is 1128 begin 1129 if Is_Non_Empty_List (Flist) then 1130 Lastn := Next (After); 1131 Insert_List_After_And_Analyze (After, Flist); 1132 1133 if Present (Lastn) then 1134 After := Prev (Lastn); 1135 else 1136 After := Last (List_Containing (After)); 1137 end if; 1138 end if; 1139 end Process_Flist; 1140 1141 -- Start or processing for Freeze_All_Ent 1142 1143 begin 1144 E := From; 1145 while Present (E) loop 1146 1147 -- If the entity is an inner package which is not a package 1148 -- renaming, then its entities must be frozen at this point. 1149 -- Note that such entities do NOT get frozen at the end of 1150 -- the nested package itself (only library packages freeze). 1151 1152 -- Same is true for task declarations, where anonymous records 1153 -- created for entry parameters must be frozen. 1154 1155 if Ekind (E) = E_Package 1156 and then No (Renamed_Object (E)) 1157 and then not Is_Child_Unit (E) 1158 and then not Is_Frozen (E) 1159 then 1160 New_Scope (E); 1161 Install_Visible_Declarations (E); 1162 Install_Private_Declarations (E); 1163 1164 Freeze_All (First_Entity (E), After); 1165 1166 End_Package_Scope (E); 1167 1168 elsif Ekind (E) in Task_Kind 1169 and then 1170 (Nkind (Parent (E)) = N_Task_Type_Declaration 1171 or else 1172 Nkind (Parent (E)) = N_Single_Task_Declaration) 1173 then 1174 New_Scope (E); 1175 Freeze_All (First_Entity (E), After); 1176 End_Scope; 1177 1178 -- For a derived tagged type, we must ensure that all the 1179 -- primitive operations of the parent have been frozen, so 1180 -- that their addresses will be in the parent's dispatch table 1181 -- at the point it is inherited. 1182 1183 elsif Ekind (E) = E_Record_Type 1184 and then Is_Tagged_Type (E) 1185 and then Is_Tagged_Type (Etype (E)) 1186 and then Is_Derived_Type (E) 1187 then 1188 declare 1189 Prim_List : constant Elist_Id := 1190 Primitive_Operations (Etype (E)); 1191 1192 Prim : Elmt_Id; 1193 Subp : Entity_Id; 1194 1195 begin 1196 Prim := First_Elmt (Prim_List); 1197 1198 while Present (Prim) loop 1199 Subp := Node (Prim); 1200 1201 if Comes_From_Source (Subp) 1202 and then not Is_Frozen (Subp) 1203 then 1204 Flist := Freeze_Entity (Subp, Loc); 1205 Process_Flist; 1206 end if; 1207 1208 Next_Elmt (Prim); 1209 end loop; 1210 end; 1211 end if; 1212 1213 if not Is_Frozen (E) then 1214 Flist := Freeze_Entity (E, Loc); 1215 Process_Flist; 1216 end if; 1217 1218 -- If an incomplete type is still not frozen, this may be 1219 -- a premature freezing because of a body declaration that 1220 -- follows. Indicate where the freezing took place. 1221 1222 -- If the freezing is caused by the end of the current 1223 -- declarative part, it is a Taft Amendment type, and there 1224 -- is no error. 1225 1226 if not Is_Frozen (E) 1227 and then Ekind (E) = E_Incomplete_Type 1228 then 1229 declare 1230 Bod : constant Node_Id := Next (After); 1231 1232 begin 1233 if (Nkind (Bod) = N_Subprogram_Body 1234 or else Nkind (Bod) = N_Entry_Body 1235 or else Nkind (Bod) = N_Package_Body 1236 or else Nkind (Bod) = N_Protected_Body 1237 or else Nkind (Bod) = N_Task_Body 1238 or else Nkind (Bod) in N_Body_Stub) 1239 and then 1240 List_Containing (After) = List_Containing (Parent (E)) 1241 then 1242 Error_Msg_Sloc := Sloc (Next (After)); 1243 Error_Msg_NE 1244 ("type& is frozen# before its full declaration", 1245 Parent (E), E); 1246 end if; 1247 end; 1248 end if; 1249 1250 Next_Entity (E); 1251 end loop; 1252 end Freeze_All_Ent; 1253 1254 -- Start of processing for Freeze_All 1255 1256 begin 1257 Freeze_All_Ent (From, After); 1258 1259 -- Now that all types are frozen, we can deal with default expressions 1260 -- that require us to build a default expression functions. This is the 1261 -- point at which such functions are constructed (after all types that 1262 -- might be used in such expressions have been frozen). 1263 1264 -- We also add finalization chains to access types whose designated 1265 -- types are controlled. This is normally done when freezing the type, 1266 -- but this misses recursive type definitions where the later members 1267 -- of the recursion introduce controlled components (e.g. 5624-001). 1268 1269 -- Loop through entities 1270 1271 E := From; 1272 while Present (E) loop 1273 if Is_Subprogram (E) then 1274 1275 if not Default_Expressions_Processed (E) then 1276 Process_Default_Expressions (E, After); 1277 end if; 1278 1279 if not Has_Completion (E) then 1280 Decl := Unit_Declaration_Node (E); 1281 1282 if Nkind (Decl) = N_Subprogram_Renaming_Declaration then 1283 Build_And_Analyze_Renamed_Body (Decl, E, After); 1284 1285 elsif Nkind (Decl) = N_Subprogram_Declaration 1286 and then Present (Corresponding_Body (Decl)) 1287 and then 1288 Nkind (Unit_Declaration_Node (Corresponding_Body (Decl))) 1289 = N_Subprogram_Renaming_Declaration 1290 then 1291 Build_And_Analyze_Renamed_Body 1292 (Decl, Corresponding_Body (Decl), After); 1293 end if; 1294 end if; 1295 1296 elsif Ekind (E) in Task_Kind 1297 and then 1298 (Nkind (Parent (E)) = N_Task_Type_Declaration 1299 or else 1300 Nkind (Parent (E)) = N_Single_Task_Declaration) 1301 then 1302 declare 1303 Ent : Entity_Id; 1304 begin 1305 Ent := First_Entity (E); 1306 1307 while Present (Ent) loop 1308 1309 if Is_Entry (Ent) 1310 and then not Default_Expressions_Processed (Ent) 1311 then 1312 Process_Default_Expressions (Ent, After); 1313 end if; 1314 1315 Next_Entity (Ent); 1316 end loop; 1317 end; 1318 1319 elsif Is_Access_Type (E) 1320 and then Comes_From_Source (E) 1321 and then Ekind (Directly_Designated_Type (E)) = E_Incomplete_Type 1322 and then Controlled_Type (Designated_Type (E)) 1323 and then No (Associated_Final_Chain (E)) 1324 then 1325 Build_Final_List (Parent (E), E); 1326 end if; 1327 1328 Next_Entity (E); 1329 end loop; 1330 end Freeze_All; 1331 1332 ----------------------- 1333 -- Freeze_And_Append -- 1334 ----------------------- 1335 1336 procedure Freeze_And_Append 1337 (Ent : Entity_Id; 1338 Loc : Source_Ptr; 1339 Result : in out List_Id) 1340 is 1341 L : constant List_Id := Freeze_Entity (Ent, Loc); 1342 1343 begin 1344 if Is_Non_Empty_List (L) then 1345 if Result = No_List then 1346 Result := L; 1347 else 1348 Append_List (L, Result); 1349 end if; 1350 end if; 1351 end Freeze_And_Append; 1352 1353 ------------------- 1354 -- Freeze_Before -- 1355 ------------------- 1356 1357 procedure Freeze_Before (N : Node_Id; T : Entity_Id) is 1358 Freeze_Nodes : constant List_Id := Freeze_Entity (T, Sloc (N)); 1359 1360 begin 1361 if Is_Non_Empty_List (Freeze_Nodes) then 1362 Insert_Actions (N, Freeze_Nodes); 1363 end if; 1364 end Freeze_Before; 1365 1366 ------------------- 1367 -- Freeze_Entity -- 1368 ------------------- 1369 1370 function Freeze_Entity (E : Entity_Id; Loc : Source_Ptr) return List_Id is 1371 Comp : Entity_Id; 1372 F_Node : Node_Id; 1373 Result : List_Id; 1374 Indx : Node_Id; 1375 Formal : Entity_Id; 1376 Atype : Entity_Id; 1377 1378 procedure Check_Current_Instance (Comp_Decl : Node_Id); 1379 -- Check that an Access or Unchecked_Access attribute with 1380 -- a prefix which is the current instance type can only be 1381 -- applied when the type is limited. 1382 1383 function After_Last_Declaration return Boolean; 1384 -- If Loc is a freeze_entity that appears after the last declaration 1385 -- in the scope, inhibit error messages on late completion. 1386 1387 procedure Freeze_Record_Type (Rec : Entity_Id); 1388 -- Freeze each component, handle some representation clauses, and 1389 -- freeze primitive operations if this is a tagged type. 1390 1391 ---------------------------- 1392 -- After_Last_Declaration -- 1393 ---------------------------- 1394 1395 function After_Last_Declaration return Boolean is 1396 Spec : constant Node_Id := Parent (Current_Scope); 1397 1398 begin 1399 if Nkind (Spec) = N_Package_Specification then 1400 if Present (Private_Declarations (Spec)) then 1401 return Loc >= Sloc (Last (Private_Declarations (Spec))); 1402 1403 elsif Present (Visible_Declarations (Spec)) then 1404 return Loc >= Sloc (Last (Visible_Declarations (Spec))); 1405 else 1406 return False; 1407 end if; 1408 1409 else 1410 return False; 1411 end if; 1412 end After_Last_Declaration; 1413 1414 ---------------------------- 1415 -- Check_Current_Instance -- 1416 ---------------------------- 1417 1418 procedure Check_Current_Instance (Comp_Decl : Node_Id) is 1419 1420 function Process (N : Node_Id) return Traverse_Result; 1421 -- Process routine to apply check to given node. 1422 1423 ------------- 1424 -- Process -- 1425 ------------- 1426 1427 function Process (N : Node_Id) return Traverse_Result is 1428 begin 1429 case Nkind (N) is 1430 when N_Attribute_Reference => 1431 if (Attribute_Name (N) = Name_Access 1432 or else 1433 Attribute_Name (N) = Name_Unchecked_Access) 1434 and then Is_Entity_Name (Prefix (N)) 1435 and then Is_Type (Entity (Prefix (N))) 1436 and then Entity (Prefix (N)) = E 1437 then 1438 Error_Msg_N 1439 ("current instance must be a limited type", Prefix (N)); 1440 return Abandon; 1441 else 1442 return OK; 1443 end if; 1444 1445 when others => return OK; 1446 end case; 1447 end Process; 1448 1449 procedure Traverse is new Traverse_Proc (Process); 1450 1451 -- Start of processing for Check_Current_Instance 1452 1453 begin 1454 Traverse (Comp_Decl); 1455 end Check_Current_Instance; 1456 1457 ------------------------ 1458 -- Freeze_Record_Type -- 1459 ------------------------ 1460 1461 procedure Freeze_Record_Type (Rec : Entity_Id) is 1462 Comp : Entity_Id; 1463 IR : Node_Id; 1464 Junk : Boolean; 1465 ADC : Node_Id; 1466 1467 Unplaced_Component : Boolean := False; 1468 -- Set True if we find at least one component with no component 1469 -- clause (used to warn about useless Pack pragmas). 1470 1471 Placed_Component : Boolean := False; 1472 -- Set True if we find at least one component with a component 1473 -- clause (used to warn about useless Bit_Order pragmas). 1474 1475 begin 1476 -- If this is a subtype of a controlled type, declared without 1477 -- a constraint, the _controller may not appear in the component 1478 -- list if the parent was not frozen at the point of subtype 1479 -- declaration. Inherit the _controller component now. 1480 1481 if Rec /= Base_Type (Rec) 1482 and then Has_Controlled_Component (Rec) 1483 then 1484 if Nkind (Parent (Rec)) = N_Subtype_Declaration 1485 and then Is_Entity_Name (Subtype_Indication (Parent (Rec))) 1486 then 1487 Set_First_Entity (Rec, First_Entity (Base_Type (Rec))); 1488 1489 -- If this is an internal type without a declaration, as for 1490 -- a record component, the base type may not yet be frozen, 1491 -- and its controller has not been created. Add an explicit 1492 -- freeze node for the itype, so it will be frozen after the 1493 -- base type. 1494 1495 elsif Is_Itype (Rec) 1496 and then Has_Delayed_Freeze (Base_Type (Rec)) 1497 and then 1498 Nkind (Associated_Node_For_Itype (Rec)) = 1499 N_Component_Declaration 1500 then 1501 Ensure_Freeze_Node (Rec); 1502 end if; 1503 end if; 1504 1505 -- Freeze components and embedded subtypes 1506 1507 Comp := First_Entity (Rec); 1508 while Present (Comp) loop 1509 if not Is_Type (Comp) then 1510 Freeze_And_Append (Etype (Comp), Loc, Result); 1511 end if; 1512 1513 -- If the component is an access type with an allocator 1514 -- as default value, the designated type will be frozen 1515 -- by the corresponding expression in init_proc. In order 1516 -- to place the freeze node for the designated type before 1517 -- that for the current record type, freeze it now. 1518 1519 -- Same process if the component is an array of access types, 1520 -- initialized with an aggregate. If the designated type is 1521 -- private, it cannot contain allocators, and it is premature 1522 -- to freeze the type, so we check for this as well. 1523 1524 if Is_Access_Type (Etype (Comp)) 1525 and then Present (Parent (Comp)) 1526 and then Present (Expression (Parent (Comp))) 1527 and then Nkind (Expression (Parent (Comp))) = N_Allocator 1528 then 1529 declare 1530 Alloc : constant Node_Id := Expression (Parent (Comp)); 1531 1532 begin 1533 -- If component is pointer to a classwide type, freeze 1534 -- the specific type in the expression being allocated. 1535 -- The expression may be a subtype indication, in which 1536 -- case freeze the subtype mark. 1537 1538 if Is_Class_Wide_Type (Designated_Type (Etype (Comp))) then 1539 if Is_Entity_Name (Expression (Alloc)) then 1540 Freeze_And_Append 1541 (Entity (Expression (Alloc)), Loc, Result); 1542 elsif 1543 Nkind (Expression (Alloc)) = N_Subtype_Indication 1544 then 1545 Freeze_And_Append 1546 (Entity (Subtype_Mark (Expression (Alloc))), 1547 Loc, Result); 1548 end if; 1549 1550 else 1551 Freeze_And_Append 1552 (Designated_Type (Etype (Comp)), Loc, Result); 1553 end if; 1554 end; 1555 1556 -- If this is a constrained subtype of an already frozen type, 1557 -- make the subtype frozen as well. It might otherwise be frozen 1558 -- in the wrong scope, and a freeze node on subtype has no effect. 1559 1560 elsif Is_Access_Type (Etype (Comp)) 1561 and then not Is_Frozen (Designated_Type (Etype (Comp))) 1562 and then Is_Itype (Designated_Type (Etype (Comp))) 1563 and then Is_Frozen (Base_Type (Designated_Type (Etype (Comp)))) 1564 then 1565 Set_Is_Frozen (Designated_Type (Etype (Comp))); 1566 1567 -- In addition, add an Itype_Reference to ensure that the 1568 -- access subtype is elaborated early enough. This cannot 1569 -- be done if the subtype may depend on discriminants. 1570 1571 if Ekind (Comp) = E_Component 1572 and then Is_Itype (Etype (Comp)) 1573 and then not Has_Discriminants (Rec) 1574 then 1575 IR := Make_Itype_Reference (Sloc (Comp)); 1576 Set_Itype (IR, Designated_Type (Etype (Comp))); 1577 1578 if No (Result) then 1579 Result := New_List (IR); 1580 else 1581 Append (IR, Result); 1582 end if; 1583 end if; 1584 1585 elsif Is_Array_Type (Etype (Comp)) 1586 and then Is_Access_Type (Component_Type (Etype (Comp))) 1587 and then Present (Parent (Comp)) 1588 and then Nkind (Parent (Comp)) = N_Component_Declaration 1589 and then Present (Expression (Parent (Comp))) 1590 and then Nkind (Expression (Parent (Comp))) = N_Aggregate 1591 and then Is_Fully_Defined 1592 (Designated_Type (Component_Type (Etype (Comp)))) 1593 then 1594 Freeze_And_Append 1595 (Designated_Type 1596 (Component_Type (Etype (Comp))), Loc, Result); 1597 end if; 1598 1599 -- Processing for real components (exclude anonymous subtypes) 1600 1601 if Ekind (Comp) = E_Component 1602 or else Ekind (Comp) = E_Discriminant 1603 then 1604 -- Check for error of component clause given for variable 1605 -- sized type. We have to delay this test till this point, 1606 -- since the component type has to be frozen for us to know 1607 -- if it is variable length. We omit this test in a generic 1608 -- context, it will be applied at instantiation time. 1609 1610 declare 1611 CC : constant Node_Id := Component_Clause (Comp); 1612 1613 begin 1614 if Present (CC) then 1615 Placed_Component := True; 1616 1617 if Inside_A_Generic then 1618 null; 1619 1620 elsif not Size_Known_At_Compile_Time 1621 (Underlying_Type (Etype (Comp))) 1622 then 1623 Error_Msg_N 1624 ("component clause not allowed for variable " & 1625 "length component", CC); 1626 end if; 1627 1628 else 1629 Unplaced_Component := True; 1630 end if; 1631 end; 1632 1633 -- If component clause is present, then deal with the 1634 -- non-default bit order case. We cannot do this before 1635 -- the freeze point, because there is no required order 1636 -- for the component clause and the bit_order clause. 1637 1638 -- We only do this processing for the base type, and in 1639 -- fact that's important, since otherwise if there are 1640 -- record subtypes, we could reverse the bits once for 1641 -- each subtype, which would be incorrect. 1642 1643 if Present (Component_Clause (Comp)) 1644 and then Reverse_Bit_Order (Rec) 1645 and then Ekind (E) = E_Record_Type 1646 then 1647 declare 1648 CFB : constant Uint := Component_Bit_Offset (Comp); 1649 CSZ : constant Uint := Esize (Comp); 1650 CLC : constant Node_Id := Component_Clause (Comp); 1651 Pos : constant Node_Id := Position (CLC); 1652 FB : constant Node_Id := First_Bit (CLC); 1653 1654 Storage_Unit_Offset : constant Uint := 1655 CFB / System_Storage_Unit; 1656 1657 Start_Bit : constant Uint := 1658 CFB mod System_Storage_Unit; 1659 1660 begin 1661 -- Cases where field goes over storage unit boundary 1662 1663 if Start_Bit + CSZ > System_Storage_Unit then 1664 1665 -- Allow multi-byte field but generate warning 1666 1667 if Start_Bit mod System_Storage_Unit = 0 1668 and then CSZ mod System_Storage_Unit = 0 1669 then 1670 Error_Msg_N 1671 ("multi-byte field specified with non-standard" 1672 & " Bit_Order?", CLC); 1673 1674 if Bytes_Big_Endian then 1675 Error_Msg_N 1676 ("bytes are not reversed " 1677 & "(component is big-endian)?", CLC); 1678 else 1679 Error_Msg_N 1680 ("bytes are not reversed " 1681 & "(component is little-endian)?", CLC); 1682 end if; 1683 1684 -- Do not allow non-contiguous field 1685 1686 else 1687 Error_Msg_N 1688 ("attempt to specify non-contiguous field" 1689 & " not permitted", CLC); 1690 Error_Msg_N 1691 ("\(caused by non-standard Bit_Order " 1692 & "specified)", CLC); 1693 end if; 1694 1695 -- Case where field fits in one storage unit 1696 1697 else 1698 -- Give warning if suspicious component clause 1699 1700 if Intval (FB) >= System_Storage_Unit then 1701 Error_Msg_N 1702 ("?Bit_Order clause does not affect " & 1703 "byte ordering", Pos); 1704 Error_Msg_Uint_1 := 1705 Intval (Pos) + Intval (FB) / System_Storage_Unit; 1706 Error_Msg_N 1707 ("?position normalized to ^ before bit " & 1708 "order interpreted", Pos); 1709 end if; 1710 1711 -- Here is where we fix up the Component_Bit_Offset 1712 -- value to account for the reverse bit order. 1713 -- Some examples of what needs to be done are: 1714 1715 -- First_Bit .. Last_Bit Component_Bit_Offset 1716 -- old new old new 1717 1718 -- 0 .. 0 7 .. 7 0 7 1719 -- 0 .. 1 6 .. 7 0 6 1720 -- 0 .. 2 5 .. 7 0 5 1721 -- 0 .. 7 0 .. 7 0 4 1722 1723 -- 1 .. 1 6 .. 6 1 6 1724 -- 1 .. 4 3 .. 6 1 3 1725 -- 4 .. 7 0 .. 3 4 0 1726 1727 -- The general rule is that the first bit is 1728 -- is obtained by subtracting the old ending bit 1729 -- from storage_unit - 1. 1730 1731 Set_Component_Bit_Offset (Comp, 1732 (Storage_Unit_Offset * System_Storage_Unit) 1733 + (System_Storage_Unit - 1) 1734 - (Start_Bit + CSZ - 1)); 1735 1736 Set_Normalized_First_Bit (Comp, 1737 Component_Bit_Offset (Comp) mod System_Storage_Unit); 1738 end if; 1739 end; 1740 end if; 1741 end if; 1742 1743 Next_Entity (Comp); 1744 end loop; 1745 1746 -- Check for useless pragma Bit_Order 1747 1748 if not Placed_Component and then Reverse_Bit_Order (Rec) then 1749 ADC := Get_Attribute_Definition_Clause (Rec, Attribute_Bit_Order); 1750 Error_Msg_N ("?Bit_Order specification has no effect", ADC); 1751 Error_Msg_N ("\?since no component clauses were specified", ADC); 1752 end if; 1753 1754 -- Check for useless pragma Pack when all components placed 1755 1756 if Is_Packed (Rec) 1757 and then not Unplaced_Component 1758 and then Warn_On_Redundant_Constructs 1759 then 1760 Error_Msg_N 1761 ("?pragma Pack has no effect, no unplaced components", 1762 Get_Rep_Pragma (Rec, Name_Pack)); 1763 Set_Is_Packed (Rec, False); 1764 end if; 1765 1766 -- If this is the record corresponding to a remote type, 1767 -- freeze the remote type here since that is what we are 1768 -- semantically freezing. This prevents having the freeze 1769 -- node for that type in an inner scope. 1770 1771 -- Also, Check for controlled components and unchecked unions. 1772 -- Finally, enforce the restriction that access attributes with 1773 -- a current instance prefix can only apply to limited types. 1774 1775 if Ekind (Rec) = E_Record_Type then 1776 if Present (Corresponding_Remote_Type (Rec)) then 1777 Freeze_And_Append 1778 (Corresponding_Remote_Type (Rec), Loc, Result); 1779 end if; 1780 1781 Comp := First_Component (Rec); 1782 while Present (Comp) loop 1783 if Has_Controlled_Component (Etype (Comp)) 1784 or else (Chars (Comp) /= Name_uParent 1785 and then Is_Controlled (Etype (Comp))) 1786 or else (Is_Protected_Type (Etype (Comp)) 1787 and then Present 1788 (Corresponding_Record_Type (Etype (Comp))) 1789 and then Has_Controlled_Component 1790 (Corresponding_Record_Type (Etype (Comp)))) 1791 then 1792 Set_Has_Controlled_Component (Rec); 1793 exit; 1794 end if; 1795 1796 if Has_Unchecked_Union (Etype (Comp)) then 1797 Set_Has_Unchecked_Union (Rec); 1798 end if; 1799 1800 if Has_Per_Object_Constraint (Comp) 1801 and then not Is_Limited_Type (Rec) 1802 then 1803 -- Scan component declaration for likely misuses of 1804 -- current instance, either in a constraint or in a 1805 -- default expression. 1806 1807 Check_Current_Instance (Parent (Comp)); 1808 end if; 1809 1810 Next_Component (Comp); 1811 end loop; 1812 end if; 1813 1814 Set_Component_Alignment_If_Not_Set (Rec); 1815 1816 -- For first subtypes, check if there are any fixed-point 1817 -- fields with component clauses, where we must check the size. 1818 -- This is not done till the freeze point, since for fixed-point 1819 -- types, we do not know the size until the type is frozen. 1820 -- Similar processing applies to bit packed arrays. 1821 1822 if Is_First_Subtype (Rec) then 1823 Comp := First_Component (Rec); 1824 1825 while Present (Comp) loop 1826 if Present (Component_Clause (Comp)) 1827 and then (Is_Fixed_Point_Type (Etype (Comp)) 1828 or else 1829 Is_Bit_Packed_Array (Etype (Comp))) 1830 then 1831 Check_Size 1832 (Component_Name (Component_Clause (Comp)), 1833 Etype (Comp), 1834 Esize (Comp), 1835 Junk); 1836 end if; 1837 1838 Next_Component (Comp); 1839 end loop; 1840 end if; 1841 end Freeze_Record_Type; 1842 1843 -- Start of processing for Freeze_Entity 1844 1845 begin 1846 -- Do not freeze if already frozen since we only need one freeze node 1847 1848 if Is_Frozen (E) then 1849 return No_List; 1850 1851 -- It is improper to freeze an external entity within a generic 1852 -- because its freeze node will appear in a non-valid context. 1853 -- ??? We should probably freeze the entity at that point and insert 1854 -- the freeze node in a proper place but this proper place is not 1855 -- easy to find, and the proper scope is not easy to restore. For 1856 -- now, just wait to get out of the generic to freeze ??? 1857 1858 elsif Inside_A_Generic and then External_Ref_In_Generic (E) then 1859 return No_List; 1860 1861 -- Do not freeze a global entity within an inner scope created during 1862 -- expansion. A call to subprogram E within some internal procedure 1863 -- (a stream attribute for example) might require freezing E, but the 1864 -- freeze node must appear in the same declarative part as E itself. 1865 -- The two-pass elaboration mechanism in gigi guarantees that E will 1866 -- be frozen before the inner call is elaborated. We exclude constants 1867 -- from this test, because deferred constants may be frozen early, and 1868 -- must be diagnosed (see e.g. 1522-005). If the enclosing subprogram 1869 -- comes from source, or is a generic instance, then the freeze point 1870 -- is the one mandated by the language. and we freze the entity. 1871 1872 elsif In_Open_Scopes (Scope (E)) 1873 and then Scope (E) /= Current_Scope 1874 and then Ekind (E) /= E_Constant 1875 then 1876 declare 1877 S : Entity_Id := Current_Scope; 1878 1879 begin 1880 while Present (S) loop 1881 if Is_Overloadable (S) then 1882 if Comes_From_Source (S) 1883 or else Is_Generic_Instance (S) 1884 then 1885 exit; 1886 else 1887 return No_List; 1888 end if; 1889 end if; 1890 1891 S := Scope (S); 1892 end loop; 1893 end; 1894 end if; 1895 1896 -- Here to freeze the entity 1897 1898 Result := No_List; 1899 Set_Is_Frozen (E); 1900 1901 -- Case of entity being frozen is other than a type 1902 1903 if not Is_Type (E) then 1904 1905 -- If entity is exported or imported and does not have an external 1906 -- name, now is the time to provide the appropriate default name. 1907 -- Skip this if the entity is stubbed, since we don't need a name 1908 -- for any stubbed routine. 1909 1910 if (Is_Imported (E) or else Is_Exported (E)) 1911 and then No (Interface_Name (E)) 1912 and then Convention (E) /= Convention_Stubbed 1913 then 1914 Set_Encoded_Interface_Name 1915 (E, Get_Default_External_Name (E)); 1916 1917 -- Special processing for atomic objects appearing in object decls 1918 1919 elsif Is_Atomic (E) 1920 and then Nkind (Parent (E)) = N_Object_Declaration 1921 and then Present (Expression (Parent (E))) 1922 then 1923 declare 1924 Expr : constant Node_Id := Expression (Parent (E)); 1925 1926 begin 1927 -- If expression is an aggregate, assign to a temporary to 1928 -- ensure that the actual assignment is done atomically rather 1929 -- than component-wise (the assignment to the temp may be done 1930 -- component-wise, but that is harmless. 1931 1932 if Nkind (Expr) = N_Aggregate then 1933 Expand_Atomic_Aggregate (Expr, Etype (E)); 1934 1935 -- If the expression is a reference to a record or array 1936 -- object entity, then reset Is_True_Constant to False so 1937 -- that the compiler will not optimize away the intermediate 1938 -- object, which we need in this case for the same reason 1939 -- (to ensure that the actual assignment is atomic, rather 1940 -- than component-wise). 1941 1942 elsif Is_Entity_Name (Expr) 1943 and then (Is_Record_Type (Etype (Expr)) 1944 or else 1945 Is_Array_Type (Etype (Expr))) 1946 then 1947 Set_Is_True_Constant (Entity (Expr), False); 1948 end if; 1949 end; 1950 end if; 1951 1952 -- For a subprogram, freeze all parameter types and also the return 1953 -- type (RM 13.14(14)). However skip this for internal subprograms. 1954 -- This is also the point where any extra formal parameters are 1955 -- created since we now know whether the subprogram will use 1956 -- a foreign convention. 1957 1958 if Is_Subprogram (E) then 1959 if not Is_Internal (E) then 1960 declare 1961 F_Type : Entity_Id; 1962 1963 function Is_Fat_C_Ptr_Type (T : Entity_Id) return Boolean; 1964 -- Determines if given type entity is a fat pointer type 1965 -- used as an argument type or return type to a subprogram 1966 -- with C or C++ convention set. 1967 1968 -------------------------- 1969 -- Is_Fat_C_Access_Type -- 1970 -------------------------- 1971 1972 function Is_Fat_C_Ptr_Type (T : Entity_Id) return Boolean is 1973 begin 1974 return (Convention (E) = Convention_C 1975 or else 1976 Convention (E) = Convention_CPP) 1977 and then Is_Access_Type (T) 1978 and then Esize (T) > Ttypes.System_Address_Size; 1979 end Is_Fat_C_Ptr_Type; 1980 1981 begin 1982 -- Loop through formals 1983 1984 Formal := First_Formal (E); 1985 1986 while Present (Formal) loop 1987 F_Type := Etype (Formal); 1988 Freeze_And_Append (F_Type, Loc, Result); 1989 1990 if Is_Private_Type (F_Type) 1991 and then Is_Private_Type (Base_Type (F_Type)) 1992 and then No (Full_View (Base_Type (F_Type))) 1993 and then not Is_Generic_Type (F_Type) 1994 and then not Is_Derived_Type (F_Type) 1995 then 1996 -- If the type of a formal is incomplete, subprogram 1997 -- is being frozen prematurely. Within an instance 1998 -- (but not within a wrapper package) this is an 1999 -- an artifact of our need to regard the end of an 2000 -- instantiation as a freeze point. Otherwise it is 2001 -- a definite error. 2002 2003 -- and then not Is_Wrapper_Package (Current_Scope) ??? 2004 2005 if In_Instance then 2006 Set_Is_Frozen (E, False); 2007 return No_List; 2008 2009 elsif not After_Last_Declaration then 2010 Error_Msg_Node_1 := F_Type; 2011 Error_Msg 2012 ("type& must be fully defined before this point", 2013 Loc); 2014 end if; 2015 end if; 2016 2017 -- Check bad use of fat C pointer 2018 2019 if Warn_On_Export_Import and then 2020 Is_Fat_C_Ptr_Type (F_Type) 2021 then 2022 Error_Msg_Qual_Level := 1; 2023 Error_Msg_N 2024 ("?type of & does not correspond to C pointer", 2025 Formal); 2026 Error_Msg_Qual_Level := 0; 2027 end if; 2028 2029 -- Check for unconstrained array in exported foreign 2030 -- convention case. 2031 2032 if Convention (E) in Foreign_Convention 2033 and then not Is_Imported (E) 2034 and then Is_Array_Type (F_Type) 2035 and then not Is_Constrained (F_Type) 2036 and then Warn_On_Export_Import 2037 then 2038 Error_Msg_Qual_Level := 1; 2039 Error_Msg_N 2040 ("?type of argument& is unconstrained array", 2041 Formal); 2042 Error_Msg_N 2043 ("?foreign caller must pass bounds explicitly", 2044 Formal); 2045 Error_Msg_Qual_Level := 0; 2046 end if; 2047 2048 Next_Formal (Formal); 2049 end loop; 2050 2051 -- Check return type 2052 2053 if Ekind (E) = E_Function then 2054 Freeze_And_Append (Etype (E), Loc, Result); 2055 2056 if Warn_On_Export_Import 2057 and then Is_Fat_C_Ptr_Type (Etype (E)) 2058 then 2059 Error_Msg_N 2060 ("?return type of& does not correspond to C pointer", 2061 E); 2062 2063 elsif Is_Array_Type (Etype (E)) 2064 and then not Is_Constrained (Etype (E)) 2065 and then not Is_Imported (E) 2066 and then Convention (E) in Foreign_Convention 2067 and then Warn_On_Export_Import 2068 then 2069 Error_Msg_N 2070 ("?foreign convention function& should not " & 2071 "return unconstrained array", E); 2072 end if; 2073 end if; 2074 end; 2075 end if; 2076 2077 -- Must freeze its parent first if it is a derived subprogram 2078 2079 if Present (Alias (E)) then 2080 Freeze_And_Append (Alias (E), Loc, Result); 2081 end if; 2082 2083 -- If the return type requires a transient scope, and we are on 2084 -- a target allowing functions to return with a depressed stack 2085 -- pointer, then we mark the function as requiring this treatment. 2086 2087 if Ekind (E) = E_Function 2088 and then Functions_Return_By_DSP_On_Target 2089 and then Requires_Transient_Scope (Etype (E)) 2090 then 2091 Set_Function_Returns_With_DSP (E); 2092 end if; 2093 2094 if not Is_Internal (E) then 2095 Freeze_Subprogram (E); 2096 end if; 2097 2098 -- Here for other than a subprogram or type 2099 2100 else 2101 -- If entity has a type, and it is not a generic unit, then 2102 -- freeze it first (RM 13.14(10)) 2103 2104 if Present (Etype (E)) 2105 and then Ekind (E) /= E_Generic_Function 2106 then 2107 Freeze_And_Append (Etype (E), Loc, Result); 2108 end if; 2109 2110 -- For object created by object declaration, perform required 2111 -- categorization (preelaborate and pure) checks. Defer these 2112 -- checks to freeze time since pragma Import inhibits default 2113 -- initialization and thus pragma Import affects these checks. 2114 2115 if Nkind (Declaration_Node (E)) = N_Object_Declaration then 2116 Validate_Object_Declaration (Declaration_Node (E)); 2117 Check_Address_Clause (E); 2118 end if; 2119 2120 -- Check that a constant which has a pragma Volatile[_Components] 2121 -- or Atomic[_Components] also has a pragma Import (RM C.6(13)) 2122 2123 -- Note: Atomic[_Components] also sets Volatile[_Components] 2124 2125 if Ekind (E) = E_Constant 2126 and then (Has_Volatile_Components (E) or else Is_Volatile (E)) 2127 and then not Is_Imported (E) 2128 then 2129 -- Make sure we actually have a pragma, and have not merely 2130 -- inherited the indication from elsewhere (e.g. an address 2131 -- clause, which is not good enough in RM terms!) 2132 2133 if Present (Get_Rep_Pragma (E, Name_Atomic)) 2134 or else 2135 Present (Get_Rep_Pragma (E, Name_Atomic_Components)) 2136 then 2137 Error_Msg_N 2138 ("stand alone atomic constant must be " & 2139 "imported ('R'M 'C.6(13))", E); 2140 2141 elsif Present (Get_Rep_Pragma (E, Name_Volatile)) 2142 or else 2143 Present (Get_Rep_Pragma (E, Name_Volatile_Components)) 2144 then 2145 Error_Msg_N 2146 ("stand alone volatile constant must be " & 2147 "imported ('R'M 'C.6(13))", E); 2148 end if; 2149 end if; 2150 2151 -- Static objects require special handling 2152 2153 if (Ekind (E) = E_Constant or else Ekind (E) = E_Variable) 2154 and then Is_Statically_Allocated (E) 2155 then 2156 Freeze_Static_Object (E); 2157 end if; 2158 2159 -- Remaining step is to layout objects 2160 2161 if Ekind (E) = E_Variable 2162 or else 2163 Ekind (E) = E_Constant 2164 or else 2165 Ekind (E) = E_Loop_Parameter 2166 or else 2167 Is_Formal (E) 2168 then 2169 Layout_Object (E); 2170 end if; 2171 end if; 2172 2173 -- Case of a type or subtype being frozen 2174 2175 else 2176 -- The type may be defined in a generic unit. This can occur when 2177 -- freezing a generic function that returns the type (which is 2178 -- defined in a parent unit). It is clearly meaningless to freeze 2179 -- this type. However, if it is a subtype, its size may be determi- 2180 -- nable and used in subsequent checks, so might as well try to 2181 -- compute it. 2182 2183 if Present (Scope (E)) 2184 and then Is_Generic_Unit (Scope (E)) 2185 then 2186 Check_Compile_Time_Size (E); 2187 return No_List; 2188 end if; 2189 2190 -- Deal with special cases of freezing for subtype 2191 2192 if E /= Base_Type (E) then 2193 2194 -- If ancestor subtype present, freeze that first. 2195 -- Note that this will also get the base type frozen. 2196 2197 Atype := Ancestor_Subtype (E); 2198 2199 if Present (Atype) then 2200 Freeze_And_Append (Atype, Loc, Result); 2201 2202 -- Otherwise freeze the base type of the entity before 2203 -- freezing the entity itself, (RM 13.14(15)). 2204 2205 elsif E /= Base_Type (E) then 2206 Freeze_And_Append (Base_Type (E), Loc, Result); 2207 end if; 2208 2209 -- For a derived type, freeze its parent type first (RM 13.14(15)) 2210 2211 elsif Is_Derived_Type (E) then 2212 Freeze_And_Append (Etype (E), Loc, Result); 2213 Freeze_And_Append (First_Subtype (Etype (E)), Loc, Result); 2214 end if; 2215 2216 -- For array type, freeze index types and component type first 2217 -- before freezing the array (RM 13.14(15)). 2218 2219 if Is_Array_Type (E) then 2220 declare 2221 Ctyp : constant Entity_Id := Component_Type (E); 2222 Pnod : Node_Id; 2223 2224 Non_Standard_Enum : Boolean := False; 2225 -- Set true if any of the index types is an enumeration 2226 -- type with a non-standard representation. 2227 2228 begin 2229 Freeze_And_Append (Ctyp, Loc, Result); 2230 2231 Indx := First_Index (E); 2232 while Present (Indx) loop 2233 Freeze_And_Append (Etype (Indx), Loc, Result); 2234 2235 if Is_Enumeration_Type (Etype (Indx)) 2236 and then Has_Non_Standard_Rep (Etype (Indx)) 2237 then 2238 Non_Standard_Enum := True; 2239 end if; 2240 2241 Next_Index (Indx); 2242 end loop; 2243 2244 -- Processing that is done only for base types 2245 2246 if Ekind (E) = E_Array_Type then 2247 2248 -- Propagate flags for component type 2249 2250 if Is_Controlled (Component_Type (E)) 2251 or else Has_Controlled_Component (Ctyp) 2252 then 2253 Set_Has_Controlled_Component (E); 2254 end if; 2255 2256 if Has_Unchecked_Union (Component_Type (E)) then 2257 Set_Has_Unchecked_Union (E); 2258 end if; 2259 2260 -- If packing was requested or if the component size was set 2261 -- explicitly, then see if bit packing is required. This 2262 -- processing is only done for base types, since all the 2263 -- representation aspects involved are type-related. This 2264 -- is not just an optimization, if we start processing the 2265 -- subtypes, they intefere with the settings on the base 2266 -- type (this is because Is_Packed has a slightly different 2267 -- meaning before and after freezing). 2268 2269 declare 2270 Csiz : Uint; 2271 Esiz : Uint; 2272 2273 begin 2274 if (Is_Packed (E) or else Has_Pragma_Pack (E)) 2275 and then not Has_Atomic_Components (E) 2276 and then Known_Static_RM_Size (Ctyp) 2277 then 2278 Csiz := UI_Max (RM_Size (Ctyp), 1); 2279 2280 elsif Known_Component_Size (E) then 2281 Csiz := Component_Size (E); 2282 2283 elsif not Known_Static_Esize (Ctyp) then 2284 Csiz := Uint_0; 2285 2286 else 2287 Esiz := Esize (Ctyp); 2288 2289 -- We can set the component size if it is less than 2290 -- 16, rounding it up to the next storage unit size. 2291 2292 if Esiz <= 8 then 2293 Csiz := Uint_8; 2294 elsif Esiz <= 16 then 2295 Csiz := Uint_16; 2296 else 2297 Csiz := Uint_0; 2298 end if; 2299 2300 -- Set component size up to match alignment if 2301 -- it would otherwise be less than the alignment. 2302 -- This deals with cases of types whose alignment 2303 -- exceeds their sizes (padded types). 2304 2305 if Csiz /= 0 then 2306 declare 2307 A : constant Uint := Alignment_In_Bits (Ctyp); 2308 2309 begin 2310 if Csiz < A then 2311 Csiz := A; 2312 end if; 2313 end; 2314 end if; 2315 2316 end if; 2317 2318 if 1 <= Csiz and then Csiz <= 64 then 2319 2320 -- We set the component size for all cases 1-64 2321 2322 Set_Component_Size (Base_Type (E), Csiz); 2323 2324 -- Check for base type of 8,16,32 bits, where the 2325 -- subtype has a length one less than the base type 2326 -- and is unsigned (e.g. Natural subtype of Integer) 2327 2328 -- In such cases, if a component size was not set 2329 -- explicitly, then generate a warning. 2330 2331 if Has_Pragma_Pack (E) 2332 and then not Has_Component_Size_Clause (E) 2333 and then 2334 (Csiz = 7 or else Csiz = 15 or else Csiz = 31) 2335 and then Esize (Base_Type (Ctyp)) = Csiz + 1 2336 then 2337 Error_Msg_Uint_1 := Csiz; 2338 Pnod := 2339 Get_Rep_Pragma (First_Subtype (E), Name_Pack); 2340 2341 if Present (Pnod) then 2342 Error_Msg_N 2343 ("pragma Pack causes component size to be ^?", 2344 Pnod); 2345 Error_Msg_N 2346 ("\use Component_Size to set desired value", 2347 Pnod); 2348 end if; 2349 end if; 2350 2351 -- Actual packing is not needed for 8,16,32,64 2352 -- Also not needed for 24 if alignment is 1 2353 2354 if Csiz = 8 2355 or else Csiz = 16 2356 or else Csiz = 32 2357 or else Csiz = 64 2358 or else (Csiz = 24 and then Alignment (Ctyp) = 1) 2359 then 2360 -- Here the array was requested to be packed, but 2361 -- the packing request had no effect, so Is_Packed 2362 -- is reset. 2363 2364 -- Note: semantically this means that we lose 2365 -- track of the fact that a derived type inherited 2366 -- a pack pragma that was non-effective, but that 2367 -- seems fine. 2368 2369 -- We regard a Pack pragma as a request to set a 2370 -- representation characteristic, and this request 2371 -- may be ignored. 2372 2373 Set_Is_Packed (Base_Type (E), False); 2374 2375 -- In all other cases, packing is indeed needed 2376 2377 else 2378 Set_Has_Non_Standard_Rep (Base_Type (E)); 2379 Set_Is_Bit_Packed_Array (Base_Type (E)); 2380 Set_Is_Packed (Base_Type (E)); 2381 end if; 2382 end if; 2383 end; 2384 2385 -- Processing that is done only for subtypes 2386 2387 else 2388 -- Acquire alignment from base type 2389 2390 if Unknown_Alignment (E) then 2391 Set_Alignment (E, Alignment (Base_Type (E))); 2392 end if; 2393 end if; 2394 2395 -- For bit-packed arrays, check the size 2396 2397 if Is_Bit_Packed_Array (E) 2398 and then Known_Esize (E) 2399 then 2400 declare 2401 Discard : Boolean; 2402 SizC : constant Node_Id := Size_Clause (E); 2403 2404 begin 2405 -- It is not clear if it is possible to have no size 2406 -- clause at this stage, but this is not worth worrying 2407 -- about. Post the error on the entity name in the size 2408 -- clause if present, else on the type entity itself. 2409 2410 if Present (SizC) then 2411 Check_Size (Name (SizC), E, Esize (E), Discard); 2412 else 2413 Check_Size (E, E, Esize (E), Discard); 2414 end if; 2415 end; 2416 end if; 2417 2418 -- Check one common case of a size given where the array 2419 -- needs to be packed, but was not so the size cannot be 2420 -- honored. This would of course be caught by the backend, 2421 -- and indeed we don't catch all cases. The point is that 2422 -- we can give a better error message in those cases that 2423 -- we do catch with the circuitry here. 2424 2425 declare 2426 Lo, Hi : Node_Id; 2427 Ctyp : constant Entity_Id := Component_Type (E); 2428 2429 begin 2430 if Present (Size_Clause (E)) 2431 and then Known_Static_Esize (E) 2432 and then not Is_Bit_Packed_Array (E) 2433 and then not Has_Pragma_Pack (E) 2434 and then Number_Dimensions (E) = 1 2435 and then not Has_Component_Size_Clause (E) 2436 and then Known_Static_Esize (Ctyp) 2437 then 2438 Get_Index_Bounds (First_Index (E), Lo, Hi); 2439 2440 if Compile_Time_Known_Value (Lo) 2441 and then Compile_Time_Known_Value (Hi) 2442 and then Known_Static_RM_Size (Ctyp) 2443 and then RM_Size (Ctyp) < 64 2444 then 2445 declare 2446 Lov : constant Uint := Expr_Value (Lo); 2447 Hiv : constant Uint := Expr_Value (Hi); 2448 Len : constant Uint := 2449 UI_Max (Uint_0, Hiv - Lov + 1); 2450 Rsiz : constant Uint := RM_Size (Ctyp); 2451 2452 -- What we are looking for here is the situation 2453 -- where the Esize given would be exactly right 2454 -- if there was a pragma Pack (resulting in the 2455 -- component size being the same as the RM_Size). 2456 -- Furthermore, the component type size must be 2457 -- an odd size (not a multiple of storage unit) 2458 2459 begin 2460 if Esize (E) = Len * Rsiz 2461 and then Rsiz mod System_Storage_Unit /= 0 2462 then 2463 Error_Msg_NE 2464 ("size given for& too small", 2465 Size_Clause (E), E); 2466 Error_Msg_N 2467 ("\explicit pragma Pack is required", 2468 Size_Clause (E)); 2469 end if; 2470 end; 2471 end if; 2472 end if; 2473 end; 2474 2475 -- If any of the index types was an enumeration type with 2476 -- a non-standard rep clause, then we indicate that the 2477 -- array type is always packed (even if it is not bit packed). 2478 2479 if Non_Standard_Enum then 2480 Set_Has_Non_Standard_Rep (Base_Type (E)); 2481 Set_Is_Packed (Base_Type (E)); 2482 end if; 2483 end; 2484 2485 Set_Component_Alignment_If_Not_Set (E); 2486 2487 -- If the array is packed, we must create the packed array 2488 -- type to be used to actually implement the type. This is 2489 -- only needed for real array types (not for string literal 2490 -- types, since they are present only for the front end). 2491 2492 if Is_Packed (E) 2493 and then Ekind (E) /= E_String_Literal_Subtype 2494 then 2495 Create_Packed_Array_Type (E); 2496 Freeze_And_Append (Packed_Array_Type (E), Loc, Result); 2497 2498 -- Size information of packed array type is copied to the 2499 -- array type, since this is really the representation. 2500 2501 Set_Size_Info (E, Packed_Array_Type (E)); 2502 Set_RM_Size (E, RM_Size (Packed_Array_Type (E))); 2503 end if; 2504 2505 -- For a class-wide type, the corresponding specific type is 2506 -- frozen as well (RM 13.14(15)) 2507 2508 elsif Is_Class_Wide_Type (E) then 2509 Freeze_And_Append (Root_Type (E), Loc, Result); 2510 2511 -- If the Class_Wide_Type is an Itype (when type is the anonymous 2512 -- parent of a derived type) and it is a library-level entity, 2513 -- generate an itype reference for it. Otherwise, its first 2514 -- explicit reference may be in an inner scope, which will be 2515 -- rejected by the back-end. 2516 2517 if Is_Itype (E) 2518 and then Is_Compilation_Unit (Scope (E)) 2519 then 2520 declare 2521 Ref : constant Node_Id := Make_Itype_Reference (Loc); 2522 2523 begin 2524 Set_Itype (Ref, E); 2525 if No (Result) then 2526 Result := New_List (Ref); 2527 else 2528 Append (Ref, Result); 2529 end if; 2530 end; 2531 end if; 2532 2533 -- The equivalent type associated with a class-wide subtype 2534 -- needs to be frozen to ensure that its layout is done. 2535 -- Class-wide subtypes are currently only frozen on targets 2536 -- requiring front-end layout (see New_Class_Wide_Subtype 2537 -- and Make_CW_Equivalent_Type in exp_util.adb). 2538 2539 if Ekind (E) = E_Class_Wide_Subtype 2540 and then Present (Equivalent_Type (E)) 2541 then 2542 Freeze_And_Append (Equivalent_Type (E), Loc, Result); 2543 end if; 2544 2545 -- For a record (sub)type, freeze all the component types (RM 2546 -- 13.14(15). We test for E_Record_(sub)Type here, rather than 2547 -- using Is_Record_Type, because we don't want to attempt the 2548 -- freeze for the case of a private type with record extension 2549 -- (we will do that later when the full type is frozen). 2550 2551 elsif Ekind (E) = E_Record_Type 2552 or else Ekind (E) = E_Record_Subtype 2553 then 2554 Freeze_Record_Type (E); 2555 2556 -- For a concurrent type, freeze corresponding record type. This 2557 -- does not correpond to any specific rule in the RM, but the 2558 -- record type is essentially part of the concurrent type. 2559 -- Freeze as well all local entities. This includes record types 2560 -- created for entry parameter blocks, and whatever local entities 2561 -- may appear in the private part. 2562 2563 elsif Is_Concurrent_Type (E) then 2564 if Present (Corresponding_Record_Type (E)) then 2565 Freeze_And_Append 2566 (Corresponding_Record_Type (E), Loc, Result); 2567 end if; 2568 2569 Comp := First_Entity (E); 2570 2571 while Present (Comp) loop 2572 if Is_Type (Comp) then 2573 Freeze_And_Append (Comp, Loc, Result); 2574 2575 elsif (Ekind (Comp)) /= E_Function then 2576 Freeze_And_Append (Etype (Comp), Loc, Result); 2577 end if; 2578 2579 Next_Entity (Comp); 2580 end loop; 2581 2582 -- Private types are required to point to the same freeze node 2583 -- as their corresponding full views. The freeze node itself 2584 -- has to point to the partial view of the entity (because 2585 -- from the partial view, we can retrieve the full view, but 2586 -- not the reverse). However, in order to freeze correctly, 2587 -- we need to freeze the full view. If we are freezing at the 2588 -- end of a scope (or within the scope of the private type), 2589 -- the partial and full views will have been swapped, the 2590 -- full view appears first in the entity chain and the swapping 2591 -- mechanism ensures that the pointers are properly set (on 2592 -- scope exit). 2593 2594 -- If we encounter the partial view before the full view 2595 -- (e.g. when freezing from another scope), we freeze the 2596 -- full view, and then set the pointers appropriately since 2597 -- we cannot rely on swapping to fix things up (subtypes in an 2598 -- outer scope might not get swapped). 2599 2600 elsif Is_Incomplete_Or_Private_Type (E) 2601 and then not Is_Generic_Type (E) 2602 then 2603 -- Case of full view present 2604 2605 if Present (Full_View (E)) then 2606 2607 -- If full view has already been frozen, then no 2608 -- further processing is required 2609 2610 if Is_Frozen (Full_View (E)) then 2611 2612 Set_Has_Delayed_Freeze (E, False); 2613 Set_Freeze_Node (E, Empty); 2614 Check_Debug_Info_Needed (E); 2615 2616 -- Otherwise freeze full view and patch the pointers 2617 -- so that the freeze node will elaborate both views 2618 -- in the back-end. 2619 2620 else 2621 declare 2622 Full : constant Entity_Id := Full_View (E); 2623 2624 begin 2625 if Is_Private_Type (Full) 2626 and then Present (Underlying_Full_View (Full)) 2627 then 2628 Freeze_And_Append 2629 (Underlying_Full_View (Full), Loc, Result); 2630 end if; 2631 2632 Freeze_And_Append (Full, Loc, Result); 2633 2634 if Has_Delayed_Freeze (E) then 2635 F_Node := Freeze_Node (Full); 2636 2637 if Present (F_Node) then 2638 Set_Freeze_Node (E, F_Node); 2639 Set_Entity (F_Node, E); 2640 2641 else 2642 -- {Incomplete,Private}_Subtypes 2643 -- with Full_Views constrained by discriminants 2644 2645 Set_Has_Delayed_Freeze (E, False); 2646 Set_Freeze_Node (E, Empty); 2647 end if; 2648 end if; 2649 end; 2650 2651 Check_Debug_Info_Needed (E); 2652 end if; 2653 2654 -- AI-117 requires that the convention of a partial view 2655 -- be the same as the convention of the full view. Note 2656 -- that this is a recognized breach of privacy, but it's 2657 -- essential for logical consistency of representation, 2658 -- and the lack of a rule in RM95 was an oversight. 2659 2660 Set_Convention (E, Convention (Full_View (E))); 2661 2662 Set_Size_Known_At_Compile_Time (E, 2663 Size_Known_At_Compile_Time (Full_View (E))); 2664 2665 -- Size information is copied from the full view to the 2666 -- incomplete or private view for consistency 2667 2668 -- We skip this is the full view is not a type. This is 2669 -- very strange of course, and can only happen as a result 2670 -- of certain illegalities, such as a premature attempt to 2671 -- derive from an incomplete type. 2672 2673 if Is_Type (Full_View (E)) then 2674 Set_Size_Info (E, Full_View (E)); 2675 Set_RM_Size (E, RM_Size (Full_View (E))); 2676 end if; 2677 2678 return Result; 2679 2680 -- Case of no full view present. If entity is derived or subtype, 2681 -- it is safe to freeze, correctness depends on the frozen status 2682 -- of parent. Otherwise it is either premature usage, or a Taft 2683 -- amendment type, so diagnosis is at the point of use and the 2684 -- type might be frozen later. 2685 2686 elsif E /= Base_Type (E) 2687 or else Is_Derived_Type (E) 2688 then 2689 null; 2690 2691 else 2692 Set_Is_Frozen (E, False); 2693 return No_List; 2694 end if; 2695 2696 -- For access subprogram, freeze types of all formals, the return 2697 -- type was already frozen, since it is the Etype of the function. 2698 2699 elsif Ekind (E) = E_Subprogram_Type then 2700 Formal := First_Formal (E); 2701 while Present (Formal) loop 2702 Freeze_And_Append (Etype (Formal), Loc, Result); 2703 Next_Formal (Formal); 2704 end loop; 2705 2706 -- If the return type requires a transient scope, and we are on 2707 -- a target allowing functions to return with a depressed stack 2708 -- pointer, then we mark the function as requiring this treatment. 2709 2710 if Functions_Return_By_DSP_On_Target 2711 and then Requires_Transient_Scope (Etype (E)) 2712 then 2713 Set_Function_Returns_With_DSP (E); 2714 end if; 2715 2716 Freeze_Subprogram (E); 2717 2718 -- For access to a protected subprogram, freeze the equivalent 2719 -- type (however this is not set if we are not generating code) 2720 -- or if this is an anonymous type used just for resolution). 2721 2722 elsif Ekind (E) = E_Access_Protected_Subprogram_Type 2723 and then Operating_Mode = Generate_Code 2724 and then Present (Equivalent_Type (E)) 2725 then 2726 Freeze_And_Append (Equivalent_Type (E), Loc, Result); 2727 end if; 2728 2729 -- Generic types are never seen by the back-end, and are also not 2730 -- processed by the expander (since the expander is turned off for 2731 -- generic processing), so we never need freeze nodes for them. 2732 2733 if Is_Generic_Type (E) then 2734 return Result; 2735 end if; 2736 2737 -- Some special processing for non-generic types to complete 2738 -- representation details not known till the freeze point. 2739 2740 if Is_Fixed_Point_Type (E) then 2741 Freeze_Fixed_Point_Type (E); 2742 2743 -- Some error checks required for ordinary fixed-point type. 2744 -- Defer these till the freeze-point since we need the small 2745 -- and range values. We only do these checks for base types 2746 2747 if Is_Ordinary_Fixed_Point_Type (E) 2748 and then E = Base_Type (E) 2749 then 2750 if Small_Value (E) < Ureal_2_M_80 then 2751 Error_Msg_Name_1 := Name_Small; 2752 Error_Msg_N 2753 ("`&''%` is too small, minimum is 2.0'*'*(-80)", E); 2754 2755 elsif Small_Value (E) > Ureal_2_80 then 2756 Error_Msg_Name_1 := Name_Small; 2757 Error_Msg_N 2758 ("`&''%` is too large, maximum is 2.0'*'*80", E); 2759 end if; 2760 2761 if Expr_Value_R (Type_Low_Bound (E)) < Ureal_M_10_36 then 2762 Error_Msg_Name_1 := Name_First; 2763 Error_Msg_N 2764 ("`&''%` is too small, minimum is -10.0'*'*36", E); 2765 end if; 2766 2767 if Expr_Value_R (Type_High_Bound (E)) > Ureal_10_36 then 2768 Error_Msg_Name_1 := Name_Last; 2769 Error_Msg_N 2770 ("`&''%` is too large, maximum is 10.0'*'*36", E); 2771 end if; 2772 end if; 2773 2774 elsif Is_Enumeration_Type (E) then 2775 Freeze_Enumeration_Type (E); 2776 2777 elsif Is_Integer_Type (E) then 2778 Adjust_Esize_For_Alignment (E); 2779 2780 elsif Is_Access_Type (E) 2781 and then No (Associated_Storage_Pool (E)) 2782 then 2783 Check_Restriction (No_Standard_Storage_Pools, E); 2784 end if; 2785 2786 -- If the current entity is an array or record subtype and has 2787 -- discriminants used to constrain it, it must not freeze, because 2788 -- Freeze_Entity nodes force Gigi to process the frozen type. 2789 2790 if Is_Composite_Type (E) then 2791 2792 if Is_Array_Type (E) then 2793 declare 2794 Index : Node_Id := First_Index (E); 2795 Expr1 : Node_Id; 2796 Expr2 : Node_Id; 2797 2798 begin 2799 while Present (Index) loop 2800 if Etype (Index) /= Any_Type then 2801 Get_Index_Bounds (Index, Expr1, Expr2); 2802 2803 for J in 1 .. 2 loop 2804 if Nkind (Expr1) = N_Identifier 2805 and then Ekind (Entity (Expr1)) = E_Discriminant 2806 then 2807 Set_Has_Delayed_Freeze (E, False); 2808 Set_Freeze_Node (E, Empty); 2809 Check_Debug_Info_Needed (E); 2810 return Result; 2811 end if; 2812 2813 Expr1 := Expr2; 2814 end loop; 2815 end if; 2816 2817 Next_Index (Index); 2818 end loop; 2819 end; 2820 2821 elsif Has_Discriminants (E) 2822 and Is_Constrained (E) 2823 then 2824 declare 2825 Constraint : Elmt_Id; 2826 Expr : Node_Id; 2827 2828 begin 2829 Constraint := First_Elmt (Discriminant_Constraint (E)); 2830 while Present (Constraint) loop 2831 Expr := Node (Constraint); 2832 if Nkind (Expr) = N_Identifier 2833 and then Ekind (Entity (Expr)) = E_Discriminant 2834 then 2835 Set_Has_Delayed_Freeze (E, False); 2836 Set_Freeze_Node (E, Empty); 2837 Check_Debug_Info_Needed (E); 2838 return Result; 2839 end if; 2840 2841 Next_Elmt (Constraint); 2842 end loop; 2843 end; 2844 end if; 2845 2846 -- AI-117 requires that all new primitives of a tagged type 2847 -- must inherit the convention of the full view of the type. 2848 -- Inherited and overriding operations are defined to inherit 2849 -- the convention of their parent or overridden subprogram 2850 -- (also specified in AI-117), and that will have occurred 2851 -- earlier (in Derive_Subprogram and New_Overloaded_Entity). 2852 -- Here we set the convention of primitives that are still 2853 -- convention Ada, which will ensure that any new primitives 2854 -- inherit the type's convention. Class-wide types can have 2855 -- a foreign convention inherited from their specific type, 2856 -- but are excluded from this since they don't have any 2857 -- associated primitives. 2858 2859 if Is_Tagged_Type (E) 2860 and then not Is_Class_Wide_Type (E) 2861 and then Convention (E) /= Convention_Ada 2862 then 2863 declare 2864 Prim_List : constant Elist_Id := Primitive_Operations (E); 2865 Prim : Elmt_Id; 2866 begin 2867 Prim := First_Elmt (Prim_List); 2868 while Present (Prim) loop 2869 if Convention (Node (Prim)) = Convention_Ada then 2870 Set_Convention (Node (Prim), Convention (E)); 2871 end if; 2872 2873 Next_Elmt (Prim); 2874 end loop; 2875 end; 2876 end if; 2877 end if; 2878 2879 -- Generate primitive operation references for a tagged type 2880 2881 if Is_Tagged_Type (E) 2882 and then not Is_Class_Wide_Type (E) 2883 then 2884 declare 2885 Prim_List : constant Elist_Id := Primitive_Operations (E); 2886 Prim : Elmt_Id; 2887 Ent : Entity_Id; 2888 2889 begin 2890 Prim := First_Elmt (Prim_List); 2891 while Present (Prim) loop 2892 Ent := Node (Prim); 2893 2894 -- If the operation is derived, get the original for 2895 -- cross-reference purposes (it is the original for 2896 -- which we want the xref, and for which the comes 2897 -- from source test needs to be performed). 2898 2899 while Present (Alias (Ent)) loop 2900 Ent := Alias (Ent); 2901 end loop; 2902 2903 Generate_Reference (E, Ent, 'p', Set_Ref => False); 2904 Next_Elmt (Prim); 2905 end loop; 2906 2907 -- If we get an exception, then something peculiar has happened 2908 -- probably as a result of a previous error. Since this is only 2909 -- for non-critical cross-references, ignore the error. 2910 2911 exception 2912 when others => null; 2913 end; 2914 end if; 2915 2916 -- Now that all types from which E may depend are frozen, see 2917 -- if the size is known at compile time, if it must be unsigned, 2918 -- or if strict alignent is required 2919 2920 Check_Compile_Time_Size (E); 2921 Check_Unsigned_Type (E); 2922 2923 if Base_Type (E) = E then 2924 Check_Strict_Alignment (E); 2925 end if; 2926 2927 -- Do not allow a size clause for a type which does not have a size 2928 -- that is known at compile time 2929 2930 if Has_Size_Clause (E) 2931 and then not Size_Known_At_Compile_Time (E) 2932 then 2933 -- Supress this message if errors posted on E, even if we are 2934 -- in all errors mode, since this is often a junk message 2935 2936 if not Error_Posted (E) then 2937 Error_Msg_N 2938 ("size clause not allowed for variable length type", 2939 Size_Clause (E)); 2940 end if; 2941 end if; 2942 2943 -- Remaining process is to set/verify the representation information, 2944 -- in particular the size and alignment values. This processing is 2945 -- not required for generic types, since generic types do not play 2946 -- any part in code generation, and so the size and alignment values 2947 -- for suhc types are irrelevant. 2948 2949 if Is_Generic_Type (E) then 2950 return Result; 2951 2952 -- Otherwise we call the layout procedure 2953 2954 else 2955 Layout_Type (E); 2956 end if; 2957 2958 -- End of freeze processing for type entities 2959 end if; 2960 2961 -- Here is where we logically freeze the current entity. If it has a 2962 -- freeze node, then this is the point at which the freeze node is 2963 -- linked into the result list. 2964 2965 if Has_Delayed_Freeze (E) then 2966 2967 -- If a freeze node is already allocated, use it, otherwise allocate 2968 -- a new one. The preallocation happens in the case of anonymous base 2969 -- types, where we preallocate so that we can set First_Subtype_Link. 2970 -- Note that we reset the Sloc to the current freeze location. 2971 2972 if Present (Freeze_Node (E)) then 2973 F_Node := Freeze_Node (E); 2974 Set_Sloc (F_Node, Loc); 2975 2976 else 2977 F_Node := New_Node (N_Freeze_Entity, Loc); 2978 Set_Freeze_Node (E, F_Node); 2979 Set_Access_Types_To_Process (F_Node, No_Elist); 2980 Set_TSS_Elist (F_Node, No_Elist); 2981 Set_Actions (F_Node, No_List); 2982 end if; 2983 2984 Set_Entity (F_Node, E); 2985 2986 if Result = No_List then 2987 Result := New_List (F_Node); 2988 else 2989 Append (F_Node, Result); 2990 end if; 2991 end if; 2992 2993 -- When a type is frozen, the first subtype of the type is frozen as 2994 -- well (RM 13.14(15)). This has to be done after freezing the type, 2995 -- since obviously the first subtype depends on its own base type. 2996 2997 if Is_Type (E) then 2998 Freeze_And_Append (First_Subtype (E), Loc, Result); 2999 3000 -- If we just froze a tagged non-class wide record, then freeze the 3001 -- corresponding class-wide type. This must be done after the tagged 3002 -- type itself is frozen, because the class-wide type refers to the 3003 -- tagged type which generates the class. 3004 3005 if Is_Tagged_Type (E) 3006 and then not Is_Class_Wide_Type (E) 3007 and then Present (Class_Wide_Type (E)) 3008 then 3009 Freeze_And_Append (Class_Wide_Type (E), Loc, Result); 3010 end if; 3011 end if; 3012 3013 Check_Debug_Info_Needed (E); 3014 3015 -- Special handling for subprograms 3016 3017 if Is_Subprogram (E) then 3018 3019 -- If subprogram has address clause then reset Is_Public flag, since 3020 -- we do not want the backend to generate external references. 3021 3022 if Present (Address_Clause (E)) 3023 and then not Is_Library_Level_Entity (E) 3024 then 3025 Set_Is_Public (E, False); 3026 3027 -- If no address clause and not intrinsic, then for imported 3028 -- subprogram in main unit, generate descriptor if we are in 3029 -- Propagate_Exceptions mode. 3030 3031 elsif Propagate_Exceptions 3032 and then Is_Imported (E) 3033 and then not Is_Intrinsic_Subprogram (E) 3034 and then Convention (E) /= Convention_Stubbed 3035 then 3036 if Result = No_List then 3037 Result := Empty_List; 3038 end if; 3039 3040 Generate_Subprogram_Descriptor_For_Imported_Subprogram 3041 (E, Result); 3042 end if; 3043 end if; 3044 3045 return Result; 3046 end Freeze_Entity; 3047 3048 ----------------------------- 3049 -- Freeze_Enumeration_Type -- 3050 ----------------------------- 3051 3052 procedure Freeze_Enumeration_Type (Typ : Entity_Id) is 3053 begin 3054 if Has_Foreign_Convention (Typ) 3055 and then not Has_Size_Clause (Typ) 3056 and then Esize (Typ) < Standard_Integer_Size 3057 then 3058 Init_Esize (Typ, Standard_Integer_Size); 3059 else 3060 Adjust_Esize_For_Alignment (Typ); 3061 end if; 3062 end Freeze_Enumeration_Type; 3063 3064 ----------------------- 3065 -- Freeze_Expression -- 3066 ----------------------- 3067 3068 procedure Freeze_Expression (N : Node_Id) is 3069 In_Def_Exp : constant Boolean := In_Default_Expression; 3070 Typ : Entity_Id; 3071 Nam : Entity_Id; 3072 Desig_Typ : Entity_Id; 3073 P : Node_Id; 3074 Parent_P : Node_Id; 3075 3076 Freeze_Outside : Boolean := False; 3077 -- This flag is set true if the entity must be frozen outside the 3078 -- current subprogram. This happens in the case of expander generated 3079 -- subprograms (_Init_Proc, _Input, _Output, _Read, _Write) which do 3080 -- not freeze all entities like other bodies, but which nevertheless 3081 -- may reference entities that have to be frozen before the body and 3082 -- obviously cannot be frozen inside the body. 3083 3084 function In_Exp_Body (N : Node_Id) return Boolean; 3085 -- Given an N_Handled_Sequence_Of_Statements node N, determines whether 3086 -- it is the handled statement sequence of an expander generated 3087 -- subprogram (init proc, or stream subprogram). If so, it returns 3088 -- True, otherwise False. 3089 3090 ----------------- 3091 -- In_Exp_Body -- 3092 ----------------- 3093 3094 function In_Exp_Body (N : Node_Id) return Boolean is 3095 P : Node_Id; 3096 3097 begin 3098 if Nkind (N) = N_Subprogram_Body then 3099 P := N; 3100 else 3101 P := Parent (N); 3102 end if; 3103 3104 if Nkind (P) /= N_Subprogram_Body then 3105 return False; 3106 3107 else 3108 P := Defining_Unit_Name (Specification (P)); 3109 3110 if Nkind (P) = N_Defining_Identifier 3111 and then (Is_Init_Proc (P) or else 3112 Is_TSS (P, TSS_Stream_Input) or else 3113 Is_TSS (P, TSS_Stream_Output) or else 3114 Is_TSS (P, TSS_Stream_Read) or else 3115 Is_TSS (P, TSS_Stream_Write)) 3116 then 3117 return True; 3118 else 3119 return False; 3120 end if; 3121 end if; 3122 end In_Exp_Body; 3123 3124 -- Start of processing for Freeze_Expression 3125 3126 begin 3127 -- Immediate return if freezing is inhibited. This flag is set by 3128 -- the analyzer to stop freezing on generated expressions that would 3129 -- cause freezing if they were in the source program, but which are 3130 -- not supposed to freeze, since they are created. 3131 3132 if Must_Not_Freeze (N) then 3133 return; 3134 end if; 3135 3136 -- If expression is non-static, then it does not freeze in a default 3137 -- expression, see section "Handling of Default Expressions" in the 3138 -- spec of package Sem for further details. Note that we have to 3139 -- make sure that we actually have a real expression (if we have 3140 -- a subtype indication, we can't test Is_Static_Expression!) 3141 3142 if In_Def_Exp 3143 and then Nkind (N) in N_Subexpr 3144 and then not Is_Static_Expression (N) 3145 then 3146 return; 3147 end if; 3148 3149 -- Freeze type of expression if not frozen already 3150 3151 Typ := Empty; 3152 3153 if Nkind (N) in N_Has_Etype then 3154 if not Is_Frozen (Etype (N)) then 3155 Typ := Etype (N); 3156 3157 -- Base type may be an derived numeric type that is frozen at 3158 -- the point of declaration, but first_subtype is still unfrozen. 3159 3160 elsif not Is_Frozen (First_Subtype (Etype (N))) then 3161 Typ := First_Subtype (Etype (N)); 3162 end if; 3163 end if; 3164 3165 -- For entity name, freeze entity if not frozen already. A special 3166 -- exception occurs for an identifier that did not come from source. 3167 -- We don't let such identifiers freeze a non-internal entity, i.e. 3168 -- an entity that did come from source, since such an identifier was 3169 -- generated by the expander, and cannot have any semantic effect on 3170 -- the freezing semantics. For example, this stops the parameter of 3171 -- an initialization procedure from freezing the variable. 3172 3173 if Is_Entity_Name (N) 3174 and then not Is_Frozen (Entity (N)) 3175 and then (Nkind (N) /= N_Identifier 3176 or else Comes_From_Source (N) 3177 or else not Comes_From_Source (Entity (N))) 3178 then 3179 Nam := Entity (N); 3180 else 3181 Nam := Empty; 3182 end if; 3183 3184 -- For an allocator freeze designated type if not frozen already. 3185 3186 -- For an aggregate whose component type is an access type, freeze 3187 -- the designated type now, so that its freeze does not appear within 3188 -- the loop that might be created in the expansion of the aggregate. 3189 -- If the designated type is a private type without full view, the 3190 -- expression cannot contain an allocator, so the type is not frozen. 3191 3192 Desig_Typ := Empty; 3193 3194 case Nkind (N) is 3195 when N_Allocator => 3196 Desig_Typ := Designated_Type (Etype (N)); 3197 3198 when N_Aggregate => 3199 if Is_Array_Type (Etype (N)) 3200 and then Is_Access_Type (Component_Type (Etype (N))) 3201 then 3202 Desig_Typ := Designated_Type (Component_Type (Etype (N))); 3203 end if; 3204 3205 when N_Selected_Component | 3206 N_Indexed_Component | 3207 N_Slice => 3208 3209 if Is_Access_Type (Etype (Prefix (N))) then 3210 Desig_Typ := Designated_Type (Etype (Prefix (N))); 3211 end if; 3212 3213 when others => 3214 null; 3215 end case; 3216 3217 if Desig_Typ /= Empty 3218 and then (Is_Frozen (Desig_Typ) 3219 or else (not Is_Fully_Defined (Desig_Typ))) 3220 then 3221 Desig_Typ := Empty; 3222 end if; 3223 3224 -- All done if nothing needs freezing 3225 3226 if No (Typ) 3227 and then No (Nam) 3228 and then No (Desig_Typ) 3229 then 3230 return; 3231 end if; 3232 3233 -- Loop for looking at the right place to insert the freeze nodes 3234 -- exiting from the loop when it is appropriate to insert the freeze 3235 -- node before the current node P. 3236 3237 -- Also checks some special exceptions to the freezing rules. These 3238 -- cases result in a direct return, bypassing the freeze action. 3239 3240 P := N; 3241 loop 3242 Parent_P := Parent (P); 3243 3244 -- If we don't have a parent, then we are not in a well-formed 3245 -- tree. This is an unusual case, but there are some legitimate 3246 -- situations in which this occurs, notably when the expressions 3247 -- in the range of a type declaration are resolved. We simply 3248 -- ignore the freeze request in this case. Is this right ??? 3249 3250 if No (Parent_P) then 3251 return; 3252 end if; 3253 3254 -- See if we have got to an appropriate point in the tree 3255 3256 case Nkind (Parent_P) is 3257 3258 -- A special test for the exception of (RM 13.14(8)) for the 3259 -- case of per-object expressions (RM 3.8(18)) occurring in a 3260 -- component definition or a discrete subtype definition. Note 3261 -- that we test for a component declaration which includes both 3262 -- cases we are interested in, and furthermore the tree does not 3263 -- have explicit nodes for either of these two constructs. 3264 3265 when N_Component_Declaration => 3266 3267 -- The case we want to test for here is an identifier that is 3268 -- a per-object expression, this is either a discriminant that 3269 -- appears in a context other than the component declaration 3270 -- or it is a reference to the type of the enclosing construct. 3271 3272 -- For either of these cases, we skip the freezing 3273 3274 if not In_Default_Expression 3275 and then Nkind (N) = N_Identifier 3276 and then (Present (Entity (N))) 3277 then 3278 -- We recognize the discriminant case by just looking for 3279 -- a reference to a discriminant. It can only be one for 3280 -- the enclosing construct. Skip freezing in this case. 3281 3282 if Ekind (Entity (N)) = E_Discriminant then 3283 return; 3284 3285 -- For the case of a reference to the enclosing record, 3286 -- (or task or protected type), we look for a type that 3287 -- matches the current scope. 3288 3289 elsif Entity (N) = Current_Scope then 3290 return; 3291 end if; 3292 end if; 3293 3294 -- If we have an enumeration literal that appears as the 3295 -- choice in the aggregate of an enumeration representation 3296 -- clause, then freezing does not occur (RM 13.14(10)). 3297 3298 when N_Enumeration_Representation_Clause => 3299 3300 -- The case we are looking for is an enumeration literal 3301 3302 if (Nkind (N) = N_Identifier or Nkind (N) = N_Character_Literal) 3303 and then Is_Enumeration_Type (Etype (N)) 3304 then 3305 -- If enumeration literal appears directly as the choice, 3306 -- do not freeze (this is the normal non-overloade case) 3307 3308 if Nkind (Parent (N)) = N_Component_Association 3309 and then First (Choices (Parent (N))) = N 3310 then 3311 return; 3312 3313 -- If enumeration literal appears as the name of a 3314 -- function which is the choice, then also do not freeze. 3315 -- This happens in the overloaded literal case, where the 3316 -- enumeration literal is temporarily changed to a function 3317 -- call for overloading analysis purposes. 3318 3319 elsif Nkind (Parent (N)) = N_Function_Call 3320 and then 3321 Nkind (Parent (Parent (N))) = N_Component_Association 3322 and then 3323 First (Choices (Parent (Parent (N)))) = Parent (N) 3324 then 3325 return; 3326 end if; 3327 end if; 3328 3329 -- Normally if the parent is a handled sequence of statements, 3330 -- then the current node must be a statement, and that is an 3331 -- appropriate place to insert a freeze node. 3332 3333 when N_Handled_Sequence_Of_Statements => 3334 3335 -- An exception occurs when the sequence of statements is 3336 -- for an expander generated body that did not do the usual 3337 -- freeze all operation. In this case we usually want to 3338 -- freeze outside this body, not inside it, and we skip 3339 -- past the subprogram body that we are inside. 3340 3341 if In_Exp_Body (Parent_P) then 3342 3343 -- However, we *do* want to freeze at this point if we have 3344 -- an entity to freeze, and that entity is declared *inside* 3345 -- the body of the expander generated procedure. This case 3346 -- is recognized by the scope of the type, which is either 3347 -- the spec for some enclosing body, or (in the case of 3348 -- init_procs, for which there are no separate specs) the 3349 -- current scope. 3350 3351 declare 3352 Subp : constant Node_Id := Parent (Parent_P); 3353 Cspc : Entity_Id; 3354 3355 begin 3356 if Nkind (Subp) = N_Subprogram_Body then 3357 Cspc := Corresponding_Spec (Subp); 3358 3359 if (Present (Typ) and then Scope (Typ) = Cspc) 3360 or else 3361 (Present (Nam) and then Scope (Nam) = Cspc) 3362 then 3363 exit; 3364 3365 elsif Present (Typ) 3366 and then Scope (Typ) = Current_Scope 3367 and then Current_Scope = Defining_Entity (Subp) 3368 then 3369 exit; 3370 end if; 3371 end if; 3372 end; 3373 3374 -- If not that exception to the exception, then this is 3375 -- where we delay the freeze till outside the body. 3376 3377 Parent_P := Parent (Parent_P); 3378 Freeze_Outside := True; 3379 3380 -- Here if normal case where we are in handled statement 3381 -- sequence and want to do the insertion right there. 3382 3383 else 3384 exit; 3385 end if; 3386 3387 -- If parent is a body or a spec or a block, then the current 3388 -- node is a statement or declaration and we can insert the 3389 -- freeze node before it. 3390 3391 when N_Package_Specification | 3392 N_Package_Body | 3393 N_Subprogram_Body | 3394 N_Task_Body | 3395 N_Protected_Body | 3396 N_Entry_Body | 3397 N_Block_Statement => exit; 3398 3399 -- The expander is allowed to define types in any statements list, 3400 -- so any of the following parent nodes also mark a freezing point 3401 -- if the actual node is in a list of statements or declarations. 3402 3403 when N_Exception_Handler | 3404 N_If_Statement | 3405 N_Elsif_Part | 3406 N_Case_Statement_Alternative | 3407 N_Compilation_Unit_Aux | 3408 N_Selective_Accept | 3409 N_Accept_Alternative | 3410 N_Delay_Alternative | 3411 N_Conditional_Entry_Call | 3412 N_Entry_Call_Alternative | 3413 N_Triggering_Alternative | 3414 N_Abortable_Part | 3415 N_Freeze_Entity => 3416 3417 exit when Is_List_Member (P); 3418 3419 -- Note: The N_Loop_Statement is a special case. A type that 3420 -- appears in the source can never be frozen in a loop (this 3421 -- occurs only because of a loop expanded by the expander), 3422 -- so we keep on going. Otherwise we terminate the search. 3423 -- Same is true of any entity which comes from source. (if they 3424 -- have a predefined type, that type does not appear to come 3425 -- from source, but the entity should not be frozen here). 3426 3427 when N_Loop_Statement => 3428 exit when not Comes_From_Source (Etype (N)) 3429 and then (No (Nam) or else not Comes_From_Source (Nam)); 3430 3431 -- For all other cases, keep looking at parents 3432 3433 when others => 3434 null; 3435 end case; 3436 3437 -- We fall through the case if we did not yet find the proper 3438 -- place in the free for inserting the freeze node, so climb! 3439 3440 P := Parent_P; 3441 end loop; 3442 3443 -- If the expression appears in a record or an initialization 3444 -- procedure, the freeze nodes are collected and attached to 3445 -- the current scope, to be inserted and analyzed on exit from 3446 -- the scope, to insure that generated entities appear in the 3447 -- correct scope. If the expression is a default for a discriminant 3448 -- specification, the scope is still void. The expression can also 3449 -- appear in the discriminant part of a private or concurrent type. 3450 3451 -- The other case requiring this special handling is if we are in 3452 -- a default expression, since in that case we are about to freeze 3453 -- a static type, and the freeze scope needs to be the outer scope, 3454 -- not the scope of the subprogram with the default parameter. 3455 3456 -- For default expressions in generic units, the Move_Freeze_Nodes 3457 -- mechanism (see sem_ch12.adb) takes care of placing them at the 3458 -- proper place, after the generic unit. 3459 3460 if (In_Def_Exp and not Inside_A_Generic) 3461 or else Freeze_Outside 3462 or else (Is_Type (Current_Scope) 3463 and then (not Is_Concurrent_Type (Current_Scope) 3464 or else not Has_Completion (Current_Scope))) 3465 or else Ekind (Current_Scope) = E_Void 3466 then 3467 declare 3468 Loc : constant Source_Ptr := Sloc (Current_Scope); 3469 Freeze_Nodes : List_Id := No_List; 3470 3471 begin 3472 if Present (Desig_Typ) then 3473 Freeze_And_Append (Desig_Typ, Loc, Freeze_Nodes); 3474 end if; 3475 3476 if Present (Typ) then 3477 Freeze_And_Append (Typ, Loc, Freeze_Nodes); 3478 end if; 3479 3480 if Present (Nam) then 3481 Freeze_And_Append (Nam, Loc, Freeze_Nodes); 3482 end if; 3483 3484 if Is_Non_Empty_List (Freeze_Nodes) then 3485 if No (Scope_Stack.Table 3486 (Scope_Stack.Last).Pending_Freeze_Actions) 3487 then 3488 Scope_Stack.Table 3489 (Scope_Stack.Last).Pending_Freeze_Actions := 3490 Freeze_Nodes; 3491 else 3492 Append_List (Freeze_Nodes, Scope_Stack.Table 3493 (Scope_Stack.Last).Pending_Freeze_Actions); 3494 end if; 3495 end if; 3496 end; 3497 3498 return; 3499 end if; 3500 3501 -- Now we have the right place to do the freezing. First, a special 3502 -- adjustment, if we are in default expression analysis mode, these 3503 -- freeze actions must not be thrown away (normally all inserted 3504 -- actions are thrown away in this mode. However, the freeze actions 3505 -- are from static expressions and one of the important reasons we 3506 -- are doing this special analysis is to get these freeze actions. 3507 -- Therefore we turn off the In_Default_Expression mode to propagate 3508 -- these freeze actions. This also means they get properly analyzed 3509 -- and expanded. 3510 3511 In_Default_Expression := False; 3512 3513 -- Freeze the designated type of an allocator (RM 13.14(13)) 3514 3515 if Present (Desig_Typ) then 3516 Freeze_Before (P, Desig_Typ); 3517 end if; 3518 3519 -- Freeze type of expression (RM 13.14(10)). Note that we took care of 3520 -- the enumeration representation clause exception in the loop above. 3521 3522 if Present (Typ) then 3523 Freeze_Before (P, Typ); 3524 end if; 3525 3526 -- Freeze name if one is present (RM 13.14(11)) 3527 3528 if Present (Nam) then 3529 Freeze_Before (P, Nam); 3530 end if; 3531 3532 In_Default_Expression := In_Def_Exp; 3533 end Freeze_Expression; 3534 3535 ----------------------------- 3536 -- Freeze_Fixed_Point_Type -- 3537 ----------------------------- 3538 3539 -- Certain fixed-point types and subtypes, including implicit base 3540 -- types and declared first subtypes, have not yet set up a range. 3541 -- This is because the range cannot be set until the Small and Size 3542 -- values are known, and these are not known till the type is frozen. 3543 3544 -- To signal this case, Scalar_Range contains an unanalyzed syntactic 3545 -- range whose bounds are unanalyzed real literals. This routine will 3546 -- recognize this case, and transform this range node into a properly 3547 -- typed range with properly analyzed and resolved values. 3548 3549 procedure Freeze_Fixed_Point_Type (Typ : Entity_Id) is 3550 Rng : constant Node_Id := Scalar_Range (Typ); 3551 Lo : constant Node_Id := Low_Bound (Rng); 3552 Hi : constant Node_Id := High_Bound (Rng); 3553 Btyp : constant Entity_Id := Base_Type (Typ); 3554 Brng : constant Node_Id := Scalar_Range (Btyp); 3555 BLo : constant Node_Id := Low_Bound (Brng); 3556 BHi : constant Node_Id := High_Bound (Brng); 3557 Small : constant Ureal := Small_Value (Typ); 3558 Loval : Ureal; 3559 Hival : Ureal; 3560 Atype : Entity_Id; 3561 3562 Actual_Size : Nat; 3563 3564 function Fsize (Lov, Hiv : Ureal) return Nat; 3565 -- Returns size of type with given bounds. Also leaves these 3566 -- bounds set as the current bounds of the Typ. 3567 3568 function Fsize (Lov, Hiv : Ureal) return Nat is 3569 begin 3570 Set_Realval (Lo, Lov); 3571 Set_Realval (Hi, Hiv); 3572 return Minimum_Size (Typ); 3573 end Fsize; 3574 3575 -- Start of processing for Freeze_Fixed_Point_Type; 3576 3577 begin 3578 -- If Esize of a subtype has not previously been set, set it now 3579 3580 if Unknown_Esize (Typ) then 3581 Atype := Ancestor_Subtype (Typ); 3582 3583 if Present (Atype) then 3584 Set_Esize (Typ, Esize (Atype)); 3585 else 3586 Set_Esize (Typ, Esize (Base_Type (Typ))); 3587 end if; 3588 end if; 3589 3590 -- Immediate return if the range is already analyzed. This means 3591 -- that the range is already set, and does not need to be computed 3592 -- by this routine. 3593 3594 if Analyzed (Rng) then 3595 return; 3596 end if; 3597 3598 -- Immediate return if either of the bounds raises Constraint_Error 3599 3600 if Raises_Constraint_Error (Lo) 3601 or else Raises_Constraint_Error (Hi) 3602 then 3603 return; 3604 end if; 3605 3606 Loval := Realval (Lo); 3607 Hival := Realval (Hi); 3608 3609 -- Ordinary fixed-point case 3610 3611 if Is_Ordinary_Fixed_Point_Type (Typ) then 3612 3613 -- For the ordinary fixed-point case, we are allowed to fudge the 3614 -- end-points up or down by small. Generally we prefer to fudge 3615 -- up, i.e. widen the bounds for non-model numbers so that the 3616 -- end points are included. However there are cases in which this 3617 -- cannot be done, and indeed cases in which we may need to narrow 3618 -- the bounds. The following circuit makes the decision. 3619 3620 -- Note: our terminology here is that Incl_EP means that the 3621 -- bounds are widened by Small if necessary to include the end 3622 -- points, and Excl_EP means that the bounds are narrowed by 3623 -- Small to exclude the end-points if this reduces the size. 3624 3625 -- Note that in the Incl case, all we care about is including the 3626 -- end-points. In the Excl case, we want to narrow the bounds as 3627 -- much as permitted by the RM, to give the smallest possible size. 3628 3629 Fudge : declare 3630 Loval_Incl_EP : Ureal; 3631 Hival_Incl_EP : Ureal; 3632 3633 Loval_Excl_EP : Ureal; 3634 Hival_Excl_EP : Ureal; 3635 3636 Size_Incl_EP : Nat; 3637 Size_Excl_EP : Nat; 3638 3639 Model_Num : Ureal; 3640 First_Subt : Entity_Id; 3641 Actual_Lo : Ureal; 3642 Actual_Hi : Ureal; 3643 3644 begin 3645 -- First step. Base types are required to be symmetrical. Right 3646 -- now, the base type range is a copy of the first subtype range. 3647 -- This will be corrected before we are done, but right away we 3648 -- need to deal with the case where both bounds are non-negative. 3649 -- In this case, we set the low bound to the negative of the high 3650 -- bound, to make sure that the size is computed to include the 3651 -- required sign. Note that we do not need to worry about the 3652 -- case of both bounds negative, because the sign will be dealt 3653 -- with anyway. Furthermore we can't just go making such a bound 3654 -- symmetrical, since in a twos-complement system, there is an 3655 -- extra negative value which could not be accomodated on the 3656 -- positive side. 3657 3658 if Typ = Btyp 3659 and then not UR_Is_Negative (Loval) 3660 and then Hival > Loval 3661 then 3662 Loval := -Hival; 3663 Set_Realval (Lo, Loval); 3664 end if; 3665 3666 -- Compute the fudged bounds. If the number is a model number, 3667 -- then we do nothing to include it, but we are allowed to 3668 -- backoff to the next adjacent model number when we exclude 3669 -- it. If it is not a model number then we straddle the two 3670 -- values with the model numbers on either side. 3671 3672 Model_Num := UR_Trunc (Loval / Small) * Small; 3673 3674 if Loval = Model_Num then 3675 Loval_Incl_EP := Model_Num; 3676 else 3677 Loval_Incl_EP := Model_Num - Small; 3678 end if; 3679 3680 -- The low value excluding the end point is Small greater, but 3681 -- we do not do this exclusion if the low value is positive, 3682 -- since it can't help the size and could actually hurt by 3683 -- crossing the high bound. 3684 3685 if UR_Is_Negative (Loval_Incl_EP) then 3686 Loval_Excl_EP := Loval_Incl_EP + Small; 3687 else 3688 Loval_Excl_EP := Loval_Incl_EP; 3689 end if; 3690 3691 -- Similar processing for upper bound and high value 3692 3693 Model_Num := UR_Trunc (Hival / Small) * Small; 3694 3695 if Hival = Model_Num then 3696 Hival_Incl_EP := Model_Num; 3697 else 3698 Hival_Incl_EP := Model_Num + Small; 3699 end if; 3700 3701 if UR_Is_Positive (Hival_Incl_EP) then 3702 Hival_Excl_EP := Hival_Incl_EP - Small; 3703 else 3704 Hival_Excl_EP := Hival_Incl_EP; 3705 end if; 3706 3707 -- One further adjustment is needed. In the case of subtypes, 3708 -- we cannot go outside the range of the base type, or we get 3709 -- peculiarities, and the base type range is already set. This 3710 -- only applies to the Incl values, since clearly the Excl 3711 -- values are already as restricted as they are allowed to be. 3712 3713 if Typ /= Btyp then 3714 Loval_Incl_EP := UR_Max (Loval_Incl_EP, Realval (BLo)); 3715 Hival_Incl_EP := UR_Min (Hival_Incl_EP, Realval (BHi)); 3716 end if; 3717 3718 -- Get size including and excluding end points 3719 3720 Size_Incl_EP := Fsize (Loval_Incl_EP, Hival_Incl_EP); 3721 Size_Excl_EP := Fsize (Loval_Excl_EP, Hival_Excl_EP); 3722 3723 -- No need to exclude end-points if it does not reduce size 3724 3725 if Fsize (Loval_Incl_EP, Hival_Excl_EP) = Size_Excl_EP then 3726 Loval_Excl_EP := Loval_Incl_EP; 3727 end if; 3728 3729 if Fsize (Loval_Excl_EP, Hival_Incl_EP) = Size_Excl_EP then 3730 Hival_Excl_EP := Hival_Incl_EP; 3731 end if; 3732 3733 -- Now we set the actual size to be used. We want to use the 3734 -- bounds fudged up to include the end-points but only if this 3735 -- can be done without violating a specifically given size 3736 -- size clause or causing an unacceptable increase in size. 3737 3738 -- Case of size clause given 3739 3740 if Has_Size_Clause (Typ) then 3741 3742 -- Use the inclusive size only if it is consistent with 3743 -- the explicitly specified size. 3744 3745 if Size_Incl_EP <= RM_Size (Typ) then 3746 Actual_Lo := Loval_Incl_EP; 3747 Actual_Hi := Hival_Incl_EP; 3748 Actual_Size := Size_Incl_EP; 3749 3750 -- If the inclusive size is too large, we try excluding 3751 -- the end-points (will be caught later if does not work). 3752 3753 else 3754 Actual_Lo := Loval_Excl_EP; 3755 Actual_Hi := Hival_Excl_EP; 3756 Actual_Size := Size_Excl_EP; 3757 end if; 3758 3759 -- Case of size clause not given 3760 3761 else 3762 -- If we have a base type whose corresponding first subtype 3763 -- has an explicit size that is large enough to include our 3764 -- end-points, then do so. There is no point in working hard 3765 -- to get a base type whose size is smaller than the specified 3766 -- size of the first subtype. 3767 3768 First_Subt := First_Subtype (Typ); 3769 3770 if Has_Size_Clause (First_Subt) 3771 and then Size_Incl_EP <= Esize (First_Subt) 3772 then 3773 Actual_Size := Size_Incl_EP; 3774 Actual_Lo := Loval_Incl_EP; 3775 Actual_Hi := Hival_Incl_EP; 3776 3777 -- If excluding the end-points makes the size smaller and 3778 -- results in a size of 8,16,32,64, then we take the smaller 3779 -- size. For the 64 case, this is compulsory. For the other 3780 -- cases, it seems reasonable. We like to include end points 3781 -- if we can, but not at the expense of moving to the next 3782 -- natural boundary of size. 3783 3784 elsif Size_Incl_EP /= Size_Excl_EP 3785 and then 3786 (Size_Excl_EP = 8 or else 3787 Size_Excl_EP = 16 or else 3788 Size_Excl_EP = 32 or else 3789 Size_Excl_EP = 64) 3790 then 3791 Actual_Size := Size_Excl_EP; 3792 Actual_Lo := Loval_Excl_EP; 3793 Actual_Hi := Hival_Excl_EP; 3794 3795 -- Otherwise we can definitely include the end points 3796 3797 else 3798 Actual_Size := Size_Incl_EP; 3799 Actual_Lo := Loval_Incl_EP; 3800 Actual_Hi := Hival_Incl_EP; 3801 end if; 3802 3803 -- One pathological case: normally we never fudge a low 3804 -- bound down, since it would seem to increase the size 3805 -- (if it has any effect), but for ranges containing a 3806 -- single value, or no values, the high bound can be 3807 -- small too large. Consider: 3808 3809 -- type t is delta 2.0**(-14) 3810 -- range 131072.0 .. 0; 3811 3812 -- That lower bound is *just* outside the range of 32 3813 -- bits, and does need fudging down in this case. Note 3814 -- that the bounds will always have crossed here, since 3815 -- the high bound will be fudged down if necessary, as 3816 -- in the case of: 3817 3818 -- type t is delta 2.0**(-14) 3819 -- range 131072.0 .. 131072.0; 3820 3821 -- So we can detect the situation by looking for crossed 3822 -- bounds, and if the bounds are crossed, and the low 3823 -- bound is greater than zero, we will always back it 3824 -- off by small, since this is completely harmless. 3825 3826 if Actual_Lo > Actual_Hi then 3827 if UR_Is_Positive (Actual_Lo) then 3828 Actual_Lo := Loval_Incl_EP - Small; 3829 Actual_Size := Fsize (Actual_Lo, Actual_Hi); 3830 3831 -- And of course, we need to do exactly the same parallel 3832 -- fudge for flat ranges in the negative region. 3833 3834 elsif UR_Is_Negative (Actual_Hi) then 3835 Actual_Hi := Hival_Incl_EP + Small; 3836 Actual_Size := Fsize (Actual_Lo, Actual_Hi); 3837 end if; 3838 end if; 3839 end if; 3840 3841 Set_Realval (Lo, Actual_Lo); 3842 Set_Realval (Hi, Actual_Hi); 3843 end Fudge; 3844 3845 -- For the decimal case, none of this fudging is required, since there 3846 -- are no end-point problems in the decimal case (the end-points are 3847 -- always included). 3848 3849 else 3850 Actual_Size := Fsize (Loval, Hival); 3851 end if; 3852 3853 -- At this stage, the actual size has been calculated and the proper 3854 -- required bounds are stored in the low and high bounds. 3855 3856 if Actual_Size > 64 then 3857 Error_Msg_Uint_1 := UI_From_Int (Actual_Size); 3858 Error_Msg_N 3859 ("size required (^) for type& too large, maximum is 64", Typ); 3860 Actual_Size := 64; 3861 end if; 3862 3863 -- Check size against explicit given size 3864 3865 if Has_Size_Clause (Typ) then 3866 if Actual_Size > RM_Size (Typ) then 3867 Error_Msg_Uint_1 := RM_Size (Typ); 3868 Error_Msg_Uint_2 := UI_From_Int (Actual_Size); 3869 Error_Msg_NE 3870 ("size given (^) for type& too small, minimum is ^", 3871 Size_Clause (Typ), Typ); 3872 3873 else 3874 Actual_Size := UI_To_Int (Esize (Typ)); 3875 end if; 3876 3877 -- Increase size to next natural boundary if no size clause given 3878 3879 else 3880 if Actual_Size <= 8 then 3881 Actual_Size := 8; 3882 elsif Actual_Size <= 16 then 3883 Actual_Size := 16; 3884 elsif Actual_Size <= 32 then 3885 Actual_Size := 32; 3886 else 3887 Actual_Size := 64; 3888 end if; 3889 3890 Init_Esize (Typ, Actual_Size); 3891 Adjust_Esize_For_Alignment (Typ); 3892 end if; 3893 3894 -- If we have a base type, then expand the bounds so that they 3895 -- extend to the full width of the allocated size in bits, to 3896 -- avoid junk range checks on intermediate computations. 3897 3898 if Base_Type (Typ) = Typ then 3899 Set_Realval (Lo, -(Small * (Uint_2 ** (Actual_Size - 1)))); 3900 Set_Realval (Hi, (Small * (Uint_2 ** (Actual_Size - 1) - 1))); 3901 end if; 3902 3903 -- Final step is to reanalyze the bounds using the proper type 3904 -- and set the Corresponding_Integer_Value fields of the literals. 3905 3906 Set_Etype (Lo, Empty); 3907 Set_Analyzed (Lo, False); 3908 Analyze (Lo); 3909 3910 -- Resolve with universal fixed if the base type, and the base 3911 -- type if it is a subtype. Note we can't resolve the base type 3912 -- with itself, that would be a reference before definition. 3913 3914 if Typ = Btyp then 3915 Resolve (Lo, Universal_Fixed); 3916 else 3917 Resolve (Lo, Btyp); 3918 end if; 3919 3920 -- Set corresponding integer value for bound 3921 3922 Set_Corresponding_Integer_Value 3923 (Lo, UR_To_Uint (Realval (Lo) / Small)); 3924 3925 -- Similar processing for high bound 3926 3927 Set_Etype (Hi, Empty); 3928 Set_Analyzed (Hi, False); 3929 Analyze (Hi); 3930 3931 if Typ = Btyp then 3932 Resolve (Hi, Universal_Fixed); 3933 else 3934 Resolve (Hi, Btyp); 3935 end if; 3936 3937 Set_Corresponding_Integer_Value 3938 (Hi, UR_To_Uint (Realval (Hi) / Small)); 3939 3940 -- Set type of range to correspond to bounds 3941 3942 Set_Etype (Rng, Etype (Lo)); 3943 3944 -- Set Esize to calculated size if not set already 3945 3946 if Unknown_Esize (Typ) then 3947 Init_Esize (Typ, Actual_Size); 3948 end if; 3949 3950 -- Set RM_Size if not already set. If already set, check value 3951 3952 declare 3953 Minsiz : constant Uint := UI_From_Int (Minimum_Size (Typ)); 3954 3955 begin 3956 if RM_Size (Typ) /= Uint_0 then 3957 if RM_Size (Typ) < Minsiz then 3958 Error_Msg_Uint_1 := RM_Size (Typ); 3959 Error_Msg_Uint_2 := Minsiz; 3960 Error_Msg_NE 3961 ("size given (^) for type& too small, minimum is ^", 3962 Size_Clause (Typ), Typ); 3963 end if; 3964 3965 else 3966 Set_RM_Size (Typ, Minsiz); 3967 end if; 3968 end; 3969 end Freeze_Fixed_Point_Type; 3970 3971 ------------------ 3972 -- Freeze_Itype -- 3973 ------------------ 3974 3975 procedure Freeze_Itype (T : Entity_Id; N : Node_Id) is 3976 L : List_Id; 3977 3978 begin 3979 Set_Has_Delayed_Freeze (T); 3980 L := Freeze_Entity (T, Sloc (N)); 3981 3982 if Is_Non_Empty_List (L) then 3983 Insert_Actions (N, L); 3984 end if; 3985 end Freeze_Itype; 3986 3987 -------------------------- 3988 -- Freeze_Static_Object -- 3989 -------------------------- 3990 3991 procedure Freeze_Static_Object (E : Entity_Id) is 3992 3993 Cannot_Be_Static : exception; 3994 -- Exception raised if the type of a static object cannot be made 3995 -- static. This happens if the type depends on non-global objects. 3996 3997 procedure Ensure_Expression_Is_SA (N : Node_Id); 3998 -- Called to ensure that an expression used as part of a type 3999 -- definition is statically allocatable, which means that the type 4000 -- of the expression is statically allocatable, and the expression 4001 -- is either static, or a reference to a library level constant. 4002 4003 procedure Ensure_Type_Is_SA (Typ : Entity_Id); 4004 -- Called to mark a type as static, checking that it is possible 4005 -- to set the type as static. If it is not possible, then the 4006 -- exception Cannot_Be_Static is raised. 4007 4008 ----------------------------- 4009 -- Ensure_Expression_Is_SA -- 4010 ----------------------------- 4011 4012 procedure Ensure_Expression_Is_SA (N : Node_Id) is 4013 Ent : Entity_Id; 4014 4015 begin 4016 Ensure_Type_Is_SA (Etype (N)); 4017 4018 if Is_Static_Expression (N) then 4019 return; 4020 4021 elsif Nkind (N) = N_Identifier then 4022 Ent := Entity (N); 4023 4024 if Present (Ent) 4025 and then Ekind (Ent) = E_Constant 4026 and then Is_Library_Level_Entity (Ent) 4027 then 4028 return; 4029 end if; 4030 end if; 4031 4032 raise Cannot_Be_Static; 4033 end Ensure_Expression_Is_SA; 4034 4035 ----------------------- 4036 -- Ensure_Type_Is_SA -- 4037 ----------------------- 4038 4039 procedure Ensure_Type_Is_SA (Typ : Entity_Id) is 4040 N : Node_Id; 4041 C : Entity_Id; 4042 4043 begin 4044 -- If type is library level, we are all set 4045 4046 if Is_Library_Level_Entity (Typ) then 4047 return; 4048 end if; 4049 4050 -- We are also OK if the type is already marked as statically 4051 -- allocated, which means we processed it before. 4052 4053 if Is_Statically_Allocated (Typ) then 4054 return; 4055 end if; 4056 4057 -- Mark type as statically allocated 4058 4059 Set_Is_Statically_Allocated (Typ); 4060 4061 -- Check that it is safe to statically allocate this type 4062 4063 if Is_Scalar_Type (Typ) or else Is_Real_Type (Typ) then 4064 Ensure_Expression_Is_SA (Type_Low_Bound (Typ)); 4065 Ensure_Expression_Is_SA (Type_High_Bound (Typ)); 4066 4067 elsif Is_Array_Type (Typ) then 4068 N := First_Index (Typ); 4069 while Present (N) loop 4070 Ensure_Type_Is_SA (Etype (N)); 4071 Next_Index (N); 4072 end loop; 4073 4074 Ensure_Type_Is_SA (Component_Type (Typ)); 4075 4076 elsif Is_Access_Type (Typ) then 4077 if Ekind (Designated_Type (Typ)) = E_Subprogram_Type then 4078 4079 declare 4080 F : Entity_Id; 4081 T : constant Entity_Id := Etype (Designated_Type (Typ)); 4082 4083 begin 4084 if T /= Standard_Void_Type then 4085 Ensure_Type_Is_SA (T); 4086 end if; 4087 4088 F := First_Formal (Designated_Type (Typ)); 4089 4090 while Present (F) loop 4091 Ensure_Type_Is_SA (Etype (F)); 4092 Next_Formal (F); 4093 end loop; 4094 end; 4095 4096 else 4097 Ensure_Type_Is_SA (Designated_Type (Typ)); 4098 end if; 4099 4100 elsif Is_Record_Type (Typ) then 4101 C := First_Entity (Typ); 4102 4103 while Present (C) loop 4104 if Ekind (C) = E_Discriminant 4105 or else Ekind (C) = E_Component 4106 then 4107 Ensure_Type_Is_SA (Etype (C)); 4108 4109 elsif Is_Type (C) then 4110 Ensure_Type_Is_SA (C); 4111 end if; 4112 4113 Next_Entity (C); 4114 end loop; 4115 4116 elsif Ekind (Typ) = E_Subprogram_Type then 4117 Ensure_Type_Is_SA (Etype (Typ)); 4118 4119 C := First_Formal (Typ); 4120 while Present (C) loop 4121 Ensure_Type_Is_SA (Etype (C)); 4122 Next_Formal (C); 4123 end loop; 4124 4125 else 4126 raise Cannot_Be_Static; 4127 end if; 4128 end Ensure_Type_Is_SA; 4129 4130 -- Start of processing for Freeze_Static_Object 4131 4132 begin 4133 Ensure_Type_Is_SA (Etype (E)); 4134 4135 -- Reset True_Constant flag, since something strange is going on 4136 -- with the scoping here, and our simple value traceing may not 4137 -- be sufficient for this indication to be reliable. We kill the 4138 -- Constant_Value indication for the same reason. 4139 4140 Set_Is_True_Constant (E, False); 4141 Set_Current_Value (E, Empty); 4142 4143 exception 4144 when Cannot_Be_Static => 4145 4146 -- If the object that cannot be static is imported or exported, 4147 -- then we give an error message saying that this object cannot 4148 -- be imported or exported. 4149 4150 if Is_Imported (E) then 4151 Error_Msg_N 4152 ("& cannot be imported (local type is not constant)", E); 4153 4154 -- Otherwise must be exported, something is wrong if compiler 4155 -- is marking something as statically allocated which cannot be). 4156 4157 else pragma Assert (Is_Exported (E)); 4158 Error_Msg_N 4159 ("& cannot be exported (local type is not constant)", E); 4160 end if; 4161 end Freeze_Static_Object; 4162 4163 ----------------------- 4164 -- Freeze_Subprogram -- 4165 ----------------------- 4166 4167 procedure Freeze_Subprogram (E : Entity_Id) is 4168 Retype : Entity_Id; 4169 F : Entity_Id; 4170 4171 begin 4172 -- Subprogram may not have an address clause unless it is imported 4173 4174 if Present (Address_Clause (E)) then 4175 if not Is_Imported (E) then 4176 Error_Msg_N 4177 ("address clause can only be given " & 4178 "for imported subprogram", 4179 Name (Address_Clause (E))); 4180 end if; 4181 end if; 4182 4183 -- Reset the Pure indication on an imported subprogram unless an 4184 -- explicit Pure_Function pragma was present. We do this because 4185 -- otherwise it is an insidious error to call a non-pure function 4186 -- from a pure unit and have calls mysteriously optimized away. 4187 -- What happens here is that the Import can bypass the normal 4188 -- check to ensure that pure units call only pure subprograms. 4189 4190 if Is_Imported (E) 4191 and then Is_Pure (E) 4192 and then not Has_Pragma_Pure_Function (E) 4193 then 4194 Set_Is_Pure (E, False); 4195 end if; 4196 4197 -- For non-foreign convention subprograms, this is where we create 4198 -- the extra formals (for accessibility level and constrained bit 4199 -- information). We delay this till the freeze point precisely so 4200 -- that we know the convention! 4201 4202 if not Has_Foreign_Convention (E) then 4203 Create_Extra_Formals (E); 4204 Set_Mechanisms (E); 4205 4206 -- If this is convention Ada and a Valued_Procedure, that's odd 4207 4208 if Ekind (E) = E_Procedure 4209 and then Is_Valued_Procedure (E) 4210 and then Convention (E) = Convention_Ada 4211 and then Warn_On_Export_Import 4212 then 4213 Error_Msg_N 4214 ("?Valued_Procedure has no effect for convention Ada", E); 4215 Set_Is_Valued_Procedure (E, False); 4216 end if; 4217 4218 -- Case of foreign convention 4219 4220 else 4221 Set_Mechanisms (E); 4222 4223 -- For foreign conventions, warn about return of an 4224 -- unconstrained array. 4225 4226 -- Note: we *do* allow a return by descriptor for the VMS case, 4227 -- though here there is probably more to be done ??? 4228 4229 if Ekind (E) = E_Function then 4230 Retype := Underlying_Type (Etype (E)); 4231 4232 -- If no return type, probably some other error, e.g. a 4233 -- missing full declaration, so ignore. 4234 4235 if No (Retype) then 4236 null; 4237 4238 -- If the return type is generic, we have emitted a warning 4239 -- earlier on, and there is nothing else to check here. 4240 -- Specific instantiations may lead to erroneous behavior. 4241 4242 elsif Is_Generic_Type (Etype (E)) then 4243 null; 4244 4245 elsif Is_Array_Type (Retype) 4246 and then not Is_Constrained (Retype) 4247 and then Mechanism (E) not in Descriptor_Codes 4248 and then Warn_On_Export_Import 4249 then 4250 Error_Msg_N 4251 ("?foreign convention function& should not return " & 4252 "unconstrained array", E); 4253 return; 4254 end if; 4255 end if; 4256 4257 -- If any of the formals for an exported foreign convention 4258 -- subprogram have defaults, then emit an appropriate warning 4259 -- since this is odd (default cannot be used from non-Ada code) 4260 4261 if Is_Exported (E) then 4262 F := First_Formal (E); 4263 while Present (F) loop 4264 if Warn_On_Export_Import 4265 and then Present (Default_Value (F)) 4266 then 4267 Error_Msg_N 4268 ("?parameter cannot be defaulted in non-Ada call", 4269 Default_Value (F)); 4270 end if; 4271 4272 Next_Formal (F); 4273 end loop; 4274 end if; 4275 end if; 4276 4277 -- For VMS, descriptor mechanisms for parameters are allowed only 4278 -- for imported subprograms. 4279 4280 if OpenVMS_On_Target then 4281 if not Is_Imported (E) then 4282 F := First_Formal (E); 4283 while Present (F) loop 4284 if Mechanism (F) in Descriptor_Codes then 4285 Error_Msg_N 4286 ("descriptor mechanism for parameter not permitted", F); 4287 Error_Msg_N 4288 ("\can only be used for imported subprogram", F); 4289 end if; 4290 4291 Next_Formal (F); 4292 end loop; 4293 end if; 4294 end if; 4295 end Freeze_Subprogram; 4296 4297 ----------------------- 4298 -- Is_Fully_Defined -- 4299 ----------------------- 4300 4301 function Is_Fully_Defined (T : Entity_Id) return Boolean is 4302 begin 4303 if Ekind (T) = E_Class_Wide_Type then 4304 return Is_Fully_Defined (Etype (T)); 4305 4306 elsif Is_Array_Type (T) then 4307 return Is_Fully_Defined (Component_Type (T)); 4308 4309 elsif Is_Record_Type (T) 4310 and not Is_Private_Type (T) 4311 then 4312 -- Verify that the record type has no components with 4313 -- private types without completion. 4314 4315 declare 4316 Comp : Entity_Id; 4317 4318 begin 4319 Comp := First_Component (T); 4320 4321 while Present (Comp) loop 4322 if not Is_Fully_Defined (Etype (Comp)) then 4323 return False; 4324 end if; 4325 4326 Next_Component (Comp); 4327 end loop; 4328 return True; 4329 end; 4330 4331 else return not Is_Private_Type (T) 4332 or else Present (Full_View (Base_Type (T))); 4333 end if; 4334 end Is_Fully_Defined; 4335 4336 --------------------------------- 4337 -- Process_Default_Expressions -- 4338 --------------------------------- 4339 4340 procedure Process_Default_Expressions 4341 (E : Entity_Id; 4342 After : in out Node_Id) 4343 is 4344 Loc : constant Source_Ptr := Sloc (E); 4345 Dbody : Node_Id; 4346 Formal : Node_Id; 4347 Dcopy : Node_Id; 4348 Dnam : Entity_Id; 4349 4350 begin 4351 Set_Default_Expressions_Processed (E); 4352 4353 -- A subprogram instance and its associated anonymous subprogram 4354 -- share their signature. The default expression functions are defined 4355 -- in the wrapper packages for the anonymous subprogram, and should 4356 -- not be generated again for the instance. 4357 4358 if Is_Generic_Instance (E) 4359 and then Present (Alias (E)) 4360 and then Default_Expressions_Processed (Alias (E)) 4361 then 4362 return; 4363 end if; 4364 4365 Formal := First_Formal (E); 4366 4367 while Present (Formal) loop 4368 if Present (Default_Value (Formal)) then 4369 4370 -- We work with a copy of the default expression because we 4371 -- do not want to disturb the original, since this would mess 4372 -- up the conformance checking. 4373 4374 Dcopy := New_Copy_Tree (Default_Value (Formal)); 4375 4376 -- The analysis of the expression may generate insert actions, 4377 -- which of course must not be executed. We wrap those actions 4378 -- in a procedure that is not called, and later on eliminated. 4379 -- The following cases have no side-effects, and are analyzed 4380 -- directly. 4381 4382 if Nkind (Dcopy) = N_Identifier 4383 or else Nkind (Dcopy) = N_Expanded_Name 4384 or else Nkind (Dcopy) = N_Integer_Literal 4385 or else (Nkind (Dcopy) = N_Real_Literal 4386 and then not Vax_Float (Etype (Dcopy))) 4387 or else Nkind (Dcopy) = N_Character_Literal 4388 or else Nkind (Dcopy) = N_String_Literal 4389 or else Nkind (Dcopy) = N_Null 4390 or else (Nkind (Dcopy) = N_Attribute_Reference 4391 and then 4392 Attribute_Name (Dcopy) = Name_Null_Parameter) 4393 then 4394 4395 -- If there is no default function, we must still do a full 4396 -- analyze call on the default value, to ensure that all 4397 -- error checks are performed, e.g. those associated with 4398 -- static evaluation. Note that this branch will always be 4399 -- taken if the analyzer is turned off (but we still need the 4400 -- error checks). 4401 4402 -- Note: the setting of parent here is to meet the requirement 4403 -- that we can only analyze the expression while attached to 4404 -- the tree. Really the requirement is that the parent chain 4405 -- be set, we don't actually need to be in the tree. 4406 4407 Set_Parent (Dcopy, Declaration_Node (Formal)); 4408 Analyze (Dcopy); 4409 4410 -- Default expressions are resolved with their own type if the 4411 -- context is generic, to avoid anomalies with private types. 4412 4413 if Ekind (Scope (E)) = E_Generic_Package then 4414 Resolve (Dcopy); 4415 else 4416 Resolve (Dcopy, Etype (Formal)); 4417 end if; 4418 4419 -- If that resolved expression will raise constraint error, 4420 -- then flag the default value as raising constraint error. 4421 -- This allows a proper error message on the calls. 4422 4423 if Raises_Constraint_Error (Dcopy) then 4424 Set_Raises_Constraint_Error (Default_Value (Formal)); 4425 end if; 4426 4427 -- If the default is a parameterless call, we use the name of 4428 -- the called function directly, and there is no body to build. 4429 4430 elsif Nkind (Dcopy) = N_Function_Call 4431 and then No (Parameter_Associations (Dcopy)) 4432 then 4433 null; 4434 4435 -- Else construct and analyze the body of a wrapper procedure 4436 -- that contains an object declaration to hold the expression. 4437 -- Given that this is done only to complete the analysis, it 4438 -- simpler to build a procedure than a function which might 4439 -- involve secondary stack expansion. 4440 4441 else 4442 Dnam := 4443 Make_Defining_Identifier (Loc, New_Internal_Name ('D')); 4444 4445 Dbody := 4446 Make_Subprogram_Body (Loc, 4447 Specification => 4448 Make_Procedure_Specification (Loc, 4449 Defining_Unit_Name => Dnam), 4450 4451 Declarations => New_List ( 4452 Make_Object_Declaration (Loc, 4453 Defining_Identifier => 4454 Make_Defining_Identifier (Loc, 4455 New_Internal_Name ('T')), 4456 Object_Definition => 4457 New_Occurrence_Of (Etype (Formal), Loc), 4458 Expression => New_Copy_Tree (Dcopy))), 4459 4460 Handled_Statement_Sequence => 4461 Make_Handled_Sequence_Of_Statements (Loc, 4462 Statements => New_List)); 4463 4464 Set_Scope (Dnam, Scope (E)); 4465 Set_Assignment_OK (First (Declarations (Dbody))); 4466 Set_Is_Eliminated (Dnam); 4467 Insert_After (After, Dbody); 4468 Analyze (Dbody); 4469 After := Dbody; 4470 end if; 4471 end if; 4472 4473 Next_Formal (Formal); 4474 end loop; 4475 4476 end Process_Default_Expressions; 4477 4478 ---------------------------------------- 4479 -- Set_Component_Alignment_If_Not_Set -- 4480 ---------------------------------------- 4481 4482 procedure Set_Component_Alignment_If_Not_Set (Typ : Entity_Id) is 4483 begin 4484 -- Ignore if not base type, subtypes don't need anything 4485 4486 if Typ /= Base_Type (Typ) then 4487 return; 4488 end if; 4489 4490 -- Do not override existing representation 4491 4492 if Is_Packed (Typ) then 4493 return; 4494 4495 elsif Has_Specified_Layout (Typ) then 4496 return; 4497 4498 elsif Component_Alignment (Typ) /= Calign_Default then 4499 return; 4500 4501 else 4502 Set_Component_Alignment 4503 (Typ, Scope_Stack.Table 4504 (Scope_Stack.Last).Component_Alignment_Default); 4505 end if; 4506 end Set_Component_Alignment_If_Not_Set; 4507 4508 --------------------------- 4509 -- Set_Debug_Info_Needed -- 4510 --------------------------- 4511 4512 procedure Set_Debug_Info_Needed (T : Entity_Id) is 4513 begin 4514 if No (T) 4515 or else Needs_Debug_Info (T) 4516 or else Debug_Info_Off (T) 4517 then 4518 return; 4519 else 4520 Set_Needs_Debug_Info (T); 4521 end if; 4522 4523 if Is_Object (T) then 4524 Set_Debug_Info_Needed (Etype (T)); 4525 4526 elsif Is_Type (T) then 4527 Set_Debug_Info_Needed (Etype (T)); 4528 4529 if Is_Record_Type (T) then 4530 declare 4531 Ent : Entity_Id := First_Entity (T); 4532 begin 4533 while Present (Ent) loop 4534 Set_Debug_Info_Needed (Ent); 4535 Next_Entity (Ent); 4536 end loop; 4537 end; 4538 4539 elsif Is_Array_Type (T) then 4540 Set_Debug_Info_Needed (Component_Type (T)); 4541 4542 declare 4543 Indx : Node_Id := First_Index (T); 4544 begin 4545 while Present (Indx) loop 4546 Set_Debug_Info_Needed (Etype (Indx)); 4547 Indx := Next_Index (Indx); 4548 end loop; 4549 end; 4550 4551 if Is_Packed (T) then 4552 Set_Debug_Info_Needed (Packed_Array_Type (T)); 4553 end if; 4554 4555 elsif Is_Access_Type (T) then 4556 Set_Debug_Info_Needed (Directly_Designated_Type (T)); 4557 4558 elsif Is_Private_Type (T) then 4559 Set_Debug_Info_Needed (Full_View (T)); 4560 4561 elsif Is_Protected_Type (T) then 4562 Set_Debug_Info_Needed (Corresponding_Record_Type (T)); 4563 end if; 4564 end if; 4565 end Set_Debug_Info_Needed; 4566 4567 ------------------ 4568 -- Warn_Overlay -- 4569 ------------------ 4570 4571 procedure Warn_Overlay 4572 (Expr : Node_Id; 4573 Typ : Entity_Id; 4574 Nam : Entity_Id) 4575 is 4576 Ent : constant Entity_Id := Entity (Nam); 4577 -- The object to which the address clause applies. 4578 4579 Init : Node_Id; 4580 Old : Entity_Id := Empty; 4581 Decl : Node_Id; 4582 4583 begin 4584 -- No warning if address clause overlay warnings are off 4585 4586 if not Address_Clause_Overlay_Warnings then 4587 return; 4588 end if; 4589 4590 -- No warning if there is an explicit initialization 4591 4592 Init := Original_Node (Expression (Declaration_Node (Ent))); 4593 4594 if Present (Init) and then Comes_From_Source (Init) then 4595 return; 4596 end if; 4597 4598 -- We only give the warning for non-imported entities of a type 4599 -- for which a non-null base init proc is defined (or for access 4600 -- types which have implicit null initialization). 4601 4602 if Present (Expr) 4603 and then (Has_Non_Null_Base_Init_Proc (Typ) 4604 or else Is_Access_Type (Typ)) 4605 and then not Is_Imported (Ent) 4606 then 4607 if Nkind (Expr) = N_Attribute_Reference 4608 and then Is_Entity_Name (Prefix (Expr)) 4609 then 4610 Old := Entity (Prefix (Expr)); 4611 4612 elsif Is_Entity_Name (Expr) 4613 and then Ekind (Entity (Expr)) = E_Constant 4614 then 4615 Decl := Declaration_Node (Entity (Expr)); 4616 4617 if Nkind (Decl) = N_Object_Declaration 4618 and then Present (Expression (Decl)) 4619 and then Nkind (Expression (Decl)) = N_Attribute_Reference 4620 and then Is_Entity_Name (Prefix (Expression (Decl))) 4621 then 4622 Old := Entity (Prefix (Expression (Decl))); 4623 4624 elsif Nkind (Expr) = N_Function_Call then 4625 return; 4626 end if; 4627 4628 -- A function call (most likely to To_Address) is probably not 4629 -- an overlay, so skip warning. Ditto if the function call was 4630 -- inlined and transformed into an entity. 4631 4632 elsif Nkind (Original_Node (Expr)) = N_Function_Call then 4633 return; 4634 end if; 4635 4636 Decl := Next (Parent (Expr)); 4637 4638 -- If a pragma Import follows, we assume that it is for the current 4639 -- target of the address clause, and skip the warning. 4640 4641 if Present (Decl) 4642 and then Nkind (Decl) = N_Pragma 4643 and then Chars (Decl) = Name_Import 4644 then 4645 return; 4646 end if; 4647 4648 if Present (Old) then 4649 Error_Msg_Node_2 := Old; 4650 Error_Msg_N 4651 ("default initialization of & may modify &?", 4652 Nam); 4653 else 4654 Error_Msg_N 4655 ("default initialization of & may modify overlaid storage?", 4656 Nam); 4657 end if; 4658 4659 -- Add friendly warning if initialization comes from a packed array 4660 -- component. 4661 4662 if Is_Record_Type (Typ) then 4663 declare 4664 Comp : Entity_Id; 4665 4666 begin 4667 Comp := First_Component (Typ); 4668 4669 while Present (Comp) loop 4670 if Nkind (Parent (Comp)) = N_Component_Declaration 4671 and then Present (Expression (Parent (Comp))) 4672 then 4673 exit; 4674 elsif Is_Array_Type (Etype (Comp)) 4675 and then Present (Packed_Array_Type (Etype (Comp))) 4676 then 4677 Error_Msg_NE 4678 ("packed array component& will be initialized to zero?", 4679 Nam, Comp); 4680 exit; 4681 else 4682 Next_Component (Comp); 4683 end if; 4684 end loop; 4685 end; 4686 end if; 4687 4688 Error_Msg_N 4689 ("use pragma Import for & to " & 4690 "suppress initialization ('R'M B.1(24))?", 4691 Nam); 4692 end if; 4693 end Warn_Overlay; 4694 4695end Freeze; 4696