gcc/ada/ali.adb

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