1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- U N A M E -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1992-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. -- 17-- -- 18-- As a special exception under Section 7 of GPL version 3, you are granted -- 19-- additional permissions described in the GCC Runtime Library Exception, -- 20-- version 3.1, as published by the Free Software Foundation. -- 21-- -- 22-- You should have received a copy of the GNU General Public License and -- 23-- a copy of the GCC Runtime Library Exception along with this program; -- 24-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- 25-- <http://www.gnu.org/licenses/>. -- 26-- -- 27-- GNAT was originally developed by the GNAT team at New York University. -- 28-- Extensive contributions were provided by Ada Core Technologies Inc. -- 29-- -- 30------------------------------------------------------------------------------ 31 32with Atree; use Atree; 33with Casing; use Casing; 34with Einfo; use Einfo; 35with Hostparm; 36with Lib; use Lib; 37with Nlists; use Nlists; 38with Output; use Output; 39with Sinfo; use Sinfo; 40with Sinput; use Sinput; 41 42package body Uname is 43 44 function Has_Prefix (X, Prefix : String) return Boolean; 45 -- True if Prefix is at the beginning of X. For example, 46 -- Has_Prefix("a-filename.ads", Prefix => "a-") is True. 47 48 ------------------- 49 -- Get_Body_Name -- 50 ------------------- 51 52 function Get_Body_Name (N : Unit_Name_Type) return Unit_Name_Type is 53 begin 54 Get_Name_String (N); 55 56 pragma Assert (Name_Len > 2 57 and then Name_Buffer (Name_Len - 1) = '%' 58 and then Name_Buffer (Name_Len) = 's'); 59 60 Name_Buffer (Name_Len) := 'b'; 61 return Name_Find; 62 end Get_Body_Name; 63 64 ----------------------------------- 65 -- Get_External_Unit_Name_String -- 66 ----------------------------------- 67 68 procedure Get_External_Unit_Name_String (N : Unit_Name_Type) is 69 Pcount : Natural; 70 Newlen : Natural; 71 72 begin 73 -- Get unit name and eliminate trailing %s or %b 74 75 Get_Name_String (N); 76 Name_Len := Name_Len - 2; 77 78 -- Find number of components 79 80 Pcount := 0; 81 for J in 1 .. Name_Len loop 82 if Name_Buffer (J) = '.' then 83 Pcount := Pcount + 1; 84 end if; 85 end loop; 86 87 -- If simple name, nothing to do 88 89 if Pcount = 0 then 90 return; 91 end if; 92 93 -- If name has multiple components, replace dots by double underscore 94 95 Newlen := Name_Len + Pcount; 96 97 for J in reverse 1 .. Name_Len loop 98 if Name_Buffer (J) = '.' then 99 Name_Buffer (Newlen) := '_'; 100 Name_Buffer (Newlen - 1) := '_'; 101 Newlen := Newlen - 2; 102 103 else 104 Name_Buffer (Newlen) := Name_Buffer (J); 105 Newlen := Newlen - 1; 106 end if; 107 end loop; 108 109 Name_Len := Name_Len + Pcount; 110 end Get_External_Unit_Name_String; 111 112 -------------------------- 113 -- Get_Parent_Body_Name -- 114 -------------------------- 115 116 function Get_Parent_Body_Name (N : Unit_Name_Type) return Unit_Name_Type is 117 begin 118 Get_Name_String (N); 119 120 while Name_Buffer (Name_Len) /= '.' loop 121 pragma Assert (Name_Len > 1); -- not a child or subunit name 122 Name_Len := Name_Len - 1; 123 end loop; 124 125 Name_Buffer (Name_Len) := '%'; 126 Name_Len := Name_Len + 1; 127 Name_Buffer (Name_Len) := 'b'; 128 return Name_Find; 129 130 end Get_Parent_Body_Name; 131 132 -------------------------- 133 -- Get_Parent_Spec_Name -- 134 -------------------------- 135 136 function Get_Parent_Spec_Name (N : Unit_Name_Type) return Unit_Name_Type is 137 begin 138 Get_Name_String (N); 139 140 while Name_Buffer (Name_Len) /= '.' loop 141 if Name_Len = 1 then 142 return No_Unit_Name; 143 else 144 Name_Len := Name_Len - 1; 145 end if; 146 end loop; 147 148 Name_Buffer (Name_Len) := '%'; 149 Name_Len := Name_Len + 1; 150 Name_Buffer (Name_Len) := 's'; 151 return Name_Find; 152 153 end Get_Parent_Spec_Name; 154 155 ------------------- 156 -- Get_Spec_Name -- 157 ------------------- 158 159 function Get_Spec_Name (N : Unit_Name_Type) return Unit_Name_Type is 160 begin 161 Get_Name_String (N); 162 163 pragma Assert (Name_Len > 2 164 and then Name_Buffer (Name_Len - 1) = '%' 165 and then Name_Buffer (Name_Len) = 'b'); 166 167 Name_Buffer (Name_Len) := 's'; 168 return Name_Find; 169 end Get_Spec_Name; 170 171 ------------------- 172 -- Get_Unit_Name -- 173 ------------------- 174 175 function Get_Unit_Name (N : Node_Id) return Unit_Name_Type is 176 177 Unit_Name_Buffer : String (1 .. Hostparm.Max_Name_Length); 178 -- Buffer used to build name of unit. Note that we cannot use the 179 -- Name_Buffer in package Name_Table because we use it to read 180 -- component names. 181 182 Unit_Name_Length : Natural := 0; 183 -- Length of name stored in Unit_Name_Buffer 184 185 Node : Node_Id; 186 -- Program unit node 187 188 procedure Add_Char (C : Character); 189 -- Add a single character to stored unit name 190 191 procedure Add_Name (Name : Name_Id); 192 -- Add the characters of a names table entry to stored unit name 193 194 procedure Add_Node_Name (Node : Node_Id); 195 -- Recursive procedure adds characters associated with Node 196 197 function Get_Parent (Node : Node_Id) return Node_Id; 198 -- Get parent compilation unit of a stub 199 200 -------------- 201 -- Add_Char -- 202 -------------- 203 204 procedure Add_Char (C : Character) is 205 begin 206 -- Should really check for max length exceeded here??? 207 Unit_Name_Length := Unit_Name_Length + 1; 208 Unit_Name_Buffer (Unit_Name_Length) := C; 209 end Add_Char; 210 211 -------------- 212 -- Add_Name -- 213 -------------- 214 215 procedure Add_Name (Name : Name_Id) is 216 begin 217 Get_Name_String (Name); 218 219 for J in 1 .. Name_Len loop 220 Add_Char (Name_Buffer (J)); 221 end loop; 222 end Add_Name; 223 224 ------------------- 225 -- Add_Node_Name -- 226 ------------------- 227 228 procedure Add_Node_Name (Node : Node_Id) is 229 Kind : constant Node_Kind := Nkind (Node); 230 231 begin 232 -- Just ignore an error node (someone else will give a message) 233 234 if Node = Error then 235 return; 236 237 -- Otherwise see what kind of node we have 238 239 else 240 case Kind is 241 when N_Defining_Identifier 242 | N_Defining_Operator_Symbol 243 | N_Identifier 244 => 245 -- Note: it is of course an error to have a defining 246 -- operator symbol at this point, but this is not where 247 -- the error is signalled, so we handle it nicely here. 248 249 Add_Name (Chars (Node)); 250 251 when N_Defining_Program_Unit_Name => 252 Add_Node_Name (Name (Node)); 253 Add_Char ('.'); 254 Add_Node_Name (Defining_Identifier (Node)); 255 256 when N_Expanded_Name 257 | N_Selected_Component 258 => 259 Add_Node_Name (Prefix (Node)); 260 Add_Char ('.'); 261 Add_Node_Name (Selector_Name (Node)); 262 263 when N_Package_Specification 264 | N_Subprogram_Specification 265 => 266 Add_Node_Name (Defining_Unit_Name (Node)); 267 268 when N_Generic_Declaration 269 | N_Package_Declaration 270 | N_Subprogram_Body 271 | N_Subprogram_Declaration 272 => 273 Add_Node_Name (Specification (Node)); 274 275 when N_Generic_Instantiation => 276 Add_Node_Name (Defining_Unit_Name (Node)); 277 278 when N_Package_Body => 279 Add_Node_Name (Defining_Unit_Name (Node)); 280 281 when N_Protected_Body 282 | N_Task_Body 283 => 284 Add_Node_Name (Defining_Identifier (Node)); 285 286 when N_Package_Renaming_Declaration => 287 Add_Node_Name (Defining_Unit_Name (Node)); 288 289 when N_Subprogram_Renaming_Declaration => 290 Add_Node_Name (Specification (Node)); 291 292 when N_Generic_Renaming_Declaration => 293 Add_Node_Name (Defining_Unit_Name (Node)); 294 295 when N_Subprogram_Body_Stub => 296 Add_Node_Name (Get_Parent (Node)); 297 Add_Char ('.'); 298 Add_Node_Name (Specification (Node)); 299 300 when N_Compilation_Unit => 301 Add_Node_Name (Unit (Node)); 302 303 when N_Package_Body_Stub 304 | N_Protected_Body_Stub 305 | N_Task_Body_Stub 306 => 307 Add_Node_Name (Get_Parent (Node)); 308 Add_Char ('.'); 309 Add_Node_Name (Defining_Identifier (Node)); 310 311 when N_Subunit => 312 Add_Node_Name (Name (Node)); 313 Add_Char ('.'); 314 Add_Node_Name (Proper_Body (Node)); 315 316 when N_With_Clause => 317 Add_Node_Name (Name (Node)); 318 319 when N_Pragma => 320 Add_Node_Name (Expression (First 321 (Pragma_Argument_Associations (Node)))); 322 323 -- Tasks and protected stuff appear only in an error context, 324 -- but the error has been posted elsewhere, so we deal nicely 325 -- with these error situations here, and produce a reasonable 326 -- unit name using the defining identifier. 327 328 when N_Protected_Type_Declaration 329 | N_Single_Protected_Declaration 330 | N_Single_Task_Declaration 331 | N_Task_Type_Declaration 332 => 333 Add_Node_Name (Defining_Identifier (Node)); 334 335 when others => 336 raise Program_Error; 337 end case; 338 end if; 339 end Add_Node_Name; 340 341 ---------------- 342 -- Get_Parent -- 343 ---------------- 344 345 function Get_Parent (Node : Node_Id) return Node_Id is 346 N : Node_Id := Node; 347 348 begin 349 while Nkind (N) /= N_Compilation_Unit loop 350 N := Parent (N); 351 end loop; 352 353 return N; 354 end Get_Parent; 355 356 -- Start of processing for Get_Unit_Name 357 358 begin 359 Node := N; 360 361 -- If we have Defining_Identifier, find the associated unit node 362 363 if Nkind (Node) = N_Defining_Identifier then 364 Node := Declaration_Node (Node); 365 366 -- If an expanded name, it is an already analyzed child unit, find 367 -- unit node. 368 369 elsif Nkind (Node) = N_Expanded_Name then 370 Node := Declaration_Node (Entity (Node)); 371 end if; 372 373 if Nkind (Node) = N_Package_Specification 374 or else Nkind (Node) in N_Subprogram_Specification 375 then 376 Node := Parent (Node); 377 end if; 378 379 -- Node points to the unit, so get its name and add proper suffix 380 381 Add_Node_Name (Node); 382 Add_Char ('%'); 383 384 case Nkind (Node) is 385 when N_Generic_Declaration 386 | N_Generic_Instantiation 387 | N_Generic_Renaming_Declaration 388 | N_Package_Declaration 389 | N_Package_Renaming_Declaration 390 | N_Pragma 391 | N_Protected_Type_Declaration 392 | N_Single_Protected_Declaration 393 | N_Single_Task_Declaration 394 | N_Subprogram_Declaration 395 | N_Subprogram_Renaming_Declaration 396 | N_Task_Type_Declaration 397 | N_With_Clause 398 => 399 Add_Char ('s'); 400 401 when N_Body_Stub 402 | N_Identifier 403 | N_Package_Body 404 | N_Protected_Body 405 | N_Selected_Component 406 | N_Subprogram_Body 407 | N_Subunit 408 | N_Task_Body 409 => 410 Add_Char ('b'); 411 412 when others => 413 raise Program_Error; 414 end case; 415 416 Name_Buffer (1 .. Unit_Name_Length) := 417 Unit_Name_Buffer (1 .. Unit_Name_Length); 418 Name_Len := Unit_Name_Length; 419 return Name_Find; 420 421 end Get_Unit_Name; 422 423 -------------------------- 424 -- Get_Unit_Name_String -- 425 -------------------------- 426 427 procedure Get_Unit_Name_String 428 (N : Unit_Name_Type; 429 Suffix : Boolean := True) 430 is 431 Unit_Is_Body : Boolean; 432 433 begin 434 Get_Decoded_Name_String (N); 435 Unit_Is_Body := Name_Buffer (Name_Len) = 'b'; 436 Set_Casing (Identifier_Casing (Source_Index (Main_Unit))); 437 438 -- A special fudge, normally we don't have operator symbols present, 439 -- since it is always an error to do so. However, if we do, at this 440 -- stage it has the form: 441 442 -- "and" 443 444 -- and the %s or %b has already been eliminated so put 2 chars back 445 446 if Name_Buffer (1) = '"' then 447 Name_Len := Name_Len + 2; 448 end if; 449 450 -- Now adjust the %s or %b to (spec) or (body) 451 452 if Suffix then 453 if Unit_Is_Body then 454 Name_Buffer (Name_Len - 1 .. Name_Len + 5) := " (body)"; 455 else 456 Name_Buffer (Name_Len - 1 .. Name_Len + 5) := " (spec)"; 457 end if; 458 end if; 459 460 for J in 1 .. Name_Len loop 461 if Name_Buffer (J) = '-' then 462 Name_Buffer (J) := '.'; 463 end if; 464 end loop; 465 466 -- Adjust Name_Len 467 468 if Suffix then 469 Name_Len := Name_Len + (7 - 2); 470 else 471 Name_Len := Name_Len - 2; 472 end if; 473 end Get_Unit_Name_String; 474 475 ---------------- 476 -- Has_Prefix -- 477 ---------------- 478 479 function Has_Prefix (X, Prefix : String) return Boolean is 480 begin 481 if X'Length >= Prefix'Length then 482 declare 483 Slice : String renames 484 X (X'First .. X'First + Prefix'Length - 1); 485 begin 486 return Slice = Prefix; 487 end; 488 end if; 489 return False; 490 end Has_Prefix; 491 492 ------------------ 493 -- Is_Body_Name -- 494 ------------------ 495 496 function Is_Body_Name (N : Unit_Name_Type) return Boolean is 497 begin 498 Get_Name_String (N); 499 return Name_Len > 2 500 and then Name_Buffer (Name_Len - 1) = '%' 501 and then Name_Buffer (Name_Len) = 'b'; 502 end Is_Body_Name; 503 504 ------------------- 505 -- Is_Child_Name -- 506 ------------------- 507 508 function Is_Child_Name (N : Unit_Name_Type) return Boolean is 509 J : Natural; 510 511 begin 512 Get_Name_String (N); 513 J := Name_Len; 514 515 while Name_Buffer (J) /= '.' loop 516 if J = 1 then 517 return False; -- not a child or subunit name 518 else 519 J := J - 1; 520 end if; 521 end loop; 522 523 return True; 524 end Is_Child_Name; 525 526 --------------------------- 527 -- Is_Internal_Unit_Name -- 528 --------------------------- 529 530 function Is_Internal_Unit_Name 531 (Name : String; 532 Renamings_Included : Boolean := True) return Boolean 533 is 534 Gnat : constant String := "gnat"; 535 536 begin 537 if Name = Gnat then 538 return True; 539 end if; 540 541 if Has_Prefix (Name, Prefix => Gnat & ".") then 542 return True; 543 end if; 544 545 return Is_Predefined_Unit_Name (Name, Renamings_Included); 546 end Is_Internal_Unit_Name; 547 548 ----------------------------- 549 -- Is_Predefined_Unit_Name -- 550 ----------------------------- 551 552 function Is_Predefined_Unit_Name 553 (Name : String; 554 Renamings_Included : Boolean := True) return Boolean 555 is 556 Ada : constant String := "ada"; 557 Interfaces : constant String := "interfaces"; 558 System : constant String := "system"; 559 560 begin 561 if Name = Ada 562 or else Name = Interfaces 563 or else Name = System 564 then 565 return True; 566 end if; 567 568 if Has_Prefix (Name, Prefix => Ada & ".") 569 or else Has_Prefix (Name, Prefix => Interfaces & ".") 570 or else Has_Prefix (Name, Prefix => System & ".") 571 then 572 return True; 573 end if; 574 575 if not Renamings_Included then 576 return False; 577 end if; 578 579 -- The following are the predefined renamings 580 581 return 582 Name = "calendar" 583 or else Name = "machine_code" 584 or else Name = "unchecked_conversion" 585 or else Name = "unchecked_deallocation" 586 or else Name = "direct_io" 587 or else Name = "io_exceptions" 588 or else Name = "sequential_io" 589 or else Name = "text_io"; 590 end Is_Predefined_Unit_Name; 591 592 ------------------ 593 -- Is_Spec_Name -- 594 ------------------ 595 596 function Is_Spec_Name (N : Unit_Name_Type) return Boolean is 597 begin 598 Get_Name_String (N); 599 return Name_Len > 2 600 and then Name_Buffer (Name_Len - 1) = '%' 601 and then Name_Buffer (Name_Len) = 's'; 602 end Is_Spec_Name; 603 604 ----------------------- 605 -- Name_To_Unit_Name -- 606 ----------------------- 607 608 function Name_To_Unit_Name (N : Name_Id) return Unit_Name_Type is 609 begin 610 Get_Name_String (N); 611 Name_Buffer (Name_Len + 1) := '%'; 612 Name_Buffer (Name_Len + 2) := 's'; 613 Name_Len := Name_Len + 2; 614 return Name_Find; 615 end Name_To_Unit_Name; 616 617 --------------- 618 -- New_Child -- 619 --------------- 620 621 function New_Child 622 (Old : Unit_Name_Type; 623 Newp : Unit_Name_Type) return Unit_Name_Type 624 is 625 P : Natural; 626 627 begin 628 Get_Name_String (Old); 629 630 declare 631 Child : constant String := Name_Buffer (1 .. Name_Len); 632 633 begin 634 Get_Name_String (Newp); 635 Name_Len := Name_Len - 2; 636 637 P := Child'Last; 638 while Child (P) /= '.' loop 639 P := P - 1; 640 end loop; 641 642 while P <= Child'Last loop 643 Name_Len := Name_Len + 1; 644 Name_Buffer (Name_Len) := Child (P); 645 P := P + 1; 646 end loop; 647 648 return Name_Find; 649 end; 650 end New_Child; 651 652 -------------- 653 -- Uname_Ge -- 654 -------------- 655 656 function Uname_Ge (Left, Right : Unit_Name_Type) return Boolean is 657 begin 658 return Left = Right or else Uname_Gt (Left, Right); 659 end Uname_Ge; 660 661 -------------- 662 -- Uname_Gt -- 663 -------------- 664 665 function Uname_Gt (Left, Right : Unit_Name_Type) return Boolean is 666 begin 667 return Left /= Right and then not Uname_Lt (Left, Right); 668 end Uname_Gt; 669 670 -------------- 671 -- Uname_Le -- 672 -------------- 673 674 function Uname_Le (Left, Right : Unit_Name_Type) return Boolean is 675 begin 676 return Left = Right or else Uname_Lt (Left, Right); 677 end Uname_Le; 678 679 -------------- 680 -- Uname_Lt -- 681 -------------- 682 683 function Uname_Lt (Left, Right : Unit_Name_Type) return Boolean is 684 Left_Name : String (1 .. Hostparm.Max_Name_Length); 685 Left_Length : Natural; 686 Right_Name : String renames Name_Buffer; 687 Right_Length : Natural renames Name_Len; 688 J : Natural; 689 690 begin 691 pragma Warnings (Off, Right_Length); 692 -- Suppress warnings on Right_Length, used in pragma Assert 693 694 if Left = Right then 695 return False; 696 end if; 697 698 Get_Name_String (Left); 699 Left_Name (1 .. Name_Len + 1) := Name_Buffer (1 .. Name_Len + 1); 700 Left_Length := Name_Len; 701 Get_Name_String (Right); 702 J := 1; 703 704 loop 705 exit when Left_Name (J) = '%'; 706 707 if Right_Name (J) = '%' then 708 return False; -- left name is longer 709 end if; 710 711 pragma Assert (J <= Left_Length and then J <= Right_Length); 712 713 if Left_Name (J) /= Right_Name (J) then 714 return Left_Name (J) < Right_Name (J); -- parent names different 715 end if; 716 717 J := J + 1; 718 end loop; 719 720 -- Come here pointing to % in left name 721 722 if Right_Name (J) /= '%' then 723 return True; -- right name is longer 724 end if; 725 726 -- Here the parent names are the same and specs sort low. If neither is 727 -- a spec, then we are comparing the same name and we want a result of 728 -- False in any case. 729 730 return Left_Name (J + 1) = 's'; 731 end Uname_Lt; 732 733 --------------------- 734 -- Write_Unit_Name -- 735 --------------------- 736 737 procedure Write_Unit_Name (N : Unit_Name_Type) is 738 begin 739 Get_Unit_Name_String (N); 740 Write_Str (Name_Buffer (1 .. Name_Len)); 741 end Write_Unit_Name; 742 743end Uname; 744