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