1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- S E M _ C H 6 -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- 10-- -- 11-- GNAT is free software; you can redistribute it and/or modify it under -- 12-- terms of the GNU General Public License as published by the Free Soft- -- 13-- ware Foundation; either version 3, or (at your option) any later ver- -- 14-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 15-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 16-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- 17-- for more details. You should have received a copy of the GNU General -- 18-- Public License distributed with GNAT; see file COPYING3. If not, go to -- 19-- http://www.gnu.org/licenses for a complete copy of the license. -- 20-- -- 21-- GNAT was originally developed by the GNAT team at New York University. -- 22-- Extensive contributions were provided by Ada Core Technologies Inc. -- 23-- -- 24------------------------------------------------------------------------------ 25 26with Atree; use Atree; 27with Checks; use Checks; 28with Debug; use Debug; 29with Einfo; use Einfo; 30with Elists; use Elists; 31with Errout; use Errout; 32with Expander; use Expander; 33with Exp_Ch6; use Exp_Ch6; 34with Exp_Ch7; use Exp_Ch7; 35with Exp_Ch9; use Exp_Ch9; 36with Exp_Dbug; use Exp_Dbug; 37with Exp_Disp; use Exp_Disp; 38with Exp_Tss; use Exp_Tss; 39with Exp_Util; use Exp_Util; 40with Fname; use Fname; 41with Freeze; use Freeze; 42with Itypes; use Itypes; 43with Lib.Xref; use Lib.Xref; 44with Layout; use Layout; 45with Namet; use Namet; 46with Lib; use Lib; 47with Nlists; use Nlists; 48with Nmake; use Nmake; 49with Opt; use Opt; 50with Output; use Output; 51with Restrict; use Restrict; 52with Rident; use Rident; 53with Rtsfind; use Rtsfind; 54with Sem; use Sem; 55with Sem_Aux; use Sem_Aux; 56with Sem_Cat; use Sem_Cat; 57with Sem_Ch3; use Sem_Ch3; 58with Sem_Ch4; use Sem_Ch4; 59with Sem_Ch5; use Sem_Ch5; 60with Sem_Ch8; use Sem_Ch8; 61with Sem_Ch10; use Sem_Ch10; 62with Sem_Ch12; use Sem_Ch12; 63with Sem_Ch13; use Sem_Ch13; 64with Sem_Dim; use Sem_Dim; 65with Sem_Disp; use Sem_Disp; 66with Sem_Dist; use Sem_Dist; 67with Sem_Elim; use Sem_Elim; 68with Sem_Eval; use Sem_Eval; 69with Sem_Mech; use Sem_Mech; 70with Sem_Prag; use Sem_Prag; 71with Sem_Res; use Sem_Res; 72with Sem_Util; use Sem_Util; 73with Sem_Type; use Sem_Type; 74with Sem_Warn; use Sem_Warn; 75with Sinput; use Sinput; 76with Stand; use Stand; 77with Sinfo; use Sinfo; 78with Sinfo.CN; use Sinfo.CN; 79with Snames; use Snames; 80with Stringt; use Stringt; 81with Style; 82with Stylesw; use Stylesw; 83with Targparm; use Targparm; 84with Tbuild; use Tbuild; 85with Uintp; use Uintp; 86with Urealp; use Urealp; 87with Validsw; use Validsw; 88 89package body Sem_Ch6 is 90 91 May_Hide_Profile : Boolean := False; 92 -- This flag is used to indicate that two formals in two subprograms being 93 -- checked for conformance differ only in that one is an access parameter 94 -- while the other is of a general access type with the same designated 95 -- type. In this case, if the rest of the signatures match, a call to 96 -- either subprogram may be ambiguous, which is worth a warning. The flag 97 -- is set in Compatible_Types, and the warning emitted in 98 -- New_Overloaded_Entity. 99 100 ----------------------- 101 -- Local Subprograms -- 102 ----------------------- 103 104 procedure Analyze_Return_Statement (N : Node_Id); 105 -- Common processing for simple and extended return statements 106 107 procedure Analyze_Function_Return (N : Node_Id); 108 -- Subsidiary to Analyze_Return_Statement. Called when the return statement 109 -- applies to a [generic] function. 110 111 procedure Analyze_Return_Type (N : Node_Id); 112 -- Subsidiary to Process_Formals: analyze subtype mark in function 113 -- specification in a context where the formals are visible and hide 114 -- outer homographs. 115 116 procedure Analyze_Subprogram_Body_Helper (N : Node_Id); 117 -- Does all the real work of Analyze_Subprogram_Body. This is split out so 118 -- that we can use RETURN but not skip the debug output at the end. 119 120 procedure Analyze_Generic_Subprogram_Body (N : Node_Id; Gen_Id : Entity_Id); 121 -- Analyze a generic subprogram body. N is the body to be analyzed, and 122 -- Gen_Id is the defining entity Id for the corresponding spec. 123 124 procedure Build_Body_To_Inline (N : Node_Id; Subp : Entity_Id); 125 -- If a subprogram has pragma Inline and inlining is active, use generic 126 -- machinery to build an unexpanded body for the subprogram. This body is 127 -- subsequently used for inline expansions at call sites. If subprogram can 128 -- be inlined (depending on size and nature of local declarations) this 129 -- function returns true. Otherwise subprogram body is treated normally. 130 -- If proper warnings are enabled and the subprogram contains a construct 131 -- that cannot be inlined, the offending construct is flagged accordingly. 132 133 function Can_Override_Operator (Subp : Entity_Id) return Boolean; 134 -- Returns true if Subp can override a predefined operator. 135 136 procedure Check_And_Build_Body_To_Inline 137 (N : Node_Id; 138 Spec_Id : Entity_Id; 139 Body_Id : Entity_Id); 140 -- Spec_Id and Body_Id are the entities of the specification and body of 141 -- the subprogram body N. If N can be inlined by the frontend (supported 142 -- cases documented in Check_Body_To_Inline) then build the body-to-inline 143 -- associated with N and attach it to the declaration node of Spec_Id. 144 145 procedure Check_Conformance 146 (New_Id : Entity_Id; 147 Old_Id : Entity_Id; 148 Ctype : Conformance_Type; 149 Errmsg : Boolean; 150 Conforms : out Boolean; 151 Err_Loc : Node_Id := Empty; 152 Get_Inst : Boolean := False; 153 Skip_Controlling_Formals : Boolean := False); 154 -- Given two entities, this procedure checks that the profiles associated 155 -- with these entities meet the conformance criterion given by the third 156 -- parameter. If they conform, Conforms is set True and control returns 157 -- to the caller. If they do not conform, Conforms is set to False, and 158 -- in addition, if Errmsg is True on the call, proper messages are output 159 -- to complain about the conformance failure. If Err_Loc is non_Empty 160 -- the error messages are placed on Err_Loc, if Err_Loc is empty, then 161 -- error messages are placed on the appropriate part of the construct 162 -- denoted by New_Id. If Get_Inst is true, then this is a mode conformance 163 -- against a formal access-to-subprogram type so Get_Instance_Of must 164 -- be called. 165 166 procedure Check_Subprogram_Order (N : Node_Id); 167 -- N is the N_Subprogram_Body node for a subprogram. This routine applies 168 -- the alpha ordering rule for N if this ordering requirement applicable. 169 170 procedure Check_Returns 171 (HSS : Node_Id; 172 Mode : Character; 173 Err : out Boolean; 174 Proc : Entity_Id := Empty); 175 -- Called to check for missing return statements in a function body, or for 176 -- returns present in a procedure body which has No_Return set. HSS is the 177 -- handled statement sequence for the subprogram body. This procedure 178 -- checks all flow paths to make sure they either have return (Mode = 'F', 179 -- used for functions) or do not have a return (Mode = 'P', used for 180 -- No_Return procedures). The flag Err is set if there are any control 181 -- paths not explicitly terminated by a return in the function case, and is 182 -- True otherwise. Proc is the entity for the procedure case and is used 183 -- in posting the warning message. 184 185 procedure Check_Untagged_Equality (Eq_Op : Entity_Id); 186 -- In Ada 2012, a primitive equality operator on an untagged record type 187 -- must appear before the type is frozen, and have the same visibility as 188 -- that of the type. This procedure checks that this rule is met, and 189 -- otherwise emits an error on the subprogram declaration and a warning 190 -- on the earlier freeze point if it is easy to locate. 191 192 procedure Enter_Overloaded_Entity (S : Entity_Id); 193 -- This procedure makes S, a new overloaded entity, into the first visible 194 -- entity with that name. 195 196 function Is_Non_Overriding_Operation 197 (Prev_E : Entity_Id; 198 New_E : Entity_Id) return Boolean; 199 -- Enforce the rule given in 12.3(18): a private operation in an instance 200 -- overrides an inherited operation only if the corresponding operation 201 -- was overriding in the generic. This needs to be checked for primitive 202 -- operations of types derived (in the generic unit) from formal private 203 -- or formal derived types. 204 205 procedure Make_Inequality_Operator (S : Entity_Id); 206 -- Create the declaration for an inequality operator that is implicitly 207 -- created by a user-defined equality operator that yields a boolean. 208 209 procedure May_Need_Actuals (Fun : Entity_Id); 210 -- Flag functions that can be called without parameters, i.e. those that 211 -- have no parameters, or those for which defaults exist for all parameters 212 213 procedure Process_PPCs 214 (N : Node_Id; 215 Spec_Id : Entity_Id; 216 Body_Id : Entity_Id); 217 -- Called from Analyze[_Generic]_Subprogram_Body to deal with scanning post 218 -- conditions for the body and assembling and inserting the _postconditions 219 -- procedure. N is the node for the subprogram body and Body_Id/Spec_Id are 220 -- the entities for the body and separate spec (if there is no separate 221 -- spec, Spec_Id is Empty). Note that invariants and predicates may also 222 -- provide postconditions, and are also handled in this procedure. 223 224 procedure Set_Formal_Validity (Formal_Id : Entity_Id); 225 -- Formal_Id is an formal parameter entity. This procedure deals with 226 -- setting the proper validity status for this entity, which depends on 227 -- the kind of parameter and the validity checking mode. 228 229 --------------------------------------------- 230 -- Analyze_Abstract_Subprogram_Declaration -- 231 --------------------------------------------- 232 233 procedure Analyze_Abstract_Subprogram_Declaration (N : Node_Id) is 234 Designator : constant Entity_Id := 235 Analyze_Subprogram_Specification (Specification (N)); 236 Scop : constant Entity_Id := Current_Scope; 237 238 begin 239 Check_SPARK_Restriction ("abstract subprogram is not allowed", N); 240 241 Generate_Definition (Designator); 242 Set_Contract (Designator, Make_Contract (Sloc (Designator))); 243 Set_Is_Abstract_Subprogram (Designator); 244 New_Overloaded_Entity (Designator); 245 Check_Delayed_Subprogram (Designator); 246 247 Set_Categorization_From_Scope (Designator, Scop); 248 249 if Ekind (Scope (Designator)) = E_Protected_Type then 250 Error_Msg_N 251 ("abstract subprogram not allowed in protected type", N); 252 253 -- Issue a warning if the abstract subprogram is neither a dispatching 254 -- operation nor an operation that overrides an inherited subprogram or 255 -- predefined operator, since this most likely indicates a mistake. 256 257 elsif Warn_On_Redundant_Constructs 258 and then not Is_Dispatching_Operation (Designator) 259 and then not Present (Overridden_Operation (Designator)) 260 and then (not Is_Operator_Symbol_Name (Chars (Designator)) 261 or else Scop /= Scope (Etype (First_Formal (Designator)))) 262 then 263 Error_Msg_N 264 ("abstract subprogram is not dispatching or overriding?r?", N); 265 end if; 266 267 Generate_Reference_To_Formals (Designator); 268 Check_Eliminated (Designator); 269 270 if Has_Aspects (N) then 271 Analyze_Aspect_Specifications (N, Designator); 272 end if; 273 end Analyze_Abstract_Subprogram_Declaration; 274 275 --------------------------------- 276 -- Analyze_Expression_Function -- 277 --------------------------------- 278 279 procedure Analyze_Expression_Function (N : Node_Id) is 280 Loc : constant Source_Ptr := Sloc (N); 281 LocX : constant Source_Ptr := Sloc (Expression (N)); 282 Expr : constant Node_Id := Expression (N); 283 Spec : constant Node_Id := Specification (N); 284 285 Def_Id : Entity_Id; 286 287 Prev : Entity_Id; 288 -- If the expression is a completion, Prev is the entity whose 289 -- declaration is completed. Def_Id is needed to analyze the spec. 290 291 New_Body : Node_Id; 292 New_Decl : Node_Id; 293 New_Spec : Node_Id; 294 Ret : Node_Id; 295 296 begin 297 -- This is one of the occasions on which we transform the tree during 298 -- semantic analysis. If this is a completion, transform the expression 299 -- function into an equivalent subprogram body, and analyze it. 300 301 -- Expression functions are inlined unconditionally. The back-end will 302 -- determine whether this is possible. 303 304 Inline_Processing_Required := True; 305 306 -- Create a specification for the generated body. Types and defauts in 307 -- the profile are copies of the spec, but new entities must be created 308 -- for the unit name and the formals. 309 310 New_Spec := New_Copy_Tree (Spec); 311 Set_Defining_Unit_Name (New_Spec, 312 Make_Defining_Identifier (Sloc (Defining_Unit_Name (Spec)), 313 Chars (Defining_Unit_Name (Spec)))); 314 315 if Present (Parameter_Specifications (New_Spec)) then 316 declare 317 Formal_Spec : Node_Id; 318 begin 319 Formal_Spec := First (Parameter_Specifications (New_Spec)); 320 while Present (Formal_Spec) loop 321 Set_Defining_Identifier 322 (Formal_Spec, 323 Make_Defining_Identifier (Sloc (Formal_Spec), 324 Chars => Chars (Defining_Identifier (Formal_Spec)))); 325 Next (Formal_Spec); 326 end loop; 327 end; 328 end if; 329 330 Prev := Current_Entity_In_Scope (Defining_Entity (Spec)); 331 332 -- If there are previous overloadable entities with the same name, 333 -- check whether any of them is completed by the expression function. 334 335 if Present (Prev) and then Is_Overloadable (Prev) then 336 Def_Id := Analyze_Subprogram_Specification (Spec); 337 Prev := Find_Corresponding_Spec (N); 338 end if; 339 340 Ret := Make_Simple_Return_Statement (LocX, Expression (N)); 341 342 New_Body := 343 Make_Subprogram_Body (Loc, 344 Specification => New_Spec, 345 Declarations => Empty_List, 346 Handled_Statement_Sequence => 347 Make_Handled_Sequence_Of_Statements (LocX, 348 Statements => New_List (Ret))); 349 350 if Present (Prev) and then Ekind (Prev) = E_Generic_Function then 351 352 -- If the expression completes a generic subprogram, we must create a 353 -- separate node for the body, because at instantiation the original 354 -- node of the generic copy must be a generic subprogram body, and 355 -- cannot be a expression function. Otherwise we just rewrite the 356 -- expression with the non-generic body. 357 358 Insert_After (N, New_Body); 359 Rewrite (N, Make_Null_Statement (Loc)); 360 Set_Has_Completion (Prev, False); 361 Analyze (N); 362 Analyze (New_Body); 363 Set_Is_Inlined (Prev); 364 365 elsif Present (Prev) 366 and then Comes_From_Source (Prev) 367 then 368 Set_Has_Completion (Prev, False); 369 370 -- For navigation purposes, indicate that the function is a body 371 372 Generate_Reference (Prev, Defining_Entity (N), 'b', Force => True); 373 Rewrite (N, New_Body); 374 Analyze (N); 375 376 -- Prev is the previous entity with the same name, but it is can 377 -- be an unrelated spec that is not completed by the expression 378 -- function. In that case the relevant entity is the one in the body. 379 -- Not clear that the backend can inline it in this case ??? 380 381 if Has_Completion (Prev) then 382 Set_Is_Inlined (Prev); 383 384 -- The formals of the expression function are body formals, 385 -- and do not appear in the ali file, which will only contain 386 -- references to the formals of the original subprogram spec. 387 388 declare 389 F1 : Entity_Id; 390 F2 : Entity_Id; 391 392 begin 393 F1 := First_Formal (Def_Id); 394 F2 := First_Formal (Prev); 395 396 while Present (F1) loop 397 Set_Spec_Entity (F1, F2); 398 Next_Formal (F1); 399 Next_Formal (F2); 400 end loop; 401 end; 402 403 else 404 Set_Is_Inlined (Defining_Entity (New_Body)); 405 end if; 406 407 -- If this is not a completion, create both a declaration and a body, so 408 -- that the expression can be inlined whenever possible. 409 410 else 411 -- An expression function that is not a completion is not a 412 -- subprogram declaration, and thus cannot appear in a protected 413 -- definition. 414 415 if Nkind (Parent (N)) = N_Protected_Definition then 416 Error_Msg_N 417 ("an expression function is not a legal protected operation", N); 418 end if; 419 420 New_Decl := 421 Make_Subprogram_Declaration (Loc, Specification => Spec); 422 423 Rewrite (N, New_Decl); 424 Analyze (N); 425 Set_Is_Inlined (Defining_Entity (New_Decl)); 426 427 -- To prevent premature freeze action, insert the new body at the end 428 -- of the current declarations, or at the end of the package spec. 429 -- However, resolve usage names now, to prevent spurious visibility 430 -- on later entities. 431 432 declare 433 Decls : List_Id := List_Containing (N); 434 Par : constant Node_Id := Parent (Decls); 435 Id : constant Entity_Id := Defining_Entity (New_Decl); 436 437 begin 438 if Nkind (Par) = N_Package_Specification 439 and then Decls = Visible_Declarations (Par) 440 and then Present (Private_Declarations (Par)) 441 and then not Is_Empty_List (Private_Declarations (Par)) 442 then 443 Decls := Private_Declarations (Par); 444 end if; 445 446 Insert_After (Last (Decls), New_Body); 447 Push_Scope (Id); 448 Install_Formals (Id); 449 Preanalyze_Spec_Expression (Expression (Ret), Etype (Id)); 450 End_Scope; 451 end; 452 end if; 453 454 -- If the return expression is a static constant, we suppress warning 455 -- messages on unused formals, which in most cases will be noise. 456 457 Set_Is_Trivial_Subprogram (Defining_Entity (New_Body), 458 Is_OK_Static_Expression (Expr)); 459 end Analyze_Expression_Function; 460 461 ---------------------------------------- 462 -- Analyze_Extended_Return_Statement -- 463 ---------------------------------------- 464 465 procedure Analyze_Extended_Return_Statement (N : Node_Id) is 466 begin 467 Analyze_Return_Statement (N); 468 end Analyze_Extended_Return_Statement; 469 470 ---------------------------- 471 -- Analyze_Function_Call -- 472 ---------------------------- 473 474 procedure Analyze_Function_Call (N : Node_Id) is 475 P : constant Node_Id := Name (N); 476 Actuals : constant List_Id := Parameter_Associations (N); 477 Actual : Node_Id; 478 479 begin 480 Analyze (P); 481 482 -- A call of the form A.B (X) may be an Ada 2005 call, which is 483 -- rewritten as B (A, X). If the rewriting is successful, the call 484 -- has been analyzed and we just return. 485 486 if Nkind (P) = N_Selected_Component 487 and then Name (N) /= P 488 and then Is_Rewrite_Substitution (N) 489 and then Present (Etype (N)) 490 then 491 return; 492 end if; 493 494 -- If error analyzing name, then set Any_Type as result type and return 495 496 if Etype (P) = Any_Type then 497 Set_Etype (N, Any_Type); 498 return; 499 end if; 500 501 -- Otherwise analyze the parameters 502 503 if Present (Actuals) then 504 Actual := First (Actuals); 505 while Present (Actual) loop 506 Analyze (Actual); 507 Check_Parameterless_Call (Actual); 508 Next (Actual); 509 end loop; 510 end if; 511 512 Analyze_Call (N); 513 514 -- Mark function call if within assertion 515 516 if In_Assertion_Expr /= 0 then 517 Set_In_Assertion (N); 518 end if; 519 end Analyze_Function_Call; 520 521 ----------------------------- 522 -- Analyze_Function_Return -- 523 ----------------------------- 524 525 procedure Analyze_Function_Return (N : Node_Id) is 526 Loc : constant Source_Ptr := Sloc (N); 527 Stm_Entity : constant Entity_Id := Return_Statement_Entity (N); 528 Scope_Id : constant Entity_Id := Return_Applies_To (Stm_Entity); 529 530 R_Type : constant Entity_Id := Etype (Scope_Id); 531 -- Function result subtype 532 533 procedure Check_Limited_Return (Expr : Node_Id); 534 -- Check the appropriate (Ada 95 or Ada 2005) rules for returning 535 -- limited types. Used only for simple return statements. 536 -- Expr is the expression returned. 537 538 procedure Check_Return_Subtype_Indication (Obj_Decl : Node_Id); 539 -- Check that the return_subtype_indication properly matches the result 540 -- subtype of the function, as required by RM-6.5(5.1/2-5.3/2). 541 542 -------------------------- 543 -- Check_Limited_Return -- 544 -------------------------- 545 546 procedure Check_Limited_Return (Expr : Node_Id) is 547 begin 548 -- Ada 2005 (AI-318-02): Return-by-reference types have been 549 -- removed and replaced by anonymous access results. This is an 550 -- incompatibility with Ada 95. Not clear whether this should be 551 -- enforced yet or perhaps controllable with special switch. ??? 552 553 -- A limited interface that is not immutably limited is OK. 554 555 if Is_Limited_Interface (R_Type) 556 and then 557 not (Is_Task_Interface (R_Type) 558 or else Is_Protected_Interface (R_Type) 559 or else Is_Synchronized_Interface (R_Type)) 560 then 561 null; 562 563 elsif Is_Limited_Type (R_Type) 564 and then not Is_Interface (R_Type) 565 and then Comes_From_Source (N) 566 and then not In_Instance_Body 567 and then not OK_For_Limited_Init_In_05 (R_Type, Expr) 568 then 569 -- Error in Ada 2005 570 571 if Ada_Version >= Ada_2005 572 and then not Debug_Flag_Dot_L 573 and then not GNAT_Mode 574 then 575 Error_Msg_N 576 ("(Ada 2005) cannot copy object of a limited type " & 577 "(RM-2005 6.5(5.5/2))", Expr); 578 579 if Is_Immutably_Limited_Type (R_Type) then 580 Error_Msg_N 581 ("\return by reference not permitted in Ada 2005", Expr); 582 end if; 583 584 -- Warn in Ada 95 mode, to give folks a heads up about this 585 -- incompatibility. 586 587 -- In GNAT mode, this is just a warning, to allow it to be 588 -- evilly turned off. Otherwise it is a real error. 589 590 -- In a generic context, simplify the warning because it makes 591 -- no sense to discuss pass-by-reference or copy. 592 593 elsif Warn_On_Ada_2005_Compatibility or GNAT_Mode then 594 if Inside_A_Generic then 595 Error_Msg_N 596 ("return of limited object not permitted in Ada 2005 " 597 & "(RM-2005 6.5(5.5/2))?y?", Expr); 598 599 elsif Is_Immutably_Limited_Type (R_Type) then 600 Error_Msg_N 601 ("return by reference not permitted in Ada 2005 " 602 & "(RM-2005 6.5(5.5/2))?y?", Expr); 603 else 604 Error_Msg_N 605 ("cannot copy object of a limited type in Ada 2005 " 606 & "(RM-2005 6.5(5.5/2))?y?", Expr); 607 end if; 608 609 -- Ada 95 mode, compatibility warnings disabled 610 611 else 612 return; -- skip continuation messages below 613 end if; 614 615 if not Inside_A_Generic then 616 Error_Msg_N 617 ("\consider switching to return of access type", Expr); 618 Explain_Limited_Type (R_Type, Expr); 619 end if; 620 end if; 621 end Check_Limited_Return; 622 623 ------------------------------------- 624 -- Check_Return_Subtype_Indication -- 625 ------------------------------------- 626 627 procedure Check_Return_Subtype_Indication (Obj_Decl : Node_Id) is 628 Return_Obj : constant Node_Id := Defining_Identifier (Obj_Decl); 629 630 R_Stm_Type : constant Entity_Id := Etype (Return_Obj); 631 -- Subtype given in the extended return statement (must match R_Type) 632 633 Subtype_Ind : constant Node_Id := 634 Object_Definition (Original_Node (Obj_Decl)); 635 636 R_Type_Is_Anon_Access : 637 constant Boolean := 638 Ekind (R_Type) = E_Anonymous_Access_Subprogram_Type 639 or else 640 Ekind (R_Type) = E_Anonymous_Access_Protected_Subprogram_Type 641 or else 642 Ekind (R_Type) = E_Anonymous_Access_Type; 643 -- True if return type of the function is an anonymous access type 644 -- Can't we make Is_Anonymous_Access_Type in einfo ??? 645 646 R_Stm_Type_Is_Anon_Access : 647 constant Boolean := 648 Ekind (R_Stm_Type) = E_Anonymous_Access_Subprogram_Type 649 or else 650 Ekind (R_Stm_Type) = E_Anonymous_Access_Protected_Subprogram_Type 651 or else 652 Ekind (R_Stm_Type) = E_Anonymous_Access_Type; 653 -- True if type of the return object is an anonymous access type 654 655 begin 656 -- First, avoid cascaded errors 657 658 if Error_Posted (Obj_Decl) or else Error_Posted (Subtype_Ind) then 659 return; 660 end if; 661 662 -- "return access T" case; check that the return statement also has 663 -- "access T", and that the subtypes statically match: 664 -- if this is an access to subprogram the signatures must match. 665 666 if R_Type_Is_Anon_Access then 667 if R_Stm_Type_Is_Anon_Access then 668 if 669 Ekind (Designated_Type (R_Stm_Type)) /= E_Subprogram_Type 670 then 671 if Base_Type (Designated_Type (R_Stm_Type)) /= 672 Base_Type (Designated_Type (R_Type)) 673 or else not Subtypes_Statically_Match (R_Stm_Type, R_Type) 674 then 675 Error_Msg_N 676 ("subtype must statically match function result subtype", 677 Subtype_Mark (Subtype_Ind)); 678 end if; 679 680 else 681 -- For two anonymous access to subprogram types, the 682 -- types themselves must be type conformant. 683 684 if not Conforming_Types 685 (R_Stm_Type, R_Type, Fully_Conformant) 686 then 687 Error_Msg_N 688 ("subtype must statically match function result subtype", 689 Subtype_Ind); 690 end if; 691 end if; 692 693 else 694 Error_Msg_N ("must use anonymous access type", Subtype_Ind); 695 end if; 696 697 -- If the return object is of an anonymous access type, then report 698 -- an error if the function's result type is not also anonymous. 699 700 elsif R_Stm_Type_Is_Anon_Access 701 and then not R_Type_Is_Anon_Access 702 then 703 Error_Msg_N ("anonymous access not allowed for function with " & 704 "named access result", Subtype_Ind); 705 706 -- Subtype indication case: check that the return object's type is 707 -- covered by the result type, and that the subtypes statically match 708 -- when the result subtype is constrained. Also handle record types 709 -- with unknown discriminants for which we have built the underlying 710 -- record view. Coverage is needed to allow specific-type return 711 -- objects when the result type is class-wide (see AI05-32). 712 713 elsif Covers (Base_Type (R_Type), Base_Type (R_Stm_Type)) 714 or else (Is_Underlying_Record_View (Base_Type (R_Stm_Type)) 715 and then 716 Covers 717 (Base_Type (R_Type), 718 Underlying_Record_View (Base_Type (R_Stm_Type)))) 719 then 720 -- A null exclusion may be present on the return type, on the 721 -- function specification, on the object declaration or on the 722 -- subtype itself. 723 724 if Is_Access_Type (R_Type) 725 and then 726 (Can_Never_Be_Null (R_Type) 727 or else Null_Exclusion_Present (Parent (Scope_Id))) /= 728 Can_Never_Be_Null (R_Stm_Type) 729 then 730 Error_Msg_N 731 ("subtype must statically match function result subtype", 732 Subtype_Ind); 733 end if; 734 735 -- AI05-103: for elementary types, subtypes must statically match 736 737 if Is_Constrained (R_Type) 738 or else Is_Access_Type (R_Type) 739 then 740 if not Subtypes_Statically_Match (R_Stm_Type, R_Type) then 741 Error_Msg_N 742 ("subtype must statically match function result subtype", 743 Subtype_Ind); 744 end if; 745 end if; 746 747 elsif Etype (Base_Type (R_Type)) = R_Stm_Type 748 and then Is_Null_Extension (Base_Type (R_Type)) 749 then 750 null; 751 752 else 753 Error_Msg_N 754 ("wrong type for return_subtype_indication", Subtype_Ind); 755 end if; 756 end Check_Return_Subtype_Indication; 757 758 --------------------- 759 -- Local Variables -- 760 --------------------- 761 762 Expr : Node_Id; 763 764 -- Start of processing for Analyze_Function_Return 765 766 begin 767 Set_Return_Present (Scope_Id); 768 769 if Nkind (N) = N_Simple_Return_Statement then 770 Expr := Expression (N); 771 772 -- Guard against a malformed expression. The parser may have tried to 773 -- recover but the node is not analyzable. 774 775 if Nkind (Expr) = N_Error then 776 Set_Etype (Expr, Any_Type); 777 Expander_Mode_Save_And_Set (False); 778 return; 779 780 else 781 -- The resolution of a controlled [extension] aggregate associated 782 -- with a return statement creates a temporary which needs to be 783 -- finalized on function exit. Wrap the return statement inside a 784 -- block so that the finalization machinery can detect this case. 785 -- This early expansion is done only when the return statement is 786 -- not part of a handled sequence of statements. 787 788 if Nkind_In (Expr, N_Aggregate, 789 N_Extension_Aggregate) 790 and then Needs_Finalization (R_Type) 791 and then Nkind (Parent (N)) /= N_Handled_Sequence_Of_Statements 792 then 793 Rewrite (N, 794 Make_Block_Statement (Loc, 795 Handled_Statement_Sequence => 796 Make_Handled_Sequence_Of_Statements (Loc, 797 Statements => New_List (Relocate_Node (N))))); 798 799 Analyze (N); 800 return; 801 end if; 802 803 Analyze_And_Resolve (Expr, R_Type); 804 Check_Limited_Return (Expr); 805 end if; 806 807 -- RETURN only allowed in SPARK as the last statement in function 808 809 if Nkind (Parent (N)) /= N_Handled_Sequence_Of_Statements 810 and then 811 (Nkind (Parent (Parent (N))) /= N_Subprogram_Body 812 or else Present (Next (N))) 813 then 814 Check_SPARK_Restriction 815 ("RETURN should be the last statement in function", N); 816 end if; 817 818 else 819 Check_SPARK_Restriction ("extended RETURN is not allowed", N); 820 821 -- Analyze parts specific to extended_return_statement: 822 823 declare 824 Obj_Decl : constant Node_Id := 825 Last (Return_Object_Declarations (N)); 826 Has_Aliased : constant Boolean := Aliased_Present (Obj_Decl); 827 HSS : constant Node_Id := Handled_Statement_Sequence (N); 828 829 begin 830 Expr := Expression (Obj_Decl); 831 832 -- Note: The check for OK_For_Limited_Init will happen in 833 -- Analyze_Object_Declaration; we treat it as a normal 834 -- object declaration. 835 836 Set_Is_Return_Object (Defining_Identifier (Obj_Decl)); 837 Analyze (Obj_Decl); 838 839 Check_Return_Subtype_Indication (Obj_Decl); 840 841 if Present (HSS) then 842 Analyze (HSS); 843 844 if Present (Exception_Handlers (HSS)) then 845 846 -- ???Has_Nested_Block_With_Handler needs to be set. 847 -- Probably by creating an actual N_Block_Statement. 848 -- Probably in Expand. 849 850 null; 851 end if; 852 end if; 853 854 -- Mark the return object as referenced, since the return is an 855 -- implicit reference of the object. 856 857 Set_Referenced (Defining_Identifier (Obj_Decl)); 858 859 Check_References (Stm_Entity); 860 861 -- Check RM 6.5 (5.9/3) 862 863 if Has_Aliased then 864 if Ada_Version < Ada_2012 then 865 866 -- Shouldn't this test Warn_On_Ada_2012_Compatibility ??? 867 -- Can it really happen (extended return???) 868 869 Error_Msg_N 870 ("aliased only allowed for limited" 871 & " return objects in Ada 2012?", N); 872 873 elsif not Is_Immutably_Limited_Type (R_Type) then 874 Error_Msg_N ("aliased only allowed for limited" 875 & " return objects", N); 876 end if; 877 end if; 878 end; 879 end if; 880 881 -- Case of Expr present 882 883 if Present (Expr) 884 885 -- Defend against previous errors 886 887 and then Nkind (Expr) /= N_Empty 888 and then Present (Etype (Expr)) 889 then 890 -- Apply constraint check. Note that this is done before the implicit 891 -- conversion of the expression done for anonymous access types to 892 -- ensure correct generation of the null-excluding check associated 893 -- with null-excluding expressions found in return statements. 894 895 Apply_Constraint_Check (Expr, R_Type); 896 897 -- Ada 2005 (AI-318-02): When the result type is an anonymous access 898 -- type, apply an implicit conversion of the expression to that type 899 -- to force appropriate static and run-time accessibility checks. 900 901 if Ada_Version >= Ada_2005 902 and then Ekind (R_Type) = E_Anonymous_Access_Type 903 then 904 Rewrite (Expr, Convert_To (R_Type, Relocate_Node (Expr))); 905 Analyze_And_Resolve (Expr, R_Type); 906 907 -- If this is a local anonymous access to subprogram, the 908 -- accessibility check can be applied statically. The return is 909 -- illegal if the access type of the return expression is declared 910 -- inside of the subprogram (except if it is the subtype indication 911 -- of an extended return statement). 912 913 elsif Ekind (R_Type) = E_Anonymous_Access_Subprogram_Type then 914 if not Comes_From_Source (Current_Scope) 915 or else Ekind (Current_Scope) = E_Return_Statement 916 then 917 null; 918 919 elsif 920 Scope_Depth (Scope (Etype (Expr))) >= Scope_Depth (Scope_Id) 921 then 922 Error_Msg_N ("cannot return local access to subprogram", N); 923 end if; 924 end if; 925 926 -- If the result type is class-wide, then check that the return 927 -- expression's type is not declared at a deeper level than the 928 -- function (RM05-6.5(5.6/2)). 929 930 if Ada_Version >= Ada_2005 931 and then Is_Class_Wide_Type (R_Type) 932 then 933 if Type_Access_Level (Etype (Expr)) > 934 Subprogram_Access_Level (Scope_Id) 935 then 936 Error_Msg_N 937 ("level of return expression type is deeper than " & 938 "class-wide function!", Expr); 939 end if; 940 end if; 941 942 -- Check incorrect use of dynamically tagged expression 943 944 if Is_Tagged_Type (R_Type) then 945 Check_Dynamically_Tagged_Expression 946 (Expr => Expr, 947 Typ => R_Type, 948 Related_Nod => N); 949 end if; 950 951 -- ??? A real run-time accessibility check is needed in cases 952 -- involving dereferences of access parameters. For now we just 953 -- check the static cases. 954 955 if (Ada_Version < Ada_2005 or else Debug_Flag_Dot_L) 956 and then Is_Immutably_Limited_Type (Etype (Scope_Id)) 957 and then Object_Access_Level (Expr) > 958 Subprogram_Access_Level (Scope_Id) 959 then 960 -- Suppress the message in a generic, where the rewriting 961 -- is irrelevant. 962 963 if Inside_A_Generic then 964 null; 965 966 else 967 Rewrite (N, 968 Make_Raise_Program_Error (Loc, 969 Reason => PE_Accessibility_Check_Failed)); 970 Analyze (N); 971 972 Error_Msg_N 973 ("cannot return a local value by reference??", N); 974 Error_Msg_NE 975 ("\& will be raised at run time??", 976 N, Standard_Program_Error); 977 end if; 978 end if; 979 980 if Known_Null (Expr) 981 and then Nkind (Parent (Scope_Id)) = N_Function_Specification 982 and then Null_Exclusion_Present (Parent (Scope_Id)) 983 then 984 Apply_Compile_Time_Constraint_Error 985 (N => Expr, 986 Msg => "(Ada 2005) null not allowed for " 987 & "null-excluding return??", 988 Reason => CE_Null_Not_Allowed); 989 end if; 990 end if; 991 end Analyze_Function_Return; 992 993 ------------------------------------- 994 -- Analyze_Generic_Subprogram_Body -- 995 ------------------------------------- 996 997 procedure Analyze_Generic_Subprogram_Body 998 (N : Node_Id; 999 Gen_Id : Entity_Id) 1000 is 1001 Gen_Decl : constant Node_Id := Unit_Declaration_Node (Gen_Id); 1002 Kind : constant Entity_Kind := Ekind (Gen_Id); 1003 Body_Id : Entity_Id; 1004 New_N : Node_Id; 1005 Spec : Node_Id; 1006 1007 begin 1008 -- Copy body and disable expansion while analyzing the generic For a 1009 -- stub, do not copy the stub (which would load the proper body), this 1010 -- will be done when the proper body is analyzed. 1011 1012 if Nkind (N) /= N_Subprogram_Body_Stub then 1013 New_N := Copy_Generic_Node (N, Empty, Instantiating => False); 1014 Rewrite (N, New_N); 1015 Start_Generic; 1016 end if; 1017 1018 Spec := Specification (N); 1019 1020 -- Within the body of the generic, the subprogram is callable, and 1021 -- behaves like the corresponding non-generic unit. 1022 1023 Body_Id := Defining_Entity (Spec); 1024 1025 if Kind = E_Generic_Procedure 1026 and then Nkind (Spec) /= N_Procedure_Specification 1027 then 1028 Error_Msg_N ("invalid body for generic procedure ", Body_Id); 1029 return; 1030 1031 elsif Kind = E_Generic_Function 1032 and then Nkind (Spec) /= N_Function_Specification 1033 then 1034 Error_Msg_N ("invalid body for generic function ", Body_Id); 1035 return; 1036 end if; 1037 1038 Set_Corresponding_Body (Gen_Decl, Body_Id); 1039 1040 if Has_Completion (Gen_Id) 1041 and then Nkind (Parent (N)) /= N_Subunit 1042 then 1043 Error_Msg_N ("duplicate generic body", N); 1044 return; 1045 else 1046 Set_Has_Completion (Gen_Id); 1047 end if; 1048 1049 if Nkind (N) = N_Subprogram_Body_Stub then 1050 Set_Ekind (Defining_Entity (Specification (N)), Kind); 1051 else 1052 Set_Corresponding_Spec (N, Gen_Id); 1053 end if; 1054 1055 if Nkind (Parent (N)) = N_Compilation_Unit then 1056 Set_Cunit_Entity (Current_Sem_Unit, Defining_Entity (N)); 1057 end if; 1058 1059 -- Make generic parameters immediately visible in the body. They are 1060 -- needed to process the formals declarations. Then make the formals 1061 -- visible in a separate step. 1062 1063 Push_Scope (Gen_Id); 1064 1065 declare 1066 E : Entity_Id; 1067 First_Ent : Entity_Id; 1068 1069 begin 1070 First_Ent := First_Entity (Gen_Id); 1071 1072 E := First_Ent; 1073 while Present (E) and then not Is_Formal (E) loop 1074 Install_Entity (E); 1075 Next_Entity (E); 1076 end loop; 1077 1078 Set_Use (Generic_Formal_Declarations (Gen_Decl)); 1079 1080 -- Now generic formals are visible, and the specification can be 1081 -- analyzed, for subsequent conformance check. 1082 1083 Body_Id := Analyze_Subprogram_Specification (Spec); 1084 1085 -- Make formal parameters visible 1086 1087 if Present (E) then 1088 1089 -- E is the first formal parameter, we loop through the formals 1090 -- installing them so that they will be visible. 1091 1092 Set_First_Entity (Gen_Id, E); 1093 while Present (E) loop 1094 Install_Entity (E); 1095 Next_Formal (E); 1096 end loop; 1097 end if; 1098 1099 -- Visible generic entity is callable within its own body 1100 1101 Set_Ekind (Gen_Id, Ekind (Body_Id)); 1102 Set_Ekind (Body_Id, E_Subprogram_Body); 1103 Set_Convention (Body_Id, Convention (Gen_Id)); 1104 Set_Is_Obsolescent (Body_Id, Is_Obsolescent (Gen_Id)); 1105 Set_Scope (Body_Id, Scope (Gen_Id)); 1106 Check_Fully_Conformant (Body_Id, Gen_Id, Body_Id); 1107 1108 if Nkind (N) = N_Subprogram_Body_Stub then 1109 1110 -- No body to analyze, so restore state of generic unit 1111 1112 Set_Ekind (Gen_Id, Kind); 1113 Set_Ekind (Body_Id, Kind); 1114 1115 if Present (First_Ent) then 1116 Set_First_Entity (Gen_Id, First_Ent); 1117 end if; 1118 1119 End_Scope; 1120 return; 1121 end if; 1122 1123 -- If this is a compilation unit, it must be made visible explicitly, 1124 -- because the compilation of the declaration, unlike other library 1125 -- unit declarations, does not. If it is not a unit, the following 1126 -- is redundant but harmless. 1127 1128 Set_Is_Immediately_Visible (Gen_Id); 1129 Reference_Body_Formals (Gen_Id, Body_Id); 1130 1131 if Is_Child_Unit (Gen_Id) then 1132 Generate_Reference (Gen_Id, Scope (Gen_Id), 'k', False); 1133 end if; 1134 1135 Set_Actual_Subtypes (N, Current_Scope); 1136 1137 -- Deal with preconditions and postconditions. In formal verification 1138 -- mode, we keep pre- and postconditions attached to entities rather 1139 -- than inserted in the code, in order to facilitate a distinct 1140 -- treatment for them. 1141 1142 if not Alfa_Mode then 1143 Process_PPCs (N, Gen_Id, Body_Id); 1144 end if; 1145 1146 -- If the generic unit carries pre- or post-conditions, copy them 1147 -- to the original generic tree, so that they are properly added 1148 -- to any instantiation. 1149 1150 declare 1151 Orig : constant Node_Id := Original_Node (N); 1152 Cond : Node_Id; 1153 1154 begin 1155 Cond := First (Declarations (N)); 1156 while Present (Cond) loop 1157 if Nkind (Cond) = N_Pragma 1158 and then Pragma_Name (Cond) = Name_Check 1159 then 1160 Prepend (New_Copy_Tree (Cond), Declarations (Orig)); 1161 1162 elsif Nkind (Cond) = N_Pragma 1163 and then Pragma_Name (Cond) = Name_Postcondition 1164 then 1165 Set_Ekind (Defining_Entity (Orig), Ekind (Gen_Id)); 1166 Prepend (New_Copy_Tree (Cond), Declarations (Orig)); 1167 else 1168 exit; 1169 end if; 1170 1171 Next (Cond); 1172 end loop; 1173 end; 1174 1175 Analyze_Declarations (Declarations (N)); 1176 Check_Completion; 1177 Analyze (Handled_Statement_Sequence (N)); 1178 1179 Save_Global_References (Original_Node (N)); 1180 1181 -- Prior to exiting the scope, include generic formals again (if any 1182 -- are present) in the set of local entities. 1183 1184 if Present (First_Ent) then 1185 Set_First_Entity (Gen_Id, First_Ent); 1186 end if; 1187 1188 Check_References (Gen_Id); 1189 end; 1190 1191 Process_End_Label (Handled_Statement_Sequence (N), 't', Current_Scope); 1192 End_Scope; 1193 Check_Subprogram_Order (N); 1194 1195 -- Outside of its body, unit is generic again 1196 1197 Set_Ekind (Gen_Id, Kind); 1198 Generate_Reference (Gen_Id, Body_Id, 'b', Set_Ref => False); 1199 1200 if Style_Check then 1201 Style.Check_Identifier (Body_Id, Gen_Id); 1202 end if; 1203 1204 End_Generic; 1205 end Analyze_Generic_Subprogram_Body; 1206 1207 ----------------------------- 1208 -- Analyze_Operator_Symbol -- 1209 ----------------------------- 1210 1211 -- An operator symbol such as "+" or "and" may appear in context where the 1212 -- literal denotes an entity name, such as "+"(x, y) or in context when it 1213 -- is just a string, as in (conjunction = "or"). In these cases the parser 1214 -- generates this node, and the semantics does the disambiguation. Other 1215 -- such case are actuals in an instantiation, the generic unit in an 1216 -- instantiation, and pragma arguments. 1217 1218 procedure Analyze_Operator_Symbol (N : Node_Id) is 1219 Par : constant Node_Id := Parent (N); 1220 1221 begin 1222 if (Nkind (Par) = N_Function_Call 1223 and then N = Name (Par)) 1224 or else Nkind (Par) = N_Function_Instantiation 1225 or else (Nkind (Par) = N_Indexed_Component 1226 and then N = Prefix (Par)) 1227 or else (Nkind (Par) = N_Pragma_Argument_Association 1228 and then not Is_Pragma_String_Literal (Par)) 1229 or else Nkind (Par) = N_Subprogram_Renaming_Declaration 1230 or else (Nkind (Par) = N_Attribute_Reference 1231 and then Attribute_Name (Par) /= Name_Value) 1232 then 1233 Find_Direct_Name (N); 1234 1235 else 1236 Change_Operator_Symbol_To_String_Literal (N); 1237 Analyze (N); 1238 end if; 1239 end Analyze_Operator_Symbol; 1240 1241 ----------------------------------- 1242 -- Analyze_Parameter_Association -- 1243 ----------------------------------- 1244 1245 procedure Analyze_Parameter_Association (N : Node_Id) is 1246 begin 1247 Analyze (Explicit_Actual_Parameter (N)); 1248 end Analyze_Parameter_Association; 1249 1250 ---------------------------- 1251 -- Analyze_Procedure_Call -- 1252 ---------------------------- 1253 1254 procedure Analyze_Procedure_Call (N : Node_Id) is 1255 Loc : constant Source_Ptr := Sloc (N); 1256 P : constant Node_Id := Name (N); 1257 Actuals : constant List_Id := Parameter_Associations (N); 1258 Actual : Node_Id; 1259 New_N : Node_Id; 1260 1261 procedure Analyze_Call_And_Resolve; 1262 -- Do Analyze and Resolve calls for procedure call 1263 -- At end, check illegal order dependence. 1264 1265 ------------------------------ 1266 -- Analyze_Call_And_Resolve -- 1267 ------------------------------ 1268 1269 procedure Analyze_Call_And_Resolve is 1270 begin 1271 if Nkind (N) = N_Procedure_Call_Statement then 1272 Analyze_Call (N); 1273 Resolve (N, Standard_Void_Type); 1274 else 1275 Analyze (N); 1276 end if; 1277 end Analyze_Call_And_Resolve; 1278 1279 -- Start of processing for Analyze_Procedure_Call 1280 1281 begin 1282 -- The syntactic construct: PREFIX ACTUAL_PARAMETER_PART can denote 1283 -- a procedure call or an entry call. The prefix may denote an access 1284 -- to subprogram type, in which case an implicit dereference applies. 1285 -- If the prefix is an indexed component (without implicit dereference) 1286 -- then the construct denotes a call to a member of an entire family. 1287 -- If the prefix is a simple name, it may still denote a call to a 1288 -- parameterless member of an entry family. Resolution of these various 1289 -- interpretations is delicate. 1290 1291 Analyze (P); 1292 1293 -- If this is a call of the form Obj.Op, the call may have been 1294 -- analyzed and possibly rewritten into a block, in which case 1295 -- we are done. 1296 1297 if Analyzed (N) then 1298 return; 1299 end if; 1300 1301 -- If there is an error analyzing the name (which may have been 1302 -- rewritten if the original call was in prefix notation) then error 1303 -- has been emitted already, mark node and return. 1304 1305 if Error_Posted (N) or else Etype (Name (N)) = Any_Type then 1306 Set_Etype (N, Any_Type); 1307 return; 1308 end if; 1309 1310 -- Otherwise analyze the parameters 1311 1312 if Present (Actuals) then 1313 Actual := First (Actuals); 1314 1315 while Present (Actual) loop 1316 Analyze (Actual); 1317 Check_Parameterless_Call (Actual); 1318 Next (Actual); 1319 end loop; 1320 end if; 1321 1322 -- Special processing for Elab_Spec, Elab_Body and Elab_Subp_Body calls 1323 1324 if Nkind (P) = N_Attribute_Reference 1325 and then (Attribute_Name (P) = Name_Elab_Spec or else 1326 Attribute_Name (P) = Name_Elab_Body or else 1327 Attribute_Name (P) = Name_Elab_Subp_Body) 1328 then 1329 if Present (Actuals) then 1330 Error_Msg_N 1331 ("no parameters allowed for this call", First (Actuals)); 1332 return; 1333 end if; 1334 1335 Set_Etype (N, Standard_Void_Type); 1336 Set_Analyzed (N); 1337 1338 elsif Is_Entity_Name (P) 1339 and then Is_Record_Type (Etype (Entity (P))) 1340 and then Remote_AST_I_Dereference (P) 1341 then 1342 return; 1343 1344 elsif Is_Entity_Name (P) 1345 and then Ekind (Entity (P)) /= E_Entry_Family 1346 then 1347 if Is_Access_Type (Etype (P)) 1348 and then Ekind (Designated_Type (Etype (P))) = E_Subprogram_Type 1349 and then No (Actuals) 1350 and then Comes_From_Source (N) 1351 then 1352 Error_Msg_N ("missing explicit dereference in call", N); 1353 end if; 1354 1355 Analyze_Call_And_Resolve; 1356 1357 -- If the prefix is the simple name of an entry family, this is 1358 -- a parameterless call from within the task body itself. 1359 1360 elsif Is_Entity_Name (P) 1361 and then Nkind (P) = N_Identifier 1362 and then Ekind (Entity (P)) = E_Entry_Family 1363 and then Present (Actuals) 1364 and then No (Next (First (Actuals))) 1365 then 1366 -- Can be call to parameterless entry family. What appears to be the 1367 -- sole argument is in fact the entry index. Rewrite prefix of node 1368 -- accordingly. Source representation is unchanged by this 1369 -- transformation. 1370 1371 New_N := 1372 Make_Indexed_Component (Loc, 1373 Prefix => 1374 Make_Selected_Component (Loc, 1375 Prefix => New_Occurrence_Of (Scope (Entity (P)), Loc), 1376 Selector_Name => New_Occurrence_Of (Entity (P), Loc)), 1377 Expressions => Actuals); 1378 Set_Name (N, New_N); 1379 Set_Etype (New_N, Standard_Void_Type); 1380 Set_Parameter_Associations (N, No_List); 1381 Analyze_Call_And_Resolve; 1382 1383 elsif Nkind (P) = N_Explicit_Dereference then 1384 if Ekind (Etype (P)) = E_Subprogram_Type then 1385 Analyze_Call_And_Resolve; 1386 else 1387 Error_Msg_N ("expect access to procedure in call", P); 1388 end if; 1389 1390 -- The name can be a selected component or an indexed component that 1391 -- yields an access to subprogram. Such a prefix is legal if the call 1392 -- has parameter associations. 1393 1394 elsif Is_Access_Type (Etype (P)) 1395 and then Ekind (Designated_Type (Etype (P))) = E_Subprogram_Type 1396 then 1397 if Present (Actuals) then 1398 Analyze_Call_And_Resolve; 1399 else 1400 Error_Msg_N ("missing explicit dereference in call ", N); 1401 end if; 1402 1403 -- If not an access to subprogram, then the prefix must resolve to the 1404 -- name of an entry, entry family, or protected operation. 1405 1406 -- For the case of a simple entry call, P is a selected component where 1407 -- the prefix is the task and the selector name is the entry. A call to 1408 -- a protected procedure will have the same syntax. If the protected 1409 -- object contains overloaded operations, the entity may appear as a 1410 -- function, the context will select the operation whose type is Void. 1411 1412 elsif Nkind (P) = N_Selected_Component 1413 and then (Ekind (Entity (Selector_Name (P))) = E_Entry 1414 or else 1415 Ekind (Entity (Selector_Name (P))) = E_Procedure 1416 or else 1417 Ekind (Entity (Selector_Name (P))) = E_Function) 1418 then 1419 Analyze_Call_And_Resolve; 1420 1421 elsif Nkind (P) = N_Selected_Component 1422 and then Ekind (Entity (Selector_Name (P))) = E_Entry_Family 1423 and then Present (Actuals) 1424 and then No (Next (First (Actuals))) 1425 then 1426 -- Can be call to parameterless entry family. What appears to be the 1427 -- sole argument is in fact the entry index. Rewrite prefix of node 1428 -- accordingly. Source representation is unchanged by this 1429 -- transformation. 1430 1431 New_N := 1432 Make_Indexed_Component (Loc, 1433 Prefix => New_Copy (P), 1434 Expressions => Actuals); 1435 Set_Name (N, New_N); 1436 Set_Etype (New_N, Standard_Void_Type); 1437 Set_Parameter_Associations (N, No_List); 1438 Analyze_Call_And_Resolve; 1439 1440 -- For the case of a reference to an element of an entry family, P is 1441 -- an indexed component whose prefix is a selected component (task and 1442 -- entry family), and whose index is the entry family index. 1443 1444 elsif Nkind (P) = N_Indexed_Component 1445 and then Nkind (Prefix (P)) = N_Selected_Component 1446 and then Ekind (Entity (Selector_Name (Prefix (P)))) = E_Entry_Family 1447 then 1448 Analyze_Call_And_Resolve; 1449 1450 -- If the prefix is the name of an entry family, it is a call from 1451 -- within the task body itself. 1452 1453 elsif Nkind (P) = N_Indexed_Component 1454 and then Nkind (Prefix (P)) = N_Identifier 1455 and then Ekind (Entity (Prefix (P))) = E_Entry_Family 1456 then 1457 New_N := 1458 Make_Selected_Component (Loc, 1459 Prefix => New_Occurrence_Of (Scope (Entity (Prefix (P))), Loc), 1460 Selector_Name => New_Occurrence_Of (Entity (Prefix (P)), Loc)); 1461 Rewrite (Prefix (P), New_N); 1462 Analyze (P); 1463 Analyze_Call_And_Resolve; 1464 1465 -- In Ada 2012. a qualified expression is a name, but it cannot be a 1466 -- procedure name, so the construct can only be a qualified expression. 1467 1468 elsif Nkind (P) = N_Qualified_Expression 1469 and then Ada_Version >= Ada_2012 1470 then 1471 Rewrite (N, Make_Code_Statement (Loc, Expression => P)); 1472 Analyze (N); 1473 1474 -- Anything else is an error 1475 1476 else 1477 Error_Msg_N ("invalid procedure or entry call", N); 1478 end if; 1479 end Analyze_Procedure_Call; 1480 1481 ------------------------------ 1482 -- Analyze_Return_Statement -- 1483 ------------------------------ 1484 1485 procedure Analyze_Return_Statement (N : Node_Id) is 1486 1487 pragma Assert (Nkind_In (N, N_Simple_Return_Statement, 1488 N_Extended_Return_Statement)); 1489 1490 Returns_Object : constant Boolean := 1491 Nkind (N) = N_Extended_Return_Statement 1492 or else 1493 (Nkind (N) = N_Simple_Return_Statement 1494 and then Present (Expression (N))); 1495 -- True if we're returning something; that is, "return <expression>;" 1496 -- or "return Result : T [:= ...]". False for "return;". Used for error 1497 -- checking: If Returns_Object is True, N should apply to a function 1498 -- body; otherwise N should apply to a procedure body, entry body, 1499 -- accept statement, or extended return statement. 1500 1501 function Find_What_It_Applies_To return Entity_Id; 1502 -- Find the entity representing the innermost enclosing body, accept 1503 -- statement, or extended return statement. If the result is a callable 1504 -- construct or extended return statement, then this will be the value 1505 -- of the Return_Applies_To attribute. Otherwise, the program is 1506 -- illegal. See RM-6.5(4/2). 1507 1508 ----------------------------- 1509 -- Find_What_It_Applies_To -- 1510 ----------------------------- 1511 1512 function Find_What_It_Applies_To return Entity_Id is 1513 Result : Entity_Id := Empty; 1514 1515 begin 1516 -- Loop outward through the Scope_Stack, skipping blocks, loops, 1517 -- and postconditions. 1518 1519 for J in reverse 0 .. Scope_Stack.Last loop 1520 Result := Scope_Stack.Table (J).Entity; 1521 exit when not Ekind_In (Result, E_Block, E_Loop) 1522 and then Chars (Result) /= Name_uPostconditions; 1523 end loop; 1524 1525 pragma Assert (Present (Result)); 1526 return Result; 1527 end Find_What_It_Applies_To; 1528 1529 -- Local declarations 1530 1531 Scope_Id : constant Entity_Id := Find_What_It_Applies_To; 1532 Kind : constant Entity_Kind := Ekind (Scope_Id); 1533 Loc : constant Source_Ptr := Sloc (N); 1534 Stm_Entity : constant Entity_Id := 1535 New_Internal_Entity 1536 (E_Return_Statement, Current_Scope, Loc, 'R'); 1537 1538 -- Start of processing for Analyze_Return_Statement 1539 1540 begin 1541 Set_Return_Statement_Entity (N, Stm_Entity); 1542 1543 Set_Etype (Stm_Entity, Standard_Void_Type); 1544 Set_Return_Applies_To (Stm_Entity, Scope_Id); 1545 1546 -- Place Return entity on scope stack, to simplify enforcement of 6.5 1547 -- (4/2): an inner return statement will apply to this extended return. 1548 1549 if Nkind (N) = N_Extended_Return_Statement then 1550 Push_Scope (Stm_Entity); 1551 end if; 1552 1553 -- Check that pragma No_Return is obeyed. Don't complain about the 1554 -- implicitly-generated return that is placed at the end. 1555 1556 if No_Return (Scope_Id) and then Comes_From_Source (N) then 1557 Error_Msg_N ("RETURN statement not allowed (No_Return)", N); 1558 end if; 1559 1560 -- Warn on any unassigned OUT parameters if in procedure 1561 1562 if Ekind (Scope_Id) = E_Procedure then 1563 Warn_On_Unassigned_Out_Parameter (N, Scope_Id); 1564 end if; 1565 1566 -- Check that functions return objects, and other things do not 1567 1568 if Kind = E_Function or else Kind = E_Generic_Function then 1569 if not Returns_Object then 1570 Error_Msg_N ("missing expression in return from function", N); 1571 end if; 1572 1573 elsif Kind = E_Procedure or else Kind = E_Generic_Procedure then 1574 if Returns_Object then 1575 Error_Msg_N ("procedure cannot return value (use function)", N); 1576 end if; 1577 1578 elsif Kind = E_Entry or else Kind = E_Entry_Family then 1579 if Returns_Object then 1580 if Is_Protected_Type (Scope (Scope_Id)) then 1581 Error_Msg_N ("entry body cannot return value", N); 1582 else 1583 Error_Msg_N ("accept statement cannot return value", N); 1584 end if; 1585 end if; 1586 1587 elsif Kind = E_Return_Statement then 1588 1589 -- We are nested within another return statement, which must be an 1590 -- extended_return_statement. 1591 1592 if Returns_Object then 1593 if Nkind (N) = N_Extended_Return_Statement then 1594 Error_Msg_N 1595 ("extended return statement cannot be nested (use `RETURN;`)", 1596 N); 1597 1598 -- Case of a simple return statement with a value inside extended 1599 -- return statement. 1600 1601 else 1602 Error_Msg_N 1603 ("return nested in extended return statement cannot return " & 1604 "value (use `RETURN;`)", N); 1605 end if; 1606 end if; 1607 1608 else 1609 Error_Msg_N ("illegal context for return statement", N); 1610 end if; 1611 1612 if Ekind_In (Kind, E_Function, E_Generic_Function) then 1613 Analyze_Function_Return (N); 1614 1615 elsif Ekind_In (Kind, E_Procedure, E_Generic_Procedure) then 1616 Set_Return_Present (Scope_Id); 1617 end if; 1618 1619 if Nkind (N) = N_Extended_Return_Statement then 1620 End_Scope; 1621 end if; 1622 1623 Kill_Current_Values (Last_Assignment_Only => True); 1624 Check_Unreachable_Code (N); 1625 1626 Analyze_Dimension (N); 1627 end Analyze_Return_Statement; 1628 1629 ------------------------------------- 1630 -- Analyze_Simple_Return_Statement -- 1631 ------------------------------------- 1632 1633 procedure Analyze_Simple_Return_Statement (N : Node_Id) is 1634 begin 1635 if Present (Expression (N)) then 1636 Mark_Coextensions (N, Expression (N)); 1637 end if; 1638 1639 Analyze_Return_Statement (N); 1640 end Analyze_Simple_Return_Statement; 1641 1642 ------------------------- 1643 -- Analyze_Return_Type -- 1644 ------------------------- 1645 1646 procedure Analyze_Return_Type (N : Node_Id) is 1647 Designator : constant Entity_Id := Defining_Entity (N); 1648 Typ : Entity_Id := Empty; 1649 1650 begin 1651 -- Normal case where result definition does not indicate an error 1652 1653 if Result_Definition (N) /= Error then 1654 if Nkind (Result_Definition (N)) = N_Access_Definition then 1655 Check_SPARK_Restriction 1656 ("access result is not allowed", Result_Definition (N)); 1657 1658 -- Ada 2005 (AI-254): Handle anonymous access to subprograms 1659 1660 declare 1661 AD : constant Node_Id := 1662 Access_To_Subprogram_Definition (Result_Definition (N)); 1663 begin 1664 if Present (AD) and then Protected_Present (AD) then 1665 Typ := Replace_Anonymous_Access_To_Protected_Subprogram (N); 1666 else 1667 Typ := Access_Definition (N, Result_Definition (N)); 1668 end if; 1669 end; 1670 1671 Set_Parent (Typ, Result_Definition (N)); 1672 Set_Is_Local_Anonymous_Access (Typ); 1673 Set_Etype (Designator, Typ); 1674 1675 -- Ada 2005 (AI-231): Ensure proper usage of null exclusion 1676 1677 Null_Exclusion_Static_Checks (N); 1678 1679 -- Subtype_Mark case 1680 1681 else 1682 Find_Type (Result_Definition (N)); 1683 Typ := Entity (Result_Definition (N)); 1684 Set_Etype (Designator, Typ); 1685 1686 -- Unconstrained array as result is not allowed in SPARK 1687 1688 if Is_Array_Type (Typ) 1689 and then not Is_Constrained (Typ) 1690 then 1691 Check_SPARK_Restriction 1692 ("returning an unconstrained array is not allowed", 1693 Result_Definition (N)); 1694 end if; 1695 1696 -- Ada 2005 (AI-231): Ensure proper usage of null exclusion 1697 1698 Null_Exclusion_Static_Checks (N); 1699 1700 -- If a null exclusion is imposed on the result type, then create 1701 -- a null-excluding itype (an access subtype) and use it as the 1702 -- function's Etype. Note that the null exclusion checks are done 1703 -- right before this, because they don't get applied to types that 1704 -- do not come from source. 1705 1706 if Is_Access_Type (Typ) 1707 and then Null_Exclusion_Present (N) 1708 then 1709 Set_Etype (Designator, 1710 Create_Null_Excluding_Itype 1711 (T => Typ, 1712 Related_Nod => N, 1713 Scope_Id => Scope (Current_Scope))); 1714 1715 -- The new subtype must be elaborated before use because 1716 -- it is visible outside of the function. However its base 1717 -- type may not be frozen yet, so the reference that will 1718 -- force elaboration must be attached to the freezing of 1719 -- the base type. 1720 1721 -- If the return specification appears on a proper body, 1722 -- the subtype will have been created already on the spec. 1723 1724 if Is_Frozen (Typ) then 1725 if Nkind (Parent (N)) = N_Subprogram_Body 1726 and then Nkind (Parent (Parent (N))) = N_Subunit 1727 then 1728 null; 1729 else 1730 Build_Itype_Reference (Etype (Designator), Parent (N)); 1731 end if; 1732 1733 else 1734 Ensure_Freeze_Node (Typ); 1735 1736 declare 1737 IR : constant Node_Id := Make_Itype_Reference (Sloc (N)); 1738 begin 1739 Set_Itype (IR, Etype (Designator)); 1740 Append_Freeze_Actions (Typ, New_List (IR)); 1741 end; 1742 end if; 1743 1744 else 1745 Set_Etype (Designator, Typ); 1746 end if; 1747 1748 if Ekind (Typ) = E_Incomplete_Type 1749 and then Is_Value_Type (Typ) 1750 then 1751 null; 1752 1753 elsif Ekind (Typ) = E_Incomplete_Type 1754 or else (Is_Class_Wide_Type (Typ) 1755 and then 1756 Ekind (Root_Type (Typ)) = E_Incomplete_Type) 1757 then 1758 -- AI05-0151: Tagged incomplete types are allowed in all formal 1759 -- parts. Untagged incomplete types are not allowed in bodies. 1760 1761 if Ada_Version >= Ada_2012 then 1762 if Is_Tagged_Type (Typ) then 1763 null; 1764 1765 elsif Nkind_In (Parent (Parent (N)), 1766 N_Accept_Statement, 1767 N_Entry_Body, 1768 N_Subprogram_Body) 1769 then 1770 Error_Msg_NE 1771 ("invalid use of untagged incomplete type&", 1772 Designator, Typ); 1773 end if; 1774 1775 -- The type must be completed in the current package. This 1776 -- is checked at the end of the package declaraton, when 1777 -- Taft-amendment types are identified. If the return type 1778 -- is class-wide, there is no required check, the type can 1779 -- be a bona fide TAT. 1780 1781 if Ekind (Scope (Current_Scope)) = E_Package 1782 and then In_Private_Part (Scope (Current_Scope)) 1783 and then not Is_Class_Wide_Type (Typ) 1784 then 1785 Append_Elmt (Designator, Private_Dependents (Typ)); 1786 end if; 1787 1788 else 1789 Error_Msg_NE 1790 ("invalid use of incomplete type&", Designator, Typ); 1791 end if; 1792 end if; 1793 end if; 1794 1795 -- Case where result definition does indicate an error 1796 1797 else 1798 Set_Etype (Designator, Any_Type); 1799 end if; 1800 end Analyze_Return_Type; 1801 1802 ----------------------------- 1803 -- Analyze_Subprogram_Body -- 1804 ----------------------------- 1805 1806 procedure Analyze_Subprogram_Body (N : Node_Id) is 1807 Loc : constant Source_Ptr := Sloc (N); 1808 Body_Spec : constant Node_Id := Specification (N); 1809 Body_Id : constant Entity_Id := Defining_Entity (Body_Spec); 1810 1811 begin 1812 if Debug_Flag_C then 1813 Write_Str ("==> subprogram body "); 1814 Write_Name (Chars (Body_Id)); 1815 Write_Str (" from "); 1816 Write_Location (Loc); 1817 Write_Eol; 1818 Indent; 1819 end if; 1820 1821 Trace_Scope (N, Body_Id, " Analyze subprogram: "); 1822 1823 -- The real work is split out into the helper, so it can do "return;" 1824 -- without skipping the debug output: 1825 1826 Analyze_Subprogram_Body_Helper (N); 1827 1828 if Debug_Flag_C then 1829 Outdent; 1830 Write_Str ("<== subprogram body "); 1831 Write_Name (Chars (Body_Id)); 1832 Write_Str (" from "); 1833 Write_Location (Loc); 1834 Write_Eol; 1835 end if; 1836 end Analyze_Subprogram_Body; 1837 1838 ------------------------------------ 1839 -- Analyze_Subprogram_Body_Helper -- 1840 ------------------------------------ 1841 1842 -- This procedure is called for regular subprogram bodies, generic bodies, 1843 -- and for subprogram stubs of both kinds. In the case of stubs, only the 1844 -- specification matters, and is used to create a proper declaration for 1845 -- the subprogram, or to perform conformance checks. 1846 1847 procedure Analyze_Subprogram_Body_Helper (N : Node_Id) is 1848 Loc : constant Source_Ptr := Sloc (N); 1849 Body_Spec : constant Node_Id := Specification (N); 1850 Body_Id : Entity_Id := Defining_Entity (Body_Spec); 1851 Prev_Id : constant Entity_Id := Current_Entity_In_Scope (Body_Id); 1852 Conformant : Boolean; 1853 HSS : Node_Id; 1854 Prot_Typ : Entity_Id := Empty; 1855 Spec_Id : Entity_Id; 1856 Spec_Decl : Node_Id := Empty; 1857 1858 Last_Real_Spec_Entity : Entity_Id := Empty; 1859 -- When we analyze a separate spec, the entity chain ends up containing 1860 -- the formals, as well as any itypes generated during analysis of the 1861 -- default expressions for parameters, or the arguments of associated 1862 -- precondition/postcondition pragmas (which are analyzed in the context 1863 -- of the spec since they have visibility on formals). 1864 -- 1865 -- These entities belong with the spec and not the body. However we do 1866 -- the analysis of the body in the context of the spec (again to obtain 1867 -- visibility to the formals), and all the entities generated during 1868 -- this analysis end up also chained to the entity chain of the spec. 1869 -- But they really belong to the body, and there is circuitry to move 1870 -- them from the spec to the body. 1871 -- 1872 -- However, when we do this move, we don't want to move the real spec 1873 -- entities (first para above) to the body. The Last_Real_Spec_Entity 1874 -- variable points to the last real spec entity, so we only move those 1875 -- chained beyond that point. It is initialized to Empty to deal with 1876 -- the case where there is no separate spec. 1877 1878 procedure Check_Anonymous_Return; 1879 -- Ada 2005: if a function returns an access type that denotes a task, 1880 -- or a type that contains tasks, we must create a master entity for 1881 -- the anonymous type, which typically will be used in an allocator 1882 -- in the body of the function. 1883 1884 procedure Check_Inline_Pragma (Spec : in out Node_Id); 1885 -- Look ahead to recognize a pragma that may appear after the body. 1886 -- If there is a previous spec, check that it appears in the same 1887 -- declarative part. If the pragma is Inline_Always, perform inlining 1888 -- unconditionally, otherwise only if Front_End_Inlining is requested. 1889 -- If the body acts as a spec, and inlining is required, we create a 1890 -- subprogram declaration for it, in order to attach the body to inline. 1891 -- If pragma does not appear after the body, check whether there is 1892 -- an inline pragma before any local declarations. 1893 1894 procedure Check_Missing_Return; 1895 -- Checks for a function with a no return statements, and also performs 1896 -- the warning checks implemented by Check_Returns. In formal mode, also 1897 -- verify that a function ends with a RETURN and that a procedure does 1898 -- not contain any RETURN. 1899 1900 function Disambiguate_Spec return Entity_Id; 1901 -- When a primitive is declared between the private view and the full 1902 -- view of a concurrent type which implements an interface, a special 1903 -- mechanism is used to find the corresponding spec of the primitive 1904 -- body. 1905 1906 procedure Exchange_Limited_Views (Subp_Id : Entity_Id); 1907 -- Ada 2012 (AI05-0151): Detect whether the profile of Subp_Id contains 1908 -- incomplete types coming from a limited context and swap their limited 1909 -- views with the non-limited ones. 1910 1911 function Is_Private_Concurrent_Primitive 1912 (Subp_Id : Entity_Id) return Boolean; 1913 -- Determine whether subprogram Subp_Id is a primitive of a concurrent 1914 -- type that implements an interface and has a private view. 1915 1916 procedure Set_Trivial_Subprogram (N : Node_Id); 1917 -- Sets the Is_Trivial_Subprogram flag in both spec and body of the 1918 -- subprogram whose body is being analyzed. N is the statement node 1919 -- causing the flag to be set, if the following statement is a return 1920 -- of an entity, we mark the entity as set in source to suppress any 1921 -- warning on the stylized use of function stubs with a dummy return. 1922 1923 procedure Verify_Overriding_Indicator; 1924 -- If there was a previous spec, the entity has been entered in the 1925 -- current scope previously. If the body itself carries an overriding 1926 -- indicator, check that it is consistent with the known status of the 1927 -- entity. 1928 1929 ---------------------------- 1930 -- Check_Anonymous_Return -- 1931 ---------------------------- 1932 1933 procedure Check_Anonymous_Return is 1934 Decl : Node_Id; 1935 Par : Node_Id; 1936 Scop : Entity_Id; 1937 1938 begin 1939 if Present (Spec_Id) then 1940 Scop := Spec_Id; 1941 else 1942 Scop := Body_Id; 1943 end if; 1944 1945 if Ekind (Scop) = E_Function 1946 and then Ekind (Etype (Scop)) = E_Anonymous_Access_Type 1947 and then not Is_Thunk (Scop) 1948 and then (Has_Task (Designated_Type (Etype (Scop))) 1949 or else 1950 (Is_Class_Wide_Type (Designated_Type (Etype (Scop))) 1951 and then 1952 Is_Limited_Record (Designated_Type (Etype (Scop))))) 1953 and then Expander_Active 1954 1955 -- Avoid cases with no tasking support 1956 1957 and then RTE_Available (RE_Current_Master) 1958 and then not Restriction_Active (No_Task_Hierarchy) 1959 then 1960 Decl := 1961 Make_Object_Declaration (Loc, 1962 Defining_Identifier => 1963 Make_Defining_Identifier (Loc, Name_uMaster), 1964 Constant_Present => True, 1965 Object_Definition => 1966 New_Reference_To (RTE (RE_Master_Id), Loc), 1967 Expression => 1968 Make_Explicit_Dereference (Loc, 1969 New_Reference_To (RTE (RE_Current_Master), Loc))); 1970 1971 if Present (Declarations (N)) then 1972 Prepend (Decl, Declarations (N)); 1973 else 1974 Set_Declarations (N, New_List (Decl)); 1975 end if; 1976 1977 Set_Master_Id (Etype (Scop), Defining_Identifier (Decl)); 1978 Set_Has_Master_Entity (Scop); 1979 1980 -- Now mark the containing scope as a task master 1981 1982 Par := N; 1983 while Nkind (Par) /= N_Compilation_Unit loop 1984 Par := Parent (Par); 1985 pragma Assert (Present (Par)); 1986 1987 -- If we fall off the top, we are at the outer level, and 1988 -- the environment task is our effective master, so nothing 1989 -- to mark. 1990 1991 if Nkind_In 1992 (Par, N_Task_Body, N_Block_Statement, N_Subprogram_Body) 1993 then 1994 Set_Is_Task_Master (Par, True); 1995 exit; 1996 end if; 1997 end loop; 1998 end if; 1999 end Check_Anonymous_Return; 2000 2001 ------------------------- 2002 -- Check_Inline_Pragma -- 2003 ------------------------- 2004 2005 procedure Check_Inline_Pragma (Spec : in out Node_Id) is 2006 Prag : Node_Id; 2007 Plist : List_Id; 2008 2009 function Is_Inline_Pragma (N : Node_Id) return Boolean; 2010 -- True when N is a pragma Inline or Inline_Always that applies 2011 -- to this subprogram. 2012 2013 ----------------------- 2014 -- Is_Inline_Pragma -- 2015 ----------------------- 2016 2017 function Is_Inline_Pragma (N : Node_Id) return Boolean is 2018 begin 2019 return 2020 Nkind (N) = N_Pragma 2021 and then 2022 (Pragma_Name (N) = Name_Inline_Always 2023 or else 2024 (Front_End_Inlining 2025 and then Pragma_Name (N) = Name_Inline)) 2026 and then 2027 Chars 2028 (Expression (First (Pragma_Argument_Associations (N)))) 2029 = Chars (Body_Id); 2030 end Is_Inline_Pragma; 2031 2032 -- Start of processing for Check_Inline_Pragma 2033 2034 begin 2035 if not Expander_Active then 2036 return; 2037 end if; 2038 2039 if Is_List_Member (N) 2040 and then Present (Next (N)) 2041 and then Is_Inline_Pragma (Next (N)) 2042 then 2043 Prag := Next (N); 2044 2045 elsif Nkind (N) /= N_Subprogram_Body_Stub 2046 and then Present (Declarations (N)) 2047 and then Is_Inline_Pragma (First (Declarations (N))) 2048 then 2049 Prag := First (Declarations (N)); 2050 2051 else 2052 Prag := Empty; 2053 end if; 2054 2055 if Present (Prag) then 2056 if Present (Spec_Id) then 2057 if In_Same_List (N, Unit_Declaration_Node (Spec_Id)) then 2058 Analyze (Prag); 2059 end if; 2060 2061 else 2062 -- Create a subprogram declaration, to make treatment uniform 2063 2064 declare 2065 Subp : constant Entity_Id := 2066 Make_Defining_Identifier (Loc, Chars (Body_Id)); 2067 Decl : constant Node_Id := 2068 Make_Subprogram_Declaration (Loc, 2069 Specification => 2070 New_Copy_Tree (Specification (N))); 2071 2072 begin 2073 Set_Defining_Unit_Name (Specification (Decl), Subp); 2074 2075 if Present (First_Formal (Body_Id)) then 2076 Plist := Copy_Parameter_List (Body_Id); 2077 Set_Parameter_Specifications 2078 (Specification (Decl), Plist); 2079 end if; 2080 2081 Insert_Before (N, Decl); 2082 Analyze (Decl); 2083 Analyze (Prag); 2084 Set_Has_Pragma_Inline (Subp); 2085 2086 if Pragma_Name (Prag) = Name_Inline_Always then 2087 Set_Is_Inlined (Subp); 2088 Set_Has_Pragma_Inline_Always (Subp); 2089 end if; 2090 2091 Spec := Subp; 2092 end; 2093 end if; 2094 end if; 2095 end Check_Inline_Pragma; 2096 2097 -------------------------- 2098 -- Check_Missing_Return -- 2099 -------------------------- 2100 2101 procedure Check_Missing_Return is 2102 Id : Entity_Id; 2103 Missing_Ret : Boolean; 2104 2105 begin 2106 if Nkind (Body_Spec) = N_Function_Specification then 2107 if Present (Spec_Id) then 2108 Id := Spec_Id; 2109 else 2110 Id := Body_Id; 2111 end if; 2112 2113 if Return_Present (Id) then 2114 Check_Returns (HSS, 'F', Missing_Ret); 2115 2116 if Missing_Ret then 2117 Set_Has_Missing_Return (Id); 2118 end if; 2119 2120 elsif Is_Generic_Subprogram (Id) 2121 or else not Is_Machine_Code_Subprogram (Id) 2122 then 2123 Error_Msg_N ("missing RETURN statement in function body", N); 2124 end if; 2125 2126 -- If procedure with No_Return, check returns 2127 2128 elsif Nkind (Body_Spec) = N_Procedure_Specification 2129 and then Present (Spec_Id) 2130 and then No_Return (Spec_Id) 2131 then 2132 Check_Returns (HSS, 'P', Missing_Ret, Spec_Id); 2133 end if; 2134 2135 -- Special checks in SPARK mode 2136 2137 if Nkind (Body_Spec) = N_Function_Specification then 2138 2139 -- In SPARK mode, last statement of a function should be a return 2140 2141 declare 2142 Stat : constant Node_Id := Last_Source_Statement (HSS); 2143 begin 2144 if Present (Stat) 2145 and then not Nkind_In (Stat, N_Simple_Return_Statement, 2146 N_Extended_Return_Statement) 2147 then 2148 Check_SPARK_Restriction 2149 ("last statement in function should be RETURN", Stat); 2150 end if; 2151 end; 2152 2153 -- In SPARK mode, verify that a procedure has no return 2154 2155 elsif Nkind (Body_Spec) = N_Procedure_Specification then 2156 if Present (Spec_Id) then 2157 Id := Spec_Id; 2158 else 2159 Id := Body_Id; 2160 end if; 2161 2162 -- Would be nice to point to return statement here, can we 2163 -- borrow the Check_Returns procedure here ??? 2164 2165 if Return_Present (Id) then 2166 Check_SPARK_Restriction 2167 ("procedure should not have RETURN", N); 2168 end if; 2169 end if; 2170 end Check_Missing_Return; 2171 2172 ----------------------- 2173 -- Disambiguate_Spec -- 2174 ----------------------- 2175 2176 function Disambiguate_Spec return Entity_Id is 2177 Priv_Spec : Entity_Id; 2178 Spec_N : Entity_Id; 2179 2180 procedure Replace_Types (To_Corresponding : Boolean); 2181 -- Depending on the flag, replace the type of formal parameters of 2182 -- Body_Id if it is a concurrent type implementing interfaces with 2183 -- the corresponding record type or the other way around. 2184 2185 procedure Replace_Types (To_Corresponding : Boolean) is 2186 Formal : Entity_Id; 2187 Formal_Typ : Entity_Id; 2188 2189 begin 2190 Formal := First_Formal (Body_Id); 2191 while Present (Formal) loop 2192 Formal_Typ := Etype (Formal); 2193 2194 if Is_Class_Wide_Type (Formal_Typ) then 2195 Formal_Typ := Root_Type (Formal_Typ); 2196 end if; 2197 2198 -- From concurrent type to corresponding record 2199 2200 if To_Corresponding then 2201 if Is_Concurrent_Type (Formal_Typ) 2202 and then Present (Corresponding_Record_Type (Formal_Typ)) 2203 and then Present (Interfaces ( 2204 Corresponding_Record_Type (Formal_Typ))) 2205 then 2206 Set_Etype (Formal, 2207 Corresponding_Record_Type (Formal_Typ)); 2208 end if; 2209 2210 -- From corresponding record to concurrent type 2211 2212 else 2213 if Is_Concurrent_Record_Type (Formal_Typ) 2214 and then Present (Interfaces (Formal_Typ)) 2215 then 2216 Set_Etype (Formal, 2217 Corresponding_Concurrent_Type (Formal_Typ)); 2218 end if; 2219 end if; 2220 2221 Next_Formal (Formal); 2222 end loop; 2223 end Replace_Types; 2224 2225 -- Start of processing for Disambiguate_Spec 2226 2227 begin 2228 -- Try to retrieve the specification of the body as is. All error 2229 -- messages are suppressed because the body may not have a spec in 2230 -- its current state. 2231 2232 Spec_N := Find_Corresponding_Spec (N, False); 2233 2234 -- It is possible that this is the body of a primitive declared 2235 -- between a private and a full view of a concurrent type. The 2236 -- controlling parameter of the spec carries the concurrent type, 2237 -- not the corresponding record type as transformed by Analyze_ 2238 -- Subprogram_Specification. In such cases, we undo the change 2239 -- made by the analysis of the specification and try to find the 2240 -- spec again. 2241 2242 -- Note that wrappers already have their corresponding specs and 2243 -- bodies set during their creation, so if the candidate spec is 2244 -- a wrapper, then we definitely need to swap all types to their 2245 -- original concurrent status. 2246 2247 if No (Spec_N) 2248 or else Is_Primitive_Wrapper (Spec_N) 2249 then 2250 -- Restore all references of corresponding record types to the 2251 -- original concurrent types. 2252 2253 Replace_Types (To_Corresponding => False); 2254 Priv_Spec := Find_Corresponding_Spec (N, False); 2255 2256 -- The current body truly belongs to a primitive declared between 2257 -- a private and a full view. We leave the modified body as is, 2258 -- and return the true spec. 2259 2260 if Present (Priv_Spec) 2261 and then Is_Private_Primitive (Priv_Spec) 2262 then 2263 return Priv_Spec; 2264 end if; 2265 2266 -- In case that this is some sort of error, restore the original 2267 -- state of the body. 2268 2269 Replace_Types (To_Corresponding => True); 2270 end if; 2271 2272 return Spec_N; 2273 end Disambiguate_Spec; 2274 2275 ---------------------------- 2276 -- Exchange_Limited_Views -- 2277 ---------------------------- 2278 2279 procedure Exchange_Limited_Views (Subp_Id : Entity_Id) is 2280 procedure Detect_And_Exchange (Id : Entity_Id); 2281 -- Determine whether Id's type denotes an incomplete type associated 2282 -- with a limited with clause and exchange the limited view with the 2283 -- non-limited one. 2284 2285 ------------------------- 2286 -- Detect_And_Exchange -- 2287 ------------------------- 2288 2289 procedure Detect_And_Exchange (Id : Entity_Id) is 2290 Typ : constant Entity_Id := Etype (Id); 2291 2292 begin 2293 if Ekind (Typ) = E_Incomplete_Type 2294 and then From_With_Type (Typ) 2295 and then Present (Non_Limited_View (Typ)) 2296 then 2297 Set_Etype (Id, Non_Limited_View (Typ)); 2298 end if; 2299 end Detect_And_Exchange; 2300 2301 -- Local variables 2302 2303 Formal : Entity_Id; 2304 2305 -- Start of processing for Exchange_Limited_Views 2306 2307 begin 2308 if No (Subp_Id) then 2309 return; 2310 2311 -- Do not process subprogram bodies as they already use the non- 2312 -- limited view of types. 2313 2314 elsif not Ekind_In (Subp_Id, E_Function, E_Procedure) then 2315 return; 2316 end if; 2317 2318 -- Examine all formals and swap views when applicable 2319 2320 Formal := First_Formal (Subp_Id); 2321 while Present (Formal) loop 2322 Detect_And_Exchange (Formal); 2323 2324 Next_Formal (Formal); 2325 end loop; 2326 2327 -- Process the return type of a function 2328 2329 if Ekind (Subp_Id) = E_Function then 2330 Detect_And_Exchange (Subp_Id); 2331 end if; 2332 end Exchange_Limited_Views; 2333 2334 ------------------------------------- 2335 -- Is_Private_Concurrent_Primitive -- 2336 ------------------------------------- 2337 2338 function Is_Private_Concurrent_Primitive 2339 (Subp_Id : Entity_Id) return Boolean 2340 is 2341 Formal_Typ : Entity_Id; 2342 2343 begin 2344 if Present (First_Formal (Subp_Id)) then 2345 Formal_Typ := Etype (First_Formal (Subp_Id)); 2346 2347 if Is_Concurrent_Record_Type (Formal_Typ) then 2348 if Is_Class_Wide_Type (Formal_Typ) then 2349 Formal_Typ := Root_Type (Formal_Typ); 2350 end if; 2351 2352 Formal_Typ := Corresponding_Concurrent_Type (Formal_Typ); 2353 end if; 2354 2355 -- The type of the first formal is a concurrent tagged type with 2356 -- a private view. 2357 2358 return 2359 Is_Concurrent_Type (Formal_Typ) 2360 and then Is_Tagged_Type (Formal_Typ) 2361 and then Has_Private_Declaration (Formal_Typ); 2362 end if; 2363 2364 return False; 2365 end Is_Private_Concurrent_Primitive; 2366 2367 ---------------------------- 2368 -- Set_Trivial_Subprogram -- 2369 ---------------------------- 2370 2371 procedure Set_Trivial_Subprogram (N : Node_Id) is 2372 Nxt : constant Node_Id := Next (N); 2373 2374 begin 2375 Set_Is_Trivial_Subprogram (Body_Id); 2376 2377 if Present (Spec_Id) then 2378 Set_Is_Trivial_Subprogram (Spec_Id); 2379 end if; 2380 2381 if Present (Nxt) 2382 and then Nkind (Nxt) = N_Simple_Return_Statement 2383 and then No (Next (Nxt)) 2384 and then Present (Expression (Nxt)) 2385 and then Is_Entity_Name (Expression (Nxt)) 2386 then 2387 Set_Never_Set_In_Source (Entity (Expression (Nxt)), False); 2388 end if; 2389 end Set_Trivial_Subprogram; 2390 2391 --------------------------------- 2392 -- Verify_Overriding_Indicator -- 2393 --------------------------------- 2394 2395 procedure Verify_Overriding_Indicator is 2396 begin 2397 if Must_Override (Body_Spec) then 2398 if Nkind (Spec_Id) = N_Defining_Operator_Symbol 2399 and then Operator_Matches_Spec (Spec_Id, Spec_Id) 2400 then 2401 null; 2402 2403 elsif not Present (Overridden_Operation (Spec_Id)) then 2404 Error_Msg_NE 2405 ("subprogram& is not overriding", Body_Spec, Spec_Id); 2406 end if; 2407 2408 elsif Must_Not_Override (Body_Spec) then 2409 if Present (Overridden_Operation (Spec_Id)) then 2410 Error_Msg_NE 2411 ("subprogram& overrides inherited operation", 2412 Body_Spec, Spec_Id); 2413 2414 elsif Nkind (Spec_Id) = N_Defining_Operator_Symbol 2415 and then Operator_Matches_Spec (Spec_Id, Spec_Id) 2416 then 2417 Error_Msg_NE 2418 ("subprogram & overrides predefined operator ", 2419 Body_Spec, Spec_Id); 2420 2421 -- If this is not a primitive operation or protected subprogram, 2422 -- then the overriding indicator is altogether illegal. 2423 2424 elsif not Is_Primitive (Spec_Id) 2425 and then Ekind (Scope (Spec_Id)) /= E_Protected_Type 2426 then 2427 Error_Msg_N 2428 ("overriding indicator only allowed " & 2429 "if subprogram is primitive", 2430 Body_Spec); 2431 end if; 2432 2433 elsif Style_Check 2434 and then Present (Overridden_Operation (Spec_Id)) 2435 then 2436 pragma Assert (Unit_Declaration_Node (Body_Id) = N); 2437 Style.Missing_Overriding (N, Body_Id); 2438 2439 elsif Style_Check 2440 and then Can_Override_Operator (Spec_Id) 2441 and then not Is_Predefined_File_Name 2442 (Unit_File_Name (Get_Source_Unit (Spec_Id))) 2443 then 2444 pragma Assert (Unit_Declaration_Node (Body_Id) = N); 2445 Style.Missing_Overriding (N, Body_Id); 2446 end if; 2447 end Verify_Overriding_Indicator; 2448 2449 -- Start of processing for Analyze_Subprogram_Body_Helper 2450 2451 begin 2452 -- Generic subprograms are handled separately. They always have a 2453 -- generic specification. Determine whether current scope has a 2454 -- previous declaration. 2455 2456 -- If the subprogram body is defined within an instance of the same 2457 -- name, the instance appears as a package renaming, and will be hidden 2458 -- within the subprogram. 2459 2460 if Present (Prev_Id) 2461 and then not Is_Overloadable (Prev_Id) 2462 and then (Nkind (Parent (Prev_Id)) /= N_Package_Renaming_Declaration 2463 or else Comes_From_Source (Prev_Id)) 2464 then 2465 if Is_Generic_Subprogram (Prev_Id) then 2466 Spec_Id := Prev_Id; 2467 Set_Is_Compilation_Unit (Body_Id, Is_Compilation_Unit (Spec_Id)); 2468 Set_Is_Child_Unit (Body_Id, Is_Child_Unit (Spec_Id)); 2469 2470 Analyze_Generic_Subprogram_Body (N, Spec_Id); 2471 2472 if Nkind (N) = N_Subprogram_Body then 2473 HSS := Handled_Statement_Sequence (N); 2474 Check_Missing_Return; 2475 end if; 2476 2477 return; 2478 2479 else 2480 -- Previous entity conflicts with subprogram name. Attempting to 2481 -- enter name will post error. 2482 2483 Enter_Name (Body_Id); 2484 return; 2485 end if; 2486 2487 -- Non-generic case, find the subprogram declaration, if one was seen, 2488 -- or enter new overloaded entity in the current scope. If the 2489 -- Current_Entity is the Body_Id itself, the unit is being analyzed as 2490 -- part of the context of one of its subunits. No need to redo the 2491 -- analysis. 2492 2493 elsif Prev_Id = Body_Id 2494 and then Has_Completion (Body_Id) 2495 then 2496 return; 2497 2498 else 2499 Body_Id := Analyze_Subprogram_Specification (Body_Spec); 2500 2501 if Nkind (N) = N_Subprogram_Body_Stub 2502 or else No (Corresponding_Spec (N)) 2503 then 2504 if Is_Private_Concurrent_Primitive (Body_Id) then 2505 Spec_Id := Disambiguate_Spec; 2506 else 2507 Spec_Id := Find_Corresponding_Spec (N); 2508 end if; 2509 2510 -- If this is a duplicate body, no point in analyzing it 2511 2512 if Error_Posted (N) then 2513 return; 2514 end if; 2515 2516 -- A subprogram body should cause freezing of its own declaration, 2517 -- but if there was no previous explicit declaration, then the 2518 -- subprogram will get frozen too late (there may be code within 2519 -- the body that depends on the subprogram having been frozen, 2520 -- such as uses of extra formals), so we force it to be frozen 2521 -- here. Same holds if the body and spec are compilation units. 2522 -- Finally, if the return type is an anonymous access to protected 2523 -- subprogram, it must be frozen before the body because its 2524 -- expansion has generated an equivalent type that is used when 2525 -- elaborating the body. 2526 2527 -- An exception in the case of Ada 2012, AI05-177: The bodies 2528 -- created for expression functions do not freeze. 2529 2530 if No (Spec_Id) 2531 and then Nkind (Original_Node (N)) /= N_Expression_Function 2532 then 2533 Freeze_Before (N, Body_Id); 2534 2535 elsif Nkind (Parent (N)) = N_Compilation_Unit then 2536 Freeze_Before (N, Spec_Id); 2537 2538 elsif Is_Access_Subprogram_Type (Etype (Body_Id)) then 2539 Freeze_Before (N, Etype (Body_Id)); 2540 end if; 2541 2542 else 2543 Spec_Id := Corresponding_Spec (N); 2544 end if; 2545 end if; 2546 2547 -- Ada 2012 aspects may appear in a subprogram body, but only if there 2548 -- is no previous spec. 2549 2550 if Has_Aspects (N) then 2551 if Present (Corresponding_Spec (N)) then 2552 Error_Msg_N 2553 ("aspect specifications must appear in subprogram declaration", 2554 N); 2555 else 2556 Analyze_Aspect_Specifications (N, Body_Id); 2557 end if; 2558 end if; 2559 2560 -- Previously we scanned the body to look for nested subprograms, and 2561 -- rejected an inline directive if nested subprograms were present, 2562 -- because the back-end would generate conflicting symbols for the 2563 -- nested bodies. This is now unnecessary. 2564 2565 -- Look ahead to recognize a pragma Inline that appears after the body 2566 2567 Check_Inline_Pragma (Spec_Id); 2568 2569 -- Deal with special case of a fully private operation in the body of 2570 -- the protected type. We must create a declaration for the subprogram, 2571 -- in order to attach the protected subprogram that will be used in 2572 -- internal calls. We exclude compiler generated bodies from the 2573 -- expander since the issue does not arise for those cases. 2574 2575 if No (Spec_Id) 2576 and then Comes_From_Source (N) 2577 and then Is_Protected_Type (Current_Scope) 2578 then 2579 Spec_Id := Build_Private_Protected_Declaration (N); 2580 end if; 2581 2582 -- If a separate spec is present, then deal with freezing issues 2583 2584 if Present (Spec_Id) then 2585 Spec_Decl := Unit_Declaration_Node (Spec_Id); 2586 Verify_Overriding_Indicator; 2587 2588 -- In general, the spec will be frozen when we start analyzing the 2589 -- body. However, for internally generated operations, such as 2590 -- wrapper functions for inherited operations with controlling 2591 -- results, the spec may not have been frozen by the time we expand 2592 -- the freeze actions that include the bodies. In particular, extra 2593 -- formals for accessibility or for return-in-place may need to be 2594 -- generated. Freeze nodes, if any, are inserted before the current 2595 -- body. These freeze actions are also needed in ASIS mode to enable 2596 -- the proper back-annotations. 2597 2598 if not Is_Frozen (Spec_Id) 2599 and then (Expander_Active or ASIS_Mode) 2600 then 2601 -- Force the generation of its freezing node to ensure proper 2602 -- management of access types in the backend. 2603 2604 -- This is definitely needed for some cases, but it is not clear 2605 -- why, to be investigated further??? 2606 2607 Set_Has_Delayed_Freeze (Spec_Id); 2608 Freeze_Before (N, Spec_Id); 2609 end if; 2610 end if; 2611 2612 -- Mark presence of postcondition procedure in current scope and mark 2613 -- the procedure itself as needing debug info. The latter is important 2614 -- when analyzing decision coverage (for example, for MC/DC coverage). 2615 2616 if Chars (Body_Id) = Name_uPostconditions then 2617 Set_Has_Postconditions (Current_Scope); 2618 Set_Debug_Info_Needed (Body_Id); 2619 end if; 2620 2621 -- Place subprogram on scope stack, and make formals visible. If there 2622 -- is a spec, the visible entity remains that of the spec. 2623 2624 if Present (Spec_Id) then 2625 Generate_Reference (Spec_Id, Body_Id, 'b', Set_Ref => False); 2626 2627 if Is_Child_Unit (Spec_Id) then 2628 Generate_Reference (Spec_Id, Scope (Spec_Id), 'k', False); 2629 end if; 2630 2631 if Style_Check then 2632 Style.Check_Identifier (Body_Id, Spec_Id); 2633 end if; 2634 2635 Set_Is_Compilation_Unit (Body_Id, Is_Compilation_Unit (Spec_Id)); 2636 Set_Is_Child_Unit (Body_Id, Is_Child_Unit (Spec_Id)); 2637 2638 if Is_Abstract_Subprogram (Spec_Id) then 2639 Error_Msg_N ("an abstract subprogram cannot have a body", N); 2640 return; 2641 2642 else 2643 Set_Convention (Body_Id, Convention (Spec_Id)); 2644 Set_Has_Completion (Spec_Id); 2645 2646 if Is_Protected_Type (Scope (Spec_Id)) then 2647 Prot_Typ := Scope (Spec_Id); 2648 end if; 2649 2650 -- If this is a body generated for a renaming, do not check for 2651 -- full conformance. The check is redundant, because the spec of 2652 -- the body is a copy of the spec in the renaming declaration, 2653 -- and the test can lead to spurious errors on nested defaults. 2654 2655 if Present (Spec_Decl) 2656 and then not Comes_From_Source (N) 2657 and then 2658 (Nkind (Original_Node (Spec_Decl)) = 2659 N_Subprogram_Renaming_Declaration 2660 or else (Present (Corresponding_Body (Spec_Decl)) 2661 and then 2662 Nkind (Unit_Declaration_Node 2663 (Corresponding_Body (Spec_Decl))) = 2664 N_Subprogram_Renaming_Declaration)) 2665 then 2666 Conformant := True; 2667 2668 -- Conversely, the spec may have been generated for specless body 2669 -- with an inline pragma. 2670 2671 elsif Comes_From_Source (N) 2672 and then not Comes_From_Source (Spec_Id) 2673 and then Has_Pragma_Inline (Spec_Id) 2674 then 2675 Conformant := True; 2676 2677 else 2678 Check_Conformance 2679 (Body_Id, Spec_Id, 2680 Fully_Conformant, True, Conformant, Body_Id); 2681 end if; 2682 2683 -- If the body is not fully conformant, we have to decide if we 2684 -- should analyze it or not. If it has a really messed up profile 2685 -- then we probably should not analyze it, since we will get too 2686 -- many bogus messages. 2687 2688 -- Our decision is to go ahead in the non-fully conformant case 2689 -- only if it is at least mode conformant with the spec. Note 2690 -- that the call to Check_Fully_Conformant has issued the proper 2691 -- error messages to complain about the lack of conformance. 2692 2693 if not Conformant 2694 and then not Mode_Conformant (Body_Id, Spec_Id) 2695 then 2696 return; 2697 end if; 2698 end if; 2699 2700 if Spec_Id /= Body_Id then 2701 Reference_Body_Formals (Spec_Id, Body_Id); 2702 end if; 2703 2704 if Nkind (N) /= N_Subprogram_Body_Stub then 2705 Set_Corresponding_Spec (N, Spec_Id); 2706 2707 -- Ada 2005 (AI-345): If the operation is a primitive operation 2708 -- of a concurrent type, the type of the first parameter has been 2709 -- replaced with the corresponding record, which is the proper 2710 -- run-time structure to use. However, within the body there may 2711 -- be uses of the formals that depend on primitive operations 2712 -- of the type (in particular calls in prefixed form) for which 2713 -- we need the original concurrent type. The operation may have 2714 -- several controlling formals, so the replacement must be done 2715 -- for all of them. 2716 2717 if Comes_From_Source (Spec_Id) 2718 and then Present (First_Entity (Spec_Id)) 2719 and then Ekind (Etype (First_Entity (Spec_Id))) = E_Record_Type 2720 and then Is_Tagged_Type (Etype (First_Entity (Spec_Id))) 2721 and then 2722 Present (Interfaces (Etype (First_Entity (Spec_Id)))) 2723 and then 2724 Present 2725 (Corresponding_Concurrent_Type 2726 (Etype (First_Entity (Spec_Id)))) 2727 then 2728 declare 2729 Typ : constant Entity_Id := Etype (First_Entity (Spec_Id)); 2730 Form : Entity_Id; 2731 2732 begin 2733 Form := First_Formal (Spec_Id); 2734 while Present (Form) loop 2735 if Etype (Form) = Typ then 2736 Set_Etype (Form, Corresponding_Concurrent_Type (Typ)); 2737 end if; 2738 2739 Next_Formal (Form); 2740 end loop; 2741 end; 2742 end if; 2743 2744 -- Make the formals visible, and place subprogram on scope stack. 2745 -- This is also the point at which we set Last_Real_Spec_Entity 2746 -- to mark the entities which will not be moved to the body. 2747 2748 Install_Formals (Spec_Id); 2749 Last_Real_Spec_Entity := Last_Entity (Spec_Id); 2750 2751 -- Within an instance, add local renaming declarations so that 2752 -- gdb can retrieve the values of actuals more easily. This is 2753 -- only relevant if generating code (and indeed we definitely 2754 -- do not want these definitions -gnatc mode, because that would 2755 -- confuse ASIS). 2756 2757 if Is_Generic_Instance (Spec_Id) 2758 and then Is_Wrapper_Package (Current_Scope) 2759 and then Expander_Active 2760 then 2761 Build_Subprogram_Instance_Renamings (N, Current_Scope); 2762 end if; 2763 2764 Push_Scope (Spec_Id); 2765 2766 -- Make sure that the subprogram is immediately visible. For 2767 -- child units that have no separate spec this is indispensable. 2768 -- Otherwise it is safe albeit redundant. 2769 2770 Set_Is_Immediately_Visible (Spec_Id); 2771 end if; 2772 2773 Set_Corresponding_Body (Unit_Declaration_Node (Spec_Id), Body_Id); 2774 Set_Ekind (Body_Id, E_Subprogram_Body); 2775 Set_Scope (Body_Id, Scope (Spec_Id)); 2776 Set_Is_Obsolescent (Body_Id, Is_Obsolescent (Spec_Id)); 2777 2778 -- Case of subprogram body with no previous spec 2779 2780 else 2781 -- Check for style warning required 2782 2783 if Style_Check 2784 2785 -- Only apply check for source level subprograms for which checks 2786 -- have not been suppressed. 2787 2788 and then Comes_From_Source (Body_Id) 2789 and then not Suppress_Style_Checks (Body_Id) 2790 2791 -- No warnings within an instance 2792 2793 and then not In_Instance 2794 2795 -- No warnings for expression functions 2796 2797 and then Nkind (Original_Node (N)) /= N_Expression_Function 2798 then 2799 Style.Body_With_No_Spec (N); 2800 end if; 2801 2802 New_Overloaded_Entity (Body_Id); 2803 2804 if Nkind (N) /= N_Subprogram_Body_Stub then 2805 Set_Acts_As_Spec (N); 2806 Generate_Definition (Body_Id); 2807 Set_Contract (Body_Id, Make_Contract (Sloc (Body_Id))); 2808 Generate_Reference 2809 (Body_Id, Body_Id, 'b', Set_Ref => False, Force => True); 2810 Install_Formals (Body_Id); 2811 Push_Scope (Body_Id); 2812 end if; 2813 2814 -- For stubs and bodies with no previous spec, generate references to 2815 -- formals. 2816 2817 Generate_Reference_To_Formals (Body_Id); 2818 end if; 2819 2820 -- If the return type is an anonymous access type whose designated type 2821 -- is the limited view of a class-wide type and the non-limited view is 2822 -- available, update the return type accordingly. 2823 2824 if Ada_Version >= Ada_2005 2825 and then Comes_From_Source (N) 2826 then 2827 declare 2828 Etyp : Entity_Id; 2829 Rtyp : Entity_Id; 2830 2831 begin 2832 Rtyp := Etype (Current_Scope); 2833 2834 if Ekind (Rtyp) = E_Anonymous_Access_Type then 2835 Etyp := Directly_Designated_Type (Rtyp); 2836 2837 if Is_Class_Wide_Type (Etyp) 2838 and then From_With_Type (Etyp) 2839 then 2840 Set_Directly_Designated_Type 2841 (Etype (Current_Scope), Available_View (Etyp)); 2842 end if; 2843 end if; 2844 end; 2845 end if; 2846 2847 -- If this is the proper body of a stub, we must verify that the stub 2848 -- conforms to the body, and to the previous spec if one was present. 2849 -- We know already that the body conforms to that spec. This test is 2850 -- only required for subprograms that come from source. 2851 2852 if Nkind (Parent (N)) = N_Subunit 2853 and then Comes_From_Source (N) 2854 and then not Error_Posted (Body_Id) 2855 and then Nkind (Corresponding_Stub (Parent (N))) = 2856 N_Subprogram_Body_Stub 2857 then 2858 declare 2859 Old_Id : constant Entity_Id := 2860 Defining_Entity 2861 (Specification (Corresponding_Stub (Parent (N)))); 2862 2863 Conformant : Boolean := False; 2864 2865 begin 2866 if No (Spec_Id) then 2867 Check_Fully_Conformant (Body_Id, Old_Id); 2868 2869 else 2870 Check_Conformance 2871 (Body_Id, Old_Id, Fully_Conformant, False, Conformant); 2872 2873 if not Conformant then 2874 2875 -- The stub was taken to be a new declaration. Indicate that 2876 -- it lacks a body. 2877 2878 Set_Has_Completion (Old_Id, False); 2879 end if; 2880 end if; 2881 end; 2882 end if; 2883 2884 Set_Has_Completion (Body_Id); 2885 Check_Eliminated (Body_Id); 2886 2887 if Nkind (N) = N_Subprogram_Body_Stub then 2888 return; 2889 end if; 2890 2891 -- Handle frontend inlining. There is no need to prepare us for inlining 2892 -- if we will not generate the code. 2893 2894 -- Old semantics 2895 2896 if not Debug_Flag_Dot_K then 2897 if Present (Spec_Id) 2898 and then Expander_Active 2899 and then 2900 (Has_Pragma_Inline_Always (Spec_Id) 2901 or else (Has_Pragma_Inline (Spec_Id) and Front_End_Inlining)) 2902 then 2903 Build_Body_To_Inline (N, Spec_Id); 2904 end if; 2905 2906 -- New semantics 2907 2908 elsif Expander_Active 2909 and then Serious_Errors_Detected = 0 2910 and then Present (Spec_Id) 2911 and then Has_Pragma_Inline (Spec_Id) 2912 then 2913 Check_And_Build_Body_To_Inline (N, Spec_Id, Body_Id); 2914 end if; 2915 2916 -- Ada 2005 (AI-262): In library subprogram bodies, after the analysis 2917 -- of the specification we have to install the private withed units. 2918 -- This holds for child units as well. 2919 2920 if Is_Compilation_Unit (Body_Id) 2921 or else Nkind (Parent (N)) = N_Compilation_Unit 2922 then 2923 Install_Private_With_Clauses (Body_Id); 2924 end if; 2925 2926 Check_Anonymous_Return; 2927 2928 -- Set the Protected_Formal field of each extra formal of the protected 2929 -- subprogram to reference the corresponding extra formal of the 2930 -- subprogram that implements it. For regular formals this occurs when 2931 -- the protected subprogram's declaration is expanded, but the extra 2932 -- formals don't get created until the subprogram is frozen. We need to 2933 -- do this before analyzing the protected subprogram's body so that any 2934 -- references to the original subprogram's extra formals will be changed 2935 -- refer to the implementing subprogram's formals (see Expand_Formal). 2936 2937 if Present (Spec_Id) 2938 and then Is_Protected_Type (Scope (Spec_Id)) 2939 and then Present (Protected_Body_Subprogram (Spec_Id)) 2940 then 2941 declare 2942 Impl_Subp : constant Entity_Id := 2943 Protected_Body_Subprogram (Spec_Id); 2944 Prot_Ext_Formal : Entity_Id := Extra_Formals (Spec_Id); 2945 Impl_Ext_Formal : Entity_Id := Extra_Formals (Impl_Subp); 2946 begin 2947 while Present (Prot_Ext_Formal) loop 2948 pragma Assert (Present (Impl_Ext_Formal)); 2949 Set_Protected_Formal (Prot_Ext_Formal, Impl_Ext_Formal); 2950 Next_Formal_With_Extras (Prot_Ext_Formal); 2951 Next_Formal_With_Extras (Impl_Ext_Formal); 2952 end loop; 2953 end; 2954 end if; 2955 2956 -- Now we can go on to analyze the body 2957 2958 HSS := Handled_Statement_Sequence (N); 2959 Set_Actual_Subtypes (N, Current_Scope); 2960 2961 -- Deal with preconditions and postconditions. In formal verification 2962 -- mode, we keep pre- and postconditions attached to entities rather 2963 -- than inserted in the code, in order to facilitate a distinct 2964 -- treatment for them. 2965 2966 if not Alfa_Mode then 2967 Process_PPCs (N, Spec_Id, Body_Id); 2968 end if; 2969 2970 -- Add a declaration for the Protection object, renaming declarations 2971 -- for discriminals and privals and finally a declaration for the entry 2972 -- family index (if applicable). This form of early expansion is done 2973 -- when the Expander is active because Install_Private_Data_Declarations 2974 -- references entities which were created during regular expansion. The 2975 -- body may be the rewritting of an expression function, and we need to 2976 -- verify that the original node is in the source. 2977 2978 if Full_Expander_Active 2979 and then Comes_From_Source (Original_Node (N)) 2980 and then Present (Prot_Typ) 2981 and then Present (Spec_Id) 2982 and then not Is_Eliminated (Spec_Id) 2983 then 2984 Install_Private_Data_Declarations 2985 (Sloc (N), Spec_Id, Prot_Typ, N, Declarations (N)); 2986 end if; 2987 2988 -- Ada 2012 (AI05-0151): Incomplete types coming from a limited context 2989 -- may now appear in parameter and result profiles. Since the analysis 2990 -- of a subprogram body may use the parameter and result profile of the 2991 -- spec, swap any limited views with their non-limited counterpart. 2992 2993 if Ada_Version >= Ada_2012 then 2994 Exchange_Limited_Views (Spec_Id); 2995 end if; 2996 2997 -- Analyze the declarations (this call will analyze the precondition 2998 -- Check pragmas we prepended to the list, as well as the declaration 2999 -- of the _Postconditions procedure). 3000 3001 Analyze_Declarations (Declarations (N)); 3002 3003 -- Check completion, and analyze the statements 3004 3005 Check_Completion; 3006 Inspect_Deferred_Constant_Completion (Declarations (N)); 3007 Analyze (HSS); 3008 3009 -- Deal with end of scope processing for the body 3010 3011 Process_End_Label (HSS, 't', Current_Scope); 3012 End_Scope; 3013 Check_Subprogram_Order (N); 3014 Set_Analyzed (Body_Id); 3015 3016 -- If we have a separate spec, then the analysis of the declarations 3017 -- caused the entities in the body to be chained to the spec id, but 3018 -- we want them chained to the body id. Only the formal parameters 3019 -- end up chained to the spec id in this case. 3020 3021 if Present (Spec_Id) then 3022 3023 -- We must conform to the categorization of our spec 3024 3025 Validate_Categorization_Dependency (N, Spec_Id); 3026 3027 -- And if this is a child unit, the parent units must conform 3028 3029 if Is_Child_Unit (Spec_Id) then 3030 Validate_Categorization_Dependency 3031 (Unit_Declaration_Node (Spec_Id), Spec_Id); 3032 end if; 3033 3034 -- Here is where we move entities from the spec to the body 3035 3036 -- Case where there are entities that stay with the spec 3037 3038 if Present (Last_Real_Spec_Entity) then 3039 3040 -- No body entities (happens when the only real spec entities come 3041 -- from precondition and postcondition pragmas). 3042 3043 if No (Last_Entity (Body_Id)) then 3044 Set_First_Entity 3045 (Body_Id, Next_Entity (Last_Real_Spec_Entity)); 3046 3047 -- Body entities present (formals), so chain stuff past them 3048 3049 else 3050 Set_Next_Entity 3051 (Last_Entity (Body_Id), Next_Entity (Last_Real_Spec_Entity)); 3052 end if; 3053 3054 Set_Next_Entity (Last_Real_Spec_Entity, Empty); 3055 Set_Last_Entity (Body_Id, Last_Entity (Spec_Id)); 3056 Set_Last_Entity (Spec_Id, Last_Real_Spec_Entity); 3057 3058 -- Case where there are no spec entities, in this case there can be 3059 -- no body entities either, so just move everything. 3060 3061 else 3062 pragma Assert (No (Last_Entity (Body_Id))); 3063 Set_First_Entity (Body_Id, First_Entity (Spec_Id)); 3064 Set_Last_Entity (Body_Id, Last_Entity (Spec_Id)); 3065 Set_First_Entity (Spec_Id, Empty); 3066 Set_Last_Entity (Spec_Id, Empty); 3067 end if; 3068 end if; 3069 3070 Check_Missing_Return; 3071 3072 -- Now we are going to check for variables that are never modified in 3073 -- the body of the procedure. But first we deal with a special case 3074 -- where we want to modify this check. If the body of the subprogram 3075 -- starts with a raise statement or its equivalent, or if the body 3076 -- consists entirely of a null statement, then it is pretty obvious 3077 -- that it is OK to not reference the parameters. For example, this 3078 -- might be the following common idiom for a stubbed function: 3079 -- statement of the procedure raises an exception. In particular this 3080 -- deals with the common idiom of a stubbed function, which might 3081 -- appear as something like: 3082 3083 -- function F (A : Integer) return Some_Type; 3084 -- X : Some_Type; 3085 -- begin 3086 -- raise Program_Error; 3087 -- return X; 3088 -- end F; 3089 3090 -- Here the purpose of X is simply to satisfy the annoying requirement 3091 -- in Ada that there be at least one return, and we certainly do not 3092 -- want to go posting warnings on X that it is not initialized! On 3093 -- the other hand, if X is entirely unreferenced that should still 3094 -- get a warning. 3095 3096 -- What we do is to detect these cases, and if we find them, flag the 3097 -- subprogram as being Is_Trivial_Subprogram and then use that flag to 3098 -- suppress unwanted warnings. For the case of the function stub above 3099 -- we have a special test to set X as apparently assigned to suppress 3100 -- the warning. 3101 3102 declare 3103 Stm : Node_Id; 3104 3105 begin 3106 -- Skip initial labels (for one thing this occurs when we are in 3107 -- front end ZCX mode, but in any case it is irrelevant), and also 3108 -- initial Push_xxx_Error_Label nodes, which are also irrelevant. 3109 3110 Stm := First (Statements (HSS)); 3111 while Nkind (Stm) = N_Label 3112 or else Nkind (Stm) in N_Push_xxx_Label 3113 loop 3114 Next (Stm); 3115 end loop; 3116 3117 -- Do the test on the original statement before expansion 3118 3119 declare 3120 Ostm : constant Node_Id := Original_Node (Stm); 3121 3122 begin 3123 -- If explicit raise statement, turn on flag 3124 3125 if Nkind (Ostm) = N_Raise_Statement then 3126 Set_Trivial_Subprogram (Stm); 3127 3128 -- If null statement, and no following statements, turn on flag 3129 3130 elsif Nkind (Stm) = N_Null_Statement 3131 and then Comes_From_Source (Stm) 3132 and then No (Next (Stm)) 3133 then 3134 Set_Trivial_Subprogram (Stm); 3135 3136 -- Check for explicit call cases which likely raise an exception 3137 3138 elsif Nkind (Ostm) = N_Procedure_Call_Statement then 3139 if Is_Entity_Name (Name (Ostm)) then 3140 declare 3141 Ent : constant Entity_Id := Entity (Name (Ostm)); 3142 3143 begin 3144 -- If the procedure is marked No_Return, then likely it 3145 -- raises an exception, but in any case it is not coming 3146 -- back here, so turn on the flag. 3147 3148 if Present (Ent) 3149 and then Ekind (Ent) = E_Procedure 3150 and then No_Return (Ent) 3151 then 3152 Set_Trivial_Subprogram (Stm); 3153 end if; 3154 end; 3155 end if; 3156 end if; 3157 end; 3158 end; 3159 3160 -- Check for variables that are never modified 3161 3162 declare 3163 E1, E2 : Entity_Id; 3164 3165 begin 3166 -- If there is a separate spec, then transfer Never_Set_In_Source 3167 -- flags from out parameters to the corresponding entities in the 3168 -- body. The reason we do that is we want to post error flags on 3169 -- the body entities, not the spec entities. 3170 3171 if Present (Spec_Id) then 3172 E1 := First_Entity (Spec_Id); 3173 while Present (E1) loop 3174 if Ekind (E1) = E_Out_Parameter then 3175 E2 := First_Entity (Body_Id); 3176 while Present (E2) loop 3177 exit when Chars (E1) = Chars (E2); 3178 Next_Entity (E2); 3179 end loop; 3180 3181 if Present (E2) then 3182 Set_Never_Set_In_Source (E2, Never_Set_In_Source (E1)); 3183 end if; 3184 end if; 3185 3186 Next_Entity (E1); 3187 end loop; 3188 end if; 3189 3190 -- Check references in body 3191 3192 Check_References (Body_Id); 3193 end; 3194 end Analyze_Subprogram_Body_Helper; 3195 3196 ------------------------------------ 3197 -- Analyze_Subprogram_Declaration -- 3198 ------------------------------------ 3199 3200 procedure Analyze_Subprogram_Declaration (N : Node_Id) is 3201 Loc : constant Source_Ptr := Sloc (N); 3202 Scop : constant Entity_Id := Current_Scope; 3203 Designator : Entity_Id; 3204 Form : Node_Id; 3205 Null_Body : Node_Id := Empty; 3206 3207 -- Start of processing for Analyze_Subprogram_Declaration 3208 3209 begin 3210 -- Null procedures are not allowed in SPARK 3211 3212 if Nkind (Specification (N)) = N_Procedure_Specification 3213 and then Null_Present (Specification (N)) 3214 then 3215 Check_SPARK_Restriction ("null procedure is not allowed", N); 3216 end if; 3217 3218 -- For a null procedure, capture the profile before analysis, for 3219 -- expansion at the freeze point and at each point of call. The body 3220 -- will only be used if the procedure has preconditions. In that case 3221 -- the body is analyzed at the freeze point. 3222 3223 if Nkind (Specification (N)) = N_Procedure_Specification 3224 and then Null_Present (Specification (N)) 3225 and then Expander_Active 3226 then 3227 Null_Body := 3228 Make_Subprogram_Body (Loc, 3229 Specification => 3230 New_Copy_Tree (Specification (N)), 3231 Declarations => 3232 New_List, 3233 Handled_Statement_Sequence => 3234 Make_Handled_Sequence_Of_Statements (Loc, 3235 Statements => New_List (Make_Null_Statement (Loc)))); 3236 3237 -- Create new entities for body and formals 3238 3239 Set_Defining_Unit_Name (Specification (Null_Body), 3240 Make_Defining_Identifier (Loc, Chars (Defining_Entity (N)))); 3241 3242 Form := First (Parameter_Specifications (Specification (Null_Body))); 3243 while Present (Form) loop 3244 Set_Defining_Identifier (Form, 3245 Make_Defining_Identifier (Loc, 3246 Chars (Defining_Identifier (Form)))); 3247 3248 -- Resolve the types of the formals now, because the freeze point 3249 -- may appear in a different context, e.g. an instantiation. 3250 3251 if Nkind (Parameter_Type (Form)) /= N_Access_Definition then 3252 Find_Type (Parameter_Type (Form)); 3253 3254 elsif 3255 No (Access_To_Subprogram_Definition (Parameter_Type (Form))) 3256 then 3257 Find_Type (Subtype_Mark (Parameter_Type (Form))); 3258 3259 else 3260 3261 -- the case of a null procedure with a formal that is an 3262 -- access_to_subprogram type, and that is used as an actual 3263 -- in an instantiation is left to the enthusiastic reader. 3264 3265 null; 3266 end if; 3267 3268 Next (Form); 3269 end loop; 3270 3271 if Is_Protected_Type (Current_Scope) then 3272 Error_Msg_N ("protected operation cannot be a null procedure", N); 3273 end if; 3274 end if; 3275 3276 Designator := Analyze_Subprogram_Specification (Specification (N)); 3277 3278 -- A reference may already have been generated for the unit name, in 3279 -- which case the following call is redundant. However it is needed for 3280 -- declarations that are the rewriting of an expression function. 3281 3282 Generate_Definition (Designator); 3283 3284 if Debug_Flag_C then 3285 Write_Str ("==> subprogram spec "); 3286 Write_Name (Chars (Designator)); 3287 Write_Str (" from "); 3288 Write_Location (Sloc (N)); 3289 Write_Eol; 3290 Indent; 3291 end if; 3292 3293 if Nkind (Specification (N)) = N_Procedure_Specification 3294 and then Null_Present (Specification (N)) 3295 then 3296 Set_Has_Completion (Designator); 3297 3298 -- Null procedures are always inlined, but generic formal subprograms 3299 -- which appear as such in the internal instance of formal packages, 3300 -- need no completion and are not marked Inline. 3301 3302 if Present (Null_Body) 3303 and then Nkind (N) /= N_Formal_Concrete_Subprogram_Declaration 3304 then 3305 Set_Corresponding_Body (N, Defining_Entity (Null_Body)); 3306 Set_Body_To_Inline (N, Null_Body); 3307 Set_Is_Inlined (Designator); 3308 end if; 3309 end if; 3310 3311 Validate_RCI_Subprogram_Declaration (N); 3312 New_Overloaded_Entity (Designator); 3313 Check_Delayed_Subprogram (Designator); 3314 3315 -- If the type of the first formal of the current subprogram is a 3316 -- nongeneric tagged private type, mark the subprogram as being a 3317 -- private primitive. Ditto if this is a function with controlling 3318 -- result, and the return type is currently private. In both cases, 3319 -- the type of the controlling argument or result must be in the 3320 -- current scope for the operation to be primitive. 3321 3322 if Has_Controlling_Result (Designator) 3323 and then Is_Private_Type (Etype (Designator)) 3324 and then Scope (Etype (Designator)) = Current_Scope 3325 and then not Is_Generic_Actual_Type (Etype (Designator)) 3326 then 3327 Set_Is_Private_Primitive (Designator); 3328 3329 elsif Present (First_Formal (Designator)) then 3330 declare 3331 Formal_Typ : constant Entity_Id := 3332 Etype (First_Formal (Designator)); 3333 begin 3334 Set_Is_Private_Primitive (Designator, 3335 Is_Tagged_Type (Formal_Typ) 3336 and then Scope (Formal_Typ) = Current_Scope 3337 and then Is_Private_Type (Formal_Typ) 3338 and then not Is_Generic_Actual_Type (Formal_Typ)); 3339 end; 3340 end if; 3341 3342 -- Ada 2005 (AI-251): Abstract interface primitives must be abstract 3343 -- or null. 3344 3345 if Ada_Version >= Ada_2005 3346 and then Comes_From_Source (N) 3347 and then Is_Dispatching_Operation (Designator) 3348 then 3349 declare 3350 E : Entity_Id; 3351 Etyp : Entity_Id; 3352 3353 begin 3354 if Has_Controlling_Result (Designator) then 3355 Etyp := Etype (Designator); 3356 3357 else 3358 E := First_Entity (Designator); 3359 while Present (E) 3360 and then Is_Formal (E) 3361 and then not Is_Controlling_Formal (E) 3362 loop 3363 Next_Entity (E); 3364 end loop; 3365 3366 Etyp := Etype (E); 3367 end if; 3368 3369 if Is_Access_Type (Etyp) then 3370 Etyp := Directly_Designated_Type (Etyp); 3371 end if; 3372 3373 if Is_Interface (Etyp) 3374 and then not Is_Abstract_Subprogram (Designator) 3375 and then not (Ekind (Designator) = E_Procedure 3376 and then Null_Present (Specification (N))) 3377 then 3378 Error_Msg_Name_1 := Chars (Defining_Entity (N)); 3379 3380 -- Specialize error message based on procedures vs. functions, 3381 -- since functions can't be null subprograms. 3382 3383 if Ekind (Designator) = E_Procedure then 3384 Error_Msg_N 3385 ("interface procedure % must be abstract or null", N); 3386 else 3387 Error_Msg_N ("interface function % must be abstract", N); 3388 end if; 3389 end if; 3390 end; 3391 end if; 3392 3393 -- What is the following code for, it used to be 3394 3395 -- ??? Set_Suppress_Elaboration_Checks 3396 -- ??? (Designator, Elaboration_Checks_Suppressed (Designator)); 3397 3398 -- The following seems equivalent, but a bit dubious 3399 3400 if Elaboration_Checks_Suppressed (Designator) then 3401 Set_Kill_Elaboration_Checks (Designator); 3402 end if; 3403 3404 if Scop /= Standard_Standard 3405 and then not Is_Child_Unit (Designator) 3406 then 3407 Set_Categorization_From_Scope (Designator, Scop); 3408 else 3409 -- For a compilation unit, check for library-unit pragmas 3410 3411 Push_Scope (Designator); 3412 Set_Categorization_From_Pragmas (N); 3413 Validate_Categorization_Dependency (N, Designator); 3414 Pop_Scope; 3415 end if; 3416 3417 -- For a compilation unit, set body required. This flag will only be 3418 -- reset if a valid Import or Interface pragma is processed later on. 3419 3420 if Nkind (Parent (N)) = N_Compilation_Unit then 3421 Set_Body_Required (Parent (N), True); 3422 3423 if Ada_Version >= Ada_2005 3424 and then Nkind (Specification (N)) = N_Procedure_Specification 3425 and then Null_Present (Specification (N)) 3426 then 3427 Error_Msg_N 3428 ("null procedure cannot be declared at library level", N); 3429 end if; 3430 end if; 3431 3432 Generate_Reference_To_Formals (Designator); 3433 Check_Eliminated (Designator); 3434 3435 if Debug_Flag_C then 3436 Outdent; 3437 Write_Str ("<== subprogram spec "); 3438 Write_Name (Chars (Designator)); 3439 Write_Str (" from "); 3440 Write_Location (Sloc (N)); 3441 Write_Eol; 3442 end if; 3443 3444 if Is_Protected_Type (Current_Scope) then 3445 3446 -- Indicate that this is a protected operation, because it may be 3447 -- used in subsequent declarations within the protected type. 3448 3449 Set_Convention (Designator, Convention_Protected); 3450 end if; 3451 3452 List_Inherited_Pre_Post_Aspects (Designator); 3453 3454 if Has_Aspects (N) then 3455 Analyze_Aspect_Specifications (N, Designator); 3456 end if; 3457 end Analyze_Subprogram_Declaration; 3458 3459 -------------------------------------- 3460 -- Analyze_Subprogram_Specification -- 3461 -------------------------------------- 3462 3463 -- Reminder: N here really is a subprogram specification (not a subprogram 3464 -- declaration). This procedure is called to analyze the specification in 3465 -- both subprogram bodies and subprogram declarations (specs). 3466 3467 function Analyze_Subprogram_Specification (N : Node_Id) return Entity_Id is 3468 Designator : constant Entity_Id := Defining_Entity (N); 3469 Formals : constant List_Id := Parameter_Specifications (N); 3470 3471 -- Start of processing for Analyze_Subprogram_Specification 3472 3473 begin 3474 -- User-defined operator is not allowed in SPARK, except as a renaming 3475 3476 if Nkind (Defining_Unit_Name (N)) = N_Defining_Operator_Symbol 3477 and then Nkind (Parent (N)) /= N_Subprogram_Renaming_Declaration 3478 then 3479 Check_SPARK_Restriction ("user-defined operator is not allowed", N); 3480 end if; 3481 3482 -- Proceed with analysis. Do not emit a cross-reference entry if the 3483 -- specification comes from an expression function, because it may be 3484 -- the completion of a previous declaration. It is is not, the cross- 3485 -- reference entry will be emitted for the new subprogram declaration. 3486 3487 if Nkind (Parent (N)) /= N_Expression_Function then 3488 Generate_Definition (Designator); 3489 end if; 3490 3491 Set_Contract (Designator, Make_Contract (Sloc (Designator))); 3492 3493 if Nkind (N) = N_Function_Specification then 3494 Set_Ekind (Designator, E_Function); 3495 Set_Mechanism (Designator, Default_Mechanism); 3496 else 3497 Set_Ekind (Designator, E_Procedure); 3498 Set_Etype (Designator, Standard_Void_Type); 3499 end if; 3500 3501 -- Introduce new scope for analysis of the formals and the return type 3502 3503 Set_Scope (Designator, Current_Scope); 3504 3505 if Present (Formals) then 3506 Push_Scope (Designator); 3507 Process_Formals (Formals, N); 3508 3509 -- Check dimensions in N for formals with default expression 3510 3511 Analyze_Dimension_Formals (N, Formals); 3512 3513 -- Ada 2005 (AI-345): If this is an overriding operation of an 3514 -- inherited interface operation, and the controlling type is 3515 -- a synchronized type, replace the type with its corresponding 3516 -- record, to match the proper signature of an overriding operation. 3517 -- Same processing for an access parameter whose designated type is 3518 -- derived from a synchronized interface. 3519 3520 if Ada_Version >= Ada_2005 then 3521 declare 3522 Formal : Entity_Id; 3523 Formal_Typ : Entity_Id; 3524 Rec_Typ : Entity_Id; 3525 Desig_Typ : Entity_Id; 3526 3527 begin 3528 Formal := First_Formal (Designator); 3529 while Present (Formal) loop 3530 Formal_Typ := Etype (Formal); 3531 3532 if Is_Concurrent_Type (Formal_Typ) 3533 and then Present (Corresponding_Record_Type (Formal_Typ)) 3534 then 3535 Rec_Typ := Corresponding_Record_Type (Formal_Typ); 3536 3537 if Present (Interfaces (Rec_Typ)) then 3538 Set_Etype (Formal, Rec_Typ); 3539 end if; 3540 3541 elsif Ekind (Formal_Typ) = E_Anonymous_Access_Type then 3542 Desig_Typ := Designated_Type (Formal_Typ); 3543 3544 if Is_Concurrent_Type (Desig_Typ) 3545 and then Present (Corresponding_Record_Type (Desig_Typ)) 3546 then 3547 Rec_Typ := Corresponding_Record_Type (Desig_Typ); 3548 3549 if Present (Interfaces (Rec_Typ)) then 3550 Set_Directly_Designated_Type (Formal_Typ, Rec_Typ); 3551 end if; 3552 end if; 3553 end if; 3554 3555 Next_Formal (Formal); 3556 end loop; 3557 end; 3558 end if; 3559 3560 End_Scope; 3561 3562 -- The subprogram scope is pushed and popped around the processing of 3563 -- the return type for consistency with call above to Process_Formals 3564 -- (which itself can call Analyze_Return_Type), and to ensure that any 3565 -- itype created for the return type will be associated with the proper 3566 -- scope. 3567 3568 elsif Nkind (N) = N_Function_Specification then 3569 Push_Scope (Designator); 3570 Analyze_Return_Type (N); 3571 End_Scope; 3572 end if; 3573 3574 -- Function case 3575 3576 if Nkind (N) = N_Function_Specification then 3577 3578 -- Deal with operator symbol case 3579 3580 if Nkind (Designator) = N_Defining_Operator_Symbol then 3581 Valid_Operator_Definition (Designator); 3582 end if; 3583 3584 May_Need_Actuals (Designator); 3585 3586 -- Ada 2005 (AI-251): If the return type is abstract, verify that 3587 -- the subprogram is abstract also. This does not apply to renaming 3588 -- declarations, where abstractness is inherited, and to subprogram 3589 -- bodies generated for stream operations, which become renamings as 3590 -- bodies. 3591 3592 -- In case of primitives associated with abstract interface types 3593 -- the check is applied later (see Analyze_Subprogram_Declaration). 3594 3595 if not Nkind_In (Original_Node (Parent (N)), 3596 N_Subprogram_Renaming_Declaration, 3597 N_Abstract_Subprogram_Declaration, 3598 N_Formal_Abstract_Subprogram_Declaration) 3599 then 3600 if Is_Abstract_Type (Etype (Designator)) 3601 and then not Is_Interface (Etype (Designator)) 3602 then 3603 Error_Msg_N 3604 ("function that returns abstract type must be abstract", N); 3605 3606 -- Ada 2012 (AI-0073): Extend this test to subprograms with an 3607 -- access result whose designated type is abstract. 3608 3609 elsif Nkind (Result_Definition (N)) = N_Access_Definition 3610 and then 3611 not Is_Class_Wide_Type (Designated_Type (Etype (Designator))) 3612 and then Is_Abstract_Type (Designated_Type (Etype (Designator))) 3613 and then Ada_Version >= Ada_2012 3614 then 3615 Error_Msg_N ("function whose access result designates " 3616 & "abstract type must be abstract", N); 3617 end if; 3618 end if; 3619 end if; 3620 3621 return Designator; 3622 end Analyze_Subprogram_Specification; 3623 3624 -------------------------- 3625 -- Build_Body_To_Inline -- 3626 -------------------------- 3627 3628 procedure Build_Body_To_Inline (N : Node_Id; Subp : Entity_Id) is 3629 Decl : constant Node_Id := Unit_Declaration_Node (Subp); 3630 Original_Body : Node_Id; 3631 Body_To_Analyze : Node_Id; 3632 Max_Size : constant := 10; 3633 Stat_Count : Integer := 0; 3634 3635 function Has_Excluded_Declaration (Decls : List_Id) return Boolean; 3636 -- Check for declarations that make inlining not worthwhile 3637 3638 function Has_Excluded_Statement (Stats : List_Id) return Boolean; 3639 -- Check for statements that make inlining not worthwhile: any tasking 3640 -- statement, nested at any level. Keep track of total number of 3641 -- elementary statements, as a measure of acceptable size. 3642 3643 function Has_Pending_Instantiation return Boolean; 3644 -- If some enclosing body contains instantiations that appear before the 3645 -- corresponding generic body, the enclosing body has a freeze node so 3646 -- that it can be elaborated after the generic itself. This might 3647 -- conflict with subsequent inlinings, so that it is unsafe to try to 3648 -- inline in such a case. 3649 3650 function Has_Single_Return return Boolean; 3651 -- In general we cannot inline functions that return unconstrained type. 3652 -- However, we can handle such functions if all return statements return 3653 -- a local variable that is the only declaration in the body of the 3654 -- function. In that case the call can be replaced by that local 3655 -- variable as is done for other inlined calls. 3656 3657 procedure Remove_Pragmas; 3658 -- A pragma Unreferenced or pragma Unmodified that mentions a formal 3659 -- parameter has no meaning when the body is inlined and the formals 3660 -- are rewritten. Remove it from body to inline. The analysis of the 3661 -- non-inlined body will handle the pragma properly. 3662 3663 function Uses_Secondary_Stack (Bod : Node_Id) return Boolean; 3664 -- If the body of the subprogram includes a call that returns an 3665 -- unconstrained type, the secondary stack is involved, and it 3666 -- is not worth inlining. 3667 3668 ------------------------------ 3669 -- Has_Excluded_Declaration -- 3670 ------------------------------ 3671 3672 function Has_Excluded_Declaration (Decls : List_Id) return Boolean is 3673 D : Node_Id; 3674 3675 function Is_Unchecked_Conversion (D : Node_Id) return Boolean; 3676 -- Nested subprograms make a given body ineligible for inlining, but 3677 -- we make an exception for instantiations of unchecked conversion. 3678 -- The body has not been analyzed yet, so check the name, and verify 3679 -- that the visible entity with that name is the predefined unit. 3680 3681 ----------------------------- 3682 -- Is_Unchecked_Conversion -- 3683 ----------------------------- 3684 3685 function Is_Unchecked_Conversion (D : Node_Id) return Boolean is 3686 Id : constant Node_Id := Name (D); 3687 Conv : Entity_Id; 3688 3689 begin 3690 if Nkind (Id) = N_Identifier 3691 and then Chars (Id) = Name_Unchecked_Conversion 3692 then 3693 Conv := Current_Entity (Id); 3694 3695 elsif Nkind_In (Id, N_Selected_Component, N_Expanded_Name) 3696 and then Chars (Selector_Name (Id)) = Name_Unchecked_Conversion 3697 then 3698 Conv := Current_Entity (Selector_Name (Id)); 3699 else 3700 return False; 3701 end if; 3702 3703 return Present (Conv) 3704 and then Is_Predefined_File_Name 3705 (Unit_File_Name (Get_Source_Unit (Conv))) 3706 and then Is_Intrinsic_Subprogram (Conv); 3707 end Is_Unchecked_Conversion; 3708 3709 -- Start of processing for Has_Excluded_Declaration 3710 3711 begin 3712 D := First (Decls); 3713 while Present (D) loop 3714 if (Nkind (D) = N_Function_Instantiation 3715 and then not Is_Unchecked_Conversion (D)) 3716 or else Nkind_In (D, N_Protected_Type_Declaration, 3717 N_Package_Declaration, 3718 N_Package_Instantiation, 3719 N_Subprogram_Body, 3720 N_Procedure_Instantiation, 3721 N_Task_Type_Declaration) 3722 then 3723 Cannot_Inline 3724 ("cannot inline & (non-allowed declaration)?", D, Subp); 3725 return True; 3726 end if; 3727 3728 Next (D); 3729 end loop; 3730 3731 return False; 3732 end Has_Excluded_Declaration; 3733 3734 ---------------------------- 3735 -- Has_Excluded_Statement -- 3736 ---------------------------- 3737 3738 function Has_Excluded_Statement (Stats : List_Id) return Boolean is 3739 S : Node_Id; 3740 E : Node_Id; 3741 3742 begin 3743 S := First (Stats); 3744 while Present (S) loop 3745 Stat_Count := Stat_Count + 1; 3746 3747 if Nkind_In (S, N_Abort_Statement, 3748 N_Asynchronous_Select, 3749 N_Conditional_Entry_Call, 3750 N_Delay_Relative_Statement, 3751 N_Delay_Until_Statement, 3752 N_Selective_Accept, 3753 N_Timed_Entry_Call) 3754 then 3755 Cannot_Inline 3756 ("cannot inline & (non-allowed statement)?", S, Subp); 3757 return True; 3758 3759 elsif Nkind (S) = N_Block_Statement then 3760 if Present (Declarations (S)) 3761 and then Has_Excluded_Declaration (Declarations (S)) 3762 then 3763 return True; 3764 3765 elsif Present (Handled_Statement_Sequence (S)) 3766 and then 3767 (Present 3768 (Exception_Handlers (Handled_Statement_Sequence (S))) 3769 or else 3770 Has_Excluded_Statement 3771 (Statements (Handled_Statement_Sequence (S)))) 3772 then 3773 return True; 3774 end if; 3775 3776 elsif Nkind (S) = N_Case_Statement then 3777 E := First (Alternatives (S)); 3778 while Present (E) loop 3779 if Has_Excluded_Statement (Statements (E)) then 3780 return True; 3781 end if; 3782 3783 Next (E); 3784 end loop; 3785 3786 elsif Nkind (S) = N_If_Statement then 3787 if Has_Excluded_Statement (Then_Statements (S)) then 3788 return True; 3789 end if; 3790 3791 if Present (Elsif_Parts (S)) then 3792 E := First (Elsif_Parts (S)); 3793 while Present (E) loop 3794 if Has_Excluded_Statement (Then_Statements (E)) then 3795 return True; 3796 end if; 3797 3798 Next (E); 3799 end loop; 3800 end if; 3801 3802 if Present (Else_Statements (S)) 3803 and then Has_Excluded_Statement (Else_Statements (S)) 3804 then 3805 return True; 3806 end if; 3807 3808 elsif Nkind (S) = N_Loop_Statement 3809 and then Has_Excluded_Statement (Statements (S)) 3810 then 3811 return True; 3812 3813 elsif Nkind (S) = N_Extended_Return_Statement then 3814 if Has_Excluded_Statement 3815 (Statements (Handled_Statement_Sequence (S))) 3816 or else Present 3817 (Exception_Handlers (Handled_Statement_Sequence (S))) 3818 then 3819 return True; 3820 end if; 3821 end if; 3822 3823 Next (S); 3824 end loop; 3825 3826 return False; 3827 end Has_Excluded_Statement; 3828 3829 ------------------------------- 3830 -- Has_Pending_Instantiation -- 3831 ------------------------------- 3832 3833 function Has_Pending_Instantiation return Boolean is 3834 S : Entity_Id; 3835 3836 begin 3837 S := Current_Scope; 3838 while Present (S) loop 3839 if Is_Compilation_Unit (S) 3840 or else Is_Child_Unit (S) 3841 then 3842 return False; 3843 3844 elsif Ekind (S) = E_Package 3845 and then Has_Forward_Instantiation (S) 3846 then 3847 return True; 3848 end if; 3849 3850 S := Scope (S); 3851 end loop; 3852 3853 return False; 3854 end Has_Pending_Instantiation; 3855 3856 ------------------------ 3857 -- Has_Single_Return -- 3858 ------------------------ 3859 3860 function Has_Single_Return return Boolean is 3861 Return_Statement : Node_Id := Empty; 3862 3863 function Check_Return (N : Node_Id) return Traverse_Result; 3864 3865 ------------------ 3866 -- Check_Return -- 3867 ------------------ 3868 3869 function Check_Return (N : Node_Id) return Traverse_Result is 3870 begin 3871 if Nkind (N) = N_Simple_Return_Statement then 3872 if Present (Expression (N)) 3873 and then Is_Entity_Name (Expression (N)) 3874 then 3875 if No (Return_Statement) then 3876 Return_Statement := N; 3877 return OK; 3878 3879 elsif Chars (Expression (N)) = 3880 Chars (Expression (Return_Statement)) 3881 then 3882 return OK; 3883 3884 else 3885 return Abandon; 3886 end if; 3887 3888 -- A return statement within an extended return is a noop 3889 -- after inlining. 3890 3891 elsif No (Expression (N)) 3892 and then Nkind (Parent (Parent (N))) = 3893 N_Extended_Return_Statement 3894 then 3895 return OK; 3896 3897 else 3898 -- Expression has wrong form 3899 3900 return Abandon; 3901 end if; 3902 3903 -- We can only inline a build-in-place function if 3904 -- it has a single extended return. 3905 3906 elsif Nkind (N) = N_Extended_Return_Statement then 3907 if No (Return_Statement) then 3908 Return_Statement := N; 3909 return OK; 3910 3911 else 3912 return Abandon; 3913 end if; 3914 3915 else 3916 return OK; 3917 end if; 3918 end Check_Return; 3919 3920 function Check_All_Returns is new Traverse_Func (Check_Return); 3921 3922 -- Start of processing for Has_Single_Return 3923 3924 begin 3925 if Check_All_Returns (N) /= OK then 3926 return False; 3927 3928 elsif Nkind (Return_Statement) = N_Extended_Return_Statement then 3929 return True; 3930 3931 else 3932 return Present (Declarations (N)) 3933 and then Present (First (Declarations (N))) 3934 and then Chars (Expression (Return_Statement)) = 3935 Chars (Defining_Identifier (First (Declarations (N)))); 3936 end if; 3937 end Has_Single_Return; 3938 3939 -------------------- 3940 -- Remove_Pragmas -- 3941 -------------------- 3942 3943 procedure Remove_Pragmas is 3944 Decl : Node_Id; 3945 Nxt : Node_Id; 3946 3947 begin 3948 Decl := First (Declarations (Body_To_Analyze)); 3949 while Present (Decl) loop 3950 Nxt := Next (Decl); 3951 3952 if Nkind (Decl) = N_Pragma 3953 and then (Pragma_Name (Decl) = Name_Unreferenced 3954 or else 3955 Pragma_Name (Decl) = Name_Unmodified) 3956 then 3957 Remove (Decl); 3958 end if; 3959 3960 Decl := Nxt; 3961 end loop; 3962 end Remove_Pragmas; 3963 3964 -------------------------- 3965 -- Uses_Secondary_Stack -- 3966 -------------------------- 3967 3968 function Uses_Secondary_Stack (Bod : Node_Id) return Boolean is 3969 function Check_Call (N : Node_Id) return Traverse_Result; 3970 -- Look for function calls that return an unconstrained type 3971 3972 ---------------- 3973 -- Check_Call -- 3974 ---------------- 3975 3976 function Check_Call (N : Node_Id) return Traverse_Result is 3977 begin 3978 if Nkind (N) = N_Function_Call 3979 and then Is_Entity_Name (Name (N)) 3980 and then Is_Composite_Type (Etype (Entity (Name (N)))) 3981 and then not Is_Constrained (Etype (Entity (Name (N)))) 3982 then 3983 Cannot_Inline 3984 ("cannot inline & (call returns unconstrained type)?", 3985 N, Subp); 3986 return Abandon; 3987 else 3988 return OK; 3989 end if; 3990 end Check_Call; 3991 3992 function Check_Calls is new Traverse_Func (Check_Call); 3993 3994 begin 3995 return Check_Calls (Bod) = Abandon; 3996 end Uses_Secondary_Stack; 3997 3998 -- Start of processing for Build_Body_To_Inline 3999 4000 begin 4001 -- Return immediately if done already 4002 4003 if Nkind (Decl) = N_Subprogram_Declaration 4004 and then Present (Body_To_Inline (Decl)) 4005 then 4006 return; 4007 4008 -- Functions that return unconstrained composite types require 4009 -- secondary stack handling, and cannot currently be inlined, unless 4010 -- all return statements return a local variable that is the first 4011 -- local declaration in the body. 4012 4013 elsif Ekind (Subp) = E_Function 4014 and then not Is_Scalar_Type (Etype (Subp)) 4015 and then not Is_Access_Type (Etype (Subp)) 4016 and then not Is_Constrained (Etype (Subp)) 4017 then 4018 if not Has_Single_Return then 4019 Cannot_Inline 4020 ("cannot inline & (unconstrained return type)?", N, Subp); 4021 return; 4022 end if; 4023 4024 -- Ditto for functions that return controlled types, where controlled 4025 -- actions interfere in complex ways with inlining. 4026 4027 elsif Ekind (Subp) = E_Function 4028 and then Needs_Finalization (Etype (Subp)) 4029 then 4030 Cannot_Inline 4031 ("cannot inline & (controlled return type)?", N, Subp); 4032 return; 4033 end if; 4034 4035 if Present (Declarations (N)) 4036 and then Has_Excluded_Declaration (Declarations (N)) 4037 then 4038 return; 4039 end if; 4040 4041 if Present (Handled_Statement_Sequence (N)) then 4042 if Present (Exception_Handlers (Handled_Statement_Sequence (N))) then 4043 Cannot_Inline 4044 ("cannot inline& (exception handler)?", 4045 First (Exception_Handlers (Handled_Statement_Sequence (N))), 4046 Subp); 4047 return; 4048 elsif 4049 Has_Excluded_Statement 4050 (Statements (Handled_Statement_Sequence (N))) 4051 then 4052 return; 4053 end if; 4054 end if; 4055 4056 -- We do not inline a subprogram that is too large, unless it is 4057 -- marked Inline_Always. This pragma does not suppress the other 4058 -- checks on inlining (forbidden declarations, handlers, etc). 4059 4060 if Stat_Count > Max_Size 4061 and then not Has_Pragma_Inline_Always (Subp) 4062 then 4063 Cannot_Inline ("cannot inline& (body too large)?", N, Subp); 4064 return; 4065 end if; 4066 4067 if Has_Pending_Instantiation then 4068 Cannot_Inline 4069 ("cannot inline& (forward instance within enclosing body)?", 4070 N, Subp); 4071 return; 4072 end if; 4073 4074 -- Within an instance, the body to inline must be treated as a nested 4075 -- generic, so that the proper global references are preserved. 4076 4077 -- Note that we do not do this at the library level, because it is not 4078 -- needed, and furthermore this causes trouble if front end inlining 4079 -- is activated (-gnatN). 4080 4081 if In_Instance and then Scope (Current_Scope) /= Standard_Standard then 4082 Save_Env (Scope (Current_Scope), Scope (Current_Scope)); 4083 Original_Body := Copy_Generic_Node (N, Empty, True); 4084 else 4085 Original_Body := Copy_Separate_Tree (N); 4086 end if; 4087 4088 -- We need to capture references to the formals in order to substitute 4089 -- the actuals at the point of inlining, i.e. instantiation. To treat 4090 -- the formals as globals to the body to inline, we nest it within 4091 -- a dummy parameterless subprogram, declared within the real one. 4092 -- To avoid generating an internal name (which is never public, and 4093 -- which affects serial numbers of other generated names), we use 4094 -- an internal symbol that cannot conflict with user declarations. 4095 4096 Set_Parameter_Specifications (Specification (Original_Body), No_List); 4097 Set_Defining_Unit_Name 4098 (Specification (Original_Body), 4099 Make_Defining_Identifier (Sloc (N), Name_uParent)); 4100 Set_Corresponding_Spec (Original_Body, Empty); 4101 4102 Body_To_Analyze := Copy_Generic_Node (Original_Body, Empty, False); 4103 4104 -- Set return type of function, which is also global and does not need 4105 -- to be resolved. 4106 4107 if Ekind (Subp) = E_Function then 4108 Set_Result_Definition (Specification (Body_To_Analyze), 4109 New_Occurrence_Of (Etype (Subp), Sloc (N))); 4110 end if; 4111 4112 if No (Declarations (N)) then 4113 Set_Declarations (N, New_List (Body_To_Analyze)); 4114 else 4115 Append (Body_To_Analyze, Declarations (N)); 4116 end if; 4117 4118 Expander_Mode_Save_And_Set (False); 4119 Remove_Pragmas; 4120 4121 Analyze (Body_To_Analyze); 4122 Push_Scope (Defining_Entity (Body_To_Analyze)); 4123 Save_Global_References (Original_Body); 4124 End_Scope; 4125 Remove (Body_To_Analyze); 4126 4127 Expander_Mode_Restore; 4128 4129 -- Restore environment if previously saved 4130 4131 if In_Instance and then Scope (Current_Scope) /= Standard_Standard then 4132 Restore_Env; 4133 end if; 4134 4135 -- If secondary stk used there is no point in inlining. We have 4136 -- already issued the warning in this case, so nothing to do. 4137 4138 if Uses_Secondary_Stack (Body_To_Analyze) then 4139 return; 4140 end if; 4141 4142 Set_Body_To_Inline (Decl, Original_Body); 4143 Set_Ekind (Defining_Entity (Original_Body), Ekind (Subp)); 4144 Set_Is_Inlined (Subp); 4145 end Build_Body_To_Inline; 4146 4147 ------------------- 4148 -- Cannot_Inline -- 4149 ------------------- 4150 4151 procedure Cannot_Inline 4152 (Msg : String; 4153 N : Node_Id; 4154 Subp : Entity_Id; 4155 Is_Serious : Boolean := False) 4156 is 4157 begin 4158 pragma Assert (Msg (Msg'Last) = '?'); 4159 4160 -- Old semantics 4161 4162 if not Debug_Flag_Dot_K then 4163 4164 -- Do not emit warning if this is a predefined unit which is not 4165 -- the main unit. With validity checks enabled, some predefined 4166 -- subprograms may contain nested subprograms and become ineligible 4167 -- for inlining. 4168 4169 if Is_Predefined_File_Name (Unit_File_Name (Get_Source_Unit (Subp))) 4170 and then not In_Extended_Main_Source_Unit (Subp) 4171 then 4172 null; 4173 4174 elsif Has_Pragma_Inline_Always (Subp) then 4175 4176 -- Remove last character (question mark) to make this into an 4177 -- error, because the Inline_Always pragma cannot be obeyed. 4178 4179 Error_Msg_NE (Msg (Msg'First .. Msg'Last - 1), N, Subp); 4180 4181 elsif Ineffective_Inline_Warnings then 4182 Error_Msg_NE (Msg & "p?", N, Subp); 4183 end if; 4184 4185 return; 4186 4187 -- New semantics 4188 4189 elsif Is_Serious then 4190 4191 -- Remove last character (question mark) to make this into an error. 4192 4193 Error_Msg_NE (Msg (Msg'First .. Msg'Last - 1), N, Subp); 4194 4195 elsif Optimization_Level = 0 then 4196 4197 -- Do not emit warning if this is a predefined unit which is not 4198 -- the main unit. This behavior is currently provided for backward 4199 -- compatibility but it will be removed when we enforce the 4200 -- strictness of the new rules. 4201 4202 if Is_Predefined_File_Name (Unit_File_Name (Get_Source_Unit (Subp))) 4203 and then not In_Extended_Main_Source_Unit (Subp) 4204 then 4205 null; 4206 4207 elsif Has_Pragma_Inline_Always (Subp) then 4208 4209 -- Emit a warning if this is a call to a runtime subprogram 4210 -- which is located inside a generic. Previously this call 4211 -- was silently skipped! 4212 4213 if Is_Generic_Instance (Subp) then 4214 declare 4215 Gen_P : constant Entity_Id := Generic_Parent (Parent (Subp)); 4216 begin 4217 if Is_Predefined_File_Name 4218 (Unit_File_Name (Get_Source_Unit (Gen_P))) 4219 then 4220 Set_Is_Inlined (Subp, False); 4221 Error_Msg_NE (Msg & "p?", N, Subp); 4222 return; 4223 end if; 4224 end; 4225 end if; 4226 4227 -- Remove last character (question mark) to make this into an 4228 -- error, because the Inline_Always pragma cannot be obeyed. 4229 4230 Error_Msg_NE (Msg (Msg'First .. Msg'Last - 1), N, Subp); 4231 4232 else pragma Assert (Front_End_Inlining); 4233 Set_Is_Inlined (Subp, False); 4234 4235 -- When inlining cannot take place we must issue an error. 4236 -- For backward compatibility we still report a warning. 4237 4238 if Ineffective_Inline_Warnings then 4239 Error_Msg_NE (Msg & "p?", N, Subp); 4240 end if; 4241 end if; 4242 4243 -- Compiling with optimizations enabled it is too early to report 4244 -- problems since the backend may still perform inlining. In order 4245 -- to report unhandled inlinings the program must be compiled with 4246 -- -Winline and the error is reported by the backend. 4247 4248 else 4249 null; 4250 end if; 4251 end Cannot_Inline; 4252 4253 ------------------------------------ 4254 -- Check_And_Build_Body_To_Inline -- 4255 ------------------------------------ 4256 4257 procedure Check_And_Build_Body_To_Inline 4258 (N : Node_Id; 4259 Spec_Id : Entity_Id; 4260 Body_Id : Entity_Id) 4261 is 4262 procedure Build_Body_To_Inline (N : Node_Id; Spec_Id : Entity_Id); 4263 -- Use generic machinery to build an unexpanded body for the subprogram. 4264 -- This body is subsequently used for inline expansions at call sites. 4265 4266 function Can_Split_Unconstrained_Function (N : Node_Id) return Boolean; 4267 -- Return true if we generate code for the function body N, the function 4268 -- body N has no local declarations and its unique statement is a single 4269 -- extended return statement with a handled statements sequence. 4270 4271 function Check_Body_To_Inline 4272 (N : Node_Id; 4273 Subp : Entity_Id) return Boolean; 4274 -- N is the N_Subprogram_Body of Subp. Return true if Subp can be 4275 -- inlined by the frontend. These are the rules: 4276 -- * At -O0 use fe inlining when inline_always is specified except if 4277 -- the function returns a controlled type. 4278 -- * At other optimization levels use the fe inlining for both inline 4279 -- and inline_always in the following cases: 4280 -- - function returning a known at compile time constant 4281 -- - function returning a call to an intrinsic function 4282 -- - function returning an unconstrained type (see Can_Split 4283 -- Unconstrained_Function). 4284 -- - function returning a call to a frontend-inlined function 4285 -- Use the back-end mechanism otherwise 4286 -- 4287 -- In addition, in the following cases the function cannot be inlined by 4288 -- the frontend: 4289 -- - functions that uses the secondary stack 4290 -- - functions that have declarations of: 4291 -- - Concurrent types 4292 -- - Packages 4293 -- - Instantiations 4294 -- - Subprograms 4295 -- - functions that have some of the following statements: 4296 -- - abort 4297 -- - asynchronous-select 4298 -- - conditional-entry-call 4299 -- - delay-relative 4300 -- - delay-until 4301 -- - selective-accept 4302 -- - timed-entry-call 4303 -- - functions that have exception handlers 4304 -- - functions that have some enclosing body containing instantiations 4305 -- that appear before the corresponding generic body. 4306 4307 procedure Generate_Body_To_Inline 4308 (N : Node_Id; 4309 Body_To_Inline : out Node_Id); 4310 -- Generate a parameterless duplicate of subprogram body N. Occurrences 4311 -- of pragmas referencing the formals are removed since they have no 4312 -- meaning when the body is inlined and the formals are rewritten (the 4313 -- analysis of the non-inlined body will handle these pragmas properly). 4314 -- A new internal name is associated with Body_To_Inline. 4315 4316 procedure Split_Unconstrained_Function 4317 (N : Node_Id; 4318 Spec_Id : Entity_Id); 4319 -- N is an inlined function body that returns an unconstrained type and 4320 -- has a single extended return statement. Split N in two subprograms: 4321 -- a procedure P' and a function F'. The formals of P' duplicate the 4322 -- formals of N plus an extra formal which is used return a value; 4323 -- its body is composed by the declarations and list of statements 4324 -- of the extended return statement of N. 4325 4326 -------------------------- 4327 -- Build_Body_To_Inline -- 4328 -------------------------- 4329 4330 procedure Build_Body_To_Inline (N : Node_Id; Spec_Id : Entity_Id) is 4331 Decl : constant Node_Id := Unit_Declaration_Node (Spec_Id); 4332 Original_Body : Node_Id; 4333 Body_To_Analyze : Node_Id; 4334 4335 begin 4336 pragma Assert (Current_Scope = Spec_Id); 4337 4338 -- Within an instance, the body to inline must be treated as a nested 4339 -- generic, so that the proper global references are preserved. We 4340 -- do not do this at the library level, because it is not needed, and 4341 -- furthermore this causes trouble if front end inlining is activated 4342 -- (-gnatN). 4343 4344 if In_Instance 4345 and then Scope (Current_Scope) /= Standard_Standard 4346 then 4347 Save_Env (Scope (Current_Scope), Scope (Current_Scope)); 4348 end if; 4349 4350 -- We need to capture references to the formals in order 4351 -- to substitute the actuals at the point of inlining, i.e. 4352 -- instantiation. To treat the formals as globals to the body to 4353 -- inline, we nest it within a dummy parameterless subprogram, 4354 -- declared within the real one. 4355 4356 Generate_Body_To_Inline (N, Original_Body); 4357 Body_To_Analyze := Copy_Generic_Node (Original_Body, Empty, False); 4358 4359 -- Set return type of function, which is also global and does not 4360 -- need to be resolved. 4361 4362 if Ekind (Spec_Id) = E_Function then 4363 Set_Result_Definition (Specification (Body_To_Analyze), 4364 New_Occurrence_Of (Etype (Spec_Id), Sloc (N))); 4365 end if; 4366 4367 if No (Declarations (N)) then 4368 Set_Declarations (N, New_List (Body_To_Analyze)); 4369 else 4370 Append_To (Declarations (N), Body_To_Analyze); 4371 end if; 4372 4373 Preanalyze (Body_To_Analyze); 4374 4375 Push_Scope (Defining_Entity (Body_To_Analyze)); 4376 Save_Global_References (Original_Body); 4377 End_Scope; 4378 Remove (Body_To_Analyze); 4379 4380 -- Restore environment if previously saved 4381 4382 if In_Instance 4383 and then Scope (Current_Scope) /= Standard_Standard 4384 then 4385 Restore_Env; 4386 end if; 4387 4388 pragma Assert (No (Body_To_Inline (Decl))); 4389 Set_Body_To_Inline (Decl, Original_Body); 4390 Set_Ekind (Defining_Entity (Original_Body), Ekind (Spec_Id)); 4391 end Build_Body_To_Inline; 4392 4393 -------------------------- 4394 -- Check_Body_To_Inline -- 4395 -------------------------- 4396 4397 function Check_Body_To_Inline 4398 (N : Node_Id; 4399 Subp : Entity_Id) return Boolean 4400 is 4401 Max_Size : constant := 10; 4402 Stat_Count : Integer := 0; 4403 4404 function Has_Excluded_Declaration (Decls : List_Id) return Boolean; 4405 -- Check for declarations that make inlining not worthwhile 4406 4407 function Has_Excluded_Statement (Stats : List_Id) return Boolean; 4408 -- Check for statements that make inlining not worthwhile: any 4409 -- tasking statement, nested at any level. Keep track of total 4410 -- number of elementary statements, as a measure of acceptable size. 4411 4412 function Has_Pending_Instantiation return Boolean; 4413 -- Return True if some enclosing body contains instantiations that 4414 -- appear before the corresponding generic body. 4415 4416 function Returns_Compile_Time_Constant (N : Node_Id) return Boolean; 4417 -- Return True if all the return statements of the function body N 4418 -- are simple return statements and return a compile time constant 4419 4420 function Returns_Intrinsic_Function_Call (N : Node_Id) return Boolean; 4421 -- Return True if all the return statements of the function body N 4422 -- are simple return statements and return an intrinsic function call 4423 4424 function Uses_Secondary_Stack (N : Node_Id) return Boolean; 4425 -- If the body of the subprogram includes a call that returns an 4426 -- unconstrained type, the secondary stack is involved, and it 4427 -- is not worth inlining. 4428 4429 ------------------------------ 4430 -- Has_Excluded_Declaration -- 4431 ------------------------------ 4432 4433 function Has_Excluded_Declaration (Decls : List_Id) return Boolean is 4434 D : Node_Id; 4435 4436 function Is_Unchecked_Conversion (D : Node_Id) return Boolean; 4437 -- Nested subprograms make a given body ineligible for inlining, 4438 -- but we make an exception for instantiations of unchecked 4439 -- conversion. The body has not been analyzed yet, so check the 4440 -- name, and verify that the visible entity with that name is the 4441 -- predefined unit. 4442 4443 ----------------------------- 4444 -- Is_Unchecked_Conversion -- 4445 ----------------------------- 4446 4447 function Is_Unchecked_Conversion (D : Node_Id) return Boolean is 4448 Id : constant Node_Id := Name (D); 4449 Conv : Entity_Id; 4450 4451 begin 4452 if Nkind (Id) = N_Identifier 4453 and then Chars (Id) = Name_Unchecked_Conversion 4454 then 4455 Conv := Current_Entity (Id); 4456 4457 elsif Nkind_In (Id, N_Selected_Component, N_Expanded_Name) 4458 and then Chars (Selector_Name (Id)) 4459 = Name_Unchecked_Conversion 4460 then 4461 Conv := Current_Entity (Selector_Name (Id)); 4462 else 4463 return False; 4464 end if; 4465 4466 return Present (Conv) 4467 and then Is_Predefined_File_Name 4468 (Unit_File_Name (Get_Source_Unit (Conv))) 4469 and then Is_Intrinsic_Subprogram (Conv); 4470 end Is_Unchecked_Conversion; 4471 4472 -- Start of processing for Has_Excluded_Declaration 4473 4474 begin 4475 D := First (Decls); 4476 while Present (D) loop 4477 if (Nkind (D) = N_Function_Instantiation 4478 and then not Is_Unchecked_Conversion (D)) 4479 or else Nkind_In (D, N_Protected_Type_Declaration, 4480 N_Package_Declaration, 4481 N_Package_Instantiation, 4482 N_Subprogram_Body, 4483 N_Procedure_Instantiation, 4484 N_Task_Type_Declaration) 4485 then 4486 Cannot_Inline 4487 ("cannot inline & (non-allowed declaration)?", D, Subp); 4488 4489 return True; 4490 end if; 4491 4492 Next (D); 4493 end loop; 4494 4495 return False; 4496 end Has_Excluded_Declaration; 4497 4498 ---------------------------- 4499 -- Has_Excluded_Statement -- 4500 ---------------------------- 4501 4502 function Has_Excluded_Statement (Stats : List_Id) return Boolean is 4503 S : Node_Id; 4504 E : Node_Id; 4505 4506 begin 4507 S := First (Stats); 4508 while Present (S) loop 4509 Stat_Count := Stat_Count + 1; 4510 4511 if Nkind_In (S, N_Abort_Statement, 4512 N_Asynchronous_Select, 4513 N_Conditional_Entry_Call, 4514 N_Delay_Relative_Statement, 4515 N_Delay_Until_Statement, 4516 N_Selective_Accept, 4517 N_Timed_Entry_Call) 4518 then 4519 Cannot_Inline 4520 ("cannot inline & (non-allowed statement)?", S, Subp); 4521 return True; 4522 4523 elsif Nkind (S) = N_Block_Statement then 4524 if Present (Declarations (S)) 4525 and then Has_Excluded_Declaration (Declarations (S)) 4526 then 4527 return True; 4528 4529 elsif Present (Handled_Statement_Sequence (S)) then 4530 if Present 4531 (Exception_Handlers (Handled_Statement_Sequence (S))) 4532 then 4533 Cannot_Inline 4534 ("cannot inline& (exception handler)?", 4535 First (Exception_Handlers 4536 (Handled_Statement_Sequence (S))), 4537 Subp); 4538 return True; 4539 4540 elsif Has_Excluded_Statement 4541 (Statements (Handled_Statement_Sequence (S))) 4542 then 4543 return True; 4544 end if; 4545 end if; 4546 4547 elsif Nkind (S) = N_Case_Statement then 4548 E := First (Alternatives (S)); 4549 while Present (E) loop 4550 if Has_Excluded_Statement (Statements (E)) then 4551 return True; 4552 end if; 4553 4554 Next (E); 4555 end loop; 4556 4557 elsif Nkind (S) = N_If_Statement then 4558 if Has_Excluded_Statement (Then_Statements (S)) then 4559 return True; 4560 end if; 4561 4562 if Present (Elsif_Parts (S)) then 4563 E := First (Elsif_Parts (S)); 4564 while Present (E) loop 4565 if Has_Excluded_Statement (Then_Statements (E)) then 4566 return True; 4567 end if; 4568 Next (E); 4569 end loop; 4570 end if; 4571 4572 if Present (Else_Statements (S)) 4573 and then Has_Excluded_Statement (Else_Statements (S)) 4574 then 4575 return True; 4576 end if; 4577 4578 elsif Nkind (S) = N_Loop_Statement 4579 and then Has_Excluded_Statement (Statements (S)) 4580 then 4581 return True; 4582 4583 elsif Nkind (S) = N_Extended_Return_Statement then 4584 if Present (Handled_Statement_Sequence (S)) 4585 and then 4586 Has_Excluded_Statement 4587 (Statements (Handled_Statement_Sequence (S))) 4588 then 4589 return True; 4590 4591 elsif Present (Handled_Statement_Sequence (S)) 4592 and then 4593 Present (Exception_Handlers 4594 (Handled_Statement_Sequence (S))) 4595 then 4596 Cannot_Inline 4597 ("cannot inline& (exception handler)?", 4598 First (Exception_Handlers 4599 (Handled_Statement_Sequence (S))), 4600 Subp); 4601 return True; 4602 end if; 4603 end if; 4604 4605 Next (S); 4606 end loop; 4607 4608 return False; 4609 end Has_Excluded_Statement; 4610 4611 ------------------------------- 4612 -- Has_Pending_Instantiation -- 4613 ------------------------------- 4614 4615 function Has_Pending_Instantiation return Boolean is 4616 S : Entity_Id; 4617 4618 begin 4619 S := Current_Scope; 4620 while Present (S) loop 4621 if Is_Compilation_Unit (S) 4622 or else Is_Child_Unit (S) 4623 then 4624 return False; 4625 4626 elsif Ekind (S) = E_Package 4627 and then Has_Forward_Instantiation (S) 4628 then 4629 return True; 4630 end if; 4631 4632 S := Scope (S); 4633 end loop; 4634 4635 return False; 4636 end Has_Pending_Instantiation; 4637 4638 ------------------------------------ 4639 -- Returns_Compile_Time_Constant -- 4640 ------------------------------------ 4641 4642 function Returns_Compile_Time_Constant (N : Node_Id) return Boolean is 4643 4644 function Check_Return (N : Node_Id) return Traverse_Result; 4645 4646 ------------------ 4647 -- Check_Return -- 4648 ------------------ 4649 4650 function Check_Return (N : Node_Id) return Traverse_Result is 4651 begin 4652 if Nkind (N) = N_Extended_Return_Statement then 4653 return Abandon; 4654 4655 elsif Nkind (N) = N_Simple_Return_Statement then 4656 if Present (Expression (N)) then 4657 declare 4658 Orig_Expr : constant Node_Id := 4659 Original_Node (Expression (N)); 4660 4661 begin 4662 if Nkind_In (Orig_Expr, N_Integer_Literal, 4663 N_Real_Literal, 4664 N_Character_Literal) 4665 then 4666 return OK; 4667 4668 elsif Is_Entity_Name (Orig_Expr) 4669 and then Ekind (Entity (Orig_Expr)) = E_Constant 4670 and then Is_Static_Expression (Orig_Expr) 4671 then 4672 return OK; 4673 else 4674 return Abandon; 4675 end if; 4676 end; 4677 4678 -- Expression has wrong form 4679 4680 else 4681 return Abandon; 4682 end if; 4683 4684 -- Continue analyzing statements 4685 4686 else 4687 return OK; 4688 end if; 4689 end Check_Return; 4690 4691 function Check_All_Returns is new Traverse_Func (Check_Return); 4692 4693 -- Start of processing for Returns_Compile_Time_Constant 4694 4695 begin 4696 return Check_All_Returns (N) = OK; 4697 end Returns_Compile_Time_Constant; 4698 4699 -------------------------------------- 4700 -- Returns_Intrinsic_Function_Call -- 4701 -------------------------------------- 4702 4703 function Returns_Intrinsic_Function_Call 4704 (N : Node_Id) return Boolean 4705 is 4706 function Check_Return (N : Node_Id) return Traverse_Result; 4707 4708 ------------------ 4709 -- Check_Return -- 4710 ------------------ 4711 4712 function Check_Return (N : Node_Id) return Traverse_Result is 4713 begin 4714 if Nkind (N) = N_Extended_Return_Statement then 4715 return Abandon; 4716 4717 elsif Nkind (N) = N_Simple_Return_Statement then 4718 if Present (Expression (N)) then 4719 declare 4720 Orig_Expr : constant Node_Id := 4721 Original_Node (Expression (N)); 4722 4723 begin 4724 if Nkind (Orig_Expr) in N_Op 4725 and then Is_Intrinsic_Subprogram (Entity (Orig_Expr)) 4726 then 4727 return OK; 4728 4729 elsif Nkind (Orig_Expr) in N_Has_Entity 4730 and then Present (Entity (Orig_Expr)) 4731 and then Ekind (Entity (Orig_Expr)) = E_Function 4732 and then Is_Inlined (Entity (Orig_Expr)) 4733 then 4734 return OK; 4735 4736 elsif Nkind (Orig_Expr) in N_Has_Entity 4737 and then Present (Entity (Orig_Expr)) 4738 and then Is_Intrinsic_Subprogram (Entity (Orig_Expr)) 4739 then 4740 return OK; 4741 4742 else 4743 return Abandon; 4744 end if; 4745 end; 4746 4747 -- Expression has wrong form 4748 4749 else 4750 return Abandon; 4751 end if; 4752 4753 -- Continue analyzing statements 4754 4755 else 4756 return OK; 4757 end if; 4758 end Check_Return; 4759 4760 function Check_All_Returns is new Traverse_Func (Check_Return); 4761 4762 -- Start of processing for Returns_Intrinsic_Function_Call 4763 4764 begin 4765 return Check_All_Returns (N) = OK; 4766 end Returns_Intrinsic_Function_Call; 4767 4768 -------------------------- 4769 -- Uses_Secondary_Stack -- 4770 -------------------------- 4771 4772 function Uses_Secondary_Stack (N : Node_Id) return Boolean is 4773 4774 function Check_Call (N : Node_Id) return Traverse_Result; 4775 -- Look for function calls that return an unconstrained type 4776 4777 ---------------- 4778 -- Check_Call -- 4779 ---------------- 4780 4781 function Check_Call (N : Node_Id) return Traverse_Result is 4782 begin 4783 if Nkind (N) = N_Function_Call 4784 and then Is_Entity_Name (Name (N)) 4785 and then Is_Composite_Type (Etype (Entity (Name (N)))) 4786 and then not Is_Constrained (Etype (Entity (Name (N)))) 4787 then 4788 Cannot_Inline 4789 ("cannot inline & (call returns unconstrained type)?", 4790 N, Subp); 4791 4792 return Abandon; 4793 else 4794 return OK; 4795 end if; 4796 end Check_Call; 4797 4798 function Check_Calls is new Traverse_Func (Check_Call); 4799 4800 -- Start of processing for Uses_Secondary_Stack 4801 4802 begin 4803 return Check_Calls (N) = Abandon; 4804 end Uses_Secondary_Stack; 4805 4806 -- Local variables 4807 4808 Decl : constant Node_Id := Unit_Declaration_Node (Spec_Id); 4809 May_Inline : constant Boolean := 4810 Has_Pragma_Inline_Always (Spec_Id) 4811 or else (Has_Pragma_Inline (Spec_Id) 4812 and then ((Optimization_Level > 0 4813 and then Ekind (Spec_Id) 4814 = E_Function) 4815 or else Front_End_Inlining)); 4816 Body_To_Analyze : Node_Id; 4817 4818 -- Start of processing for Check_Body_To_Inline 4819 4820 begin 4821 -- No action needed in stubs since the attribute Body_To_Inline 4822 -- is not available 4823 4824 if Nkind (Decl) = N_Subprogram_Body_Stub then 4825 return False; 4826 4827 -- Cannot build the body to inline if the attribute is already set. 4828 -- This attribute may have been set if this is a subprogram renaming 4829 -- declarations (see Freeze.Build_Renamed_Body). 4830 4831 elsif Present (Body_To_Inline (Decl)) then 4832 return False; 4833 4834 -- No action needed if the subprogram does not fulfill the minimum 4835 -- conditions to be inlined by the frontend 4836 4837 elsif not May_Inline then 4838 return False; 4839 end if; 4840 4841 -- Check excluded declarations 4842 4843 if Present (Declarations (N)) 4844 and then Has_Excluded_Declaration (Declarations (N)) 4845 then 4846 return False; 4847 end if; 4848 4849 -- Check excluded statements 4850 4851 if Present (Handled_Statement_Sequence (N)) then 4852 if Present 4853 (Exception_Handlers (Handled_Statement_Sequence (N))) 4854 then 4855 Cannot_Inline 4856 ("cannot inline& (exception handler)?", 4857 First 4858 (Exception_Handlers (Handled_Statement_Sequence (N))), 4859 Subp); 4860 4861 return False; 4862 4863 elsif Has_Excluded_Statement 4864 (Statements (Handled_Statement_Sequence (N))) 4865 then 4866 return False; 4867 end if; 4868 end if; 4869 4870 -- For backward compatibility, compiling under -gnatN we do not 4871 -- inline a subprogram that is too large, unless it is marked 4872 -- Inline_Always. This pragma does not suppress the other checks 4873 -- on inlining (forbidden declarations, handlers, etc). 4874 4875 if Front_End_Inlining 4876 and then not Has_Pragma_Inline_Always (Subp) 4877 and then Stat_Count > Max_Size 4878 then 4879 Cannot_Inline ("cannot inline& (body too large)?", N, Subp); 4880 return False; 4881 end if; 4882 4883 -- If some enclosing body contains instantiations that appear before 4884 -- the corresponding generic body, the enclosing body has a freeze 4885 -- node so that it can be elaborated after the generic itself. This 4886 -- might conflict with subsequent inlinings, so that it is unsafe to 4887 -- try to inline in such a case. 4888 4889 if Has_Pending_Instantiation then 4890 Cannot_Inline 4891 ("cannot inline& (forward instance within enclosing body)?", 4892 N, Subp); 4893 4894 return False; 4895 end if; 4896 4897 -- Generate and preanalyze the body to inline (needed to perform 4898 -- the rest of the checks) 4899 4900 Generate_Body_To_Inline (N, Body_To_Analyze); 4901 4902 if Ekind (Subp) = E_Function then 4903 Set_Result_Definition (Specification (Body_To_Analyze), 4904 New_Occurrence_Of (Etype (Subp), Sloc (N))); 4905 end if; 4906 4907 -- Nest the body to analyze within the real one 4908 4909 if No (Declarations (N)) then 4910 Set_Declarations (N, New_List (Body_To_Analyze)); 4911 else 4912 Append_To (Declarations (N), Body_To_Analyze); 4913 end if; 4914 4915 Preanalyze (Body_To_Analyze); 4916 Remove (Body_To_Analyze); 4917 4918 -- Keep separate checks needed when compiling without optimizations 4919 4920 if Optimization_Level = 0 4921 4922 -- AAMP and VM targets have no support for inlining in the backend 4923 -- and hence we use frontend inlining at all optimization levels. 4924 4925 or else AAMP_On_Target 4926 or else VM_Target /= No_VM 4927 then 4928 -- Cannot inline functions whose body has a call that returns an 4929 -- unconstrained type since the secondary stack is involved, and 4930 -- it is not worth inlining. 4931 4932 if Uses_Secondary_Stack (Body_To_Analyze) then 4933 return False; 4934 4935 -- Cannot inline functions that return controlled types since 4936 -- controlled actions interfere in complex ways with inlining. 4937 4938 elsif Ekind (Subp) = E_Function 4939 and then Needs_Finalization (Etype (Subp)) 4940 then 4941 Cannot_Inline 4942 ("cannot inline & (controlled return type)?", N, Subp); 4943 return False; 4944 4945 elsif Returns_Unconstrained_Type (Subp) then 4946 Cannot_Inline 4947 ("cannot inline & (unconstrained return type)?", N, Subp); 4948 return False; 4949 end if; 4950 4951 -- Compiling with optimizations enabled 4952 4953 else 4954 -- Procedures are never frontend inlined in this case! 4955 4956 if Ekind (Subp) /= E_Function then 4957 return False; 4958 4959 -- Functions returning unconstrained types are tested 4960 -- separately (see Can_Split_Unconstrained_Function). 4961 4962 elsif Returns_Unconstrained_Type (Subp) then 4963 null; 4964 4965 -- Check supported cases 4966 4967 elsif not Returns_Compile_Time_Constant (Body_To_Analyze) 4968 and then Convention (Subp) /= Convention_Intrinsic 4969 and then not Returns_Intrinsic_Function_Call (Body_To_Analyze) 4970 then 4971 return False; 4972 end if; 4973 end if; 4974 4975 return True; 4976 end Check_Body_To_Inline; 4977 4978 -------------------------------------- 4979 -- Can_Split_Unconstrained_Function -- 4980 -------------------------------------- 4981 4982 function Can_Split_Unconstrained_Function (N : Node_Id) return Boolean 4983 is 4984 Ret_Node : constant Node_Id := 4985 First (Statements (Handled_Statement_Sequence (N))); 4986 D : Node_Id; 4987 4988 begin 4989 -- No user defined declarations allowed in the function except inside 4990 -- the unique return statement; implicit labels are the only allowed 4991 -- declarations. 4992 4993 if not Is_Empty_List (Declarations (N)) then 4994 D := First (Declarations (N)); 4995 while Present (D) loop 4996 if Nkind (D) /= N_Implicit_Label_Declaration then 4997 return False; 4998 end if; 4999 5000 Next (D); 5001 end loop; 5002 end if; 5003 5004 -- We only split the inlined function when we are generating the code 5005 -- of its body; otherwise we leave duplicated split subprograms in 5006 -- the tree which (if referenced) generate wrong references at link 5007 -- time. 5008 5009 return In_Extended_Main_Code_Unit (N) 5010 and then Present (Ret_Node) 5011 and then Nkind (Ret_Node) = N_Extended_Return_Statement 5012 and then No (Next (Ret_Node)) 5013 and then Present (Handled_Statement_Sequence (Ret_Node)); 5014 end Can_Split_Unconstrained_Function; 5015 5016 ----------------------------- 5017 -- Generate_Body_To_Inline -- 5018 ----------------------------- 5019 5020 procedure Generate_Body_To_Inline 5021 (N : Node_Id; 5022 Body_To_Inline : out Node_Id) 5023 is 5024 procedure Remove_Pragmas (N : Node_Id); 5025 -- Remove occurrences of pragmas that may reference the formals of 5026 -- N. The analysis of the non-inlined body will handle these pragmas 5027 -- properly. 5028 5029 -------------------- 5030 -- Remove_Pragmas -- 5031 -------------------- 5032 5033 procedure Remove_Pragmas (N : Node_Id) is 5034 Decl : Node_Id; 5035 Nxt : Node_Id; 5036 5037 begin 5038 Decl := First (Declarations (N)); 5039 while Present (Decl) loop 5040 Nxt := Next (Decl); 5041 5042 if Nkind (Decl) = N_Pragma 5043 and then (Pragma_Name (Decl) = Name_Unreferenced 5044 or else 5045 Pragma_Name (Decl) = Name_Unmodified) 5046 then 5047 Remove (Decl); 5048 end if; 5049 5050 Decl := Nxt; 5051 end loop; 5052 end Remove_Pragmas; 5053 5054 -- Start of processing for Generate_Body_To_Inline 5055 5056 begin 5057 -- Within an instance, the body to inline must be treated as a nested 5058 -- generic, so that the proper global references are preserved. 5059 5060 -- Note that we do not do this at the library level, because it 5061 -- is not needed, and furthermore this causes trouble if front 5062 -- end inlining is activated (-gnatN). 5063 5064 if In_Instance 5065 and then Scope (Current_Scope) /= Standard_Standard 5066 then 5067 Body_To_Inline := Copy_Generic_Node (N, Empty, True); 5068 else 5069 Body_To_Inline := Copy_Separate_Tree (N); 5070 end if; 5071 5072 -- A pragma Unreferenced or pragma Unmodified that mentions a formal 5073 -- parameter has no meaning when the body is inlined and the formals 5074 -- are rewritten. Remove it from body to inline. The analysis of the 5075 -- non-inlined body will handle the pragma properly. 5076 5077 Remove_Pragmas (Body_To_Inline); 5078 5079 -- We need to capture references to the formals in order 5080 -- to substitute the actuals at the point of inlining, i.e. 5081 -- instantiation. To treat the formals as globals to the body to 5082 -- inline, we nest it within a dummy parameterless subprogram, 5083 -- declared within the real one. 5084 5085 Set_Parameter_Specifications 5086 (Specification (Body_To_Inline), No_List); 5087 5088 -- A new internal name is associated with Body_To_Inline to avoid 5089 -- conflicts when the non-inlined body N is analyzed. 5090 5091 Set_Defining_Unit_Name (Specification (Body_To_Inline), 5092 Make_Defining_Identifier (Sloc (N), New_Internal_Name ('P'))); 5093 Set_Corresponding_Spec (Body_To_Inline, Empty); 5094 end Generate_Body_To_Inline; 5095 5096 ---------------------------------- 5097 -- Split_Unconstrained_Function -- 5098 ---------------------------------- 5099 5100 procedure Split_Unconstrained_Function 5101 (N : Node_Id; 5102 Spec_Id : Entity_Id) 5103 is 5104 Loc : constant Source_Ptr := Sloc (N); 5105 Ret_Node : constant Node_Id := 5106 First (Statements (Handled_Statement_Sequence (N))); 5107 Ret_Obj : constant Node_Id := 5108 First (Return_Object_Declarations (Ret_Node)); 5109 5110 procedure Build_Procedure 5111 (Proc_Id : out Entity_Id; 5112 Decl_List : out List_Id); 5113 -- Build a procedure containing the statements found in the extended 5114 -- return statement of the unconstrained function body N. 5115 5116 procedure Build_Procedure 5117 (Proc_Id : out Entity_Id; 5118 Decl_List : out List_Id) 5119 is 5120 Formal : Entity_Id; 5121 Formal_List : constant List_Id := New_List; 5122 Proc_Spec : Node_Id; 5123 Proc_Body : Node_Id; 5124 Subp_Name : constant Name_Id := New_Internal_Name ('F'); 5125 Body_Decl_List : List_Id := No_List; 5126 Param_Type : Node_Id; 5127 5128 begin 5129 if Nkind (Object_Definition (Ret_Obj)) = N_Identifier then 5130 Param_Type := New_Copy (Object_Definition (Ret_Obj)); 5131 else 5132 Param_Type := 5133 New_Copy (Subtype_Mark (Object_Definition (Ret_Obj))); 5134 end if; 5135 5136 Append_To (Formal_List, 5137 Make_Parameter_Specification (Loc, 5138 Defining_Identifier => 5139 Make_Defining_Identifier (Loc, 5140 Chars => Chars (Defining_Identifier (Ret_Obj))), 5141 In_Present => False, 5142 Out_Present => True, 5143 Null_Exclusion_Present => False, 5144 Parameter_Type => Param_Type)); 5145 5146 Formal := First_Formal (Spec_Id); 5147 while Present (Formal) loop 5148 Append_To (Formal_List, 5149 Make_Parameter_Specification (Loc, 5150 Defining_Identifier => 5151 Make_Defining_Identifier (Sloc (Formal), 5152 Chars => Chars (Formal)), 5153 In_Present => In_Present (Parent (Formal)), 5154 Out_Present => Out_Present (Parent (Formal)), 5155 Null_Exclusion_Present => 5156 Null_Exclusion_Present (Parent (Formal)), 5157 Parameter_Type => 5158 New_Reference_To (Etype (Formal), Loc), 5159 Expression => 5160 Copy_Separate_Tree (Expression (Parent (Formal))))); 5161 5162 Next_Formal (Formal); 5163 end loop; 5164 5165 Proc_Id := 5166 Make_Defining_Identifier (Loc, Chars => Subp_Name); 5167 5168 Proc_Spec := 5169 Make_Procedure_Specification (Loc, 5170 Defining_Unit_Name => Proc_Id, 5171 Parameter_Specifications => Formal_List); 5172 5173 Decl_List := New_List; 5174 5175 Append_To (Decl_List, 5176 Make_Subprogram_Declaration (Loc, Proc_Spec)); 5177 5178 -- Can_Convert_Unconstrained_Function checked that the function 5179 -- has no local declarations except implicit label declarations. 5180 -- Copy these declarations to the built procedure. 5181 5182 if Present (Declarations (N)) then 5183 Body_Decl_List := New_List; 5184 5185 declare 5186 D : Node_Id; 5187 New_D : Node_Id; 5188 5189 begin 5190 D := First (Declarations (N)); 5191 while Present (D) loop 5192 pragma Assert (Nkind (D) = N_Implicit_Label_Declaration); 5193 5194 New_D := 5195 Make_Implicit_Label_Declaration (Loc, 5196 Make_Defining_Identifier (Loc, 5197 Chars => Chars (Defining_Identifier (D))), 5198 Label_Construct => Empty); 5199 Append_To (Body_Decl_List, New_D); 5200 5201 Next (D); 5202 end loop; 5203 end; 5204 end if; 5205 5206 pragma Assert (Present (Handled_Statement_Sequence (Ret_Node))); 5207 5208 Proc_Body := 5209 Make_Subprogram_Body (Loc, 5210 Specification => Copy_Separate_Tree (Proc_Spec), 5211 Declarations => Body_Decl_List, 5212 Handled_Statement_Sequence => 5213 Copy_Separate_Tree (Handled_Statement_Sequence (Ret_Node))); 5214 5215 Set_Defining_Unit_Name (Specification (Proc_Body), 5216 Make_Defining_Identifier (Loc, Subp_Name)); 5217 5218 Append_To (Decl_List, Proc_Body); 5219 end Build_Procedure; 5220 5221 -- Local variables 5222 5223 New_Obj : constant Node_Id := Copy_Separate_Tree (Ret_Obj); 5224 Blk_Stmt : Node_Id; 5225 Proc_Id : Entity_Id; 5226 Proc_Call : Node_Id; 5227 5228 -- Start of processing for Split_Unconstrained_Function 5229 5230 begin 5231 -- Build the associated procedure, analyze it and insert it before 5232 -- the function body N 5233 5234 declare 5235 Scope : constant Entity_Id := Current_Scope; 5236 Decl_List : List_Id; 5237 begin 5238 Pop_Scope; 5239 Build_Procedure (Proc_Id, Decl_List); 5240 Insert_Actions (N, Decl_List); 5241 Push_Scope (Scope); 5242 end; 5243 5244 -- Build the call to the generated procedure 5245 5246 declare 5247 Actual_List : constant List_Id := New_List; 5248 Formal : Entity_Id; 5249 5250 begin 5251 Append_To (Actual_List, 5252 New_Reference_To (Defining_Identifier (New_Obj), Loc)); 5253 5254 Formal := First_Formal (Spec_Id); 5255 while Present (Formal) loop 5256 Append_To (Actual_List, New_Reference_To (Formal, Loc)); 5257 5258 -- Avoid spurious warning on unreferenced formals 5259 5260 Set_Referenced (Formal); 5261 Next_Formal (Formal); 5262 end loop; 5263 5264 Proc_Call := 5265 Make_Procedure_Call_Statement (Loc, 5266 Name => New_Reference_To (Proc_Id, Loc), 5267 Parameter_Associations => Actual_List); 5268 end; 5269 5270 -- Generate 5271 5272 -- declare 5273 -- New_Obj : ... 5274 -- begin 5275 -- main_1__F1b (New_Obj, ...); 5276 -- return Obj; 5277 -- end B10b; 5278 5279 Blk_Stmt := 5280 Make_Block_Statement (Loc, 5281 Declarations => New_List (New_Obj), 5282 Handled_Statement_Sequence => 5283 Make_Handled_Sequence_Of_Statements (Loc, 5284 Statements => New_List ( 5285 5286 Proc_Call, 5287 5288 Make_Simple_Return_Statement (Loc, 5289 Expression => 5290 New_Reference_To 5291 (Defining_Identifier (New_Obj), Loc))))); 5292 5293 Rewrite (Ret_Node, Blk_Stmt); 5294 end Split_Unconstrained_Function; 5295 5296 -- Start of processing for Check_And_Build_Body_To_Inline 5297 5298 begin 5299 -- Do not inline any subprogram that contains nested subprograms, since 5300 -- the backend inlining circuit seems to generate uninitialized 5301 -- references in this case. We know this happens in the case of front 5302 -- end ZCX support, but it also appears it can happen in other cases as 5303 -- well. The backend often rejects attempts to inline in the case of 5304 -- nested procedures anyway, so little if anything is lost by this. 5305 -- Note that this is test is for the benefit of the back-end. There is 5306 -- a separate test for front-end inlining that also rejects nested 5307 -- subprograms. 5308 5309 -- Do not do this test if errors have been detected, because in some 5310 -- error cases, this code blows up, and we don't need it anyway if 5311 -- there have been errors, since we won't get to the linker anyway. 5312 5313 if Comes_From_Source (Body_Id) 5314 and then (Has_Pragma_Inline_Always (Spec_Id) 5315 or else Optimization_Level > 0) 5316 and then Serious_Errors_Detected = 0 5317 then 5318 declare 5319 P_Ent : Node_Id; 5320 5321 begin 5322 P_Ent := Body_Id; 5323 loop 5324 P_Ent := Scope (P_Ent); 5325 exit when No (P_Ent) or else P_Ent = Standard_Standard; 5326 5327 if Is_Subprogram (P_Ent) then 5328 Set_Is_Inlined (P_Ent, False); 5329 5330 if Comes_From_Source (P_Ent) 5331 and then Has_Pragma_Inline (P_Ent) 5332 then 5333 Cannot_Inline 5334 ("cannot inline& (nested subprogram)?", N, P_Ent, 5335 Is_Serious => True); 5336 end if; 5337 end if; 5338 end loop; 5339 end; 5340 end if; 5341 5342 -- Build the body to inline only if really needed! 5343 5344 if Check_Body_To_Inline (N, Spec_Id) 5345 and then Serious_Errors_Detected = 0 5346 then 5347 if Returns_Unconstrained_Type (Spec_Id) then 5348 if Can_Split_Unconstrained_Function (N) then 5349 Split_Unconstrained_Function (N, Spec_Id); 5350 Build_Body_To_Inline (N, Spec_Id); 5351 Set_Is_Inlined (Spec_Id); 5352 end if; 5353 else 5354 Build_Body_To_Inline (N, Spec_Id); 5355 Set_Is_Inlined (Spec_Id); 5356 end if; 5357 end if; 5358 end Check_And_Build_Body_To_Inline; 5359 5360 ----------------------- 5361 -- Check_Conformance -- 5362 ----------------------- 5363 5364 procedure Check_Conformance 5365 (New_Id : Entity_Id; 5366 Old_Id : Entity_Id; 5367 Ctype : Conformance_Type; 5368 Errmsg : Boolean; 5369 Conforms : out Boolean; 5370 Err_Loc : Node_Id := Empty; 5371 Get_Inst : Boolean := False; 5372 Skip_Controlling_Formals : Boolean := False) 5373 is 5374 procedure Conformance_Error (Msg : String; N : Node_Id := New_Id); 5375 -- Sets Conforms to False. If Errmsg is False, then that's all it does. 5376 -- If Errmsg is True, then processing continues to post an error message 5377 -- for conformance error on given node. Two messages are output. The 5378 -- first message points to the previous declaration with a general "no 5379 -- conformance" message. The second is the detailed reason, supplied as 5380 -- Msg. The parameter N provide information for a possible & insertion 5381 -- in the message, and also provides the location for posting the 5382 -- message in the absence of a specified Err_Loc location. 5383 5384 ----------------------- 5385 -- Conformance_Error -- 5386 ----------------------- 5387 5388 procedure Conformance_Error (Msg : String; N : Node_Id := New_Id) is 5389 Enode : Node_Id; 5390 5391 begin 5392 Conforms := False; 5393 5394 if Errmsg then 5395 if No (Err_Loc) then 5396 Enode := N; 5397 else 5398 Enode := Err_Loc; 5399 end if; 5400 5401 Error_Msg_Sloc := Sloc (Old_Id); 5402 5403 case Ctype is 5404 when Type_Conformant => 5405 Error_Msg_N -- CODEFIX 5406 ("not type conformant with declaration#!", Enode); 5407 5408 when Mode_Conformant => 5409 if Nkind (Parent (Old_Id)) = N_Full_Type_Declaration then 5410 Error_Msg_N 5411 ("not mode conformant with operation inherited#!", 5412 Enode); 5413 else 5414 Error_Msg_N 5415 ("not mode conformant with declaration#!", Enode); 5416 end if; 5417 5418 when Subtype_Conformant => 5419 if Nkind (Parent (Old_Id)) = N_Full_Type_Declaration then 5420 Error_Msg_N 5421 ("not subtype conformant with operation inherited#!", 5422 Enode); 5423 else 5424 Error_Msg_N 5425 ("not subtype conformant with declaration#!", Enode); 5426 end if; 5427 5428 when Fully_Conformant => 5429 if Nkind (Parent (Old_Id)) = N_Full_Type_Declaration then 5430 Error_Msg_N -- CODEFIX 5431 ("not fully conformant with operation inherited#!", 5432 Enode); 5433 else 5434 Error_Msg_N -- CODEFIX 5435 ("not fully conformant with declaration#!", Enode); 5436 end if; 5437 end case; 5438 5439 Error_Msg_NE (Msg, Enode, N); 5440 end if; 5441 end Conformance_Error; 5442 5443 -- Local Variables 5444 5445 Old_Type : constant Entity_Id := Etype (Old_Id); 5446 New_Type : constant Entity_Id := Etype (New_Id); 5447 Old_Formal : Entity_Id; 5448 New_Formal : Entity_Id; 5449 Access_Types_Match : Boolean; 5450 Old_Formal_Base : Entity_Id; 5451 New_Formal_Base : Entity_Id; 5452 5453 -- Start of processing for Check_Conformance 5454 5455 begin 5456 Conforms := True; 5457 5458 -- We need a special case for operators, since they don't appear 5459 -- explicitly. 5460 5461 if Ctype = Type_Conformant then 5462 if Ekind (New_Id) = E_Operator 5463 and then Operator_Matches_Spec (New_Id, Old_Id) 5464 then 5465 return; 5466 end if; 5467 end if; 5468 5469 -- If both are functions/operators, check return types conform 5470 5471 if Old_Type /= Standard_Void_Type 5472 and then New_Type /= Standard_Void_Type 5473 then 5474 5475 -- If we are checking interface conformance we omit controlling 5476 -- arguments and result, because we are only checking the conformance 5477 -- of the remaining parameters. 5478 5479 if Has_Controlling_Result (Old_Id) 5480 and then Has_Controlling_Result (New_Id) 5481 and then Skip_Controlling_Formals 5482 then 5483 null; 5484 5485 elsif not Conforming_Types (Old_Type, New_Type, Ctype, Get_Inst) then 5486 Conformance_Error ("\return type does not match!", New_Id); 5487 return; 5488 end if; 5489 5490 -- Ada 2005 (AI-231): In case of anonymous access types check the 5491 -- null-exclusion and access-to-constant attributes match. 5492 5493 if Ada_Version >= Ada_2005 5494 and then Ekind (Etype (Old_Type)) = E_Anonymous_Access_Type 5495 and then 5496 (Can_Never_Be_Null (Old_Type) 5497 /= Can_Never_Be_Null (New_Type) 5498 or else Is_Access_Constant (Etype (Old_Type)) 5499 /= Is_Access_Constant (Etype (New_Type))) 5500 then 5501 Conformance_Error ("\return type does not match!", New_Id); 5502 return; 5503 end if; 5504 5505 -- If either is a function/operator and the other isn't, error 5506 5507 elsif Old_Type /= Standard_Void_Type 5508 or else New_Type /= Standard_Void_Type 5509 then 5510 Conformance_Error ("\functions can only match functions!", New_Id); 5511 return; 5512 end if; 5513 5514 -- In subtype conformant case, conventions must match (RM 6.3.1(16)). 5515 -- If this is a renaming as body, refine error message to indicate that 5516 -- the conflict is with the original declaration. If the entity is not 5517 -- frozen, the conventions don't have to match, the one of the renamed 5518 -- entity is inherited. 5519 5520 if Ctype >= Subtype_Conformant then 5521 if Convention (Old_Id) /= Convention (New_Id) then 5522 5523 if not Is_Frozen (New_Id) then 5524 null; 5525 5526 elsif Present (Err_Loc) 5527 and then Nkind (Err_Loc) = N_Subprogram_Renaming_Declaration 5528 and then Present (Corresponding_Spec (Err_Loc)) 5529 then 5530 Error_Msg_Name_1 := Chars (New_Id); 5531 Error_Msg_Name_2 := 5532 Name_Ada + Convention_Id'Pos (Convention (New_Id)); 5533 Conformance_Error ("\prior declaration for% has convention %!"); 5534 5535 else 5536 Conformance_Error ("\calling conventions do not match!"); 5537 end if; 5538 5539 return; 5540 5541 elsif Is_Formal_Subprogram (Old_Id) 5542 or else Is_Formal_Subprogram (New_Id) 5543 then 5544 Conformance_Error ("\formal subprograms not allowed!"); 5545 return; 5546 end if; 5547 end if; 5548 5549 -- Deal with parameters 5550 5551 -- Note: we use the entity information, rather than going directly 5552 -- to the specification in the tree. This is not only simpler, but 5553 -- absolutely necessary for some cases of conformance tests between 5554 -- operators, where the declaration tree simply does not exist! 5555 5556 Old_Formal := First_Formal (Old_Id); 5557 New_Formal := First_Formal (New_Id); 5558 while Present (Old_Formal) and then Present (New_Formal) loop 5559 if Is_Controlling_Formal (Old_Formal) 5560 and then Is_Controlling_Formal (New_Formal) 5561 and then Skip_Controlling_Formals 5562 then 5563 -- The controlling formals will have different types when 5564 -- comparing an interface operation with its match, but both 5565 -- or neither must be access parameters. 5566 5567 if Is_Access_Type (Etype (Old_Formal)) 5568 = 5569 Is_Access_Type (Etype (New_Formal)) 5570 then 5571 goto Skip_Controlling_Formal; 5572 else 5573 Conformance_Error 5574 ("\access parameter does not match!", New_Formal); 5575 end if; 5576 end if; 5577 5578 -- Ada 2012: Mode conformance also requires that formal parameters 5579 -- be both aliased, or neither. 5580 5581 if Ctype >= Mode_Conformant and then Ada_Version >= Ada_2012 then 5582 if Is_Aliased (Old_Formal) /= Is_Aliased (New_Formal) then 5583 Conformance_Error 5584 ("\aliased parameter mismatch!", New_Formal); 5585 end if; 5586 end if; 5587 5588 if Ctype = Fully_Conformant then 5589 5590 -- Names must match. Error message is more accurate if we do 5591 -- this before checking that the types of the formals match. 5592 5593 if Chars (Old_Formal) /= Chars (New_Formal) then 5594 Conformance_Error ("\name & does not match!", New_Formal); 5595 5596 -- Set error posted flag on new formal as well to stop 5597 -- junk cascaded messages in some cases. 5598 5599 Set_Error_Posted (New_Formal); 5600 return; 5601 end if; 5602 5603 -- Null exclusion must match 5604 5605 if Null_Exclusion_Present (Parent (Old_Formal)) 5606 /= 5607 Null_Exclusion_Present (Parent (New_Formal)) 5608 then 5609 -- Only give error if both come from source. This should be 5610 -- investigated some time, since it should not be needed ??? 5611 5612 if Comes_From_Source (Old_Formal) 5613 and then 5614 Comes_From_Source (New_Formal) 5615 then 5616 Conformance_Error 5617 ("\null exclusion for & does not match", New_Formal); 5618 5619 -- Mark error posted on the new formal to avoid duplicated 5620 -- complaint about types not matching. 5621 5622 Set_Error_Posted (New_Formal); 5623 end if; 5624 end if; 5625 end if; 5626 5627 -- Ada 2005 (AI-423): Possible access [sub]type and itype match. This 5628 -- case occurs whenever a subprogram is being renamed and one of its 5629 -- parameters imposes a null exclusion. For example: 5630 5631 -- type T is null record; 5632 -- type Acc_T is access T; 5633 -- subtype Acc_T_Sub is Acc_T; 5634 5635 -- procedure P (Obj : not null Acc_T_Sub); -- itype 5636 -- procedure Ren_P (Obj : Acc_T_Sub) -- subtype 5637 -- renames P; 5638 5639 Old_Formal_Base := Etype (Old_Formal); 5640 New_Formal_Base := Etype (New_Formal); 5641 5642 if Get_Inst then 5643 Old_Formal_Base := Get_Instance_Of (Old_Formal_Base); 5644 New_Formal_Base := Get_Instance_Of (New_Formal_Base); 5645 end if; 5646 5647 Access_Types_Match := Ada_Version >= Ada_2005 5648 5649 -- Ensure that this rule is only applied when New_Id is a 5650 -- renaming of Old_Id. 5651 5652 and then Nkind (Parent (Parent (New_Id))) = 5653 N_Subprogram_Renaming_Declaration 5654 and then Nkind (Name (Parent (Parent (New_Id)))) in N_Has_Entity 5655 and then Present (Entity (Name (Parent (Parent (New_Id))))) 5656 and then Entity (Name (Parent (Parent (New_Id)))) = Old_Id 5657 5658 -- Now handle the allowed access-type case 5659 5660 and then Is_Access_Type (Old_Formal_Base) 5661 and then Is_Access_Type (New_Formal_Base) 5662 5663 -- The type kinds must match. The only exception occurs with 5664 -- multiple generics of the form: 5665 5666 -- generic generic 5667 -- type F is private; type A is private; 5668 -- type F_Ptr is access F; type A_Ptr is access A; 5669 -- with proc F_P (X : F_Ptr); with proc A_P (X : A_Ptr); 5670 -- package F_Pack is ... package A_Pack is 5671 -- package F_Inst is 5672 -- new F_Pack (A, A_Ptr, A_P); 5673 5674 -- When checking for conformance between the parameters of A_P 5675 -- and F_P, the type kinds of F_Ptr and A_Ptr will not match 5676 -- because the compiler has transformed A_Ptr into a subtype of 5677 -- F_Ptr. We catch this case in the code below. 5678 5679 and then (Ekind (Old_Formal_Base) = Ekind (New_Formal_Base) 5680 or else 5681 (Is_Generic_Type (Old_Formal_Base) 5682 and then Is_Generic_Type (New_Formal_Base) 5683 and then Is_Internal (New_Formal_Base) 5684 and then Etype (Etype (New_Formal_Base)) = 5685 Old_Formal_Base)) 5686 and then Directly_Designated_Type (Old_Formal_Base) = 5687 Directly_Designated_Type (New_Formal_Base) 5688 and then ((Is_Itype (Old_Formal_Base) 5689 and then Can_Never_Be_Null (Old_Formal_Base)) 5690 or else 5691 (Is_Itype (New_Formal_Base) 5692 and then Can_Never_Be_Null (New_Formal_Base))); 5693 5694 -- Types must always match. In the visible part of an instance, 5695 -- usual overloading rules for dispatching operations apply, and 5696 -- we check base types (not the actual subtypes). 5697 5698 if In_Instance_Visible_Part 5699 and then Is_Dispatching_Operation (New_Id) 5700 then 5701 if not Conforming_Types 5702 (T1 => Base_Type (Etype (Old_Formal)), 5703 T2 => Base_Type (Etype (New_Formal)), 5704 Ctype => Ctype, 5705 Get_Inst => Get_Inst) 5706 and then not Access_Types_Match 5707 then 5708 Conformance_Error ("\type of & does not match!", New_Formal); 5709 return; 5710 end if; 5711 5712 elsif not Conforming_Types 5713 (T1 => Old_Formal_Base, 5714 T2 => New_Formal_Base, 5715 Ctype => Ctype, 5716 Get_Inst => Get_Inst) 5717 and then not Access_Types_Match 5718 then 5719 -- Don't give error message if old type is Any_Type. This test 5720 -- avoids some cascaded errors, e.g. in case of a bad spec. 5721 5722 if Errmsg and then Old_Formal_Base = Any_Type then 5723 Conforms := False; 5724 else 5725 Conformance_Error ("\type of & does not match!", New_Formal); 5726 end if; 5727 5728 return; 5729 end if; 5730 5731 -- For mode conformance, mode must match 5732 5733 if Ctype >= Mode_Conformant then 5734 if Parameter_Mode (Old_Formal) /= Parameter_Mode (New_Formal) then 5735 if not Ekind_In (New_Id, E_Function, E_Procedure) 5736 or else not Is_Primitive_Wrapper (New_Id) 5737 then 5738 Conformance_Error ("\mode of & does not match!", New_Formal); 5739 5740 else 5741 declare 5742 T : constant Entity_Id := Find_Dispatching_Type (New_Id); 5743 begin 5744 if Is_Protected_Type 5745 (Corresponding_Concurrent_Type (T)) 5746 then 5747 Error_Msg_PT (T, New_Id); 5748 else 5749 Conformance_Error 5750 ("\mode of & does not match!", New_Formal); 5751 end if; 5752 end; 5753 end if; 5754 5755 return; 5756 5757 -- Part of mode conformance for access types is having the same 5758 -- constant modifier. 5759 5760 elsif Access_Types_Match 5761 and then Is_Access_Constant (Old_Formal_Base) /= 5762 Is_Access_Constant (New_Formal_Base) 5763 then 5764 Conformance_Error 5765 ("\constant modifier does not match!", New_Formal); 5766 return; 5767 end if; 5768 end if; 5769 5770 if Ctype >= Subtype_Conformant then 5771 5772 -- Ada 2005 (AI-231): In case of anonymous access types check 5773 -- the null-exclusion and access-to-constant attributes must 5774 -- match. For null exclusion, we test the types rather than the 5775 -- formals themselves, since the attribute is only set reliably 5776 -- on the formals in the Ada 95 case, and we exclude the case 5777 -- where Old_Formal is marked as controlling, to avoid errors 5778 -- when matching completing bodies with dispatching declarations 5779 -- (access formals in the bodies aren't marked Can_Never_Be_Null). 5780 5781 if Ada_Version >= Ada_2005 5782 and then Ekind (Etype (Old_Formal)) = E_Anonymous_Access_Type 5783 and then Ekind (Etype (New_Formal)) = E_Anonymous_Access_Type 5784 and then 5785 ((Can_Never_Be_Null (Etype (Old_Formal)) /= 5786 Can_Never_Be_Null (Etype (New_Formal)) 5787 and then 5788 not Is_Controlling_Formal (Old_Formal)) 5789 or else 5790 Is_Access_Constant (Etype (Old_Formal)) /= 5791 Is_Access_Constant (Etype (New_Formal))) 5792 5793 -- Do not complain if error already posted on New_Formal. This 5794 -- avoids some redundant error messages. 5795 5796 and then not Error_Posted (New_Formal) 5797 then 5798 -- It is allowed to omit the null-exclusion in case of stream 5799 -- attribute subprograms. We recognize stream subprograms 5800 -- through their TSS-generated suffix. 5801 5802 declare 5803 TSS_Name : constant TSS_Name_Type := Get_TSS_Name (New_Id); 5804 5805 begin 5806 if TSS_Name /= TSS_Stream_Read 5807 and then TSS_Name /= TSS_Stream_Write 5808 and then TSS_Name /= TSS_Stream_Input 5809 and then TSS_Name /= TSS_Stream_Output 5810 then 5811 -- Here we have a definite conformance error. It is worth 5812 -- special casing the error message for the case of a 5813 -- controlling formal (which excludes null). 5814 5815 if Is_Controlling_Formal (New_Formal) then 5816 Error_Msg_Node_2 := Scope (New_Formal); 5817 Conformance_Error 5818 ("\controlling formal& of& excludes null, " 5819 & "declaration must exclude null as well", 5820 New_Formal); 5821 5822 -- Normal case (couldn't we give more detail here???) 5823 5824 else 5825 Conformance_Error 5826 ("\type of & does not match!", New_Formal); 5827 end if; 5828 5829 return; 5830 end if; 5831 end; 5832 end if; 5833 end if; 5834 5835 -- Full conformance checks 5836 5837 if Ctype = Fully_Conformant then 5838 5839 -- We have checked already that names match 5840 5841 if Parameter_Mode (Old_Formal) = E_In_Parameter then 5842 5843 -- Check default expressions for in parameters 5844 5845 declare 5846 NewD : constant Boolean := 5847 Present (Default_Value (New_Formal)); 5848 OldD : constant Boolean := 5849 Present (Default_Value (Old_Formal)); 5850 begin 5851 if NewD or OldD then 5852 5853 -- The old default value has been analyzed because the 5854 -- current full declaration will have frozen everything 5855 -- before. The new default value has not been analyzed, 5856 -- so analyze it now before we check for conformance. 5857 5858 if NewD then 5859 Push_Scope (New_Id); 5860 Preanalyze_Spec_Expression 5861 (Default_Value (New_Formal), Etype (New_Formal)); 5862 End_Scope; 5863 end if; 5864 5865 if not (NewD and OldD) 5866 or else not Fully_Conformant_Expressions 5867 (Default_Value (Old_Formal), 5868 Default_Value (New_Formal)) 5869 then 5870 Conformance_Error 5871 ("\default expression for & does not match!", 5872 New_Formal); 5873 return; 5874 end if; 5875 end if; 5876 end; 5877 end if; 5878 end if; 5879 5880 -- A couple of special checks for Ada 83 mode. These checks are 5881 -- skipped if either entity is an operator in package Standard, 5882 -- or if either old or new instance is not from the source program. 5883 5884 if Ada_Version = Ada_83 5885 and then Sloc (Old_Id) > Standard_Location 5886 and then Sloc (New_Id) > Standard_Location 5887 and then Comes_From_Source (Old_Id) 5888 and then Comes_From_Source (New_Id) 5889 then 5890 declare 5891 Old_Param : constant Node_Id := Declaration_Node (Old_Formal); 5892 New_Param : constant Node_Id := Declaration_Node (New_Formal); 5893 5894 begin 5895 -- Explicit IN must be present or absent in both cases. This 5896 -- test is required only in the full conformance case. 5897 5898 if In_Present (Old_Param) /= In_Present (New_Param) 5899 and then Ctype = Fully_Conformant 5900 then 5901 Conformance_Error 5902 ("\(Ada 83) IN must appear in both declarations", 5903 New_Formal); 5904 return; 5905 end if; 5906 5907 -- Grouping (use of comma in param lists) must be the same 5908 -- This is where we catch a misconformance like: 5909 5910 -- A, B : Integer 5911 -- A : Integer; B : Integer 5912 5913 -- which are represented identically in the tree except 5914 -- for the setting of the flags More_Ids and Prev_Ids. 5915 5916 if More_Ids (Old_Param) /= More_Ids (New_Param) 5917 or else Prev_Ids (Old_Param) /= Prev_Ids (New_Param) 5918 then 5919 Conformance_Error 5920 ("\grouping of & does not match!", New_Formal); 5921 return; 5922 end if; 5923 end; 5924 end if; 5925 5926 -- This label is required when skipping controlling formals 5927 5928 <<Skip_Controlling_Formal>> 5929 5930 Next_Formal (Old_Formal); 5931 Next_Formal (New_Formal); 5932 end loop; 5933 5934 if Present (Old_Formal) then 5935 Conformance_Error ("\too few parameters!"); 5936 return; 5937 5938 elsif Present (New_Formal) then 5939 Conformance_Error ("\too many parameters!", New_Formal); 5940 return; 5941 end if; 5942 end Check_Conformance; 5943 5944 ----------------------- 5945 -- Check_Conventions -- 5946 ----------------------- 5947 5948 procedure Check_Conventions (Typ : Entity_Id) is 5949 Ifaces_List : Elist_Id; 5950 5951 procedure Check_Convention (Op : Entity_Id); 5952 -- Verify that the convention of inherited dispatching operation Op is 5953 -- consistent among all subprograms it overrides. In order to minimize 5954 -- the search, Search_From is utilized to designate a specific point in 5955 -- the list rather than iterating over the whole list once more. 5956 5957 ---------------------- 5958 -- Check_Convention -- 5959 ---------------------- 5960 5961 procedure Check_Convention (Op : Entity_Id) is 5962 Iface_Elmt : Elmt_Id; 5963 Iface_Prim_Elmt : Elmt_Id; 5964 Iface_Prim : Entity_Id; 5965 5966 begin 5967 Iface_Elmt := First_Elmt (Ifaces_List); 5968 while Present (Iface_Elmt) loop 5969 Iface_Prim_Elmt := 5970 First_Elmt (Primitive_Operations (Node (Iface_Elmt))); 5971 while Present (Iface_Prim_Elmt) loop 5972 Iface_Prim := Node (Iface_Prim_Elmt); 5973 5974 if Is_Interface_Conformant (Typ, Iface_Prim, Op) 5975 and then Convention (Iface_Prim) /= Convention (Op) 5976 then 5977 Error_Msg_N 5978 ("inconsistent conventions in primitive operations", Typ); 5979 5980 Error_Msg_Name_1 := Chars (Op); 5981 Error_Msg_Name_2 := Get_Convention_Name (Convention (Op)); 5982 Error_Msg_Sloc := Sloc (Op); 5983 5984 if Comes_From_Source (Op) or else No (Alias (Op)) then 5985 if not Present (Overridden_Operation (Op)) then 5986 Error_Msg_N ("\\primitive % defined #", Typ); 5987 else 5988 Error_Msg_N 5989 ("\\overriding operation % with " & 5990 "convention % defined #", Typ); 5991 end if; 5992 5993 else pragma Assert (Present (Alias (Op))); 5994 Error_Msg_Sloc := Sloc (Alias (Op)); 5995 Error_Msg_N 5996 ("\\inherited operation % with " & 5997 "convention % defined #", Typ); 5998 end if; 5999 6000 Error_Msg_Name_1 := Chars (Op); 6001 Error_Msg_Name_2 := 6002 Get_Convention_Name (Convention (Iface_Prim)); 6003 Error_Msg_Sloc := Sloc (Iface_Prim); 6004 Error_Msg_N 6005 ("\\overridden operation % with " & 6006 "convention % defined #", Typ); 6007 6008 -- Avoid cascading errors 6009 6010 return; 6011 end if; 6012 6013 Next_Elmt (Iface_Prim_Elmt); 6014 end loop; 6015 6016 Next_Elmt (Iface_Elmt); 6017 end loop; 6018 end Check_Convention; 6019 6020 -- Local variables 6021 6022 Prim_Op : Entity_Id; 6023 Prim_Op_Elmt : Elmt_Id; 6024 6025 -- Start of processing for Check_Conventions 6026 6027 begin 6028 if not Has_Interfaces (Typ) then 6029 return; 6030 end if; 6031 6032 Collect_Interfaces (Typ, Ifaces_List); 6033 6034 -- The algorithm checks every overriding dispatching operation against 6035 -- all the corresponding overridden dispatching operations, detecting 6036 -- differences in conventions. 6037 6038 Prim_Op_Elmt := First_Elmt (Primitive_Operations (Typ)); 6039 while Present (Prim_Op_Elmt) loop 6040 Prim_Op := Node (Prim_Op_Elmt); 6041 6042 -- A small optimization: skip the predefined dispatching operations 6043 -- since they always have the same convention. 6044 6045 if not Is_Predefined_Dispatching_Operation (Prim_Op) then 6046 Check_Convention (Prim_Op); 6047 end if; 6048 6049 Next_Elmt (Prim_Op_Elmt); 6050 end loop; 6051 end Check_Conventions; 6052 6053 ------------------------------ 6054 -- Check_Delayed_Subprogram -- 6055 ------------------------------ 6056 6057 procedure Check_Delayed_Subprogram (Designator : Entity_Id) is 6058 F : Entity_Id; 6059 6060 procedure Possible_Freeze (T : Entity_Id); 6061 -- T is the type of either a formal parameter or of the return type. 6062 -- If T is not yet frozen and needs a delayed freeze, then the 6063 -- subprogram itself must be delayed. If T is the limited view of an 6064 -- incomplete type the subprogram must be frozen as well, because 6065 -- T may depend on local types that have not been frozen yet. 6066 6067 --------------------- 6068 -- Possible_Freeze -- 6069 --------------------- 6070 6071 procedure Possible_Freeze (T : Entity_Id) is 6072 begin 6073 if Has_Delayed_Freeze (T) and then not Is_Frozen (T) then 6074 Set_Has_Delayed_Freeze (Designator); 6075 6076 elsif Is_Access_Type (T) 6077 and then Has_Delayed_Freeze (Designated_Type (T)) 6078 and then not Is_Frozen (Designated_Type (T)) 6079 then 6080 Set_Has_Delayed_Freeze (Designator); 6081 6082 elsif Ekind (T) = E_Incomplete_Type and then From_With_Type (T) then 6083 Set_Has_Delayed_Freeze (Designator); 6084 6085 -- AI05-0151: In Ada 2012, Incomplete types can appear in the profile 6086 -- of a subprogram or entry declaration. 6087 6088 elsif Ekind (T) = E_Incomplete_Type 6089 and then Ada_Version >= Ada_2012 6090 then 6091 Set_Has_Delayed_Freeze (Designator); 6092 end if; 6093 6094 end Possible_Freeze; 6095 6096 -- Start of processing for Check_Delayed_Subprogram 6097 6098 begin 6099 -- All subprograms, including abstract subprograms, may need a freeze 6100 -- node if some formal type or the return type needs one. 6101 6102 Possible_Freeze (Etype (Designator)); 6103 Possible_Freeze (Base_Type (Etype (Designator))); -- needed ??? 6104 6105 -- Need delayed freeze if any of the formal types themselves need 6106 -- a delayed freeze and are not yet frozen. 6107 6108 F := First_Formal (Designator); 6109 while Present (F) loop 6110 Possible_Freeze (Etype (F)); 6111 Possible_Freeze (Base_Type (Etype (F))); -- needed ??? 6112 Next_Formal (F); 6113 end loop; 6114 6115 -- Mark functions that return by reference. Note that it cannot be 6116 -- done for delayed_freeze subprograms because the underlying 6117 -- returned type may not be known yet (for private types) 6118 6119 if not Has_Delayed_Freeze (Designator) 6120 and then Expander_Active 6121 then 6122 declare 6123 Typ : constant Entity_Id := Etype (Designator); 6124 Utyp : constant Entity_Id := Underlying_Type (Typ); 6125 6126 begin 6127 if Is_Immutably_Limited_Type (Typ) then 6128 Set_Returns_By_Ref (Designator); 6129 6130 elsif Present (Utyp) and then CW_Or_Has_Controlled_Part (Utyp) then 6131 Set_Returns_By_Ref (Designator); 6132 end if; 6133 end; 6134 end if; 6135 end Check_Delayed_Subprogram; 6136 6137 ------------------------------------ 6138 -- Check_Discriminant_Conformance -- 6139 ------------------------------------ 6140 6141 procedure Check_Discriminant_Conformance 6142 (N : Node_Id; 6143 Prev : Entity_Id; 6144 Prev_Loc : Node_Id) 6145 is 6146 Old_Discr : Entity_Id := First_Discriminant (Prev); 6147 New_Discr : Node_Id := First (Discriminant_Specifications (N)); 6148 New_Discr_Id : Entity_Id; 6149 New_Discr_Type : Entity_Id; 6150 6151 procedure Conformance_Error (Msg : String; N : Node_Id); 6152 -- Post error message for conformance error on given node. Two messages 6153 -- are output. The first points to the previous declaration with a 6154 -- general "no conformance" message. The second is the detailed reason, 6155 -- supplied as Msg. The parameter N provide information for a possible 6156 -- & insertion in the message. 6157 6158 ----------------------- 6159 -- Conformance_Error -- 6160 ----------------------- 6161 6162 procedure Conformance_Error (Msg : String; N : Node_Id) is 6163 begin 6164 Error_Msg_Sloc := Sloc (Prev_Loc); 6165 Error_Msg_N -- CODEFIX 6166 ("not fully conformant with declaration#!", N); 6167 Error_Msg_NE (Msg, N, N); 6168 end Conformance_Error; 6169 6170 -- Start of processing for Check_Discriminant_Conformance 6171 6172 begin 6173 while Present (Old_Discr) and then Present (New_Discr) loop 6174 New_Discr_Id := Defining_Identifier (New_Discr); 6175 6176 -- The subtype mark of the discriminant on the full type has not 6177 -- been analyzed so we do it here. For an access discriminant a new 6178 -- type is created. 6179 6180 if Nkind (Discriminant_Type (New_Discr)) = N_Access_Definition then 6181 New_Discr_Type := 6182 Access_Definition (N, Discriminant_Type (New_Discr)); 6183 6184 else 6185 Analyze (Discriminant_Type (New_Discr)); 6186 New_Discr_Type := Etype (Discriminant_Type (New_Discr)); 6187 6188 -- Ada 2005: if the discriminant definition carries a null 6189 -- exclusion, create an itype to check properly for consistency 6190 -- with partial declaration. 6191 6192 if Is_Access_Type (New_Discr_Type) 6193 and then Null_Exclusion_Present (New_Discr) 6194 then 6195 New_Discr_Type := 6196 Create_Null_Excluding_Itype 6197 (T => New_Discr_Type, 6198 Related_Nod => New_Discr, 6199 Scope_Id => Current_Scope); 6200 end if; 6201 end if; 6202 6203 if not Conforming_Types 6204 (Etype (Old_Discr), New_Discr_Type, Fully_Conformant) 6205 then 6206 Conformance_Error ("type of & does not match!", New_Discr_Id); 6207 return; 6208 else 6209 -- Treat the new discriminant as an occurrence of the old one, 6210 -- for navigation purposes, and fill in some semantic 6211 -- information, for completeness. 6212 6213 Generate_Reference (Old_Discr, New_Discr_Id, 'r'); 6214 Set_Etype (New_Discr_Id, Etype (Old_Discr)); 6215 Set_Scope (New_Discr_Id, Scope (Old_Discr)); 6216 end if; 6217 6218 -- Names must match 6219 6220 if Chars (Old_Discr) /= Chars (Defining_Identifier (New_Discr)) then 6221 Conformance_Error ("name & does not match!", New_Discr_Id); 6222 return; 6223 end if; 6224 6225 -- Default expressions must match 6226 6227 declare 6228 NewD : constant Boolean := 6229 Present (Expression (New_Discr)); 6230 OldD : constant Boolean := 6231 Present (Expression (Parent (Old_Discr))); 6232 6233 begin 6234 if NewD or OldD then 6235 6236 -- The old default value has been analyzed and expanded, 6237 -- because the current full declaration will have frozen 6238 -- everything before. The new default values have not been 6239 -- expanded, so expand now to check conformance. 6240 6241 if NewD then 6242 Preanalyze_Spec_Expression 6243 (Expression (New_Discr), New_Discr_Type); 6244 end if; 6245 6246 if not (NewD and OldD) 6247 or else not Fully_Conformant_Expressions 6248 (Expression (Parent (Old_Discr)), 6249 Expression (New_Discr)) 6250 6251 then 6252 Conformance_Error 6253 ("default expression for & does not match!", 6254 New_Discr_Id); 6255 return; 6256 end if; 6257 end if; 6258 end; 6259 6260 -- In Ada 83 case, grouping must match: (A,B : X) /= (A : X; B : X) 6261 6262 if Ada_Version = Ada_83 then 6263 declare 6264 Old_Disc : constant Node_Id := Declaration_Node (Old_Discr); 6265 6266 begin 6267 -- Grouping (use of comma in param lists) must be the same 6268 -- This is where we catch a misconformance like: 6269 6270 -- A, B : Integer 6271 -- A : Integer; B : Integer 6272 6273 -- which are represented identically in the tree except 6274 -- for the setting of the flags More_Ids and Prev_Ids. 6275 6276 if More_Ids (Old_Disc) /= More_Ids (New_Discr) 6277 or else Prev_Ids (Old_Disc) /= Prev_Ids (New_Discr) 6278 then 6279 Conformance_Error 6280 ("grouping of & does not match!", New_Discr_Id); 6281 return; 6282 end if; 6283 end; 6284 end if; 6285 6286 Next_Discriminant (Old_Discr); 6287 Next (New_Discr); 6288 end loop; 6289 6290 if Present (Old_Discr) then 6291 Conformance_Error ("too few discriminants!", Defining_Identifier (N)); 6292 return; 6293 6294 elsif Present (New_Discr) then 6295 Conformance_Error 6296 ("too many discriminants!", Defining_Identifier (New_Discr)); 6297 return; 6298 end if; 6299 end Check_Discriminant_Conformance; 6300 6301 ---------------------------- 6302 -- Check_Fully_Conformant -- 6303 ---------------------------- 6304 6305 procedure Check_Fully_Conformant 6306 (New_Id : Entity_Id; 6307 Old_Id : Entity_Id; 6308 Err_Loc : Node_Id := Empty) 6309 is 6310 Result : Boolean; 6311 pragma Warnings (Off, Result); 6312 begin 6313 Check_Conformance 6314 (New_Id, Old_Id, Fully_Conformant, True, Result, Err_Loc); 6315 end Check_Fully_Conformant; 6316 6317 --------------------------- 6318 -- Check_Mode_Conformant -- 6319 --------------------------- 6320 6321 procedure Check_Mode_Conformant 6322 (New_Id : Entity_Id; 6323 Old_Id : Entity_Id; 6324 Err_Loc : Node_Id := Empty; 6325 Get_Inst : Boolean := False) 6326 is 6327 Result : Boolean; 6328 pragma Warnings (Off, Result); 6329 begin 6330 Check_Conformance 6331 (New_Id, Old_Id, Mode_Conformant, True, Result, Err_Loc, Get_Inst); 6332 end Check_Mode_Conformant; 6333 6334 -------------------------------- 6335 -- Check_Overriding_Indicator -- 6336 -------------------------------- 6337 6338 procedure Check_Overriding_Indicator 6339 (Subp : Entity_Id; 6340 Overridden_Subp : Entity_Id; 6341 Is_Primitive : Boolean) 6342 is 6343 Decl : Node_Id; 6344 Spec : Node_Id; 6345 6346 begin 6347 -- No overriding indicator for literals 6348 6349 if Ekind (Subp) = E_Enumeration_Literal then 6350 return; 6351 6352 elsif Ekind (Subp) = E_Entry then 6353 Decl := Parent (Subp); 6354 6355 -- No point in analyzing a malformed operator 6356 6357 elsif Nkind (Subp) = N_Defining_Operator_Symbol 6358 and then Error_Posted (Subp) 6359 then 6360 return; 6361 6362 else 6363 Decl := Unit_Declaration_Node (Subp); 6364 end if; 6365 6366 if Nkind_In (Decl, N_Subprogram_Body, 6367 N_Subprogram_Body_Stub, 6368 N_Subprogram_Declaration, 6369 N_Abstract_Subprogram_Declaration, 6370 N_Subprogram_Renaming_Declaration) 6371 then 6372 Spec := Specification (Decl); 6373 6374 elsif Nkind (Decl) = N_Entry_Declaration then 6375 Spec := Decl; 6376 6377 else 6378 return; 6379 end if; 6380 6381 -- The overriding operation is type conformant with the overridden one, 6382 -- but the names of the formals are not required to match. If the names 6383 -- appear permuted in the overriding operation, this is a possible 6384 -- source of confusion that is worth diagnosing. Controlling formals 6385 -- often carry names that reflect the type, and it is not worthwhile 6386 -- requiring that their names match. 6387 6388 if Present (Overridden_Subp) 6389 and then Nkind (Subp) /= N_Defining_Operator_Symbol 6390 then 6391 declare 6392 Form1 : Entity_Id; 6393 Form2 : Entity_Id; 6394 6395 begin 6396 Form1 := First_Formal (Subp); 6397 Form2 := First_Formal (Overridden_Subp); 6398 6399 -- If the overriding operation is a synchronized operation, skip 6400 -- the first parameter of the overridden operation, which is 6401 -- implicit in the new one. If the operation is declared in the 6402 -- body it is not primitive and all formals must match. 6403 6404 if Is_Concurrent_Type (Scope (Subp)) 6405 and then Is_Tagged_Type (Scope (Subp)) 6406 and then not Has_Completion (Scope (Subp)) 6407 then 6408 Form2 := Next_Formal (Form2); 6409 end if; 6410 6411 if Present (Form1) then 6412 Form1 := Next_Formal (Form1); 6413 Form2 := Next_Formal (Form2); 6414 end if; 6415 6416 while Present (Form1) loop 6417 if not Is_Controlling_Formal (Form1) 6418 and then Present (Next_Formal (Form2)) 6419 and then Chars (Form1) = Chars (Next_Formal (Form2)) 6420 then 6421 Error_Msg_Node_2 := Alias (Overridden_Subp); 6422 Error_Msg_Sloc := Sloc (Error_Msg_Node_2); 6423 Error_Msg_NE 6424 ("& does not match corresponding formal of&#", 6425 Form1, Form1); 6426 exit; 6427 end if; 6428 6429 Next_Formal (Form1); 6430 Next_Formal (Form2); 6431 end loop; 6432 end; 6433 end if; 6434 6435 -- If there is an overridden subprogram, then check that there is no 6436 -- "not overriding" indicator, and mark the subprogram as overriding. 6437 -- This is not done if the overridden subprogram is marked as hidden, 6438 -- which can occur for the case of inherited controlled operations 6439 -- (see Derive_Subprogram), unless the inherited subprogram's parent 6440 -- subprogram is not itself hidden. (Note: This condition could probably 6441 -- be simplified, leaving out the testing for the specific controlled 6442 -- cases, but it seems safer and clearer this way, and echoes similar 6443 -- special-case tests of this kind in other places.) 6444 6445 if Present (Overridden_Subp) 6446 and then (not Is_Hidden (Overridden_Subp) 6447 or else 6448 ((Chars (Overridden_Subp) = Name_Initialize 6449 or else 6450 Chars (Overridden_Subp) = Name_Adjust 6451 or else 6452 Chars (Overridden_Subp) = Name_Finalize) 6453 and then Present (Alias (Overridden_Subp)) 6454 and then not Is_Hidden (Alias (Overridden_Subp)))) 6455 then 6456 if Must_Not_Override (Spec) then 6457 Error_Msg_Sloc := Sloc (Overridden_Subp); 6458 6459 if Ekind (Subp) = E_Entry then 6460 Error_Msg_NE 6461 ("entry & overrides inherited operation #", Spec, Subp); 6462 else 6463 Error_Msg_NE 6464 ("subprogram & overrides inherited operation #", Spec, Subp); 6465 end if; 6466 6467 -- Special-case to fix a GNAT oddity: Limited_Controlled is declared 6468 -- as an extension of Root_Controlled, and thus has a useless Adjust 6469 -- operation. This operation should not be inherited by other limited 6470 -- controlled types. An explicit Adjust for them is not overriding. 6471 6472 elsif Must_Override (Spec) 6473 and then Chars (Overridden_Subp) = Name_Adjust 6474 and then Is_Limited_Type (Etype (First_Formal (Subp))) 6475 and then Present (Alias (Overridden_Subp)) 6476 and then 6477 Is_Predefined_File_Name 6478 (Unit_File_Name (Get_Source_Unit (Alias (Overridden_Subp)))) 6479 then 6480 Error_Msg_NE ("subprogram & is not overriding", Spec, Subp); 6481 6482 elsif Is_Subprogram (Subp) then 6483 if Is_Init_Proc (Subp) then 6484 null; 6485 6486 elsif No (Overridden_Operation (Subp)) then 6487 6488 -- For entities generated by Derive_Subprograms the overridden 6489 -- operation is the inherited primitive (which is available 6490 -- through the attribute alias) 6491 6492 if (Is_Dispatching_Operation (Subp) 6493 or else Is_Dispatching_Operation (Overridden_Subp)) 6494 and then not Comes_From_Source (Overridden_Subp) 6495 and then Find_Dispatching_Type (Overridden_Subp) = 6496 Find_Dispatching_Type (Subp) 6497 and then Present (Alias (Overridden_Subp)) 6498 and then Comes_From_Source (Alias (Overridden_Subp)) 6499 then 6500 Set_Overridden_Operation (Subp, Alias (Overridden_Subp)); 6501 6502 else 6503 Set_Overridden_Operation (Subp, Overridden_Subp); 6504 end if; 6505 end if; 6506 end if; 6507 6508 -- If primitive flag is set or this is a protected operation, then 6509 -- the operation is overriding at the point of its declaration, so 6510 -- warn if necessary. Otherwise it may have been declared before the 6511 -- operation it overrides and no check is required. 6512 6513 if Style_Check 6514 and then not Must_Override (Spec) 6515 and then (Is_Primitive 6516 or else Ekind (Scope (Subp)) = E_Protected_Type) 6517 then 6518 Style.Missing_Overriding (Decl, Subp); 6519 end if; 6520 6521 -- If Subp is an operator, it may override a predefined operation, if 6522 -- it is defined in the same scope as the type to which it applies. 6523 -- In that case Overridden_Subp is empty because of our implicit 6524 -- representation for predefined operators. We have to check whether the 6525 -- signature of Subp matches that of a predefined operator. Note that 6526 -- first argument provides the name of the operator, and the second 6527 -- argument the signature that may match that of a standard operation. 6528 -- If the indicator is overriding, then the operator must match a 6529 -- predefined signature, because we know already that there is no 6530 -- explicit overridden operation. 6531 6532 elsif Nkind (Subp) = N_Defining_Operator_Symbol then 6533 if Must_Not_Override (Spec) then 6534 6535 -- If this is not a primitive or a protected subprogram, then 6536 -- "not overriding" is illegal. 6537 6538 if not Is_Primitive 6539 and then Ekind (Scope (Subp)) /= E_Protected_Type 6540 then 6541 Error_Msg_N 6542 ("overriding indicator only allowed " 6543 & "if subprogram is primitive", Subp); 6544 6545 elsif Can_Override_Operator (Subp) then 6546 Error_Msg_NE 6547 ("subprogram& overrides predefined operator ", Spec, Subp); 6548 end if; 6549 6550 elsif Must_Override (Spec) then 6551 if No (Overridden_Operation (Subp)) 6552 and then not Can_Override_Operator (Subp) 6553 then 6554 Error_Msg_NE ("subprogram & is not overriding", Spec, Subp); 6555 end if; 6556 6557 elsif not Error_Posted (Subp) 6558 and then Style_Check 6559 and then Can_Override_Operator (Subp) 6560 and then 6561 not Is_Predefined_File_Name 6562 (Unit_File_Name (Get_Source_Unit (Subp))) 6563 then 6564 -- If style checks are enabled, indicate that the indicator is 6565 -- missing. However, at the point of declaration, the type of 6566 -- which this is a primitive operation may be private, in which 6567 -- case the indicator would be premature. 6568 6569 if Has_Private_Declaration (Etype (Subp)) 6570 or else Has_Private_Declaration (Etype (First_Formal (Subp))) 6571 then 6572 null; 6573 else 6574 Style.Missing_Overriding (Decl, Subp); 6575 end if; 6576 end if; 6577 6578 elsif Must_Override (Spec) then 6579 if Ekind (Subp) = E_Entry then 6580 Error_Msg_NE ("entry & is not overriding", Spec, Subp); 6581 else 6582 Error_Msg_NE ("subprogram & is not overriding", Spec, Subp); 6583 end if; 6584 6585 -- If the operation is marked "not overriding" and it's not primitive 6586 -- then an error is issued, unless this is an operation of a task or 6587 -- protected type (RM05-8.3.1(3/2-4/2)). Error cases where "overriding" 6588 -- has been specified have already been checked above. 6589 6590 elsif Must_Not_Override (Spec) 6591 and then not Is_Primitive 6592 and then Ekind (Subp) /= E_Entry 6593 and then Ekind (Scope (Subp)) /= E_Protected_Type 6594 then 6595 Error_Msg_N 6596 ("overriding indicator only allowed if subprogram is primitive", 6597 Subp); 6598 return; 6599 end if; 6600 end Check_Overriding_Indicator; 6601 6602 ------------------- 6603 -- Check_Returns -- 6604 ------------------- 6605 6606 -- Note: this procedure needs to know far too much about how the expander 6607 -- messes with exceptions. The use of the flag Exception_Junk and the 6608 -- incorporation of knowledge of Exp_Ch11.Expand_Local_Exception_Handlers 6609 -- works, but is not very clean. It would be better if the expansion 6610 -- routines would leave Original_Node working nicely, and we could use 6611 -- Original_Node here to ignore all the peculiar expander messing ??? 6612 6613 procedure Check_Returns 6614 (HSS : Node_Id; 6615 Mode : Character; 6616 Err : out Boolean; 6617 Proc : Entity_Id := Empty) 6618 is 6619 Handler : Node_Id; 6620 6621 procedure Check_Statement_Sequence (L : List_Id); 6622 -- Internal recursive procedure to check a list of statements for proper 6623 -- termination by a return statement (or a transfer of control or a 6624 -- compound statement that is itself internally properly terminated). 6625 6626 ------------------------------ 6627 -- Check_Statement_Sequence -- 6628 ------------------------------ 6629 6630 procedure Check_Statement_Sequence (L : List_Id) is 6631 Last_Stm : Node_Id; 6632 Stm : Node_Id; 6633 Kind : Node_Kind; 6634 6635 Raise_Exception_Call : Boolean; 6636 -- Set True if statement sequence terminated by Raise_Exception call 6637 -- or a Reraise_Occurrence call. 6638 6639 begin 6640 Raise_Exception_Call := False; 6641 6642 -- Get last real statement 6643 6644 Last_Stm := Last (L); 6645 6646 -- Deal with digging out exception handler statement sequences that 6647 -- have been transformed by the local raise to goto optimization. 6648 -- See Exp_Ch11.Expand_Local_Exception_Handlers for details. If this 6649 -- optimization has occurred, we are looking at something like: 6650 6651 -- begin 6652 -- original stmts in block 6653 6654 -- exception \ 6655 -- when excep1 => | 6656 -- goto L1; | omitted if No_Exception_Propagation 6657 -- when excep2 => | 6658 -- goto L2; / 6659 -- end; 6660 6661 -- goto L3; -- skip handler when exception not raised 6662 6663 -- <<L1>> -- target label for local exception 6664 -- begin 6665 -- estmts1 6666 -- end; 6667 6668 -- goto L3; 6669 6670 -- <<L2>> 6671 -- begin 6672 -- estmts2 6673 -- end; 6674 6675 -- <<L3>> 6676 6677 -- and what we have to do is to dig out the estmts1 and estmts2 6678 -- sequences (which were the original sequences of statements in 6679 -- the exception handlers) and check them. 6680 6681 if Nkind (Last_Stm) = N_Label 6682 and then Exception_Junk (Last_Stm) 6683 then 6684 Stm := Last_Stm; 6685 loop 6686 Prev (Stm); 6687 exit when No (Stm); 6688 exit when Nkind (Stm) /= N_Block_Statement; 6689 exit when not Exception_Junk (Stm); 6690 Prev (Stm); 6691 exit when No (Stm); 6692 exit when Nkind (Stm) /= N_Label; 6693 exit when not Exception_Junk (Stm); 6694 Check_Statement_Sequence 6695 (Statements (Handled_Statement_Sequence (Next (Stm)))); 6696 6697 Prev (Stm); 6698 Last_Stm := Stm; 6699 exit when No (Stm); 6700 exit when Nkind (Stm) /= N_Goto_Statement; 6701 exit when not Exception_Junk (Stm); 6702 end loop; 6703 end if; 6704 6705 -- Don't count pragmas 6706 6707 while Nkind (Last_Stm) = N_Pragma 6708 6709 -- Don't count call to SS_Release (can happen after Raise_Exception) 6710 6711 or else 6712 (Nkind (Last_Stm) = N_Procedure_Call_Statement 6713 and then 6714 Nkind (Name (Last_Stm)) = N_Identifier 6715 and then 6716 Is_RTE (Entity (Name (Last_Stm)), RE_SS_Release)) 6717 6718 -- Don't count exception junk 6719 6720 or else 6721 (Nkind_In (Last_Stm, N_Goto_Statement, 6722 N_Label, 6723 N_Object_Declaration) 6724 and then Exception_Junk (Last_Stm)) 6725 or else Nkind (Last_Stm) in N_Push_xxx_Label 6726 or else Nkind (Last_Stm) in N_Pop_xxx_Label 6727 6728 -- Inserted code, such as finalization calls, is irrelevant: we only 6729 -- need to check original source. 6730 6731 or else Is_Rewrite_Insertion (Last_Stm) 6732 loop 6733 Prev (Last_Stm); 6734 end loop; 6735 6736 -- Here we have the "real" last statement 6737 6738 Kind := Nkind (Last_Stm); 6739 6740 -- Transfer of control, OK. Note that in the No_Return procedure 6741 -- case, we already diagnosed any explicit return statements, so 6742 -- we can treat them as OK in this context. 6743 6744 if Is_Transfer (Last_Stm) then 6745 return; 6746 6747 -- Check cases of explicit non-indirect procedure calls 6748 6749 elsif Kind = N_Procedure_Call_Statement 6750 and then Is_Entity_Name (Name (Last_Stm)) 6751 then 6752 -- Check call to Raise_Exception procedure which is treated 6753 -- specially, as is a call to Reraise_Occurrence. 6754 6755 -- We suppress the warning in these cases since it is likely that 6756 -- the programmer really does not expect to deal with the case 6757 -- of Null_Occurrence, and thus would find a warning about a 6758 -- missing return curious, and raising Program_Error does not 6759 -- seem such a bad behavior if this does occur. 6760 6761 -- Note that in the Ada 2005 case for Raise_Exception, the actual 6762 -- behavior will be to raise Constraint_Error (see AI-329). 6763 6764 if Is_RTE (Entity (Name (Last_Stm)), RE_Raise_Exception) 6765 or else 6766 Is_RTE (Entity (Name (Last_Stm)), RE_Reraise_Occurrence) 6767 then 6768 Raise_Exception_Call := True; 6769 6770 -- For Raise_Exception call, test first argument, if it is 6771 -- an attribute reference for a 'Identity call, then we know 6772 -- that the call cannot possibly return. 6773 6774 declare 6775 Arg : constant Node_Id := 6776 Original_Node (First_Actual (Last_Stm)); 6777 begin 6778 if Nkind (Arg) = N_Attribute_Reference 6779 and then Attribute_Name (Arg) = Name_Identity 6780 then 6781 return; 6782 end if; 6783 end; 6784 end if; 6785 6786 -- If statement, need to look inside if there is an else and check 6787 -- each constituent statement sequence for proper termination. 6788 6789 elsif Kind = N_If_Statement 6790 and then Present (Else_Statements (Last_Stm)) 6791 then 6792 Check_Statement_Sequence (Then_Statements (Last_Stm)); 6793 Check_Statement_Sequence (Else_Statements (Last_Stm)); 6794 6795 if Present (Elsif_Parts (Last_Stm)) then 6796 declare 6797 Elsif_Part : Node_Id := First (Elsif_Parts (Last_Stm)); 6798 6799 begin 6800 while Present (Elsif_Part) loop 6801 Check_Statement_Sequence (Then_Statements (Elsif_Part)); 6802 Next (Elsif_Part); 6803 end loop; 6804 end; 6805 end if; 6806 6807 return; 6808 6809 -- Case statement, check each case for proper termination 6810 6811 elsif Kind = N_Case_Statement then 6812 declare 6813 Case_Alt : Node_Id; 6814 begin 6815 Case_Alt := First_Non_Pragma (Alternatives (Last_Stm)); 6816 while Present (Case_Alt) loop 6817 Check_Statement_Sequence (Statements (Case_Alt)); 6818 Next_Non_Pragma (Case_Alt); 6819 end loop; 6820 end; 6821 6822 return; 6823 6824 -- Block statement, check its handled sequence of statements 6825 6826 elsif Kind = N_Block_Statement then 6827 declare 6828 Err1 : Boolean; 6829 6830 begin 6831 Check_Returns 6832 (Handled_Statement_Sequence (Last_Stm), Mode, Err1); 6833 6834 if Err1 then 6835 Err := True; 6836 end if; 6837 6838 return; 6839 end; 6840 6841 -- Loop statement. If there is an iteration scheme, we can definitely 6842 -- fall out of the loop. Similarly if there is an exit statement, we 6843 -- can fall out. In either case we need a following return. 6844 6845 elsif Kind = N_Loop_Statement then 6846 if Present (Iteration_Scheme (Last_Stm)) 6847 or else Has_Exit (Entity (Identifier (Last_Stm))) 6848 then 6849 null; 6850 6851 -- A loop with no exit statement or iteration scheme is either 6852 -- an infinite loop, or it has some other exit (raise/return). 6853 -- In either case, no warning is required. 6854 6855 else 6856 return; 6857 end if; 6858 6859 -- Timed entry call, check entry call and delay alternatives 6860 6861 -- Note: in expanded code, the timed entry call has been converted 6862 -- to a set of expanded statements on which the check will work 6863 -- correctly in any case. 6864 6865 elsif Kind = N_Timed_Entry_Call then 6866 declare 6867 ECA : constant Node_Id := Entry_Call_Alternative (Last_Stm); 6868 DCA : constant Node_Id := Delay_Alternative (Last_Stm); 6869 6870 begin 6871 -- If statement sequence of entry call alternative is missing, 6872 -- then we can definitely fall through, and we post the error 6873 -- message on the entry call alternative itself. 6874 6875 if No (Statements (ECA)) then 6876 Last_Stm := ECA; 6877 6878 -- If statement sequence of delay alternative is missing, then 6879 -- we can definitely fall through, and we post the error 6880 -- message on the delay alternative itself. 6881 6882 -- Note: if both ECA and DCA are missing the return, then we 6883 -- post only one message, should be enough to fix the bugs. 6884 -- If not we will get a message next time on the DCA when the 6885 -- ECA is fixed! 6886 6887 elsif No (Statements (DCA)) then 6888 Last_Stm := DCA; 6889 6890 -- Else check both statement sequences 6891 6892 else 6893 Check_Statement_Sequence (Statements (ECA)); 6894 Check_Statement_Sequence (Statements (DCA)); 6895 return; 6896 end if; 6897 end; 6898 6899 -- Conditional entry call, check entry call and else part 6900 6901 -- Note: in expanded code, the conditional entry call has been 6902 -- converted to a set of expanded statements on which the check 6903 -- will work correctly in any case. 6904 6905 elsif Kind = N_Conditional_Entry_Call then 6906 declare 6907 ECA : constant Node_Id := Entry_Call_Alternative (Last_Stm); 6908 6909 begin 6910 -- If statement sequence of entry call alternative is missing, 6911 -- then we can definitely fall through, and we post the error 6912 -- message on the entry call alternative itself. 6913 6914 if No (Statements (ECA)) then 6915 Last_Stm := ECA; 6916 6917 -- Else check statement sequence and else part 6918 6919 else 6920 Check_Statement_Sequence (Statements (ECA)); 6921 Check_Statement_Sequence (Else_Statements (Last_Stm)); 6922 return; 6923 end if; 6924 end; 6925 end if; 6926 6927 -- If we fall through, issue appropriate message 6928 6929 if Mode = 'F' then 6930 if not Raise_Exception_Call then 6931 Error_Msg_N 6932 ("RETURN statement missing following this statement??!", 6933 Last_Stm); 6934 Error_Msg_N 6935 ("\Program_Error may be raised at run time??!", 6936 Last_Stm); 6937 end if; 6938 6939 -- Note: we set Err even though we have not issued a warning 6940 -- because we still have a case of a missing return. This is 6941 -- an extremely marginal case, probably will never be noticed 6942 -- but we might as well get it right. 6943 6944 Err := True; 6945 6946 -- Otherwise we have the case of a procedure marked No_Return 6947 6948 else 6949 if not Raise_Exception_Call then 6950 Error_Msg_N 6951 ("implied return after this statement " & 6952 "will raise Program_Error??", 6953 Last_Stm); 6954 Error_Msg_NE 6955 ("\procedure & is marked as No_Return??!", 6956 Last_Stm, Proc); 6957 end if; 6958 6959 declare 6960 RE : constant Node_Id := 6961 Make_Raise_Program_Error (Sloc (Last_Stm), 6962 Reason => PE_Implicit_Return); 6963 begin 6964 Insert_After (Last_Stm, RE); 6965 Analyze (RE); 6966 end; 6967 end if; 6968 end Check_Statement_Sequence; 6969 6970 -- Start of processing for Check_Returns 6971 6972 begin 6973 Err := False; 6974 Check_Statement_Sequence (Statements (HSS)); 6975 6976 if Present (Exception_Handlers (HSS)) then 6977 Handler := First_Non_Pragma (Exception_Handlers (HSS)); 6978 while Present (Handler) loop 6979 Check_Statement_Sequence (Statements (Handler)); 6980 Next_Non_Pragma (Handler); 6981 end loop; 6982 end if; 6983 end Check_Returns; 6984 6985 ------------------------------- 6986 -- Check_Subprogram_Contract -- 6987 ------------------------------- 6988 6989 procedure Check_Subprogram_Contract (Spec_Id : Entity_Id) is 6990 6991 -- Code is currently commented out as, in some cases, it causes crashes 6992 -- because Direct_Primitive_Operations is not available for a private 6993 -- type. This may cause more warnings to be issued than necessary. See 6994 -- below for the intended use of this variable. ??? 6995 6996-- Inherited : constant Subprogram_List := 6997-- Inherited_Subprograms (Spec_Id); 6998-- -- List of subprograms inherited by this subprogram 6999 7000 -- We ignore postconditions "True" or "False" and contract-cases which 7001 -- have similar Ensures components, which we call "trivial", when 7002 -- issuing warnings, since these postconditions and contract-cases 7003 -- purposedly ignore the post-state. 7004 7005 Last_Postcondition : Node_Id := Empty; 7006 -- Last non-trivial postcondition on the subprogram, or else Empty if 7007 -- either no non-trivial postcondition or only inherited postconditions. 7008 7009 Last_Contract_Case : Node_Id := Empty; 7010 -- Last non-trivial contract-case on the subprogram, or else Empty 7011 7012 Attribute_Result_Mentioned : Boolean := False; 7013 -- Whether attribute 'Result is mentioned in a non-trivial postcondition 7014 -- or contract-case. 7015 7016 No_Warning_On_Some_Postcondition : Boolean := False; 7017 -- Whether there exists a non-trivial postcondition or contract-case 7018 -- without a corresponding warning. 7019 7020 Post_State_Mentioned : Boolean := False; 7021 -- Whether some expression mentioned in a postcondition or contract-case 7022 -- can have a different value in the post-state than in the pre-state. 7023 7024 function Check_Attr_Result (N : Node_Id) return Traverse_Result; 7025 -- Check if N is a reference to the attribute 'Result, and if so set 7026 -- Attribute_Result_Mentioned and return Abandon. Otherwise return OK. 7027 7028 function Check_Post_State (N : Node_Id) return Traverse_Result; 7029 -- Check whether the value of evaluating N can be different in the 7030 -- post-state, compared to the same evaluation in the pre-state, and 7031 -- if so set Post_State_Mentioned and return Abandon. Return Skip on 7032 -- reference to attribute 'Old, in order to ignore its prefix, which 7033 -- is precisely evaluated in the pre-state. Otherwise return OK. 7034 7035 function Is_Trivial_Post_Or_Ensures (N : Node_Id) return Boolean; 7036 -- Return True if node N is trivially "True" or "False", and it comes 7037 -- from source. In particular, nodes that are statically known "True" or 7038 -- "False" by the compiler but not written as such in source code are 7039 -- not considered as trivial. 7040 7041 procedure Process_Contract_Cases (Spec : Node_Id); 7042 -- This processes the Spec_CTC_List from Spec, processing any contract 7043 -- case from the list. The caller has checked that Spec_CTC_List is 7044 -- non-Empty. 7045 7046 procedure Process_Post_Conditions (Spec : Node_Id; Class : Boolean); 7047 -- This processes the Spec_PPC_List from Spec, processing any 7048 -- postcondition from the list. If Class is True, then only 7049 -- postconditions marked with Class_Present are considered. The 7050 -- caller has checked that Spec_PPC_List is non-Empty. 7051 7052 function Find_Attribute_Result is new Traverse_Func (Check_Attr_Result); 7053 7054 function Find_Post_State is new Traverse_Func (Check_Post_State); 7055 7056 ----------------------- 7057 -- Check_Attr_Result -- 7058 ----------------------- 7059 7060 function Check_Attr_Result (N : Node_Id) return Traverse_Result is 7061 begin 7062 if Nkind (N) = N_Attribute_Reference 7063 and then Get_Attribute_Id (Attribute_Name (N)) = Attribute_Result 7064 then 7065 Attribute_Result_Mentioned := True; 7066 return Abandon; 7067 else 7068 return OK; 7069 end if; 7070 end Check_Attr_Result; 7071 7072 ---------------------- 7073 -- Check_Post_State -- 7074 ---------------------- 7075 7076 function Check_Post_State (N : Node_Id) return Traverse_Result is 7077 Found : Boolean := False; 7078 7079 begin 7080 case Nkind (N) is 7081 when N_Function_Call | 7082 N_Explicit_Dereference => 7083 Found := True; 7084 7085 when N_Identifier | 7086 N_Expanded_Name => 7087 7088 declare 7089 E : constant Entity_Id := Entity (N); 7090 7091 begin 7092 -- ???Quantified expressions get analyzed later, so E can 7093 -- be empty at this point. In this case, we suppress the 7094 -- warning, just in case E is assignable. It seems better to 7095 -- have false negatives than false positives. At some point, 7096 -- we should make the warning more accurate, either by 7097 -- analyzing quantified expressions earlier, or moving 7098 -- this processing later. 7099 7100 if No (E) 7101 or else 7102 (Is_Entity_Name (N) 7103 and then Ekind (E) in Assignable_Kind) 7104 then 7105 Found := True; 7106 end if; 7107 end; 7108 7109 when N_Attribute_Reference => 7110 case Get_Attribute_Id (Attribute_Name (N)) is 7111 when Attribute_Old => 7112 return Skip; 7113 when Attribute_Result => 7114 Found := True; 7115 when others => 7116 null; 7117 end case; 7118 7119 when others => 7120 null; 7121 end case; 7122 7123 if Found then 7124 Post_State_Mentioned := True; 7125 return Abandon; 7126 else 7127 return OK; 7128 end if; 7129 end Check_Post_State; 7130 7131 -------------------------------- 7132 -- Is_Trivial_Post_Or_Ensures -- 7133 -------------------------------- 7134 7135 function Is_Trivial_Post_Or_Ensures (N : Node_Id) return Boolean is 7136 begin 7137 return Is_Entity_Name (N) 7138 and then (Entity (N) = Standard_True 7139 or else 7140 Entity (N) = Standard_False) 7141 and then Comes_From_Source (N); 7142 end Is_Trivial_Post_Or_Ensures; 7143 7144 ---------------------------- 7145 -- Process_Contract_Cases -- 7146 ---------------------------- 7147 7148 procedure Process_Contract_Cases (Spec : Node_Id) is 7149 Prag : Node_Id; 7150 Arg : Node_Id; 7151 7152 Ignored : Traverse_Final_Result; 7153 pragma Unreferenced (Ignored); 7154 7155 begin 7156 Prag := Spec_CTC_List (Contract (Spec)); 7157 loop 7158 -- Retrieve the Ensures component of the contract-case, if any 7159 7160 Arg := Get_Ensures_From_CTC_Pragma (Prag); 7161 7162 -- Ignore trivial contract-case when Ensures component is "True" 7163 -- or "False". 7164 7165 if Pragma_Name (Prag) = Name_Contract_Case 7166 and then not Is_Trivial_Post_Or_Ensures (Expression (Arg)) 7167 then 7168 -- Since contract-cases are listed in reverse order, the first 7169 -- contract-case in the list is the last in the source. 7170 7171 if No (Last_Contract_Case) then 7172 Last_Contract_Case := Prag; 7173 end if; 7174 7175 -- For functions, look for presence of 'Result in Ensures 7176 7177 if Ekind_In (Spec_Id, E_Function, E_Generic_Function) then 7178 Ignored := Find_Attribute_Result (Arg); 7179 end if; 7180 7181 -- For each individual contract-case, look for presence 7182 -- of an expression that could be evaluated differently 7183 -- in post-state. 7184 7185 Post_State_Mentioned := False; 7186 Ignored := Find_Post_State (Arg); 7187 7188 if Post_State_Mentioned then 7189 No_Warning_On_Some_Postcondition := True; 7190 else 7191 Error_Msg_N 7192 ("`Ensures` component refers only to pre-state??", Prag); 7193 end if; 7194 end if; 7195 7196 Prag := Next_Pragma (Prag); 7197 exit when No (Prag); 7198 end loop; 7199 end Process_Contract_Cases; 7200 7201 ----------------------------- 7202 -- Process_Post_Conditions -- 7203 ----------------------------- 7204 7205 procedure Process_Post_Conditions 7206 (Spec : Node_Id; 7207 Class : Boolean) 7208 is 7209 Prag : Node_Id; 7210 Arg : Node_Id; 7211 Ignored : Traverse_Final_Result; 7212 pragma Unreferenced (Ignored); 7213 7214 begin 7215 Prag := Spec_PPC_List (Contract (Spec)); 7216 loop 7217 Arg := First (Pragma_Argument_Associations (Prag)); 7218 7219 -- Ignore trivial postcondition of "True" or "False" 7220 7221 if Pragma_Name (Prag) = Name_Postcondition 7222 and then not Is_Trivial_Post_Or_Ensures (Expression (Arg)) 7223 then 7224 -- Since pre- and post-conditions are listed in reverse order, 7225 -- the first postcondition in the list is last in the source. 7226 7227 if not Class and then No (Last_Postcondition) then 7228 Last_Postcondition := Prag; 7229 end if; 7230 7231 -- For functions, look for presence of 'Result in postcondition 7232 7233 if Ekind_In (Spec_Id, E_Function, E_Generic_Function) then 7234 Ignored := Find_Attribute_Result (Arg); 7235 end if; 7236 7237 -- For each individual non-inherited postcondition, look 7238 -- for presence of an expression that could be evaluated 7239 -- differently in post-state. 7240 7241 if not Class then 7242 Post_State_Mentioned := False; 7243 Ignored := Find_Post_State (Arg); 7244 7245 if Post_State_Mentioned then 7246 No_Warning_On_Some_Postcondition := True; 7247 else 7248 Error_Msg_N 7249 ("postcondition refers only to pre-state??", Prag); 7250 end if; 7251 end if; 7252 end if; 7253 7254 Prag := Next_Pragma (Prag); 7255 exit when No (Prag); 7256 end loop; 7257 end Process_Post_Conditions; 7258 7259 -- Start of processing for Check_Subprogram_Contract 7260 7261 begin 7262 if not Warn_On_Suspicious_Contract then 7263 return; 7264 end if; 7265 7266 -- Process spec postconditions 7267 7268 if Present (Spec_PPC_List (Contract (Spec_Id))) then 7269 Process_Post_Conditions (Spec_Id, Class => False); 7270 end if; 7271 7272 -- Process inherited postconditions 7273 7274 -- Code is currently commented out as, in some cases, it causes crashes 7275 -- because Direct_Primitive_Operations is not available for a private 7276 -- type. This may cause more warnings to be issued than necessary. ??? 7277 7278-- for J in Inherited'Range loop 7279-- if Present (Spec_PPC_List (Contract (Inherited (J)))) then 7280-- Process_Post_Conditions (Inherited (J), Class => True); 7281-- end if; 7282-- end loop; 7283 7284 -- Process contract cases 7285 7286 if Present (Spec_CTC_List (Contract (Spec_Id))) then 7287 Process_Contract_Cases (Spec_Id); 7288 end if; 7289 7290 -- Issue warning for functions whose postcondition does not mention 7291 -- 'Result after all postconditions have been processed, and provided 7292 -- all postconditions do not already get a warning that they only refer 7293 -- to pre-state. 7294 7295 if Ekind_In (Spec_Id, E_Function, E_Generic_Function) 7296 and then (Present (Last_Postcondition) 7297 or else Present (Last_Contract_Case)) 7298 and then not Attribute_Result_Mentioned 7299 and then No_Warning_On_Some_Postcondition 7300 then 7301 if Present (Last_Postcondition) then 7302 if Present (Last_Contract_Case) then 7303 Error_Msg_N 7304 ("neither function postcondition nor " 7305 & "contract cases mention result?T?", Last_Postcondition); 7306 7307 else 7308 Error_Msg_N 7309 ("function postcondition does not mention result?T?", 7310 Last_Postcondition); 7311 end if; 7312 else 7313 Error_Msg_N 7314 ("contract cases do not mention result?T?", Last_Contract_Case); 7315 end if; 7316 end if; 7317 end Check_Subprogram_Contract; 7318 7319 ---------------------------- 7320 -- Check_Subprogram_Order -- 7321 ---------------------------- 7322 7323 procedure Check_Subprogram_Order (N : Node_Id) is 7324 7325 function Subprogram_Name_Greater (S1, S2 : String) return Boolean; 7326 -- This is used to check if S1 > S2 in the sense required by this test, 7327 -- for example nameab < namec, but name2 < name10. 7328 7329 ----------------------------- 7330 -- Subprogram_Name_Greater -- 7331 ----------------------------- 7332 7333 function Subprogram_Name_Greater (S1, S2 : String) return Boolean is 7334 L1, L2 : Positive; 7335 N1, N2 : Natural; 7336 7337 begin 7338 -- Deal with special case where names are identical except for a 7339 -- numerical suffix. These are handled specially, taking the numeric 7340 -- ordering from the suffix into account. 7341 7342 L1 := S1'Last; 7343 while S1 (L1) in '0' .. '9' loop 7344 L1 := L1 - 1; 7345 end loop; 7346 7347 L2 := S2'Last; 7348 while S2 (L2) in '0' .. '9' loop 7349 L2 := L2 - 1; 7350 end loop; 7351 7352 -- If non-numeric parts non-equal, do straight compare 7353 7354 if S1 (S1'First .. L1) /= S2 (S2'First .. L2) then 7355 return S1 > S2; 7356 7357 -- If non-numeric parts equal, compare suffixed numeric parts. Note 7358 -- that a missing suffix is treated as numeric zero in this test. 7359 7360 else 7361 N1 := 0; 7362 while L1 < S1'Last loop 7363 L1 := L1 + 1; 7364 N1 := N1 * 10 + Character'Pos (S1 (L1)) - Character'Pos ('0'); 7365 end loop; 7366 7367 N2 := 0; 7368 while L2 < S2'Last loop 7369 L2 := L2 + 1; 7370 N2 := N2 * 10 + Character'Pos (S2 (L2)) - Character'Pos ('0'); 7371 end loop; 7372 7373 return N1 > N2; 7374 end if; 7375 end Subprogram_Name_Greater; 7376 7377 -- Start of processing for Check_Subprogram_Order 7378 7379 begin 7380 -- Check body in alpha order if this is option 7381 7382 if Style_Check 7383 and then Style_Check_Order_Subprograms 7384 and then Nkind (N) = N_Subprogram_Body 7385 and then Comes_From_Source (N) 7386 and then In_Extended_Main_Source_Unit (N) 7387 then 7388 declare 7389 LSN : String_Ptr 7390 renames Scope_Stack.Table 7391 (Scope_Stack.Last).Last_Subprogram_Name; 7392 7393 Body_Id : constant Entity_Id := 7394 Defining_Entity (Specification (N)); 7395 7396 begin 7397 Get_Decoded_Name_String (Chars (Body_Id)); 7398 7399 if LSN /= null then 7400 if Subprogram_Name_Greater 7401 (LSN.all, Name_Buffer (1 .. Name_Len)) 7402 then 7403 Style.Subprogram_Not_In_Alpha_Order (Body_Id); 7404 end if; 7405 7406 Free (LSN); 7407 end if; 7408 7409 LSN := new String'(Name_Buffer (1 .. Name_Len)); 7410 end; 7411 end if; 7412 end Check_Subprogram_Order; 7413 7414 ------------------------------ 7415 -- Check_Subtype_Conformant -- 7416 ------------------------------ 7417 7418 procedure Check_Subtype_Conformant 7419 (New_Id : Entity_Id; 7420 Old_Id : Entity_Id; 7421 Err_Loc : Node_Id := Empty; 7422 Skip_Controlling_Formals : Boolean := False; 7423 Get_Inst : Boolean := False) 7424 is 7425 Result : Boolean; 7426 pragma Warnings (Off, Result); 7427 begin 7428 Check_Conformance 7429 (New_Id, Old_Id, Subtype_Conformant, True, Result, Err_Loc, 7430 Skip_Controlling_Formals => Skip_Controlling_Formals, 7431 Get_Inst => Get_Inst); 7432 end Check_Subtype_Conformant; 7433 7434 --------------------------- 7435 -- Check_Type_Conformant -- 7436 --------------------------- 7437 7438 procedure Check_Type_Conformant 7439 (New_Id : Entity_Id; 7440 Old_Id : Entity_Id; 7441 Err_Loc : Node_Id := Empty) 7442 is 7443 Result : Boolean; 7444 pragma Warnings (Off, Result); 7445 begin 7446 Check_Conformance 7447 (New_Id, Old_Id, Type_Conformant, True, Result, Err_Loc); 7448 end Check_Type_Conformant; 7449 7450 --------------------------- 7451 -- Can_Override_Operator -- 7452 --------------------------- 7453 7454 function Can_Override_Operator (Subp : Entity_Id) return Boolean is 7455 Typ : Entity_Id; 7456 7457 begin 7458 if Nkind (Subp) /= N_Defining_Operator_Symbol then 7459 return False; 7460 7461 else 7462 Typ := Base_Type (Etype (First_Formal (Subp))); 7463 7464 -- Check explicitly that the operation is a primitive of the type 7465 7466 return Operator_Matches_Spec (Subp, Subp) 7467 and then not Is_Generic_Type (Typ) 7468 and then Scope (Subp) = Scope (Typ) 7469 and then not Is_Class_Wide_Type (Typ); 7470 end if; 7471 end Can_Override_Operator; 7472 7473 ---------------------- 7474 -- Conforming_Types -- 7475 ---------------------- 7476 7477 function Conforming_Types 7478 (T1 : Entity_Id; 7479 T2 : Entity_Id; 7480 Ctype : Conformance_Type; 7481 Get_Inst : Boolean := False) return Boolean 7482 is 7483 Type_1 : Entity_Id := T1; 7484 Type_2 : Entity_Id := T2; 7485 Are_Anonymous_Access_To_Subprogram_Types : Boolean := False; 7486 7487 function Base_Types_Match (T1, T2 : Entity_Id) return Boolean; 7488 -- If neither T1 nor T2 are generic actual types, or if they are in 7489 -- different scopes (e.g. parent and child instances), then verify that 7490 -- the base types are equal. Otherwise T1 and T2 must be on the same 7491 -- subtype chain. The whole purpose of this procedure is to prevent 7492 -- spurious ambiguities in an instantiation that may arise if two 7493 -- distinct generic types are instantiated with the same actual. 7494 7495 function Find_Designated_Type (T : Entity_Id) return Entity_Id; 7496 -- An access parameter can designate an incomplete type. If the 7497 -- incomplete type is the limited view of a type from a limited_ 7498 -- with_clause, check whether the non-limited view is available. If 7499 -- it is a (non-limited) incomplete type, get the full view. 7500 7501 function Matches_Limited_With_View (T1, T2 : Entity_Id) return Boolean; 7502 -- Returns True if and only if either T1 denotes a limited view of T2 7503 -- or T2 denotes a limited view of T1. This can arise when the limited 7504 -- with view of a type is used in a subprogram declaration and the 7505 -- subprogram body is in the scope of a regular with clause for the 7506 -- same unit. In such a case, the two type entities can be considered 7507 -- identical for purposes of conformance checking. 7508 7509 ---------------------- 7510 -- Base_Types_Match -- 7511 ---------------------- 7512 7513 function Base_Types_Match (T1, T2 : Entity_Id) return Boolean is 7514 begin 7515 if T1 = T2 then 7516 return True; 7517 7518 elsif Base_Type (T1) = Base_Type (T2) then 7519 7520 -- The following is too permissive. A more precise test should 7521 -- check that the generic actual is an ancestor subtype of the 7522 -- other ???. 7523 7524 -- See code in Find_Corresponding_Spec that applies an additional 7525 -- filter to handle accidental amiguities in instances. 7526 7527 return not Is_Generic_Actual_Type (T1) 7528 or else not Is_Generic_Actual_Type (T2) 7529 or else Scope (T1) /= Scope (T2); 7530 7531 else 7532 return False; 7533 end if; 7534 end Base_Types_Match; 7535 7536 -------------------------- 7537 -- Find_Designated_Type -- 7538 -------------------------- 7539 7540 function Find_Designated_Type (T : Entity_Id) return Entity_Id is 7541 Desig : Entity_Id; 7542 7543 begin 7544 Desig := Directly_Designated_Type (T); 7545 7546 if Ekind (Desig) = E_Incomplete_Type then 7547 7548 -- If regular incomplete type, get full view if available 7549 7550 if Present (Full_View (Desig)) then 7551 Desig := Full_View (Desig); 7552 7553 -- If limited view of a type, get non-limited view if available, 7554 -- and check again for a regular incomplete type. 7555 7556 elsif Present (Non_Limited_View (Desig)) then 7557 Desig := Get_Full_View (Non_Limited_View (Desig)); 7558 end if; 7559 end if; 7560 7561 return Desig; 7562 end Find_Designated_Type; 7563 7564 ------------------------------- 7565 -- Matches_Limited_With_View -- 7566 ------------------------------- 7567 7568 function Matches_Limited_With_View (T1, T2 : Entity_Id) return Boolean is 7569 begin 7570 -- In some cases a type imported through a limited_with clause, and 7571 -- its nonlimited view are both visible, for example in an anonymous 7572 -- access-to-class-wide type in a formal. Both entities designate the 7573 -- same type. 7574 7575 if From_With_Type (T1) 7576 and then T2 = Available_View (T1) 7577 then 7578 return True; 7579 7580 elsif From_With_Type (T2) 7581 and then T1 = Available_View (T2) 7582 then 7583 return True; 7584 7585 elsif From_With_Type (T1) 7586 and then From_With_Type (T2) 7587 and then Available_View (T1) = Available_View (T2) 7588 then 7589 return True; 7590 7591 else 7592 return False; 7593 end if; 7594 end Matches_Limited_With_View; 7595 7596 -- Start of processing for Conforming_Types 7597 7598 begin 7599 -- The context is an instance association for a formal 7600 -- access-to-subprogram type; the formal parameter types require 7601 -- mapping because they may denote other formal parameters of the 7602 -- generic unit. 7603 7604 if Get_Inst then 7605 Type_1 := Get_Instance_Of (T1); 7606 Type_2 := Get_Instance_Of (T2); 7607 end if; 7608 7609 -- If one of the types is a view of the other introduced by a limited 7610 -- with clause, treat these as conforming for all purposes. 7611 7612 if Matches_Limited_With_View (T1, T2) then 7613 return True; 7614 7615 elsif Base_Types_Match (Type_1, Type_2) then 7616 return Ctype <= Mode_Conformant 7617 or else Subtypes_Statically_Match (Type_1, Type_2); 7618 7619 elsif Is_Incomplete_Or_Private_Type (Type_1) 7620 and then Present (Full_View (Type_1)) 7621 and then Base_Types_Match (Full_View (Type_1), Type_2) 7622 then 7623 return Ctype <= Mode_Conformant 7624 or else Subtypes_Statically_Match (Full_View (Type_1), Type_2); 7625 7626 elsif Ekind (Type_2) = E_Incomplete_Type 7627 and then Present (Full_View (Type_2)) 7628 and then Base_Types_Match (Type_1, Full_View (Type_2)) 7629 then 7630 return Ctype <= Mode_Conformant 7631 or else Subtypes_Statically_Match (Type_1, Full_View (Type_2)); 7632 7633 elsif Is_Private_Type (Type_2) 7634 and then In_Instance 7635 and then Present (Full_View (Type_2)) 7636 and then Base_Types_Match (Type_1, Full_View (Type_2)) 7637 then 7638 return Ctype <= Mode_Conformant 7639 or else Subtypes_Statically_Match (Type_1, Full_View (Type_2)); 7640 end if; 7641 7642 -- Ada 2005 (AI-254): Anonymous access-to-subprogram types must be 7643 -- treated recursively because they carry a signature. 7644 7645 Are_Anonymous_Access_To_Subprogram_Types := 7646 Ekind (Type_1) = Ekind (Type_2) 7647 and then 7648 (Ekind (Type_1) = E_Anonymous_Access_Subprogram_Type 7649 or else 7650 Ekind (Type_1) = E_Anonymous_Access_Protected_Subprogram_Type); 7651 7652 -- Test anonymous access type case. For this case, static subtype 7653 -- matching is required for mode conformance (RM 6.3.1(15)). We check 7654 -- the base types because we may have built internal subtype entities 7655 -- to handle null-excluding types (see Process_Formals). 7656 7657 if (Ekind (Base_Type (Type_1)) = E_Anonymous_Access_Type 7658 and then 7659 Ekind (Base_Type (Type_2)) = E_Anonymous_Access_Type) 7660 or else Are_Anonymous_Access_To_Subprogram_Types -- Ada 2005 (AI-254) 7661 then 7662 declare 7663 Desig_1 : Entity_Id; 7664 Desig_2 : Entity_Id; 7665 7666 begin 7667 -- In Ada 2005, access constant indicators must match for 7668 -- subtype conformance. 7669 7670 if Ada_Version >= Ada_2005 7671 and then Ctype >= Subtype_Conformant 7672 and then 7673 Is_Access_Constant (Type_1) /= Is_Access_Constant (Type_2) 7674 then 7675 return False; 7676 end if; 7677 7678 Desig_1 := Find_Designated_Type (Type_1); 7679 Desig_2 := Find_Designated_Type (Type_2); 7680 7681 -- If the context is an instance association for a formal 7682 -- access-to-subprogram type; formal access parameter designated 7683 -- types require mapping because they may denote other formal 7684 -- parameters of the generic unit. 7685 7686 if Get_Inst then 7687 Desig_1 := Get_Instance_Of (Desig_1); 7688 Desig_2 := Get_Instance_Of (Desig_2); 7689 end if; 7690 7691 -- It is possible for a Class_Wide_Type to be introduced for an 7692 -- incomplete type, in which case there is a separate class_ wide 7693 -- type for the full view. The types conform if their Etypes 7694 -- conform, i.e. one may be the full view of the other. This can 7695 -- only happen in the context of an access parameter, other uses 7696 -- of an incomplete Class_Wide_Type are illegal. 7697 7698 if Is_Class_Wide_Type (Desig_1) 7699 and then 7700 Is_Class_Wide_Type (Desig_2) 7701 then 7702 return 7703 Conforming_Types 7704 (Etype (Base_Type (Desig_1)), 7705 Etype (Base_Type (Desig_2)), Ctype); 7706 7707 elsif Are_Anonymous_Access_To_Subprogram_Types then 7708 if Ada_Version < Ada_2005 then 7709 return Ctype = Type_Conformant 7710 or else 7711 Subtypes_Statically_Match (Desig_1, Desig_2); 7712 7713 -- We must check the conformance of the signatures themselves 7714 7715 else 7716 declare 7717 Conformant : Boolean; 7718 begin 7719 Check_Conformance 7720 (Desig_1, Desig_2, Ctype, False, Conformant); 7721 return Conformant; 7722 end; 7723 end if; 7724 7725 else 7726 return Base_Type (Desig_1) = Base_Type (Desig_2) 7727 and then (Ctype = Type_Conformant 7728 or else 7729 Subtypes_Statically_Match (Desig_1, Desig_2)); 7730 end if; 7731 end; 7732 7733 -- Otherwise definitely no match 7734 7735 else 7736 if ((Ekind (Type_1) = E_Anonymous_Access_Type 7737 and then Is_Access_Type (Type_2)) 7738 or else (Ekind (Type_2) = E_Anonymous_Access_Type 7739 and then Is_Access_Type (Type_1))) 7740 and then 7741 Conforming_Types 7742 (Designated_Type (Type_1), Designated_Type (Type_2), Ctype) 7743 then 7744 May_Hide_Profile := True; 7745 end if; 7746 7747 return False; 7748 end if; 7749 end Conforming_Types; 7750 7751 -------------------------- 7752 -- Create_Extra_Formals -- 7753 -------------------------- 7754 7755 procedure Create_Extra_Formals (E : Entity_Id) is 7756 Formal : Entity_Id; 7757 First_Extra : Entity_Id := Empty; 7758 Last_Extra : Entity_Id; 7759 Formal_Type : Entity_Id; 7760 P_Formal : Entity_Id := Empty; 7761 7762 function Add_Extra_Formal 7763 (Assoc_Entity : Entity_Id; 7764 Typ : Entity_Id; 7765 Scope : Entity_Id; 7766 Suffix : String) return Entity_Id; 7767 -- Add an extra formal to the current list of formals and extra formals. 7768 -- The extra formal is added to the end of the list of extra formals, 7769 -- and also returned as the result. These formals are always of mode IN. 7770 -- The new formal has the type Typ, is declared in Scope, and its name 7771 -- is given by a concatenation of the name of Assoc_Entity and Suffix. 7772 -- The following suffixes are currently used. They should not be changed 7773 -- without coordinating with CodePeer, which makes use of these to 7774 -- provide better messages. 7775 7776 -- O denotes the Constrained bit. 7777 -- L denotes the accessibility level. 7778 -- BIP_xxx denotes an extra formal for a build-in-place function. See 7779 -- the full list in exp_ch6.BIP_Formal_Kind. 7780 7781 ---------------------- 7782 -- Add_Extra_Formal -- 7783 ---------------------- 7784 7785 function Add_Extra_Formal 7786 (Assoc_Entity : Entity_Id; 7787 Typ : Entity_Id; 7788 Scope : Entity_Id; 7789 Suffix : String) return Entity_Id 7790 is 7791 EF : constant Entity_Id := 7792 Make_Defining_Identifier (Sloc (Assoc_Entity), 7793 Chars => New_External_Name (Chars (Assoc_Entity), 7794 Suffix => Suffix)); 7795 7796 begin 7797 -- A little optimization. Never generate an extra formal for the 7798 -- _init operand of an initialization procedure, since it could 7799 -- never be used. 7800 7801 if Chars (Formal) = Name_uInit then 7802 return Empty; 7803 end if; 7804 7805 Set_Ekind (EF, E_In_Parameter); 7806 Set_Actual_Subtype (EF, Typ); 7807 Set_Etype (EF, Typ); 7808 Set_Scope (EF, Scope); 7809 Set_Mechanism (EF, Default_Mechanism); 7810 Set_Formal_Validity (EF); 7811 7812 if No (First_Extra) then 7813 First_Extra := EF; 7814 Set_Extra_Formals (Scope, First_Extra); 7815 end if; 7816 7817 if Present (Last_Extra) then 7818 Set_Extra_Formal (Last_Extra, EF); 7819 end if; 7820 7821 Last_Extra := EF; 7822 7823 return EF; 7824 end Add_Extra_Formal; 7825 7826 -- Start of processing for Create_Extra_Formals 7827 7828 begin 7829 -- We never generate extra formals if expansion is not active 7830 -- because we don't need them unless we are generating code. 7831 7832 if not Expander_Active then 7833 return; 7834 end if; 7835 7836 -- If this is a derived subprogram then the subtypes of the parent 7837 -- subprogram's formal parameters will be used to determine the need 7838 -- for extra formals. 7839 7840 if Is_Overloadable (E) and then Present (Alias (E)) then 7841 P_Formal := First_Formal (Alias (E)); 7842 end if; 7843 7844 Last_Extra := Empty; 7845 Formal := First_Formal (E); 7846 while Present (Formal) loop 7847 Last_Extra := Formal; 7848 Next_Formal (Formal); 7849 end loop; 7850 7851 -- If Extra_formals were already created, don't do it again. This 7852 -- situation may arise for subprogram types created as part of 7853 -- dispatching calls (see Expand_Dispatching_Call) 7854 7855 if Present (Last_Extra) and then 7856 Present (Extra_Formal (Last_Extra)) 7857 then 7858 return; 7859 end if; 7860 7861 -- If the subprogram is a predefined dispatching subprogram then don't 7862 -- generate any extra constrained or accessibility level formals. In 7863 -- general we suppress these for internal subprograms (by not calling 7864 -- Freeze_Subprogram and Create_Extra_Formals at all), but internally 7865 -- generated stream attributes do get passed through because extra 7866 -- build-in-place formals are needed in some cases (limited 'Input). 7867 7868 if Is_Predefined_Internal_Operation (E) then 7869 goto Test_For_Func_Result_Extras; 7870 end if; 7871 7872 Formal := First_Formal (E); 7873 while Present (Formal) loop 7874 7875 -- Create extra formal for supporting the attribute 'Constrained. 7876 -- The case of a private type view without discriminants also 7877 -- requires the extra formal if the underlying type has defaulted 7878 -- discriminants. 7879 7880 if Ekind (Formal) /= E_In_Parameter then 7881 if Present (P_Formal) then 7882 Formal_Type := Etype (P_Formal); 7883 else 7884 Formal_Type := Etype (Formal); 7885 end if; 7886 7887 -- Do not produce extra formals for Unchecked_Union parameters. 7888 -- Jump directly to the end of the loop. 7889 7890 if Is_Unchecked_Union (Base_Type (Formal_Type)) then 7891 goto Skip_Extra_Formal_Generation; 7892 end if; 7893 7894 if not Has_Discriminants (Formal_Type) 7895 and then Ekind (Formal_Type) in Private_Kind 7896 and then Present (Underlying_Type (Formal_Type)) 7897 then 7898 Formal_Type := Underlying_Type (Formal_Type); 7899 end if; 7900 7901 -- Suppress the extra formal if formal's subtype is constrained or 7902 -- indefinite, or we're compiling for Ada 2012 and the underlying 7903 -- type is tagged and limited. In Ada 2012, a limited tagged type 7904 -- can have defaulted discriminants, but 'Constrained is required 7905 -- to return True, so the formal is never needed (see AI05-0214). 7906 -- Note that this ensures consistency of calling sequences for 7907 -- dispatching operations when some types in a class have defaults 7908 -- on discriminants and others do not (and requiring the extra 7909 -- formal would introduce distributed overhead). 7910 7911 if Has_Discriminants (Formal_Type) 7912 and then not Is_Constrained (Formal_Type) 7913 and then not Is_Indefinite_Subtype (Formal_Type) 7914 and then (Ada_Version < Ada_2012 7915 or else 7916 not (Is_Tagged_Type (Underlying_Type (Formal_Type)) 7917 and then Is_Limited_Type (Formal_Type))) 7918 then 7919 Set_Extra_Constrained 7920 (Formal, Add_Extra_Formal (Formal, Standard_Boolean, E, "O")); 7921 end if; 7922 end if; 7923 7924 -- Create extra formal for supporting accessibility checking. This 7925 -- is done for both anonymous access formals and formals of named 7926 -- access types that are marked as controlling formals. The latter 7927 -- case can occur when Expand_Dispatching_Call creates a subprogram 7928 -- type and substitutes the types of access-to-class-wide actuals 7929 -- for the anonymous access-to-specific-type of controlling formals. 7930 -- Base_Type is applied because in cases where there is a null 7931 -- exclusion the formal may have an access subtype. 7932 7933 -- This is suppressed if we specifically suppress accessibility 7934 -- checks at the package level for either the subprogram, or the 7935 -- package in which it resides. However, we do not suppress it 7936 -- simply if the scope has accessibility checks suppressed, since 7937 -- this could cause trouble when clients are compiled with a 7938 -- different suppression setting. The explicit checks at the 7939 -- package level are safe from this point of view. 7940 7941 if (Ekind (Base_Type (Etype (Formal))) = E_Anonymous_Access_Type 7942 or else (Is_Controlling_Formal (Formal) 7943 and then Is_Access_Type (Base_Type (Etype (Formal))))) 7944 and then not 7945 (Explicit_Suppress (E, Accessibility_Check) 7946 or else 7947 Explicit_Suppress (Scope (E), Accessibility_Check)) 7948 and then 7949 (No (P_Formal) 7950 or else Present (Extra_Accessibility (P_Formal))) 7951 then 7952 Set_Extra_Accessibility 7953 (Formal, Add_Extra_Formal (Formal, Standard_Natural, E, "L")); 7954 end if; 7955 7956 -- This label is required when skipping extra formal generation for 7957 -- Unchecked_Union parameters. 7958 7959 <<Skip_Extra_Formal_Generation>> 7960 7961 if Present (P_Formal) then 7962 Next_Formal (P_Formal); 7963 end if; 7964 7965 Next_Formal (Formal); 7966 end loop; 7967 7968 <<Test_For_Func_Result_Extras>> 7969 7970 -- Ada 2012 (AI05-234): "the accessibility level of the result of a 7971 -- function call is ... determined by the point of call ...". 7972 7973 if Needs_Result_Accessibility_Level (E) then 7974 Set_Extra_Accessibility_Of_Result 7975 (E, Add_Extra_Formal (E, Standard_Natural, E, "L")); 7976 end if; 7977 7978 -- Ada 2005 (AI-318-02): In the case of build-in-place functions, add 7979 -- appropriate extra formals. See type Exp_Ch6.BIP_Formal_Kind. 7980 7981 if Ada_Version >= Ada_2005 and then Is_Build_In_Place_Function (E) then 7982 declare 7983 Result_Subt : constant Entity_Id := Etype (E); 7984 Full_Subt : constant Entity_Id := Available_View (Result_Subt); 7985 Formal_Typ : Entity_Id; 7986 7987 Discard : Entity_Id; 7988 pragma Warnings (Off, Discard); 7989 7990 begin 7991 -- In the case of functions with unconstrained result subtypes, 7992 -- add a 4-state formal indicating whether the return object is 7993 -- allocated by the caller (1), or should be allocated by the 7994 -- callee on the secondary stack (2), in the global heap (3), or 7995 -- in a user-defined storage pool (4). For the moment we just use 7996 -- Natural for the type of this formal. Note that this formal 7997 -- isn't usually needed in the case where the result subtype is 7998 -- constrained, but it is needed when the function has a tagged 7999 -- result, because generally such functions can be called in a 8000 -- dispatching context and such calls must be handled like calls 8001 -- to a class-wide function. 8002 8003 if Needs_BIP_Alloc_Form (E) then 8004 Discard := 8005 Add_Extra_Formal 8006 (E, Standard_Natural, 8007 E, BIP_Formal_Suffix (BIP_Alloc_Form)); 8008 8009 -- Add BIP_Storage_Pool, in case BIP_Alloc_Form indicates to 8010 -- use a user-defined pool. This formal is not added on 8011 -- .NET/JVM/ZFP as those targets do not support pools. 8012 8013 if VM_Target = No_VM 8014 and then RTE_Available (RE_Root_Storage_Pool_Ptr) 8015 then 8016 Discard := 8017 Add_Extra_Formal 8018 (E, RTE (RE_Root_Storage_Pool_Ptr), 8019 E, BIP_Formal_Suffix (BIP_Storage_Pool)); 8020 end if; 8021 end if; 8022 8023 -- In the case of functions whose result type needs finalization, 8024 -- add an extra formal which represents the finalization master. 8025 8026 if Needs_BIP_Finalization_Master (E) then 8027 Discard := 8028 Add_Extra_Formal 8029 (E, RTE (RE_Finalization_Master_Ptr), 8030 E, BIP_Formal_Suffix (BIP_Finalization_Master)); 8031 end if; 8032 8033 -- When the result type contains tasks, add two extra formals: the 8034 -- master of the tasks to be created, and the caller's activation 8035 -- chain. 8036 8037 if Has_Task (Full_Subt) then 8038 Discard := 8039 Add_Extra_Formal 8040 (E, RTE (RE_Master_Id), 8041 E, BIP_Formal_Suffix (BIP_Task_Master)); 8042 Discard := 8043 Add_Extra_Formal 8044 (E, RTE (RE_Activation_Chain_Access), 8045 E, BIP_Formal_Suffix (BIP_Activation_Chain)); 8046 end if; 8047 8048 -- All build-in-place functions get an extra formal that will be 8049 -- passed the address of the return object within the caller. 8050 8051 Formal_Typ := 8052 Create_Itype (E_Anonymous_Access_Type, E, Scope_Id => Scope (E)); 8053 8054 Set_Directly_Designated_Type (Formal_Typ, Result_Subt); 8055 Set_Etype (Formal_Typ, Formal_Typ); 8056 Set_Depends_On_Private 8057 (Formal_Typ, Has_Private_Component (Formal_Typ)); 8058 Set_Is_Public (Formal_Typ, Is_Public (Scope (Formal_Typ))); 8059 Set_Is_Access_Constant (Formal_Typ, False); 8060 8061 -- Ada 2005 (AI-50217): Propagate the attribute that indicates 8062 -- the designated type comes from the limited view (for back-end 8063 -- purposes). 8064 8065 Set_From_With_Type (Formal_Typ, From_With_Type (Result_Subt)); 8066 8067 Layout_Type (Formal_Typ); 8068 8069 Discard := 8070 Add_Extra_Formal 8071 (E, Formal_Typ, E, BIP_Formal_Suffix (BIP_Object_Access)); 8072 end; 8073 end if; 8074 end Create_Extra_Formals; 8075 8076 ----------------------------- 8077 -- Enter_Overloaded_Entity -- 8078 ----------------------------- 8079 8080 procedure Enter_Overloaded_Entity (S : Entity_Id) is 8081 E : Entity_Id := Current_Entity_In_Scope (S); 8082 C_E : Entity_Id := Current_Entity (S); 8083 8084 begin 8085 if Present (E) then 8086 Set_Has_Homonym (E); 8087 Set_Has_Homonym (S); 8088 end if; 8089 8090 Set_Is_Immediately_Visible (S); 8091 Set_Scope (S, Current_Scope); 8092 8093 -- Chain new entity if front of homonym in current scope, so that 8094 -- homonyms are contiguous. 8095 8096 if Present (E) 8097 and then E /= C_E 8098 then 8099 while Homonym (C_E) /= E loop 8100 C_E := Homonym (C_E); 8101 end loop; 8102 8103 Set_Homonym (C_E, S); 8104 8105 else 8106 E := C_E; 8107 Set_Current_Entity (S); 8108 end if; 8109 8110 Set_Homonym (S, E); 8111 8112 if Is_Inherited_Operation (S) then 8113 Append_Inherited_Subprogram (S); 8114 else 8115 Append_Entity (S, Current_Scope); 8116 end if; 8117 8118 Set_Public_Status (S); 8119 8120 if Debug_Flag_E then 8121 Write_Str ("New overloaded entity chain: "); 8122 Write_Name (Chars (S)); 8123 8124 E := S; 8125 while Present (E) loop 8126 Write_Str (" "); Write_Int (Int (E)); 8127 E := Homonym (E); 8128 end loop; 8129 8130 Write_Eol; 8131 end if; 8132 8133 -- Generate warning for hiding 8134 8135 if Warn_On_Hiding 8136 and then Comes_From_Source (S) 8137 and then In_Extended_Main_Source_Unit (S) 8138 then 8139 E := S; 8140 loop 8141 E := Homonym (E); 8142 exit when No (E); 8143 8144 -- Warn unless genuine overloading. Do not emit warning on 8145 -- hiding predefined operators in Standard (these are either an 8146 -- (artifact of our implicit declarations, or simple noise) but 8147 -- keep warning on a operator defined on a local subtype, because 8148 -- of the real danger that different operators may be applied in 8149 -- various parts of the program. 8150 8151 -- Note that if E and S have the same scope, there is never any 8152 -- hiding. Either the two conflict, and the program is illegal, 8153 -- or S is overriding an implicit inherited subprogram. 8154 8155 if Scope (E) /= Scope (S) 8156 and then (not Is_Overloadable (E) 8157 or else Subtype_Conformant (E, S)) 8158 and then (Is_Immediately_Visible (E) 8159 or else 8160 Is_Potentially_Use_Visible (S)) 8161 then 8162 if Scope (E) /= Standard_Standard then 8163 Error_Msg_Sloc := Sloc (E); 8164 Error_Msg_N ("declaration of & hides one#?h?", S); 8165 8166 elsif Nkind (S) = N_Defining_Operator_Symbol 8167 and then 8168 Scope (Base_Type (Etype (First_Formal (S)))) /= Scope (S) 8169 then 8170 Error_Msg_N 8171 ("declaration of & hides predefined operator?h?", S); 8172 end if; 8173 end if; 8174 end loop; 8175 end if; 8176 end Enter_Overloaded_Entity; 8177 8178 ----------------------------- 8179 -- Check_Untagged_Equality -- 8180 ----------------------------- 8181 8182 procedure Check_Untagged_Equality (Eq_Op : Entity_Id) is 8183 Typ : constant Entity_Id := Etype (First_Formal (Eq_Op)); 8184 Decl : constant Node_Id := Unit_Declaration_Node (Eq_Op); 8185 Obj_Decl : Node_Id; 8186 8187 begin 8188 if Nkind (Decl) = N_Subprogram_Declaration 8189 and then Is_Record_Type (Typ) 8190 and then not Is_Tagged_Type (Typ) 8191 then 8192 -- If the type is not declared in a package, or if we are in the 8193 -- body of the package or in some other scope, the new operation is 8194 -- not primitive, and therefore legal, though suspicious. If the 8195 -- type is a generic actual (sub)type, the operation is not primitive 8196 -- either because the base type is declared elsewhere. 8197 8198 if Is_Frozen (Typ) then 8199 if Ekind (Scope (Typ)) /= E_Package 8200 or else Scope (Typ) /= Current_Scope 8201 then 8202 null; 8203 8204 elsif Is_Generic_Actual_Type (Typ) then 8205 null; 8206 8207 elsif In_Package_Body (Scope (Typ)) then 8208 Error_Msg_NE 8209 ("equality operator must be declared " 8210 & "before type& is frozen", Eq_Op, Typ); 8211 Error_Msg_N 8212 ("\move declaration to package spec", Eq_Op); 8213 8214 else 8215 Error_Msg_NE 8216 ("equality operator must be declared " 8217 & "before type& is frozen", Eq_Op, Typ); 8218 8219 Obj_Decl := Next (Parent (Typ)); 8220 while Present (Obj_Decl) and then Obj_Decl /= Decl loop 8221 if Nkind (Obj_Decl) = N_Object_Declaration 8222 and then Etype (Defining_Identifier (Obj_Decl)) = Typ 8223 then 8224 Error_Msg_NE 8225 ("type& is frozen by declaration??", Obj_Decl, Typ); 8226 Error_Msg_N 8227 ("\an equality operator cannot be declared after this " 8228 & "point (RM 4.5.2 (9.8)) (Ada 2012))??", Obj_Decl); 8229 exit; 8230 end if; 8231 8232 Next (Obj_Decl); 8233 end loop; 8234 end if; 8235 8236 elsif not In_Same_List (Parent (Typ), Decl) 8237 and then not Is_Limited_Type (Typ) 8238 then 8239 8240 -- This makes it illegal to have a primitive equality declared in 8241 -- the private part if the type is visible. 8242 8243 Error_Msg_N ("equality operator appears too late", Eq_Op); 8244 end if; 8245 end if; 8246 end Check_Untagged_Equality; 8247 8248 ----------------------------- 8249 -- Find_Corresponding_Spec -- 8250 ----------------------------- 8251 8252 function Find_Corresponding_Spec 8253 (N : Node_Id; 8254 Post_Error : Boolean := True) return Entity_Id 8255 is 8256 Spec : constant Node_Id := Specification (N); 8257 Designator : constant Entity_Id := Defining_Entity (Spec); 8258 8259 E : Entity_Id; 8260 8261 function Different_Generic_Profile (E : Entity_Id) return Boolean; 8262 -- Even if fully conformant, a body may depend on a generic actual when 8263 -- the spec does not, or vice versa, in which case they were distinct 8264 -- entities in the generic. 8265 8266 ------------------------------- 8267 -- Different_Generic_Profile -- 8268 ------------------------------- 8269 8270 function Different_Generic_Profile (E : Entity_Id) return Boolean is 8271 F1, F2 : Entity_Id; 8272 8273 begin 8274 if Ekind (E) = E_Function 8275 and then Is_Generic_Actual_Type (Etype (E)) /= 8276 Is_Generic_Actual_Type (Etype (Designator)) 8277 then 8278 return True; 8279 end if; 8280 8281 F1 := First_Formal (Designator); 8282 F2 := First_Formal (E); 8283 while Present (F1) loop 8284 if Is_Generic_Actual_Type (Etype (F1)) /= 8285 Is_Generic_Actual_Type (Etype (F2)) 8286 then 8287 return True; 8288 end if; 8289 8290 Next_Formal (F1); 8291 Next_Formal (F2); 8292 end loop; 8293 8294 return False; 8295 end Different_Generic_Profile; 8296 8297 -- Start of processing for Find_Corresponding_Spec 8298 8299 begin 8300 E := Current_Entity (Designator); 8301 while Present (E) loop 8302 8303 -- We are looking for a matching spec. It must have the same scope, 8304 -- and the same name, and either be type conformant, or be the case 8305 -- of a library procedure spec and its body (which belong to one 8306 -- another regardless of whether they are type conformant or not). 8307 8308 if Scope (E) = Current_Scope then 8309 if Current_Scope = Standard_Standard 8310 or else (Ekind (E) = Ekind (Designator) 8311 and then Type_Conformant (E, Designator)) 8312 then 8313 -- Within an instantiation, we know that spec and body are 8314 -- subtype conformant, because they were subtype conformant in 8315 -- the generic. We choose the subtype-conformant entity here as 8316 -- well, to resolve spurious ambiguities in the instance that 8317 -- were not present in the generic (i.e. when two different 8318 -- types are given the same actual). If we are looking for a 8319 -- spec to match a body, full conformance is expected. 8320 8321 if In_Instance then 8322 Set_Convention (Designator, Convention (E)); 8323 8324 -- Skip past subprogram bodies and subprogram renamings that 8325 -- may appear to have a matching spec, but that aren't fully 8326 -- conformant with it. That can occur in cases where an 8327 -- actual type causes unrelated homographs in the instance. 8328 8329 if Nkind_In (N, N_Subprogram_Body, 8330 N_Subprogram_Renaming_Declaration) 8331 and then Present (Homonym (E)) 8332 and then not Fully_Conformant (Designator, E) 8333 then 8334 goto Next_Entity; 8335 8336 elsif not Subtype_Conformant (Designator, E) then 8337 goto Next_Entity; 8338 8339 elsif Different_Generic_Profile (E) then 8340 goto Next_Entity; 8341 end if; 8342 end if; 8343 8344 -- Ada 2012 (AI05-0165): For internally generated bodies of 8345 -- null procedures locate the internally generated spec. We 8346 -- enforce mode conformance since a tagged type may inherit 8347 -- from interfaces several null primitives which differ only 8348 -- in the mode of the formals. 8349 8350 if not (Comes_From_Source (E)) 8351 and then Is_Null_Procedure (E) 8352 and then not Mode_Conformant (Designator, E) 8353 then 8354 null; 8355 8356 elsif not Has_Completion (E) then 8357 if Nkind (N) /= N_Subprogram_Body_Stub then 8358 Set_Corresponding_Spec (N, E); 8359 end if; 8360 8361 Set_Has_Completion (E); 8362 return E; 8363 8364 elsif Nkind (Parent (N)) = N_Subunit then 8365 8366 -- If this is the proper body of a subunit, the completion 8367 -- flag is set when analyzing the stub. 8368 8369 return E; 8370 8371 -- If E is an internal function with a controlling result that 8372 -- was created for an operation inherited by a null extension, 8373 -- it may be overridden by a body without a previous spec (one 8374 -- more reason why these should be shunned). In that case 8375 -- remove the generated body if present, because the current 8376 -- one is the explicit overriding. 8377 8378 elsif Ekind (E) = E_Function 8379 and then Ada_Version >= Ada_2005 8380 and then not Comes_From_Source (E) 8381 and then Has_Controlling_Result (E) 8382 and then Is_Null_Extension (Etype (E)) 8383 and then Comes_From_Source (Spec) 8384 then 8385 Set_Has_Completion (E, False); 8386 8387 if Expander_Active 8388 and then Nkind (Parent (E)) = N_Function_Specification 8389 then 8390 Remove 8391 (Unit_Declaration_Node 8392 (Corresponding_Body (Unit_Declaration_Node (E)))); 8393 8394 return E; 8395 8396 -- If expansion is disabled, or if the wrapper function has 8397 -- not been generated yet, this a late body overriding an 8398 -- inherited operation, or it is an overriding by some other 8399 -- declaration before the controlling result is frozen. In 8400 -- either case this is a declaration of a new entity. 8401 8402 else 8403 return Empty; 8404 end if; 8405 8406 -- If the body already exists, then this is an error unless 8407 -- the previous declaration is the implicit declaration of a 8408 -- derived subprogram. It is also legal for an instance to 8409 -- contain type conformant overloadable declarations (but the 8410 -- generic declaration may not), per 8.3(26/2). 8411 8412 elsif No (Alias (E)) 8413 and then not Is_Intrinsic_Subprogram (E) 8414 and then not In_Instance 8415 and then Post_Error 8416 then 8417 Error_Msg_Sloc := Sloc (E); 8418 8419 if Is_Imported (E) then 8420 Error_Msg_NE 8421 ("body not allowed for imported subprogram & declared#", 8422 N, E); 8423 else 8424 Error_Msg_NE ("duplicate body for & declared#", N, E); 8425 end if; 8426 end if; 8427 8428 -- Child units cannot be overloaded, so a conformance mismatch 8429 -- between body and a previous spec is an error. 8430 8431 elsif Is_Child_Unit (E) 8432 and then 8433 Nkind (Unit_Declaration_Node (Designator)) = N_Subprogram_Body 8434 and then 8435 Nkind (Parent (Unit_Declaration_Node (Designator))) = 8436 N_Compilation_Unit 8437 and then Post_Error 8438 then 8439 Error_Msg_N 8440 ("body of child unit does not match previous declaration", N); 8441 end if; 8442 end if; 8443 8444 <<Next_Entity>> 8445 E := Homonym (E); 8446 end loop; 8447 8448 -- On exit, we know that no previous declaration of subprogram exists 8449 8450 return Empty; 8451 end Find_Corresponding_Spec; 8452 8453 ---------------------- 8454 -- Fully_Conformant -- 8455 ---------------------- 8456 8457 function Fully_Conformant (New_Id, Old_Id : Entity_Id) return Boolean is 8458 Result : Boolean; 8459 begin 8460 Check_Conformance (New_Id, Old_Id, Fully_Conformant, False, Result); 8461 return Result; 8462 end Fully_Conformant; 8463 8464 ---------------------------------- 8465 -- Fully_Conformant_Expressions -- 8466 ---------------------------------- 8467 8468 function Fully_Conformant_Expressions 8469 (Given_E1 : Node_Id; 8470 Given_E2 : Node_Id) return Boolean 8471 is 8472 E1 : constant Node_Id := Original_Node (Given_E1); 8473 E2 : constant Node_Id := Original_Node (Given_E2); 8474 -- We always test conformance on original nodes, since it is possible 8475 -- for analysis and/or expansion to make things look as though they 8476 -- conform when they do not, e.g. by converting 1+2 into 3. 8477 8478 function FCE (Given_E1, Given_E2 : Node_Id) return Boolean 8479 renames Fully_Conformant_Expressions; 8480 8481 function FCL (L1, L2 : List_Id) return Boolean; 8482 -- Compare elements of two lists for conformance. Elements have to be 8483 -- conformant, and actuals inserted as default parameters do not match 8484 -- explicit actuals with the same value. 8485 8486 function FCO (Op_Node, Call_Node : Node_Id) return Boolean; 8487 -- Compare an operator node with a function call 8488 8489 --------- 8490 -- FCL -- 8491 --------- 8492 8493 function FCL (L1, L2 : List_Id) return Boolean is 8494 N1, N2 : Node_Id; 8495 8496 begin 8497 if L1 = No_List then 8498 N1 := Empty; 8499 else 8500 N1 := First (L1); 8501 end if; 8502 8503 if L2 = No_List then 8504 N2 := Empty; 8505 else 8506 N2 := First (L2); 8507 end if; 8508 8509 -- Compare two lists, skipping rewrite insertions (we want to compare 8510 -- the original trees, not the expanded versions!) 8511 8512 loop 8513 if Is_Rewrite_Insertion (N1) then 8514 Next (N1); 8515 elsif Is_Rewrite_Insertion (N2) then 8516 Next (N2); 8517 elsif No (N1) then 8518 return No (N2); 8519 elsif No (N2) then 8520 return False; 8521 elsif not FCE (N1, N2) then 8522 return False; 8523 else 8524 Next (N1); 8525 Next (N2); 8526 end if; 8527 end loop; 8528 end FCL; 8529 8530 --------- 8531 -- FCO -- 8532 --------- 8533 8534 function FCO (Op_Node, Call_Node : Node_Id) return Boolean is 8535 Actuals : constant List_Id := Parameter_Associations (Call_Node); 8536 Act : Node_Id; 8537 8538 begin 8539 if No (Actuals) 8540 or else Entity (Op_Node) /= Entity (Name (Call_Node)) 8541 then 8542 return False; 8543 8544 else 8545 Act := First (Actuals); 8546 8547 if Nkind (Op_Node) in N_Binary_Op then 8548 if not FCE (Left_Opnd (Op_Node), Act) then 8549 return False; 8550 end if; 8551 8552 Next (Act); 8553 end if; 8554 8555 return Present (Act) 8556 and then FCE (Right_Opnd (Op_Node), Act) 8557 and then No (Next (Act)); 8558 end if; 8559 end FCO; 8560 8561 -- Start of processing for Fully_Conformant_Expressions 8562 8563 begin 8564 -- Non-conformant if paren count does not match. Note: if some idiot 8565 -- complains that we don't do this right for more than 3 levels of 8566 -- parentheses, they will be treated with the respect they deserve! 8567 8568 if Paren_Count (E1) /= Paren_Count (E2) then 8569 return False; 8570 8571 -- If same entities are referenced, then they are conformant even if 8572 -- they have different forms (RM 8.3.1(19-20)). 8573 8574 elsif Is_Entity_Name (E1) and then Is_Entity_Name (E2) then 8575 if Present (Entity (E1)) then 8576 return Entity (E1) = Entity (E2) 8577 or else (Chars (Entity (E1)) = Chars (Entity (E2)) 8578 and then Ekind (Entity (E1)) = E_Discriminant 8579 and then Ekind (Entity (E2)) = E_In_Parameter); 8580 8581 elsif Nkind (E1) = N_Expanded_Name 8582 and then Nkind (E2) = N_Expanded_Name 8583 and then Nkind (Selector_Name (E1)) = N_Character_Literal 8584 and then Nkind (Selector_Name (E2)) = N_Character_Literal 8585 then 8586 return Chars (Selector_Name (E1)) = Chars (Selector_Name (E2)); 8587 8588 else 8589 -- Identifiers in component associations don't always have 8590 -- entities, but their names must conform. 8591 8592 return Nkind (E1) = N_Identifier 8593 and then Nkind (E2) = N_Identifier 8594 and then Chars (E1) = Chars (E2); 8595 end if; 8596 8597 elsif Nkind (E1) = N_Character_Literal 8598 and then Nkind (E2) = N_Expanded_Name 8599 then 8600 return Nkind (Selector_Name (E2)) = N_Character_Literal 8601 and then Chars (E1) = Chars (Selector_Name (E2)); 8602 8603 elsif Nkind (E2) = N_Character_Literal 8604 and then Nkind (E1) = N_Expanded_Name 8605 then 8606 return Nkind (Selector_Name (E1)) = N_Character_Literal 8607 and then Chars (E2) = Chars (Selector_Name (E1)); 8608 8609 elsif Nkind (E1) in N_Op 8610 and then Nkind (E2) = N_Function_Call 8611 then 8612 return FCO (E1, E2); 8613 8614 elsif Nkind (E2) in N_Op 8615 and then Nkind (E1) = N_Function_Call 8616 then 8617 return FCO (E2, E1); 8618 8619 -- Otherwise we must have the same syntactic entity 8620 8621 elsif Nkind (E1) /= Nkind (E2) then 8622 return False; 8623 8624 -- At this point, we specialize by node type 8625 8626 else 8627 case Nkind (E1) is 8628 8629 when N_Aggregate => 8630 return 8631 FCL (Expressions (E1), Expressions (E2)) 8632 and then 8633 FCL (Component_Associations (E1), 8634 Component_Associations (E2)); 8635 8636 when N_Allocator => 8637 if Nkind (Expression (E1)) = N_Qualified_Expression 8638 or else 8639 Nkind (Expression (E2)) = N_Qualified_Expression 8640 then 8641 return FCE (Expression (E1), Expression (E2)); 8642 8643 -- Check that the subtype marks and any constraints 8644 -- are conformant 8645 8646 else 8647 declare 8648 Indic1 : constant Node_Id := Expression (E1); 8649 Indic2 : constant Node_Id := Expression (E2); 8650 Elt1 : Node_Id; 8651 Elt2 : Node_Id; 8652 8653 begin 8654 if Nkind (Indic1) /= N_Subtype_Indication then 8655 return 8656 Nkind (Indic2) /= N_Subtype_Indication 8657 and then Entity (Indic1) = Entity (Indic2); 8658 8659 elsif Nkind (Indic2) /= N_Subtype_Indication then 8660 return 8661 Nkind (Indic1) /= N_Subtype_Indication 8662 and then Entity (Indic1) = Entity (Indic2); 8663 8664 else 8665 if Entity (Subtype_Mark (Indic1)) /= 8666 Entity (Subtype_Mark (Indic2)) 8667 then 8668 return False; 8669 end if; 8670 8671 Elt1 := First (Constraints (Constraint (Indic1))); 8672 Elt2 := First (Constraints (Constraint (Indic2))); 8673 while Present (Elt1) and then Present (Elt2) loop 8674 if not FCE (Elt1, Elt2) then 8675 return False; 8676 end if; 8677 8678 Next (Elt1); 8679 Next (Elt2); 8680 end loop; 8681 8682 return True; 8683 end if; 8684 end; 8685 end if; 8686 8687 when N_Attribute_Reference => 8688 return 8689 Attribute_Name (E1) = Attribute_Name (E2) 8690 and then FCL (Expressions (E1), Expressions (E2)); 8691 8692 when N_Binary_Op => 8693 return 8694 Entity (E1) = Entity (E2) 8695 and then FCE (Left_Opnd (E1), Left_Opnd (E2)) 8696 and then FCE (Right_Opnd (E1), Right_Opnd (E2)); 8697 8698 when N_Short_Circuit | N_Membership_Test => 8699 return 8700 FCE (Left_Opnd (E1), Left_Opnd (E2)) 8701 and then 8702 FCE (Right_Opnd (E1), Right_Opnd (E2)); 8703 8704 when N_Case_Expression => 8705 declare 8706 Alt1 : Node_Id; 8707 Alt2 : Node_Id; 8708 8709 begin 8710 if not FCE (Expression (E1), Expression (E2)) then 8711 return False; 8712 8713 else 8714 Alt1 := First (Alternatives (E1)); 8715 Alt2 := First (Alternatives (E2)); 8716 loop 8717 if Present (Alt1) /= Present (Alt2) then 8718 return False; 8719 elsif No (Alt1) then 8720 return True; 8721 end if; 8722 8723 if not FCE (Expression (Alt1), Expression (Alt2)) 8724 or else not FCL (Discrete_Choices (Alt1), 8725 Discrete_Choices (Alt2)) 8726 then 8727 return False; 8728 end if; 8729 8730 Next (Alt1); 8731 Next (Alt2); 8732 end loop; 8733 end if; 8734 end; 8735 8736 when N_Character_Literal => 8737 return 8738 Char_Literal_Value (E1) = Char_Literal_Value (E2); 8739 8740 when N_Component_Association => 8741 return 8742 FCL (Choices (E1), Choices (E2)) 8743 and then 8744 FCE (Expression (E1), Expression (E2)); 8745 8746 when N_Explicit_Dereference => 8747 return 8748 FCE (Prefix (E1), Prefix (E2)); 8749 8750 when N_Extension_Aggregate => 8751 return 8752 FCL (Expressions (E1), Expressions (E2)) 8753 and then Null_Record_Present (E1) = 8754 Null_Record_Present (E2) 8755 and then FCL (Component_Associations (E1), 8756 Component_Associations (E2)); 8757 8758 when N_Function_Call => 8759 return 8760 FCE (Name (E1), Name (E2)) 8761 and then 8762 FCL (Parameter_Associations (E1), 8763 Parameter_Associations (E2)); 8764 8765 when N_If_Expression => 8766 return 8767 FCL (Expressions (E1), Expressions (E2)); 8768 8769 when N_Indexed_Component => 8770 return 8771 FCE (Prefix (E1), Prefix (E2)) 8772 and then 8773 FCL (Expressions (E1), Expressions (E2)); 8774 8775 when N_Integer_Literal => 8776 return (Intval (E1) = Intval (E2)); 8777 8778 when N_Null => 8779 return True; 8780 8781 when N_Operator_Symbol => 8782 return 8783 Chars (E1) = Chars (E2); 8784 8785 when N_Others_Choice => 8786 return True; 8787 8788 when N_Parameter_Association => 8789 return 8790 Chars (Selector_Name (E1)) = Chars (Selector_Name (E2)) 8791 and then FCE (Explicit_Actual_Parameter (E1), 8792 Explicit_Actual_Parameter (E2)); 8793 8794 when N_Qualified_Expression => 8795 return 8796 FCE (Subtype_Mark (E1), Subtype_Mark (E2)) 8797 and then 8798 FCE (Expression (E1), Expression (E2)); 8799 8800 when N_Quantified_Expression => 8801 if not FCE (Condition (E1), Condition (E2)) then 8802 return False; 8803 end if; 8804 8805 if Present (Loop_Parameter_Specification (E1)) 8806 and then Present (Loop_Parameter_Specification (E2)) 8807 then 8808 declare 8809 L1 : constant Node_Id := 8810 Loop_Parameter_Specification (E1); 8811 L2 : constant Node_Id := 8812 Loop_Parameter_Specification (E2); 8813 8814 begin 8815 return 8816 Reverse_Present (L1) = Reverse_Present (L2) 8817 and then 8818 FCE (Defining_Identifier (L1), 8819 Defining_Identifier (L2)) 8820 and then 8821 FCE (Discrete_Subtype_Definition (L1), 8822 Discrete_Subtype_Definition (L2)); 8823 end; 8824 8825 elsif Present (Iterator_Specification (E1)) 8826 and then Present (Iterator_Specification (E2)) 8827 then 8828 declare 8829 I1 : constant Node_Id := Iterator_Specification (E1); 8830 I2 : constant Node_Id := Iterator_Specification (E2); 8831 8832 begin 8833 return 8834 FCE (Defining_Identifier (I1), 8835 Defining_Identifier (I2)) 8836 and then 8837 Of_Present (I1) = Of_Present (I2) 8838 and then 8839 Reverse_Present (I1) = Reverse_Present (I2) 8840 and then FCE (Name (I1), Name (I2)) 8841 and then FCE (Subtype_Indication (I1), 8842 Subtype_Indication (I2)); 8843 end; 8844 8845 -- The quantified expressions used different specifications to 8846 -- walk their respective ranges. 8847 8848 else 8849 return False; 8850 end if; 8851 8852 when N_Range => 8853 return 8854 FCE (Low_Bound (E1), Low_Bound (E2)) 8855 and then 8856 FCE (High_Bound (E1), High_Bound (E2)); 8857 8858 when N_Real_Literal => 8859 return (Realval (E1) = Realval (E2)); 8860 8861 when N_Selected_Component => 8862 return 8863 FCE (Prefix (E1), Prefix (E2)) 8864 and then 8865 FCE (Selector_Name (E1), Selector_Name (E2)); 8866 8867 when N_Slice => 8868 return 8869 FCE (Prefix (E1), Prefix (E2)) 8870 and then 8871 FCE (Discrete_Range (E1), Discrete_Range (E2)); 8872 8873 when N_String_Literal => 8874 declare 8875 S1 : constant String_Id := Strval (E1); 8876 S2 : constant String_Id := Strval (E2); 8877 L1 : constant Nat := String_Length (S1); 8878 L2 : constant Nat := String_Length (S2); 8879 8880 begin 8881 if L1 /= L2 then 8882 return False; 8883 8884 else 8885 for J in 1 .. L1 loop 8886 if Get_String_Char (S1, J) /= 8887 Get_String_Char (S2, J) 8888 then 8889 return False; 8890 end if; 8891 end loop; 8892 8893 return True; 8894 end if; 8895 end; 8896 8897 when N_Type_Conversion => 8898 return 8899 FCE (Subtype_Mark (E1), Subtype_Mark (E2)) 8900 and then 8901 FCE (Expression (E1), Expression (E2)); 8902 8903 when N_Unary_Op => 8904 return 8905 Entity (E1) = Entity (E2) 8906 and then 8907 FCE (Right_Opnd (E1), Right_Opnd (E2)); 8908 8909 when N_Unchecked_Type_Conversion => 8910 return 8911 FCE (Subtype_Mark (E1), Subtype_Mark (E2)) 8912 and then 8913 FCE (Expression (E1), Expression (E2)); 8914 8915 -- All other node types cannot appear in this context. Strictly 8916 -- we should raise a fatal internal error. Instead we just ignore 8917 -- the nodes. This means that if anyone makes a mistake in the 8918 -- expander and mucks an expression tree irretrievably, the 8919 -- result will be a failure to detect a (probably very obscure) 8920 -- case of non-conformance, which is better than bombing on some 8921 -- case where two expressions do in fact conform. 8922 8923 when others => 8924 return True; 8925 8926 end case; 8927 end if; 8928 end Fully_Conformant_Expressions; 8929 8930 ---------------------------------------- 8931 -- Fully_Conformant_Discrete_Subtypes -- 8932 ---------------------------------------- 8933 8934 function Fully_Conformant_Discrete_Subtypes 8935 (Given_S1 : Node_Id; 8936 Given_S2 : Node_Id) return Boolean 8937 is 8938 S1 : constant Node_Id := Original_Node (Given_S1); 8939 S2 : constant Node_Id := Original_Node (Given_S2); 8940 8941 function Conforming_Bounds (B1, B2 : Node_Id) return Boolean; 8942 -- Special-case for a bound given by a discriminant, which in the body 8943 -- is replaced with the discriminal of the enclosing type. 8944 8945 function Conforming_Ranges (R1, R2 : Node_Id) return Boolean; 8946 -- Check both bounds 8947 8948 ----------------------- 8949 -- Conforming_Bounds -- 8950 ----------------------- 8951 8952 function Conforming_Bounds (B1, B2 : Node_Id) return Boolean is 8953 begin 8954 if Is_Entity_Name (B1) 8955 and then Is_Entity_Name (B2) 8956 and then Ekind (Entity (B1)) = E_Discriminant 8957 then 8958 return Chars (B1) = Chars (B2); 8959 8960 else 8961 return Fully_Conformant_Expressions (B1, B2); 8962 end if; 8963 end Conforming_Bounds; 8964 8965 ----------------------- 8966 -- Conforming_Ranges -- 8967 ----------------------- 8968 8969 function Conforming_Ranges (R1, R2 : Node_Id) return Boolean is 8970 begin 8971 return 8972 Conforming_Bounds (Low_Bound (R1), Low_Bound (R2)) 8973 and then 8974 Conforming_Bounds (High_Bound (R1), High_Bound (R2)); 8975 end Conforming_Ranges; 8976 8977 -- Start of processing for Fully_Conformant_Discrete_Subtypes 8978 8979 begin 8980 if Nkind (S1) /= Nkind (S2) then 8981 return False; 8982 8983 elsif Is_Entity_Name (S1) then 8984 return Entity (S1) = Entity (S2); 8985 8986 elsif Nkind (S1) = N_Range then 8987 return Conforming_Ranges (S1, S2); 8988 8989 elsif Nkind (S1) = N_Subtype_Indication then 8990 return 8991 Entity (Subtype_Mark (S1)) = Entity (Subtype_Mark (S2)) 8992 and then 8993 Conforming_Ranges 8994 (Range_Expression (Constraint (S1)), 8995 Range_Expression (Constraint (S2))); 8996 else 8997 return True; 8998 end if; 8999 end Fully_Conformant_Discrete_Subtypes; 9000 9001 -------------------- 9002 -- Install_Entity -- 9003 -------------------- 9004 9005 procedure Install_Entity (E : Entity_Id) is 9006 Prev : constant Entity_Id := Current_Entity (E); 9007 begin 9008 Set_Is_Immediately_Visible (E); 9009 Set_Current_Entity (E); 9010 Set_Homonym (E, Prev); 9011 end Install_Entity; 9012 9013 --------------------- 9014 -- Install_Formals -- 9015 --------------------- 9016 9017 procedure Install_Formals (Id : Entity_Id) is 9018 F : Entity_Id; 9019 begin 9020 F := First_Formal (Id); 9021 while Present (F) loop 9022 Install_Entity (F); 9023 Next_Formal (F); 9024 end loop; 9025 end Install_Formals; 9026 9027 ----------------------------- 9028 -- Is_Interface_Conformant -- 9029 ----------------------------- 9030 9031 function Is_Interface_Conformant 9032 (Tagged_Type : Entity_Id; 9033 Iface_Prim : Entity_Id; 9034 Prim : Entity_Id) return Boolean 9035 is 9036 Iface : constant Entity_Id := Find_Dispatching_Type (Iface_Prim); 9037 Typ : constant Entity_Id := Find_Dispatching_Type (Prim); 9038 9039 function Controlling_Formal (Prim : Entity_Id) return Entity_Id; 9040 -- Return the controlling formal of Prim 9041 9042 ------------------------ 9043 -- Controlling_Formal -- 9044 ------------------------ 9045 9046 function Controlling_Formal (Prim : Entity_Id) return Entity_Id is 9047 E : Entity_Id := First_Entity (Prim); 9048 9049 begin 9050 while Present (E) loop 9051 if Is_Formal (E) and then Is_Controlling_Formal (E) then 9052 return E; 9053 end if; 9054 9055 Next_Entity (E); 9056 end loop; 9057 9058 return Empty; 9059 end Controlling_Formal; 9060 9061 -- Local variables 9062 9063 Iface_Ctrl_F : constant Entity_Id := Controlling_Formal (Iface_Prim); 9064 Prim_Ctrl_F : constant Entity_Id := Controlling_Formal (Prim); 9065 9066 -- Start of processing for Is_Interface_Conformant 9067 9068 begin 9069 pragma Assert (Is_Subprogram (Iface_Prim) 9070 and then Is_Subprogram (Prim) 9071 and then Is_Dispatching_Operation (Iface_Prim) 9072 and then Is_Dispatching_Operation (Prim)); 9073 9074 pragma Assert (Is_Interface (Iface) 9075 or else (Present (Alias (Iface_Prim)) 9076 and then 9077 Is_Interface 9078 (Find_Dispatching_Type (Ultimate_Alias (Iface_Prim))))); 9079 9080 if Prim = Iface_Prim 9081 or else not Is_Subprogram (Prim) 9082 or else Ekind (Prim) /= Ekind (Iface_Prim) 9083 or else not Is_Dispatching_Operation (Prim) 9084 or else Scope (Prim) /= Scope (Tagged_Type) 9085 or else No (Typ) 9086 or else Base_Type (Typ) /= Base_Type (Tagged_Type) 9087 or else not Primitive_Names_Match (Iface_Prim, Prim) 9088 then 9089 return False; 9090 9091 -- The mode of the controlling formals must match 9092 9093 elsif Present (Iface_Ctrl_F) 9094 and then Present (Prim_Ctrl_F) 9095 and then Ekind (Iface_Ctrl_F) /= Ekind (Prim_Ctrl_F) 9096 then 9097 return False; 9098 9099 -- Case of a procedure, or a function whose result type matches the 9100 -- result type of the interface primitive, or a function that has no 9101 -- controlling result (I or access I). 9102 9103 elsif Ekind (Iface_Prim) = E_Procedure 9104 or else Etype (Prim) = Etype (Iface_Prim) 9105 or else not Has_Controlling_Result (Prim) 9106 then 9107 return Type_Conformant 9108 (Iface_Prim, Prim, Skip_Controlling_Formals => True); 9109 9110 -- Case of a function returning an interface, or an access to one. 9111 -- Check that the return types correspond. 9112 9113 elsif Implements_Interface (Typ, Iface) then 9114 if (Ekind (Etype (Prim)) = E_Anonymous_Access_Type) 9115 /= 9116 (Ekind (Etype (Iface_Prim)) = E_Anonymous_Access_Type) 9117 then 9118 return False; 9119 else 9120 return 9121 Type_Conformant (Prim, Iface_Prim, 9122 Skip_Controlling_Formals => True); 9123 end if; 9124 9125 else 9126 return False; 9127 end if; 9128 end Is_Interface_Conformant; 9129 9130 --------------------------------- 9131 -- Is_Non_Overriding_Operation -- 9132 --------------------------------- 9133 9134 function Is_Non_Overriding_Operation 9135 (Prev_E : Entity_Id; 9136 New_E : Entity_Id) return Boolean 9137 is 9138 Formal : Entity_Id; 9139 F_Typ : Entity_Id; 9140 G_Typ : Entity_Id := Empty; 9141 9142 function Get_Generic_Parent_Type (F_Typ : Entity_Id) return Entity_Id; 9143 -- If F_Type is a derived type associated with a generic actual subtype, 9144 -- then return its Generic_Parent_Type attribute, else return Empty. 9145 9146 function Types_Correspond 9147 (P_Type : Entity_Id; 9148 N_Type : Entity_Id) return Boolean; 9149 -- Returns true if and only if the types (or designated types in the 9150 -- case of anonymous access types) are the same or N_Type is derived 9151 -- directly or indirectly from P_Type. 9152 9153 ----------------------------- 9154 -- Get_Generic_Parent_Type -- 9155 ----------------------------- 9156 9157 function Get_Generic_Parent_Type (F_Typ : Entity_Id) return Entity_Id is 9158 G_Typ : Entity_Id; 9159 Defn : Node_Id; 9160 Indic : Node_Id; 9161 9162 begin 9163 if Is_Derived_Type (F_Typ) 9164 and then Nkind (Parent (F_Typ)) = N_Full_Type_Declaration 9165 then 9166 -- The tree must be traversed to determine the parent subtype in 9167 -- the generic unit, which unfortunately isn't always available 9168 -- via semantic attributes. ??? (Note: The use of Original_Node 9169 -- is needed for cases where a full derived type has been 9170 -- rewritten.) 9171 9172 Defn := Type_Definition (Original_Node (Parent (F_Typ))); 9173 if Nkind (Defn) = N_Derived_Type_Definition then 9174 Indic := Subtype_Indication (Defn); 9175 9176 if Nkind (Indic) = N_Subtype_Indication then 9177 G_Typ := Entity (Subtype_Mark (Indic)); 9178 else 9179 G_Typ := Entity (Indic); 9180 end if; 9181 9182 if Nkind (Parent (G_Typ)) = N_Subtype_Declaration 9183 and then Present (Generic_Parent_Type (Parent (G_Typ))) 9184 then 9185 return Generic_Parent_Type (Parent (G_Typ)); 9186 end if; 9187 end if; 9188 end if; 9189 9190 return Empty; 9191 end Get_Generic_Parent_Type; 9192 9193 ---------------------- 9194 -- Types_Correspond -- 9195 ---------------------- 9196 9197 function Types_Correspond 9198 (P_Type : Entity_Id; 9199 N_Type : Entity_Id) return Boolean 9200 is 9201 Prev_Type : Entity_Id := Base_Type (P_Type); 9202 New_Type : Entity_Id := Base_Type (N_Type); 9203 9204 begin 9205 if Ekind (Prev_Type) = E_Anonymous_Access_Type then 9206 Prev_Type := Designated_Type (Prev_Type); 9207 end if; 9208 9209 if Ekind (New_Type) = E_Anonymous_Access_Type then 9210 New_Type := Designated_Type (New_Type); 9211 end if; 9212 9213 if Prev_Type = New_Type then 9214 return True; 9215 9216 elsif not Is_Class_Wide_Type (New_Type) then 9217 while Etype (New_Type) /= New_Type loop 9218 New_Type := Etype (New_Type); 9219 if New_Type = Prev_Type then 9220 return True; 9221 end if; 9222 end loop; 9223 end if; 9224 return False; 9225 end Types_Correspond; 9226 9227 -- Start of processing for Is_Non_Overriding_Operation 9228 9229 begin 9230 -- In the case where both operations are implicit derived subprograms 9231 -- then neither overrides the other. This can only occur in certain 9232 -- obscure cases (e.g., derivation from homographs created in a generic 9233 -- instantiation). 9234 9235 if Present (Alias (Prev_E)) and then Present (Alias (New_E)) then 9236 return True; 9237 9238 elsif Ekind (Current_Scope) = E_Package 9239 and then Is_Generic_Instance (Current_Scope) 9240 and then In_Private_Part (Current_Scope) 9241 and then Comes_From_Source (New_E) 9242 then 9243 -- We examine the formals and result type of the inherited operation, 9244 -- to determine whether their type is derived from (the instance of) 9245 -- a generic type. The first such formal or result type is the one 9246 -- tested. 9247 9248 Formal := First_Formal (Prev_E); 9249 while Present (Formal) loop 9250 F_Typ := Base_Type (Etype (Formal)); 9251 9252 if Ekind (F_Typ) = E_Anonymous_Access_Type then 9253 F_Typ := Designated_Type (F_Typ); 9254 end if; 9255 9256 G_Typ := Get_Generic_Parent_Type (F_Typ); 9257 exit when Present (G_Typ); 9258 9259 Next_Formal (Formal); 9260 end loop; 9261 9262 if No (G_Typ) and then Ekind (Prev_E) = E_Function then 9263 G_Typ := Get_Generic_Parent_Type (Base_Type (Etype (Prev_E))); 9264 end if; 9265 9266 if No (G_Typ) then 9267 return False; 9268 end if; 9269 9270 -- If the generic type is a private type, then the original operation 9271 -- was not overriding in the generic, because there was no primitive 9272 -- operation to override. 9273 9274 if Nkind (Parent (G_Typ)) = N_Formal_Type_Declaration 9275 and then Nkind (Formal_Type_Definition (Parent (G_Typ))) = 9276 N_Formal_Private_Type_Definition 9277 then 9278 return True; 9279 9280 -- The generic parent type is the ancestor of a formal derived 9281 -- type declaration. We need to check whether it has a primitive 9282 -- operation that should be overridden by New_E in the generic. 9283 9284 else 9285 declare 9286 P_Formal : Entity_Id; 9287 N_Formal : Entity_Id; 9288 P_Typ : Entity_Id; 9289 N_Typ : Entity_Id; 9290 P_Prim : Entity_Id; 9291 Prim_Elt : Elmt_Id := First_Elmt (Primitive_Operations (G_Typ)); 9292 9293 begin 9294 while Present (Prim_Elt) loop 9295 P_Prim := Node (Prim_Elt); 9296 9297 if Chars (P_Prim) = Chars (New_E) 9298 and then Ekind (P_Prim) = Ekind (New_E) 9299 then 9300 P_Formal := First_Formal (P_Prim); 9301 N_Formal := First_Formal (New_E); 9302 while Present (P_Formal) and then Present (N_Formal) loop 9303 P_Typ := Etype (P_Formal); 9304 N_Typ := Etype (N_Formal); 9305 9306 if not Types_Correspond (P_Typ, N_Typ) then 9307 exit; 9308 end if; 9309 9310 Next_Entity (P_Formal); 9311 Next_Entity (N_Formal); 9312 end loop; 9313 9314 -- Found a matching primitive operation belonging to the 9315 -- formal ancestor type, so the new subprogram is 9316 -- overriding. 9317 9318 if No (P_Formal) 9319 and then No (N_Formal) 9320 and then (Ekind (New_E) /= E_Function 9321 or else 9322 Types_Correspond 9323 (Etype (P_Prim), Etype (New_E))) 9324 then 9325 return False; 9326 end if; 9327 end if; 9328 9329 Next_Elmt (Prim_Elt); 9330 end loop; 9331 9332 -- If no match found, then the new subprogram does not 9333 -- override in the generic (nor in the instance). 9334 9335 -- If the type in question is not abstract, and the subprogram 9336 -- is, this will be an error if the new operation is in the 9337 -- private part of the instance. Emit a warning now, which will 9338 -- make the subsequent error message easier to understand. 9339 9340 if not Is_Abstract_Type (F_Typ) 9341 and then Is_Abstract_Subprogram (Prev_E) 9342 and then In_Private_Part (Current_Scope) 9343 then 9344 Error_Msg_Node_2 := F_Typ; 9345 Error_Msg_NE 9346 ("private operation& in generic unit does not override " & 9347 "any primitive operation of& (RM 12.3 (18))??", 9348 New_E, New_E); 9349 end if; 9350 9351 return True; 9352 end; 9353 end if; 9354 else 9355 return False; 9356 end if; 9357 end Is_Non_Overriding_Operation; 9358 9359 ------------------------------------- 9360 -- List_Inherited_Pre_Post_Aspects -- 9361 ------------------------------------- 9362 9363 procedure List_Inherited_Pre_Post_Aspects (E : Entity_Id) is 9364 begin 9365 if Opt.List_Inherited_Aspects 9366 and then (Is_Subprogram (E) or else Is_Generic_Subprogram (E)) 9367 then 9368 declare 9369 Inherited : constant Subprogram_List := Inherited_Subprograms (E); 9370 P : Node_Id; 9371 9372 begin 9373 for J in Inherited'Range loop 9374 P := Spec_PPC_List (Contract (Inherited (J))); 9375 while Present (P) loop 9376 Error_Msg_Sloc := Sloc (P); 9377 9378 if Class_Present (P) and then not Split_PPC (P) then 9379 if Pragma_Name (P) = Name_Precondition then 9380 Error_Msg_N 9381 ("info: & inherits `Pre''Class` aspect from #?L?", 9382 E); 9383 else 9384 Error_Msg_N 9385 ("info: & inherits `Post''Class` aspect from #?L?", 9386 E); 9387 end if; 9388 end if; 9389 9390 P := Next_Pragma (P); 9391 end loop; 9392 end loop; 9393 end; 9394 end if; 9395 end List_Inherited_Pre_Post_Aspects; 9396 9397 ------------------------------ 9398 -- Make_Inequality_Operator -- 9399 ------------------------------ 9400 9401 -- S is the defining identifier of an equality operator. We build a 9402 -- subprogram declaration with the right signature. This operation is 9403 -- intrinsic, because it is always expanded as the negation of the 9404 -- call to the equality function. 9405 9406 procedure Make_Inequality_Operator (S : Entity_Id) is 9407 Loc : constant Source_Ptr := Sloc (S); 9408 Decl : Node_Id; 9409 Formals : List_Id; 9410 Op_Name : Entity_Id; 9411 9412 FF : constant Entity_Id := First_Formal (S); 9413 NF : constant Entity_Id := Next_Formal (FF); 9414 9415 begin 9416 -- Check that equality was properly defined, ignore call if not 9417 9418 if No (NF) then 9419 return; 9420 end if; 9421 9422 declare 9423 A : constant Entity_Id := 9424 Make_Defining_Identifier (Sloc (FF), 9425 Chars => Chars (FF)); 9426 9427 B : constant Entity_Id := 9428 Make_Defining_Identifier (Sloc (NF), 9429 Chars => Chars (NF)); 9430 9431 begin 9432 Op_Name := Make_Defining_Operator_Symbol (Loc, Name_Op_Ne); 9433 9434 Formals := New_List ( 9435 Make_Parameter_Specification (Loc, 9436 Defining_Identifier => A, 9437 Parameter_Type => 9438 New_Reference_To (Etype (First_Formal (S)), 9439 Sloc (Etype (First_Formal (S))))), 9440 9441 Make_Parameter_Specification (Loc, 9442 Defining_Identifier => B, 9443 Parameter_Type => 9444 New_Reference_To (Etype (Next_Formal (First_Formal (S))), 9445 Sloc (Etype (Next_Formal (First_Formal (S))))))); 9446 9447 Decl := 9448 Make_Subprogram_Declaration (Loc, 9449 Specification => 9450 Make_Function_Specification (Loc, 9451 Defining_Unit_Name => Op_Name, 9452 Parameter_Specifications => Formals, 9453 Result_Definition => 9454 New_Reference_To (Standard_Boolean, Loc))); 9455 9456 -- Insert inequality right after equality if it is explicit or after 9457 -- the derived type when implicit. These entities are created only 9458 -- for visibility purposes, and eventually replaced in the course of 9459 -- expansion, so they do not need to be attached to the tree and seen 9460 -- by the back-end. Keeping them internal also avoids spurious 9461 -- freezing problems. The declaration is inserted in the tree for 9462 -- analysis, and removed afterwards. If the equality operator comes 9463 -- from an explicit declaration, attach the inequality immediately 9464 -- after. Else the equality is inherited from a derived type 9465 -- declaration, so insert inequality after that declaration. 9466 9467 if No (Alias (S)) then 9468 Insert_After (Unit_Declaration_Node (S), Decl); 9469 elsif Is_List_Member (Parent (S)) then 9470 Insert_After (Parent (S), Decl); 9471 else 9472 Insert_After (Parent (Etype (First_Formal (S))), Decl); 9473 end if; 9474 9475 Mark_Rewrite_Insertion (Decl); 9476 Set_Is_Intrinsic_Subprogram (Op_Name); 9477 Analyze (Decl); 9478 Remove (Decl); 9479 Set_Has_Completion (Op_Name); 9480 Set_Corresponding_Equality (Op_Name, S); 9481 Set_Is_Abstract_Subprogram (Op_Name, Is_Abstract_Subprogram (S)); 9482 end; 9483 end Make_Inequality_Operator; 9484 9485 ---------------------- 9486 -- May_Need_Actuals -- 9487 ---------------------- 9488 9489 procedure May_Need_Actuals (Fun : Entity_Id) is 9490 F : Entity_Id; 9491 B : Boolean; 9492 9493 begin 9494 F := First_Formal (Fun); 9495 B := True; 9496 while Present (F) loop 9497 if No (Default_Value (F)) then 9498 B := False; 9499 exit; 9500 end if; 9501 9502 Next_Formal (F); 9503 end loop; 9504 9505 Set_Needs_No_Actuals (Fun, B); 9506 end May_Need_Actuals; 9507 9508 --------------------- 9509 -- Mode_Conformant -- 9510 --------------------- 9511 9512 function Mode_Conformant (New_Id, Old_Id : Entity_Id) return Boolean is 9513 Result : Boolean; 9514 begin 9515 Check_Conformance (New_Id, Old_Id, Mode_Conformant, False, Result); 9516 return Result; 9517 end Mode_Conformant; 9518 9519 --------------------------- 9520 -- New_Overloaded_Entity -- 9521 --------------------------- 9522 9523 procedure New_Overloaded_Entity 9524 (S : Entity_Id; 9525 Derived_Type : Entity_Id := Empty) 9526 is 9527 Overridden_Subp : Entity_Id := Empty; 9528 -- Set if the current scope has an operation that is type-conformant 9529 -- with S, and becomes hidden by S. 9530 9531 Is_Primitive_Subp : Boolean; 9532 -- Set to True if the new subprogram is primitive 9533 9534 E : Entity_Id; 9535 -- Entity that S overrides 9536 9537 Prev_Vis : Entity_Id := Empty; 9538 -- Predecessor of E in Homonym chain 9539 9540 procedure Check_For_Primitive_Subprogram 9541 (Is_Primitive : out Boolean; 9542 Is_Overriding : Boolean := False); 9543 -- If the subprogram being analyzed is a primitive operation of the type 9544 -- of a formal or result, set the Has_Primitive_Operations flag on the 9545 -- type, and set Is_Primitive to True (otherwise set to False). Set the 9546 -- corresponding flag on the entity itself for later use. 9547 9548 procedure Check_Synchronized_Overriding 9549 (Def_Id : Entity_Id; 9550 Overridden_Subp : out Entity_Id); 9551 -- First determine if Def_Id is an entry or a subprogram either defined 9552 -- in the scope of a task or protected type, or is a primitive of such 9553 -- a type. Check whether Def_Id overrides a subprogram of an interface 9554 -- implemented by the synchronized type, return the overridden entity 9555 -- or Empty. 9556 9557 function Is_Private_Declaration (E : Entity_Id) return Boolean; 9558 -- Check that E is declared in the private part of the current package, 9559 -- or in the package body, where it may hide a previous declaration. 9560 -- We can't use In_Private_Part by itself because this flag is also 9561 -- set when freezing entities, so we must examine the place of the 9562 -- declaration in the tree, and recognize wrapper packages as well. 9563 9564 function Is_Overriding_Alias 9565 (Old_E : Entity_Id; 9566 New_E : Entity_Id) return Boolean; 9567 -- Check whether new subprogram and old subprogram are both inherited 9568 -- from subprograms that have distinct dispatch table entries. This can 9569 -- occur with derivations from instances with accidental homonyms. 9570 -- The function is conservative given that the converse is only true 9571 -- within instances that contain accidental overloadings. 9572 9573 ------------------------------------ 9574 -- Check_For_Primitive_Subprogram -- 9575 ------------------------------------ 9576 9577 procedure Check_For_Primitive_Subprogram 9578 (Is_Primitive : out Boolean; 9579 Is_Overriding : Boolean := False) 9580 is 9581 Formal : Entity_Id; 9582 F_Typ : Entity_Id; 9583 B_Typ : Entity_Id; 9584 9585 function Visible_Part_Type (T : Entity_Id) return Boolean; 9586 -- Returns true if T is declared in the visible part of the current 9587 -- package scope; otherwise returns false. Assumes that T is declared 9588 -- in a package. 9589 9590 procedure Check_Private_Overriding (T : Entity_Id); 9591 -- Checks that if a primitive abstract subprogram of a visible 9592 -- abstract type is declared in a private part, then it must override 9593 -- an abstract subprogram declared in the visible part. Also checks 9594 -- that if a primitive function with a controlling result is declared 9595 -- in a private part, then it must override a function declared in 9596 -- the visible part. 9597 9598 ------------------------------ 9599 -- Check_Private_Overriding -- 9600 ------------------------------ 9601 9602 procedure Check_Private_Overriding (T : Entity_Id) is 9603 begin 9604 if Is_Package_Or_Generic_Package (Current_Scope) 9605 and then In_Private_Part (Current_Scope) 9606 and then Visible_Part_Type (T) 9607 and then not In_Instance 9608 then 9609 if Is_Abstract_Type (T) 9610 and then Is_Abstract_Subprogram (S) 9611 and then (not Is_Overriding 9612 or else not Is_Abstract_Subprogram (E)) 9613 then 9614 Error_Msg_N 9615 ("abstract subprograms must be visible " 9616 & "(RM 3.9.3(10))!", S); 9617 9618 elsif Ekind (S) = E_Function 9619 and then not Is_Overriding 9620 then 9621 if Is_Tagged_Type (T) 9622 and then T = Base_Type (Etype (S)) 9623 then 9624 Error_Msg_N 9625 ("private function with tagged result must" 9626 & " override visible-part function", S); 9627 Error_Msg_N 9628 ("\move subprogram to the visible part" 9629 & " (RM 3.9.3(10))", S); 9630 9631 -- AI05-0073: extend this test to the case of a function 9632 -- with a controlling access result. 9633 9634 elsif Ekind (Etype (S)) = E_Anonymous_Access_Type 9635 and then Is_Tagged_Type (Designated_Type (Etype (S))) 9636 and then 9637 not Is_Class_Wide_Type (Designated_Type (Etype (S))) 9638 and then Ada_Version >= Ada_2012 9639 then 9640 Error_Msg_N 9641 ("private function with controlling access result " 9642 & "must override visible-part function", S); 9643 Error_Msg_N 9644 ("\move subprogram to the visible part" 9645 & " (RM 3.9.3(10))", S); 9646 end if; 9647 end if; 9648 end if; 9649 end Check_Private_Overriding; 9650 9651 ----------------------- 9652 -- Visible_Part_Type -- 9653 ----------------------- 9654 9655 function Visible_Part_Type (T : Entity_Id) return Boolean is 9656 P : constant Node_Id := Unit_Declaration_Node (Scope (T)); 9657 N : Node_Id; 9658 9659 begin 9660 -- If the entity is a private type, then it must be declared in a 9661 -- visible part. 9662 9663 if Ekind (T) in Private_Kind then 9664 return True; 9665 end if; 9666 9667 -- Otherwise, we traverse the visible part looking for its 9668 -- corresponding declaration. We cannot use the declaration 9669 -- node directly because in the private part the entity of a 9670 -- private type is the one in the full view, which does not 9671 -- indicate that it is the completion of something visible. 9672 9673 N := First (Visible_Declarations (Specification (P))); 9674 while Present (N) loop 9675 if Nkind (N) = N_Full_Type_Declaration 9676 and then Present (Defining_Identifier (N)) 9677 and then T = Defining_Identifier (N) 9678 then 9679 return True; 9680 9681 elsif Nkind_In (N, N_Private_Type_Declaration, 9682 N_Private_Extension_Declaration) 9683 and then Present (Defining_Identifier (N)) 9684 and then T = Full_View (Defining_Identifier (N)) 9685 then 9686 return True; 9687 end if; 9688 9689 Next (N); 9690 end loop; 9691 9692 return False; 9693 end Visible_Part_Type; 9694 9695 -- Start of processing for Check_For_Primitive_Subprogram 9696 9697 begin 9698 Is_Primitive := False; 9699 9700 if not Comes_From_Source (S) then 9701 null; 9702 9703 -- If subprogram is at library level, it is not primitive operation 9704 9705 elsif Current_Scope = Standard_Standard then 9706 null; 9707 9708 elsif (Is_Package_Or_Generic_Package (Current_Scope) 9709 and then not In_Package_Body (Current_Scope)) 9710 or else Is_Overriding 9711 then 9712 -- For function, check return type 9713 9714 if Ekind (S) = E_Function then 9715 if Ekind (Etype (S)) = E_Anonymous_Access_Type then 9716 F_Typ := Designated_Type (Etype (S)); 9717 else 9718 F_Typ := Etype (S); 9719 end if; 9720 9721 B_Typ := Base_Type (F_Typ); 9722 9723 if Scope (B_Typ) = Current_Scope 9724 and then not Is_Class_Wide_Type (B_Typ) 9725 and then not Is_Generic_Type (B_Typ) 9726 then 9727 Is_Primitive := True; 9728 Set_Has_Primitive_Operations (B_Typ); 9729 Set_Is_Primitive (S); 9730 Check_Private_Overriding (B_Typ); 9731 end if; 9732 end if; 9733 9734 -- For all subprograms, check formals 9735 9736 Formal := First_Formal (S); 9737 while Present (Formal) loop 9738 if Ekind (Etype (Formal)) = E_Anonymous_Access_Type then 9739 F_Typ := Designated_Type (Etype (Formal)); 9740 else 9741 F_Typ := Etype (Formal); 9742 end if; 9743 9744 B_Typ := Base_Type (F_Typ); 9745 9746 if Ekind (B_Typ) = E_Access_Subtype then 9747 B_Typ := Base_Type (B_Typ); 9748 end if; 9749 9750 if Scope (B_Typ) = Current_Scope 9751 and then not Is_Class_Wide_Type (B_Typ) 9752 and then not Is_Generic_Type (B_Typ) 9753 then 9754 Is_Primitive := True; 9755 Set_Is_Primitive (S); 9756 Set_Has_Primitive_Operations (B_Typ); 9757 Check_Private_Overriding (B_Typ); 9758 end if; 9759 9760 Next_Formal (Formal); 9761 end loop; 9762 9763 -- Special case: An equality function can be redefined for a type 9764 -- occurring in a declarative part, and won't otherwise be treated as 9765 -- a primitive because it doesn't occur in a package spec and doesn't 9766 -- override an inherited subprogram. It's important that we mark it 9767 -- primitive so it can be returned by Collect_Primitive_Operations 9768 -- and be used in composing the equality operation of later types 9769 -- that have a component of the type. 9770 9771 elsif Chars (S) = Name_Op_Eq 9772 and then Etype (S) = Standard_Boolean 9773 then 9774 B_Typ := Base_Type (Etype (First_Formal (S))); 9775 9776 if Scope (B_Typ) = Current_Scope 9777 and then 9778 Base_Type (Etype (Next_Formal (First_Formal (S)))) = B_Typ 9779 and then not Is_Limited_Type (B_Typ) 9780 then 9781 Is_Primitive := True; 9782 Set_Is_Primitive (S); 9783 Set_Has_Primitive_Operations (B_Typ); 9784 Check_Private_Overriding (B_Typ); 9785 end if; 9786 end if; 9787 end Check_For_Primitive_Subprogram; 9788 9789 ----------------------------------- 9790 -- Check_Synchronized_Overriding -- 9791 ----------------------------------- 9792 9793 procedure Check_Synchronized_Overriding 9794 (Def_Id : Entity_Id; 9795 Overridden_Subp : out Entity_Id) 9796 is 9797 Ifaces_List : Elist_Id; 9798 In_Scope : Boolean; 9799 Typ : Entity_Id; 9800 9801 function Matches_Prefixed_View_Profile 9802 (Prim_Params : List_Id; 9803 Iface_Params : List_Id) return Boolean; 9804 -- Determine whether a subprogram's parameter profile Prim_Params 9805 -- matches that of a potentially overridden interface subprogram 9806 -- Iface_Params. Also determine if the type of first parameter of 9807 -- Iface_Params is an implemented interface. 9808 9809 ----------------------------------- 9810 -- Matches_Prefixed_View_Profile -- 9811 ----------------------------------- 9812 9813 function Matches_Prefixed_View_Profile 9814 (Prim_Params : List_Id; 9815 Iface_Params : List_Id) return Boolean 9816 is 9817 Iface_Id : Entity_Id; 9818 Iface_Param : Node_Id; 9819 Iface_Typ : Entity_Id; 9820 Prim_Id : Entity_Id; 9821 Prim_Param : Node_Id; 9822 Prim_Typ : Entity_Id; 9823 9824 function Is_Implemented 9825 (Ifaces_List : Elist_Id; 9826 Iface : Entity_Id) return Boolean; 9827 -- Determine if Iface is implemented by the current task or 9828 -- protected type. 9829 9830 -------------------- 9831 -- Is_Implemented -- 9832 -------------------- 9833 9834 function Is_Implemented 9835 (Ifaces_List : Elist_Id; 9836 Iface : Entity_Id) return Boolean 9837 is 9838 Iface_Elmt : Elmt_Id; 9839 9840 begin 9841 Iface_Elmt := First_Elmt (Ifaces_List); 9842 while Present (Iface_Elmt) loop 9843 if Node (Iface_Elmt) = Iface then 9844 return True; 9845 end if; 9846 9847 Next_Elmt (Iface_Elmt); 9848 end loop; 9849 9850 return False; 9851 end Is_Implemented; 9852 9853 -- Start of processing for Matches_Prefixed_View_Profile 9854 9855 begin 9856 Iface_Param := First (Iface_Params); 9857 Iface_Typ := Etype (Defining_Identifier (Iface_Param)); 9858 9859 if Is_Access_Type (Iface_Typ) then 9860 Iface_Typ := Designated_Type (Iface_Typ); 9861 end if; 9862 9863 Prim_Param := First (Prim_Params); 9864 9865 -- The first parameter of the potentially overridden subprogram 9866 -- must be an interface implemented by Prim. 9867 9868 if not Is_Interface (Iface_Typ) 9869 or else not Is_Implemented (Ifaces_List, Iface_Typ) 9870 then 9871 return False; 9872 end if; 9873 9874 -- The checks on the object parameters are done, move onto the 9875 -- rest of the parameters. 9876 9877 if not In_Scope then 9878 Prim_Param := Next (Prim_Param); 9879 end if; 9880 9881 Iface_Param := Next (Iface_Param); 9882 while Present (Iface_Param) and then Present (Prim_Param) loop 9883 Iface_Id := Defining_Identifier (Iface_Param); 9884 Iface_Typ := Find_Parameter_Type (Iface_Param); 9885 9886 Prim_Id := Defining_Identifier (Prim_Param); 9887 Prim_Typ := Find_Parameter_Type (Prim_Param); 9888 9889 if Ekind (Iface_Typ) = E_Anonymous_Access_Type 9890 and then Ekind (Prim_Typ) = E_Anonymous_Access_Type 9891 and then Is_Concurrent_Type (Designated_Type (Prim_Typ)) 9892 then 9893 Iface_Typ := Designated_Type (Iface_Typ); 9894 Prim_Typ := Designated_Type (Prim_Typ); 9895 end if; 9896 9897 -- Case of multiple interface types inside a parameter profile 9898 9899 -- (Obj_Param : in out Iface; ...; Param : Iface) 9900 9901 -- If the interface type is implemented, then the matching type 9902 -- in the primitive should be the implementing record type. 9903 9904 if Ekind (Iface_Typ) = E_Record_Type 9905 and then Is_Interface (Iface_Typ) 9906 and then Is_Implemented (Ifaces_List, Iface_Typ) 9907 then 9908 if Prim_Typ /= Typ then 9909 return False; 9910 end if; 9911 9912 -- The two parameters must be both mode and subtype conformant 9913 9914 elsif Ekind (Iface_Id) /= Ekind (Prim_Id) 9915 or else not 9916 Conforming_Types (Iface_Typ, Prim_Typ, Subtype_Conformant) 9917 then 9918 return False; 9919 end if; 9920 9921 Next (Iface_Param); 9922 Next (Prim_Param); 9923 end loop; 9924 9925 -- One of the two lists contains more parameters than the other 9926 9927 if Present (Iface_Param) or else Present (Prim_Param) then 9928 return False; 9929 end if; 9930 9931 return True; 9932 end Matches_Prefixed_View_Profile; 9933 9934 -- Start of processing for Check_Synchronized_Overriding 9935 9936 begin 9937 Overridden_Subp := Empty; 9938 9939 -- Def_Id must be an entry or a subprogram. We should skip predefined 9940 -- primitives internally generated by the frontend; however at this 9941 -- stage predefined primitives are still not fully decorated. As a 9942 -- minor optimization we skip here internally generated subprograms. 9943 9944 if (Ekind (Def_Id) /= E_Entry 9945 and then Ekind (Def_Id) /= E_Function 9946 and then Ekind (Def_Id) /= E_Procedure) 9947 or else not Comes_From_Source (Def_Id) 9948 then 9949 return; 9950 end if; 9951 9952 -- Search for the concurrent declaration since it contains the list 9953 -- of all implemented interfaces. In this case, the subprogram is 9954 -- declared within the scope of a protected or a task type. 9955 9956 if Present (Scope (Def_Id)) 9957 and then Is_Concurrent_Type (Scope (Def_Id)) 9958 and then not Is_Generic_Actual_Type (Scope (Def_Id)) 9959 then 9960 Typ := Scope (Def_Id); 9961 In_Scope := True; 9962 9963 -- The enclosing scope is not a synchronized type and the subprogram 9964 -- has no formals. 9965 9966 elsif No (First_Formal (Def_Id)) then 9967 return; 9968 9969 -- The subprogram has formals and hence it may be a primitive of a 9970 -- concurrent type. 9971 9972 else 9973 Typ := Etype (First_Formal (Def_Id)); 9974 9975 if Is_Access_Type (Typ) then 9976 Typ := Directly_Designated_Type (Typ); 9977 end if; 9978 9979 if Is_Concurrent_Type (Typ) 9980 and then not Is_Generic_Actual_Type (Typ) 9981 then 9982 In_Scope := False; 9983 9984 -- This case occurs when the concurrent type is declared within 9985 -- a generic unit. As a result the corresponding record has been 9986 -- built and used as the type of the first formal, we just have 9987 -- to retrieve the corresponding concurrent type. 9988 9989 elsif Is_Concurrent_Record_Type (Typ) 9990 and then not Is_Class_Wide_Type (Typ) 9991 and then Present (Corresponding_Concurrent_Type (Typ)) 9992 then 9993 Typ := Corresponding_Concurrent_Type (Typ); 9994 In_Scope := False; 9995 9996 else 9997 return; 9998 end if; 9999 end if; 10000 10001 -- There is no overriding to check if is an inherited operation in a 10002 -- type derivation on for a generic actual. 10003 10004 Collect_Interfaces (Typ, Ifaces_List); 10005 10006 if Is_Empty_Elmt_List (Ifaces_List) then 10007 return; 10008 end if; 10009 10010 -- Determine whether entry or subprogram Def_Id overrides a primitive 10011 -- operation that belongs to one of the interfaces in Ifaces_List. 10012 10013 declare 10014 Candidate : Entity_Id := Empty; 10015 Hom : Entity_Id := Empty; 10016 Iface_Typ : Entity_Id; 10017 Subp : Entity_Id := Empty; 10018 10019 begin 10020 -- Traverse the homonym chain, looking for a potentially 10021 -- overridden subprogram that belongs to an implemented 10022 -- interface. 10023 10024 Hom := Current_Entity_In_Scope (Def_Id); 10025 while Present (Hom) loop 10026 Subp := Hom; 10027 10028 if Subp = Def_Id 10029 or else not Is_Overloadable (Subp) 10030 or else not Is_Primitive (Subp) 10031 or else not Is_Dispatching_Operation (Subp) 10032 or else not Present (Find_Dispatching_Type (Subp)) 10033 or else not Is_Interface (Find_Dispatching_Type (Subp)) 10034 then 10035 null; 10036 10037 -- Entries and procedures can override abstract or null 10038 -- interface procedures. 10039 10040 elsif (Ekind (Def_Id) = E_Procedure 10041 or else Ekind (Def_Id) = E_Entry) 10042 and then Ekind (Subp) = E_Procedure 10043 and then Matches_Prefixed_View_Profile 10044 (Parameter_Specifications (Parent (Def_Id)), 10045 Parameter_Specifications (Parent (Subp))) 10046 then 10047 Candidate := Subp; 10048 10049 -- For an overridden subprogram Subp, check whether the mode 10050 -- of its first parameter is correct depending on the kind 10051 -- of synchronized type. 10052 10053 declare 10054 Formal : constant Node_Id := First_Formal (Candidate); 10055 10056 begin 10057 -- In order for an entry or a protected procedure to 10058 -- override, the first parameter of the overridden 10059 -- routine must be of mode "out", "in out" or 10060 -- access-to-variable. 10061 10062 if (Ekind (Candidate) = E_Entry 10063 or else Ekind (Candidate) = E_Procedure) 10064 and then Is_Protected_Type (Typ) 10065 and then Ekind (Formal) /= E_In_Out_Parameter 10066 and then Ekind (Formal) /= E_Out_Parameter 10067 and then Nkind (Parameter_Type (Parent (Formal))) 10068 /= N_Access_Definition 10069 then 10070 null; 10071 10072 -- All other cases are OK since a task entry or routine 10073 -- does not have a restriction on the mode of the first 10074 -- parameter of the overridden interface routine. 10075 10076 else 10077 Overridden_Subp := Candidate; 10078 return; 10079 end if; 10080 end; 10081 10082 -- Functions can override abstract interface functions 10083 10084 elsif Ekind (Def_Id) = E_Function 10085 and then Ekind (Subp) = E_Function 10086 and then Matches_Prefixed_View_Profile 10087 (Parameter_Specifications (Parent (Def_Id)), 10088 Parameter_Specifications (Parent (Subp))) 10089 and then Etype (Result_Definition (Parent (Def_Id))) = 10090 Etype (Result_Definition (Parent (Subp))) 10091 then 10092 Overridden_Subp := Subp; 10093 return; 10094 end if; 10095 10096 Hom := Homonym (Hom); 10097 end loop; 10098 10099 -- After examining all candidates for overriding, we are left with 10100 -- the best match which is a mode incompatible interface routine. 10101 -- Do not emit an error if the Expander is active since this error 10102 -- will be detected later on after all concurrent types are 10103 -- expanded and all wrappers are built. This check is meant for 10104 -- spec-only compilations. 10105 10106 if Present (Candidate) and then not Expander_Active then 10107 Iface_Typ := 10108 Find_Parameter_Type (Parent (First_Formal (Candidate))); 10109 10110 -- Def_Id is primitive of a protected type, declared inside the 10111 -- type, and the candidate is primitive of a limited or 10112 -- synchronized interface. 10113 10114 if In_Scope 10115 and then Is_Protected_Type (Typ) 10116 and then 10117 (Is_Limited_Interface (Iface_Typ) 10118 or else Is_Protected_Interface (Iface_Typ) 10119 or else Is_Synchronized_Interface (Iface_Typ) 10120 or else Is_Task_Interface (Iface_Typ)) 10121 then 10122 Error_Msg_PT (Parent (Typ), Candidate); 10123 end if; 10124 end if; 10125 10126 Overridden_Subp := Candidate; 10127 return; 10128 end; 10129 end Check_Synchronized_Overriding; 10130 10131 ---------------------------- 10132 -- Is_Private_Declaration -- 10133 ---------------------------- 10134 10135 function Is_Private_Declaration (E : Entity_Id) return Boolean is 10136 Priv_Decls : List_Id; 10137 Decl : constant Node_Id := Unit_Declaration_Node (E); 10138 10139 begin 10140 if Is_Package_Or_Generic_Package (Current_Scope) 10141 and then In_Private_Part (Current_Scope) 10142 then 10143 Priv_Decls := 10144 Private_Declarations 10145 (Specification (Unit_Declaration_Node (Current_Scope))); 10146 10147 return In_Package_Body (Current_Scope) 10148 or else 10149 (Is_List_Member (Decl) 10150 and then List_Containing (Decl) = Priv_Decls) 10151 or else (Nkind (Parent (Decl)) = N_Package_Specification 10152 and then not 10153 Is_Compilation_Unit 10154 (Defining_Entity (Parent (Decl))) 10155 and then List_Containing (Parent (Parent (Decl))) = 10156 Priv_Decls); 10157 else 10158 return False; 10159 end if; 10160 end Is_Private_Declaration; 10161 10162 -------------------------- 10163 -- Is_Overriding_Alias -- 10164 -------------------------- 10165 10166 function Is_Overriding_Alias 10167 (Old_E : Entity_Id; 10168 New_E : Entity_Id) return Boolean 10169 is 10170 AO : constant Entity_Id := Alias (Old_E); 10171 AN : constant Entity_Id := Alias (New_E); 10172 10173 begin 10174 return Scope (AO) /= Scope (AN) 10175 or else No (DTC_Entity (AO)) 10176 or else No (DTC_Entity (AN)) 10177 or else DT_Position (AO) = DT_Position (AN); 10178 end Is_Overriding_Alias; 10179 10180 -- Start of processing for New_Overloaded_Entity 10181 10182 begin 10183 -- We need to look for an entity that S may override. This must be a 10184 -- homonym in the current scope, so we look for the first homonym of 10185 -- S in the current scope as the starting point for the search. 10186 10187 E := Current_Entity_In_Scope (S); 10188 10189 -- Ada 2005 (AI-251): Derivation of abstract interface primitives. 10190 -- They are directly added to the list of primitive operations of 10191 -- Derived_Type, unless this is a rederivation in the private part 10192 -- of an operation that was already derived in the visible part of 10193 -- the current package. 10194 10195 if Ada_Version >= Ada_2005 10196 and then Present (Derived_Type) 10197 and then Present (Alias (S)) 10198 and then Is_Dispatching_Operation (Alias (S)) 10199 and then Present (Find_Dispatching_Type (Alias (S))) 10200 and then Is_Interface (Find_Dispatching_Type (Alias (S))) 10201 then 10202 -- For private types, when the full-view is processed we propagate to 10203 -- the full view the non-overridden entities whose attribute "alias" 10204 -- references an interface primitive. These entities were added by 10205 -- Derive_Subprograms to ensure that interface primitives are 10206 -- covered. 10207 10208 -- Inside_Freeze_Actions is non zero when S corresponds with an 10209 -- internal entity that links an interface primitive with its 10210 -- covering primitive through attribute Interface_Alias (see 10211 -- Add_Internal_Interface_Entities). 10212 10213 if Inside_Freezing_Actions = 0 10214 and then Is_Package_Or_Generic_Package (Current_Scope) 10215 and then In_Private_Part (Current_Scope) 10216 and then Nkind (Parent (E)) = N_Private_Extension_Declaration 10217 and then Nkind (Parent (S)) = N_Full_Type_Declaration 10218 and then Full_View (Defining_Identifier (Parent (E))) 10219 = Defining_Identifier (Parent (S)) 10220 and then Alias (E) = Alias (S) 10221 then 10222 Check_Operation_From_Private_View (S, E); 10223 Set_Is_Dispatching_Operation (S); 10224 10225 -- Common case 10226 10227 else 10228 Enter_Overloaded_Entity (S); 10229 Check_Dispatching_Operation (S, Empty); 10230 Check_For_Primitive_Subprogram (Is_Primitive_Subp); 10231 end if; 10232 10233 return; 10234 end if; 10235 10236 -- If there is no homonym then this is definitely not overriding 10237 10238 if No (E) then 10239 Enter_Overloaded_Entity (S); 10240 Check_Dispatching_Operation (S, Empty); 10241 Check_For_Primitive_Subprogram (Is_Primitive_Subp); 10242 10243 -- If subprogram has an explicit declaration, check whether it 10244 -- has an overriding indicator. 10245 10246 if Comes_From_Source (S) then 10247 Check_Synchronized_Overriding (S, Overridden_Subp); 10248 10249 -- (Ada 2012: AI05-0125-1): If S is a dispatching operation then 10250 -- it may have overridden some hidden inherited primitive. Update 10251 -- Overridden_Subp to avoid spurious errors when checking the 10252 -- overriding indicator. 10253 10254 if Ada_Version >= Ada_2012 10255 and then No (Overridden_Subp) 10256 and then Is_Dispatching_Operation (S) 10257 and then Present (Overridden_Operation (S)) 10258 then 10259 Overridden_Subp := Overridden_Operation (S); 10260 end if; 10261 10262 Check_Overriding_Indicator 10263 (S, Overridden_Subp, Is_Primitive => Is_Primitive_Subp); 10264 end if; 10265 10266 -- If there is a homonym that is not overloadable, then we have an 10267 -- error, except for the special cases checked explicitly below. 10268 10269 elsif not Is_Overloadable (E) then 10270 10271 -- Check for spurious conflict produced by a subprogram that has the 10272 -- same name as that of the enclosing generic package. The conflict 10273 -- occurs within an instance, between the subprogram and the renaming 10274 -- declaration for the package. After the subprogram, the package 10275 -- renaming declaration becomes hidden. 10276 10277 if Ekind (E) = E_Package 10278 and then Present (Renamed_Object (E)) 10279 and then Renamed_Object (E) = Current_Scope 10280 and then Nkind (Parent (Renamed_Object (E))) = 10281 N_Package_Specification 10282 and then Present (Generic_Parent (Parent (Renamed_Object (E)))) 10283 then 10284 Set_Is_Hidden (E); 10285 Set_Is_Immediately_Visible (E, False); 10286 Enter_Overloaded_Entity (S); 10287 Set_Homonym (S, Homonym (E)); 10288 Check_Dispatching_Operation (S, Empty); 10289 Check_Overriding_Indicator (S, Empty, Is_Primitive => False); 10290 10291 -- If the subprogram is implicit it is hidden by the previous 10292 -- declaration. However if it is dispatching, it must appear in the 10293 -- dispatch table anyway, because it can be dispatched to even if it 10294 -- cannot be called directly. 10295 10296 elsif Present (Alias (S)) and then not Comes_From_Source (S) then 10297 Set_Scope (S, Current_Scope); 10298 10299 if Is_Dispatching_Operation (Alias (S)) then 10300 Check_Dispatching_Operation (S, Empty); 10301 end if; 10302 10303 return; 10304 10305 else 10306 Error_Msg_Sloc := Sloc (E); 10307 10308 -- Generate message, with useful additional warning if in generic 10309 10310 if Is_Generic_Unit (E) then 10311 Error_Msg_N ("previous generic unit cannot be overloaded", S); 10312 Error_Msg_N ("\& conflicts with declaration#", S); 10313 else 10314 Error_Msg_N ("& conflicts with declaration#", S); 10315 end if; 10316 10317 return; 10318 end if; 10319 10320 -- E exists and is overloadable 10321 10322 else 10323 Check_Synchronized_Overriding (S, Overridden_Subp); 10324 10325 -- Loop through E and its homonyms to determine if any of them is 10326 -- the candidate for overriding by S. 10327 10328 while Present (E) loop 10329 10330 -- Definitely not interesting if not in the current scope 10331 10332 if Scope (E) /= Current_Scope then 10333 null; 10334 10335 -- Ada 2012 (AI05-0165): For internally generated bodies of 10336 -- null procedures locate the internally generated spec. We 10337 -- enforce mode conformance since a tagged type may inherit 10338 -- from interfaces several null primitives which differ only 10339 -- in the mode of the formals. 10340 10341 elsif not Comes_From_Source (S) 10342 and then Is_Null_Procedure (S) 10343 and then not Mode_Conformant (E, S) 10344 then 10345 null; 10346 10347 -- Check if we have type conformance 10348 10349 elsif Type_Conformant (E, S) then 10350 10351 -- If the old and new entities have the same profile and one 10352 -- is not the body of the other, then this is an error, unless 10353 -- one of them is implicitly declared. 10354 10355 -- There are some cases when both can be implicit, for example 10356 -- when both a literal and a function that overrides it are 10357 -- inherited in a derivation, or when an inherited operation 10358 -- of a tagged full type overrides the inherited operation of 10359 -- a private extension. Ada 83 had a special rule for the 10360 -- literal case. In Ada 95, the later implicit operation hides 10361 -- the former, and the literal is always the former. In the 10362 -- odd case where both are derived operations declared at the 10363 -- same point, both operations should be declared, and in that 10364 -- case we bypass the following test and proceed to the next 10365 -- part. This can only occur for certain obscure cases in 10366 -- instances, when an operation on a type derived from a formal 10367 -- private type does not override a homograph inherited from 10368 -- the actual. In subsequent derivations of such a type, the 10369 -- DT positions of these operations remain distinct, if they 10370 -- have been set. 10371 10372 if Present (Alias (S)) 10373 and then (No (Alias (E)) 10374 or else Comes_From_Source (E) 10375 or else Is_Abstract_Subprogram (S) 10376 or else 10377 (Is_Dispatching_Operation (E) 10378 and then Is_Overriding_Alias (E, S))) 10379 and then Ekind (E) /= E_Enumeration_Literal 10380 then 10381 -- When an derived operation is overloaded it may be due to 10382 -- the fact that the full view of a private extension 10383 -- re-inherits. It has to be dealt with. 10384 10385 if Is_Package_Or_Generic_Package (Current_Scope) 10386 and then In_Private_Part (Current_Scope) 10387 then 10388 Check_Operation_From_Private_View (S, E); 10389 end if; 10390 10391 -- In any case the implicit operation remains hidden by the 10392 -- existing declaration, which is overriding. Indicate that 10393 -- E overrides the operation from which S is inherited. 10394 10395 if Present (Alias (S)) then 10396 Set_Overridden_Operation (E, Alias (S)); 10397 else 10398 Set_Overridden_Operation (E, S); 10399 end if; 10400 10401 if Comes_From_Source (E) then 10402 Check_Overriding_Indicator (E, S, Is_Primitive => False); 10403 end if; 10404 10405 return; 10406 10407 -- Within an instance, the renaming declarations for actual 10408 -- subprograms may become ambiguous, but they do not hide each 10409 -- other. 10410 10411 elsif Ekind (E) /= E_Entry 10412 and then not Comes_From_Source (E) 10413 and then not Is_Generic_Instance (E) 10414 and then (Present (Alias (E)) 10415 or else Is_Intrinsic_Subprogram (E)) 10416 and then (not In_Instance 10417 or else No (Parent (E)) 10418 or else Nkind (Unit_Declaration_Node (E)) /= 10419 N_Subprogram_Renaming_Declaration) 10420 then 10421 -- A subprogram child unit is not allowed to override an 10422 -- inherited subprogram (10.1.1(20)). 10423 10424 if Is_Child_Unit (S) then 10425 Error_Msg_N 10426 ("child unit overrides inherited subprogram in parent", 10427 S); 10428 return; 10429 end if; 10430 10431 if Is_Non_Overriding_Operation (E, S) then 10432 Enter_Overloaded_Entity (S); 10433 10434 if No (Derived_Type) 10435 or else Is_Tagged_Type (Derived_Type) 10436 then 10437 Check_Dispatching_Operation (S, Empty); 10438 end if; 10439 10440 return; 10441 end if; 10442 10443 -- E is a derived operation or an internal operator which 10444 -- is being overridden. Remove E from further visibility. 10445 -- Furthermore, if E is a dispatching operation, it must be 10446 -- replaced in the list of primitive operations of its type 10447 -- (see Override_Dispatching_Operation). 10448 10449 Overridden_Subp := E; 10450 10451 declare 10452 Prev : Entity_Id; 10453 10454 begin 10455 Prev := First_Entity (Current_Scope); 10456 while Present (Prev) 10457 and then Next_Entity (Prev) /= E 10458 loop 10459 Next_Entity (Prev); 10460 end loop; 10461 10462 -- It is possible for E to be in the current scope and 10463 -- yet not in the entity chain. This can only occur in a 10464 -- generic context where E is an implicit concatenation 10465 -- in the formal part, because in a generic body the 10466 -- entity chain starts with the formals. 10467 10468 pragma Assert 10469 (Present (Prev) or else Chars (E) = Name_Op_Concat); 10470 10471 -- E must be removed both from the entity_list of the 10472 -- current scope, and from the visibility chain 10473 10474 if Debug_Flag_E then 10475 Write_Str ("Override implicit operation "); 10476 Write_Int (Int (E)); 10477 Write_Eol; 10478 end if; 10479 10480 -- If E is a predefined concatenation, it stands for four 10481 -- different operations. As a result, a single explicit 10482 -- declaration does not hide it. In a possible ambiguous 10483 -- situation, Disambiguate chooses the user-defined op, 10484 -- so it is correct to retain the previous internal one. 10485 10486 if Chars (E) /= Name_Op_Concat 10487 or else Ekind (E) /= E_Operator 10488 then 10489 -- For nondispatching derived operations that are 10490 -- overridden by a subprogram declared in the private 10491 -- part of a package, we retain the derived subprogram 10492 -- but mark it as not immediately visible. If the 10493 -- derived operation was declared in the visible part 10494 -- then this ensures that it will still be visible 10495 -- outside the package with the proper signature 10496 -- (calls from outside must also be directed to this 10497 -- version rather than the overriding one, unlike the 10498 -- dispatching case). Calls from inside the package 10499 -- will still resolve to the overriding subprogram 10500 -- since the derived one is marked as not visible 10501 -- within the package. 10502 10503 -- If the private operation is dispatching, we achieve 10504 -- the overriding by keeping the implicit operation 10505 -- but setting its alias to be the overriding one. In 10506 -- this fashion the proper body is executed in all 10507 -- cases, but the original signature is used outside 10508 -- of the package. 10509 10510 -- If the overriding is not in the private part, we 10511 -- remove the implicit operation altogether. 10512 10513 if Is_Private_Declaration (S) then 10514 if not Is_Dispatching_Operation (E) then 10515 Set_Is_Immediately_Visible (E, False); 10516 else 10517 -- Work done in Override_Dispatching_Operation, 10518 -- so nothing else needs to be done here. 10519 10520 null; 10521 end if; 10522 10523 else 10524 -- Find predecessor of E in Homonym chain 10525 10526 if E = Current_Entity (E) then 10527 Prev_Vis := Empty; 10528 else 10529 Prev_Vis := Current_Entity (E); 10530 while Homonym (Prev_Vis) /= E loop 10531 Prev_Vis := Homonym (Prev_Vis); 10532 end loop; 10533 end if; 10534 10535 if Prev_Vis /= Empty then 10536 10537 -- Skip E in the visibility chain 10538 10539 Set_Homonym (Prev_Vis, Homonym (E)); 10540 10541 else 10542 Set_Name_Entity_Id (Chars (E), Homonym (E)); 10543 end if; 10544 10545 Set_Next_Entity (Prev, Next_Entity (E)); 10546 10547 if No (Next_Entity (Prev)) then 10548 Set_Last_Entity (Current_Scope, Prev); 10549 end if; 10550 end if; 10551 end if; 10552 10553 Enter_Overloaded_Entity (S); 10554 10555 -- For entities generated by Derive_Subprograms the 10556 -- overridden operation is the inherited primitive 10557 -- (which is available through the attribute alias). 10558 10559 if not (Comes_From_Source (E)) 10560 and then Is_Dispatching_Operation (E) 10561 and then Find_Dispatching_Type (E) = 10562 Find_Dispatching_Type (S) 10563 and then Present (Alias (E)) 10564 and then Comes_From_Source (Alias (E)) 10565 then 10566 Set_Overridden_Operation (S, Alias (E)); 10567 10568 -- Normal case of setting entity as overridden 10569 10570 -- Note: Static_Initialization and Overridden_Operation 10571 -- attributes use the same field in subprogram entities. 10572 -- Static_Initialization is only defined for internal 10573 -- initialization procedures, where Overridden_Operation 10574 -- is irrelevant. Therefore the setting of this attribute 10575 -- must check whether the target is an init_proc. 10576 10577 elsif not Is_Init_Proc (S) then 10578 Set_Overridden_Operation (S, E); 10579 end if; 10580 10581 Check_Overriding_Indicator (S, E, Is_Primitive => True); 10582 10583 -- If S is a user-defined subprogram or a null procedure 10584 -- expanded to override an inherited null procedure, or a 10585 -- predefined dispatching primitive then indicate that E 10586 -- overrides the operation from which S is inherited. 10587 10588 if Comes_From_Source (S) 10589 or else 10590 (Present (Parent (S)) 10591 and then 10592 Nkind (Parent (S)) = N_Procedure_Specification 10593 and then 10594 Null_Present (Parent (S))) 10595 or else 10596 (Present (Alias (E)) 10597 and then 10598 Is_Predefined_Dispatching_Operation (Alias (E))) 10599 then 10600 if Present (Alias (E)) then 10601 Set_Overridden_Operation (S, Alias (E)); 10602 end if; 10603 end if; 10604 10605 if Is_Dispatching_Operation (E) then 10606 10607 -- An overriding dispatching subprogram inherits the 10608 -- convention of the overridden subprogram (AI-117). 10609 10610 Set_Convention (S, Convention (E)); 10611 Check_Dispatching_Operation (S, E); 10612 10613 else 10614 Check_Dispatching_Operation (S, Empty); 10615 end if; 10616 10617 Check_For_Primitive_Subprogram 10618 (Is_Primitive_Subp, Is_Overriding => True); 10619 goto Check_Inequality; 10620 end; 10621 10622 -- Apparent redeclarations in instances can occur when two 10623 -- formal types get the same actual type. The subprograms in 10624 -- in the instance are legal, even if not callable from the 10625 -- outside. Calls from within are disambiguated elsewhere. 10626 -- For dispatching operations in the visible part, the usual 10627 -- rules apply, and operations with the same profile are not 10628 -- legal (B830001). 10629 10630 elsif (In_Instance_Visible_Part 10631 and then not Is_Dispatching_Operation (E)) 10632 or else In_Instance_Not_Visible 10633 then 10634 null; 10635 10636 -- Here we have a real error (identical profile) 10637 10638 else 10639 Error_Msg_Sloc := Sloc (E); 10640 10641 -- Avoid cascaded errors if the entity appears in 10642 -- subsequent calls. 10643 10644 Set_Scope (S, Current_Scope); 10645 10646 -- Generate error, with extra useful warning for the case 10647 -- of a generic instance with no completion. 10648 10649 if Is_Generic_Instance (S) 10650 and then not Has_Completion (E) 10651 then 10652 Error_Msg_N 10653 ("instantiation cannot provide body for&", S); 10654 Error_Msg_N ("\& conflicts with declaration#", S); 10655 else 10656 Error_Msg_N ("& conflicts with declaration#", S); 10657 end if; 10658 10659 return; 10660 end if; 10661 10662 else 10663 -- If one subprogram has an access parameter and the other 10664 -- a parameter of an access type, calls to either might be 10665 -- ambiguous. Verify that parameters match except for the 10666 -- access parameter. 10667 10668 if May_Hide_Profile then 10669 declare 10670 F1 : Entity_Id; 10671 F2 : Entity_Id; 10672 10673 begin 10674 F1 := First_Formal (S); 10675 F2 := First_Formal (E); 10676 while Present (F1) and then Present (F2) loop 10677 if Is_Access_Type (Etype (F1)) then 10678 if not Is_Access_Type (Etype (F2)) 10679 or else not Conforming_Types 10680 (Designated_Type (Etype (F1)), 10681 Designated_Type (Etype (F2)), 10682 Type_Conformant) 10683 then 10684 May_Hide_Profile := False; 10685 end if; 10686 10687 elsif 10688 not Conforming_Types 10689 (Etype (F1), Etype (F2), Type_Conformant) 10690 then 10691 May_Hide_Profile := False; 10692 end if; 10693 10694 Next_Formal (F1); 10695 Next_Formal (F2); 10696 end loop; 10697 10698 if May_Hide_Profile 10699 and then No (F1) 10700 and then No (F2) 10701 then 10702 Error_Msg_NE ("calls to& may be ambiguous??", S, S); 10703 end if; 10704 end; 10705 end if; 10706 end if; 10707 10708 E := Homonym (E); 10709 end loop; 10710 10711 -- On exit, we know that S is a new entity 10712 10713 Enter_Overloaded_Entity (S); 10714 Check_For_Primitive_Subprogram (Is_Primitive_Subp); 10715 Check_Overriding_Indicator 10716 (S, Overridden_Subp, Is_Primitive => Is_Primitive_Subp); 10717 10718 -- Overloading is not allowed in SPARK, except for operators 10719 10720 if Nkind (S) /= N_Defining_Operator_Symbol then 10721 Error_Msg_Sloc := Sloc (Homonym (S)); 10722 Check_SPARK_Restriction 10723 ("overloading not allowed with entity#", S); 10724 end if; 10725 10726 -- If S is a derived operation for an untagged type then by 10727 -- definition it's not a dispatching operation (even if the parent 10728 -- operation was dispatching), so Check_Dispatching_Operation is not 10729 -- called in that case. 10730 10731 if No (Derived_Type) 10732 or else Is_Tagged_Type (Derived_Type) 10733 then 10734 Check_Dispatching_Operation (S, Empty); 10735 end if; 10736 end if; 10737 10738 -- If this is a user-defined equality operator that is not a derived 10739 -- subprogram, create the corresponding inequality. If the operation is 10740 -- dispatching, the expansion is done elsewhere, and we do not create 10741 -- an explicit inequality operation. 10742 10743 <<Check_Inequality>> 10744 if Chars (S) = Name_Op_Eq 10745 and then Etype (S) = Standard_Boolean 10746 and then Present (Parent (S)) 10747 and then not Is_Dispatching_Operation (S) 10748 then 10749 Make_Inequality_Operator (S); 10750 10751 if Ada_Version >= Ada_2012 then 10752 Check_Untagged_Equality (S); 10753 end if; 10754 end if; 10755 end New_Overloaded_Entity; 10756 10757 --------------------- 10758 -- Process_Formals -- 10759 --------------------- 10760 10761 procedure Process_Formals 10762 (T : List_Id; 10763 Related_Nod : Node_Id) 10764 is 10765 Param_Spec : Node_Id; 10766 Formal : Entity_Id; 10767 Formal_Type : Entity_Id; 10768 Default : Node_Id; 10769 Ptype : Entity_Id; 10770 10771 Num_Out_Params : Nat := 0; 10772 First_Out_Param : Entity_Id := Empty; 10773 -- Used for setting Is_Only_Out_Parameter 10774 10775 function Designates_From_With_Type (Typ : Entity_Id) return Boolean; 10776 -- Determine whether an access type designates a type coming from a 10777 -- limited view. 10778 10779 function Is_Class_Wide_Default (D : Node_Id) return Boolean; 10780 -- Check whether the default has a class-wide type. After analysis the 10781 -- default has the type of the formal, so we must also check explicitly 10782 -- for an access attribute. 10783 10784 ------------------------------- 10785 -- Designates_From_With_Type -- 10786 ------------------------------- 10787 10788 function Designates_From_With_Type (Typ : Entity_Id) return Boolean is 10789 Desig : Entity_Id := Typ; 10790 10791 begin 10792 if Is_Access_Type (Desig) then 10793 Desig := Directly_Designated_Type (Desig); 10794 end if; 10795 10796 if Is_Class_Wide_Type (Desig) then 10797 Desig := Root_Type (Desig); 10798 end if; 10799 10800 return 10801 Ekind (Desig) = E_Incomplete_Type 10802 and then From_With_Type (Desig); 10803 end Designates_From_With_Type; 10804 10805 --------------------------- 10806 -- Is_Class_Wide_Default -- 10807 --------------------------- 10808 10809 function Is_Class_Wide_Default (D : Node_Id) return Boolean is 10810 begin 10811 return Is_Class_Wide_Type (Designated_Type (Etype (D))) 10812 or else (Nkind (D) = N_Attribute_Reference 10813 and then Attribute_Name (D) = Name_Access 10814 and then Is_Class_Wide_Type (Etype (Prefix (D)))); 10815 end Is_Class_Wide_Default; 10816 10817 -- Start of processing for Process_Formals 10818 10819 begin 10820 -- In order to prevent premature use of the formals in the same formal 10821 -- part, the Ekind is left undefined until all default expressions are 10822 -- analyzed. The Ekind is established in a separate loop at the end. 10823 10824 Param_Spec := First (T); 10825 while Present (Param_Spec) loop 10826 Formal := Defining_Identifier (Param_Spec); 10827 Set_Never_Set_In_Source (Formal, True); 10828 Enter_Name (Formal); 10829 10830 -- Case of ordinary parameters 10831 10832 if Nkind (Parameter_Type (Param_Spec)) /= N_Access_Definition then 10833 Find_Type (Parameter_Type (Param_Spec)); 10834 Ptype := Parameter_Type (Param_Spec); 10835 10836 if Ptype = Error then 10837 goto Continue; 10838 end if; 10839 10840 Formal_Type := Entity (Ptype); 10841 10842 if Is_Incomplete_Type (Formal_Type) 10843 or else 10844 (Is_Class_Wide_Type (Formal_Type) 10845 and then Is_Incomplete_Type (Root_Type (Formal_Type))) 10846 then 10847 -- Ada 2005 (AI-326): Tagged incomplete types allowed in 10848 -- primitive operations, as long as their completion is 10849 -- in the same declarative part. If in the private part 10850 -- this means that the type cannot be a Taft-amendment type. 10851 -- Check is done on package exit. For access to subprograms, 10852 -- the use is legal for Taft-amendment types. 10853 10854 -- Ada 2012: tagged incomplete types are allowed as generic 10855 -- formal types. They do not introduce dependencies and the 10856 -- corresponding generic subprogram does not have a delayed 10857 -- freeze, because it does not need a freeze node. 10858 10859 if Is_Tagged_Type (Formal_Type) then 10860 if Ekind (Scope (Current_Scope)) = E_Package 10861 and then not From_With_Type (Formal_Type) 10862 and then not Is_Generic_Type (Formal_Type) 10863 and then not Is_Class_Wide_Type (Formal_Type) 10864 then 10865 if not Nkind_In 10866 (Parent (T), N_Access_Function_Definition, 10867 N_Access_Procedure_Definition) 10868 then 10869 Append_Elmt 10870 (Current_Scope, 10871 Private_Dependents (Base_Type (Formal_Type))); 10872 10873 -- Freezing is delayed to ensure that Register_Prim 10874 -- will get called for this operation, which is needed 10875 -- in cases where static dispatch tables aren't built. 10876 -- (Note that the same is done for controlling access 10877 -- parameter cases in function Access_Definition.) 10878 10879 Set_Has_Delayed_Freeze (Current_Scope); 10880 end if; 10881 end if; 10882 10883 -- Special handling of Value_Type for CIL case 10884 10885 elsif Is_Value_Type (Formal_Type) then 10886 null; 10887 10888 elsif not Nkind_In (Parent (T), N_Access_Function_Definition, 10889 N_Access_Procedure_Definition) 10890 then 10891 -- AI05-0151: Tagged incomplete types are allowed in all 10892 -- formal parts. Untagged incomplete types are not allowed 10893 -- in bodies. 10894 10895 if Ada_Version >= Ada_2012 then 10896 if Is_Tagged_Type (Formal_Type) then 10897 null; 10898 10899 elsif Nkind_In (Parent (Parent (T)), N_Accept_Statement, 10900 N_Entry_Body, 10901 N_Subprogram_Body) 10902 then 10903 Error_Msg_NE 10904 ("invalid use of untagged incomplete type&", 10905 Ptype, Formal_Type); 10906 end if; 10907 10908 else 10909 Error_Msg_NE 10910 ("invalid use of incomplete type&", 10911 Param_Spec, Formal_Type); 10912 10913 -- Further checks on the legality of incomplete types 10914 -- in formal parts are delayed until the freeze point 10915 -- of the enclosing subprogram or access to subprogram. 10916 end if; 10917 end if; 10918 10919 elsif Ekind (Formal_Type) = E_Void then 10920 Error_Msg_NE 10921 ("premature use of&", 10922 Parameter_Type (Param_Spec), Formal_Type); 10923 end if; 10924 10925 -- Ada 2012 (AI-142): Handle aliased parameters 10926 10927 if Ada_Version >= Ada_2012 10928 and then Aliased_Present (Param_Spec) 10929 then 10930 Set_Is_Aliased (Formal); 10931 end if; 10932 10933 -- Ada 2005 (AI-231): Create and decorate an internal subtype 10934 -- declaration corresponding to the null-excluding type of the 10935 -- formal in the enclosing scope. Finally, replace the parameter 10936 -- type of the formal with the internal subtype. 10937 10938 if Ada_Version >= Ada_2005 10939 and then Null_Exclusion_Present (Param_Spec) 10940 then 10941 if not Is_Access_Type (Formal_Type) then 10942 Error_Msg_N 10943 ("`NOT NULL` allowed only for an access type", Param_Spec); 10944 10945 else 10946 if Can_Never_Be_Null (Formal_Type) 10947 and then Comes_From_Source (Related_Nod) 10948 then 10949 Error_Msg_NE 10950 ("`NOT NULL` not allowed (& already excludes null)", 10951 Param_Spec, Formal_Type); 10952 end if; 10953 10954 Formal_Type := 10955 Create_Null_Excluding_Itype 10956 (T => Formal_Type, 10957 Related_Nod => Related_Nod, 10958 Scope_Id => Scope (Current_Scope)); 10959 10960 -- If the designated type of the itype is an itype that is 10961 -- not frozen yet, we set the Has_Delayed_Freeze attribute 10962 -- on the access subtype, to prevent order-of-elaboration 10963 -- issues in the backend. 10964 10965 -- Example: 10966 -- type T is access procedure; 10967 -- procedure Op (O : not null T); 10968 10969 if Is_Itype (Directly_Designated_Type (Formal_Type)) 10970 and then 10971 not Is_Frozen (Directly_Designated_Type (Formal_Type)) 10972 then 10973 Set_Has_Delayed_Freeze (Formal_Type); 10974 end if; 10975 end if; 10976 end if; 10977 10978 -- An access formal type 10979 10980 else 10981 Formal_Type := 10982 Access_Definition (Related_Nod, Parameter_Type (Param_Spec)); 10983 10984 -- No need to continue if we already notified errors 10985 10986 if not Present (Formal_Type) then 10987 return; 10988 end if; 10989 10990 -- Ada 2005 (AI-254) 10991 10992 declare 10993 AD : constant Node_Id := 10994 Access_To_Subprogram_Definition 10995 (Parameter_Type (Param_Spec)); 10996 begin 10997 if Present (AD) and then Protected_Present (AD) then 10998 Formal_Type := 10999 Replace_Anonymous_Access_To_Protected_Subprogram 11000 (Param_Spec); 11001 end if; 11002 end; 11003 end if; 11004 11005 Set_Etype (Formal, Formal_Type); 11006 11007 -- Deal with default expression if present 11008 11009 Default := Expression (Param_Spec); 11010 11011 if Present (Default) then 11012 Check_SPARK_Restriction 11013 ("default expression is not allowed", Default); 11014 11015 if Out_Present (Param_Spec) then 11016 Error_Msg_N 11017 ("default initialization only allowed for IN parameters", 11018 Param_Spec); 11019 end if; 11020 11021 -- Do the special preanalysis of the expression (see section on 11022 -- "Handling of Default Expressions" in the spec of package Sem). 11023 11024 Preanalyze_Spec_Expression (Default, Formal_Type); 11025 11026 -- An access to constant cannot be the default for 11027 -- an access parameter that is an access to variable. 11028 11029 if Ekind (Formal_Type) = E_Anonymous_Access_Type 11030 and then not Is_Access_Constant (Formal_Type) 11031 and then Is_Access_Type (Etype (Default)) 11032 and then Is_Access_Constant (Etype (Default)) 11033 then 11034 Error_Msg_N 11035 ("formal that is access to variable cannot be initialized " & 11036 "with an access-to-constant expression", Default); 11037 end if; 11038 11039 -- Check that the designated type of an access parameter's default 11040 -- is not a class-wide type unless the parameter's designated type 11041 -- is also class-wide. 11042 11043 if Ekind (Formal_Type) = E_Anonymous_Access_Type 11044 and then not Designates_From_With_Type (Formal_Type) 11045 and then Is_Class_Wide_Default (Default) 11046 and then not Is_Class_Wide_Type (Designated_Type (Formal_Type)) 11047 then 11048 Error_Msg_N 11049 ("access to class-wide expression not allowed here", Default); 11050 end if; 11051 11052 -- Check incorrect use of dynamically tagged expressions 11053 11054 if Is_Tagged_Type (Formal_Type) then 11055 Check_Dynamically_Tagged_Expression 11056 (Expr => Default, 11057 Typ => Formal_Type, 11058 Related_Nod => Default); 11059 end if; 11060 end if; 11061 11062 -- Ada 2005 (AI-231): Static checks 11063 11064 if Ada_Version >= Ada_2005 11065 and then Is_Access_Type (Etype (Formal)) 11066 and then Can_Never_Be_Null (Etype (Formal)) 11067 then 11068 Null_Exclusion_Static_Checks (Param_Spec); 11069 end if; 11070 11071 <<Continue>> 11072 Next (Param_Spec); 11073 end loop; 11074 11075 -- If this is the formal part of a function specification, analyze the 11076 -- subtype mark in the context where the formals are visible but not 11077 -- yet usable, and may hide outer homographs. 11078 11079 if Nkind (Related_Nod) = N_Function_Specification then 11080 Analyze_Return_Type (Related_Nod); 11081 end if; 11082 11083 -- Now set the kind (mode) of each formal 11084 11085 Param_Spec := First (T); 11086 while Present (Param_Spec) loop 11087 Formal := Defining_Identifier (Param_Spec); 11088 Set_Formal_Mode (Formal); 11089 11090 if Ekind (Formal) = E_In_Parameter then 11091 Set_Default_Value (Formal, Expression (Param_Spec)); 11092 11093 if Present (Expression (Param_Spec)) then 11094 Default := Expression (Param_Spec); 11095 11096 if Is_Scalar_Type (Etype (Default)) then 11097 if Nkind (Parameter_Type (Param_Spec)) /= 11098 N_Access_Definition 11099 then 11100 Formal_Type := Entity (Parameter_Type (Param_Spec)); 11101 else 11102 Formal_Type := 11103 Access_Definition 11104 (Related_Nod, Parameter_Type (Param_Spec)); 11105 end if; 11106 11107 Apply_Scalar_Range_Check (Default, Formal_Type); 11108 end if; 11109 end if; 11110 11111 elsif Ekind (Formal) = E_Out_Parameter then 11112 Num_Out_Params := Num_Out_Params + 1; 11113 11114 if Num_Out_Params = 1 then 11115 First_Out_Param := Formal; 11116 end if; 11117 11118 elsif Ekind (Formal) = E_In_Out_Parameter then 11119 Num_Out_Params := Num_Out_Params + 1; 11120 end if; 11121 11122 -- Skip remaining processing if formal type was in error 11123 11124 if Etype (Formal) = Any_Type or else Error_Posted (Formal) then 11125 goto Next_Parameter; 11126 end if; 11127 11128 -- Force call by reference if aliased 11129 11130 if Is_Aliased (Formal) then 11131 Set_Mechanism (Formal, By_Reference); 11132 11133 -- Warn if user asked this to be passed by copy 11134 11135 if Convention (Formal_Type) = Convention_Ada_Pass_By_Copy then 11136 Error_Msg_N 11137 ("cannot pass aliased parameter & by copy?", Formal); 11138 end if; 11139 11140 -- Force mechanism if type has Convention Ada_Pass_By_Ref/Copy 11141 11142 elsif Convention (Formal_Type) = Convention_Ada_Pass_By_Copy then 11143 Set_Mechanism (Formal, By_Copy); 11144 11145 elsif Convention (Formal_Type) = Convention_Ada_Pass_By_Reference then 11146 Set_Mechanism (Formal, By_Reference); 11147 end if; 11148 11149 <<Next_Parameter>> 11150 Next (Param_Spec); 11151 end loop; 11152 11153 if Present (First_Out_Param) and then Num_Out_Params = 1 then 11154 Set_Is_Only_Out_Parameter (First_Out_Param); 11155 end if; 11156 end Process_Formals; 11157 11158 ------------------ 11159 -- Process_PPCs -- 11160 ------------------ 11161 11162 procedure Process_PPCs 11163 (N : Node_Id; 11164 Spec_Id : Entity_Id; 11165 Body_Id : Entity_Id) 11166 is 11167 Loc : constant Source_Ptr := Sloc (N); 11168 Prag : Node_Id; 11169 Parms : List_Id; 11170 11171 Designator : Entity_Id; 11172 -- Subprogram designator, set from Spec_Id if present, else Body_Id 11173 11174 Precond : Node_Id := Empty; 11175 -- Set non-Empty if we prepend precondition to the declarations. This 11176 -- is used to hook up inherited preconditions (adding the condition 11177 -- expression with OR ELSE, and adding the message). 11178 11179 Inherited_Precond : Node_Id; 11180 -- Precondition inherited from parent subprogram 11181 11182 Inherited : constant Subprogram_List := 11183 Inherited_Subprograms (Spec_Id); 11184 -- List of subprograms inherited by this subprogram 11185 11186 Plist : List_Id := No_List; 11187 -- List of generated postconditions 11188 11189 procedure Check_Access_Invariants (E : Entity_Id); 11190 -- If the subprogram returns an access to a type with invariants, or 11191 -- has access parameters whose designated type has an invariant, then 11192 -- under the same visibility conditions as for other invariant checks, 11193 -- the type invariant must be applied to the returned value. 11194 11195 procedure Expand_Contract_Cases (CCs : Node_Id; Subp_Id : Entity_Id); 11196 -- Given pragma Contract_Cases CCs, create the circuitry needed to 11197 -- evaluate case guards and trigger consequence expressions. Subp_Id 11198 -- denotes the related subprogram. 11199 11200 function Grab_CC return Node_Id; 11201 -- Prag contains an analyzed contract case pragma. This function copies 11202 -- relevant components of the pragma, creates the corresponding Check 11203 -- pragma and returns the Check pragma as the result. 11204 11205 function Grab_PPC (Pspec : Entity_Id := Empty) return Node_Id; 11206 -- Prag contains an analyzed precondition or postcondition pragma. This 11207 -- function copies the pragma, changes it to the corresponding Check 11208 -- pragma and returns the Check pragma as the result. If Pspec is non- 11209 -- empty, this is the case of inheriting a PPC, where we must change 11210 -- references to parameters of the inherited subprogram to point to the 11211 -- corresponding parameters of the current subprogram. 11212 11213 procedure Insert_After_Last_Declaration (Nod : Node_Id); 11214 -- Insert node Nod after the last declaration of the context 11215 11216 function Invariants_Or_Predicates_Present return Boolean; 11217 -- Determines if any invariants or predicates are present for any OUT 11218 -- or IN OUT parameters of the subprogram, or (for a function) if the 11219 -- return value has an invariant. 11220 11221 function Is_Public_Subprogram_For (T : Entity_Id) return Boolean; 11222 -- T is the entity for a private type for which invariants are defined. 11223 -- This function returns True if the procedure corresponding to the 11224 -- value of Designator is a public procedure from the point of view of 11225 -- this type (i.e. its spec is in the visible part of the package that 11226 -- contains the declaration of the private type). A True value means 11227 -- that an invariant check is required (for an IN OUT parameter, or 11228 -- the returned value of a function. 11229 11230 ----------------------------- 11231 -- Check_Access_Invariants -- 11232 ----------------------------- 11233 11234 procedure Check_Access_Invariants (E : Entity_Id) is 11235 Call : Node_Id; 11236 Obj : Node_Id; 11237 Typ : Entity_Id; 11238 11239 begin 11240 if Is_Access_Type (Etype (E)) 11241 and then not Is_Access_Constant (Etype (E)) 11242 then 11243 Typ := Designated_Type (Etype (E)); 11244 11245 if Has_Invariants (Typ) 11246 and then Present (Invariant_Procedure (Typ)) 11247 and then Is_Public_Subprogram_For (Typ) 11248 then 11249 Obj := 11250 Make_Explicit_Dereference (Loc, 11251 Prefix => New_Occurrence_Of (E, Loc)); 11252 Set_Etype (Obj, Typ); 11253 11254 Call := Make_Invariant_Call (Obj); 11255 11256 Append_To (Plist, 11257 Make_If_Statement (Loc, 11258 Condition => 11259 Make_Op_Ne (Loc, 11260 Left_Opnd => Make_Null (Loc), 11261 Right_Opnd => New_Occurrence_Of (E, Loc)), 11262 Then_Statements => New_List (Call))); 11263 end if; 11264 end if; 11265 end Check_Access_Invariants; 11266 11267 --------------------------- 11268 -- Expand_Contract_Cases -- 11269 --------------------------- 11270 11271 -- Pragma Contract_Cases is expanded in the following manner: 11272 11273 -- subprogram S is 11274 -- Flag_1 : Boolean := False; 11275 -- . . . 11276 -- Flag_N : Boolean := False; 11277 -- Flag_N+1 : Boolean := False; -- when "others" present 11278 -- Count : Natural := 0; 11279 11280 -- <preconditions (if any)> 11281 11282 -- if Case_Guard_1 then 11283 -- Flag_1 := True; 11284 -- Count := Count + 1; 11285 -- end if; 11286 -- . . . 11287 -- if Case_Guard_N then 11288 -- Flag_N := True; 11289 -- Count := Count + 1; 11290 -- end if; 11291 11292 -- if Count = 0 then 11293 -- raise Assertion_Error with "contract cases incomplete"; 11294 -- <or> 11295 -- Flag_N+1 := True; -- when "others" present 11296 11297 -- elsif Count > 1 then 11298 -- declare 11299 -- Str0 : constant String := 11300 -- "contract cases overlap for subprogram ABC"; 11301 -- Str1 : constant String := 11302 -- (if Flag_1 then 11303 -- Str0 & "case guard at xxx evaluates to True" 11304 -- else Str0); 11305 -- StrN : constant String := 11306 -- (if Flag_N then 11307 -- StrN-1 & "case guard at xxx evaluates to True" 11308 -- else StrN-1); 11309 -- begin 11310 -- raise Assertion_Error with StrN; 11311 -- end; 11312 -- end if; 11313 11314 -- procedure _Postconditions is 11315 -- begin 11316 -- <postconditions (if any)> 11317 11318 -- if Flag_1 and then not Consequence_1 then 11319 -- raise Assertion_Error with "failed contract case at xxx"; 11320 -- end if; 11321 -- . . . 11322 -- if Flag_N[+1] and then not Consequence_N[+1] then 11323 -- raise Assertion_Error with "failed contract case at xxx"; 11324 -- end if; 11325 -- end _Postconditions; 11326 -- begin 11327 -- . . . 11328 -- end S; 11329 11330 procedure Expand_Contract_Cases (CCs : Node_Id; Subp_Id : Entity_Id) is 11331 Loc : constant Source_Ptr := Sloc (CCs); 11332 11333 procedure Case_Guard_Error 11334 (Decls : List_Id; 11335 Flag : Entity_Id; 11336 Error_Loc : Source_Ptr; 11337 Msg : in out Entity_Id); 11338 -- Given a declarative list Decls, status flag Flag, the location of 11339 -- the error and a string Msg, construct the following check: 11340 -- Msg : constant String := 11341 -- (if Flag then 11342 -- Msg & "case guard at Error_Loc evaluates to True" 11343 -- else Msg); 11344 -- The resulting code is added to Decls 11345 11346 procedure Consequence_Error 11347 (Checks : in out Node_Id; 11348 Flag : Entity_Id; 11349 Conseq : Node_Id); 11350 -- Given an if statement Checks, status flag Flag and a consequence 11351 -- Conseq, construct the following check: 11352 -- [els]if Flag and then not Conseq then 11353 -- raise Assertion_Error 11354 -- with "failed contract case at Sloc (Conseq)"; 11355 -- [end if;] 11356 -- The resulting code is added to Checks 11357 11358 function Declaration_Of (Id : Entity_Id) return Node_Id; 11359 -- Given the entity Id of a boolean flag, generate: 11360 -- Id : Boolean := False; 11361 11362 function Increment (Id : Entity_Id) return Node_Id; 11363 -- Given the entity Id of a numerical variable, generate: 11364 -- Id := Id + 1; 11365 11366 function Set (Id : Entity_Id) return Node_Id; 11367 -- Given the entity Id of a boolean variable, generate: 11368 -- Id := True; 11369 11370 ---------------------- 11371 -- Case_Guard_Error -- 11372 ---------------------- 11373 11374 procedure Case_Guard_Error 11375 (Decls : List_Id; 11376 Flag : Entity_Id; 11377 Error_Loc : Source_Ptr; 11378 Msg : in out Entity_Id) 11379 is 11380 New_Line : constant Character := Character'Val (10); 11381 New_Msg : constant Entity_Id := Make_Temporary (Loc, 'S'); 11382 11383 begin 11384 Start_String; 11385 Store_String_Char (New_Line); 11386 Store_String_Chars (" case guard at "); 11387 Store_String_Chars (Build_Location_String (Error_Loc)); 11388 Store_String_Chars (" evaluates to True"); 11389 11390 -- Generate: 11391 -- New_Msg : constant String := 11392 -- (if Flag then 11393 -- Msg & "case guard at Error_Loc evaluates to True" 11394 -- else Msg); 11395 11396 Append_To (Decls, 11397 Make_Object_Declaration (Loc, 11398 Defining_Identifier => New_Msg, 11399 Constant_Present => True, 11400 Object_Definition => New_Reference_To (Standard_String, Loc), 11401 Expression => 11402 Make_If_Expression (Loc, 11403 Expressions => New_List ( 11404 New_Reference_To (Flag, Loc), 11405 11406 Make_Op_Concat (Loc, 11407 Left_Opnd => New_Reference_To (Msg, Loc), 11408 Right_Opnd => Make_String_Literal (Loc, End_String)), 11409 11410 New_Reference_To (Msg, Loc))))); 11411 11412 Msg := New_Msg; 11413 end Case_Guard_Error; 11414 11415 ----------------------- 11416 -- Consequence_Error -- 11417 ----------------------- 11418 11419 procedure Consequence_Error 11420 (Checks : in out Node_Id; 11421 Flag : Entity_Id; 11422 Conseq : Node_Id) 11423 is 11424 Cond : Node_Id; 11425 Error : Node_Id; 11426 11427 begin 11428 -- Generate: 11429 -- Flag and then not Conseq 11430 11431 Cond := 11432 Make_And_Then (Loc, 11433 Left_Opnd => New_Reference_To (Flag, Loc), 11434 Right_Opnd => 11435 Make_Op_Not (Loc, 11436 Right_Opnd => Relocate_Node (Conseq))); 11437 11438 -- Generate: 11439 -- raise Assertion_Error 11440 -- with "failed contract case at Sloc (Conseq)"; 11441 11442 Start_String; 11443 Store_String_Chars ("failed contract case at "); 11444 Store_String_Chars (Build_Location_String (Sloc (Conseq))); 11445 11446 Error := 11447 Make_Procedure_Call_Statement (Loc, 11448 Name => 11449 New_Reference_To (RTE (RE_Raise_Assert_Failure), Loc), 11450 Parameter_Associations => New_List ( 11451 Make_String_Literal (Loc, End_String))); 11452 11453 if No (Checks) then 11454 Checks := 11455 Make_If_Statement (Loc, 11456 Condition => Cond, 11457 Then_Statements => New_List (Error)); 11458 11459 else 11460 if No (Elsif_Parts (Checks)) then 11461 Set_Elsif_Parts (Checks, New_List); 11462 end if; 11463 11464 Append_To (Elsif_Parts (Checks), 11465 Make_Elsif_Part (Loc, 11466 Condition => Cond, 11467 Then_Statements => New_List (Error))); 11468 end if; 11469 end Consequence_Error; 11470 11471 -------------------- 11472 -- Declaration_Of -- 11473 -------------------- 11474 11475 function Declaration_Of (Id : Entity_Id) return Node_Id is 11476 begin 11477 return 11478 Make_Object_Declaration (Loc, 11479 Defining_Identifier => Id, 11480 Object_Definition => 11481 New_Reference_To (Standard_Boolean, Loc), 11482 Expression => 11483 New_Reference_To (Standard_False, Loc)); 11484 end Declaration_Of; 11485 11486 --------------- 11487 -- Increment -- 11488 --------------- 11489 11490 function Increment (Id : Entity_Id) return Node_Id is 11491 begin 11492 return 11493 Make_Assignment_Statement (Loc, 11494 Name => New_Reference_To (Id, Loc), 11495 Expression => 11496 Make_Op_Add (Loc, 11497 Left_Opnd => New_Reference_To (Id, Loc), 11498 Right_Opnd => Make_Integer_Literal (Loc, 1))); 11499 end Increment; 11500 11501 --------- 11502 -- Set -- 11503 --------- 11504 11505 function Set (Id : Entity_Id) return Node_Id is 11506 begin 11507 return 11508 Make_Assignment_Statement (Loc, 11509 Name => New_Reference_To (Id, Loc), 11510 Expression => New_Reference_To (Standard_True, Loc)); 11511 end Set; 11512 11513 -- Local variables 11514 11515 Aggr : constant Node_Id := 11516 Expression (First 11517 (Pragma_Argument_Associations (CCs))); 11518 Decls : constant List_Id := Declarations (N); 11519 Multiple_PCs : constant Boolean := 11520 List_Length (Component_Associations (Aggr)) > 1; 11521 Case_Guard : Node_Id; 11522 CG_Checks : Node_Id; 11523 CG_Stmts : List_Id; 11524 Conseq : Node_Id; 11525 Conseq_Checks : Node_Id := Empty; 11526 Count : Entity_Id; 11527 Error_Decls : List_Id; 11528 Flag : Entity_Id; 11529 Msg_Str : Entity_Id; 11530 Others_Flag : Entity_Id := Empty; 11531 Post_Case : Node_Id; 11532 11533 -- Start of processing for Expand_Contract_Cases 11534 11535 begin 11536 -- Create the counter which tracks the number of case guards that 11537 -- evaluate to True. 11538 11539 -- Count : Natural := 0; 11540 11541 Count := Make_Temporary (Loc, 'C'); 11542 11543 Prepend_To (Decls, 11544 Make_Object_Declaration (Loc, 11545 Defining_Identifier => Count, 11546 Object_Definition => New_Reference_To (Standard_Natural, Loc), 11547 Expression => Make_Integer_Literal (Loc, 0))); 11548 11549 -- Create the base error message for multiple overlapping case 11550 -- guards. 11551 11552 -- Msg_Str : constant String := 11553 -- "contract cases overlap for subprogram Subp_Id"; 11554 11555 if Multiple_PCs then 11556 Msg_Str := Make_Temporary (Loc, 'S'); 11557 11558 Start_String; 11559 Store_String_Chars ("contract cases overlap for subprogram "); 11560 Store_String_Chars (Get_Name_String (Chars (Subp_Id))); 11561 11562 Error_Decls := New_List ( 11563 Make_Object_Declaration (Loc, 11564 Defining_Identifier => Msg_Str, 11565 Constant_Present => True, 11566 Object_Definition => New_Reference_To (Standard_String, Loc), 11567 Expression => Make_String_Literal (Loc, End_String))); 11568 end if; 11569 11570 -- Process individual post cases 11571 11572 Post_Case := First (Component_Associations (Aggr)); 11573 while Present (Post_Case) loop 11574 Case_Guard := First (Choices (Post_Case)); 11575 Conseq := Expression (Post_Case); 11576 11577 -- The "others" choice requires special processing 11578 11579 if Nkind (Case_Guard) = N_Others_Choice then 11580 Others_Flag := Make_Temporary (Loc, 'F'); 11581 Prepend_To (Decls, Declaration_Of (Others_Flag)); 11582 11583 -- Check possible overlap between a case guard and "others" 11584 11585 if Multiple_PCs then 11586 Case_Guard_Error 11587 (Decls => Error_Decls, 11588 Flag => Others_Flag, 11589 Error_Loc => Sloc (Case_Guard), 11590 Msg => Msg_Str); 11591 end if; 11592 11593 -- Check the corresponding consequence of "others" 11594 11595 Consequence_Error 11596 (Checks => Conseq_Checks, 11597 Flag => Others_Flag, 11598 Conseq => Conseq); 11599 11600 -- Regular post case 11601 11602 else 11603 -- Create the flag which tracks the state of its associated 11604 -- case guard. 11605 11606 Flag := Make_Temporary (Loc, 'F'); 11607 Prepend_To (Decls, Declaration_Of (Flag)); 11608 11609 -- The flag is set when the case guard is evaluated to True 11610 -- if Case_Guard then 11611 -- Flag := True; 11612 -- Count := Count + 1; 11613 -- end if; 11614 11615 Append_To (Decls, 11616 Make_If_Statement (Loc, 11617 Condition => Relocate_Node (Case_Guard), 11618 Then_Statements => New_List ( 11619 Set (Flag), 11620 Increment (Count)))); 11621 11622 -- Check whether this case guard overlaps with another case 11623 -- guard. 11624 11625 if Multiple_PCs then 11626 Case_Guard_Error 11627 (Decls => Error_Decls, 11628 Flag => Flag, 11629 Error_Loc => Sloc (Case_Guard), 11630 Msg => Msg_Str); 11631 end if; 11632 11633 -- The corresponding consequence of the case guard which 11634 -- evaluated to True must hold on exit from the subprogram. 11635 11636 Consequence_Error (Conseq_Checks, Flag, Conseq); 11637 end if; 11638 11639 Next (Post_Case); 11640 end loop; 11641 11642 -- Raise Assertion_Error when none of the case guards evaluate to 11643 -- True. The only exception is when we have "others", in which case 11644 -- there is no error because "others" acts as a default True. 11645 11646 -- Generate: 11647 -- Flag := True; 11648 11649 if Present (Others_Flag) then 11650 CG_Stmts := New_List (Set (Others_Flag)); 11651 11652 -- Generate: 11653 -- raise Assetion_Error with "contract cases incomplete"; 11654 11655 else 11656 Start_String; 11657 Store_String_Chars ("contract cases incomplete"); 11658 11659 CG_Stmts := New_List ( 11660 Make_Procedure_Call_Statement (Loc, 11661 Name => 11662 New_Reference_To (RTE (RE_Raise_Assert_Failure), Loc), 11663 Parameter_Associations => New_List ( 11664 Make_String_Literal (Loc, End_String)))); 11665 end if; 11666 11667 CG_Checks := 11668 Make_If_Statement (Loc, 11669 Condition => 11670 Make_Op_Eq (Loc, 11671 Left_Opnd => New_Reference_To (Count, Loc), 11672 Right_Opnd => Make_Integer_Literal (Loc, 0)), 11673 Then_Statements => CG_Stmts); 11674 11675 -- Detect a possible failure due to several case guards evaluating to 11676 -- True. 11677 11678 -- Generate: 11679 -- elsif Count > 0 then 11680 -- declare 11681 -- <Error_Decls> 11682 -- begin 11683 -- raise Assertion_Error with <Msg_Str>; 11684 -- end if; 11685 11686 if Multiple_PCs then 11687 Set_Elsif_Parts (CG_Checks, New_List ( 11688 Make_Elsif_Part (Loc, 11689 Condition => 11690 Make_Op_Gt (Loc, 11691 Left_Opnd => New_Reference_To (Count, Loc), 11692 Right_Opnd => Make_Integer_Literal (Loc, 1)), 11693 11694 Then_Statements => New_List ( 11695 Make_Block_Statement (Loc, 11696 Declarations => Error_Decls, 11697 Handled_Statement_Sequence => 11698 Make_Handled_Sequence_Of_Statements (Loc, 11699 Statements => New_List ( 11700 Make_Procedure_Call_Statement (Loc, 11701 Name => 11702 New_Reference_To 11703 (RTE (RE_Raise_Assert_Failure), Loc), 11704 Parameter_Associations => New_List ( 11705 New_Reference_To (Msg_Str, Loc)))))))))); 11706 end if; 11707 11708 Append_To (Decls, CG_Checks); 11709 11710 -- Raise Assertion_Error when the corresponding consequence of a case 11711 -- guard that evaluated to True fails. 11712 11713 if No (Plist) then 11714 Plist := New_List; 11715 end if; 11716 11717 Append_To (Plist, Conseq_Checks); 11718 end Expand_Contract_Cases; 11719 11720 ------------- 11721 -- Grab_CC -- 11722 ------------- 11723 11724 function Grab_CC return Node_Id is 11725 Loc : constant Source_Ptr := Sloc (Prag); 11726 CP : Node_Id; 11727 Req : Node_Id; 11728 Ens : Node_Id; 11729 Post : Node_Id; 11730 11731 -- As with postcondition, the string is "failed xx from yy" where 11732 -- xx is in all lower case. The reason for this different wording 11733 -- compared to other Check cases is that the failure is not at the 11734 -- point of occurrence of the pragma, unlike the other Check cases. 11735 11736 Msg : constant String := 11737 "failed contract case from " & Build_Location_String (Loc); 11738 11739 begin 11740 -- Copy the Requires and Ensures expressions 11741 11742 Req := New_Copy_Tree 11743 (Expression (Get_Requires_From_CTC_Pragma (Prag)), 11744 New_Scope => Current_Scope); 11745 11746 Ens := New_Copy_Tree 11747 (Expression (Get_Ensures_From_CTC_Pragma (Prag)), 11748 New_Scope => Current_Scope); 11749 11750 -- Build the postcondition (not Requires'Old or else Ensures) 11751 11752 Post := 11753 Make_Or_Else (Loc, 11754 Left_Opnd => 11755 Make_Op_Not (Loc, 11756 Make_Attribute_Reference (Loc, 11757 Prefix => Req, 11758 Attribute_Name => Name_Old)), 11759 Right_Opnd => Ens); 11760 11761 -- For a contract case pragma within a generic, generate a 11762 -- postcondition pragma for later expansion. This is also used 11763 -- when an error was detected, thus setting Expander_Active to False. 11764 11765 if not Expander_Active then 11766 CP := 11767 Make_Pragma (Loc, 11768 Chars => Name_Postcondition, 11769 Pragma_Argument_Associations => New_List ( 11770 Make_Pragma_Argument_Association (Loc, 11771 Chars => Name_Check, 11772 Expression => Post), 11773 11774 Make_Pragma_Argument_Association (Loc, 11775 Chars => Name_Message, 11776 Expression => Make_String_Literal (Loc, Msg)))); 11777 11778 -- Otherwise, create the Check pragma 11779 11780 else 11781 CP := 11782 Make_Pragma (Loc, 11783 Chars => Name_Check, 11784 Pragma_Argument_Associations => New_List ( 11785 Make_Pragma_Argument_Association (Loc, 11786 Chars => Name_Name, 11787 Expression => Make_Identifier (Loc, Name_Postcondition)), 11788 11789 Make_Pragma_Argument_Association (Loc, 11790 Chars => Name_Check, 11791 Expression => Post), 11792 11793 Make_Pragma_Argument_Association (Loc, 11794 Chars => Name_Message, 11795 Expression => Make_String_Literal (Loc, Msg)))); 11796 end if; 11797 11798 -- Return the Postcondition or Check pragma 11799 11800 return CP; 11801 end Grab_CC; 11802 11803 -------------- 11804 -- Grab_PPC -- 11805 -------------- 11806 11807 function Grab_PPC (Pspec : Entity_Id := Empty) return Node_Id is 11808 Nam : constant Name_Id := Pragma_Name (Prag); 11809 Map : Elist_Id; 11810 CP : Node_Id; 11811 11812 begin 11813 -- Prepare map if this is the case where we have to map entities of 11814 -- arguments in the overridden subprogram to corresponding entities 11815 -- of the current subprogram. 11816 11817 if No (Pspec) then 11818 Map := No_Elist; 11819 11820 else 11821 declare 11822 PF : Entity_Id; 11823 CF : Entity_Id; 11824 11825 begin 11826 Map := New_Elmt_List; 11827 PF := First_Formal (Pspec); 11828 CF := First_Formal (Designator); 11829 while Present (PF) loop 11830 Append_Elmt (PF, Map); 11831 Append_Elmt (CF, Map); 11832 Next_Formal (PF); 11833 Next_Formal (CF); 11834 end loop; 11835 end; 11836 end if; 11837 11838 -- Now we can copy the tree, doing any required substitutions 11839 11840 CP := New_Copy_Tree (Prag, Map => Map, New_Scope => Current_Scope); 11841 11842 -- Set Analyzed to false, since we want to reanalyze the check 11843 -- procedure. Note that it is only at the outer level that we 11844 -- do this fiddling, for the spec cases, the already preanalyzed 11845 -- parameters are not affected. 11846 11847 Set_Analyzed (CP, False); 11848 11849 -- We also make sure Comes_From_Source is False for the copy 11850 11851 Set_Comes_From_Source (CP, False); 11852 11853 -- For a postcondition pragma within a generic, preserve the pragma 11854 -- for later expansion. This is also used when an error was detected, 11855 -- thus setting Expander_Active to False. 11856 11857 if Nam = Name_Postcondition 11858 and then not Expander_Active 11859 then 11860 return CP; 11861 end if; 11862 11863 -- Change copy of pragma into corresponding pragma Check 11864 11865 Prepend_To (Pragma_Argument_Associations (CP), 11866 Make_Pragma_Argument_Association (Sloc (Prag), 11867 Expression => Make_Identifier (Loc, Nam))); 11868 Set_Pragma_Identifier (CP, Make_Identifier (Sloc (Prag), Name_Check)); 11869 11870 -- If this is inherited case and the current message starts with 11871 -- "failed p", we change it to "failed inherited p...". 11872 11873 if Present (Pspec) then 11874 declare 11875 Msg : constant Node_Id := 11876 Last (Pragma_Argument_Associations (CP)); 11877 11878 begin 11879 if Chars (Msg) = Name_Message then 11880 String_To_Name_Buffer (Strval (Expression (Msg))); 11881 11882 if Name_Buffer (1 .. 8) = "failed p" then 11883 Insert_Str_In_Name_Buffer ("inherited ", 8); 11884 Set_Strval 11885 (Expression (Last (Pragma_Argument_Associations (CP))), 11886 String_From_Name_Buffer); 11887 end if; 11888 end if; 11889 end; 11890 end if; 11891 11892 -- Return the check pragma 11893 11894 return CP; 11895 end Grab_PPC; 11896 11897 ----------------------------------- 11898 -- Insert_After_Last_Declaration -- 11899 ----------------------------------- 11900 11901 procedure Insert_After_Last_Declaration (Nod : Node_Id) is 11902 Decls : constant List_Id := Declarations (N); 11903 11904 begin 11905 if No (Decls) then 11906 Set_Declarations (N, New_List (Nod)); 11907 else 11908 Append_To (Decls, Nod); 11909 end if; 11910 end Insert_After_Last_Declaration; 11911 11912 -------------------------------------- 11913 -- Invariants_Or_Predicates_Present -- 11914 -------------------------------------- 11915 11916 function Invariants_Or_Predicates_Present return Boolean is 11917 Formal : Entity_Id; 11918 11919 begin 11920 -- Check function return result. If result is an access type there 11921 -- may be invariants on the designated type. 11922 11923 if Ekind (Designator) /= E_Procedure 11924 and then Has_Invariants (Etype (Designator)) 11925 then 11926 return True; 11927 11928 elsif Ekind (Designator) /= E_Procedure 11929 and then Is_Access_Type (Etype (Designator)) 11930 and then Has_Invariants (Designated_Type (Etype (Designator))) 11931 then 11932 return True; 11933 end if; 11934 11935 -- Check parameters 11936 11937 Formal := First_Formal (Designator); 11938 while Present (Formal) loop 11939 if Ekind (Formal) /= E_In_Parameter 11940 and then (Has_Invariants (Etype (Formal)) 11941 or else Present (Predicate_Function (Etype (Formal)))) 11942 then 11943 return True; 11944 11945 elsif Is_Access_Type (Etype (Formal)) 11946 and then Has_Invariants (Designated_Type (Etype (Formal))) 11947 then 11948 return True; 11949 end if; 11950 11951 Next_Formal (Formal); 11952 end loop; 11953 11954 return False; 11955 end Invariants_Or_Predicates_Present; 11956 11957 ------------------------------ 11958 -- Is_Public_Subprogram_For -- 11959 ------------------------------ 11960 11961 -- The type T is a private type, its declaration is therefore in 11962 -- the list of public declarations of some package. The test for a 11963 -- public subprogram is that its declaration is in this same list 11964 -- of declarations for the same package (note that all the public 11965 -- declarations are in one list, and all the private declarations 11966 -- in another, so this deals with the public/private distinction). 11967 11968 function Is_Public_Subprogram_For (T : Entity_Id) return Boolean is 11969 DD : constant Node_Id := Unit_Declaration_Node (Designator); 11970 -- The subprogram declaration for the subprogram in question 11971 11972 TL : constant List_Id := 11973 Visible_Declarations 11974 (Specification (Unit_Declaration_Node (Scope (T)))); 11975 -- The list of declarations containing the private declaration of 11976 -- the type. We know it is a private type, so we know its scope is 11977 -- the package in question, and we know it must be in the visible 11978 -- declarations of this package. 11979 11980 begin 11981 -- If the subprogram declaration is not a list member, it must be 11982 -- an Init_Proc, in which case we want to consider it to be a 11983 -- public subprogram, since we do get initializations to deal with. 11984 -- Other internally generated subprograms are not public. 11985 11986 if not Is_List_Member (DD) 11987 and then Is_Init_Proc (Defining_Entity (DD)) 11988 then 11989 return True; 11990 11991 -- The declaration may have been generated for an expression function 11992 -- so check whether that function comes from source. 11993 11994 elsif not Comes_From_Source (DD) 11995 and then 11996 (Nkind (Original_Node (DD)) /= N_Expression_Function 11997 or else not Comes_From_Source (Defining_Entity (DD))) 11998 then 11999 return False; 12000 12001 -- Otherwise we test whether the subprogram is declared in the 12002 -- visible declarations of the package containing the type. 12003 12004 else 12005 return TL = List_Containing (DD); 12006 end if; 12007 end Is_Public_Subprogram_For; 12008 12009 -- Start of processing for Process_PPCs 12010 12011 begin 12012 -- Capture designator from spec if present, else from body 12013 12014 if Present (Spec_Id) then 12015 Designator := Spec_Id; 12016 else 12017 Designator := Body_Id; 12018 end if; 12019 12020 -- Internally generated subprograms, such as type-specific functions, 12021 -- don't get assertion checks. 12022 12023 if Get_TSS_Name (Designator) /= TSS_Null then 12024 return; 12025 end if; 12026 12027 -- Grab preconditions from spec 12028 12029 if Present (Spec_Id) then 12030 12031 -- Loop through PPC pragmas from spec. Note that preconditions from 12032 -- the body will be analyzed and converted when we scan the body 12033 -- declarations below. 12034 12035 Prag := Spec_PPC_List (Contract (Spec_Id)); 12036 while Present (Prag) loop 12037 if Pragma_Name (Prag) = Name_Precondition then 12038 12039 -- For Pre (or Precondition pragma), we simply prepend the 12040 -- pragma to the list of declarations right away so that it 12041 -- will be executed at the start of the procedure. Note that 12042 -- this processing reverses the order of the list, which is 12043 -- what we want since new entries were chained to the head of 12044 -- the list. There can be more than one precondition when we 12045 -- use pragma Precondition. 12046 12047 if not Class_Present (Prag) then 12048 Prepend (Grab_PPC, Declarations (N)); 12049 12050 -- For Pre'Class there can only be one pragma, and we save 12051 -- it in Precond for now. We will add inherited Pre'Class 12052 -- stuff before inserting this pragma in the declarations. 12053 else 12054 Precond := Grab_PPC; 12055 end if; 12056 end if; 12057 12058 Prag := Next_Pragma (Prag); 12059 end loop; 12060 12061 -- Now deal with inherited preconditions 12062 12063 for J in Inherited'Range loop 12064 Prag := Spec_PPC_List (Contract (Inherited (J))); 12065 12066 while Present (Prag) loop 12067 if Pragma_Name (Prag) = Name_Precondition 12068 and then Class_Present (Prag) 12069 then 12070 Inherited_Precond := Grab_PPC (Inherited (J)); 12071 12072 -- No precondition so far, so establish this as the first 12073 12074 if No (Precond) then 12075 Precond := Inherited_Precond; 12076 12077 -- Here we already have a precondition, add inherited one 12078 12079 else 12080 -- Add new precondition to old one using OR ELSE 12081 12082 declare 12083 New_Expr : constant Node_Id := 12084 Get_Pragma_Arg 12085 (Next 12086 (First 12087 (Pragma_Argument_Associations 12088 (Inherited_Precond)))); 12089 Old_Expr : constant Node_Id := 12090 Get_Pragma_Arg 12091 (Next 12092 (First 12093 (Pragma_Argument_Associations 12094 (Precond)))); 12095 12096 begin 12097 if Paren_Count (Old_Expr) = 0 then 12098 Set_Paren_Count (Old_Expr, 1); 12099 end if; 12100 12101 if Paren_Count (New_Expr) = 0 then 12102 Set_Paren_Count (New_Expr, 1); 12103 end if; 12104 12105 Rewrite (Old_Expr, 12106 Make_Or_Else (Sloc (Old_Expr), 12107 Left_Opnd => Relocate_Node (Old_Expr), 12108 Right_Opnd => New_Expr)); 12109 end; 12110 12111 -- Add new message in the form: 12112 12113 -- failed precondition from bla 12114 -- also failed inherited precondition from bla 12115 -- ... 12116 12117 -- Skip this if exception locations are suppressed 12118 12119 if not Exception_Locations_Suppressed then 12120 declare 12121 New_Msg : constant Node_Id := 12122 Get_Pragma_Arg 12123 (Last 12124 (Pragma_Argument_Associations 12125 (Inherited_Precond))); 12126 Old_Msg : constant Node_Id := 12127 Get_Pragma_Arg 12128 (Last 12129 (Pragma_Argument_Associations 12130 (Precond))); 12131 begin 12132 Start_String (Strval (Old_Msg)); 12133 Store_String_Chars (ASCII.LF & " also "); 12134 Store_String_Chars (Strval (New_Msg)); 12135 Set_Strval (Old_Msg, End_String); 12136 end; 12137 end if; 12138 end if; 12139 end if; 12140 12141 Prag := Next_Pragma (Prag); 12142 end loop; 12143 end loop; 12144 12145 -- If we have built a precondition for Pre'Class (including any 12146 -- Pre'Class aspects inherited from parent subprograms), then we 12147 -- insert this composite precondition at this stage. 12148 12149 if Present (Precond) then 12150 Prepend (Precond, Declarations (N)); 12151 end if; 12152 end if; 12153 12154 -- Build postconditions procedure if needed and prepend the following 12155 -- declaration to the start of the declarations for the subprogram. 12156 12157 -- procedure _postconditions [(_Result : resulttype)] is 12158 -- begin 12159 -- pragma Check (Postcondition, condition [,message]); 12160 -- pragma Check (Postcondition, condition [,message]); 12161 -- ... 12162 -- Invariant_Procedure (_Result) ... 12163 -- Invariant_Procedure (Arg1) 12164 -- ... 12165 -- end; 12166 12167 -- First we deal with the postconditions in the body 12168 12169 if Is_Non_Empty_List (Declarations (N)) then 12170 12171 -- Loop through declarations 12172 12173 Prag := First (Declarations (N)); 12174 while Present (Prag) loop 12175 if Nkind (Prag) = N_Pragma then 12176 12177 -- If pragma, capture if enabled postcondition, else ignore 12178 12179 if Pragma_Name (Prag) = Name_Postcondition 12180 and then Check_Enabled (Name_Postcondition) 12181 then 12182 if Plist = No_List then 12183 Plist := Empty_List; 12184 end if; 12185 12186 Analyze (Prag); 12187 12188 -- If expansion is disabled, as in a generic unit, save 12189 -- pragma for later expansion. 12190 12191 if not Expander_Active then 12192 Prepend (Grab_PPC, Declarations (N)); 12193 else 12194 Append (Grab_PPC, Plist); 12195 end if; 12196 end if; 12197 12198 Next (Prag); 12199 12200 -- Not a pragma, if comes from source, then end scan 12201 12202 elsif Comes_From_Source (Prag) then 12203 exit; 12204 12205 -- Skip stuff not coming from source 12206 12207 else 12208 Next (Prag); 12209 end if; 12210 end loop; 12211 end if; 12212 12213 -- Now deal with any postconditions from the spec 12214 12215 if Present (Spec_Id) then 12216 Spec_Postconditions : declare 12217 procedure Process_Contract_Cases (Spec : Node_Id); 12218 -- This processes the Spec_CTC_List from Spec, processing any 12219 -- contract-case from the list. The caller has checked that 12220 -- Spec_CTC_List is non-Empty. 12221 12222 procedure Process_Post_Conditions 12223 (Spec : Node_Id; 12224 Class : Boolean); 12225 -- This processes the Spec_PPC_List from Spec, processing any 12226 -- postconditions from the list. If Class is True, then only 12227 -- postconditions marked with Class_Present are considered. 12228 -- The caller has checked that Spec_PPC_List is non-Empty. 12229 12230 ---------------------------- 12231 -- Process_Contract_Cases -- 12232 ---------------------------- 12233 12234 procedure Process_Contract_Cases (Spec : Node_Id) is 12235 begin 12236 -- Loop through Contract_Case pragmas from spec 12237 12238 Prag := Spec_CTC_List (Contract (Spec)); 12239 loop 12240 if Pragma_Name (Prag) = Name_Contract_Case then 12241 if Plist = No_List then 12242 Plist := Empty_List; 12243 end if; 12244 12245 if not Expander_Active then 12246 Prepend (Grab_CC, Declarations (N)); 12247 else 12248 Append (Grab_CC, Plist); 12249 end if; 12250 12251 elsif Pragma_Name (Prag) = Name_Contract_Cases then 12252 Expand_Contract_Cases (Prag, Spec_Id); 12253 end if; 12254 12255 Prag := Next_Pragma (Prag); 12256 exit when No (Prag); 12257 end loop; 12258 end Process_Contract_Cases; 12259 12260 ----------------------------- 12261 -- Process_Post_Conditions -- 12262 ----------------------------- 12263 12264 procedure Process_Post_Conditions 12265 (Spec : Node_Id; 12266 Class : Boolean) 12267 is 12268 Pspec : Node_Id; 12269 12270 begin 12271 if Class then 12272 Pspec := Spec; 12273 else 12274 Pspec := Empty; 12275 end if; 12276 12277 -- Loop through PPC pragmas from spec 12278 12279 Prag := Spec_PPC_List (Contract (Spec)); 12280 loop 12281 if Pragma_Name (Prag) = Name_Postcondition 12282 and then (not Class or else Class_Present (Prag)) 12283 then 12284 if Plist = No_List then 12285 Plist := Empty_List; 12286 end if; 12287 12288 if not Expander_Active then 12289 Prepend 12290 (Grab_PPC (Pspec), Declarations (N)); 12291 else 12292 Append (Grab_PPC (Pspec), Plist); 12293 end if; 12294 end if; 12295 12296 Prag := Next_Pragma (Prag); 12297 exit when No (Prag); 12298 end loop; 12299 end Process_Post_Conditions; 12300 12301 -- Start of processing for Spec_Postconditions 12302 12303 begin 12304 -- Process postconditions expressed as contract-cases 12305 12306 if Present (Spec_CTC_List (Contract (Spec_Id))) then 12307 Process_Contract_Cases (Spec_Id); 12308 end if; 12309 12310 -- Process spec postconditions 12311 12312 if Present (Spec_PPC_List (Contract (Spec_Id))) then 12313 Process_Post_Conditions (Spec_Id, Class => False); 12314 end if; 12315 12316 -- Process inherited postconditions 12317 12318 for J in Inherited'Range loop 12319 if Present (Spec_PPC_List (Contract (Inherited (J)))) then 12320 Process_Post_Conditions (Inherited (J), Class => True); 12321 end if; 12322 end loop; 12323 end Spec_Postconditions; 12324 end if; 12325 12326 -- If we had any postconditions and expansion is enabled, or if the 12327 -- subprogram has invariants, then build the _Postconditions procedure. 12328 12329 if (Present (Plist) or else Invariants_Or_Predicates_Present) 12330 and then Expander_Active 12331 then 12332 if No (Plist) then 12333 Plist := Empty_List; 12334 end if; 12335 12336 -- Special processing for function return 12337 12338 if Ekind (Designator) /= E_Procedure then 12339 declare 12340 Rent : constant Entity_Id := 12341 Make_Defining_Identifier (Loc, Name_uResult); 12342 Ftyp : constant Entity_Id := Etype (Designator); 12343 12344 begin 12345 Set_Etype (Rent, Ftyp); 12346 12347 -- Add argument for return 12348 12349 Parms := 12350 New_List ( 12351 Make_Parameter_Specification (Loc, 12352 Parameter_Type => New_Occurrence_Of (Ftyp, Loc), 12353 Defining_Identifier => Rent)); 12354 12355 -- Add invariant call if returning type with invariants and 12356 -- this is a public function, i.e. a function declared in the 12357 -- visible part of the package defining the private type. 12358 12359 if Has_Invariants (Etype (Rent)) 12360 and then Present (Invariant_Procedure (Etype (Rent))) 12361 and then Is_Public_Subprogram_For (Etype (Rent)) 12362 then 12363 Append_To (Plist, 12364 Make_Invariant_Call (New_Occurrence_Of (Rent, Loc))); 12365 end if; 12366 12367 -- Same if return value is an access to type with invariants 12368 12369 Check_Access_Invariants (Rent); 12370 end; 12371 12372 -- Procedure rather than a function 12373 12374 else 12375 Parms := No_List; 12376 end if; 12377 12378 -- Add invariant calls and predicate calls for parameters. Note that 12379 -- this is done for functions as well, since in Ada 2012 they can 12380 -- have IN OUT args. 12381 12382 declare 12383 Formal : Entity_Id; 12384 Ftype : Entity_Id; 12385 12386 begin 12387 Formal := First_Formal (Designator); 12388 while Present (Formal) loop 12389 if Ekind (Formal) /= E_In_Parameter 12390 or else Is_Access_Type (Etype (Formal)) 12391 then 12392 Ftype := Etype (Formal); 12393 12394 if Has_Invariants (Ftype) 12395 and then Present (Invariant_Procedure (Ftype)) 12396 and then Is_Public_Subprogram_For (Ftype) 12397 then 12398 Append_To (Plist, 12399 Make_Invariant_Call 12400 (New_Occurrence_Of (Formal, Loc))); 12401 end if; 12402 12403 Check_Access_Invariants (Formal); 12404 12405 if Present (Predicate_Function (Ftype)) then 12406 Append_To (Plist, 12407 Make_Predicate_Check 12408 (Ftype, New_Occurrence_Of (Formal, Loc))); 12409 end if; 12410 end if; 12411 12412 Next_Formal (Formal); 12413 end loop; 12414 end; 12415 12416 -- Build and insert postcondition procedure 12417 12418 declare 12419 Post_Proc : constant Entity_Id := 12420 Make_Defining_Identifier (Loc, 12421 Chars => Name_uPostconditions); 12422 -- The entity for the _Postconditions procedure 12423 12424 begin 12425 -- Insert the corresponding body of a post condition pragma after 12426 -- the last declaration of the context. This ensures that the body 12427 -- will not cause any premature freezing as it may mention types: 12428 12429 -- procedure Proc (Obj : Array_Typ) is 12430 -- procedure _postconditions is 12431 -- begin 12432 -- ... Obj ... 12433 -- end _postconditions; 12434 12435 -- subtype T is Array_Typ (Obj'First (1) .. Obj'Last (1)); 12436 -- begin 12437 12438 -- In the example above, Obj is of type T but the incorrect 12439 -- placement of _postconditions will cause a crash in gigi due to 12440 -- an out of order reference. The body of _postconditions must be 12441 -- placed after the declaration of Temp to preserve correct 12442 -- visibility. 12443 12444 Insert_After_Last_Declaration ( 12445 Make_Subprogram_Body (Loc, 12446 Specification => 12447 Make_Procedure_Specification (Loc, 12448 Defining_Unit_Name => Post_Proc, 12449 Parameter_Specifications => Parms), 12450 12451 Declarations => Empty_List, 12452 12453 Handled_Statement_Sequence => 12454 Make_Handled_Sequence_Of_Statements (Loc, 12455 Statements => Plist))); 12456 12457 Set_Ekind (Post_Proc, E_Procedure); 12458 12459 -- If this is a procedure, set the Postcondition_Proc attribute on 12460 -- the proper defining entity for the subprogram. 12461 12462 if Ekind (Designator) = E_Procedure then 12463 Set_Postcondition_Proc (Designator, Post_Proc); 12464 end if; 12465 end; 12466 12467 Set_Has_Postconditions (Designator); 12468 end if; 12469 end Process_PPCs; 12470 12471 ---------------------------- 12472 -- Reference_Body_Formals -- 12473 ---------------------------- 12474 12475 procedure Reference_Body_Formals (Spec : Entity_Id; Bod : Entity_Id) is 12476 Fs : Entity_Id; 12477 Fb : Entity_Id; 12478 12479 begin 12480 if Error_Posted (Spec) then 12481 return; 12482 end if; 12483 12484 -- Iterate over both lists. They may be of different lengths if the two 12485 -- specs are not conformant. 12486 12487 Fs := First_Formal (Spec); 12488 Fb := First_Formal (Bod); 12489 while Present (Fs) and then Present (Fb) loop 12490 Generate_Reference (Fs, Fb, 'b'); 12491 12492 if Style_Check then 12493 Style.Check_Identifier (Fb, Fs); 12494 end if; 12495 12496 Set_Spec_Entity (Fb, Fs); 12497 Set_Referenced (Fs, False); 12498 Next_Formal (Fs); 12499 Next_Formal (Fb); 12500 end loop; 12501 end Reference_Body_Formals; 12502 12503 ------------------------- 12504 -- Set_Actual_Subtypes -- 12505 ------------------------- 12506 12507 procedure Set_Actual_Subtypes (N : Node_Id; Subp : Entity_Id) is 12508 Decl : Node_Id; 12509 Formal : Entity_Id; 12510 T : Entity_Id; 12511 First_Stmt : Node_Id := Empty; 12512 AS_Needed : Boolean; 12513 12514 begin 12515 -- If this is an empty initialization procedure, no need to create 12516 -- actual subtypes (small optimization). 12517 12518 if Ekind (Subp) = E_Procedure 12519 and then Is_Null_Init_Proc (Subp) 12520 then 12521 return; 12522 end if; 12523 12524 Formal := First_Formal (Subp); 12525 while Present (Formal) loop 12526 T := Etype (Formal); 12527 12528 -- We never need an actual subtype for a constrained formal 12529 12530 if Is_Constrained (T) then 12531 AS_Needed := False; 12532 12533 -- If we have unknown discriminants, then we do not need an actual 12534 -- subtype, or more accurately we cannot figure it out! Note that 12535 -- all class-wide types have unknown discriminants. 12536 12537 elsif Has_Unknown_Discriminants (T) then 12538 AS_Needed := False; 12539 12540 -- At this stage we have an unconstrained type that may need an 12541 -- actual subtype. For sure the actual subtype is needed if we have 12542 -- an unconstrained array type. 12543 12544 elsif Is_Array_Type (T) then 12545 AS_Needed := True; 12546 12547 -- The only other case needing an actual subtype is an unconstrained 12548 -- record type which is an IN parameter (we cannot generate actual 12549 -- subtypes for the OUT or IN OUT case, since an assignment can 12550 -- change the discriminant values. However we exclude the case of 12551 -- initialization procedures, since discriminants are handled very 12552 -- specially in this context, see the section entitled "Handling of 12553 -- Discriminants" in Einfo. 12554 12555 -- We also exclude the case of Discrim_SO_Functions (functions used 12556 -- in front end layout mode for size/offset values), since in such 12557 -- functions only discriminants are referenced, and not only are such 12558 -- subtypes not needed, but they cannot always be generated, because 12559 -- of order of elaboration issues. 12560 12561 elsif Is_Record_Type (T) 12562 and then Ekind (Formal) = E_In_Parameter 12563 and then Chars (Formal) /= Name_uInit 12564 and then not Is_Unchecked_Union (T) 12565 and then not Is_Discrim_SO_Function (Subp) 12566 then 12567 AS_Needed := True; 12568 12569 -- All other cases do not need an actual subtype 12570 12571 else 12572 AS_Needed := False; 12573 end if; 12574 12575 -- Generate actual subtypes for unconstrained arrays and 12576 -- unconstrained discriminated records. 12577 12578 if AS_Needed then 12579 if Nkind (N) = N_Accept_Statement then 12580 12581 -- If expansion is active, the formal is replaced by a local 12582 -- variable that renames the corresponding entry of the 12583 -- parameter block, and it is this local variable that may 12584 -- require an actual subtype. 12585 12586 if Full_Expander_Active then 12587 Decl := Build_Actual_Subtype (T, Renamed_Object (Formal)); 12588 else 12589 Decl := Build_Actual_Subtype (T, Formal); 12590 end if; 12591 12592 if Present (Handled_Statement_Sequence (N)) then 12593 First_Stmt := 12594 First (Statements (Handled_Statement_Sequence (N))); 12595 Prepend (Decl, Statements (Handled_Statement_Sequence (N))); 12596 Mark_Rewrite_Insertion (Decl); 12597 else 12598 -- If the accept statement has no body, there will be no 12599 -- reference to the actuals, so no need to compute actual 12600 -- subtypes. 12601 12602 return; 12603 end if; 12604 12605 else 12606 Decl := Build_Actual_Subtype (T, Formal); 12607 Prepend (Decl, Declarations (N)); 12608 Mark_Rewrite_Insertion (Decl); 12609 end if; 12610 12611 -- The declaration uses the bounds of an existing object, and 12612 -- therefore needs no constraint checks. 12613 12614 Analyze (Decl, Suppress => All_Checks); 12615 12616 -- We need to freeze manually the generated type when it is 12617 -- inserted anywhere else than in a declarative part. 12618 12619 if Present (First_Stmt) then 12620 Insert_List_Before_And_Analyze (First_Stmt, 12621 Freeze_Entity (Defining_Identifier (Decl), N)); 12622 end if; 12623 12624 if Nkind (N) = N_Accept_Statement 12625 and then Full_Expander_Active 12626 then 12627 Set_Actual_Subtype (Renamed_Object (Formal), 12628 Defining_Identifier (Decl)); 12629 else 12630 Set_Actual_Subtype (Formal, Defining_Identifier (Decl)); 12631 end if; 12632 end if; 12633 12634 Next_Formal (Formal); 12635 end loop; 12636 end Set_Actual_Subtypes; 12637 12638 --------------------- 12639 -- Set_Formal_Mode -- 12640 --------------------- 12641 12642 procedure Set_Formal_Mode (Formal_Id : Entity_Id) is 12643 Spec : constant Node_Id := Parent (Formal_Id); 12644 12645 begin 12646 -- Note: we set Is_Known_Valid for IN parameters and IN OUT parameters 12647 -- since we ensure that corresponding actuals are always valid at the 12648 -- point of the call. 12649 12650 if Out_Present (Spec) then 12651 if Ekind (Scope (Formal_Id)) = E_Function 12652 or else Ekind (Scope (Formal_Id)) = E_Generic_Function 12653 then 12654 -- [IN] OUT parameters allowed for functions in Ada 2012 12655 12656 if Ada_Version >= Ada_2012 then 12657 if In_Present (Spec) then 12658 Set_Ekind (Formal_Id, E_In_Out_Parameter); 12659 else 12660 Set_Ekind (Formal_Id, E_Out_Parameter); 12661 end if; 12662 12663 -- But not in earlier versions of Ada 12664 12665 else 12666 Error_Msg_N ("functions can only have IN parameters", Spec); 12667 Set_Ekind (Formal_Id, E_In_Parameter); 12668 end if; 12669 12670 elsif In_Present (Spec) then 12671 Set_Ekind (Formal_Id, E_In_Out_Parameter); 12672 12673 else 12674 Set_Ekind (Formal_Id, E_Out_Parameter); 12675 Set_Never_Set_In_Source (Formal_Id, True); 12676 Set_Is_True_Constant (Formal_Id, False); 12677 Set_Current_Value (Formal_Id, Empty); 12678 end if; 12679 12680 else 12681 Set_Ekind (Formal_Id, E_In_Parameter); 12682 end if; 12683 12684 -- Set Is_Known_Non_Null for access parameters since the language 12685 -- guarantees that access parameters are always non-null. We also set 12686 -- Can_Never_Be_Null, since there is no way to change the value. 12687 12688 if Nkind (Parameter_Type (Spec)) = N_Access_Definition then 12689 12690 -- Ada 2005 (AI-231): In Ada 95, access parameters are always non- 12691 -- null; In Ada 2005, only if then null_exclusion is explicit. 12692 12693 if Ada_Version < Ada_2005 12694 or else Can_Never_Be_Null (Etype (Formal_Id)) 12695 then 12696 Set_Is_Known_Non_Null (Formal_Id); 12697 Set_Can_Never_Be_Null (Formal_Id); 12698 end if; 12699 12700 -- Ada 2005 (AI-231): Null-exclusion access subtype 12701 12702 elsif Is_Access_Type (Etype (Formal_Id)) 12703 and then Can_Never_Be_Null (Etype (Formal_Id)) 12704 then 12705 Set_Is_Known_Non_Null (Formal_Id); 12706 12707 -- We can also set Can_Never_Be_Null (thus preventing some junk 12708 -- access checks) for the case of an IN parameter, which cannot 12709 -- be changed, or for an IN OUT parameter, which can be changed but 12710 -- not to a null value. But for an OUT parameter, the initial value 12711 -- passed in can be null, so we can't set this flag in that case. 12712 12713 if Ekind (Formal_Id) /= E_Out_Parameter then 12714 Set_Can_Never_Be_Null (Formal_Id); 12715 end if; 12716 end if; 12717 12718 Set_Mechanism (Formal_Id, Default_Mechanism); 12719 Set_Formal_Validity (Formal_Id); 12720 end Set_Formal_Mode; 12721 12722 ------------------------- 12723 -- Set_Formal_Validity -- 12724 ------------------------- 12725 12726 procedure Set_Formal_Validity (Formal_Id : Entity_Id) is 12727 begin 12728 -- If no validity checking, then we cannot assume anything about the 12729 -- validity of parameters, since we do not know there is any checking 12730 -- of the validity on the call side. 12731 12732 if not Validity_Checks_On then 12733 return; 12734 12735 -- If validity checking for parameters is enabled, this means we are 12736 -- not supposed to make any assumptions about argument values. 12737 12738 elsif Validity_Check_Parameters then 12739 return; 12740 12741 -- If we are checking in parameters, we will assume that the caller is 12742 -- also checking parameters, so we can assume the parameter is valid. 12743 12744 elsif Ekind (Formal_Id) = E_In_Parameter 12745 and then Validity_Check_In_Params 12746 then 12747 Set_Is_Known_Valid (Formal_Id, True); 12748 12749 -- Similar treatment for IN OUT parameters 12750 12751 elsif Ekind (Formal_Id) = E_In_Out_Parameter 12752 and then Validity_Check_In_Out_Params 12753 then 12754 Set_Is_Known_Valid (Formal_Id, True); 12755 end if; 12756 end Set_Formal_Validity; 12757 12758 ------------------------ 12759 -- Subtype_Conformant -- 12760 ------------------------ 12761 12762 function Subtype_Conformant 12763 (New_Id : Entity_Id; 12764 Old_Id : Entity_Id; 12765 Skip_Controlling_Formals : Boolean := False) return Boolean 12766 is 12767 Result : Boolean; 12768 begin 12769 Check_Conformance (New_Id, Old_Id, Subtype_Conformant, False, Result, 12770 Skip_Controlling_Formals => Skip_Controlling_Formals); 12771 return Result; 12772 end Subtype_Conformant; 12773 12774 --------------------- 12775 -- Type_Conformant -- 12776 --------------------- 12777 12778 function Type_Conformant 12779 (New_Id : Entity_Id; 12780 Old_Id : Entity_Id; 12781 Skip_Controlling_Formals : Boolean := False) return Boolean 12782 is 12783 Result : Boolean; 12784 begin 12785 May_Hide_Profile := False; 12786 12787 Check_Conformance 12788 (New_Id, Old_Id, Type_Conformant, False, Result, 12789 Skip_Controlling_Formals => Skip_Controlling_Formals); 12790 return Result; 12791 end Type_Conformant; 12792 12793 ------------------------------- 12794 -- Valid_Operator_Definition -- 12795 ------------------------------- 12796 12797 procedure Valid_Operator_Definition (Designator : Entity_Id) is 12798 N : Integer := 0; 12799 F : Entity_Id; 12800 Id : constant Name_Id := Chars (Designator); 12801 N_OK : Boolean; 12802 12803 begin 12804 F := First_Formal (Designator); 12805 while Present (F) loop 12806 N := N + 1; 12807 12808 if Present (Default_Value (F)) then 12809 Error_Msg_N 12810 ("default values not allowed for operator parameters", 12811 Parent (F)); 12812 end if; 12813 12814 Next_Formal (F); 12815 end loop; 12816 12817 -- Verify that user-defined operators have proper number of arguments 12818 -- First case of operators which can only be unary 12819 12820 if Id = Name_Op_Not 12821 or else Id = Name_Op_Abs 12822 then 12823 N_OK := (N = 1); 12824 12825 -- Case of operators which can be unary or binary 12826 12827 elsif Id = Name_Op_Add 12828 or Id = Name_Op_Subtract 12829 then 12830 N_OK := (N in 1 .. 2); 12831 12832 -- All other operators can only be binary 12833 12834 else 12835 N_OK := (N = 2); 12836 end if; 12837 12838 if not N_OK then 12839 Error_Msg_N 12840 ("incorrect number of arguments for operator", Designator); 12841 end if; 12842 12843 if Id = Name_Op_Ne 12844 and then Base_Type (Etype (Designator)) = Standard_Boolean 12845 and then not Is_Intrinsic_Subprogram (Designator) 12846 then 12847 Error_Msg_N 12848 ("explicit definition of inequality not allowed", Designator); 12849 end if; 12850 end Valid_Operator_Definition; 12851 12852end Sem_Ch6; 12853