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