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