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