1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- A L I -- 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. 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 Butil; use Butil; 27with Debug; use Debug; 28with Fname; use Fname; 29with Opt; use Opt; 30with Osint; use Osint; 31with Output; use Output; 32with Snames; use Snames; 33 34with GNAT; use GNAT; 35with GNAT.Dynamic_HTables; use GNAT.Dynamic_HTables; 36 37package body ALI is 38 39 use ASCII; 40 -- Make control characters visible 41 42 ----------- 43 -- Types -- 44 ----------- 45 46 -- The following type represents an invocation construct 47 48 type Invocation_Construct_Record is record 49 Body_Placement : Declaration_Placement_Kind := No_Declaration_Placement; 50 -- The location of the invocation construct's body with respect to the 51 -- unit where it is declared. 52 53 Kind : Invocation_Construct_Kind := Regular_Construct; 54 -- The nature of the invocation construct 55 56 Signature : Invocation_Signature_Id := No_Invocation_Signature; 57 -- The invocation signature that uniquely identifies the invocation 58 -- construct in the ALI space. 59 60 Spec_Placement : Declaration_Placement_Kind := No_Declaration_Placement; 61 -- The location of the invocation construct's spec with respect to the 62 -- unit where it is declared. 63 end record; 64 65 -- The following type represents an invocation relation. It associates an 66 -- invoker that activates/calls/instantiates with a target. 67 68 type Invocation_Relation_Record is record 69 Extra : Name_Id := No_Name; 70 -- The name of an additional entity used in error diagnostics 71 72 Invoker : Invocation_Signature_Id := No_Invocation_Signature; 73 -- The invocation signature that uniquely identifies the invoker within 74 -- the ALI space. 75 76 Kind : Invocation_Kind := No_Invocation; 77 -- The nature of the invocation 78 79 Target : Invocation_Signature_Id := No_Invocation_Signature; 80 -- The invocation signature that uniquely identifies the target within 81 -- the ALI space. 82 end record; 83 84 -- The following type represents an invocation signature. Its purpose is 85 -- to uniquely identify an invocation construct within the ALI space. The 86 -- signature comprises several pieces, some of which are used in error 87 -- diagnostics by the binder. Identification issues are resolved as 88 -- follows: 89 -- 90 -- * The Column, Line, and Locations attributes together differentiate 91 -- between homonyms. In most cases, the Column and Line are sufficient 92 -- except when generic instantiations are involved. Together, the three 93 -- attributes offer a sequence of column-line pairs that eventually 94 -- reflect the location within the generic template. 95 -- 96 -- * The Name attribute differentiates between invocation constructs at 97 -- the scope level. Since it is illegal for two entities with the same 98 -- name to coexist in the same scope, the Name attribute is sufficient 99 -- to distinguish them. Overloaded entities are already handled by the 100 -- Column, Line, and Locations attributes. 101 -- 102 -- * The Scope attribute differentiates between invocation constructs at 103 -- various levels of nesting. 104 105 type Invocation_Signature_Record is record 106 Column : Nat := 0; 107 -- The column number where the invocation construct is declared 108 109 Line : Nat := 0; 110 -- The line number where the invocation construct is declared 111 112 Locations : Name_Id := No_Name; 113 -- Sequence of column and line numbers within nested instantiations 114 115 Name : Name_Id := No_Name; 116 -- The name of the invocation construct 117 118 Scope : Name_Id := No_Name; 119 -- The qualified name of the scope where the invocation construct is 120 -- declared. 121 end record; 122 123 --------------------- 124 -- Data structures -- 125 --------------------- 126 127 package Invocation_Constructs is new Table.Table 128 (Table_Index_Type => Invocation_Construct_Id, 129 Table_Component_Type => Invocation_Construct_Record, 130 Table_Low_Bound => First_Invocation_Construct, 131 Table_Initial => 2500, 132 Table_Increment => 200, 133 Table_Name => "Invocation_Constructs"); 134 135 package Invocation_Relations is new Table.Table 136 (Table_Index_Type => Invocation_Relation_Id, 137 Table_Component_Type => Invocation_Relation_Record, 138 Table_Low_Bound => First_Invocation_Relation, 139 Table_Initial => 2500, 140 Table_Increment => 200, 141 Table_Name => "Invocation_Relation"); 142 143 package Invocation_Signatures is new Table.Table 144 (Table_Index_Type => Invocation_Signature_Id, 145 Table_Component_Type => Invocation_Signature_Record, 146 Table_Low_Bound => First_Invocation_Signature, 147 Table_Initial => 2500, 148 Table_Increment => 200, 149 Table_Name => "Invocation_Signatures"); 150 151 procedure Destroy (IS_Id : in out Invocation_Signature_Id); 152 -- Destroy an invocation signature with id IS_Id 153 154 function Hash 155 (IS_Rec : Invocation_Signature_Record) return Bucket_Range_Type; 156 -- Obtain the hash of key IS_Rec 157 158 package Sig_Map is new Dynamic_Hash_Tables 159 (Key_Type => Invocation_Signature_Record, 160 Value_Type => Invocation_Signature_Id, 161 No_Value => No_Invocation_Signature, 162 Expansion_Threshold => 1.5, 163 Expansion_Factor => 2, 164 Compression_Threshold => 0.3, 165 Compression_Factor => 2, 166 "=" => "=", 167 Destroy_Value => Destroy, 168 Hash => Hash); 169 170 -- The following map relates invocation signature records to invocation 171 -- signature ids. 172 173 Sig_To_Sig_Map : constant Sig_Map.Dynamic_Hash_Table := 174 Sig_Map.Create (500); 175 176 -- The folowing table maps declaration placement kinds to character codes 177 -- for invocation construct encoding in ALI files. 178 179 Declaration_Placement_Codes : 180 constant array (Declaration_Placement_Kind) of Character := 181 (In_Body => 'b', 182 In_Spec => 's', 183 No_Declaration_Placement => 'Z'); 184 185 Compile_Time_Invocation_Graph_Encoding : Invocation_Graph_Encoding_Kind := 186 No_Encoding; 187 -- The invocation-graph encoding format as specified at compile time. Do 188 -- not manipulate this value directly. 189 190 -- The following table maps invocation kinds to character codes for 191 -- invocation relation encoding in ALI files. 192 193 Invocation_Codes : 194 constant array (Invocation_Kind) of Character := 195 (Accept_Alternative => 'a', 196 Access_Taken => 'b', 197 Call => 'c', 198 Controlled_Adjustment => 'd', 199 Controlled_Finalization => 'e', 200 Controlled_Initialization => 'f', 201 Default_Initial_Condition_Verification => 'g', 202 Initial_Condition_Verification => 'h', 203 Instantiation => 'i', 204 Internal_Controlled_Adjustment => 'j', 205 Internal_Controlled_Finalization => 'k', 206 Internal_Controlled_Initialization => 'l', 207 Invariant_Verification => 'm', 208 Postcondition_Verification => 'n', 209 Protected_Entry_Call => 'o', 210 Protected_Subprogram_Call => 'p', 211 Task_Activation => 'q', 212 Task_Entry_Call => 'r', 213 Type_Initialization => 's', 214 No_Invocation => 'Z'); 215 216 -- The following table maps invocation construct kinds to character codes 217 -- for invocation construct encoding in ALI files. 218 219 Invocation_Construct_Codes : 220 constant array (Invocation_Construct_Kind) of Character := 221 (Elaborate_Body_Procedure => 'b', 222 Elaborate_Spec_Procedure => 's', 223 Regular_Construct => 'Z'); 224 225 -- The following table maps invocation-graph encoding kinds to character 226 -- codes for invocation-graph encoding in ALI files. 227 228 Invocation_Graph_Encoding_Codes : 229 constant array (Invocation_Graph_Encoding_Kind) of Character := 230 (Full_Path_Encoding => 'f', 231 Endpoints_Encoding => 'e', 232 No_Encoding => 'Z'); 233 234 -- The following table maps invocation-graph line kinds to character codes 235 -- used in ALI files. 236 237 Invocation_Graph_Line_Codes : 238 constant array (Invocation_Graph_Line_Kind) of Character := 239 (Invocation_Construct_Line => 'c', 240 Invocation_Graph_Attributes_Line => 'a', 241 Invocation_Relation_Line => 'r'); 242 243 -- The following variable records which characters currently are used as 244 -- line type markers in the ALI file. This is used in Scan_ALI to detect 245 -- (or skip) invalid lines. The following letters are still available: 246 -- 247 -- B F H J K O Q Z 248 249 Known_ALI_Lines : constant array (Character range 'A' .. 'Z') of Boolean := 250 ('A' => True, -- argument 251 'C' => True, -- SCO information 252 'D' => True, -- dependency 253 'E' => True, -- external 254 'G' => True, -- invocation graph 255 'I' => True, -- interrupt 256 'L' => True, -- linker option 257 'M' => True, -- main program 258 'N' => True, -- notes 259 'P' => True, -- program 260 'R' => True, -- restriction 261 'S' => True, -- specific dispatching 262 'T' => True, -- task stack information 263 'U' => True, -- unit 264 'V' => True, -- version 265 'W' => True, -- with 266 'X' => True, -- xref 267 'Y' => True, -- limited_with 268 'Z' => True, -- implicit with from instantiation 269 others => False); 270 271 ------------------------------ 272 -- Add_Invocation_Construct -- 273 ------------------------------ 274 275 procedure Add_Invocation_Construct 276 (Body_Placement : Declaration_Placement_Kind; 277 Kind : Invocation_Construct_Kind; 278 Signature : Invocation_Signature_Id; 279 Spec_Placement : Declaration_Placement_Kind; 280 Update_Units : Boolean := True) 281 is 282 begin 283 pragma Assert (Present (Signature)); 284 285 -- Create a invocation construct from the scanned attributes 286 287 Invocation_Constructs.Append 288 ((Body_Placement => Body_Placement, 289 Kind => Kind, 290 Signature => Signature, 291 Spec_Placement => Spec_Placement)); 292 293 -- Update the invocation construct counter of the current unit only when 294 -- requested by the caller. 295 296 if Update_Units then 297 declare 298 Curr_Unit : Unit_Record renames Units.Table (Units.Last); 299 300 begin 301 Curr_Unit.Last_Invocation_Construct := Invocation_Constructs.Last; 302 end; 303 end if; 304 end Add_Invocation_Construct; 305 306 ----------------------------- 307 -- Add_Invocation_Relation -- 308 ----------------------------- 309 310 procedure Add_Invocation_Relation 311 (Extra : Name_Id; 312 Invoker : Invocation_Signature_Id; 313 Kind : Invocation_Kind; 314 Target : Invocation_Signature_Id; 315 Update_Units : Boolean := True) 316 is 317 begin 318 pragma Assert (Present (Invoker)); 319 pragma Assert (Kind /= No_Invocation); 320 pragma Assert (Present (Target)); 321 322 -- Create an invocation relation from the scanned attributes 323 324 Invocation_Relations.Append 325 ((Extra => Extra, 326 Invoker => Invoker, 327 Kind => Kind, 328 Target => Target)); 329 330 -- Update the invocation relation counter of the current unit only when 331 -- requested by the caller. 332 333 if Update_Units then 334 declare 335 Curr_Unit : Unit_Record renames Units.Table (Units.Last); 336 337 begin 338 Curr_Unit.Last_Invocation_Relation := Invocation_Relations.Last; 339 end; 340 end if; 341 end Add_Invocation_Relation; 342 343 -------------------- 344 -- Body_Placement -- 345 -------------------- 346 347 function Body_Placement 348 (IC_Id : Invocation_Construct_Id) return Declaration_Placement_Kind 349 is 350 begin 351 pragma Assert (Present (IC_Id)); 352 return Invocation_Constructs.Table (IC_Id).Body_Placement; 353 end Body_Placement; 354 355 ---------------------------------------- 356 -- Code_To_Declaration_Placement_Kind -- 357 ---------------------------------------- 358 359 function Code_To_Declaration_Placement_Kind 360 (Code : Character) return Declaration_Placement_Kind 361 is 362 begin 363 -- Determine which placement kind corresponds to the character code by 364 -- traversing the contents of the mapping table. 365 366 for Kind in Declaration_Placement_Kind loop 367 if Declaration_Placement_Codes (Kind) = Code then 368 return Kind; 369 end if; 370 end loop; 371 372 raise Program_Error; 373 end Code_To_Declaration_Placement_Kind; 374 375 --------------------------------------- 376 -- Code_To_Invocation_Construct_Kind -- 377 --------------------------------------- 378 379 function Code_To_Invocation_Construct_Kind 380 (Code : Character) return Invocation_Construct_Kind 381 is 382 begin 383 -- Determine which invocation construct kind matches the character code 384 -- by traversing the contents of the mapping table. 385 386 for Kind in Invocation_Construct_Kind loop 387 if Invocation_Construct_Codes (Kind) = Code then 388 return Kind; 389 end if; 390 end loop; 391 392 raise Program_Error; 393 end Code_To_Invocation_Construct_Kind; 394 395 -------------------------------------------- 396 -- Code_To_Invocation_Graph_Encoding_Kind -- 397 -------------------------------------------- 398 399 function Code_To_Invocation_Graph_Encoding_Kind 400 (Code : Character) return Invocation_Graph_Encoding_Kind 401 is 402 begin 403 -- Determine which invocation-graph encoding kind matches the character 404 -- code by traversing the contents of the mapping table. 405 406 for Kind in Invocation_Graph_Encoding_Kind loop 407 if Invocation_Graph_Encoding_Codes (Kind) = Code then 408 return Kind; 409 end if; 410 end loop; 411 412 raise Program_Error; 413 end Code_To_Invocation_Graph_Encoding_Kind; 414 415 ----------------------------- 416 -- Code_To_Invocation_Kind -- 417 ----------------------------- 418 419 function Code_To_Invocation_Kind 420 (Code : Character) return Invocation_Kind 421 is 422 begin 423 -- Determine which invocation kind corresponds to the character code by 424 -- traversing the contents of the mapping table. 425 426 for Kind in Invocation_Kind loop 427 if Invocation_Codes (Kind) = Code then 428 return Kind; 429 end if; 430 end loop; 431 432 raise Program_Error; 433 end Code_To_Invocation_Kind; 434 435 ---------------------------------------- 436 -- Code_To_Invocation_Graph_Line_Kind -- 437 ---------------------------------------- 438 439 function Code_To_Invocation_Graph_Line_Kind 440 (Code : Character) return Invocation_Graph_Line_Kind 441 is 442 begin 443 -- Determine which invocation-graph line kind matches the character 444 -- code by traversing the contents of the mapping table. 445 446 for Kind in Invocation_Graph_Line_Kind loop 447 if Invocation_Graph_Line_Codes (Kind) = Code then 448 return Kind; 449 end if; 450 end loop; 451 452 raise Program_Error; 453 end Code_To_Invocation_Graph_Line_Kind; 454 455 ------------ 456 -- Column -- 457 ------------ 458 459 function Column (IS_Id : Invocation_Signature_Id) return Nat is 460 begin 461 pragma Assert (Present (IS_Id)); 462 return Invocation_Signatures.Table (IS_Id).Column; 463 end Column; 464 465 ---------------------------------------- 466 -- Declaration_Placement_Kind_To_Code -- 467 ---------------------------------------- 468 469 function Declaration_Placement_Kind_To_Code 470 (Kind : Declaration_Placement_Kind) return Character 471 is 472 begin 473 return Declaration_Placement_Codes (Kind); 474 end Declaration_Placement_Kind_To_Code; 475 476 ------------- 477 -- Destroy -- 478 ------------- 479 480 procedure Destroy (IS_Id : in out Invocation_Signature_Id) is 481 pragma Unreferenced (IS_Id); 482 begin 483 null; 484 end Destroy; 485 486 ----------- 487 -- Extra -- 488 ----------- 489 490 function Extra (IR_Id : Invocation_Relation_Id) return Name_Id is 491 begin 492 pragma Assert (Present (IR_Id)); 493 return Invocation_Relations.Table (IR_Id).Extra; 494 end Extra; 495 496 ----------------------------------- 497 -- For_Each_Invocation_Construct -- 498 ----------------------------------- 499 500 procedure For_Each_Invocation_Construct 501 (Processor : Invocation_Construct_Processor_Ptr) 502 is 503 begin 504 pragma Assert (Processor /= null); 505 506 for IC_Id in Invocation_Constructs.First .. 507 Invocation_Constructs.Last 508 loop 509 Processor.all (IC_Id); 510 end loop; 511 end For_Each_Invocation_Construct; 512 513 ----------------------------------- 514 -- For_Each_Invocation_Construct -- 515 ----------------------------------- 516 517 procedure For_Each_Invocation_Construct 518 (U_Id : Unit_Id; 519 Processor : Invocation_Construct_Processor_Ptr) 520 is 521 pragma Assert (Present (U_Id)); 522 pragma Assert (Processor /= null); 523 524 U_Rec : Unit_Record renames Units.Table (U_Id); 525 526 begin 527 for IC_Id in U_Rec.First_Invocation_Construct .. 528 U_Rec.Last_Invocation_Construct 529 loop 530 Processor.all (IC_Id); 531 end loop; 532 end For_Each_Invocation_Construct; 533 534 ---------------------------------- 535 -- For_Each_Invocation_Relation -- 536 ---------------------------------- 537 538 procedure For_Each_Invocation_Relation 539 (Processor : Invocation_Relation_Processor_Ptr) 540 is 541 begin 542 pragma Assert (Processor /= null); 543 544 for IR_Id in Invocation_Relations.First .. 545 Invocation_Relations.Last 546 loop 547 Processor.all (IR_Id); 548 end loop; 549 end For_Each_Invocation_Relation; 550 551 ---------------------------------- 552 -- For_Each_Invocation_Relation -- 553 ---------------------------------- 554 555 procedure For_Each_Invocation_Relation 556 (U_Id : Unit_Id; 557 Processor : Invocation_Relation_Processor_Ptr) 558 is 559 pragma Assert (Present (U_Id)); 560 pragma Assert (Processor /= null); 561 562 U_Rec : Unit_Record renames Units.Table (U_Id); 563 564 begin 565 for IR_Id in U_Rec.First_Invocation_Relation .. 566 U_Rec.Last_Invocation_Relation 567 loop 568 Processor.all (IR_Id); 569 end loop; 570 end For_Each_Invocation_Relation; 571 572 ---------- 573 -- Hash -- 574 ---------- 575 576 function Hash 577 (IS_Rec : Invocation_Signature_Record) return Bucket_Range_Type 578 is 579 Buffer : Bounded_String (2052); 580 IS_Nam : Name_Id; 581 582 begin 583 -- The hash is obtained in the following manner: 584 -- 585 -- * A String signature based on the scope, name, line number, column 586 -- number, and locations, in the following format: 587 -- 588 -- scope__name__line_column__locations 589 -- 590 -- * The String is converted into a Name_Id 591 -- * The Name_Id is used as the hash 592 593 Append (Buffer, IS_Rec.Scope); 594 Append (Buffer, "__"); 595 Append (Buffer, IS_Rec.Name); 596 Append (Buffer, "__"); 597 Append (Buffer, IS_Rec.Line); 598 Append (Buffer, '_'); 599 Append (Buffer, IS_Rec.Column); 600 601 if IS_Rec.Locations /= No_Name then 602 Append (Buffer, "__"); 603 Append (Buffer, IS_Rec.Locations); 604 end if; 605 606 IS_Nam := Name_Find (Buffer); 607 return Bucket_Range_Type (IS_Nam); 608 end Hash; 609 610 -------------------- 611 -- Initialize_ALI -- 612 -------------------- 613 614 procedure Initialize_ALI is 615 begin 616 -- When (re)initializing ALI data structures the ALI user expects to 617 -- get a fresh set of data structures. Thus we first need to erase the 618 -- marks put in the name table by the previous set of ALI routine calls. 619 -- These two loops are empty and harmless the first time in. 620 621 for J in ALIs.First .. ALIs.Last loop 622 Set_Name_Table_Int (ALIs.Table (J).Afile, 0); 623 end loop; 624 625 for J in Units.First .. Units.Last loop 626 Set_Name_Table_Int (Units.Table (J).Uname, 0); 627 end loop; 628 629 -- Free argument table strings 630 631 for J in Args.First .. Args.Last loop 632 Free (Args.Table (J)); 633 end loop; 634 635 -- Initialize all tables 636 637 ALIs.Init; 638 Invocation_Constructs.Init; 639 Invocation_Relations.Init; 640 Invocation_Signatures.Init; 641 Linker_Options.Init; 642 No_Deps.Init; 643 Notes.Init; 644 Sdep.Init; 645 Units.Init; 646 Version_Ref.Reset; 647 Withs.Init; 648 Xref_Entity.Init; 649 Xref.Init; 650 Xref_Section.Init; 651 652 -- Add dummy zeroth item in Linker_Options and Notes for sort calls 653 654 Linker_Options.Increment_Last; 655 Notes.Increment_Last; 656 657 -- Initialize global variables recording cumulative options in all 658 -- ALI files that are read for a given processing run in gnatbind. 659 660 Dynamic_Elaboration_Checks_Specified := False; 661 Locking_Policy_Specified := ' '; 662 No_Normalize_Scalars_Specified := False; 663 No_Object_Specified := False; 664 No_Component_Reordering_Specified := False; 665 GNATprove_Mode_Specified := False; 666 Normalize_Scalars_Specified := False; 667 Partition_Elaboration_Policy_Specified := ' '; 668 Queuing_Policy_Specified := ' '; 669 SSO_Default_Specified := False; 670 Task_Dispatching_Policy_Specified := ' '; 671 Unreserve_All_Interrupts_Specified := False; 672 Frontend_Exceptions_Specified := False; 673 Zero_Cost_Exceptions_Specified := False; 674 end Initialize_ALI; 675 676 --------------------------------------- 677 -- Invocation_Construct_Kind_To_Code -- 678 --------------------------------------- 679 680 function Invocation_Construct_Kind_To_Code 681 (Kind : Invocation_Construct_Kind) return Character 682 is 683 begin 684 return Invocation_Construct_Codes (Kind); 685 end Invocation_Construct_Kind_To_Code; 686 687 ------------------------------- 688 -- Invocation_Graph_Encoding -- 689 ------------------------------- 690 691 function Invocation_Graph_Encoding return Invocation_Graph_Encoding_Kind is 692 begin 693 return Compile_Time_Invocation_Graph_Encoding; 694 end Invocation_Graph_Encoding; 695 696 -------------------------------------------- 697 -- Invocation_Graph_Encoding_Kind_To_Code -- 698 -------------------------------------------- 699 700 function Invocation_Graph_Encoding_Kind_To_Code 701 (Kind : Invocation_Graph_Encoding_Kind) return Character 702 is 703 begin 704 return Invocation_Graph_Encoding_Codes (Kind); 705 end Invocation_Graph_Encoding_Kind_To_Code; 706 707 ---------------------------------------- 708 -- Invocation_Graph_Line_Kind_To_Code -- 709 ---------------------------------------- 710 711 function Invocation_Graph_Line_Kind_To_Code 712 (Kind : Invocation_Graph_Line_Kind) return Character 713 is 714 begin 715 return Invocation_Graph_Line_Codes (Kind); 716 end Invocation_Graph_Line_Kind_To_Code; 717 718 ----------------------------- 719 -- Invocation_Kind_To_Code -- 720 ----------------------------- 721 722 function Invocation_Kind_To_Code 723 (Kind : Invocation_Kind) return Character 724 is 725 begin 726 return Invocation_Codes (Kind); 727 end Invocation_Kind_To_Code; 728 729 ----------------------------- 730 -- Invocation_Signature_Of -- 731 ----------------------------- 732 733 function Invocation_Signature_Of 734 (Column : Nat; 735 Line : Nat; 736 Locations : Name_Id; 737 Name : Name_Id; 738 Scope : Name_Id) return Invocation_Signature_Id 739 is 740 IS_Rec : constant Invocation_Signature_Record := 741 (Column => Column, 742 Line => Line, 743 Locations => Locations, 744 Name => Name, 745 Scope => Scope); 746 IS_Id : Invocation_Signature_Id; 747 748 begin 749 IS_Id := Sig_Map.Get (Sig_To_Sig_Map, IS_Rec); 750 751 -- The invocation signature lacks an id. This indicates that it 752 -- is encountered for the first time during the construction of 753 -- the graph. 754 755 if not Present (IS_Id) then 756 Invocation_Signatures.Append (IS_Rec); 757 IS_Id := Invocation_Signatures.Last; 758 759 -- Map the invocation signature record to its corresponding id 760 761 Sig_Map.Put (Sig_To_Sig_Map, IS_Rec, IS_Id); 762 end if; 763 764 return IS_Id; 765 end Invocation_Signature_Of; 766 767 ------------- 768 -- Invoker -- 769 ------------- 770 771 function Invoker 772 (IR_Id : Invocation_Relation_Id) return Invocation_Signature_Id 773 is 774 begin 775 pragma Assert (Present (IR_Id)); 776 return Invocation_Relations.Table (IR_Id).Invoker; 777 end Invoker; 778 779 ---------- 780 -- Kind -- 781 ---------- 782 783 function Kind 784 (IC_Id : Invocation_Construct_Id) return Invocation_Construct_Kind 785 is 786 begin 787 pragma Assert (Present (IC_Id)); 788 return Invocation_Constructs.Table (IC_Id).Kind; 789 end Kind; 790 791 ---------- 792 -- Kind -- 793 ---------- 794 795 function Kind (IR_Id : Invocation_Relation_Id) return Invocation_Kind is 796 begin 797 pragma Assert (Present (IR_Id)); 798 return Invocation_Relations.Table (IR_Id).Kind; 799 end Kind; 800 801 ---------- 802 -- Line -- 803 ---------- 804 805 function Line (IS_Id : Invocation_Signature_Id) return Nat is 806 begin 807 pragma Assert (Present (IS_Id)); 808 return Invocation_Signatures.Table (IS_Id).Line; 809 end Line; 810 811 --------------- 812 -- Locations -- 813 --------------- 814 815 function Locations (IS_Id : Invocation_Signature_Id) return Name_Id is 816 begin 817 pragma Assert (Present (IS_Id)); 818 return Invocation_Signatures.Table (IS_Id).Locations; 819 end Locations; 820 821 ---------- 822 -- Name -- 823 ---------- 824 825 function Name (IS_Id : Invocation_Signature_Id) return Name_Id is 826 begin 827 pragma Assert (Present (IS_Id)); 828 return Invocation_Signatures.Table (IS_Id).Name; 829 end Name; 830 831 ------------- 832 -- Present -- 833 ------------- 834 835 function Present (IC_Id : Invocation_Construct_Id) return Boolean is 836 begin 837 return IC_Id /= No_Invocation_Construct; 838 end Present; 839 840 ------------- 841 -- Present -- 842 ------------- 843 844 function Present (IR_Id : Invocation_Relation_Id) return Boolean is 845 begin 846 return IR_Id /= No_Invocation_Relation; 847 end Present; 848 849 ------------- 850 -- Present -- 851 ------------- 852 853 function Present (IS_Id : Invocation_Signature_Id) return Boolean is 854 begin 855 return IS_Id /= No_Invocation_Signature; 856 end Present; 857 858 ------------- 859 -- Present -- 860 ------------- 861 862 function Present (Dep : Sdep_Id) return Boolean is 863 begin 864 return Dep /= No_Sdep_Id; 865 end Present; 866 867 ------------- 868 -- Present -- 869 ------------- 870 871 function Present (U_Id : Unit_Id) return Boolean is 872 begin 873 return U_Id /= No_Unit_Id; 874 end Present; 875 876 ------------- 877 -- Present -- 878 ------------- 879 880 function Present (W_Id : With_Id) return Boolean is 881 begin 882 return W_Id /= No_With_Id; 883 end Present; 884 885 -------------- 886 -- Scan_ALI -- 887 -------------- 888 889 function Scan_ALI 890 (F : File_Name_Type; 891 T : Text_Buffer_Ptr; 892 Ignore_ED : Boolean; 893 Err : Boolean; 894 Read_Xref : Boolean := False; 895 Read_Lines : String := ""; 896 Ignore_Lines : String := "X"; 897 Ignore_Errors : Boolean := False; 898 Directly_Scanned : Boolean := False) return ALI_Id 899 is 900 P : Text_Ptr := T'First; 901 Line : Logical_Line_Number := 1; 902 Id : ALI_Id; 903 C : Character; 904 NS_Found : Boolean; 905 First_Arg : Arg_Id; 906 907 Ignore : array (Character range 'A' .. 'Z') of Boolean; 908 -- Ignore (X) is set to True if lines starting with X are to 909 -- be ignored by Scan_ALI and skipped, and False if the lines 910 -- are to be read and processed. 911 912 Bad_ALI_Format : exception; 913 -- Exception raised by Fatal_Error if Err is True 914 915 function At_Eol return Boolean; 916 -- Test if at end of line 917 918 function At_End_Of_Field return Boolean; 919 -- Test if at end of line, or if at blank or horizontal tab 920 921 procedure Check_At_End_Of_Field; 922 -- Check if we are at end of field, fatal error if not 923 924 procedure Checkc (C : Character); 925 -- Check next character is C. If so bump past it, if not fatal error 926 927 procedure Check_Unknown_Line; 928 -- If Ignore_Errors mode, then checks C to make sure that it is not 929 -- an unknown ALI line type characters, and if so, skips lines 930 -- until the first character of the line is one of these characters, 931 -- at which point it does a Getc to put that character in C. The 932 -- call has no effect if C is already an appropriate character. 933 -- If not in Ignore_Errors mode, a fatal error is signalled if the 934 -- line is unknown. Note that if C is an EOL on entry, the line is 935 -- skipped (it is assumed that blank lines are never significant). 936 -- If C is EOF on entry, the call has no effect (it is assumed that 937 -- the caller will properly handle this case). 938 939 procedure Fatal_Error; 940 -- Generate fatal error message for badly formatted ALI file if 941 -- Err is false, or raise Bad_ALI_Format if Err is True. 942 943 procedure Fatal_Error_Ignore; 944 pragma Inline (Fatal_Error_Ignore); 945 -- In Ignore_Errors mode, has no effect, otherwise same as Fatal_Error 946 947 function Getc return Character; 948 -- Get next character, bumping P past the character obtained 949 950 function Get_File_Name 951 (Lower : Boolean := False; 952 May_Be_Quoted : Boolean := False) return File_Name_Type; 953 -- Skip blanks, then scan out a file name (name is left in Name_Buffer 954 -- with length in Name_Len, as well as returning a File_Name_Type value. 955 -- If May_Be_Quoted is True and the first non blank character is '"', 956 -- then remove starting and ending quotes and undoubled internal quotes. 957 -- If lower is false, the case is unchanged, if Lower is True then the 958 -- result is forced to all lower case for systems where file names are 959 -- not case sensitive. This ensures that gnatbind works correctly 960 -- regardless of the case of the file name on all systems. The scan 961 -- is terminated by a end of line, space or horizontal tab. Any other 962 -- special characters are included in the returned name. 963 964 function Get_Name 965 (Ignore_Spaces : Boolean := False; 966 Ignore_Special : Boolean := False; 967 May_Be_Quoted : Boolean := False) return Name_Id; 968 -- Skip blanks, then scan out a name (name is left in Name_Buffer with 969 -- length in Name_Len, as well as being returned in Name_Id form). 970 -- If Lower is set to True then the Name_Buffer will be converted to 971 -- all lower case, for systems where file names are not case sensitive. 972 -- This ensures that gnatbind works correctly regardless of the case 973 -- of the file name on all systems. The termination condition depends 974 -- on the settings of Ignore_Spaces and Ignore_Special: 975 -- 976 -- If Ignore_Spaces is False (normal case), then scan is terminated 977 -- by the normal end of field condition (EOL, space, horizontal tab) 978 -- 979 -- If Ignore_Special is False (normal case), the scan is terminated by 980 -- a typeref bracket or an equal sign except for the special case of 981 -- an operator name starting with a double quote that is terminated 982 -- by another double quote. 983 -- 984 -- If May_Be_Quoted is True and the first non blank character is '"' 985 -- the name is 'unquoted'. In this case Ignore_Special is ignored and 986 -- assumed to be True. 987 -- 988 -- It is an error to set both Ignore_Spaces and Ignore_Special to True. 989 -- This function handles wide characters properly. 990 991 function Get_Nat return Nat; 992 -- Skip blanks, then scan out an unsigned integer value in Nat range 993 -- raises ALI_Reading_Error if the encoutered type is not natural. 994 995 function Get_Stamp return Time_Stamp_Type; 996 -- Skip blanks, then scan out a time stamp 997 998 function Get_Unit_Name return Unit_Name_Type; 999 -- Skip blanks, then scan out a file name (name is left in Name_Buffer 1000 -- with length in Name_Len, as well as returning a Unit_Name_Type value. 1001 -- The case is unchanged and terminated by a normal end of field. 1002 1003 function Nextc return Character; 1004 -- Return current character without modifying pointer P 1005 1006 procedure Get_Typeref 1007 (Current_File_Num : Sdep_Id; 1008 Ref : out Tref_Kind; 1009 File_Num : out Sdep_Id; 1010 Line : out Nat; 1011 Ref_Type : out Character; 1012 Col : out Nat; 1013 Standard_Entity : out Name_Id); 1014 -- Parse the definition of a typeref (<...>, {...} or (...)) 1015 1016 procedure Scan_Invocation_Graph_Line; 1017 -- Parse a single line that encodes a piece of the invocation graph 1018 1019 procedure Skip_Eol; 1020 -- Skip past spaces, then skip past end of line (fatal error if not 1021 -- at end of line). Also skips past any following blank lines. 1022 1023 procedure Skip_Line; 1024 -- Skip rest of current line and any following blank lines 1025 1026 procedure Skip_Space; 1027 -- Skip past white space (blanks or horizontal tab) 1028 1029 procedure Skipc; 1030 -- Skip past next character, does not affect value in C. This call 1031 -- is like calling Getc and ignoring the returned result. 1032 1033 --------------------- 1034 -- At_End_Of_Field -- 1035 --------------------- 1036 1037 function At_End_Of_Field return Boolean is 1038 begin 1039 return Nextc <= ' '; 1040 end At_End_Of_Field; 1041 1042 ------------ 1043 -- At_Eol -- 1044 ------------ 1045 1046 function At_Eol return Boolean is 1047 begin 1048 return Nextc = EOF or else Nextc = CR or else Nextc = LF; 1049 end At_Eol; 1050 1051 --------------------------- 1052 -- Check_At_End_Of_Field -- 1053 --------------------------- 1054 1055 procedure Check_At_End_Of_Field is 1056 begin 1057 if not At_End_Of_Field then 1058 if Ignore_Errors then 1059 while Nextc > ' ' loop 1060 P := P + 1; 1061 end loop; 1062 else 1063 Fatal_Error; 1064 end if; 1065 end if; 1066 end Check_At_End_Of_Field; 1067 1068 ------------------------ 1069 -- Check_Unknown_Line -- 1070 ------------------------ 1071 1072 procedure Check_Unknown_Line is 1073 begin 1074 while C not in 'A' .. 'Z' 1075 or else not Known_ALI_Lines (C) 1076 loop 1077 if C = CR or else C = LF then 1078 Skip_Line; 1079 C := Nextc; 1080 1081 elsif C = EOF then 1082 return; 1083 1084 elsif Ignore_Errors then 1085 Skip_Line; 1086 C := Getc; 1087 1088 else 1089 Fatal_Error; 1090 end if; 1091 end loop; 1092 end Check_Unknown_Line; 1093 1094 ------------ 1095 -- Checkc -- 1096 ------------ 1097 1098 procedure Checkc (C : Character) is 1099 begin 1100 if Nextc = C then 1101 P := P + 1; 1102 elsif Ignore_Errors then 1103 P := P + 1; 1104 else 1105 Fatal_Error; 1106 end if; 1107 end Checkc; 1108 1109 ----------------- 1110 -- Fatal_Error -- 1111 ----------------- 1112 1113 procedure Fatal_Error is 1114 Ptr1 : Text_Ptr; 1115 Ptr2 : Text_Ptr; 1116 Col : Int; 1117 1118 procedure Wchar (C : Character); 1119 -- Write a single character, replacing horizontal tab by spaces 1120 1121 procedure Wchar (C : Character) is 1122 begin 1123 if C = HT then 1124 loop 1125 Wchar (' '); 1126 exit when Col mod 8 = 0; 1127 end loop; 1128 1129 else 1130 Write_Char (C); 1131 Col := Col + 1; 1132 end if; 1133 end Wchar; 1134 1135 -- Start of processing for Fatal_Error 1136 1137 begin 1138 if Err then 1139 raise Bad_ALI_Format; 1140 end if; 1141 1142 Set_Standard_Error; 1143 Write_Str ("fatal error: file "); 1144 Write_Name (F); 1145 Write_Str (" is incorrectly formatted"); 1146 Write_Eol; 1147 1148 Write_Str ("make sure you are using consistent versions " & 1149 1150 -- Split the following line so that it can easily be transformed for 1151 -- other back-ends where the compiler might have a different name. 1152 1153 "of gcc/gnatbind"); 1154 1155 Write_Eol; 1156 1157 -- Find start of line 1158 1159 Ptr1 := P; 1160 while Ptr1 > T'First 1161 and then T (Ptr1 - 1) /= CR 1162 and then T (Ptr1 - 1) /= LF 1163 loop 1164 Ptr1 := Ptr1 - 1; 1165 end loop; 1166 1167 Write_Int (Int (Line)); 1168 Write_Str (". "); 1169 1170 if Line < 100 then 1171 Write_Char (' '); 1172 end if; 1173 1174 if Line < 10 then 1175 Write_Char (' '); 1176 end if; 1177 1178 Col := 0; 1179 Ptr2 := Ptr1; 1180 1181 while Ptr2 < T'Last 1182 and then T (Ptr2) /= CR 1183 and then T (Ptr2) /= LF 1184 loop 1185 Wchar (T (Ptr2)); 1186 Ptr2 := Ptr2 + 1; 1187 end loop; 1188 1189 Write_Eol; 1190 1191 Write_Str (" "); 1192 Col := 0; 1193 1194 while Ptr1 < P loop 1195 if T (Ptr1) = HT then 1196 Wchar (HT); 1197 else 1198 Wchar (' '); 1199 end if; 1200 1201 Ptr1 := Ptr1 + 1; 1202 end loop; 1203 1204 Wchar ('|'); 1205 Write_Eol; 1206 1207 Exit_Program (E_Fatal); 1208 end Fatal_Error; 1209 1210 ------------------------ 1211 -- Fatal_Error_Ignore -- 1212 ------------------------ 1213 1214 procedure Fatal_Error_Ignore is 1215 begin 1216 if not Ignore_Errors then 1217 Fatal_Error; 1218 end if; 1219 end Fatal_Error_Ignore; 1220 1221 ------------------- 1222 -- Get_File_Name -- 1223 ------------------- 1224 1225 function Get_File_Name 1226 (Lower : Boolean := False; 1227 May_Be_Quoted : Boolean := False) return File_Name_Type 1228 is 1229 F : Name_Id; 1230 1231 begin 1232 F := Get_Name (Ignore_Special => True, 1233 May_Be_Quoted => May_Be_Quoted); 1234 1235 -- Convert file name to all lower case if file names are not case 1236 -- sensitive. This ensures that we handle names in the canonical 1237 -- lower case format, regardless of the actual case. 1238 1239 if Lower and not File_Names_Case_Sensitive then 1240 Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); 1241 return Name_Find; 1242 else 1243 return File_Name_Type (F); 1244 end if; 1245 end Get_File_Name; 1246 1247 -------------- 1248 -- Get_Name -- 1249 -------------- 1250 1251 function Get_Name 1252 (Ignore_Spaces : Boolean := False; 1253 Ignore_Special : Boolean := False; 1254 May_Be_Quoted : Boolean := False) return Name_Id 1255 is 1256 Char : Character; 1257 1258 begin 1259 Name_Len := 0; 1260 Skip_Space; 1261 1262 if At_Eol then 1263 if Ignore_Errors then 1264 return Error_Name; 1265 else 1266 Fatal_Error; 1267 end if; 1268 end if; 1269 1270 Char := Getc; 1271 1272 -- Deal with quoted characters 1273 1274 if May_Be_Quoted and then Char = '"' then 1275 loop 1276 if At_Eol then 1277 if Ignore_Errors then 1278 return Error_Name; 1279 else 1280 Fatal_Error; 1281 end if; 1282 end if; 1283 1284 Char := Getc; 1285 1286 if Char = '"' then 1287 if At_Eol then 1288 exit; 1289 1290 else 1291 Char := Getc; 1292 1293 if Char /= '"' then 1294 P := P - 1; 1295 exit; 1296 end if; 1297 end if; 1298 end if; 1299 1300 Add_Char_To_Name_Buffer (Char); 1301 end loop; 1302 1303 -- Other than case of quoted character 1304 1305 else 1306 P := P - 1; 1307 loop 1308 Add_Char_To_Name_Buffer (Getc); 1309 1310 exit when At_End_Of_Field and then not Ignore_Spaces; 1311 1312 if not Ignore_Special then 1313 if Name_Buffer (1) = '"' then 1314 exit when Name_Len > 1 1315 and then Name_Buffer (Name_Len) = '"'; 1316 1317 else 1318 -- Terminate on parens or angle brackets or equal sign 1319 1320 exit when Nextc = '(' or else Nextc = ')' 1321 or else Nextc = '{' or else Nextc = '}' 1322 or else Nextc = '<' or else Nextc = '>' 1323 or else Nextc = '='; 1324 1325 -- Terminate on comma 1326 1327 exit when Nextc = ','; 1328 1329 -- Terminate if left bracket not part of wide char 1330 -- sequence Note that we only recognize brackets 1331 -- notation so far ??? 1332 1333 exit when Nextc = '[' and then T (P + 1) /= '"'; 1334 1335 -- Terminate if right bracket not part of wide char 1336 -- sequence. 1337 1338 exit when Nextc = ']' and then T (P - 1) /= '"'; 1339 end if; 1340 end if; 1341 end loop; 1342 end if; 1343 1344 return Name_Find; 1345 end Get_Name; 1346 1347 ------------------- 1348 -- Get_Unit_Name -- 1349 ------------------- 1350 1351 function Get_Unit_Name return Unit_Name_Type is 1352 begin 1353 return Unit_Name_Type (Get_Name); 1354 end Get_Unit_Name; 1355 1356 ------------- 1357 -- Get_Nat -- 1358 ------------- 1359 1360 function Get_Nat return Nat is 1361 V : Nat; 1362 1363 begin 1364 Skip_Space; 1365 1366 -- Check if we are on a number. In the case of bad ALI files, this 1367 -- may not be true. 1368 1369 if not (Nextc in '0' .. '9') then 1370 Fatal_Error; 1371 end if; 1372 1373 V := 0; 1374 loop 1375 V := V * 10 + (Character'Pos (Getc) - Character'Pos ('0')); 1376 1377 exit when At_End_Of_Field; 1378 exit when Nextc < '0' or else Nextc > '9'; 1379 end loop; 1380 1381 return V; 1382 end Get_Nat; 1383 1384 --------------- 1385 -- Get_Stamp -- 1386 --------------- 1387 1388 function Get_Stamp return Time_Stamp_Type is 1389 T : Time_Stamp_Type; 1390 Start : Integer; 1391 1392 begin 1393 Skip_Space; 1394 1395 if At_Eol then 1396 if Ignore_Errors then 1397 return Dummy_Time_Stamp; 1398 else 1399 Fatal_Error; 1400 end if; 1401 end if; 1402 1403 -- Following reads old style time stamp missing first two digits 1404 1405 if Nextc in '7' .. '9' then 1406 T (1) := '1'; 1407 T (2) := '9'; 1408 Start := 3; 1409 1410 -- Normal case of full year in time stamp 1411 1412 else 1413 Start := 1; 1414 end if; 1415 1416 for J in Start .. T'Last loop 1417 T (J) := Getc; 1418 end loop; 1419 1420 return T; 1421 end Get_Stamp; 1422 1423 ----------------- 1424 -- Get_Typeref -- 1425 ----------------- 1426 1427 procedure Get_Typeref 1428 (Current_File_Num : Sdep_Id; 1429 Ref : out Tref_Kind; 1430 File_Num : out Sdep_Id; 1431 Line : out Nat; 1432 Ref_Type : out Character; 1433 Col : out Nat; 1434 Standard_Entity : out Name_Id) 1435 is 1436 N : Nat; 1437 begin 1438 case Nextc is 1439 when '<' => Ref := Tref_Derived; 1440 when '(' => Ref := Tref_Access; 1441 when '{' => Ref := Tref_Type; 1442 when others => Ref := Tref_None; 1443 end case; 1444 1445 -- Case of typeref field present 1446 1447 if Ref /= Tref_None then 1448 P := P + 1; -- skip opening bracket 1449 1450 if Nextc in 'a' .. 'z' then 1451 File_Num := No_Sdep_Id; 1452 Line := 0; 1453 Ref_Type := ' '; 1454 Col := 0; 1455 Standard_Entity := Get_Name (Ignore_Spaces => True); 1456 else 1457 N := Get_Nat; 1458 1459 if Nextc = '|' then 1460 File_Num := Sdep_Id (N + Nat (First_Sdep_Entry) - 1); 1461 P := P + 1; 1462 N := Get_Nat; 1463 else 1464 File_Num := Current_File_Num; 1465 end if; 1466 1467 Line := N; 1468 Ref_Type := Getc; 1469 Col := Get_Nat; 1470 Standard_Entity := No_Name; 1471 end if; 1472 1473 -- ??? Temporary workaround for nested generics case: 1474 -- 4i4 Directories{1|4I9[4|6[3|3]]} 1475 -- See C918-002 1476 1477 declare 1478 Nested_Brackets : Natural := 0; 1479 1480 begin 1481 loop 1482 case Nextc is 1483 when '[' => 1484 Nested_Brackets := Nested_Brackets + 1; 1485 when ']' => 1486 Nested_Brackets := Nested_Brackets - 1; 1487 when others => 1488 if Nested_Brackets = 0 then 1489 exit; 1490 end if; 1491 end case; 1492 1493 Skipc; 1494 end loop; 1495 end; 1496 1497 P := P + 1; -- skip closing bracket 1498 Skip_Space; 1499 1500 -- No typeref entry present 1501 1502 else 1503 File_Num := No_Sdep_Id; 1504 Line := 0; 1505 Ref_Type := ' '; 1506 Col := 0; 1507 Standard_Entity := No_Name; 1508 end if; 1509 end Get_Typeref; 1510 1511 ---------- 1512 -- Getc -- 1513 ---------- 1514 1515 function Getc return Character is 1516 begin 1517 if P = T'Last then 1518 return EOF; 1519 else 1520 P := P + 1; 1521 return T (P - 1); 1522 end if; 1523 end Getc; 1524 1525 ----------- 1526 -- Nextc -- 1527 ----------- 1528 1529 function Nextc return Character is 1530 begin 1531 return T (P); 1532 end Nextc; 1533 1534 -------------------------------- 1535 -- Scan_Invocation_Graph_Line -- 1536 -------------------------------- 1537 1538 procedure Scan_Invocation_Graph_Line is 1539 procedure Scan_Invocation_Construct_Line; 1540 pragma Inline (Scan_Invocation_Construct_Line); 1541 -- Parse an invocation construct line and construct the corresponding 1542 -- construct. The following data structures are updated: 1543 -- 1544 -- * Invocation_Constructs 1545 -- * Units 1546 1547 procedure Scan_Invocation_Graph_Attributes_Line; 1548 pragma Inline (Scan_Invocation_Graph_Attributes_Line); 1549 -- Parse an invocation-graph attributes line. The following data 1550 -- structures are updated: 1551 -- 1552 -- * Units 1553 1554 procedure Scan_Invocation_Relation_Line; 1555 pragma Inline (Scan_Invocation_Relation_Line); 1556 -- Parse an invocation relation line and construct the corresponding 1557 -- relation. The following data structures are updated: 1558 -- 1559 -- * Invocation_Relations 1560 -- * Units 1561 1562 function Scan_Invocation_Signature return Invocation_Signature_Id; 1563 pragma Inline (Scan_Invocation_Signature); 1564 -- Parse a single invocation signature while populating the following 1565 -- data structures: 1566 -- 1567 -- * Invocation_Signatures 1568 -- * Sig_To_Sig_Map 1569 1570 ------------------------------------ 1571 -- Scan_Invocation_Construct_Line -- 1572 ------------------------------------ 1573 1574 procedure Scan_Invocation_Construct_Line is 1575 Body_Placement : Declaration_Placement_Kind; 1576 Kind : Invocation_Construct_Kind; 1577 Signature : Invocation_Signature_Id; 1578 Spec_Placement : Declaration_Placement_Kind; 1579 1580 begin 1581 -- construct-kind 1582 1583 Kind := Code_To_Invocation_Construct_Kind (Getc); 1584 Checkc (' '); 1585 Skip_Space; 1586 1587 -- construct-spec-placement 1588 1589 Spec_Placement := Code_To_Declaration_Placement_Kind (Getc); 1590 Checkc (' '); 1591 Skip_Space; 1592 1593 -- construct-body-placement 1594 1595 Body_Placement := Code_To_Declaration_Placement_Kind (Getc); 1596 Checkc (' '); 1597 Skip_Space; 1598 1599 -- construct-signature 1600 1601 Signature := Scan_Invocation_Signature; 1602 Skip_Eol; 1603 1604 Add_Invocation_Construct 1605 (Body_Placement => Body_Placement, 1606 Kind => Kind, 1607 Signature => Signature, 1608 Spec_Placement => Spec_Placement); 1609 end Scan_Invocation_Construct_Line; 1610 1611 ------------------------------------------- 1612 -- Scan_Invocation_Graph_Attributes_Line -- 1613 ------------------------------------------- 1614 1615 procedure Scan_Invocation_Graph_Attributes_Line is 1616 begin 1617 -- encoding-kind 1618 1619 Set_Invocation_Graph_Encoding 1620 (Code_To_Invocation_Graph_Encoding_Kind (Getc)); 1621 Skip_Eol; 1622 end Scan_Invocation_Graph_Attributes_Line; 1623 1624 ----------------------------------- 1625 -- Scan_Invocation_Relation_Line -- 1626 ----------------------------------- 1627 1628 procedure Scan_Invocation_Relation_Line is 1629 Extra : Name_Id; 1630 Invoker : Invocation_Signature_Id; 1631 Kind : Invocation_Kind; 1632 Target : Invocation_Signature_Id; 1633 1634 begin 1635 -- relation-kind 1636 1637 Kind := Code_To_Invocation_Kind (Getc); 1638 Checkc (' '); 1639 Skip_Space; 1640 1641 -- (extra-name | "none") 1642 1643 Extra := Get_Name; 1644 1645 if Extra = Name_None then 1646 Extra := No_Name; 1647 end if; 1648 1649 Checkc (' '); 1650 Skip_Space; 1651 1652 -- invoker-signature 1653 1654 Invoker := Scan_Invocation_Signature; 1655 Checkc (' '); 1656 Skip_Space; 1657 1658 -- target-signature 1659 1660 Target := Scan_Invocation_Signature; 1661 Skip_Eol; 1662 1663 Add_Invocation_Relation 1664 (Extra => Extra, 1665 Invoker => Invoker, 1666 Kind => Kind, 1667 Target => Target); 1668 end Scan_Invocation_Relation_Line; 1669 1670 ------------------------------- 1671 -- Scan_Invocation_Signature -- 1672 ------------------------------- 1673 1674 function Scan_Invocation_Signature return Invocation_Signature_Id is 1675 Column : Nat; 1676 Line : Nat; 1677 Locations : Name_Id; 1678 Name : Name_Id; 1679 Scope : Name_Id; 1680 1681 begin 1682 -- [ 1683 1684 Checkc ('['); 1685 1686 -- name 1687 1688 Name := Get_Name; 1689 Checkc (' '); 1690 Skip_Space; 1691 1692 -- scope 1693 1694 Scope := Get_Name; 1695 Checkc (' '); 1696 Skip_Space; 1697 1698 -- line 1699 1700 Line := Get_Nat; 1701 Checkc (' '); 1702 Skip_Space; 1703 1704 -- column 1705 1706 Column := Get_Nat; 1707 Checkc (' '); 1708 Skip_Space; 1709 1710 -- (locations | "none") 1711 1712 Locations := Get_Name; 1713 1714 if Locations = Name_None then 1715 Locations := No_Name; 1716 end if; 1717 1718 -- ] 1719 1720 Checkc (']'); 1721 1722 -- Create an invocation signature from the scanned attributes 1723 1724 return 1725 Invocation_Signature_Of 1726 (Column => Column, 1727 Line => Line, 1728 Locations => Locations, 1729 Name => Name, 1730 Scope => Scope); 1731 end Scan_Invocation_Signature; 1732 1733 -- Local variables 1734 1735 Line : Invocation_Graph_Line_Kind; 1736 1737 -- Start of processing for Scan_Invocation_Graph_Line 1738 1739 begin 1740 if Ignore ('G') then 1741 return; 1742 end if; 1743 1744 Checkc (' '); 1745 Skip_Space; 1746 1747 -- line-kind 1748 1749 Line := Code_To_Invocation_Graph_Line_Kind (Getc); 1750 Checkc (' '); 1751 Skip_Space; 1752 1753 -- line-attributes 1754 1755 case Line is 1756 when Invocation_Construct_Line => 1757 Scan_Invocation_Construct_Line; 1758 1759 when Invocation_Graph_Attributes_Line => 1760 Scan_Invocation_Graph_Attributes_Line; 1761 1762 when Invocation_Relation_Line => 1763 Scan_Invocation_Relation_Line; 1764 end case; 1765 end Scan_Invocation_Graph_Line; 1766 1767 -------------- 1768 -- Skip_Eol -- 1769 -------------- 1770 1771 procedure Skip_Eol is 1772 begin 1773 Skip_Space; 1774 1775 if not At_Eol then 1776 if Ignore_Errors then 1777 while not At_Eol loop 1778 P := P + 1; 1779 end loop; 1780 else 1781 Fatal_Error; 1782 end if; 1783 end if; 1784 1785 -- Loop to skip past blank lines (first time through skips this EOL) 1786 1787 while Nextc < ' ' and then Nextc /= EOF loop 1788 if Nextc = LF then 1789 Line := Line + 1; 1790 end if; 1791 1792 P := P + 1; 1793 end loop; 1794 end Skip_Eol; 1795 1796 --------------- 1797 -- Skip_Line -- 1798 --------------- 1799 1800 procedure Skip_Line is 1801 begin 1802 while not At_Eol loop 1803 P := P + 1; 1804 end loop; 1805 1806 Skip_Eol; 1807 end Skip_Line; 1808 1809 ---------------- 1810 -- Skip_Space -- 1811 ---------------- 1812 1813 procedure Skip_Space is 1814 begin 1815 while Nextc = ' ' or else Nextc = HT loop 1816 P := P + 1; 1817 end loop; 1818 end Skip_Space; 1819 1820 ----------- 1821 -- Skipc -- 1822 ----------- 1823 1824 procedure Skipc is 1825 begin 1826 if P /= T'Last then 1827 P := P + 1; 1828 end if; 1829 end Skipc; 1830 1831 -- Start of processing for Scan_ALI 1832 1833 begin 1834 First_Sdep_Entry := Sdep.Last + 1; 1835 1836 -- Acquire lines to be ignored 1837 1838 if Read_Xref then 1839 Ignore := 1840 ('T' | 'U' | 'W' | 'Y' | 'Z' | 'D' | 'X' => False, others => True); 1841 1842 -- Read_Lines parameter given 1843 1844 elsif Read_Lines /= "" then 1845 Ignore := ('U' => False, others => True); 1846 1847 for J in Read_Lines'Range loop 1848 Ignore (Read_Lines (J)) := False; 1849 end loop; 1850 1851 -- Process Ignore_Lines parameter 1852 1853 else 1854 Ignore := (others => False); 1855 1856 for J in Ignore_Lines'Range loop 1857 pragma Assert (Ignore_Lines (J) /= 'U'); 1858 Ignore (Ignore_Lines (J)) := True; 1859 end loop; 1860 end if; 1861 1862 -- Setup ALI Table entry with appropriate defaults 1863 1864 ALIs.Increment_Last; 1865 Id := ALIs.Last; 1866 Set_Name_Table_Int (F, Int (Id)); 1867 1868 ALIs.Table (Id) := ( 1869 Afile => F, 1870 Compile_Errors => False, 1871 First_Interrupt_State => Interrupt_States.Last + 1, 1872 First_Sdep => No_Sdep_Id, 1873 First_Specific_Dispatching => Specific_Dispatching.Last + 1, 1874 First_Unit => No_Unit_Id, 1875 GNATprove_Mode => False, 1876 Invocation_Graph_Encoding => No_Encoding, 1877 Last_Interrupt_State => Interrupt_States.Last, 1878 Last_Sdep => No_Sdep_Id, 1879 Last_Specific_Dispatching => Specific_Dispatching.Last, 1880 Last_Unit => No_Unit_Id, 1881 Locking_Policy => ' ', 1882 Main_Priority => -1, 1883 Main_CPU => -1, 1884 Main_Program => None, 1885 No_Component_Reordering => False, 1886 No_Object => False, 1887 Normalize_Scalars => False, 1888 Ofile_Full_Name => Full_Object_File_Name, 1889 Partition_Elaboration_Policy => ' ', 1890 Queuing_Policy => ' ', 1891 Restrictions => No_Restrictions, 1892 SAL_Interface => False, 1893 Sfile => No_File, 1894 SSO_Default => ' ', 1895 Task_Dispatching_Policy => ' ', 1896 Time_Slice_Value => -1, 1897 WC_Encoding => 'b', 1898 Unit_Exception_Table => False, 1899 Ver => (others => ' '), 1900 Ver_Len => 0, 1901 Frontend_Exceptions => False, 1902 Zero_Cost_Exceptions => False); 1903 1904 -- Now we acquire the input lines from the ALI file. Note that the 1905 -- convention in the following code is that as we enter each section, 1906 -- C is set to contain the first character of the following line. 1907 1908 C := Getc; 1909 Check_Unknown_Line; 1910 1911 -- Acquire library version 1912 1913 if C /= 'V' then 1914 1915 -- The V line missing really indicates trouble, most likely it 1916 -- means we don't have an ALI file at all, so here we give a 1917 -- fatal error even if we are in Ignore_Errors mode. 1918 1919 Fatal_Error; 1920 1921 elsif Ignore ('V') then 1922 Skip_Line; 1923 1924 else 1925 Checkc (' '); 1926 Skip_Space; 1927 Checkc ('"'); 1928 1929 for J in 1 .. Ver_Len_Max loop 1930 C := Getc; 1931 exit when C = '"'; 1932 ALIs.Table (Id).Ver (J) := C; 1933 ALIs.Table (Id).Ver_Len := J; 1934 end loop; 1935 1936 Skip_Eol; 1937 end if; 1938 1939 C := Getc; 1940 Check_Unknown_Line; 1941 1942 -- Acquire main program line if present 1943 1944 if C = 'M' then 1945 if Ignore ('M') then 1946 Skip_Line; 1947 1948 else 1949 Checkc (' '); 1950 Skip_Space; 1951 1952 C := Getc; 1953 1954 if C = 'F' then 1955 ALIs.Table (Id).Main_Program := Func; 1956 elsif C = 'P' then 1957 ALIs.Table (Id).Main_Program := Proc; 1958 else 1959 P := P - 1; 1960 Fatal_Error; 1961 end if; 1962 1963 Skip_Space; 1964 1965 if not At_Eol then 1966 if Nextc < 'A' then 1967 ALIs.Table (Id).Main_Priority := Get_Nat; 1968 end if; 1969 1970 Skip_Space; 1971 1972 if Nextc = 'T' then 1973 P := P + 1; 1974 Checkc ('='); 1975 ALIs.Table (Id).Time_Slice_Value := Get_Nat; 1976 end if; 1977 1978 Skip_Space; 1979 1980 if Nextc = 'C' then 1981 P := P + 1; 1982 Checkc ('='); 1983 ALIs.Table (Id).Main_CPU := Get_Nat; 1984 end if; 1985 1986 Skip_Space; 1987 1988 Checkc ('W'); 1989 Checkc ('='); 1990 ALIs.Table (Id).WC_Encoding := Getc; 1991 end if; 1992 1993 Skip_Eol; 1994 end if; 1995 1996 C := Getc; 1997 end if; 1998 1999 -- Acquire argument lines 2000 2001 First_Arg := Args.Last + 1; 2002 2003 A_Loop : loop 2004 Check_Unknown_Line; 2005 exit A_Loop when C /= 'A'; 2006 2007 if Ignore ('A') then 2008 Skip_Line; 2009 2010 else 2011 Checkc (' '); 2012 2013 -- Scan out argument 2014 2015 Name_Len := 0; 2016 while not At_Eol loop 2017 Add_Char_To_Name_Buffer (Getc); 2018 end loop; 2019 2020 -- If -fstack-check, record that it occurred. Note that an 2021 -- additional string parameter can be specified, in the form of 2022 -- -fstack-check={no|generic|specific}. "no" means no checking, 2023 -- "generic" means force the use of old-style checking, and 2024 -- "specific" means use the best checking method. 2025 2026 if Name_Len >= 13 2027 and then Name_Buffer (1 .. 13) = "-fstack-check" 2028 and then Name_Buffer (1 .. Name_Len) /= "-fstack-check=no" 2029 then 2030 Stack_Check_Switch_Set := True; 2031 end if; 2032 2033 -- Store the argument 2034 2035 Args.Increment_Last; 2036 Args.Table (Args.Last) := new String'(Name_Buffer (1 .. Name_Len)); 2037 2038 Skip_Eol; 2039 end if; 2040 2041 C := Getc; 2042 end loop A_Loop; 2043 2044 -- Acquire P line 2045 2046 Check_Unknown_Line; 2047 2048 while C /= 'P' loop 2049 if Ignore_Errors then 2050 if C = EOF then 2051 Fatal_Error; 2052 else 2053 Skip_Line; 2054 C := Nextc; 2055 end if; 2056 else 2057 Fatal_Error; 2058 end if; 2059 end loop; 2060 2061 if Ignore ('P') then 2062 Skip_Line; 2063 2064 -- Process P line 2065 2066 else 2067 NS_Found := False; 2068 2069 while not At_Eol loop 2070 Checkc (' '); 2071 Skip_Space; 2072 C := Getc; 2073 2074 -- Processing for CE 2075 2076 if C = 'C' then 2077 Checkc ('E'); 2078 ALIs.Table (Id).Compile_Errors := True; 2079 2080 -- Processing for DB 2081 2082 elsif C = 'D' then 2083 Checkc ('B'); 2084 Detect_Blocking := True; 2085 2086 -- Processing for Ex 2087 2088 elsif C = 'E' then 2089 Partition_Elaboration_Policy_Specified := Getc; 2090 ALIs.Table (Id).Partition_Elaboration_Policy := 2091 Partition_Elaboration_Policy_Specified; 2092 2093 -- Processing for FX 2094 2095 elsif C = 'F' then 2096 C := Getc; 2097 2098 if C = 'X' then 2099 ALIs.Table (Id).Frontend_Exceptions := True; 2100 Frontend_Exceptions_Specified := True; 2101 else 2102 Fatal_Error_Ignore; 2103 end if; 2104 2105 -- Processing for GP 2106 2107 elsif C = 'G' then 2108 Checkc ('P'); 2109 GNATprove_Mode_Specified := True; 2110 ALIs.Table (Id).GNATprove_Mode := True; 2111 2112 -- Processing for Lx 2113 2114 elsif C = 'L' then 2115 Locking_Policy_Specified := Getc; 2116 ALIs.Table (Id).Locking_Policy := Locking_Policy_Specified; 2117 2118 -- Processing for flags starting with N 2119 2120 elsif C = 'N' then 2121 C := Getc; 2122 2123 -- Processing for NC 2124 2125 if C = 'C' then 2126 ALIs.Table (Id).No_Component_Reordering := True; 2127 No_Component_Reordering_Specified := True; 2128 2129 -- Processing for NO 2130 2131 elsif C = 'O' then 2132 ALIs.Table (Id).No_Object := True; 2133 No_Object_Specified := True; 2134 2135 -- Processing for NR 2136 2137 elsif C = 'R' then 2138 No_Run_Time_Mode := True; 2139 Configurable_Run_Time_Mode := True; 2140 2141 -- Processing for NS 2142 2143 elsif C = 'S' then 2144 ALIs.Table (Id).Normalize_Scalars := True; 2145 Normalize_Scalars_Specified := True; 2146 NS_Found := True; 2147 2148 -- Invalid switch starting with N 2149 2150 else 2151 Fatal_Error_Ignore; 2152 end if; 2153 2154 -- Processing for OH/OL 2155 2156 elsif C = 'O' then 2157 C := Getc; 2158 2159 if C = 'L' or else C = 'H' then 2160 ALIs.Table (Id).SSO_Default := C; 2161 SSO_Default_Specified := True; 2162 2163 else 2164 Fatal_Error_Ignore; 2165 end if; 2166 2167 -- Processing for Qx 2168 2169 elsif C = 'Q' then 2170 Queuing_Policy_Specified := Getc; 2171 ALIs.Table (Id).Queuing_Policy := Queuing_Policy_Specified; 2172 2173 -- Processing for flags starting with S 2174 2175 elsif C = 'S' then 2176 C := Getc; 2177 2178 -- Processing for SL 2179 2180 if C = 'L' then 2181 ALIs.Table (Id).SAL_Interface := True; 2182 2183 -- Processing for SS 2184 2185 elsif C = 'S' then 2186 Opt.Sec_Stack_Used := True; 2187 2188 -- Invalid switch starting with S 2189 2190 else 2191 Fatal_Error_Ignore; 2192 end if; 2193 2194 -- Processing for Tx 2195 2196 elsif C = 'T' then 2197 Task_Dispatching_Policy_Specified := Getc; 2198 ALIs.Table (Id).Task_Dispatching_Policy := 2199 Task_Dispatching_Policy_Specified; 2200 2201 -- Processing for switch starting with U 2202 2203 elsif C = 'U' then 2204 C := Getc; 2205 2206 -- Processing for UA 2207 2208 if C = 'A' then 2209 Unreserve_All_Interrupts_Specified := True; 2210 2211 -- Processing for UX 2212 2213 elsif C = 'X' then 2214 ALIs.Table (Id).Unit_Exception_Table := True; 2215 2216 -- Invalid switches starting with U 2217 2218 else 2219 Fatal_Error_Ignore; 2220 end if; 2221 2222 -- Processing for ZX 2223 2224 elsif C = 'Z' then 2225 C := Getc; 2226 2227 if C = 'X' then 2228 ALIs.Table (Id).Zero_Cost_Exceptions := True; 2229 Zero_Cost_Exceptions_Specified := True; 2230 else 2231 Fatal_Error_Ignore; 2232 end if; 2233 2234 -- Invalid parameter 2235 2236 else 2237 C := Getc; 2238 Fatal_Error_Ignore; 2239 end if; 2240 end loop; 2241 2242 if not NS_Found then 2243 No_Normalize_Scalars_Specified := True; 2244 end if; 2245 2246 Skip_Eol; 2247 end if; 2248 2249 C := Getc; 2250 Check_Unknown_Line; 2251 2252 -- Loop to skip to first restrictions line 2253 2254 while C /= 'R' loop 2255 if Ignore_Errors then 2256 if C = EOF then 2257 Fatal_Error; 2258 else 2259 Skip_Line; 2260 C := Nextc; 2261 end if; 2262 else 2263 Fatal_Error; 2264 end if; 2265 end loop; 2266 2267 -- Ignore all 'R' lines if that is required 2268 2269 if Ignore ('R') then 2270 while C = 'R' loop 2271 Skip_Line; 2272 C := Getc; 2273 end loop; 2274 2275 -- Here we process the restrictions lines (other than unit name cases) 2276 2277 else 2278 Scan_Restrictions : declare 2279 Save_R : constant Restrictions_Info := Cumulative_Restrictions; 2280 -- Save cumulative restrictions in case we have a fatal error 2281 2282 Bad_R_Line : exception; 2283 -- Signal bad restrictions line (raised on unexpected character) 2284 2285 Typ : Character; 2286 R : Restriction_Id; 2287 N : Natural; 2288 2289 begin 2290 -- Named restriction case 2291 2292 if Nextc = 'N' then 2293 Skip_Line; 2294 C := Getc; 2295 2296 -- Loop through RR and RV lines 2297 2298 while C = 'R' and then Nextc /= ' ' loop 2299 Typ := Getc; 2300 Checkc (' '); 2301 2302 -- Acquire restriction name 2303 2304 Name_Len := 0; 2305 while not At_Eol and then Nextc /= '=' loop 2306 Name_Len := Name_Len + 1; 2307 Name_Buffer (Name_Len) := Getc; 2308 end loop; 2309 2310 -- Now search list of restrictions to find match 2311 2312 declare 2313 RN : String renames Name_Buffer (1 .. Name_Len); 2314 2315 begin 2316 R := Restriction_Id'First; 2317 while R /= Not_A_Restriction_Id loop 2318 if Restriction_Id'Image (R) = RN then 2319 goto R_Found; 2320 end if; 2321 2322 R := Restriction_Id'Succ (R); 2323 end loop; 2324 2325 -- We don't recognize the restriction. This might be 2326 -- thought of as an error, and it really is, but we 2327 -- want to allow building with inconsistent versions 2328 -- of the binder and ali files (see comments at the 2329 -- start of package System.Rident), so we just ignore 2330 -- this situation. 2331 2332 goto Done_With_Restriction_Line; 2333 end; 2334 2335 <<R_Found>> 2336 2337 case R is 2338 2339 -- Boolean restriction case 2340 2341 when All_Boolean_Restrictions => 2342 case Typ is 2343 when 'V' => 2344 ALIs.Table (Id).Restrictions.Violated (R) := 2345 True; 2346 Cumulative_Restrictions.Violated (R) := True; 2347 2348 when 'R' => 2349 ALIs.Table (Id).Restrictions.Set (R) := True; 2350 Cumulative_Restrictions.Set (R) := True; 2351 2352 when others => 2353 raise Bad_R_Line; 2354 end case; 2355 2356 -- Parameter restriction case 2357 2358 when All_Parameter_Restrictions => 2359 if At_Eol or else Nextc /= '=' then 2360 raise Bad_R_Line; 2361 else 2362 Skipc; 2363 end if; 2364 2365 N := Natural (Get_Nat); 2366 2367 case Typ is 2368 2369 -- Restriction set 2370 2371 when 'R' => 2372 ALIs.Table (Id).Restrictions.Set (R) := True; 2373 ALIs.Table (Id).Restrictions.Value (R) := N; 2374 2375 if Cumulative_Restrictions.Set (R) then 2376 Cumulative_Restrictions.Value (R) := 2377 Integer'Min 2378 (Cumulative_Restrictions.Value (R), N); 2379 else 2380 Cumulative_Restrictions.Set (R) := True; 2381 Cumulative_Restrictions.Value (R) := N; 2382 end if; 2383 2384 -- Restriction violated 2385 2386 when 'V' => 2387 ALIs.Table (Id).Restrictions.Violated (R) := 2388 True; 2389 Cumulative_Restrictions.Violated (R) := True; 2390 ALIs.Table (Id).Restrictions.Count (R) := N; 2391 2392 -- Checked Max_Parameter case 2393 2394 if R in Checked_Max_Parameter_Restrictions then 2395 Cumulative_Restrictions.Count (R) := 2396 Integer'Max 2397 (Cumulative_Restrictions.Count (R), N); 2398 2399 -- Other checked parameter cases 2400 2401 else 2402 declare 2403 pragma Unsuppress (Overflow_Check); 2404 2405 begin 2406 Cumulative_Restrictions.Count (R) := 2407 Cumulative_Restrictions.Count (R) + N; 2408 2409 exception 2410 when Constraint_Error => 2411 2412 -- A constraint error comes from the 2413 -- addition. We reset to the maximum 2414 -- and indicate that the real value 2415 -- is now unknown. 2416 2417 Cumulative_Restrictions.Value (R) := 2418 Integer'Last; 2419 Cumulative_Restrictions.Unknown (R) := 2420 True; 2421 end; 2422 end if; 2423 2424 -- Deal with + case 2425 2426 if Nextc = '+' then 2427 Skipc; 2428 ALIs.Table (Id).Restrictions.Unknown (R) := 2429 True; 2430 Cumulative_Restrictions.Unknown (R) := True; 2431 end if; 2432 2433 -- Other than 'R' or 'V' 2434 2435 when others => 2436 raise Bad_R_Line; 2437 end case; 2438 2439 if not At_Eol then 2440 raise Bad_R_Line; 2441 end if; 2442 2443 -- Bizarre error case NOT_A_RESTRICTION 2444 2445 when Not_A_Restriction_Id => 2446 raise Bad_R_Line; 2447 end case; 2448 2449 if not At_Eol then 2450 raise Bad_R_Line; 2451 end if; 2452 2453 <<Done_With_Restriction_Line>> 2454 Skip_Line; 2455 C := Getc; 2456 end loop; 2457 2458 -- Positional restriction case 2459 2460 else 2461 Checkc (' '); 2462 Skip_Space; 2463 2464 -- Acquire information for boolean restrictions 2465 2466 for R in All_Boolean_Restrictions loop 2467 C := Getc; 2468 2469 case C is 2470 when 'v' => 2471 ALIs.Table (Id).Restrictions.Violated (R) := True; 2472 Cumulative_Restrictions.Violated (R) := True; 2473 2474 when 'r' => 2475 ALIs.Table (Id).Restrictions.Set (R) := True; 2476 Cumulative_Restrictions.Set (R) := True; 2477 2478 when 'n' => 2479 null; 2480 2481 when others => 2482 raise Bad_R_Line; 2483 end case; 2484 end loop; 2485 2486 -- Acquire information for parameter restrictions 2487 2488 for RP in All_Parameter_Restrictions loop 2489 case Getc is 2490 when 'n' => 2491 null; 2492 2493 when 'r' => 2494 ALIs.Table (Id).Restrictions.Set (RP) := True; 2495 2496 declare 2497 N : constant Integer := Integer (Get_Nat); 2498 begin 2499 ALIs.Table (Id).Restrictions.Value (RP) := N; 2500 2501 if Cumulative_Restrictions.Set (RP) then 2502 Cumulative_Restrictions.Value (RP) := 2503 Integer'Min 2504 (Cumulative_Restrictions.Value (RP), N); 2505 else 2506 Cumulative_Restrictions.Set (RP) := True; 2507 Cumulative_Restrictions.Value (RP) := N; 2508 end if; 2509 end; 2510 2511 when others => 2512 raise Bad_R_Line; 2513 end case; 2514 2515 -- Acquire restrictions violations information 2516 2517 case Getc is 2518 2519 when 'n' => 2520 null; 2521 2522 when 'v' => 2523 ALIs.Table (Id).Restrictions.Violated (RP) := True; 2524 Cumulative_Restrictions.Violated (RP) := True; 2525 2526 declare 2527 N : constant Integer := Integer (Get_Nat); 2528 2529 begin 2530 ALIs.Table (Id).Restrictions.Count (RP) := N; 2531 2532 if RP in Checked_Max_Parameter_Restrictions then 2533 Cumulative_Restrictions.Count (RP) := 2534 Integer'Max 2535 (Cumulative_Restrictions.Count (RP), N); 2536 2537 else 2538 declare 2539 pragma Unsuppress (Overflow_Check); 2540 2541 begin 2542 Cumulative_Restrictions.Count (RP) := 2543 Cumulative_Restrictions.Count (RP) + N; 2544 2545 exception 2546 when Constraint_Error => 2547 2548 -- A constraint error comes from the add. We 2549 -- reset to the maximum and indicate that the 2550 -- real value is now unknown. 2551 2552 Cumulative_Restrictions.Value (RP) := 2553 Integer'Last; 2554 Cumulative_Restrictions.Unknown (RP) := True; 2555 end; 2556 end if; 2557 2558 if Nextc = '+' then 2559 Skipc; 2560 ALIs.Table (Id).Restrictions.Unknown (RP) := True; 2561 Cumulative_Restrictions.Unknown (RP) := True; 2562 end if; 2563 end; 2564 2565 when others => 2566 raise Bad_R_Line; 2567 end case; 2568 end loop; 2569 2570 if not At_Eol then 2571 raise Bad_R_Line; 2572 else 2573 Skip_Line; 2574 C := Getc; 2575 end if; 2576 end if; 2577 2578 -- Here if error during scanning of restrictions line 2579 2580 exception 2581 when Bad_R_Line => 2582 2583 -- In Ignore_Errors mode, undo any changes to restrictions 2584 -- from this unit, and continue on, skipping remaining R 2585 -- lines for this unit. 2586 2587 if Ignore_Errors then 2588 Cumulative_Restrictions := Save_R; 2589 ALIs.Table (Id).Restrictions := No_Restrictions; 2590 2591 loop 2592 Skip_Eol; 2593 C := Getc; 2594 exit when C /= 'R'; 2595 end loop; 2596 2597 -- In normal mode, this is a fatal error 2598 2599 else 2600 Fatal_Error; 2601 end if; 2602 end Scan_Restrictions; 2603 end if; 2604 2605 -- Acquire additional restrictions (No_Dependence) lines if present 2606 2607 while C = 'R' loop 2608 if Ignore ('R') then 2609 Skip_Line; 2610 else 2611 Skip_Space; 2612 No_Deps.Append ((Id, Get_Name)); 2613 Skip_Eol; 2614 end if; 2615 2616 C := Getc; 2617 end loop; 2618 2619 -- Acquire 'I' lines if present 2620 2621 Check_Unknown_Line; 2622 2623 while C = 'I' loop 2624 if Ignore ('I') then 2625 Skip_Line; 2626 2627 else 2628 declare 2629 Int_Num : Nat; 2630 I_State : Character; 2631 Line_No : Nat; 2632 2633 begin 2634 Int_Num := Get_Nat; 2635 Skip_Space; 2636 I_State := Getc; 2637 Line_No := Get_Nat; 2638 2639 Interrupt_States.Append ( 2640 (Interrupt_Id => Int_Num, 2641 Interrupt_State => I_State, 2642 IS_Pragma_Line => Line_No)); 2643 2644 ALIs.Table (Id).Last_Interrupt_State := Interrupt_States.Last; 2645 Skip_Eol; 2646 end; 2647 end if; 2648 2649 C := Getc; 2650 end loop; 2651 2652 -- Acquire 'S' lines if present 2653 2654 Check_Unknown_Line; 2655 2656 while C = 'S' loop 2657 if Ignore ('S') then 2658 Skip_Line; 2659 2660 else 2661 declare 2662 Policy : Character; 2663 First_Prio : Nat; 2664 Last_Prio : Nat; 2665 Line_No : Nat; 2666 2667 begin 2668 Checkc (' '); 2669 Skip_Space; 2670 2671 Policy := Getc; 2672 Skip_Space; 2673 First_Prio := Get_Nat; 2674 Last_Prio := Get_Nat; 2675 Line_No := Get_Nat; 2676 2677 Specific_Dispatching.Append ( 2678 (Dispatching_Policy => Policy, 2679 First_Priority => First_Prio, 2680 Last_Priority => Last_Prio, 2681 PSD_Pragma_Line => Line_No)); 2682 2683 ALIs.Table (Id).Last_Specific_Dispatching := 2684 Specific_Dispatching.Last; 2685 2686 Skip_Eol; 2687 end; 2688 end if; 2689 2690 C := Getc; 2691 end loop; 2692 2693 -- Loop to acquire unit entries 2694 2695 U_Loop : loop 2696 Check_Unknown_Line; 2697 exit U_Loop when C /= 'U'; 2698 2699 -- Note: as per spec, we never ignore U lines 2700 2701 Checkc (' '); 2702 Skip_Space; 2703 Units.Increment_Last; 2704 2705 if ALIs.Table (Id).First_Unit = No_Unit_Id then 2706 ALIs.Table (Id).First_Unit := Units.Last; 2707 end if; 2708 2709 declare 2710 UL : Unit_Record renames Units.Table (Units.Last); 2711 2712 begin 2713 UL.Uname := Get_Unit_Name; 2714 UL.Predefined := Is_Predefined_Unit; 2715 UL.Internal := Is_Internal_Unit; 2716 UL.My_ALI := Id; 2717 UL.Sfile := Get_File_Name (Lower => True); 2718 UL.Pure := False; 2719 UL.Preelab := False; 2720 UL.No_Elab := False; 2721 UL.Shared_Passive := False; 2722 UL.RCI := False; 2723 UL.Remote_Types := False; 2724 UL.Serious_Errors := False; 2725 UL.Has_RACW := False; 2726 UL.Init_Scalars := False; 2727 UL.Is_Generic := False; 2728 UL.Icasing := Mixed_Case; 2729 UL.Kcasing := All_Lower_Case; 2730 UL.Dynamic_Elab := False; 2731 UL.Elaborate_Body := False; 2732 UL.Set_Elab_Entity := False; 2733 UL.Version := "00000000"; 2734 UL.First_With := Withs.Last + 1; 2735 UL.First_Arg := First_Arg; 2736 UL.First_Invocation_Construct := Invocation_Constructs.Last + 1; 2737 UL.Last_Invocation_Construct := No_Invocation_Construct; 2738 UL.First_Invocation_Relation := Invocation_Relations.Last + 1; 2739 UL.Last_Invocation_Relation := No_Invocation_Relation; 2740 UL.Elab_Position := 0; 2741 UL.SAL_Interface := ALIs.Table (Id).SAL_Interface; 2742 UL.Directly_Scanned := Directly_Scanned; 2743 UL.Body_Needed_For_SAL := False; 2744 UL.Elaborate_Body_Desirable := False; 2745 UL.Optimize_Alignment := 'O'; 2746 UL.Has_Finalizer := False; 2747 UL.Primary_Stack_Count := 0; 2748 UL.Sec_Stack_Count := 0; 2749 2750 if Debug_Flag_U then 2751 Write_Str (" ----> reading unit "); 2752 Write_Int (Int (Units.Last)); 2753 Write_Str (" "); 2754 Write_Unit_Name (UL.Uname); 2755 Write_Str (" from file "); 2756 Write_Name (UL.Sfile); 2757 Write_Eol; 2758 end if; 2759 end; 2760 2761 -- Check for duplicated unit in different files 2762 2763 declare 2764 Info : constant Int := Get_Name_Table_Int 2765 (Units.Table (Units.Last).Uname); 2766 begin 2767 if Info /= 0 2768 and then Units.Table (Units.Last).Sfile /= 2769 Units.Table (Unit_Id (Info)).Sfile 2770 then 2771 -- If Err is set then ignore duplicate unit name. This is the 2772 -- case of a call from gnatmake, where the situation can arise 2773 -- from substitution of source files. In such situations, the 2774 -- processing in gnatmake will always result in any required 2775 -- recompilations in any case, and if we consider this to be 2776 -- an error we get strange cases (for example when a generic 2777 -- instantiation is replaced by a normal package) where we 2778 -- read the old ali file, decide to recompile, and then decide 2779 -- that the old and new ali files are incompatible. 2780 2781 if Err then 2782 null; 2783 2784 -- If Err is not set, then this is a fatal error. This is 2785 -- the case of being called from the binder, where we must 2786 -- definitely diagnose this as an error. 2787 2788 else 2789 Set_Standard_Error; 2790 Write_Str ("error: duplicate unit name: "); 2791 Write_Eol; 2792 2793 Write_Str ("error: unit """); 2794 Write_Unit_Name (Units.Table (Units.Last).Uname); 2795 Write_Str (""" found in file """); 2796 Write_Name_Decoded (Units.Table (Units.Last).Sfile); 2797 Write_Char ('"'); 2798 Write_Eol; 2799 2800 Write_Str ("error: unit """); 2801 Write_Unit_Name (Units.Table (Unit_Id (Info)).Uname); 2802 Write_Str (""" found in file """); 2803 Write_Name_Decoded (Units.Table (Unit_Id (Info)).Sfile); 2804 Write_Char ('"'); 2805 Write_Eol; 2806 2807 Exit_Program (E_Fatal); 2808 end if; 2809 end if; 2810 end; 2811 2812 Set_Name_Table_Int 2813 (Units.Table (Units.Last).Uname, Int (Units.Last)); 2814 2815 -- Scan out possible version and other parameters 2816 2817 loop 2818 Skip_Space; 2819 exit when At_Eol; 2820 C := Getc; 2821 2822 -- Version field 2823 2824 if C in '0' .. '9' or else C in 'a' .. 'f' then 2825 Units.Table (Units.Last).Version (1) := C; 2826 2827 for J in 2 .. 8 loop 2828 C := Getc; 2829 Units.Table (Units.Last).Version (J) := C; 2830 end loop; 2831 2832 -- BD/BN parameters 2833 2834 elsif C = 'B' then 2835 C := Getc; 2836 2837 if C = 'D' then 2838 Check_At_End_Of_Field; 2839 Units.Table (Units.Last).Elaborate_Body_Desirable := True; 2840 2841 elsif C = 'N' then 2842 Check_At_End_Of_Field; 2843 Units.Table (Units.Last).Body_Needed_For_SAL := True; 2844 2845 else 2846 Fatal_Error_Ignore; 2847 end if; 2848 2849 -- DE parameter (Dynamic elaboration checks) 2850 2851 elsif C = 'D' then 2852 C := Getc; 2853 2854 if C = 'E' then 2855 Check_At_End_Of_Field; 2856 Units.Table (Units.Last).Dynamic_Elab := True; 2857 Dynamic_Elaboration_Checks_Specified := True; 2858 else 2859 Fatal_Error_Ignore; 2860 end if; 2861 2862 -- EB/EE parameters 2863 2864 elsif C = 'E' then 2865 C := Getc; 2866 2867 if C = 'B' then 2868 Units.Table (Units.Last).Elaborate_Body := True; 2869 elsif C = 'E' then 2870 Units.Table (Units.Last).Set_Elab_Entity := True; 2871 else 2872 Fatal_Error_Ignore; 2873 end if; 2874 2875 Check_At_End_Of_Field; 2876 2877 -- GE parameter (generic) 2878 2879 elsif C = 'G' then 2880 C := Getc; 2881 2882 if C = 'E' then 2883 Check_At_End_Of_Field; 2884 Units.Table (Units.Last).Is_Generic := True; 2885 else 2886 Fatal_Error_Ignore; 2887 end if; 2888 2889 -- IL/IS/IU parameters 2890 2891 elsif C = 'I' then 2892 C := Getc; 2893 2894 if C = 'L' then 2895 Units.Table (Units.Last).Icasing := All_Lower_Case; 2896 elsif C = 'S' then 2897 Units.Table (Units.Last).Init_Scalars := True; 2898 Initialize_Scalars_Used := True; 2899 elsif C = 'U' then 2900 Units.Table (Units.Last).Icasing := All_Upper_Case; 2901 else 2902 Fatal_Error_Ignore; 2903 end if; 2904 2905 Check_At_End_Of_Field; 2906 2907 -- KM/KU parameters 2908 2909 elsif C = 'K' then 2910 C := Getc; 2911 2912 if C = 'M' then 2913 Units.Table (Units.Last).Kcasing := Mixed_Case; 2914 elsif C = 'U' then 2915 Units.Table (Units.Last).Kcasing := All_Upper_Case; 2916 else 2917 Fatal_Error_Ignore; 2918 end if; 2919 2920 Check_At_End_Of_Field; 2921 2922 -- NE parameter 2923 2924 elsif C = 'N' then 2925 C := Getc; 2926 2927 if C = 'E' then 2928 Units.Table (Units.Last).No_Elab := True; 2929 Check_At_End_Of_Field; 2930 else 2931 Fatal_Error_Ignore; 2932 end if; 2933 2934 -- PF/PR/PU/PK parameters 2935 2936 elsif C = 'P' then 2937 C := Getc; 2938 2939 if C = 'F' then 2940 Units.Table (Units.Last).Has_Finalizer := True; 2941 elsif C = 'R' then 2942 Units.Table (Units.Last).Preelab := True; 2943 elsif C = 'U' then 2944 Units.Table (Units.Last).Pure := True; 2945 elsif C = 'K' then 2946 Units.Table (Units.Last).Unit_Kind := 'p'; 2947 else 2948 Fatal_Error_Ignore; 2949 end if; 2950 2951 Check_At_End_Of_Field; 2952 2953 -- OL/OO/OS/OT parameters 2954 2955 elsif C = 'O' then 2956 C := Getc; 2957 2958 if C = 'L' or else C = 'O' or else C = 'S' or else C = 'T' then 2959 Units.Table (Units.Last).Optimize_Alignment := C; 2960 else 2961 Fatal_Error_Ignore; 2962 end if; 2963 2964 Check_At_End_Of_Field; 2965 2966 -- RC/RT parameters 2967 2968 elsif C = 'R' then 2969 C := Getc; 2970 2971 if C = 'C' then 2972 Units.Table (Units.Last).RCI := True; 2973 elsif C = 'T' then 2974 Units.Table (Units.Last).Remote_Types := True; 2975 elsif C = 'A' then 2976 Units.Table (Units.Last).Has_RACW := True; 2977 else 2978 Fatal_Error_Ignore; 2979 end if; 2980 2981 Check_At_End_Of_Field; 2982 2983 -- SE/SP/SU parameters 2984 2985 elsif C = 'S' then 2986 C := Getc; 2987 2988 if C = 'E' then 2989 Units.Table (Units.Last).Serious_Errors := True; 2990 elsif C = 'P' then 2991 Units.Table (Units.Last).Shared_Passive := True; 2992 elsif C = 'U' then 2993 Units.Table (Units.Last).Unit_Kind := 's'; 2994 else 2995 Fatal_Error_Ignore; 2996 end if; 2997 2998 Check_At_End_Of_Field; 2999 3000 else 3001 C := Getc; 3002 Fatal_Error_Ignore; 3003 end if; 3004 end loop; 3005 3006 Skip_Eol; 3007 3008 C := Getc; 3009 3010 -- Scan out With lines for this unit 3011 3012 With_Loop : loop 3013 Check_Unknown_Line; 3014 exit With_Loop when C /= 'W' and then C /= 'Y' and then C /= 'Z'; 3015 3016 if Ignore ('W') then 3017 Skip_Line; 3018 3019 else 3020 Checkc (' '); 3021 Skip_Space; 3022 Withs.Increment_Last; 3023 Withs.Table (Withs.Last).Uname := Get_Unit_Name; 3024 Withs.Table (Withs.Last).Elaborate := False; 3025 Withs.Table (Withs.Last).Elaborate_All := False; 3026 Withs.Table (Withs.Last).Elab_Desirable := False; 3027 Withs.Table (Withs.Last).Elab_All_Desirable := False; 3028 Withs.Table (Withs.Last).SAL_Interface := False; 3029 Withs.Table (Withs.Last).Limited_With := (C = 'Y'); 3030 Withs.Table (Withs.Last).Implicit_With := (C = 'Z'); 3031 3032 -- Generic case with no object file available 3033 3034 if At_Eol then 3035 Withs.Table (Withs.Last).Sfile := No_File; 3036 Withs.Table (Withs.Last).Afile := No_File; 3037 3038 -- Normal case 3039 3040 else 3041 Withs.Table (Withs.Last).Sfile := Get_File_Name 3042 (Lower => True); 3043 Withs.Table (Withs.Last).Afile := Get_File_Name 3044 (Lower => True); 3045 3046 -- Scan out possible E, EA, ED, and AD parameters 3047 3048 while not At_Eol loop 3049 Skip_Space; 3050 3051 if Nextc = 'A' then 3052 P := P + 1; 3053 Checkc ('D'); 3054 Check_At_End_Of_Field; 3055 3056 -- Store AD indication unless ignore required 3057 3058 if not Ignore_ED then 3059 Withs.Table (Withs.Last).Elab_All_Desirable := True; 3060 end if; 3061 3062 elsif Nextc = 'E' then 3063 P := P + 1; 3064 3065 if At_End_Of_Field then 3066 Withs.Table (Withs.Last).Elaborate := True; 3067 3068 elsif Nextc = 'A' then 3069 P := P + 1; 3070 Check_At_End_Of_Field; 3071 Withs.Table (Withs.Last).Elaborate_All := True; 3072 3073 else 3074 Checkc ('D'); 3075 Check_At_End_Of_Field; 3076 3077 -- Store ED indication unless ignore required 3078 3079 if not Ignore_ED then 3080 Withs.Table (Withs.Last).Elab_Desirable := 3081 True; 3082 end if; 3083 end if; 3084 3085 else 3086 Fatal_Error; 3087 end if; 3088 end loop; 3089 end if; 3090 3091 Skip_Eol; 3092 end if; 3093 3094 C := Getc; 3095 end loop With_Loop; 3096 3097 Units.Table (Units.Last).Last_With := Withs.Last; 3098 Units.Table (Units.Last).Last_Arg := Args.Last; 3099 3100 -- Scan out task stack information for the unit if present 3101 3102 Check_Unknown_Line; 3103 3104 if C = 'T' then 3105 if Ignore ('T') then 3106 Skip_Line; 3107 3108 else 3109 Checkc (' '); 3110 Skip_Space; 3111 3112 Units.Table (Units.Last).Primary_Stack_Count := Get_Nat; 3113 Skip_Space; 3114 Units.Table (Units.Last).Sec_Stack_Count := Get_Nat; 3115 Skip_Space; 3116 Skip_Eol; 3117 end if; 3118 3119 C := Getc; 3120 end if; 3121 3122 -- If there are linker options lines present, scan them 3123 3124 Name_Len := 0; 3125 3126 Linker_Options_Loop : loop 3127 Check_Unknown_Line; 3128 exit Linker_Options_Loop when C /= 'L'; 3129 3130 if Ignore ('L') then 3131 Skip_Line; 3132 3133 else 3134 Checkc (' '); 3135 Skip_Space; 3136 Checkc ('"'); 3137 3138 loop 3139 C := Getc; 3140 3141 if C < Character'Val (16#20#) 3142 or else C > Character'Val (16#7E#) 3143 then 3144 Fatal_Error_Ignore; 3145 3146 elsif C = '{' then 3147 C := Character'Val (0); 3148 3149 declare 3150 V : Natural; 3151 3152 begin 3153 V := 0; 3154 for J in 1 .. 2 loop 3155 C := Getc; 3156 3157 if C in '0' .. '9' then 3158 V := V * 16 + 3159 Character'Pos (C) - 3160 Character'Pos ('0'); 3161 3162 elsif C in 'A' .. 'F' then 3163 V := V * 16 + 3164 Character'Pos (C) - 3165 Character'Pos ('A') + 3166 10; 3167 3168 else 3169 Fatal_Error_Ignore; 3170 end if; 3171 end loop; 3172 3173 Checkc ('}'); 3174 Add_Char_To_Name_Buffer (Character'Val (V)); 3175 end; 3176 3177 else 3178 if C = '"' then 3179 exit when Nextc /= '"'; 3180 C := Getc; 3181 end if; 3182 3183 Add_Char_To_Name_Buffer (C); 3184 end if; 3185 end loop; 3186 3187 Add_Char_To_Name_Buffer (NUL); 3188 Skip_Eol; 3189 end if; 3190 3191 C := Getc; 3192 end loop Linker_Options_Loop; 3193 3194 -- Store the linker options entry if one was found 3195 3196 if Name_Len /= 0 then 3197 Linker_Options.Increment_Last; 3198 3199 Linker_Options.Table (Linker_Options.Last).Name := 3200 Name_Enter; 3201 3202 Linker_Options.Table (Linker_Options.Last).Unit := 3203 Units.Last; 3204 3205 Linker_Options.Table (Linker_Options.Last).Internal_File := 3206 Is_Internal_File_Name (F); 3207 end if; 3208 3209 -- If there are notes present, scan them 3210 3211 Notes_Loop : loop 3212 Check_Unknown_Line; 3213 exit Notes_Loop when C /= 'N'; 3214 3215 if Ignore ('N') then 3216 Skip_Line; 3217 3218 else 3219 Checkc (' '); 3220 3221 Notes.Increment_Last; 3222 Notes.Table (Notes.Last).Pragma_Type := Getc; 3223 Notes.Table (Notes.Last).Pragma_Line := Get_Nat; 3224 Checkc (':'); 3225 Notes.Table (Notes.Last).Pragma_Col := Get_Nat; 3226 3227 if not At_Eol and then Nextc = ':' then 3228 Checkc (':'); 3229 Notes.Table (Notes.Last).Pragma_Source_File := 3230 Get_File_Name (Lower => True); 3231 else 3232 Notes.Table (Notes.Last).Pragma_Source_File := 3233 Units.Table (Units.Last).Sfile; 3234 end if; 3235 3236 if At_Eol then 3237 Notes.Table (Notes.Last).Pragma_Args := No_Name; 3238 3239 else 3240 -- Note: can't use Get_Name here as the remainder of the 3241 -- line is unstructured text whose syntax depends on the 3242 -- particular pragma used. 3243 3244 Checkc (' '); 3245 3246 Name_Len := 0; 3247 while not At_Eol loop 3248 Add_Char_To_Name_Buffer (Getc); 3249 end loop; 3250 end if; 3251 3252 Skip_Eol; 3253 end if; 3254 3255 C := Getc; 3256 end loop Notes_Loop; 3257 end loop U_Loop; 3258 3259 -- End loop through units for one ALI file 3260 3261 ALIs.Table (Id).Last_Unit := Units.Last; 3262 ALIs.Table (Id).Sfile := Units.Table (ALIs.Table (Id).First_Unit).Sfile; 3263 3264 -- Set types of the units (there can be at most 2 of them) 3265 3266 if ALIs.Table (Id).First_Unit /= ALIs.Table (Id).Last_Unit then 3267 Units.Table (ALIs.Table (Id).First_Unit).Utype := Is_Body; 3268 Units.Table (ALIs.Table (Id).Last_Unit).Utype := Is_Spec; 3269 3270 else 3271 -- Deal with body only and spec only cases, note that the reason we 3272 -- do our own checking of the name (rather than using Is_Body_Name) 3273 -- is that Uname drags in far too much compiler junk. 3274 3275 Get_Name_String (Units.Table (Units.Last).Uname); 3276 3277 if Name_Buffer (Name_Len) = 'b' then 3278 Units.Table (Units.Last).Utype := Is_Body_Only; 3279 else 3280 Units.Table (Units.Last).Utype := Is_Spec_Only; 3281 end if; 3282 end if; 3283 3284 -- Scan out external version references and put in hash table 3285 3286 E_Loop : loop 3287 Check_Unknown_Line; 3288 exit E_Loop when C /= 'E'; 3289 3290 if Ignore ('E') then 3291 Skip_Line; 3292 3293 else 3294 Checkc (' '); 3295 Skip_Space; 3296 3297 Name_Len := 0; 3298 Name_Len := 0; 3299 loop 3300 C := Getc; 3301 3302 if C < ' ' then 3303 Fatal_Error; 3304 end if; 3305 3306 exit when At_End_Of_Field; 3307 Add_Char_To_Name_Buffer (C); 3308 end loop; 3309 3310 Version_Ref.Set (new String'(Name_Buffer (1 .. Name_Len)), True); 3311 Skip_Eol; 3312 end if; 3313 3314 C := Getc; 3315 end loop E_Loop; 3316 3317 -- Scan out source dependency lines for this ALI file 3318 3319 ALIs.Table (Id).First_Sdep := Sdep.Last + 1; 3320 3321 D_Loop : loop 3322 Check_Unknown_Line; 3323 exit D_Loop when C /= 'D'; 3324 3325 if Ignore ('D') then 3326 Skip_Line; 3327 3328 else 3329 Checkc (' '); 3330 Skip_Space; 3331 Sdep.Increment_Last; 3332 3333 -- In the following call, Lower is not set to True, this is either 3334 -- a bug, or it deserves a special comment as to why this is so??? 3335 3336 -- The file/path name may be quoted 3337 3338 Sdep.Table (Sdep.Last).Sfile := 3339 Get_File_Name (May_Be_Quoted => True); 3340 3341 Sdep.Table (Sdep.Last).Stamp := Get_Stamp; 3342 Sdep.Table (Sdep.Last).Dummy_Entry := 3343 (Sdep.Table (Sdep.Last).Stamp = Dummy_Time_Stamp); 3344 3345 -- Acquire checksum value 3346 3347 Skip_Space; 3348 3349 declare 3350 Ctr : Natural; 3351 Chk : Word; 3352 3353 begin 3354 Ctr := 0; 3355 Chk := 0; 3356 3357 loop 3358 exit when At_Eol or else Ctr = 8; 3359 3360 if Nextc in '0' .. '9' then 3361 Chk := Chk * 16 + 3362 Character'Pos (Nextc) - Character'Pos ('0'); 3363 3364 elsif Nextc in 'a' .. 'f' then 3365 Chk := Chk * 16 + 3366 Character'Pos (Nextc) - Character'Pos ('a') + 10; 3367 3368 else 3369 exit; 3370 end if; 3371 3372 Ctr := Ctr + 1; 3373 P := P + 1; 3374 end loop; 3375 3376 if Ctr = 8 and then At_End_Of_Field then 3377 Sdep.Table (Sdep.Last).Checksum := Chk; 3378 else 3379 Fatal_Error; 3380 end if; 3381 end; 3382 3383 -- Acquire (sub)unit and reference file name entries 3384 3385 Sdep.Table (Sdep.Last).Subunit_Name := No_Name; 3386 Sdep.Table (Sdep.Last).Unit_Name := No_Name; 3387 Sdep.Table (Sdep.Last).Rfile := 3388 Sdep.Table (Sdep.Last).Sfile; 3389 Sdep.Table (Sdep.Last).Start_Line := 1; 3390 3391 if not At_Eol then 3392 Skip_Space; 3393 3394 -- Here for (sub)unit name 3395 3396 if Nextc not in '0' .. '9' then 3397 Name_Len := 0; 3398 while not At_End_Of_Field loop 3399 Add_Char_To_Name_Buffer (Getc); 3400 end loop; 3401 3402 -- Set the (sub)unit name. Note that we use Name_Find rather 3403 -- than Name_Enter here as the subunit name may already 3404 -- have been put in the name table by the Project Manager. 3405 3406 if Name_Len <= 2 3407 or else Name_Buffer (Name_Len - 1) /= '%' 3408 then 3409 Sdep.Table (Sdep.Last).Subunit_Name := Name_Find; 3410 else 3411 Name_Len := Name_Len - 2; 3412 Sdep.Table (Sdep.Last).Unit_Name := Name_Find; 3413 end if; 3414 3415 Skip_Space; 3416 end if; 3417 3418 -- Here for reference file name entry 3419 3420 if Nextc in '0' .. '9' then 3421 Sdep.Table (Sdep.Last).Start_Line := Get_Nat; 3422 Checkc (':'); 3423 3424 Name_Len := 0; 3425 3426 while not At_End_Of_Field loop 3427 Add_Char_To_Name_Buffer (Getc); 3428 end loop; 3429 3430 Sdep.Table (Sdep.Last).Rfile := Name_Enter; 3431 end if; 3432 end if; 3433 3434 Skip_Eol; 3435 end if; 3436 3437 C := Getc; 3438 end loop D_Loop; 3439 3440 ALIs.Table (Id).Last_Sdep := Sdep.Last; 3441 3442 -- Loop through invocation-graph lines 3443 3444 G_Loop : loop 3445 Check_Unknown_Line; 3446 exit G_Loop when C /= 'G'; 3447 3448 Scan_Invocation_Graph_Line; 3449 3450 C := Getc; 3451 end loop G_Loop; 3452 3453 -- We must at this stage be at an Xref line or the end of file 3454 3455 if C = EOF then 3456 return Id; 3457 end if; 3458 3459 Check_Unknown_Line; 3460 3461 if C /= 'X' then 3462 Fatal_Error; 3463 end if; 3464 3465 -- If we are ignoring Xref sections we are done (we ignore all 3466 -- remaining lines since only xref related lines follow X). 3467 3468 if Ignore ('X') and then not Debug_Flag_X then 3469 return Id; 3470 end if; 3471 3472 -- Loop through Xref sections 3473 3474 X_Loop : loop 3475 Check_Unknown_Line; 3476 exit X_Loop when C /= 'X'; 3477 3478 -- Make new entry in section table 3479 3480 Xref_Section.Increment_Last; 3481 3482 Read_Refs_For_One_File : declare 3483 XS : Xref_Section_Record renames 3484 Xref_Section.Table (Xref_Section.Last); 3485 3486 Current_File_Num : Sdep_Id; 3487 -- Keeps track of the current file number (changed by nn|) 3488 3489 begin 3490 XS.File_Num := Sdep_Id (Get_Nat + Nat (First_Sdep_Entry) - 1); 3491 XS.File_Name := Get_File_Name; 3492 XS.First_Entity := Xref_Entity.Last + 1; 3493 3494 Current_File_Num := XS.File_Num; 3495 3496 Skip_Space; 3497 3498 Skip_Eol; 3499 C := Nextc; 3500 3501 -- Loop through Xref entities 3502 3503 while C /= 'X' and then C /= EOF loop 3504 Xref_Entity.Increment_Last; 3505 3506 Read_Refs_For_One_Entity : declare 3507 XE : Xref_Entity_Record renames 3508 Xref_Entity.Table (Xref_Entity.Last); 3509 N : Nat; 3510 3511 procedure Read_Instantiation_Reference; 3512 -- Acquire instantiation reference. Caller has checked 3513 -- that current character is '[' and on return the cursor 3514 -- is skipped past the corresponding closing ']'. 3515 3516 ---------------------------------- 3517 -- Read_Instantiation_Reference -- 3518 ---------------------------------- 3519 3520 procedure Read_Instantiation_Reference is 3521 Local_File_Num : Sdep_Id := Current_File_Num; 3522 3523 begin 3524 Xref.Increment_Last; 3525 3526 declare 3527 XR : Xref_Record renames Xref.Table (Xref.Last); 3528 3529 begin 3530 P := P + 1; -- skip [ 3531 N := Get_Nat; 3532 3533 if Nextc = '|' then 3534 XR.File_Num := 3535 Sdep_Id (N + Nat (First_Sdep_Entry) - 1); 3536 Local_File_Num := XR.File_Num; 3537 P := P + 1; 3538 N := Get_Nat; 3539 3540 else 3541 XR.File_Num := Local_File_Num; 3542 end if; 3543 3544 XR.Line := N; 3545 XR.Rtype := ' '; 3546 XR.Col := 0; 3547 3548 -- Recursive call for next reference 3549 3550 if Nextc = '[' then 3551 pragma Warnings (Off); -- kill recursion warning 3552 Read_Instantiation_Reference; 3553 pragma Warnings (On); 3554 end if; 3555 3556 -- Skip closing bracket after recursive call 3557 3558 P := P + 1; 3559 end; 3560 end Read_Instantiation_Reference; 3561 3562 -- Start of processing for Read_Refs_For_One_Entity 3563 3564 begin 3565 XE.Line := Get_Nat; 3566 XE.Etype := Getc; 3567 XE.Col := Get_Nat; 3568 3569 case Getc is 3570 when '*' => 3571 XE.Visibility := Global; 3572 when '+' => 3573 XE.Visibility := Static; 3574 when others => 3575 XE.Visibility := Other; 3576 end case; 3577 3578 XE.Entity := Get_Name; 3579 3580 -- Handle the information about generic instantiations 3581 3582 if Nextc = '[' then 3583 Skipc; -- Opening '[' 3584 N := Get_Nat; 3585 3586 if Nextc /= '|' then 3587 XE.Iref_File_Num := Current_File_Num; 3588 XE.Iref_Line := N; 3589 else 3590 XE.Iref_File_Num := 3591 Sdep_Id (N + Nat (First_Sdep_Entry) - 1); 3592 Skipc; 3593 XE.Iref_Line := Get_Nat; 3594 end if; 3595 3596 if Getc /= ']' then 3597 Fatal_Error; 3598 end if; 3599 3600 else 3601 XE.Iref_File_Num := No_Sdep_Id; 3602 XE.Iref_Line := 0; 3603 end if; 3604 3605 Current_File_Num := XS.File_Num; 3606 3607 -- Renaming reference is present 3608 3609 if Nextc = '=' then 3610 P := P + 1; 3611 XE.Rref_Line := Get_Nat; 3612 3613 if Getc /= ':' then 3614 Fatal_Error; 3615 end if; 3616 3617 XE.Rref_Col := Get_Nat; 3618 3619 -- No renaming reference present 3620 3621 else 3622 XE.Rref_Line := 0; 3623 XE.Rref_Col := 0; 3624 end if; 3625 3626 Skip_Space; 3627 3628 XE.Oref_File_Num := No_Sdep_Id; 3629 XE.Tref_File_Num := No_Sdep_Id; 3630 XE.Tref := Tref_None; 3631 XE.First_Xref := Xref.Last + 1; 3632 3633 -- Loop to check for additional info present 3634 3635 loop 3636 declare 3637 Ref : Tref_Kind; 3638 File : Sdep_Id; 3639 Line : Nat; 3640 Typ : Character; 3641 Col : Nat; 3642 Std : Name_Id; 3643 3644 begin 3645 Get_Typeref 3646 (Current_File_Num, Ref, File, Line, Typ, Col, Std); 3647 exit when Ref = Tref_None; 3648 3649 -- Do we have an overriding procedure? 3650 3651 if Ref = Tref_Derived and then Typ = 'p' then 3652 XE.Oref_File_Num := File; 3653 XE.Oref_Line := Line; 3654 XE.Oref_Col := Col; 3655 3656 -- Arrays never override anything, and <> points to 3657 -- the index types instead 3658 3659 elsif Ref = Tref_Derived and then XE.Etype = 'A' then 3660 3661 -- Index types are stored in the list of references 3662 3663 Xref.Increment_Last; 3664 3665 declare 3666 XR : Xref_Record renames Xref.Table (Xref.Last); 3667 begin 3668 XR.File_Num := File; 3669 XR.Line := Line; 3670 XR.Rtype := Array_Index_Reference; 3671 XR.Col := Col; 3672 XR.Name := Std; 3673 end; 3674 3675 -- Interfaces are stored in the list of references, 3676 -- although the parent type itself is stored in XE. 3677 -- The first interface (when there are only 3678 -- interfaces) is stored in XE.Tref*) 3679 3680 elsif Ref = Tref_Derived 3681 and then Typ = 'R' 3682 and then XE.Tref_File_Num /= No_Sdep_Id 3683 then 3684 Xref.Increment_Last; 3685 3686 declare 3687 XR : Xref_Record renames Xref.Table (Xref.Last); 3688 begin 3689 XR.File_Num := File; 3690 XR.Line := Line; 3691 XR.Rtype := Interface_Reference; 3692 XR.Col := Col; 3693 XR.Name := Std; 3694 end; 3695 3696 else 3697 XE.Tref := Ref; 3698 XE.Tref_File_Num := File; 3699 XE.Tref_Line := Line; 3700 XE.Tref_Type := Typ; 3701 XE.Tref_Col := Col; 3702 XE.Tref_Standard_Entity := Std; 3703 end if; 3704 end; 3705 end loop; 3706 3707 -- Loop through cross-references for this entity 3708 3709 loop 3710 Skip_Space; 3711 3712 if At_Eol then 3713 Skip_Eol; 3714 exit when Nextc /= '.'; 3715 P := P + 1; 3716 end if; 3717 3718 Xref.Increment_Last; 3719 3720 declare 3721 XR : Xref_Record renames Xref.Table (Xref.Last); 3722 3723 begin 3724 N := Get_Nat; 3725 3726 if Nextc = '|' then 3727 XR.File_Num := 3728 Sdep_Id (N + Nat (First_Sdep_Entry) - 1); 3729 Current_File_Num := XR.File_Num; 3730 P := P + 1; 3731 N := Get_Nat; 3732 else 3733 XR.File_Num := Current_File_Num; 3734 end if; 3735 3736 XR.Line := N; 3737 XR.Rtype := Getc; 3738 3739 -- Imported entities reference as in: 3740 -- 494b<c,__gnat_copy_attribs>25 3741 3742 if Nextc = '<' then 3743 Skipc; 3744 XR.Imported_Lang := Get_Name; 3745 3746 pragma Assert (Nextc = ','); 3747 Skipc; 3748 3749 XR.Imported_Name := Get_Name; 3750 3751 pragma Assert (Nextc = '>'); 3752 Skipc; 3753 3754 else 3755 XR.Imported_Lang := No_Name; 3756 XR.Imported_Name := No_Name; 3757 end if; 3758 3759 XR.Col := Get_Nat; 3760 3761 if Nextc = '[' then 3762 Read_Instantiation_Reference; 3763 end if; 3764 end; 3765 end loop; 3766 3767 -- Record last cross-reference 3768 3769 XE.Last_Xref := Xref.Last; 3770 C := Nextc; 3771 3772 exception 3773 when Bad_ALI_Format => 3774 3775 -- If ignoring errors, then we skip a line with an 3776 -- unexpected error, and try to continue subsequent 3777 -- xref lines. 3778 3779 if Ignore_Errors then 3780 Xref_Entity.Decrement_Last; 3781 Skip_Line; 3782 C := Nextc; 3783 3784 -- Otherwise, we reraise the fatal exception 3785 3786 else 3787 raise; 3788 end if; 3789 end Read_Refs_For_One_Entity; 3790 end loop; 3791 3792 -- Record last entity 3793 3794 XS.Last_Entity := Xref_Entity.Last; 3795 end Read_Refs_For_One_File; 3796 3797 C := Getc; 3798 end loop X_Loop; 3799 3800 -- Here after dealing with xref sections 3801 3802 -- Ignore remaining lines, which belong to an additional section of the 3803 -- ALI file not considered here (like SCO or SPARK information). 3804 3805 Check_Unknown_Line; 3806 3807 return Id; 3808 3809 exception 3810 when Bad_ALI_Format => 3811 return No_ALI_Id; 3812 end Scan_ALI; 3813 3814 ----------- 3815 -- Scope -- 3816 ----------- 3817 3818 function Scope (IS_Id : Invocation_Signature_Id) return Name_Id is 3819 begin 3820 pragma Assert (Present (IS_Id)); 3821 return Invocation_Signatures.Table (IS_Id).Scope; 3822 end Scope; 3823 3824 --------- 3825 -- SEq -- 3826 --------- 3827 3828 function SEq (F1, F2 : String_Ptr) return Boolean is 3829 begin 3830 return F1.all = F2.all; 3831 end SEq; 3832 3833 ----------------------------------- 3834 -- Set_Invocation_Graph_Encoding -- 3835 ----------------------------------- 3836 3837 procedure Set_Invocation_Graph_Encoding 3838 (Kind : Invocation_Graph_Encoding_Kind; 3839 Update_Units : Boolean := True) 3840 is 3841 begin 3842 Compile_Time_Invocation_Graph_Encoding := Kind; 3843 3844 -- Update the invocation-graph encoding of the current unit only when 3845 -- requested by the caller. 3846 3847 if Update_Units then 3848 declare 3849 Curr_Unit : Unit_Record renames Units.Table (Units.Last); 3850 Curr_ALI : ALIs_Record renames ALIs.Table (Curr_Unit.My_ALI); 3851 3852 begin 3853 Curr_ALI.Invocation_Graph_Encoding := Kind; 3854 end; 3855 end if; 3856 end Set_Invocation_Graph_Encoding; 3857 3858 ----------- 3859 -- SHash -- 3860 ----------- 3861 3862 function SHash (S : String_Ptr) return Vindex is 3863 H : Word; 3864 3865 begin 3866 H := 0; 3867 for J in S.all'Range loop 3868 H := H * 2 + Character'Pos (S (J)); 3869 end loop; 3870 3871 return Vindex (Vindex'First + Vindex (H mod Vindex'Range_Length)); 3872 end SHash; 3873 3874 --------------- 3875 -- Signature -- 3876 --------------- 3877 3878 function Signature 3879 (IC_Id : Invocation_Construct_Id) return Invocation_Signature_Id 3880 is 3881 begin 3882 pragma Assert (Present (IC_Id)); 3883 return Invocation_Constructs.Table (IC_Id).Signature; 3884 end Signature; 3885 3886 -------------------- 3887 -- Spec_Placement -- 3888 -------------------- 3889 3890 function Spec_Placement 3891 (IC_Id : Invocation_Construct_Id) return Declaration_Placement_Kind 3892 is 3893 begin 3894 pragma Assert (Present (IC_Id)); 3895 return Invocation_Constructs.Table (IC_Id).Spec_Placement; 3896 end Spec_Placement; 3897 3898 ------------ 3899 -- Target -- 3900 ------------ 3901 3902 function Target 3903 (IR_Id : Invocation_Relation_Id) return Invocation_Signature_Id 3904 is 3905 begin 3906 pragma Assert (Present (IR_Id)); 3907 return Invocation_Relations.Table (IR_Id).Target; 3908 end Target; 3909 3910end ALI; 3911