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