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