1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- S E M _ E L I M -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1997-2019, Free Software Foundation, Inc. -- 10-- -- 11-- GNAT is free software; you can redistribute it and/or modify it under -- 12-- terms of the GNU General Public License as published by the Free Soft- -- 13-- ware Foundation; either version 3, or (at your option) any later ver- -- 14-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 15-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 16-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- 17-- for more details. You should have received a copy of the GNU General -- 18-- Public License distributed with GNAT; see file COPYING3. If not, go to -- 19-- http://www.gnu.org/licenses for a complete copy of the license. -- 20-- -- 21-- GNAT was originally developed by the GNAT team at New York University. -- 22-- Extensive contributions were provided by Ada Core Technologies Inc. -- 23-- -- 24------------------------------------------------------------------------------ 25 26with Atree; use Atree; 27with Einfo; use Einfo; 28with Errout; use Errout; 29with Lib; use Lib; 30with Namet; use Namet; 31with Nlists; use Nlists; 32with Opt; use Opt; 33with Sem; use Sem; 34with Sem_Aux; use Sem_Aux; 35with Sem_Prag; use Sem_Prag; 36with Sem_Util; use Sem_Util; 37with Sinput; use Sinput; 38with Sinfo; use Sinfo; 39with Snames; use Snames; 40with Stand; use Stand; 41with Stringt; use Stringt; 42with Table; 43 44with GNAT.HTable; use GNAT.HTable; 45 46package body Sem_Elim is 47 48 No_Elimination : Boolean; 49 -- Set True if no Eliminate pragmas active 50 51 --------------------- 52 -- Data Structures -- 53 --------------------- 54 55 -- A single pragma Eliminate is represented by the following record 56 57 type Elim_Data; 58 type Access_Elim_Data is access Elim_Data; 59 60 type Names is array (Nat range <>) of Name_Id; 61 -- Type used to represent set of names. Used for names in Unit_Name 62 -- and also the set of names in Argument_Types. 63 64 type Access_Names is access Names; 65 66 type Elim_Data is record 67 68 Unit_Name : Access_Names; 69 -- Unit name, broken down into a set of names (e.g. A.B.C is 70 -- represented as Name_Id values for A, B, C in sequence). 71 72 Entity_Name : Name_Id; 73 -- Entity name if Entity parameter if present. If no Entity parameter 74 -- was supplied, then Entity_Node is set to Empty, and the Entity_Name 75 -- field contains the last identifier name in the Unit_Name. 76 77 Entity_Scope : Access_Names; 78 -- Static scope of the entity within the compilation unit represented by 79 -- Unit_Name. 80 81 Entity_Node : Node_Id; 82 -- Save node of entity argument, for posting error messages. Set 83 -- to Empty if there is no entity argument. 84 85 Parameter_Types : Access_Names; 86 -- Set to set of names given for parameter types. If no parameter 87 -- types argument is present, this argument is set to null. 88 89 Result_Type : Name_Id; 90 -- Result type name if Result_Types parameter present, No_Name if not 91 92 Source_Location : Name_Id; 93 -- String describing the source location of subprogram defining name if 94 -- Source_Location parameter present, No_Name if not 95 96 Hash_Link : Access_Elim_Data; 97 -- Link for hash table use 98 99 Homonym : Access_Elim_Data; 100 -- Pointer to next entry with same key 101 102 Prag : Node_Id; 103 -- Node_Id for Eliminate pragma 104 105 end record; 106 107 ---------------- 108 -- Hash_Table -- 109 ---------------- 110 111 -- Setup hash table using the Entity_Name field as the hash key 112 113 subtype Element is Elim_Data; 114 subtype Elmt_Ptr is Access_Elim_Data; 115 116 subtype Key is Name_Id; 117 118 type Header_Num is range 0 .. 1023; 119 120 Null_Ptr : constant Elmt_Ptr := null; 121 122 ---------------------- 123 -- Hash_Subprograms -- 124 ---------------------- 125 126 package Hash_Subprograms is 127 128 function Equal (F1, F2 : Key) return Boolean; 129 pragma Inline (Equal); 130 131 function Get_Key (E : Elmt_Ptr) return Key; 132 pragma Inline (Get_Key); 133 134 function Hash (F : Key) return Header_Num; 135 pragma Inline (Hash); 136 137 function Next (E : Elmt_Ptr) return Elmt_Ptr; 138 pragma Inline (Next); 139 140 procedure Set_Next (E : Elmt_Ptr; Next : Elmt_Ptr); 141 pragma Inline (Set_Next); 142 143 end Hash_Subprograms; 144 145 package body Hash_Subprograms is 146 147 ----------- 148 -- Equal -- 149 ----------- 150 151 function Equal (F1, F2 : Key) return Boolean is 152 begin 153 return F1 = F2; 154 end Equal; 155 156 ------------- 157 -- Get_Key -- 158 ------------- 159 160 function Get_Key (E : Elmt_Ptr) return Key is 161 begin 162 return E.Entity_Name; 163 end Get_Key; 164 165 ---------- 166 -- Hash -- 167 ---------- 168 169 function Hash (F : Key) return Header_Num is 170 begin 171 return Header_Num (Int (F) mod 1024); 172 end Hash; 173 174 ---------- 175 -- Next -- 176 ---------- 177 178 function Next (E : Elmt_Ptr) return Elmt_Ptr is 179 begin 180 return E.Hash_Link; 181 end Next; 182 183 -------------- 184 -- Set_Next -- 185 -------------- 186 187 procedure Set_Next (E : Elmt_Ptr; Next : Elmt_Ptr) is 188 begin 189 E.Hash_Link := Next; 190 end Set_Next; 191 end Hash_Subprograms; 192 193 ------------ 194 -- Tables -- 195 ------------ 196 197 -- The following table records the data for each pragma, using the 198 -- entity name as the hash key for retrieval. Entries in this table 199 -- are set by Process_Eliminate_Pragma and read by Check_Eliminated. 200 201 package Elim_Hash_Table is new Static_HTable ( 202 Header_Num => Header_Num, 203 Element => Element, 204 Elmt_Ptr => Elmt_Ptr, 205 Null_Ptr => Null_Ptr, 206 Set_Next => Hash_Subprograms.Set_Next, 207 Next => Hash_Subprograms.Next, 208 Key => Key, 209 Get_Key => Hash_Subprograms.Get_Key, 210 Hash => Hash_Subprograms.Hash, 211 Equal => Hash_Subprograms.Equal); 212 213 -- The following table records entities for subprograms that are 214 -- eliminated, and corresponding eliminate pragmas that caused the 215 -- elimination. Entries in this table are set by Check_Eliminated 216 -- and read by Eliminate_Error_Msg. 217 218 type Elim_Entity_Entry is record 219 Prag : Node_Id; 220 Subp : Entity_Id; 221 end record; 222 223 package Elim_Entities is new Table.Table ( 224 Table_Component_Type => Elim_Entity_Entry, 225 Table_Index_Type => Name_Id'Base, 226 Table_Low_Bound => First_Name_Id, 227 Table_Initial => 50, 228 Table_Increment => 200, 229 Table_Name => "Elim_Entries"); 230 231 ---------------------- 232 -- Check_Eliminated -- 233 ---------------------- 234 235 procedure Check_Eliminated (E : Entity_Id) is 236 Elmt : Access_Elim_Data; 237 Scop : Entity_Id; 238 Form : Entity_Id; 239 Up : Nat; 240 241 begin 242 if No_Elimination then 243 return; 244 245 -- Elimination of objects and types is not implemented yet 246 247 elsif Ekind (E) not in Subprogram_Kind then 248 return; 249 end if; 250 251 -- Loop through homonyms for this key 252 253 Elmt := Elim_Hash_Table.Get (Chars (E)); 254 while Elmt /= null loop 255 Check_Homonyms : declare 256 procedure Set_Eliminated; 257 -- Set current subprogram entity as eliminated 258 259 -------------------- 260 -- Set_Eliminated -- 261 -------------------- 262 263 procedure Set_Eliminated is 264 Overridden : Entity_Id; 265 266 begin 267 if Is_Dispatching_Operation (E) then 268 269 -- If an overriding dispatching primitive is eliminated then 270 -- its parent must have been eliminated. If the parent is an 271 -- inherited operation, check the operation that it renames, 272 -- because flag Eliminated is only set on source operations. 273 274 Overridden := Overridden_Operation (E); 275 276 if Present (Overridden) 277 and then not Comes_From_Source (Overridden) 278 and then Present (Alias (Overridden)) 279 then 280 Overridden := Alias (Overridden); 281 end if; 282 283 if Present (Overridden) 284 and then not Is_Eliminated (Overridden) 285 and then not Is_Abstract_Subprogram (Overridden) 286 then 287 Error_Msg_Name_1 := Chars (E); 288 Error_Msg_N ("cannot eliminate subprogram %", E); 289 return; 290 end if; 291 end if; 292 293 Set_Is_Eliminated (E); 294 Elim_Entities.Append ((Prag => Elmt.Prag, Subp => E)); 295 end Set_Eliminated; 296 297 -- Start of processing for Check_Homonyms 298 299 begin 300 -- First we check that the name of the entity matches 301 302 if Elmt.Entity_Name /= Chars (E) then 303 goto Continue; 304 end if; 305 306 -- Find enclosing unit, and verify that its name and those of its 307 -- parents match. 308 309 Scop := Cunit_Entity (Current_Sem_Unit); 310 311 -- Now see if compilation unit matches 312 313 Up := Elmt.Unit_Name'Last; 314 315 -- If we are within a subunit, the name in the pragma has been 316 -- parsed as a child unit, but the current compilation unit is in 317 -- fact the parent in which the subunit is embedded. We must skip 318 -- the first name which is that of the subunit to match the pragma 319 -- specification. Body may be that of a package or subprogram. 320 321 declare 322 Par : Node_Id; 323 324 begin 325 Par := Parent (E); 326 while Present (Par) loop 327 if Nkind (Par) = N_Subunit then 328 if Chars (Defining_Entity (Proper_Body (Par))) = 329 Elmt.Unit_Name (Up) 330 then 331 Up := Up - 1; 332 exit; 333 334 else 335 goto Continue; 336 end if; 337 end if; 338 339 Par := Parent (Par); 340 end loop; 341 end; 342 343 for J in reverse Elmt.Unit_Name'First .. Up loop 344 if Elmt.Unit_Name (J) /= Chars (Scop) then 345 goto Continue; 346 end if; 347 348 Scop := Scope (Scop); 349 350 if Scop /= Standard_Standard and then J = 1 then 351 goto Continue; 352 end if; 353 end loop; 354 355 if Scop /= Standard_Standard then 356 goto Continue; 357 end if; 358 359 if Present (Elmt.Entity_Node) 360 and then Elmt.Entity_Scope /= null 361 then 362 -- Check that names of enclosing scopes match. Skip blocks and 363 -- wrapper package of subprogram instances, which do not appear 364 -- in the pragma. 365 366 Scop := Scope (E); 367 368 for J in reverse Elmt.Entity_Scope'Range loop 369 while Ekind (Scop) = E_Block 370 or else 371 (Ekind (Scop) = E_Package 372 and then Is_Wrapper_Package (Scop)) 373 loop 374 Scop := Scope (Scop); 375 end loop; 376 377 if Elmt.Entity_Scope (J) /= Chars (Scop) then 378 if Ekind (Scop) /= E_Protected_Type 379 or else Comes_From_Source (Scop) 380 then 381 goto Continue; 382 383 -- For simple protected declarations, retrieve the source 384 -- name of the object, which appeared in the Eliminate 385 -- pragma. 386 387 else 388 declare 389 Decl : constant Node_Id := 390 Original_Node (Parent (Scop)); 391 392 begin 393 if Elmt.Entity_Scope (J) /= 394 Chars (Defining_Identifier (Decl)) 395 then 396 if J > 0 then 397 null; 398 end if; 399 goto Continue; 400 end if; 401 end; 402 end if; 403 404 end if; 405 406 Scop := Scope (Scop); 407 end loop; 408 end if; 409 410 -- If given entity is a library level subprogram and pragma had a 411 -- single parameter, a match. 412 413 if Is_Compilation_Unit (E) 414 and then Is_Subprogram (E) 415 and then No (Elmt.Entity_Node) 416 then 417 Set_Eliminated; 418 return; 419 420 -- Check for case of type or object with two parameter case 421 422 elsif (Is_Type (E) or else Is_Object (E)) 423 and then Elmt.Result_Type = No_Name 424 and then Elmt.Parameter_Types = null 425 then 426 Set_Eliminated; 427 return; 428 429 -- Check for case of subprogram 430 431 elsif Ekind_In (E, E_Function, E_Procedure) then 432 433 -- If Source_Location present, then see if it matches 434 435 if Elmt.Source_Location /= No_Name then 436 Get_Name_String (Elmt.Source_Location); 437 438 declare 439 Sloc_Trace : constant String := 440 Name_Buffer (1 .. Name_Len); 441 442 Idx : Natural := Sloc_Trace'First; 443 -- Index in Sloc_Trace, if equals to 0, then we have 444 -- completely traversed Sloc_Trace 445 446 Last : constant Natural := Sloc_Trace'Last; 447 448 P : Source_Ptr; 449 Sindex : Source_File_Index; 450 451 function File_Name_Match return Boolean; 452 -- This function is supposed to be called when Idx points 453 -- to the beginning of the new file name, and Name_Buffer 454 -- is set to contain the name of the proper source file 455 -- from the chain corresponding to the Sloc of E. First 456 -- it checks that these two files have the same name. If 457 -- this check is successful, moves Idx to point to the 458 -- beginning of the column number. 459 460 function Line_Num_Match return Boolean; 461 -- This function is supposed to be called when Idx points 462 -- to the beginning of the column number, and P is 463 -- set to point to the proper Sloc the chain 464 -- corresponding to the Sloc of E. First it checks that 465 -- the line number Idx points on and the line number 466 -- corresponding to P are the same. If this check is 467 -- successful, moves Idx to point to the beginning of 468 -- the next file name in Sloc_Trace. If there is no file 469 -- name any more, Idx is set to 0. 470 471 function Different_Trace_Lengths return Boolean; 472 -- From Idx and P, defines if there are in both traces 473 -- more element(s) in the instantiation chains. Returns 474 -- False if one trace contains more element(s), but 475 -- another does not. If both traces contains more 476 -- elements (that is, the function returns False), moves 477 -- P ahead in the chain corresponding to E, recomputes 478 -- Sindex and sets the name of the corresponding file in 479 -- Name_Buffer 480 481 function Skip_Spaces return Natural; 482 -- If Sloc_Trace (Idx) is not space character, returns 483 -- Idx. Otherwise returns the index of the nearest 484 -- non-space character in Sloc_Trace to the right of Idx. 485 -- Returns 0 if there is no such character. 486 487 ----------------------------- 488 -- Different_Trace_Lengths -- 489 ----------------------------- 490 491 function Different_Trace_Lengths return Boolean is 492 begin 493 P := Instantiation (Sindex); 494 495 if (P = No_Location and then Idx /= 0) 496 or else 497 (P /= No_Location and then Idx = 0) 498 then 499 return True; 500 501 else 502 if P /= No_Location then 503 Sindex := Get_Source_File_Index (P); 504 Get_Name_String (File_Name (Sindex)); 505 end if; 506 507 return False; 508 end if; 509 end Different_Trace_Lengths; 510 511 --------------------- 512 -- File_Name_Match -- 513 --------------------- 514 515 function File_Name_Match return Boolean is 516 Tmp_Idx : Natural; 517 End_Idx : Natural; 518 519 begin 520 if Idx = 0 then 521 return False; 522 end if; 523 524 -- Find first colon. If no colon, then return False. 525 -- If there is a colon, Tmp_Idx is set to point just 526 -- before the colon. 527 528 Tmp_Idx := Idx - 1; 529 loop 530 if Tmp_Idx >= Last then 531 return False; 532 elsif Sloc_Trace (Tmp_Idx + 1) = ':' then 533 exit; 534 else 535 Tmp_Idx := Tmp_Idx + 1; 536 end if; 537 end loop; 538 539 -- Find last non-space before this colon. If there is 540 -- no space character before this colon, then return 541 -- False. Otherwise, End_Idx is set to point to this 542 -- non-space character. 543 544 End_Idx := Tmp_Idx; 545 loop 546 if End_Idx < Idx then 547 return False; 548 549 elsif Sloc_Trace (End_Idx) /= ' ' then 550 exit; 551 552 else 553 End_Idx := End_Idx - 1; 554 end if; 555 end loop; 556 557 -- Now see if file name matches what is in Name_Buffer 558 -- and if so, step Idx past it and return True. If the 559 -- name does not match, return False. 560 561 if Sloc_Trace (Idx .. End_Idx) = 562 Name_Buffer (1 .. Name_Len) 563 then 564 Idx := Tmp_Idx + 2; 565 Idx := Skip_Spaces; 566 return True; 567 else 568 return False; 569 end if; 570 end File_Name_Match; 571 572 -------------------- 573 -- Line_Num_Match -- 574 -------------------- 575 576 function Line_Num_Match return Boolean is 577 N : Nat := 0; 578 579 begin 580 if Idx = 0 then 581 return False; 582 end if; 583 584 while Idx <= Last 585 and then Sloc_Trace (Idx) in '0' .. '9' 586 loop 587 N := N * 10 + 588 (Character'Pos (Sloc_Trace (Idx)) - 589 Character'Pos ('0')); 590 Idx := Idx + 1; 591 end loop; 592 593 if Get_Physical_Line_Number (P) = 594 Physical_Line_Number (N) 595 then 596 while Idx <= Last and then 597 Sloc_Trace (Idx) /= '[' 598 loop 599 Idx := Idx + 1; 600 end loop; 601 602 if Idx <= Last then 603 pragma Assert (Sloc_Trace (Idx) = '['); 604 Idx := Idx + 1; 605 Idx := Skip_Spaces; 606 else 607 Idx := 0; 608 end if; 609 610 return True; 611 612 else 613 return False; 614 end if; 615 end Line_Num_Match; 616 617 ----------------- 618 -- Skip_Spaces -- 619 ----------------- 620 621 function Skip_Spaces return Natural is 622 Res : Natural; 623 624 begin 625 Res := Idx; 626 while Sloc_Trace (Res) = ' ' loop 627 Res := Res + 1; 628 629 if Res > Last then 630 Res := 0; 631 exit; 632 end if; 633 end loop; 634 635 return Res; 636 end Skip_Spaces; 637 638 begin 639 P := Sloc (E); 640 Sindex := Get_Source_File_Index (P); 641 Get_Name_String (File_Name (Sindex)); 642 643 Idx := Skip_Spaces; 644 while Idx > 0 loop 645 if not File_Name_Match then 646 goto Continue; 647 elsif not Line_Num_Match then 648 goto Continue; 649 end if; 650 651 if Different_Trace_Lengths then 652 goto Continue; 653 end if; 654 end loop; 655 end; 656 end if; 657 658 -- If we have a Result_Type, then we must have a function with 659 -- the proper result type. 660 661 if Elmt.Result_Type /= No_Name then 662 if Ekind (E) /= E_Function 663 or else Chars (Etype (E)) /= Elmt.Result_Type 664 then 665 goto Continue; 666 end if; 667 end if; 668 669 -- If we have Parameter_Types, they must match 670 671 if Elmt.Parameter_Types /= null then 672 Form := First_Formal (E); 673 674 if No (Form) 675 and then Elmt.Parameter_Types'Length = 1 676 and then Elmt.Parameter_Types (1) = No_Name 677 then 678 -- Parameterless procedure matches 679 680 null; 681 682 elsif Elmt.Parameter_Types = null then 683 goto Continue; 684 685 else 686 for J in Elmt.Parameter_Types'Range loop 687 if No (Form) 688 or else 689 Chars (Etype (Form)) /= Elmt.Parameter_Types (J) 690 then 691 goto Continue; 692 else 693 Next_Formal (Form); 694 end if; 695 end loop; 696 697 if Present (Form) then 698 goto Continue; 699 end if; 700 end if; 701 end if; 702 703 -- If we fall through, this is match 704 705 Set_Eliminated; 706 return; 707 end if; 708 end Check_Homonyms; 709 710 <<Continue>> 711 Elmt := Elmt.Homonym; 712 end loop; 713 714 return; 715 end Check_Eliminated; 716 717 ------------------------------------- 718 -- Check_For_Eliminated_Subprogram -- 719 ------------------------------------- 720 721 procedure Check_For_Eliminated_Subprogram (N : Node_Id; S : Entity_Id) is 722 Ultimate_Subp : constant Entity_Id := Ultimate_Alias (S); 723 Enclosing_Subp : Entity_Id; 724 725 begin 726 -- No check needed within a default expression for a formal, since this 727 -- is not really a use, and the expression (a call or attribute) may 728 -- never be used if the enclosing subprogram is itself eliminated. 729 730 if In_Spec_Expression then 731 return; 732 end if; 733 734 if Is_Eliminated (Ultimate_Subp) 735 and then not Inside_A_Generic 736 and then not Is_Generic_Unit (Cunit_Entity (Current_Sem_Unit)) 737 then 738 Enclosing_Subp := Current_Subprogram; 739 while Present (Enclosing_Subp) loop 740 if Is_Eliminated (Enclosing_Subp) then 741 return; 742 end if; 743 744 Enclosing_Subp := Enclosing_Subprogram (Enclosing_Subp); 745 end loop; 746 747 -- Emit error, unless we are within an instance body and the expander 748 -- is disabled, indicating an instance within an enclosing generic. 749 -- In an instance, the ultimate alias is an internal entity, so place 750 -- the message on the original subprogram. 751 752 if In_Instance_Body and then not Expander_Active then 753 null; 754 755 elsif Comes_From_Source (Ultimate_Subp) then 756 Eliminate_Error_Msg (N, Ultimate_Subp); 757 758 else 759 Eliminate_Error_Msg (N, S); 760 end if; 761 end if; 762 end Check_For_Eliminated_Subprogram; 763 764 ------------------------- 765 -- Eliminate_Error_Msg -- 766 ------------------------- 767 768 procedure Eliminate_Error_Msg (N : Node_Id; E : Entity_Id) is 769 begin 770 for J in Elim_Entities.First .. Elim_Entities.Last loop 771 if E = Elim_Entities.Table (J).Subp then 772 Error_Msg_Sloc := Sloc (Elim_Entities.Table (J).Prag); 773 Error_Msg_NE ("cannot reference subprogram & eliminated #", N, E); 774 return; 775 end if; 776 end loop; 777 778 -- If this is an internal operation generated for a protected operation, 779 -- its name does not match the source name, so just report the error. 780 781 if not Comes_From_Source (E) 782 and then Present (First_Entity (E)) 783 and then Is_Concurrent_Record_Type (Etype (First_Entity (E))) 784 then 785 Error_Msg_NE 786 ("cannot reference eliminated protected subprogram", N, E); 787 788 -- Otherwise should not fall through, entry should be in table 789 790 else 791 Error_Msg_NE 792 ("subprogram& is called but its alias is eliminated", N, E); 793 -- raise Program_Error; 794 end if; 795 end Eliminate_Error_Msg; 796 797 ---------------- 798 -- Initialize -- 799 ---------------- 800 801 procedure Initialize is 802 begin 803 Elim_Hash_Table.Reset; 804 Elim_Entities.Init; 805 No_Elimination := True; 806 end Initialize; 807 808 ------------------------------ 809 -- Process_Eliminate_Pragma -- 810 ------------------------------ 811 812 procedure Process_Eliminate_Pragma 813 (Pragma_Node : Node_Id; 814 Arg_Unit_Name : Node_Id; 815 Arg_Entity : Node_Id; 816 Arg_Parameter_Types : Node_Id; 817 Arg_Result_Type : Node_Id; 818 Arg_Source_Location : Node_Id) 819 is 820 Data : constant Access_Elim_Data := new Elim_Data; 821 -- Build result data here 822 823 Elmt : Access_Elim_Data; 824 825 Num_Names : Nat := 0; 826 -- Number of names in unit name 827 828 Lit : Node_Id; 829 Arg_Ent : Entity_Id; 830 Arg_Uname : Node_Id; 831 832 function OK_Selected_Component (N : Node_Id) return Boolean; 833 -- Test if N is a selected component with all identifiers, or a selected 834 -- component whose selector is an operator symbol. As a side effect 835 -- if result is True, sets Num_Names to the number of names present 836 -- (identifiers, and operator if any). 837 838 --------------------------- 839 -- OK_Selected_Component -- 840 --------------------------- 841 842 function OK_Selected_Component (N : Node_Id) return Boolean is 843 begin 844 if Nkind (N) = N_Identifier 845 or else Nkind (N) = N_Operator_Symbol 846 then 847 Num_Names := Num_Names + 1; 848 return True; 849 850 elsif Nkind (N) = N_Selected_Component then 851 return OK_Selected_Component (Prefix (N)) 852 and then OK_Selected_Component (Selector_Name (N)); 853 854 else 855 return False; 856 end if; 857 end OK_Selected_Component; 858 859 -- Start of processing for Process_Eliminate_Pragma 860 861 begin 862 Data.Prag := Pragma_Node; 863 Error_Msg_Name_1 := Name_Eliminate; 864 865 -- Process Unit_Name argument 866 867 if Nkind (Arg_Unit_Name) = N_Identifier then 868 Data.Unit_Name := new Names'(1 => Chars (Arg_Unit_Name)); 869 Num_Names := 1; 870 871 elsif OK_Selected_Component (Arg_Unit_Name) then 872 Data.Unit_Name := new Names (1 .. Num_Names); 873 874 Arg_Uname := Arg_Unit_Name; 875 for J in reverse 2 .. Num_Names loop 876 Data.Unit_Name (J) := Chars (Selector_Name (Arg_Uname)); 877 Arg_Uname := Prefix (Arg_Uname); 878 end loop; 879 880 Data.Unit_Name (1) := Chars (Arg_Uname); 881 882 else 883 Error_Msg_N 884 ("wrong form for Unit_Name parameter of pragma%", Arg_Unit_Name); 885 return; 886 end if; 887 888 -- Process Entity argument 889 890 if Present (Arg_Entity) then 891 Num_Names := 0; 892 893 if Nkind (Arg_Entity) = N_Identifier 894 or else Nkind (Arg_Entity) = N_Operator_Symbol 895 then 896 Data.Entity_Name := Chars (Arg_Entity); 897 Data.Entity_Node := Arg_Entity; 898 Data.Entity_Scope := null; 899 900 elsif OK_Selected_Component (Arg_Entity) then 901 Data.Entity_Scope := new Names (1 .. Num_Names - 1); 902 Data.Entity_Name := Chars (Selector_Name (Arg_Entity)); 903 Data.Entity_Node := Arg_Entity; 904 905 Arg_Ent := Prefix (Arg_Entity); 906 for J in reverse 2 .. Num_Names - 1 loop 907 Data.Entity_Scope (J) := Chars (Selector_Name (Arg_Ent)); 908 Arg_Ent := Prefix (Arg_Ent); 909 end loop; 910 911 Data.Entity_Scope (1) := Chars (Arg_Ent); 912 913 elsif Is_Config_Static_String (Arg_Entity) then 914 Data.Entity_Name := Name_Find; 915 Data.Entity_Node := Arg_Entity; 916 917 else 918 return; 919 end if; 920 else 921 Data.Entity_Node := Empty; 922 Data.Entity_Name := Data.Unit_Name (Num_Names); 923 end if; 924 925 -- Process Parameter_Types argument 926 927 if Present (Arg_Parameter_Types) then 928 929 -- Here for aggregate case 930 931 if Nkind (Arg_Parameter_Types) = N_Aggregate then 932 Data.Parameter_Types := 933 new Names 934 (1 .. List_Length (Expressions (Arg_Parameter_Types))); 935 936 Lit := First (Expressions (Arg_Parameter_Types)); 937 for J in Data.Parameter_Types'Range loop 938 if Is_Config_Static_String (Lit) then 939 Data.Parameter_Types (J) := Name_Find; 940 Next (Lit); 941 else 942 return; 943 end if; 944 end loop; 945 946 -- Otherwise we must have case of one name, which looks like a 947 -- parenthesized literal rather than an aggregate. 948 949 elsif Paren_Count (Arg_Parameter_Types) /= 1 then 950 Error_Msg_N 951 ("wrong form for argument of pragma Eliminate", 952 Arg_Parameter_Types); 953 return; 954 955 elsif Is_Config_Static_String (Arg_Parameter_Types) then 956 String_To_Name_Buffer (Strval (Arg_Parameter_Types)); 957 958 if Name_Len = 0 then 959 960 -- Parameterless procedure 961 962 Data.Parameter_Types := new Names'(1 => No_Name); 963 964 else 965 Data.Parameter_Types := new Names'(1 => Name_Find); 966 end if; 967 968 else 969 return; 970 end if; 971 end if; 972 973 -- Process Result_Types argument 974 975 if Present (Arg_Result_Type) then 976 if Is_Config_Static_String (Arg_Result_Type) then 977 Data.Result_Type := Name_Find; 978 else 979 return; 980 end if; 981 982 -- Here if no Result_Types argument 983 984 else 985 Data.Result_Type := No_Name; 986 end if; 987 988 -- Process Source_Location argument 989 990 if Present (Arg_Source_Location) then 991 if Is_Config_Static_String (Arg_Source_Location) then 992 Data.Source_Location := Name_Find; 993 else 994 return; 995 end if; 996 else 997 Data.Source_Location := No_Name; 998 end if; 999 1000 Elmt := Elim_Hash_Table.Get (Hash_Subprograms.Get_Key (Data)); 1001 1002 -- If we already have an entry with this same key, then link 1003 -- it into the chain of entries for this key. 1004 1005 if Elmt /= null then 1006 Data.Homonym := Elmt.Homonym; 1007 Elmt.Homonym := Data; 1008 1009 -- Otherwise create a new entry 1010 1011 else 1012 Elim_Hash_Table.Set (Data); 1013 end if; 1014 1015 No_Elimination := False; 1016 end Process_Eliminate_Pragma; 1017 1018end Sem_Elim; 1019