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