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