1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- A L I -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1992-2015, 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; 32 33package body ALI is 34 35 use ASCII; 36 -- Make control characters visible 37 38 -- The following variable records which characters currently are 39 -- used as line type markers in the ALI file. This is used in 40 -- Scan_ALI to detect (or skip) invalid lines. 41 42 Known_ALI_Lines : constant array (Character range 'A' .. 'Z') of Boolean := 43 ('V' => True, -- version 44 'M' => True, -- main program 45 'A' => True, -- argument 46 'P' => True, -- program 47 'R' => True, -- restriction 48 'I' => True, -- interrupt 49 'U' => True, -- unit 50 'W' => True, -- with 51 'L' => True, -- linker option 52 'N' => True, -- notes 53 'E' => True, -- external 54 'D' => True, -- dependency 55 'X' => True, -- xref 56 'S' => True, -- specific dispatching 57 'Y' => True, -- limited_with 58 'Z' => True, -- implicit with from instantiation 59 'C' => True, -- SCO information 60 'F' => True, -- SPARK cross-reference information 61 others => False); 62 63 -------------------- 64 -- Initialize_ALI -- 65 -------------------- 66 67 procedure Initialize_ALI is 68 begin 69 -- When (re)initializing ALI data structures the ALI user expects to 70 -- get a fresh set of data structures. Thus we first need to erase the 71 -- marks put in the name table by the previous set of ALI routine calls. 72 -- These two loops are empty and harmless the first time in. 73 74 for J in ALIs.First .. ALIs.Last loop 75 Set_Name_Table_Int (ALIs.Table (J).Afile, 0); 76 end loop; 77 78 for J in Units.First .. Units.Last loop 79 Set_Name_Table_Int (Units.Table (J).Uname, 0); 80 end loop; 81 82 -- Free argument table strings 83 84 for J in Args.First .. Args.Last loop 85 Free (Args.Table (J)); 86 end loop; 87 88 -- Initialize all tables 89 90 ALIs.Init; 91 No_Deps.Init; 92 Units.Init; 93 Withs.Init; 94 Sdep.Init; 95 Linker_Options.Init; 96 Notes.Init; 97 Xref_Section.Init; 98 Xref_Entity.Init; 99 Xref.Init; 100 Version_Ref.Reset; 101 102 -- Add dummy zero'th item in Linker_Options and Notes for sort calls 103 104 Linker_Options.Increment_Last; 105 Notes.Increment_Last; 106 107 -- Initialize global variables recording cumulative options in all 108 -- ALI files that are read for a given processing run in gnatbind. 109 110 Dynamic_Elaboration_Checks_Specified := False; 111 Locking_Policy_Specified := ' '; 112 No_Normalize_Scalars_Specified := False; 113 No_Object_Specified := False; 114 GNATprove_Mode_Specified := False; 115 Normalize_Scalars_Specified := False; 116 Partition_Elaboration_Policy_Specified := ' '; 117 Queuing_Policy_Specified := ' '; 118 SSO_Default_Specified := False; 119 Static_Elaboration_Model_Used := False; 120 Task_Dispatching_Policy_Specified := ' '; 121 Unreserve_All_Interrupts_Specified := False; 122 Frontend_Exceptions_Specified := False; 123 Zero_Cost_Exceptions_Specified := False; 124 end Initialize_ALI; 125 126 -------------- 127 -- Scan_ALI -- 128 -------------- 129 130 function Scan_ALI 131 (F : File_Name_Type; 132 T : Text_Buffer_Ptr; 133 Ignore_ED : Boolean; 134 Err : Boolean; 135 Read_Xref : Boolean := False; 136 Read_Lines : String := ""; 137 Ignore_Lines : String := "X"; 138 Ignore_Errors : Boolean := False; 139 Directly_Scanned : Boolean := False) return ALI_Id 140 is 141 P : Text_Ptr := T'First; 142 Line : Logical_Line_Number := 1; 143 Id : ALI_Id; 144 C : Character; 145 NS_Found : Boolean; 146 First_Arg : Arg_Id; 147 148 Ignore : array (Character range 'A' .. 'Z') of Boolean; 149 -- Ignore (X) is set to True if lines starting with X are to 150 -- be ignored by Scan_ALI and skipped, and False if the lines 151 -- are to be read and processed. 152 153 Bad_ALI_Format : exception; 154 -- Exception raised by Fatal_Error if Err is True 155 156 function At_Eol return Boolean; 157 -- Test if at end of line 158 159 function At_End_Of_Field return Boolean; 160 -- Test if at end of line, or if at blank or horizontal tab 161 162 procedure Check_At_End_Of_Field; 163 -- Check if we are at end of field, fatal error if not 164 165 procedure Checkc (C : Character); 166 -- Check next character is C. If so bump past it, if not fatal error 167 168 procedure Check_Unknown_Line; 169 -- If Ignore_Errors mode, then checks C to make sure that it is not 170 -- an unknown ALI line type characters, and if so, skips lines 171 -- until the first character of the line is one of these characters, 172 -- at which point it does a Getc to put that character in C. The 173 -- call has no effect if C is already an appropriate character. 174 -- If not in Ignore_Errors mode, a fatal error is signalled if the 175 -- line is unknown. Note that if C is an EOL on entry, the line is 176 -- skipped (it is assumed that blank lines are never significant). 177 -- If C is EOF on entry, the call has no effect (it is assumed that 178 -- the caller will properly handle this case). 179 180 procedure Fatal_Error; 181 -- Generate fatal error message for badly formatted ALI file if 182 -- Err is false, or raise Bad_ALI_Format if Err is True. 183 184 procedure Fatal_Error_Ignore; 185 pragma Inline (Fatal_Error_Ignore); 186 -- In Ignore_Errors mode, has no effect, otherwise same as Fatal_Error 187 188 function Getc return Character; 189 -- Get next character, bumping P past the character obtained 190 191 function Get_File_Name 192 (Lower : Boolean := False; 193 May_Be_Quoted : Boolean := False) return File_Name_Type; 194 -- Skip blanks, then scan out a file name (name is left in Name_Buffer 195 -- with length in Name_Len, as well as returning a File_Name_Type value. 196 -- If May_Be_Quoted is True and the first non blank character is '"', 197 -- then remove starting and ending quotes and undoubled internal quotes. 198 -- If lower is false, the case is unchanged, if Lower is True then the 199 -- result is forced to all lower case for systems where file names are 200 -- not case sensitive. This ensures that gnatbind works correctly 201 -- regardless of the case of the file name on all systems. The scan 202 -- is terminated by a end of line, space or horizontal tab. Any other 203 -- special characters are included in the returned name. 204 205 function Get_Name 206 (Ignore_Spaces : Boolean := False; 207 Ignore_Special : Boolean := False; 208 May_Be_Quoted : Boolean := False) return Name_Id; 209 -- Skip blanks, then scan out a name (name is left in Name_Buffer with 210 -- length in Name_Len, as well as being returned in Name_Id form). 211 -- If Lower is set to True then the Name_Buffer will be converted to 212 -- all lower case, for systems where file names are not case sensitive. 213 -- This ensures that gnatbind works correctly regardless of the case 214 -- of the file name on all systems. The termination condition depends 215 -- on the settings of Ignore_Spaces and Ignore_Special: 216 -- 217 -- If Ignore_Spaces is False (normal case), then scan is terminated 218 -- by the normal end of field condition (EOL, space, horizontal tab) 219 -- 220 -- If Ignore_Special is False (normal case), the scan is terminated by 221 -- a typeref bracket or an equal sign except for the special case of 222 -- an operator name starting with a double quote which is terminated 223 -- by another double quote. 224 -- 225 -- If May_Be_Quoted is True and the first non blank character is '"' 226 -- the name is 'unquoted'. In this case Ignore_Special is ignored and 227 -- assumed to be True. 228 -- 229 -- It is an error to set both Ignore_Spaces and Ignore_Special to True. 230 -- This function handles wide characters properly. 231 232 function Get_Nat return Nat; 233 -- Skip blanks, then scan out an unsigned integer value in Nat range 234 -- raises ALI_Reading_Error if the encoutered type is not natural. 235 236 function Get_Stamp return Time_Stamp_Type; 237 -- Skip blanks, then scan out a time stamp 238 239 function Get_Unit_Name return Unit_Name_Type; 240 -- Skip blanks, then scan out a file name (name is left in Name_Buffer 241 -- with length in Name_Len, as well as returning a Unit_Name_Type value. 242 -- The case is unchanged and terminated by a normal end of field. 243 244 function Nextc return Character; 245 -- Return current character without modifying pointer P 246 247 procedure Get_Typeref 248 (Current_File_Num : Sdep_Id; 249 Ref : out Tref_Kind; 250 File_Num : out Sdep_Id; 251 Line : out Nat; 252 Ref_Type : out Character; 253 Col : out Nat; 254 Standard_Entity : out Name_Id); 255 -- Parse the definition of a typeref (<...>, {...} or (...)) 256 257 procedure Skip_Eol; 258 -- Skip past spaces, then skip past end of line (fatal error if not 259 -- at end of line). Also skips past any following blank lines. 260 261 procedure Skip_Line; 262 -- Skip rest of current line and any following blank lines 263 264 procedure Skip_Space; 265 -- Skip past white space (blanks or horizontal tab) 266 267 procedure Skipc; 268 -- Skip past next character, does not affect value in C. This call 269 -- is like calling Getc and ignoring the returned result. 270 271 --------------------- 272 -- At_End_Of_Field -- 273 --------------------- 274 275 function At_End_Of_Field return Boolean is 276 begin 277 return Nextc <= ' '; 278 end At_End_Of_Field; 279 280 ------------ 281 -- At_Eol -- 282 ------------ 283 284 function At_Eol return Boolean is 285 begin 286 return Nextc = EOF or else Nextc = CR or else Nextc = LF; 287 end At_Eol; 288 289 --------------------------- 290 -- Check_At_End_Of_Field -- 291 --------------------------- 292 293 procedure Check_At_End_Of_Field is 294 begin 295 if not At_End_Of_Field then 296 if Ignore_Errors then 297 while Nextc > ' ' loop 298 P := P + 1; 299 end loop; 300 else 301 Fatal_Error; 302 end if; 303 end if; 304 end Check_At_End_Of_Field; 305 306 ------------------------ 307 -- Check_Unknown_Line -- 308 ------------------------ 309 310 procedure Check_Unknown_Line is 311 begin 312 while C not in 'A' .. 'Z' 313 or else not Known_ALI_Lines (C) 314 loop 315 if C = CR or else C = LF then 316 Skip_Line; 317 C := Nextc; 318 319 elsif C = EOF then 320 return; 321 322 elsif Ignore_Errors then 323 Skip_Line; 324 C := Getc; 325 326 else 327 Fatal_Error; 328 end if; 329 end loop; 330 end Check_Unknown_Line; 331 332 ------------ 333 -- Checkc -- 334 ------------ 335 336 procedure Checkc (C : Character) is 337 begin 338 if Nextc = C then 339 P := P + 1; 340 elsif Ignore_Errors then 341 P := P + 1; 342 else 343 Fatal_Error; 344 end if; 345 end Checkc; 346 347 ----------------- 348 -- Fatal_Error -- 349 ----------------- 350 351 procedure Fatal_Error is 352 Ptr1 : Text_Ptr; 353 Ptr2 : Text_Ptr; 354 Col : Int; 355 356 procedure Wchar (C : Character); 357 -- Write a single character, replacing horizontal tab by spaces 358 359 procedure Wchar (C : Character) is 360 begin 361 if C = HT then 362 loop 363 Wchar (' '); 364 exit when Col mod 8 = 0; 365 end loop; 366 367 else 368 Write_Char (C); 369 Col := Col + 1; 370 end if; 371 end Wchar; 372 373 -- Start of processing for Fatal_Error 374 375 begin 376 if Err then 377 raise Bad_ALI_Format; 378 end if; 379 380 Set_Standard_Error; 381 Write_Str ("fatal error: file "); 382 Write_Name (F); 383 Write_Str (" is incorrectly formatted"); 384 Write_Eol; 385 386 Write_Str ("make sure you are using consistent versions " & 387 388 -- Split the following line so that it can easily be transformed for 389 -- other back-ends where the compiler might have a different name. 390 391 "of gcc/gnatbind"); 392 393 Write_Eol; 394 395 -- Find start of line 396 397 Ptr1 := P; 398 while Ptr1 > T'First 399 and then T (Ptr1 - 1) /= CR 400 and then T (Ptr1 - 1) /= LF 401 loop 402 Ptr1 := Ptr1 - 1; 403 end loop; 404 405 Write_Int (Int (Line)); 406 Write_Str (". "); 407 408 if Line < 100 then 409 Write_Char (' '); 410 end if; 411 412 if Line < 10 then 413 Write_Char (' '); 414 end if; 415 416 Col := 0; 417 Ptr2 := Ptr1; 418 419 while Ptr2 < T'Last 420 and then T (Ptr2) /= CR 421 and then T (Ptr2) /= LF 422 loop 423 Wchar (T (Ptr2)); 424 Ptr2 := Ptr2 + 1; 425 end loop; 426 427 Write_Eol; 428 429 Write_Str (" "); 430 Col := 0; 431 432 while Ptr1 < P loop 433 if T (Ptr1) = HT then 434 Wchar (HT); 435 else 436 Wchar (' '); 437 end if; 438 439 Ptr1 := Ptr1 + 1; 440 end loop; 441 442 Wchar ('|'); 443 Write_Eol; 444 445 Exit_Program (E_Fatal); 446 end Fatal_Error; 447 448 ------------------------ 449 -- Fatal_Error_Ignore -- 450 ------------------------ 451 452 procedure Fatal_Error_Ignore is 453 begin 454 if not Ignore_Errors then 455 Fatal_Error; 456 end if; 457 end Fatal_Error_Ignore; 458 459 ------------------- 460 -- Get_File_Name -- 461 ------------------- 462 463 function Get_File_Name 464 (Lower : Boolean := False; 465 May_Be_Quoted : Boolean := False) return File_Name_Type 466 is 467 F : Name_Id; 468 469 begin 470 F := Get_Name (Ignore_Special => True, 471 May_Be_Quoted => May_Be_Quoted); 472 473 -- Convert file name to all lower case if file names are not case 474 -- sensitive. This ensures that we handle names in the canonical 475 -- lower case format, regardless of the actual case. 476 477 if Lower and not File_Names_Case_Sensitive then 478 Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); 479 return Name_Find; 480 else 481 return File_Name_Type (F); 482 end if; 483 end Get_File_Name; 484 485 -------------- 486 -- Get_Name -- 487 -------------- 488 489 function Get_Name 490 (Ignore_Spaces : Boolean := False; 491 Ignore_Special : Boolean := False; 492 May_Be_Quoted : Boolean := False) return Name_Id 493 is 494 Char : Character; 495 496 begin 497 Name_Len := 0; 498 Skip_Space; 499 500 if At_Eol then 501 if Ignore_Errors then 502 return Error_Name; 503 else 504 Fatal_Error; 505 end if; 506 end if; 507 508 Char := Getc; 509 510 -- Deal with quoted characters 511 512 if May_Be_Quoted and then Char = '"' then 513 loop 514 if At_Eol then 515 if Ignore_Errors then 516 return Error_Name; 517 else 518 Fatal_Error; 519 end if; 520 end if; 521 522 Char := Getc; 523 524 if Char = '"' then 525 if At_Eol then 526 exit; 527 528 else 529 Char := Getc; 530 531 if Char /= '"' then 532 P := P - 1; 533 exit; 534 end if; 535 end if; 536 end if; 537 538 Add_Char_To_Name_Buffer (Char); 539 end loop; 540 541 -- Other than case of quoted character 542 543 else 544 P := P - 1; 545 loop 546 Add_Char_To_Name_Buffer (Getc); 547 548 exit when At_End_Of_Field and then not Ignore_Spaces; 549 550 if not Ignore_Special then 551 if Name_Buffer (1) = '"' then 552 exit when Name_Len > 1 553 and then Name_Buffer (Name_Len) = '"'; 554 555 else 556 -- Terminate on parens or angle brackets or equal sign 557 558 exit when Nextc = '(' or else Nextc = ')' 559 or else Nextc = '{' or else Nextc = '}' 560 or else Nextc = '<' or else Nextc = '>' 561 or else Nextc = '='; 562 563 -- Terminate on comma 564 565 exit when Nextc = ','; 566 567 -- Terminate if left bracket not part of wide char 568 -- sequence Note that we only recognize brackets 569 -- notation so far ??? 570 571 exit when Nextc = '[' and then T (P + 1) /= '"'; 572 573 -- Terminate if right bracket not part of wide char 574 -- sequence. 575 576 exit when Nextc = ']' and then T (P - 1) /= '"'; 577 end if; 578 end if; 579 end loop; 580 end if; 581 582 return Name_Find; 583 end Get_Name; 584 585 ------------------- 586 -- Get_Unit_Name -- 587 ------------------- 588 589 function Get_Unit_Name return Unit_Name_Type is 590 begin 591 return Unit_Name_Type (Get_Name); 592 end Get_Unit_Name; 593 594 ------------- 595 -- Get_Nat -- 596 ------------- 597 598 function Get_Nat return Nat is 599 V : Nat; 600 601 begin 602 Skip_Space; 603 604 -- Check if we are on a number. In the case of bad ALI files, this 605 -- may not be true. 606 607 if not (Nextc in '0' .. '9') then 608 Fatal_Error; 609 end if; 610 611 V := 0; 612 loop 613 V := V * 10 + (Character'Pos (Getc) - Character'Pos ('0')); 614 615 exit when At_End_Of_Field; 616 exit when Nextc < '0' or else Nextc > '9'; 617 end loop; 618 619 return V; 620 end Get_Nat; 621 622 --------------- 623 -- Get_Stamp -- 624 --------------- 625 626 function Get_Stamp return Time_Stamp_Type is 627 T : Time_Stamp_Type; 628 Start : Integer; 629 630 begin 631 Skip_Space; 632 633 if At_Eol then 634 if Ignore_Errors then 635 return Dummy_Time_Stamp; 636 else 637 Fatal_Error; 638 end if; 639 end if; 640 641 -- Following reads old style time stamp missing first two digits 642 643 if Nextc in '7' .. '9' then 644 T (1) := '1'; 645 T (2) := '9'; 646 Start := 3; 647 648 -- Normal case of full year in time stamp 649 650 else 651 Start := 1; 652 end if; 653 654 for J in Start .. T'Last loop 655 T (J) := Getc; 656 end loop; 657 658 return T; 659 end Get_Stamp; 660 661 ----------------- 662 -- Get_Typeref -- 663 ----------------- 664 665 procedure Get_Typeref 666 (Current_File_Num : Sdep_Id; 667 Ref : out Tref_Kind; 668 File_Num : out Sdep_Id; 669 Line : out Nat; 670 Ref_Type : out Character; 671 Col : out Nat; 672 Standard_Entity : out Name_Id) 673 is 674 N : Nat; 675 begin 676 case Nextc is 677 when '<' => Ref := Tref_Derived; 678 when '(' => Ref := Tref_Access; 679 when '{' => Ref := Tref_Type; 680 when others => Ref := Tref_None; 681 end case; 682 683 -- Case of typeref field present 684 685 if Ref /= Tref_None then 686 P := P + 1; -- skip opening bracket 687 688 if Nextc in 'a' .. 'z' then 689 File_Num := No_Sdep_Id; 690 Line := 0; 691 Ref_Type := ' '; 692 Col := 0; 693 Standard_Entity := Get_Name (Ignore_Spaces => True); 694 else 695 N := Get_Nat; 696 697 if Nextc = '|' then 698 File_Num := Sdep_Id (N + Nat (First_Sdep_Entry) - 1); 699 P := P + 1; 700 N := Get_Nat; 701 else 702 File_Num := Current_File_Num; 703 end if; 704 705 Line := N; 706 Ref_Type := Getc; 707 Col := Get_Nat; 708 Standard_Entity := No_Name; 709 end if; 710 711 -- ??? Temporary workaround for nested generics case: 712 -- 4i4 Directories{1|4I9[4|6[3|3]]} 713 -- See C918-002 714 715 declare 716 Nested_Brackets : Natural := 0; 717 718 begin 719 loop 720 case Nextc is 721 when '[' => 722 Nested_Brackets := Nested_Brackets + 1; 723 when ']' => 724 Nested_Brackets := Nested_Brackets - 1; 725 when others => 726 if Nested_Brackets = 0 then 727 exit; 728 end if; 729 end case; 730 731 Skipc; 732 end loop; 733 end; 734 735 P := P + 1; -- skip closing bracket 736 Skip_Space; 737 738 -- No typeref entry present 739 740 else 741 File_Num := No_Sdep_Id; 742 Line := 0; 743 Ref_Type := ' '; 744 Col := 0; 745 Standard_Entity := No_Name; 746 end if; 747 end Get_Typeref; 748 749 ---------- 750 -- Getc -- 751 ---------- 752 753 function Getc return Character is 754 begin 755 if P = T'Last then 756 return EOF; 757 else 758 P := P + 1; 759 return T (P - 1); 760 end if; 761 end Getc; 762 763 ----------- 764 -- Nextc -- 765 ----------- 766 767 function Nextc return Character is 768 begin 769 return T (P); 770 end Nextc; 771 772 -------------- 773 -- Skip_Eol -- 774 -------------- 775 776 procedure Skip_Eol is 777 begin 778 Skip_Space; 779 780 if not At_Eol then 781 if Ignore_Errors then 782 while not At_Eol loop 783 P := P + 1; 784 end loop; 785 else 786 Fatal_Error; 787 end if; 788 end if; 789 790 -- Loop to skip past blank lines (first time through skips this EOL) 791 792 while Nextc < ' ' and then Nextc /= EOF loop 793 if Nextc = LF then 794 Line := Line + 1; 795 end if; 796 797 P := P + 1; 798 end loop; 799 end Skip_Eol; 800 801 --------------- 802 -- Skip_Line -- 803 --------------- 804 805 procedure Skip_Line is 806 begin 807 while not At_Eol loop 808 P := P + 1; 809 end loop; 810 811 Skip_Eol; 812 end Skip_Line; 813 814 ---------------- 815 -- Skip_Space -- 816 ---------------- 817 818 procedure Skip_Space is 819 begin 820 while Nextc = ' ' or else Nextc = HT loop 821 P := P + 1; 822 end loop; 823 end Skip_Space; 824 825 ----------- 826 -- Skipc -- 827 ----------- 828 829 procedure Skipc is 830 begin 831 if P /= T'Last then 832 P := P + 1; 833 end if; 834 end Skipc; 835 836 -- Start of processing for Scan_ALI 837 838 begin 839 First_Sdep_Entry := Sdep.Last + 1; 840 841 -- Acquire lines to be ignored 842 843 if Read_Xref then 844 Ignore := 845 ('U' | 'W' | 'Y' | 'Z' | 'D' | 'X' => False, others => True); 846 847 -- Read_Lines parameter given 848 849 elsif Read_Lines /= "" then 850 Ignore := ('U' => False, others => True); 851 852 for J in Read_Lines'Range loop 853 Ignore (Read_Lines (J)) := False; 854 end loop; 855 856 -- Process Ignore_Lines parameter 857 858 else 859 Ignore := (others => False); 860 861 for J in Ignore_Lines'Range loop 862 pragma Assert (Ignore_Lines (J) /= 'U'); 863 Ignore (Ignore_Lines (J)) := True; 864 end loop; 865 end if; 866 867 -- Setup ALI Table entry with appropriate defaults 868 869 ALIs.Increment_Last; 870 Id := ALIs.Last; 871 Set_Name_Table_Int (F, Int (Id)); 872 873 ALIs.Table (Id) := ( 874 Afile => F, 875 Compile_Errors => False, 876 First_Interrupt_State => Interrupt_States.Last + 1, 877 First_Sdep => No_Sdep_Id, 878 First_Specific_Dispatching => Specific_Dispatching.Last + 1, 879 First_Unit => No_Unit_Id, 880 GNATprove_Mode => False, 881 Last_Interrupt_State => Interrupt_States.Last, 882 Last_Sdep => No_Sdep_Id, 883 Last_Specific_Dispatching => Specific_Dispatching.Last, 884 Last_Unit => No_Unit_Id, 885 Locking_Policy => ' ', 886 Main_Priority => -1, 887 Main_CPU => -1, 888 Main_Program => None, 889 No_Object => False, 890 Normalize_Scalars => False, 891 Ofile_Full_Name => Full_Object_File_Name, 892 Partition_Elaboration_Policy => ' ', 893 Queuing_Policy => ' ', 894 Restrictions => No_Restrictions, 895 SAL_Interface => False, 896 Sfile => No_File, 897 SSO_Default => ' ', 898 Task_Dispatching_Policy => ' ', 899 Time_Slice_Value => -1, 900 WC_Encoding => 'b', 901 Unit_Exception_Table => False, 902 Ver => (others => ' '), 903 Ver_Len => 0, 904 Frontend_Exceptions => False, 905 Zero_Cost_Exceptions => False); 906 907 -- Now we acquire the input lines from the ALI file. Note that the 908 -- convention in the following code is that as we enter each section, 909 -- C is set to contain the first character of the following line. 910 911 C := Getc; 912 Check_Unknown_Line; 913 914 -- Acquire library version 915 916 if C /= 'V' then 917 918 -- The V line missing really indicates trouble, most likely it 919 -- means we don't have an ALI file at all, so here we give a 920 -- fatal error even if we are in Ignore_Errors mode. 921 922 Fatal_Error; 923 924 elsif Ignore ('V') then 925 Skip_Line; 926 927 else 928 Checkc (' '); 929 Skip_Space; 930 Checkc ('"'); 931 932 for J in 1 .. Ver_Len_Max loop 933 C := Getc; 934 exit when C = '"'; 935 ALIs.Table (Id).Ver (J) := C; 936 ALIs.Table (Id).Ver_Len := J; 937 end loop; 938 939 Skip_Eol; 940 end if; 941 942 C := Getc; 943 Check_Unknown_Line; 944 945 -- Acquire main program line if present 946 947 if C = 'M' then 948 if Ignore ('M') then 949 Skip_Line; 950 951 else 952 Checkc (' '); 953 Skip_Space; 954 955 C := Getc; 956 957 if C = 'F' then 958 ALIs.Table (Id).Main_Program := Func; 959 elsif C = 'P' then 960 ALIs.Table (Id).Main_Program := Proc; 961 else 962 P := P - 1; 963 Fatal_Error; 964 end if; 965 966 Skip_Space; 967 968 if not At_Eol then 969 if Nextc < 'A' then 970 ALIs.Table (Id).Main_Priority := Get_Nat; 971 end if; 972 973 Skip_Space; 974 975 if Nextc = 'T' then 976 P := P + 1; 977 Checkc ('='); 978 ALIs.Table (Id).Time_Slice_Value := Get_Nat; 979 end if; 980 981 Skip_Space; 982 983 if Nextc = 'C' then 984 P := P + 1; 985 Checkc ('='); 986 ALIs.Table (Id).Main_CPU := Get_Nat; 987 end if; 988 989 Skip_Space; 990 991 Checkc ('W'); 992 Checkc ('='); 993 ALIs.Table (Id).WC_Encoding := Getc; 994 end if; 995 996 Skip_Eol; 997 end if; 998 999 C := Getc; 1000 end if; 1001 1002 -- Acquire argument lines 1003 1004 First_Arg := Args.Last + 1; 1005 1006 A_Loop : loop 1007 Check_Unknown_Line; 1008 exit A_Loop when C /= 'A'; 1009 1010 if Ignore ('A') then 1011 Skip_Line; 1012 1013 else 1014 Checkc (' '); 1015 1016 -- Scan out argument 1017 1018 Name_Len := 0; 1019 while not At_Eol loop 1020 Add_Char_To_Name_Buffer (Getc); 1021 end loop; 1022 1023 -- If -fstack-check, record that it occurred. Note that an 1024 -- additional string parameter can be specified, in the form of 1025 -- -fstack-check={no|generic|specific}. "no" means no checking, 1026 -- "generic" means force the use of old-style checking, and 1027 -- "specific" means use the best checking method. 1028 1029 if Name_Len >= 13 1030 and then Name_Buffer (1 .. 13) = "-fstack-check" 1031 and then Name_Buffer (1 .. Name_Len) /= "-fstack-check=no" 1032 then 1033 Stack_Check_Switch_Set := True; 1034 end if; 1035 1036 -- Store the argument 1037 1038 Args.Increment_Last; 1039 Args.Table (Args.Last) := new String'(Name_Buffer (1 .. Name_Len)); 1040 1041 Skip_Eol; 1042 end if; 1043 1044 C := Getc; 1045 end loop A_Loop; 1046 1047 -- Acquire P line 1048 1049 Check_Unknown_Line; 1050 1051 while C /= 'P' loop 1052 if Ignore_Errors then 1053 if C = EOF then 1054 Fatal_Error; 1055 else 1056 Skip_Line; 1057 C := Nextc; 1058 end if; 1059 else 1060 Fatal_Error; 1061 end if; 1062 end loop; 1063 1064 if Ignore ('P') then 1065 Skip_Line; 1066 1067 -- Process P line 1068 1069 else 1070 NS_Found := False; 1071 1072 while not At_Eol loop 1073 Checkc (' '); 1074 Skip_Space; 1075 C := Getc; 1076 1077 -- Processing for CE 1078 1079 if C = 'C' then 1080 Checkc ('E'); 1081 ALIs.Table (Id).Compile_Errors := True; 1082 1083 -- Processing for DB 1084 1085 elsif C = 'D' then 1086 Checkc ('B'); 1087 Detect_Blocking := True; 1088 1089 -- Processing for Ex 1090 1091 elsif C = 'E' then 1092 Partition_Elaboration_Policy_Specified := Getc; 1093 ALIs.Table (Id).Partition_Elaboration_Policy := 1094 Partition_Elaboration_Policy_Specified; 1095 1096 -- Processing for FX 1097 1098 elsif C = 'F' then 1099 C := Getc; 1100 1101 if C = 'X' then 1102 ALIs.Table (Id).Frontend_Exceptions := True; 1103 Frontend_Exceptions_Specified := True; 1104 else 1105 Fatal_Error_Ignore; 1106 end if; 1107 1108 -- Processing for GP 1109 1110 elsif C = 'G' then 1111 Checkc ('P'); 1112 GNATprove_Mode_Specified := True; 1113 ALIs.Table (Id).GNATprove_Mode := True; 1114 1115 -- Processing for Lx 1116 1117 elsif C = 'L' then 1118 Locking_Policy_Specified := Getc; 1119 ALIs.Table (Id).Locking_Policy := Locking_Policy_Specified; 1120 1121 -- Processing for flags starting with N 1122 1123 elsif C = 'N' then 1124 C := Getc; 1125 1126 -- Processing for NO 1127 1128 if C = 'O' then 1129 ALIs.Table (Id).No_Object := True; 1130 No_Object_Specified := True; 1131 1132 -- Processing for NR 1133 1134 elsif C = 'R' then 1135 No_Run_Time_Mode := True; 1136 Configurable_Run_Time_Mode := True; 1137 1138 -- Processing for NS 1139 1140 elsif C = 'S' then 1141 ALIs.Table (Id).Normalize_Scalars := True; 1142 Normalize_Scalars_Specified := True; 1143 NS_Found := True; 1144 1145 -- Invalid switch starting with N 1146 1147 else 1148 Fatal_Error_Ignore; 1149 end if; 1150 1151 -- Processing for OH/OL 1152 1153 elsif C = 'O' then 1154 C := Getc; 1155 1156 if C = 'L' or else C = 'H' then 1157 ALIs.Table (Id).SSO_Default := C; 1158 SSO_Default_Specified := True; 1159 1160 else 1161 Fatal_Error_Ignore; 1162 end if; 1163 1164 -- Processing for Qx 1165 1166 elsif C = 'Q' then 1167 Queuing_Policy_Specified := Getc; 1168 ALIs.Table (Id).Queuing_Policy := Queuing_Policy_Specified; 1169 1170 -- Processing for flags starting with S 1171 1172 elsif C = 'S' then 1173 C := Getc; 1174 1175 -- Processing for SL 1176 1177 if C = 'L' then 1178 ALIs.Table (Id).SAL_Interface := True; 1179 1180 -- Processing for SS 1181 1182 elsif C = 'S' then 1183 Opt.Sec_Stack_Used := True; 1184 1185 -- Invalid switch starting with S 1186 1187 else 1188 Fatal_Error_Ignore; 1189 end if; 1190 1191 -- Processing for Tx 1192 1193 elsif C = 'T' then 1194 Task_Dispatching_Policy_Specified := Getc; 1195 ALIs.Table (Id).Task_Dispatching_Policy := 1196 Task_Dispatching_Policy_Specified; 1197 1198 -- Processing for switch starting with U 1199 1200 elsif C = 'U' then 1201 C := Getc; 1202 1203 -- Processing for UA 1204 1205 if C = 'A' then 1206 Unreserve_All_Interrupts_Specified := True; 1207 1208 -- Processing for UX 1209 1210 elsif C = 'X' then 1211 ALIs.Table (Id).Unit_Exception_Table := True; 1212 1213 -- Invalid switches starting with U 1214 1215 else 1216 Fatal_Error_Ignore; 1217 end if; 1218 1219 -- Processing for ZX 1220 1221 elsif C = 'Z' then 1222 C := Getc; 1223 1224 if C = 'X' then 1225 ALIs.Table (Id).Zero_Cost_Exceptions := True; 1226 Zero_Cost_Exceptions_Specified := True; 1227 else 1228 Fatal_Error_Ignore; 1229 end if; 1230 1231 -- Invalid parameter 1232 1233 else 1234 C := Getc; 1235 Fatal_Error_Ignore; 1236 end if; 1237 end loop; 1238 1239 if not NS_Found then 1240 No_Normalize_Scalars_Specified := True; 1241 end if; 1242 1243 Skip_Eol; 1244 end if; 1245 1246 C := Getc; 1247 Check_Unknown_Line; 1248 1249 -- Loop to skip to first restrictions line 1250 1251 while C /= 'R' loop 1252 if Ignore_Errors then 1253 if C = EOF then 1254 Fatal_Error; 1255 else 1256 Skip_Line; 1257 C := Nextc; 1258 end if; 1259 else 1260 Fatal_Error; 1261 end if; 1262 end loop; 1263 1264 -- Ignore all 'R' lines if that is required 1265 1266 if Ignore ('R') then 1267 while C = 'R' loop 1268 Skip_Line; 1269 C := Getc; 1270 end loop; 1271 1272 -- Here we process the restrictions lines (other than unit name cases) 1273 1274 else 1275 Scan_Restrictions : declare 1276 Save_R : constant Restrictions_Info := Cumulative_Restrictions; 1277 -- Save cumulative restrictions in case we have a fatal error 1278 1279 Bad_R_Line : exception; 1280 -- Signal bad restrictions line (raised on unexpected character) 1281 1282 Typ : Character; 1283 R : Restriction_Id; 1284 N : Natural; 1285 1286 begin 1287 -- Named restriction case 1288 1289 if Nextc = 'N' then 1290 Skip_Line; 1291 C := Getc; 1292 1293 -- Loop through RR and RV lines 1294 1295 while C = 'R' and then Nextc /= ' ' loop 1296 Typ := Getc; 1297 Checkc (' '); 1298 1299 -- Acquire restriction name 1300 1301 Name_Len := 0; 1302 while not At_Eol and then Nextc /= '=' loop 1303 Name_Len := Name_Len + 1; 1304 Name_Buffer (Name_Len) := Getc; 1305 end loop; 1306 1307 -- Now search list of restrictions to find match 1308 1309 declare 1310 RN : String renames Name_Buffer (1 .. Name_Len); 1311 1312 begin 1313 R := Restriction_Id'First; 1314 while R /= Not_A_Restriction_Id loop 1315 if Restriction_Id'Image (R) = RN then 1316 goto R_Found; 1317 end if; 1318 1319 R := Restriction_Id'Succ (R); 1320 end loop; 1321 1322 -- We don't recognize the restriction. This might be 1323 -- thought of as an error, and it really is, but we 1324 -- want to allow building with inconsistent versions 1325 -- of the binder and ali files (see comments at the 1326 -- start of package System.Rident), so we just ignore 1327 -- this situation. 1328 1329 goto Done_With_Restriction_Line; 1330 end; 1331 1332 <<R_Found>> 1333 1334 case R is 1335 1336 -- Boolean restriction case 1337 1338 when All_Boolean_Restrictions => 1339 case Typ is 1340 when 'V' => 1341 ALIs.Table (Id).Restrictions.Violated (R) := 1342 True; 1343 Cumulative_Restrictions.Violated (R) := True; 1344 1345 when 'R' => 1346 ALIs.Table (Id).Restrictions.Set (R) := True; 1347 Cumulative_Restrictions.Set (R) := True; 1348 1349 when others => 1350 raise Bad_R_Line; 1351 end case; 1352 1353 -- Parameter restriction case 1354 1355 when All_Parameter_Restrictions => 1356 if At_Eol or else Nextc /= '=' then 1357 raise Bad_R_Line; 1358 else 1359 Skipc; 1360 end if; 1361 1362 N := Natural (Get_Nat); 1363 1364 case Typ is 1365 1366 -- Restriction set 1367 1368 when 'R' => 1369 ALIs.Table (Id).Restrictions.Set (R) := True; 1370 ALIs.Table (Id).Restrictions.Value (R) := N; 1371 1372 if Cumulative_Restrictions.Set (R) then 1373 Cumulative_Restrictions.Value (R) := 1374 Integer'Min 1375 (Cumulative_Restrictions.Value (R), N); 1376 else 1377 Cumulative_Restrictions.Set (R) := True; 1378 Cumulative_Restrictions.Value (R) := N; 1379 end if; 1380 1381 -- Restriction violated 1382 1383 when 'V' => 1384 ALIs.Table (Id).Restrictions.Violated (R) := 1385 True; 1386 Cumulative_Restrictions.Violated (R) := True; 1387 ALIs.Table (Id).Restrictions.Count (R) := N; 1388 1389 -- Checked Max_Parameter case 1390 1391 if R in Checked_Max_Parameter_Restrictions then 1392 Cumulative_Restrictions.Count (R) := 1393 Integer'Max 1394 (Cumulative_Restrictions.Count (R), N); 1395 1396 -- Other checked parameter cases 1397 1398 else 1399 declare 1400 pragma Unsuppress (Overflow_Check); 1401 1402 begin 1403 Cumulative_Restrictions.Count (R) := 1404 Cumulative_Restrictions.Count (R) + N; 1405 1406 exception 1407 when Constraint_Error => 1408 1409 -- A constraint error comes from the 1410 -- addition. We reset to the maximum 1411 -- and indicate that the real value 1412 -- is now unknown. 1413 1414 Cumulative_Restrictions.Value (R) := 1415 Integer'Last; 1416 Cumulative_Restrictions.Unknown (R) := 1417 True; 1418 end; 1419 end if; 1420 1421 -- Deal with + case 1422 1423 if Nextc = '+' then 1424 Skipc; 1425 ALIs.Table (Id).Restrictions.Unknown (R) := 1426 True; 1427 Cumulative_Restrictions.Unknown (R) := True; 1428 end if; 1429 1430 -- Other than 'R' or 'V' 1431 1432 when others => 1433 raise Bad_R_Line; 1434 end case; 1435 1436 if not At_Eol then 1437 raise Bad_R_Line; 1438 end if; 1439 1440 -- Bizarre error case NOT_A_RESTRICTION 1441 1442 when Not_A_Restriction_Id => 1443 raise Bad_R_Line; 1444 end case; 1445 1446 if not At_Eol then 1447 raise Bad_R_Line; 1448 end if; 1449 1450 <<Done_With_Restriction_Line>> 1451 Skip_Line; 1452 C := Getc; 1453 end loop; 1454 1455 -- Positional restriction case 1456 1457 else 1458 Checkc (' '); 1459 Skip_Space; 1460 1461 -- Acquire information for boolean restrictions 1462 1463 for R in All_Boolean_Restrictions loop 1464 C := Getc; 1465 1466 case C is 1467 when 'v' => 1468 ALIs.Table (Id).Restrictions.Violated (R) := True; 1469 Cumulative_Restrictions.Violated (R) := True; 1470 1471 when 'r' => 1472 ALIs.Table (Id).Restrictions.Set (R) := True; 1473 Cumulative_Restrictions.Set (R) := True; 1474 1475 when 'n' => 1476 null; 1477 1478 when others => 1479 raise Bad_R_Line; 1480 end case; 1481 end loop; 1482 1483 -- Acquire information for parameter restrictions 1484 1485 for RP in All_Parameter_Restrictions loop 1486 case Getc is 1487 when 'n' => 1488 null; 1489 1490 when 'r' => 1491 ALIs.Table (Id).Restrictions.Set (RP) := True; 1492 1493 declare 1494 N : constant Integer := Integer (Get_Nat); 1495 begin 1496 ALIs.Table (Id).Restrictions.Value (RP) := N; 1497 1498 if Cumulative_Restrictions.Set (RP) then 1499 Cumulative_Restrictions.Value (RP) := 1500 Integer'Min 1501 (Cumulative_Restrictions.Value (RP), N); 1502 else 1503 Cumulative_Restrictions.Set (RP) := True; 1504 Cumulative_Restrictions.Value (RP) := N; 1505 end if; 1506 end; 1507 1508 when others => 1509 raise Bad_R_Line; 1510 end case; 1511 1512 -- Acquire restrictions violations information 1513 1514 case Getc is 1515 1516 when 'n' => 1517 null; 1518 1519 when 'v' => 1520 ALIs.Table (Id).Restrictions.Violated (RP) := True; 1521 Cumulative_Restrictions.Violated (RP) := True; 1522 1523 declare 1524 N : constant Integer := Integer (Get_Nat); 1525 1526 begin 1527 ALIs.Table (Id).Restrictions.Count (RP) := N; 1528 1529 if RP in Checked_Max_Parameter_Restrictions then 1530 Cumulative_Restrictions.Count (RP) := 1531 Integer'Max 1532 (Cumulative_Restrictions.Count (RP), N); 1533 1534 else 1535 declare 1536 pragma Unsuppress (Overflow_Check); 1537 1538 begin 1539 Cumulative_Restrictions.Count (RP) := 1540 Cumulative_Restrictions.Count (RP) + N; 1541 1542 exception 1543 when Constraint_Error => 1544 1545 -- A constraint error comes from the add. We 1546 -- reset to the maximum and indicate that the 1547 -- real value is now unknown. 1548 1549 Cumulative_Restrictions.Value (RP) := 1550 Integer'Last; 1551 Cumulative_Restrictions.Unknown (RP) := True; 1552 end; 1553 end if; 1554 1555 if Nextc = '+' then 1556 Skipc; 1557 ALIs.Table (Id).Restrictions.Unknown (RP) := True; 1558 Cumulative_Restrictions.Unknown (RP) := True; 1559 end if; 1560 end; 1561 1562 when others => 1563 raise Bad_R_Line; 1564 end case; 1565 end loop; 1566 1567 if not At_Eol then 1568 raise Bad_R_Line; 1569 else 1570 Skip_Line; 1571 C := Getc; 1572 end if; 1573 end if; 1574 1575 -- Here if error during scanning of restrictions line 1576 1577 exception 1578 when Bad_R_Line => 1579 1580 -- In Ignore_Errors mode, undo any changes to restrictions 1581 -- from this unit, and continue on, skipping remaining R 1582 -- lines for this unit. 1583 1584 if Ignore_Errors then 1585 Cumulative_Restrictions := Save_R; 1586 ALIs.Table (Id).Restrictions := No_Restrictions; 1587 1588 loop 1589 Skip_Eol; 1590 C := Getc; 1591 exit when C /= 'R'; 1592 end loop; 1593 1594 -- In normal mode, this is a fatal error 1595 1596 else 1597 Fatal_Error; 1598 end if; 1599 end Scan_Restrictions; 1600 end if; 1601 1602 -- Acquire additional restrictions (No_Dependence) lines if present 1603 1604 while C = 'R' loop 1605 if Ignore ('R') then 1606 Skip_Line; 1607 else 1608 Skip_Space; 1609 No_Deps.Append ((Id, Get_Name)); 1610 Skip_Eol; 1611 end if; 1612 1613 C := Getc; 1614 end loop; 1615 1616 -- Acquire 'I' lines if present 1617 1618 Check_Unknown_Line; 1619 1620 while C = 'I' loop 1621 if Ignore ('I') then 1622 Skip_Line; 1623 1624 else 1625 declare 1626 Int_Num : Nat; 1627 I_State : Character; 1628 Line_No : Nat; 1629 1630 begin 1631 Int_Num := Get_Nat; 1632 Skip_Space; 1633 I_State := Getc; 1634 Line_No := Get_Nat; 1635 1636 Interrupt_States.Append ( 1637 (Interrupt_Id => Int_Num, 1638 Interrupt_State => I_State, 1639 IS_Pragma_Line => Line_No)); 1640 1641 ALIs.Table (Id).Last_Interrupt_State := Interrupt_States.Last; 1642 Skip_Eol; 1643 end; 1644 end if; 1645 1646 C := Getc; 1647 end loop; 1648 1649 -- Acquire 'S' lines if present 1650 1651 Check_Unknown_Line; 1652 1653 while C = 'S' loop 1654 if Ignore ('S') then 1655 Skip_Line; 1656 1657 else 1658 declare 1659 Policy : Character; 1660 First_Prio : Nat; 1661 Last_Prio : Nat; 1662 Line_No : Nat; 1663 1664 begin 1665 Checkc (' '); 1666 Skip_Space; 1667 1668 Policy := Getc; 1669 Skip_Space; 1670 First_Prio := Get_Nat; 1671 Last_Prio := Get_Nat; 1672 Line_No := Get_Nat; 1673 1674 Specific_Dispatching.Append ( 1675 (Dispatching_Policy => Policy, 1676 First_Priority => First_Prio, 1677 Last_Priority => Last_Prio, 1678 PSD_Pragma_Line => Line_No)); 1679 1680 ALIs.Table (Id).Last_Specific_Dispatching := 1681 Specific_Dispatching.Last; 1682 1683 Skip_Eol; 1684 end; 1685 end if; 1686 1687 C := Getc; 1688 end loop; 1689 1690 -- Loop to acquire unit entries 1691 1692 U_Loop : loop 1693 Check_Unknown_Line; 1694 exit U_Loop when C /= 'U'; 1695 1696 -- Note: as per spec, we never ignore U lines 1697 1698 Checkc (' '); 1699 Skip_Space; 1700 Units.Increment_Last; 1701 1702 if ALIs.Table (Id).First_Unit = No_Unit_Id then 1703 ALIs.Table (Id).First_Unit := Units.Last; 1704 end if; 1705 1706 declare 1707 UL : Unit_Record renames Units.Table (Units.Last); 1708 1709 begin 1710 UL.Uname := Get_Unit_Name; 1711 UL.Predefined := Is_Predefined_Unit; 1712 UL.Internal := Is_Internal_Unit; 1713 UL.My_ALI := Id; 1714 UL.Sfile := Get_File_Name (Lower => True); 1715 UL.Pure := False; 1716 UL.Preelab := False; 1717 UL.No_Elab := False; 1718 UL.Shared_Passive := False; 1719 UL.RCI := False; 1720 UL.Remote_Types := False; 1721 UL.Serious_Errors := False; 1722 UL.Has_RACW := False; 1723 UL.Init_Scalars := False; 1724 UL.Is_Generic := False; 1725 UL.Icasing := Mixed_Case; 1726 UL.Kcasing := All_Lower_Case; 1727 UL.Dynamic_Elab := False; 1728 UL.Elaborate_Body := False; 1729 UL.Set_Elab_Entity := False; 1730 UL.Version := "00000000"; 1731 UL.First_With := Withs.Last + 1; 1732 UL.First_Arg := First_Arg; 1733 UL.Elab_Position := 0; 1734 UL.SAL_Interface := ALIs.Table (Id).SAL_Interface; 1735 UL.Directly_Scanned := Directly_Scanned; 1736 UL.Body_Needed_For_SAL := False; 1737 UL.Elaborate_Body_Desirable := False; 1738 UL.Optimize_Alignment := 'O'; 1739 UL.Has_Finalizer := False; 1740 1741 if Debug_Flag_U then 1742 Write_Str (" ----> reading unit "); 1743 Write_Int (Int (Units.Last)); 1744 Write_Str (" "); 1745 Write_Unit_Name (UL.Uname); 1746 Write_Str (" from file "); 1747 Write_Name (UL.Sfile); 1748 Write_Eol; 1749 end if; 1750 end; 1751 1752 -- Check for duplicated unit in different files 1753 1754 declare 1755 Info : constant Int := Get_Name_Table_Int 1756 (Units.Table (Units.Last).Uname); 1757 begin 1758 if Info /= 0 1759 and then Units.Table (Units.Last).Sfile /= 1760 Units.Table (Unit_Id (Info)).Sfile 1761 then 1762 -- If Err is set then ignore duplicate unit name. This is the 1763 -- case of a call from gnatmake, where the situation can arise 1764 -- from substitution of source files. In such situations, the 1765 -- processing in gnatmake will always result in any required 1766 -- recompilations in any case, and if we consider this to be 1767 -- an error we get strange cases (for example when a generic 1768 -- instantiation is replaced by a normal package) where we 1769 -- read the old ali file, decide to recompile, and then decide 1770 -- that the old and new ali files are incompatible. 1771 1772 if Err then 1773 null; 1774 1775 -- If Err is not set, then this is a fatal error. This is 1776 -- the case of being called from the binder, where we must 1777 -- definitely diagnose this as an error. 1778 1779 else 1780 Set_Standard_Error; 1781 Write_Str ("error: duplicate unit name: "); 1782 Write_Eol; 1783 1784 Write_Str ("error: unit """); 1785 Write_Unit_Name (Units.Table (Units.Last).Uname); 1786 Write_Str (""" found in file """); 1787 Write_Name_Decoded (Units.Table (Units.Last).Sfile); 1788 Write_Char ('"'); 1789 Write_Eol; 1790 1791 Write_Str ("error: unit """); 1792 Write_Unit_Name (Units.Table (Unit_Id (Info)).Uname); 1793 Write_Str (""" found in file """); 1794 Write_Name_Decoded (Units.Table (Unit_Id (Info)).Sfile); 1795 Write_Char ('"'); 1796 Write_Eol; 1797 1798 Exit_Program (E_Fatal); 1799 end if; 1800 end if; 1801 end; 1802 1803 Set_Name_Table_Int 1804 (Units.Table (Units.Last).Uname, Int (Units.Last)); 1805 1806 -- Scan out possible version and other parameters 1807 1808 loop 1809 Skip_Space; 1810 exit when At_Eol; 1811 C := Getc; 1812 1813 -- Version field 1814 1815 if C in '0' .. '9' or else C in 'a' .. 'f' then 1816 Units.Table (Units.Last).Version (1) := C; 1817 1818 for J in 2 .. 8 loop 1819 C := Getc; 1820 Units.Table (Units.Last).Version (J) := C; 1821 end loop; 1822 1823 -- BD/BN parameters 1824 1825 elsif C = 'B' then 1826 C := Getc; 1827 1828 if C = 'D' then 1829 Check_At_End_Of_Field; 1830 Units.Table (Units.Last).Elaborate_Body_Desirable := True; 1831 1832 elsif C = 'N' then 1833 Check_At_End_Of_Field; 1834 Units.Table (Units.Last).Body_Needed_For_SAL := True; 1835 1836 else 1837 Fatal_Error_Ignore; 1838 end if; 1839 1840 -- DE parameter (Dynamic elaboration checks) 1841 1842 elsif C = 'D' then 1843 C := Getc; 1844 1845 if C = 'E' then 1846 Check_At_End_Of_Field; 1847 Units.Table (Units.Last).Dynamic_Elab := True; 1848 Dynamic_Elaboration_Checks_Specified := True; 1849 else 1850 Fatal_Error_Ignore; 1851 end if; 1852 1853 -- EB/EE parameters 1854 1855 elsif C = 'E' then 1856 C := Getc; 1857 1858 if C = 'B' then 1859 Units.Table (Units.Last).Elaborate_Body := True; 1860 elsif C = 'E' then 1861 Units.Table (Units.Last).Set_Elab_Entity := True; 1862 else 1863 Fatal_Error_Ignore; 1864 end if; 1865 1866 Check_At_End_Of_Field; 1867 1868 -- GE parameter (generic) 1869 1870 elsif C = 'G' then 1871 C := Getc; 1872 1873 if C = 'E' then 1874 Check_At_End_Of_Field; 1875 Units.Table (Units.Last).Is_Generic := True; 1876 else 1877 Fatal_Error_Ignore; 1878 end if; 1879 1880 -- IL/IS/IU parameters 1881 1882 elsif C = 'I' then 1883 C := Getc; 1884 1885 if C = 'L' then 1886 Units.Table (Units.Last).Icasing := All_Lower_Case; 1887 elsif C = 'S' then 1888 Units.Table (Units.Last).Init_Scalars := True; 1889 Initialize_Scalars_Used := True; 1890 elsif C = 'U' then 1891 Units.Table (Units.Last).Icasing := All_Upper_Case; 1892 else 1893 Fatal_Error_Ignore; 1894 end if; 1895 1896 Check_At_End_Of_Field; 1897 1898 -- KM/KU parameters 1899 1900 elsif C = 'K' then 1901 C := Getc; 1902 1903 if C = 'M' then 1904 Units.Table (Units.Last).Kcasing := Mixed_Case; 1905 elsif C = 'U' then 1906 Units.Table (Units.Last).Kcasing := All_Upper_Case; 1907 else 1908 Fatal_Error_Ignore; 1909 end if; 1910 1911 Check_At_End_Of_Field; 1912 1913 -- NE parameter 1914 1915 elsif C = 'N' then 1916 C := Getc; 1917 1918 if C = 'E' then 1919 Units.Table (Units.Last).No_Elab := True; 1920 Check_At_End_Of_Field; 1921 else 1922 Fatal_Error_Ignore; 1923 end if; 1924 1925 -- PF/PR/PU/PK parameters 1926 1927 elsif C = 'P' then 1928 C := Getc; 1929 1930 if C = 'F' then 1931 Units.Table (Units.Last).Has_Finalizer := True; 1932 elsif C = 'R' then 1933 Units.Table (Units.Last).Preelab := True; 1934 elsif C = 'U' then 1935 Units.Table (Units.Last).Pure := True; 1936 elsif C = 'K' then 1937 Units.Table (Units.Last).Unit_Kind := 'p'; 1938 else 1939 Fatal_Error_Ignore; 1940 end if; 1941 1942 Check_At_End_Of_Field; 1943 1944 -- OL/OO/OS/OT parameters 1945 1946 elsif C = 'O' then 1947 C := Getc; 1948 1949 if C = 'L' or else C = 'O' or else C = 'S' or else C = 'T' then 1950 Units.Table (Units.Last).Optimize_Alignment := C; 1951 else 1952 Fatal_Error_Ignore; 1953 end if; 1954 1955 Check_At_End_Of_Field; 1956 1957 -- RC/RT parameters 1958 1959 elsif C = 'R' then 1960 C := Getc; 1961 1962 if C = 'C' then 1963 Units.Table (Units.Last).RCI := True; 1964 elsif C = 'T' then 1965 Units.Table (Units.Last).Remote_Types := True; 1966 elsif C = 'A' then 1967 Units.Table (Units.Last).Has_RACW := True; 1968 else 1969 Fatal_Error_Ignore; 1970 end if; 1971 1972 Check_At_End_Of_Field; 1973 1974 -- SE/SP/SU parameters 1975 1976 elsif C = 'S' then 1977 C := Getc; 1978 1979 if C = 'E' then 1980 Units.Table (Units.Last).Serious_Errors := True; 1981 elsif C = 'P' then 1982 Units.Table (Units.Last).Shared_Passive := True; 1983 elsif C = 'U' then 1984 Units.Table (Units.Last).Unit_Kind := 's'; 1985 else 1986 Fatal_Error_Ignore; 1987 end if; 1988 1989 Check_At_End_Of_Field; 1990 1991 else 1992 C := Getc; 1993 Fatal_Error_Ignore; 1994 end if; 1995 end loop; 1996 1997 Skip_Eol; 1998 1999 -- Check if static elaboration model used 2000 2001 if not Units.Table (Units.Last).Dynamic_Elab 2002 and then not Units.Table (Units.Last).Internal 2003 then 2004 Static_Elaboration_Model_Used := True; 2005 end if; 2006 2007 C := Getc; 2008 2009 -- Scan out With lines for this unit 2010 2011 With_Loop : loop 2012 Check_Unknown_Line; 2013 exit With_Loop when C /= 'W' and then C /= 'Y' and then C /= 'Z'; 2014 2015 if Ignore ('W') then 2016 Skip_Line; 2017 2018 else 2019 Checkc (' '); 2020 Skip_Space; 2021 Withs.Increment_Last; 2022 Withs.Table (Withs.Last).Uname := Get_Unit_Name; 2023 Withs.Table (Withs.Last).Elaborate := False; 2024 Withs.Table (Withs.Last).Elaborate_All := False; 2025 Withs.Table (Withs.Last).Elab_Desirable := False; 2026 Withs.Table (Withs.Last).Elab_All_Desirable := False; 2027 Withs.Table (Withs.Last).SAL_Interface := False; 2028 Withs.Table (Withs.Last).Limited_With := (C = 'Y'); 2029 Withs.Table (Withs.Last).Implicit_With_From_Instantiation 2030 := (C = 'Z'); 2031 2032 -- Generic case with no object file available 2033 2034 if At_Eol then 2035 Withs.Table (Withs.Last).Sfile := No_File; 2036 Withs.Table (Withs.Last).Afile := No_File; 2037 2038 -- Normal case 2039 2040 else 2041 Withs.Table (Withs.Last).Sfile := Get_File_Name 2042 (Lower => True); 2043 Withs.Table (Withs.Last).Afile := Get_File_Name 2044 (Lower => True); 2045 2046 -- Scan out possible E, EA, ED, and AD parameters 2047 2048 while not At_Eol loop 2049 Skip_Space; 2050 2051 if Nextc = 'A' then 2052 P := P + 1; 2053 Checkc ('D'); 2054 Check_At_End_Of_Field; 2055 2056 -- Store AD indication unless ignore required 2057 2058 if not Ignore_ED then 2059 Withs.Table (Withs.Last).Elab_All_Desirable := 2060 True; 2061 end if; 2062 2063 elsif Nextc = 'E' then 2064 P := P + 1; 2065 2066 if At_End_Of_Field then 2067 Withs.Table (Withs.Last).Elaborate := True; 2068 2069 elsif Nextc = 'A' then 2070 P := P + 1; 2071 Check_At_End_Of_Field; 2072 Withs.Table (Withs.Last).Elaborate_All := True; 2073 2074 else 2075 Checkc ('D'); 2076 Check_At_End_Of_Field; 2077 2078 -- Store ED indication unless ignore required 2079 2080 if not Ignore_ED then 2081 Withs.Table (Withs.Last).Elab_Desirable := 2082 True; 2083 end if; 2084 end if; 2085 2086 else 2087 Fatal_Error; 2088 end if; 2089 end loop; 2090 end if; 2091 2092 Skip_Eol; 2093 end if; 2094 2095 C := Getc; 2096 end loop With_Loop; 2097 2098 Units.Table (Units.Last).Last_With := Withs.Last; 2099 Units.Table (Units.Last).Last_Arg := Args.Last; 2100 2101 -- If there are linker options lines present, scan them 2102 2103 Name_Len := 0; 2104 2105 Linker_Options_Loop : loop 2106 Check_Unknown_Line; 2107 exit Linker_Options_Loop when C /= 'L'; 2108 2109 if Ignore ('L') then 2110 Skip_Line; 2111 2112 else 2113 Checkc (' '); 2114 Skip_Space; 2115 Checkc ('"'); 2116 2117 loop 2118 C := Getc; 2119 2120 if C < Character'Val (16#20#) 2121 or else C > Character'Val (16#7E#) 2122 then 2123 Fatal_Error_Ignore; 2124 2125 elsif C = '{' then 2126 C := Character'Val (0); 2127 2128 declare 2129 V : Natural; 2130 2131 begin 2132 V := 0; 2133 for J in 1 .. 2 loop 2134 C := Getc; 2135 2136 if C in '0' .. '9' then 2137 V := V * 16 + 2138 Character'Pos (C) - 2139 Character'Pos ('0'); 2140 2141 elsif C in 'A' .. 'F' then 2142 V := V * 16 + 2143 Character'Pos (C) - 2144 Character'Pos ('A') + 2145 10; 2146 2147 else 2148 Fatal_Error_Ignore; 2149 end if; 2150 end loop; 2151 2152 Checkc ('}'); 2153 Add_Char_To_Name_Buffer (Character'Val (V)); 2154 end; 2155 2156 else 2157 if C = '"' then 2158 exit when Nextc /= '"'; 2159 C := Getc; 2160 end if; 2161 2162 Add_Char_To_Name_Buffer (C); 2163 end if; 2164 end loop; 2165 2166 Add_Char_To_Name_Buffer (NUL); 2167 Skip_Eol; 2168 end if; 2169 2170 C := Getc; 2171 end loop Linker_Options_Loop; 2172 2173 -- Store the linker options entry if one was found 2174 2175 if Name_Len /= 0 then 2176 Linker_Options.Increment_Last; 2177 2178 Linker_Options.Table (Linker_Options.Last).Name := 2179 Name_Enter; 2180 2181 Linker_Options.Table (Linker_Options.Last).Unit := 2182 Units.Last; 2183 2184 Linker_Options.Table (Linker_Options.Last).Internal_File := 2185 Is_Internal_File_Name (F); 2186 2187 Linker_Options.Table (Linker_Options.Last).Original_Pos := 2188 Linker_Options.Last; 2189 end if; 2190 2191 -- If there are notes present, scan them 2192 2193 Notes_Loop : loop 2194 Check_Unknown_Line; 2195 exit Notes_Loop when C /= 'N'; 2196 2197 if Ignore ('N') then 2198 Skip_Line; 2199 2200 else 2201 Checkc (' '); 2202 2203 Notes.Increment_Last; 2204 Notes.Table (Notes.Last).Pragma_Type := Getc; 2205 Notes.Table (Notes.Last).Pragma_Line := Get_Nat; 2206 Checkc (':'); 2207 Notes.Table (Notes.Last).Pragma_Col := Get_Nat; 2208 2209 if not At_Eol and then Nextc = ':' then 2210 Checkc (':'); 2211 Notes.Table (Notes.Last).Pragma_Source_File := 2212 Get_File_Name (Lower => True); 2213 else 2214 Notes.Table (Notes.Last).Pragma_Source_File := 2215 Units.Table (Units.Last).Sfile; 2216 end if; 2217 2218 if At_Eol then 2219 Notes.Table (Notes.Last).Pragma_Args := No_Name; 2220 2221 else 2222 -- Note: can't use Get_Name here as the remainder of the 2223 -- line is unstructured text whose syntax depends on the 2224 -- particular pragma used. 2225 2226 Checkc (' '); 2227 2228 Name_Len := 0; 2229 while not At_Eol loop 2230 Add_Char_To_Name_Buffer (Getc); 2231 end loop; 2232 end if; 2233 2234 Skip_Eol; 2235 end if; 2236 2237 C := Getc; 2238 end loop Notes_Loop; 2239 end loop U_Loop; 2240 2241 -- End loop through units for one ALI file 2242 2243 ALIs.Table (Id).Last_Unit := Units.Last; 2244 ALIs.Table (Id).Sfile := Units.Table (ALIs.Table (Id).First_Unit).Sfile; 2245 2246 -- Set types of the units (there can be at most 2 of them) 2247 2248 if ALIs.Table (Id).First_Unit /= ALIs.Table (Id).Last_Unit then 2249 Units.Table (ALIs.Table (Id).First_Unit).Utype := Is_Body; 2250 Units.Table (ALIs.Table (Id).Last_Unit).Utype := Is_Spec; 2251 2252 else 2253 -- Deal with body only and spec only cases, note that the reason we 2254 -- do our own checking of the name (rather than using Is_Body_Name) 2255 -- is that Uname drags in far too much compiler junk. 2256 2257 Get_Name_String (Units.Table (Units.Last).Uname); 2258 2259 if Name_Buffer (Name_Len) = 'b' then 2260 Units.Table (Units.Last).Utype := Is_Body_Only; 2261 else 2262 Units.Table (Units.Last).Utype := Is_Spec_Only; 2263 end if; 2264 end if; 2265 2266 -- Scan out external version references and put in hash table 2267 2268 E_Loop : loop 2269 Check_Unknown_Line; 2270 exit E_Loop when C /= 'E'; 2271 2272 if Ignore ('E') then 2273 Skip_Line; 2274 2275 else 2276 Checkc (' '); 2277 Skip_Space; 2278 2279 Name_Len := 0; 2280 Name_Len := 0; 2281 loop 2282 C := Getc; 2283 2284 if C < ' ' then 2285 Fatal_Error; 2286 end if; 2287 2288 exit when At_End_Of_Field; 2289 Add_Char_To_Name_Buffer (C); 2290 end loop; 2291 2292 Version_Ref.Set (new String'(Name_Buffer (1 .. Name_Len)), True); 2293 Skip_Eol; 2294 end if; 2295 2296 C := Getc; 2297 end loop E_Loop; 2298 2299 -- Scan out source dependency lines for this ALI file 2300 2301 ALIs.Table (Id).First_Sdep := Sdep.Last + 1; 2302 2303 D_Loop : loop 2304 Check_Unknown_Line; 2305 exit D_Loop when C /= 'D'; 2306 2307 if Ignore ('D') then 2308 Skip_Line; 2309 2310 else 2311 Checkc (' '); 2312 Skip_Space; 2313 Sdep.Increment_Last; 2314 2315 -- In the following call, Lower is not set to True, this is either 2316 -- a bug, or it deserves a special comment as to why this is so??? 2317 2318 -- The file/path name may be quoted 2319 2320 Sdep.Table (Sdep.Last).Sfile := 2321 Get_File_Name (May_Be_Quoted => True); 2322 2323 Sdep.Table (Sdep.Last).Stamp := Get_Stamp; 2324 Sdep.Table (Sdep.Last).Dummy_Entry := 2325 (Sdep.Table (Sdep.Last).Stamp = Dummy_Time_Stamp); 2326 2327 -- Acquire checksum value 2328 2329 Skip_Space; 2330 2331 declare 2332 Ctr : Natural; 2333 Chk : Word; 2334 2335 begin 2336 Ctr := 0; 2337 Chk := 0; 2338 2339 loop 2340 exit when At_Eol or else Ctr = 8; 2341 2342 if Nextc in '0' .. '9' then 2343 Chk := Chk * 16 + 2344 Character'Pos (Nextc) - Character'Pos ('0'); 2345 2346 elsif Nextc in 'a' .. 'f' then 2347 Chk := Chk * 16 + 2348 Character'Pos (Nextc) - Character'Pos ('a') + 10; 2349 2350 else 2351 exit; 2352 end if; 2353 2354 Ctr := Ctr + 1; 2355 P := P + 1; 2356 end loop; 2357 2358 if Ctr = 8 and then At_End_Of_Field then 2359 Sdep.Table (Sdep.Last).Checksum := Chk; 2360 else 2361 Fatal_Error; 2362 end if; 2363 end; 2364 2365 -- Acquire (sub)unit and reference file name entries 2366 2367 Sdep.Table (Sdep.Last).Subunit_Name := No_Name; 2368 Sdep.Table (Sdep.Last).Unit_Name := No_Name; 2369 Sdep.Table (Sdep.Last).Rfile := 2370 Sdep.Table (Sdep.Last).Sfile; 2371 Sdep.Table (Sdep.Last).Start_Line := 1; 2372 2373 if not At_Eol then 2374 Skip_Space; 2375 2376 -- Here for (sub)unit name 2377 2378 if Nextc not in '0' .. '9' then 2379 Name_Len := 0; 2380 while not At_End_Of_Field loop 2381 Add_Char_To_Name_Buffer (Getc); 2382 end loop; 2383 2384 -- Set the (sub)unit name. Note that we use Name_Find rather 2385 -- than Name_Enter here as the subunit name may already 2386 -- have been put in the name table by the Project Manager. 2387 2388 if Name_Len <= 2 2389 or else Name_Buffer (Name_Len - 1) /= '%' 2390 then 2391 Sdep.Table (Sdep.Last).Subunit_Name := Name_Find; 2392 else 2393 Name_Len := Name_Len - 2; 2394 Sdep.Table (Sdep.Last).Unit_Name := Name_Find; 2395 end if; 2396 2397 Skip_Space; 2398 end if; 2399 2400 -- Here for reference file name entry 2401 2402 if Nextc in '0' .. '9' then 2403 Sdep.Table (Sdep.Last).Start_Line := Get_Nat; 2404 Checkc (':'); 2405 2406 Name_Len := 0; 2407 2408 while not At_End_Of_Field loop 2409 Add_Char_To_Name_Buffer (Getc); 2410 end loop; 2411 2412 Sdep.Table (Sdep.Last).Rfile := Name_Enter; 2413 end if; 2414 end if; 2415 2416 Skip_Eol; 2417 end if; 2418 2419 C := Getc; 2420 end loop D_Loop; 2421 2422 ALIs.Table (Id).Last_Sdep := Sdep.Last; 2423 2424 -- We must at this stage be at an Xref line or the end of file 2425 2426 if C = EOF then 2427 return Id; 2428 end if; 2429 2430 Check_Unknown_Line; 2431 2432 if C /= 'X' then 2433 Fatal_Error; 2434 end if; 2435 2436 -- If we are ignoring Xref sections we are done (we ignore all 2437 -- remaining lines since only xref related lines follow X). 2438 2439 if Ignore ('X') and then not Debug_Flag_X then 2440 return Id; 2441 end if; 2442 2443 -- Loop through Xref sections 2444 2445 X_Loop : loop 2446 Check_Unknown_Line; 2447 exit X_Loop when C /= 'X'; 2448 2449 -- Make new entry in section table 2450 2451 Xref_Section.Increment_Last; 2452 2453 Read_Refs_For_One_File : declare 2454 XS : Xref_Section_Record renames 2455 Xref_Section.Table (Xref_Section.Last); 2456 2457 Current_File_Num : Sdep_Id; 2458 -- Keeps track of the current file number (changed by nn|) 2459 2460 begin 2461 XS.File_Num := Sdep_Id (Get_Nat + Nat (First_Sdep_Entry) - 1); 2462 XS.File_Name := Get_File_Name; 2463 XS.First_Entity := Xref_Entity.Last + 1; 2464 2465 Current_File_Num := XS.File_Num; 2466 2467 Skip_Space; 2468 2469 Skip_Eol; 2470 C := Nextc; 2471 2472 -- Loop through Xref entities 2473 2474 while C /= 'X' and then C /= EOF loop 2475 Xref_Entity.Increment_Last; 2476 2477 Read_Refs_For_One_Entity : declare 2478 XE : Xref_Entity_Record renames 2479 Xref_Entity.Table (Xref_Entity.Last); 2480 N : Nat; 2481 2482 procedure Read_Instantiation_Reference; 2483 -- Acquire instantiation reference. Caller has checked 2484 -- that current character is '[' and on return the cursor 2485 -- is skipped past the corresponding closing ']'. 2486 2487 ---------------------------------- 2488 -- Read_Instantiation_Reference -- 2489 ---------------------------------- 2490 2491 procedure Read_Instantiation_Reference is 2492 Local_File_Num : Sdep_Id := Current_File_Num; 2493 2494 begin 2495 Xref.Increment_Last; 2496 2497 declare 2498 XR : Xref_Record renames Xref.Table (Xref.Last); 2499 2500 begin 2501 P := P + 1; -- skip [ 2502 N := Get_Nat; 2503 2504 if Nextc = '|' then 2505 XR.File_Num := 2506 Sdep_Id (N + Nat (First_Sdep_Entry) - 1); 2507 Local_File_Num := XR.File_Num; 2508 P := P + 1; 2509 N := Get_Nat; 2510 2511 else 2512 XR.File_Num := Local_File_Num; 2513 end if; 2514 2515 XR.Line := N; 2516 XR.Rtype := ' '; 2517 XR.Col := 0; 2518 2519 -- Recursive call for next reference 2520 2521 if Nextc = '[' then 2522 pragma Warnings (Off); -- kill recursion warning 2523 Read_Instantiation_Reference; 2524 pragma Warnings (On); 2525 end if; 2526 2527 -- Skip closing bracket after recursive call 2528 2529 P := P + 1; 2530 end; 2531 end Read_Instantiation_Reference; 2532 2533 -- Start of processing for Read_Refs_For_One_Entity 2534 2535 begin 2536 XE.Line := Get_Nat; 2537 XE.Etype := Getc; 2538 XE.Col := Get_Nat; 2539 2540 case Getc is 2541 when '*' => 2542 XE.Visibility := Global; 2543 when '+' => 2544 XE.Visibility := Static; 2545 when others => 2546 XE.Visibility := Other; 2547 end case; 2548 2549 XE.Entity := Get_Name; 2550 2551 -- Handle the information about generic instantiations 2552 2553 if Nextc = '[' then 2554 Skipc; -- Opening '[' 2555 N := Get_Nat; 2556 2557 if Nextc /= '|' then 2558 XE.Iref_File_Num := Current_File_Num; 2559 XE.Iref_Line := N; 2560 else 2561 XE.Iref_File_Num := 2562 Sdep_Id (N + Nat (First_Sdep_Entry) - 1); 2563 Skipc; 2564 XE.Iref_Line := Get_Nat; 2565 end if; 2566 2567 if Getc /= ']' then 2568 Fatal_Error; 2569 end if; 2570 2571 else 2572 XE.Iref_File_Num := No_Sdep_Id; 2573 XE.Iref_Line := 0; 2574 end if; 2575 2576 Current_File_Num := XS.File_Num; 2577 2578 -- Renaming reference is present 2579 2580 if Nextc = '=' then 2581 P := P + 1; 2582 XE.Rref_Line := Get_Nat; 2583 2584 if Getc /= ':' then 2585 Fatal_Error; 2586 end if; 2587 2588 XE.Rref_Col := Get_Nat; 2589 2590 -- No renaming reference present 2591 2592 else 2593 XE.Rref_Line := 0; 2594 XE.Rref_Col := 0; 2595 end if; 2596 2597 Skip_Space; 2598 2599 XE.Oref_File_Num := No_Sdep_Id; 2600 XE.Tref_File_Num := No_Sdep_Id; 2601 XE.Tref := Tref_None; 2602 XE.First_Xref := Xref.Last + 1; 2603 2604 -- Loop to check for additional info present 2605 2606 loop 2607 declare 2608 Ref : Tref_Kind; 2609 File : Sdep_Id; 2610 Line : Nat; 2611 Typ : Character; 2612 Col : Nat; 2613 Std : Name_Id; 2614 2615 begin 2616 Get_Typeref 2617 (Current_File_Num, Ref, File, Line, Typ, Col, Std); 2618 exit when Ref = Tref_None; 2619 2620 -- Do we have an overriding procedure? 2621 2622 if Ref = Tref_Derived and then Typ = 'p' then 2623 XE.Oref_File_Num := File; 2624 XE.Oref_Line := Line; 2625 XE.Oref_Col := Col; 2626 2627 -- Arrays never override anything, and <> points to 2628 -- the index types instead 2629 2630 elsif Ref = Tref_Derived and then XE.Etype = 'A' then 2631 2632 -- Index types are stored in the list of references 2633 2634 Xref.Increment_Last; 2635 2636 declare 2637 XR : Xref_Record renames Xref.Table (Xref.Last); 2638 begin 2639 XR.File_Num := File; 2640 XR.Line := Line; 2641 XR.Rtype := Array_Index_Reference; 2642 XR.Col := Col; 2643 XR.Name := Std; 2644 end; 2645 2646 -- Interfaces are stored in the list of references, 2647 -- although the parent type itself is stored in XE. 2648 -- The first interface (when there are only 2649 -- interfaces) is stored in XE.Tref*) 2650 2651 elsif Ref = Tref_Derived 2652 and then Typ = 'R' 2653 and then XE.Tref_File_Num /= No_Sdep_Id 2654 then 2655 Xref.Increment_Last; 2656 2657 declare 2658 XR : Xref_Record renames Xref.Table (Xref.Last); 2659 begin 2660 XR.File_Num := File; 2661 XR.Line := Line; 2662 XR.Rtype := Interface_Reference; 2663 XR.Col := Col; 2664 XR.Name := Std; 2665 end; 2666 2667 else 2668 XE.Tref := Ref; 2669 XE.Tref_File_Num := File; 2670 XE.Tref_Line := Line; 2671 XE.Tref_Type := Typ; 2672 XE.Tref_Col := Col; 2673 XE.Tref_Standard_Entity := Std; 2674 end if; 2675 end; 2676 end loop; 2677 2678 -- Loop through cross-references for this entity 2679 2680 loop 2681 Skip_Space; 2682 2683 if At_Eol then 2684 Skip_Eol; 2685 exit when Nextc /= '.'; 2686 P := P + 1; 2687 end if; 2688 2689 Xref.Increment_Last; 2690 2691 declare 2692 XR : Xref_Record renames Xref.Table (Xref.Last); 2693 2694 begin 2695 N := Get_Nat; 2696 2697 if Nextc = '|' then 2698 XR.File_Num := 2699 Sdep_Id (N + Nat (First_Sdep_Entry) - 1); 2700 Current_File_Num := XR.File_Num; 2701 P := P + 1; 2702 N := Get_Nat; 2703 else 2704 XR.File_Num := Current_File_Num; 2705 end if; 2706 2707 XR.Line := N; 2708 XR.Rtype := Getc; 2709 2710 -- Imported entities reference as in: 2711 -- 494b<c,__gnat_copy_attribs>25 2712 2713 if Nextc = '<' then 2714 Skipc; 2715 XR.Imported_Lang := Get_Name; 2716 2717 pragma Assert (Nextc = ','); 2718 Skipc; 2719 2720 XR.Imported_Name := Get_Name; 2721 2722 pragma Assert (Nextc = '>'); 2723 Skipc; 2724 2725 else 2726 XR.Imported_Lang := No_Name; 2727 XR.Imported_Name := No_Name; 2728 end if; 2729 2730 XR.Col := Get_Nat; 2731 2732 if Nextc = '[' then 2733 Read_Instantiation_Reference; 2734 end if; 2735 end; 2736 end loop; 2737 2738 -- Record last cross-reference 2739 2740 XE.Last_Xref := Xref.Last; 2741 C := Nextc; 2742 2743 exception 2744 when Bad_ALI_Format => 2745 2746 -- If ignoring errors, then we skip a line with an 2747 -- unexpected error, and try to continue subsequent 2748 -- xref lines. 2749 2750 if Ignore_Errors then 2751 Xref_Entity.Decrement_Last; 2752 Skip_Line; 2753 C := Nextc; 2754 2755 -- Otherwise, we reraise the fatal exception 2756 2757 else 2758 raise; 2759 end if; 2760 end Read_Refs_For_One_Entity; 2761 end loop; 2762 2763 -- Record last entity 2764 2765 XS.Last_Entity := Xref_Entity.Last; 2766 2767 end Read_Refs_For_One_File; 2768 2769 C := Getc; 2770 end loop X_Loop; 2771 2772 -- Here after dealing with xref sections 2773 2774 -- Ignore remaining lines, which belong to an additional section of the 2775 -- ALI file not considered here (like SCO or SPARK information). 2776 2777 Check_Unknown_Line; 2778 2779 return Id; 2780 2781 exception 2782 when Bad_ALI_Format => 2783 return No_ALI_Id; 2784 end Scan_ALI; 2785 2786 --------- 2787 -- SEq -- 2788 --------- 2789 2790 function SEq (F1, F2 : String_Ptr) return Boolean is 2791 begin 2792 return F1.all = F2.all; 2793 end SEq; 2794 2795 ----------- 2796 -- SHash -- 2797 ----------- 2798 2799 function SHash (S : String_Ptr) return Vindex is 2800 H : Word; 2801 2802 begin 2803 H := 0; 2804 for J in S.all'Range loop 2805 H := H * 2 + Character'Pos (S (J)); 2806 end loop; 2807 2808 return Vindex (Vindex'First + Vindex (H mod Vindex'Range_Length)); 2809 end SHash; 2810 2811end ALI; 2812