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-2012, 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 pragmas, 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 : Int := 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 and then 603 Sloc_Trace (Idx) = '[' 604 then 605 Idx := Idx + 1; 606 Idx := Skip_Spaces; 607 else 608 Idx := 0; 609 end if; 610 611 return True; 612 613 else 614 return False; 615 end if; 616 end Line_Num_Match; 617 618 ----------------- 619 -- Skip_Spaces -- 620 ----------------- 621 622 function Skip_Spaces return Natural is 623 Res : Natural; 624 625 begin 626 Res := Idx; 627 while Sloc_Trace (Res) = ' ' loop 628 Res := Res + 1; 629 630 if Res > Last then 631 Res := 0; 632 exit; 633 end if; 634 end loop; 635 636 return Res; 637 end Skip_Spaces; 638 639 begin 640 P := Sloc (E); 641 Sindex := Get_Source_File_Index (P); 642 Get_Name_String (File_Name (Sindex)); 643 644 Idx := Skip_Spaces; 645 while Idx > 0 loop 646 if not File_Name_Match then 647 goto Continue; 648 elsif not Line_Num_Match then 649 goto Continue; 650 end if; 651 652 if Different_Trace_Lengths then 653 goto Continue; 654 end if; 655 end loop; 656 end; 657 end if; 658 659 -- If we have a Result_Type, then we must have a function with 660 -- the proper result type. 661 662 if Elmt.Result_Type /= No_Name then 663 if Ekind (E) /= E_Function 664 or else Chars (Etype (E)) /= Elmt.Result_Type 665 then 666 goto Continue; 667 end if; 668 end if; 669 670 -- If we have Parameter_Types, they must match 671 672 if Elmt.Parameter_Types /= null then 673 Form := First_Formal (E); 674 675 if No (Form) 676 and then Elmt.Parameter_Types'Length = 1 677 and then Elmt.Parameter_Types (1) = No_Name 678 then 679 -- Parameterless procedure matches 680 681 null; 682 683 elsif Elmt.Parameter_Types = null then 684 goto Continue; 685 686 else 687 for J in Elmt.Parameter_Types'Range loop 688 if No (Form) 689 or else 690 Chars (Etype (Form)) /= Elmt.Parameter_Types (J) 691 then 692 goto Continue; 693 else 694 Next_Formal (Form); 695 end if; 696 end loop; 697 698 if Present (Form) then 699 goto Continue; 700 end if; 701 end if; 702 end if; 703 704 -- If we fall through, this is match 705 706 Set_Eliminated; 707 return; 708 end if; 709 end Check_Homonyms; 710 711 <<Continue>> 712 Elmt := Elmt.Homonym; 713 end loop; 714 715 return; 716 end Check_Eliminated; 717 718 ------------------------------------- 719 -- Check_For_Eliminated_Subprogram -- 720 ------------------------------------- 721 722 procedure Check_For_Eliminated_Subprogram (N : Node_Id; S : Entity_Id) is 723 Ultimate_Subp : constant Entity_Id := Ultimate_Alias (S); 724 Enclosing_Subp : Entity_Id; 725 726 begin 727 -- No check needed within a default expression for a formal, since this 728 -- is not really a use, and the expression (a call or attribute) may 729 -- never be used if the enclosing subprogram is itself eliminated. 730 731 if In_Spec_Expression then 732 return; 733 end if; 734 735 if Is_Eliminated (Ultimate_Subp) 736 and then not Inside_A_Generic 737 and then not Is_Generic_Unit (Cunit_Entity (Current_Sem_Unit)) 738 then 739 Enclosing_Subp := Current_Subprogram; 740 while Present (Enclosing_Subp) loop 741 if Is_Eliminated (Enclosing_Subp) then 742 return; 743 end if; 744 745 Enclosing_Subp := Enclosing_Subprogram (Enclosing_Subp); 746 end loop; 747 748 -- Emit error, unless we are within an instance body and the expander 749 -- is disabled, indicating an instance within an enclosing generic. 750 -- In an instance, the ultimate alias is an internal entity, so place 751 -- the message on the original subprogram. 752 753 if In_Instance_Body and then not Expander_Active then 754 null; 755 756 elsif Comes_From_Source (Ultimate_Subp) then 757 Eliminate_Error_Msg (N, Ultimate_Subp); 758 759 else 760 Eliminate_Error_Msg (N, S); 761 end if; 762 end if; 763 end Check_For_Eliminated_Subprogram; 764 765 ------------------------- 766 -- Eliminate_Error_Msg -- 767 ------------------------- 768 769 procedure Eliminate_Error_Msg (N : Node_Id; E : Entity_Id) is 770 begin 771 for J in Elim_Entities.First .. Elim_Entities.Last loop 772 if E = Elim_Entities.Table (J).Subp then 773 Error_Msg_Sloc := Sloc (Elim_Entities.Table (J).Prag); 774 Error_Msg_NE ("cannot reference subprogram & eliminated #", N, E); 775 return; 776 end if; 777 end loop; 778 779 -- If this is an internal operation generated for a protected operation, 780 -- its name does not match the source name, so just report the error. 781 782 if not Comes_From_Source (E) 783 and then Present (First_Entity (E)) 784 and then Is_Concurrent_Record_Type (Etype (First_Entity (E))) 785 then 786 Error_Msg_NE 787 ("cannot reference eliminated protected subprogram", N, E); 788 789 -- Otherwise should not fall through, entry should be in table 790 791 else 792 Error_Msg_NE 793 ("subprogram& is called but its alias is eliminated", N, E); 794 -- raise Program_Error; 795 end if; 796 end Eliminate_Error_Msg; 797 798 ---------------- 799 -- Initialize -- 800 ---------------- 801 802 procedure Initialize is 803 begin 804 Elim_Hash_Table.Reset; 805 Elim_Entities.Init; 806 No_Elimination := True; 807 end Initialize; 808 809 ------------------------------ 810 -- Process_Eliminate_Pragma -- 811 ------------------------------ 812 813 procedure Process_Eliminate_Pragma 814 (Pragma_Node : Node_Id; 815 Arg_Unit_Name : Node_Id; 816 Arg_Entity : Node_Id; 817 Arg_Parameter_Types : Node_Id; 818 Arg_Result_Type : Node_Id; 819 Arg_Source_Location : Node_Id) 820 is 821 Data : constant Access_Elim_Data := new Elim_Data; 822 -- Build result data here 823 824 Elmt : Access_Elim_Data; 825 826 Num_Names : Nat := 0; 827 -- Number of names in unit name 828 829 Lit : Node_Id; 830 Arg_Ent : Entity_Id; 831 Arg_Uname : Node_Id; 832 833 function OK_Selected_Component (N : Node_Id) return Boolean; 834 -- Test if N is a selected component with all identifiers, or a selected 835 -- component whose selector is an operator symbol. As a side effect 836 -- if result is True, sets Num_Names to the number of names present 837 -- (identifiers, and operator if any). 838 839 --------------------------- 840 -- OK_Selected_Component -- 841 --------------------------- 842 843 function OK_Selected_Component (N : Node_Id) return Boolean is 844 begin 845 if Nkind (N) = N_Identifier 846 or else Nkind (N) = N_Operator_Symbol 847 then 848 Num_Names := Num_Names + 1; 849 return True; 850 851 elsif Nkind (N) = N_Selected_Component then 852 return OK_Selected_Component (Prefix (N)) 853 and then OK_Selected_Component (Selector_Name (N)); 854 855 else 856 return False; 857 end if; 858 end OK_Selected_Component; 859 860 -- Start of processing for Process_Eliminate_Pragma 861 862 begin 863 Data.Prag := Pragma_Node; 864 Error_Msg_Name_1 := Name_Eliminate; 865 866 -- Process Unit_Name argument 867 868 if Nkind (Arg_Unit_Name) = N_Identifier then 869 Data.Unit_Name := new Names'(1 => Chars (Arg_Unit_Name)); 870 Num_Names := 1; 871 872 elsif OK_Selected_Component (Arg_Unit_Name) then 873 Data.Unit_Name := new Names (1 .. Num_Names); 874 875 Arg_Uname := Arg_Unit_Name; 876 for J in reverse 2 .. Num_Names loop 877 Data.Unit_Name (J) := Chars (Selector_Name (Arg_Uname)); 878 Arg_Uname := Prefix (Arg_Uname); 879 end loop; 880 881 Data.Unit_Name (1) := Chars (Arg_Uname); 882 883 else 884 Error_Msg_N 885 ("wrong form for Unit_Name parameter of pragma%", Arg_Unit_Name); 886 return; 887 end if; 888 889 -- Process Entity argument 890 891 if Present (Arg_Entity) then 892 Num_Names := 0; 893 894 if Nkind (Arg_Entity) = N_Identifier 895 or else Nkind (Arg_Entity) = N_Operator_Symbol 896 then 897 Data.Entity_Name := Chars (Arg_Entity); 898 Data.Entity_Node := Arg_Entity; 899 Data.Entity_Scope := null; 900 901 elsif OK_Selected_Component (Arg_Entity) then 902 Data.Entity_Scope := new Names (1 .. Num_Names - 1); 903 Data.Entity_Name := Chars (Selector_Name (Arg_Entity)); 904 Data.Entity_Node := Arg_Entity; 905 906 Arg_Ent := Prefix (Arg_Entity); 907 for J in reverse 2 .. Num_Names - 1 loop 908 Data.Entity_Scope (J) := Chars (Selector_Name (Arg_Ent)); 909 Arg_Ent := Prefix (Arg_Ent); 910 end loop; 911 912 Data.Entity_Scope (1) := Chars (Arg_Ent); 913 914 elsif Is_Config_Static_String (Arg_Entity) then 915 Data.Entity_Name := Name_Find; 916 Data.Entity_Node := Arg_Entity; 917 918 else 919 return; 920 end if; 921 else 922 Data.Entity_Node := Empty; 923 Data.Entity_Name := Data.Unit_Name (Num_Names); 924 end if; 925 926 -- Process Parameter_Types argument 927 928 if Present (Arg_Parameter_Types) then 929 930 -- Here for aggregate case 931 932 if Nkind (Arg_Parameter_Types) = N_Aggregate then 933 Data.Parameter_Types := 934 new Names 935 (1 .. List_Length (Expressions (Arg_Parameter_Types))); 936 937 Lit := First (Expressions (Arg_Parameter_Types)); 938 for J in Data.Parameter_Types'Range loop 939 if Is_Config_Static_String (Lit) then 940 Data.Parameter_Types (J) := Name_Find; 941 Next (Lit); 942 else 943 return; 944 end if; 945 end loop; 946 947 -- Otherwise we must have case of one name, which looks like a 948 -- parenthesized literal rather than an aggregate. 949 950 elsif Paren_Count (Arg_Parameter_Types) /= 1 then 951 Error_Msg_N 952 ("wrong form for argument of pragma Eliminate", 953 Arg_Parameter_Types); 954 return; 955 956 elsif Is_Config_Static_String (Arg_Parameter_Types) then 957 String_To_Name_Buffer (Strval (Arg_Parameter_Types)); 958 959 if Name_Len = 0 then 960 961 -- Parameterless procedure 962 963 Data.Parameter_Types := new Names'(1 => No_Name); 964 965 else 966 Data.Parameter_Types := new Names'(1 => Name_Find); 967 end if; 968 969 else 970 return; 971 end if; 972 end if; 973 974 -- Process Result_Types argument 975 976 if Present (Arg_Result_Type) then 977 if Is_Config_Static_String (Arg_Result_Type) then 978 Data.Result_Type := Name_Find; 979 else 980 return; 981 end if; 982 983 -- Here if no Result_Types argument 984 985 else 986 Data.Result_Type := No_Name; 987 end if; 988 989 -- Process Source_Location argument 990 991 if Present (Arg_Source_Location) then 992 if Is_Config_Static_String (Arg_Source_Location) then 993 Data.Source_Location := Name_Find; 994 else 995 return; 996 end if; 997 else 998 Data.Source_Location := No_Name; 999 end if; 1000 1001 Elmt := Elim_Hash_Table.Get (Hash_Subprograms.Get_Key (Data)); 1002 1003 -- If we already have an entry with this same key, then link 1004 -- it into the chain of entries for this key. 1005 1006 if Elmt /= null then 1007 Data.Homonym := Elmt.Homonym; 1008 Elmt.Homonym := Data; 1009 1010 -- Otherwise create a new entry 1011 1012 else 1013 Elim_Hash_Table.Set (Data); 1014 end if; 1015 1016 No_Elimination := False; 1017 end Process_Eliminate_Pragma; 1018 1019end Sem_Elim; 1020