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