gcc/ada/ali.adb

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