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