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