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