ali.adb   [plain text]

------------------------------------------------------------------------------
--                                                                          --
--                         GNAT COMPILER COMPONENTS                         --
--                                                                          --
--                                  A L I                                   --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--                                                                          --
--          Copyright (C) 1992-2001 Free Software Foundation, Inc.          --
--                                                                          --
-- GNAT is free software;  you can  redistribute it  and/or modify it under --
-- terms of the  GNU General Public License as published  by the Free Soft- --
-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
-- for  more details.  You should have  received  a copy of the GNU General --
-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
-- MA 02111-1307, USA.                                                      --
--                                                                          --
-- GNAT was originally developed  by the GNAT team at  New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc.      --
--                                                                          --
------------------------------------------------------------------------------

with Butil;   use Butil;
with Debug;   use Debug;
with Fname;   use Fname;
with Namet;   use Namet;
with Osint;   use Osint;
with Output;  use Output;

package body ALI is

   use ASCII;
   --  Make control characters visible

   --------------------
   -- Initialize_ALI --
   --------------------

   procedure Initialize_ALI is
   begin
      --  When (re)initializing ALI data structures the ALI user expects to
      --  get a fresh set of data structures. Thus we first need to erase the
      --  marks put in the name table by the previous set of ALI routine calls.
      --  This loop is empty and harmless the first time in.

      for J in ALIs.First .. ALIs.Last loop
         Set_Name_Table_Info (ALIs.Table (J).Afile, 0);
      end loop;

      ALIs.Init;
      Units.Init;
      Withs.Init;
      Sdep.Init;
      Linker_Options.Init;
      Xref_Section.Init;
      Xref_Entity.Init;
      Xref.Init;
      Version_Ref.Reset;

      --  Add dummy zero'th item in Linker_Options for the sort function

      Linker_Options.Increment_Last;

      --  Initialize global variables recording cumulative options in all
      --  ALI files that are read for a given processing run in gnatbind.

      Dynamic_Elaboration_Checks_Specified := False;
      Float_Format_Specified               := ' ';
      Locking_Policy_Specified             := ' ';
      No_Normalize_Scalars_Specified       := False;
      No_Object_Specified                  := False;
      Normalize_Scalars_Specified          := False;
      No_Run_Time_Specified                := False;
      Queuing_Policy_Specified             := ' ';
      Static_Elaboration_Model_Used        := False;
      Task_Dispatching_Policy_Specified    := ' ';
      Unreserve_All_Interrupts_Specified   := False;
      Zero_Cost_Exceptions_Specified       := False;

   end Initialize_ALI;

   --------------
   -- Scan_ALI --
   --------------

   function Scan_ALI
     (F         : File_Name_Type;
      T         : Text_Buffer_Ptr;
      Ignore_ED : Boolean;
      Err       : Boolean;
      Read_Xref : Boolean := False)
      return      ALI_Id
   is
      P         : Text_Ptr := T'First;
      Line      : Logical_Line_Number := 1;
      Id        : ALI_Id;
      C         : Character;
      NS_Found  : Boolean;
      First_Arg : Arg_Id;

      function At_Eol return Boolean;
      --  Test if at end of line

      function At_End_Of_Field return Boolean;
      --  Test if at end of line, or if at blank or horizontal tab

      procedure Check_At_End_Of_Field;
      --  Check if we are at end of field, fatal error if not

      procedure Checkc (C : Character);
      --  Check next character is C. If so bump past it, if not fatal error

      Bad_ALI_Format : exception;

      procedure Fatal_Error;
      --  Generate fatal error message for badly formatted ALI file if
      --  Err is false, or raise Bad_ALI_Format if Err is True.

      function Getc return Character;
      --  Get next character, bumping P past the character obtained

      function Get_Name (Lower : Boolean := False) return Name_Id;
      --  Skip blanks, then scan out a name (name is left in Name_Buffer with
      --  length in Name_Len, as well as being returned in Name_Id form).
      --  If Lower is set to True then the Name_Buffer will be converted to
      --  all lower case, for systems where file names are not case sensitive.
      --  This ensures that gnatbind works correctly regardless of the case
      --  of the file name on all systems. The name is terminated by a either
      --  white space or a typeref bracket or an equal sign except for the
      --  special case of an operator name starting with a double quite which
      --  is terminated by another double quote.

      function Get_Nat return Nat;
      --  Skip blanks, then scan out an unsigned integer value in Nat range

      function Get_Stamp return Time_Stamp_Type;
      --  Skip blanks, then scan out a time stamp

      function Nextc return Character;
      --  Return current character without modifying pointer P

      procedure Skip_Eol;
      --  Skip past end of line (fatal error if not at end of line)

      procedure Skip_Space;
      --  Skip past white space (blanks or horizontal tab)

      ---------------------
      -- At_End_Of_Field --
      ---------------------

      function At_End_Of_Field return Boolean is
      begin
         return Nextc <= ' ';
      end At_End_Of_Field;

      ------------
      -- At_Eol --
      ------------

      function At_Eol return Boolean is
      begin
         return Nextc = EOF or else Nextc = CR or else Nextc = LF;
      end At_Eol;

      ---------------------------
      -- Check_At_End_Of_Field --
      ---------------------------

      procedure Check_At_End_Of_Field is
      begin
         if not At_End_Of_Field then
            Fatal_Error;
         end if;
      end Check_At_End_Of_Field;

      ------------
      -- Checkc --
      ------------

      procedure Checkc (C : Character) is
      begin
         if Nextc = C then
            P := P + 1;
         else
            Fatal_Error;
         end if;
      end Checkc;

      -----------------
      -- Fatal_Error --
      -----------------

      procedure Fatal_Error is
         Ptr1 : Text_Ptr;
         Ptr2 : Text_Ptr;
         Col  : Int;

         procedure Wchar (C : Character);
         --  Write a single character, replacing horizontal tab by spaces

         procedure Wchar (C : Character) is
         begin
            if C = HT then
               loop
                  Wchar (' ');
                  exit when Col mod 8 = 0;
               end loop;

            else
               Write_Char (C);
               Col := Col + 1;
            end if;
         end Wchar;

      --  Start of processing for Fatal_Error

      begin
         if Err then
            raise Bad_ALI_Format;
         end if;

         Set_Standard_Error;
         Write_Str ("fatal error: file ");
         Write_Name (F);
         Write_Str (" is incorrectly formatted");
         Write_Eol;
         Write_Str
           ("make sure you are using consistent versions of gcc/gnatbind");
         Write_Eol;

         --  Find start of line

         Ptr1 := P;

         while Ptr1 > T'First
           and then T (Ptr1 - 1) /= CR
           and then T (Ptr1 - 1) /= LF
         loop
            Ptr1 := Ptr1 - 1;
         end loop;

         Write_Int (Int (Line));
         Write_Str (". ");

         if Line < 100 then
            Write_Char (' ');
         end if;

         if Line < 10 then
            Write_Char (' ');
         end if;

         Col := 0;
         Ptr2 := Ptr1;

         while Ptr2 < T'Last
           and then T (Ptr2) /= CR
           and then T (Ptr2) /= LF
         loop
            Wchar (T (Ptr2));
            Ptr2 := Ptr2 + 1;
         end loop;

         Write_Eol;

         Write_Str ("     ");
         Col := 0;

         while Ptr1 < P loop
            if T (Ptr1) = HT then
               Wchar (HT);
            else
               Wchar (' ');
            end if;

            Ptr1 := Ptr1 + 1;
         end loop;

         Wchar ('|');
         Write_Eol;

         Exit_Program (E_Fatal);
      end Fatal_Error;

      --------------
      -- Get_Name --
      --------------

      function Get_Name (Lower : Boolean := False) return Name_Id is
      begin
         Name_Len := 0;
         Skip_Space;

         if At_Eol then
            Fatal_Error;
         end if;

         loop
            Name_Len := Name_Len + 1;
            Name_Buffer (Name_Len) := Getc;

            exit when At_End_Of_Field;

            if Name_Buffer (1) = '"' then
               exit when Name_Len > 1 and then Name_Buffer (Name_Len) = '"';

            else
               exit when At_End_Of_Field
                 or else Nextc = '(' or else Nextc = ')'
                 or else Nextc = '{' or else Nextc = '}'
                 or else Nextc = '<' or else Nextc = '>'
                 or else Nextc = '=';
            end if;
         end loop;

         --  Convert file name to all lower case if file names are not case
         --  sensitive. This ensures that we handle names in the canonical
         --  lower case format, regardless of the actual case.

         if Lower and not File_Names_Case_Sensitive then
            Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
         end if;

         return Name_Find;
      end Get_Name;

      -------------
      -- Get_Nat --
      -------------

      function Get_Nat return Nat is
         V : Nat;

      begin
         Skip_Space;

         V := 0;

         loop
            V := V * 10 + (Character'Pos (Getc) - Character'Pos ('0'));
            exit when At_End_Of_Field;
            exit when Nextc < '0' or Nextc > '9';
         end loop;

         return V;
      end Get_Nat;

      ---------------
      -- Get_Stamp --
      ---------------

      function Get_Stamp return Time_Stamp_Type is
         T     : Time_Stamp_Type;
         Start : Integer;

      begin
         Skip_Space;

         if At_Eol then
            Fatal_Error;
         end if;

         --  Following reads old style time stamp missing first two digits

         if Nextc in '7' .. '9' then
            T (1) := '1';
            T (2) := '9';
            Start := 3;

         --  Normal case of full year in time stamp

         else
            Start := 1;
         end if;

         for J in Start .. T'Last loop
            T (J) := Getc;
         end loop;

         return T;
      end Get_Stamp;

      ----------
      -- Getc --
      ----------

      function Getc return Character is
      begin
         if P = T'Last then
            return EOF;
         else
            P := P + 1;
            return T (P - 1);
         end if;
      end Getc;

      -----------
      -- Nextc --
      -----------

      function Nextc return Character is
      begin
         return T (P);
      end Nextc;

      --------------
      -- Skip_Eol --
      --------------

      procedure Skip_Eol is
      begin
         Skip_Space;
         if not At_Eol then Fatal_Error; end if;

         --  Loop to skip past blank lines (first time through skips this EOL)

         while Nextc < ' ' and then Nextc /= EOF loop
            if Nextc = LF then
               Line := Line + 1;
            end if;

            P := P + 1;
         end loop;
      end Skip_Eol;

      ----------------
      -- Skip_Space --
      ----------------

      procedure Skip_Space is
      begin
         while Nextc = ' ' or else Nextc = HT loop
            P := P + 1;
         end loop;
      end Skip_Space;

   --------------------------------------
   -- Start of processing for Scan_ALI --
   --------------------------------------

   begin
      ALIs.Increment_Last;
      Id := ALIs.Last;
      Set_Name_Table_Info (F, Int (Id));

      ALIs.Table (Id) := (
        Afile                      => F,
        Compile_Errors             => False,
        First_Sdep                 => No_Sdep_Id,
        First_Unit                 => No_Unit_Id,
        Float_Format               => 'I',
        Last_Sdep                  => No_Sdep_Id,
        Last_Unit                  => No_Unit_Id,
        Locking_Policy             => ' ',
        Main_Priority              => -1,
        Main_Program               => None,
        No_Object                  => False,
        No_Run_Time                => False,
        Normalize_Scalars          => False,
        Ofile_Full_Name            => Full_Object_File_Name,
        Queuing_Policy             => ' ',
        Restrictions               => (others => ' '),
        Sfile                      => No_Name,
        Task_Dispatching_Policy    => ' ',
        Time_Slice_Value           => -1,
        WC_Encoding                => '8',
        Unit_Exception_Table       => False,
        Ver                        => (others => ' '),
        Ver_Len                    => 0,
        Zero_Cost_Exceptions       => False);

      --  Acquire library version

      Checkc ('V');
      Checkc (' ');
      Skip_Space;
      Checkc ('"');

      for J in 1 .. Ver_Len_Max loop
         C := Getc;
         exit when C = '"';
         ALIs.Table (Id).Ver (J) := C;
         ALIs.Table (Id).Ver_Len := J;
      end loop;

      Skip_Eol;

      --  Acquire main program line if present

      C := Getc;

      if C = 'M' then
         Checkc (' ');
         Skip_Space;

         C := Getc;

         if C = 'F' then
            ALIs.Table (Id).Main_Program := Func;
         elsif C = 'P' then
            ALIs.Table (Id).Main_Program := Proc;
         else
            P := P - 1;
            Fatal_Error;
         end if;

         Skip_Space;

         if not At_Eol then
            if Nextc < 'A' then
               ALIs.Table (Id).Main_Priority := Get_Nat;
            end if;

            Skip_Space;

            if Nextc = 'T' then
               P := P + 1;
               Checkc ('=');
               ALIs.Table (Id).Time_Slice_Value := Get_Nat;
            end if;

            Skip_Space;

            Checkc ('W');
            Checkc ('=');
            ALIs.Table (Id).WC_Encoding := Getc;
         end if;

         Skip_Eol;
         C := Getc;

      end if;

      --  Acquire argument lines

      First_Arg := Args.Last + 1;

      Arg_Loop : while C = 'A' loop
         Checkc (' ');
         Name_Len := 0;

         while not At_Eol loop
            Name_Len := Name_Len + 1;
            Name_Buffer (Name_Len) := Getc;
         end loop;

         Args.Increment_Last;
         Args.Table (Args.Last) := new String'(Name_Buffer (1 .. Name_Len));

         Skip_Eol;
         C := Getc;
      end loop Arg_Loop;

      --  Acquire P line, first set defaults

      if C /= 'P' then
         Fatal_Error;
      end if;

      NS_Found := False;

      while not At_Eol loop
         Checkc (' ');
         Skip_Space;
         C := Getc;

         if C = 'C' then
            Checkc ('E');
            ALIs.Table (Id).Compile_Errors := True;

         elsif C = 'F' then
            Float_Format_Specified := Getc;
            ALIs.Table (Id).Float_Format := Float_Format_Specified;

         elsif C = 'L' then
            Locking_Policy_Specified := Getc;
            ALIs.Table (Id).Locking_Policy := Locking_Policy_Specified;

         elsif C = 'N' then
            C := Getc;

            if C = 'O' then
               ALIs.Table (Id).No_Object := True;
               No_Object_Specified := True;

            elsif C = 'R' then
               No_Run_Time_Specified := True;
               ALIs.Table (Id).No_Run_Time := True;

            elsif C = 'S' then
               ALIs.Table (Id).Normalize_Scalars := True;
               Normalize_Scalars_Specified := True;
               NS_Found := True;

            else
               Fatal_Error;
            end if;

         elsif C = 'Q' then
            Queuing_Policy_Specified := Getc;
            ALIs.Table (Id).Queuing_Policy := Queuing_Policy_Specified;

         elsif C = 'T' then
            Task_Dispatching_Policy_Specified := Getc;
            ALIs.Table (Id).Task_Dispatching_Policy :=
              Task_Dispatching_Policy_Specified;

         elsif C = 'U' then
            if Nextc = 'A' then
               Unreserve_All_Interrupts_Specified := True;
               C := Getc;

            else
               Checkc ('X');
               ALIs.Table (Id).Unit_Exception_Table := True;
            end if;

         elsif C = 'Z' then
            Checkc ('X');
               ALIs.Table (Id).Zero_Cost_Exceptions := True;
               Zero_Cost_Exceptions_Specified := True;

         else
            Fatal_Error;
         end if;
      end loop;

      if not NS_Found then
         No_Normalize_Scalars_Specified := True;
      end if;

      Skip_Eol;

      --  Acquire restrictions line

      if Getc /= 'R' then
         Fatal_Error;

      else
         Checkc (' ');
         Skip_Space;

         for J in All_Restrictions loop
            C := Getc;
            ALIs.Table (Id).Restrictions (J) := C;

            case C is
               when 'v' =>
                  Restrictions (J) := 'v';

               when 'r' =>
                  if Restrictions (J) = 'n' then
                     Restrictions (J) := 'r';
                  end if;

               when 'n' =>
                  null;

               when others =>
                  Fatal_Error;
            end case;
         end loop;

         if At_Eol then
            Skip_Eol;
            C := Getc;
         else
            Fatal_Error;
         end if;
      end if;

      --  Loop to acquire unit entries

      Unit_Loop : while C = 'U' loop
         Checkc (' ');
         Skip_Space;
         Units.Increment_Last;

         if ALIs.Table (Id).First_Unit = No_Unit_Id then
            ALIs.Table (Id).First_Unit := Units.Last;
         end if;

         Units.Table (Units.Last).Uname           := Get_Name;
         Units.Table (Units.Last).Predefined      := Is_Predefined_Unit;
         Units.Table (Units.Last).Internal        := Is_Internal_Unit;
         Units.Table (Units.Last).My_ALI          := Id;
         Units.Table (Units.Last).Sfile           := Get_Name (Lower => True);
         Units.Table (Units.Last).Pure            := False;
         Units.Table (Units.Last).Preelab         := False;
         Units.Table (Units.Last).No_Elab         := False;
         Units.Table (Units.Last).Shared_Passive  := False;
         Units.Table (Units.Last).RCI             := False;
         Units.Table (Units.Last).Remote_Types    := False;
         Units.Table (Units.Last).Has_RACW        := False;
         Units.Table (Units.Last).Init_Scalars    := False;
         Units.Table (Units.Last).Is_Generic      := False;
         Units.Table (Units.Last).Icasing         := Mixed_Case;
         Units.Table (Units.Last).Kcasing         := All_Lower_Case;
         Units.Table (Units.Last).Dynamic_Elab    := False;
         Units.Table (Units.Last).Elaborate_Body  := False;
         Units.Table (Units.Last).Set_Elab_Entity := False;
         Units.Table (Units.Last).Version         := "00000000";
         Units.Table (Units.Last).First_With      := Withs.Last + 1;
         Units.Table (Units.Last).First_Arg       := First_Arg;
         Units.Table (Units.Last).Elab_Position   := 0;

         if Debug_Flag_U then
            Write_Str (" ----> reading unit ");
            Write_Int (Int (Units.Last));
            Write_Str ("  ");
            Write_Unit_Name (Units.Table (Units.Last).Uname);
            Write_Str (" from file ");
            Write_Name (Units.Table (Units.Last).Sfile);
            Write_Eol;
         end if;

         --  Check for duplicated unit in different files

         declare
            Info : constant Int := Get_Name_Table_Info
                                     (Units.Table (Units.Last).Uname);
         begin
            if Info /= 0
              and then Units.Table (Units.Last).Sfile /=
                       Units.Table (Unit_Id (Info)).Sfile
            then
               --  If Err is set then ignore duplicate unit name. This is the
               --  case of a call from gnatmake, where the situation can arise
               --  from substitution of source files. In such situations, the
               --  processing in gnatmake will always result in any required
               --  recompilations in any case, and if we consider this to be
               --  an error we get strange cases (for example when a generic
               --  instantiation is replaced by a normal package) where we
               --  read the old ali file, decide to recompile, and then decide
               --  that the old and new ali files are incompatible.

               if Err then
                  null;

               --  If Err is not set, then this is a fatal error. This is
               --  the case of being called from the binder, where we must
               --  definitely diagnose this as an error.

               else
                  Set_Standard_Error;
                  Write_Str ("error: duplicate unit name: ");
                  Write_Eol;

                  Write_Str ("error: unit """);
                  Write_Unit_Name (Units.Table (Units.Last).Uname);
                  Write_Str (""" found in file """);
                  Write_Name_Decoded (Units.Table (Units.Last).Sfile);
                  Write_Char ('"');
                  Write_Eol;

                  Write_Str ("error: unit """);
                  Write_Unit_Name (Units.Table (Unit_Id (Info)).Uname);
                  Write_Str (""" found in file """);
                  Write_Name_Decoded (Units.Table (Unit_Id (Info)).Sfile);
                  Write_Char ('"');
                  Write_Eol;

                  Exit_Program (E_Fatal);
               end if;
            end if;
         end;

         Set_Name_Table_Info
           (Units.Table (Units.Last).Uname, Int (Units.Last));

         --  Scan out possible version and other parameters

         loop
            Skip_Space;
            exit when At_Eol;
            C := Getc;

            --  Version field

            if C in '0' .. '9' or else C in 'a' .. 'f' then
               Units.Table (Units.Last).Version (1) := C;

               for J in 2 .. 8 loop
                  C := Getc;
                  Units.Table (Units.Last).Version (J) := C;
               end loop;

            --  DE parameter (Dynamic elaboration checks

            elsif C = 'D' then
               Checkc ('E');
               Check_At_End_Of_Field;
               Units.Table (Units.Last).Dynamic_Elab := True;
               Dynamic_Elaboration_Checks_Specified := True;

            --  EB/EE parameters

            elsif C = 'E' then
               C := Getc;

               if C = 'B' then
                  Units.Table (Units.Last).Elaborate_Body := True;

               elsif C = 'E' then
                  Units.Table (Units.Last).Set_Elab_Entity := True;

               else
                  Fatal_Error;
               end if;

               Check_At_End_Of_Field;

            --  GE parameter (generic)

            elsif C = 'G' then
               Checkc ('E');
               Check_At_End_Of_Field;
               Units.Table (Units.Last).Is_Generic := True;

            --  IL/IS/IU parameters

            elsif C = 'I' then
               C := Getc;

               if C = 'L' then
                  Units.Table (Units.Last).Icasing := All_Lower_Case;

               elsif C = 'S' then
                  Units.Table (Units.Last).Init_Scalars := True;
                  Initialize_Scalars_Used := True;

               elsif C = 'U' then
                  Units.Table (Units.Last).Icasing := All_Upper_Case;

               else
                  Fatal_Error;
               end if;

               Check_At_End_Of_Field;

            --  KM/KU parameters

            elsif C = 'K' then
               C := Getc;

               if C = 'M' then
                  Units.Table (Units.Last).Kcasing := Mixed_Case;

               elsif C = 'U' then
                  Units.Table (Units.Last).Kcasing := All_Upper_Case;

               else
                  Fatal_Error;
               end if;

               Check_At_End_Of_Field;

            --  NE parameter

            elsif C = 'N' then
               Checkc ('E');
               Units.Table (Units.Last).No_Elab := True;
               Check_At_End_Of_Field;

            --  PR/PU/PK parameters

            elsif C = 'P' then
               C := Getc;

               --  PR parameter (preelaborate)

               if C = 'R' then
                  Units.Table (Units.Last).Preelab := True;

               --  PU parameter (pure)

               elsif C = 'U' then
                  Units.Table (Units.Last).Pure := True;

               --  PK indicates unit is package

               elsif C = 'K' then
                  Units.Table (Units.Last).Unit_Kind := 'p';

               else
                  Fatal_Error;
               end if;

               Check_At_End_Of_Field;

            --  RC/RT parameters

            elsif C = 'R' then
               C := Getc;

               --  RC parameter (remote call interface)

               if C = 'C' then
                  Units.Table (Units.Last).RCI := True;

               --  RT parameter (remote types)

               elsif C = 'T' then
                  Units.Table (Units.Last).Remote_Types := True;

               --  RA parameter (remote access to class wide type)

               elsif C = 'A' then
                  Units.Table (Units.Last).Has_RACW := True;

               else
                  Fatal_Error;
               end if;

               Check_At_End_Of_Field;

            elsif C = 'S' then
               C := Getc;

               --  SP parameter (shared passive)

               if C = 'P' then
                  Units.Table (Units.Last).Shared_Passive := True;

               --  SU parameter indicates unit is subprogram

               elsif C = 'U' then
                  Units.Table (Units.Last).Unit_Kind := 's';

               else
                  Fatal_Error;
               end if;

               Check_At_End_Of_Field;

            else
               Fatal_Error;
            end if;

         end loop;

         Skip_Eol;

         --  Check if static elaboration model used

         if not Units.Table (Units.Last).Dynamic_Elab
           and then not Units.Table (Units.Last).Internal
         then
            Static_Elaboration_Model_Used := True;
         end if;

         --  Scan out With lines for this unit

         C := Getc;

         With_Loop : while C = 'W' loop
            Checkc (' ');
            Skip_Space;
            Withs.Increment_Last;
            Withs.Table (Withs.Last).Uname              := Get_Name;
            Withs.Table (Withs.Last).Elaborate          := False;
            Withs.Table (Withs.Last).Elaborate_All      := False;
            Withs.Table (Withs.Last).Elab_All_Desirable := False;

            --  Generic case with no object file available

            if At_Eol then
               Withs.Table (Withs.Last).Sfile := No_File;
               Withs.Table (Withs.Last).Afile := No_File;

            --  Normal case

            else
               Withs.Table (Withs.Last).Sfile := Get_Name (Lower => True);
               Withs.Table (Withs.Last).Afile := Get_Name;

               --  Scan out possible E, EA, and NE parameters

               while not At_Eol loop
                  Skip_Space;

                  if Nextc = 'E' then
                     P := P + 1;

                     if At_End_Of_Field then
                        Withs.Table (Withs.Last).Elaborate := True;

                     elsif Nextc = 'A' then
                        P := P + 1;
                        Check_At_End_Of_Field;
                        Withs.Table (Withs.Last).Elaborate_All := True;

                     else
                        Checkc ('D');
                        Check_At_End_Of_Field;

                        --  Store ED indication unless ignore required

                        if not Ignore_ED then
                           Withs.Table (Withs.Last).Elab_All_Desirable := True;
                        end if;
                     end if;
                  end if;
               end loop;
            end if;

            Skip_Eol;
            C := Getc;

         end loop With_Loop;

         Units.Table (Units.Last).Last_With := Withs.Last;
         Units.Table (Units.Last).Last_Arg  := Args.Last;

         --  If there are linker options lines present, scan them

         Name_Len := 0;

         Linker_Options_Loop : while C = 'L' loop
            Checkc (' ');
            Skip_Space;
            Checkc ('"');

            loop
               C := Getc;

               if C < Character'Val (16#20#)
                 or else C > Character'Val (16#7E#)
               then
                  Fatal_Error;

               elsif C = '{' then
                  C := Character'Val (0);

                  declare
                     V : Natural;

                  begin
                     V := 0;
                     for J in 1 .. 2 loop
                        C := Getc;

                        if C in '0' .. '9' then
                           V := V * 16 +
                                  Character'Pos (C) - Character'Pos ('0');

                        elsif C in 'A' .. 'F' then
                           V := V * 16 +
                                  Character'Pos (C) - Character'Pos ('A') + 10;

                        else
                           Fatal_Error;
                        end if;
                     end loop;

                     Checkc ('}');

                     Add_Char_To_Name_Buffer (Character'Val (V));
                  end;

               else
                  if C = '"' then
                     exit when Nextc /= '"';
                     C := Getc;
                  end if;

                  Add_Char_To_Name_Buffer (C);
               end if;
            end loop;

            Add_Char_To_Name_Buffer (nul);

            Skip_Eol;
            C := Getc;
         end loop Linker_Options_Loop;

         --  Store the linker options entry

         if Name_Len /= 0 then
            Linker_Options.Increment_Last;

            Linker_Options.Table (Linker_Options.Last).Name :=
              Name_Enter;

            Linker_Options.Table (Linker_Options.Last).Unit :=
              Units.Last;

            Linker_Options.Table (Linker_Options.Last).Internal_File :=
              Is_Internal_File_Name (F);

            Linker_Options.Table (Linker_Options.Last).Original_Pos :=
              Linker_Options.Last;
         end if;
      end loop Unit_Loop;

      --  End loop through units for one ALI file

      ALIs.Table (Id).Last_Unit := Units.Last;
      ALIs.Table (Id).Sfile := Units.Table (ALIs.Table (Id).First_Unit).Sfile;

      --  Set types of the units (there can be at most 2 of them)

      if ALIs.Table (Id).First_Unit /= ALIs.Table (Id).Last_Unit then
         Units.Table (ALIs.Table (Id).First_Unit).Utype := Is_Body;
         Units.Table (ALIs.Table (Id).Last_Unit).Utype  := Is_Spec;

      else
         --  Deal with body only and spec only cases, note that the reason we
         --  do our own checking of the name (rather than using Is_Body_Name)
         --  is that Uname drags in far too much compiler junk!

         Get_Name_String (Units.Table (Units.Last).Uname);

         if Name_Buffer (Name_Len) = 'b' then
            Units.Table (Units.Last).Utype := Is_Body_Only;
         else
            Units.Table (Units.Last).Utype := Is_Spec_Only;
         end if;
      end if;

      --  Scan out external version references and put in hash table

      while C = 'E' loop
         Checkc (' ');
         Skip_Space;

         Name_Len := 0;
         Name_Len := 0;
         loop
            C := Getc;

            if C < ' ' then
               Fatal_Error;
            end if;

            exit when At_End_Of_Field;
            Add_Char_To_Name_Buffer (C);
         end loop;

         Version_Ref.Set (new String'(Name_Buffer (1 .. Name_Len)), True);
         Skip_Eol;
         C := Getc;
      end loop;

      --  Scan out source dependency lines for this ALI file

      ALIs.Table (Id).First_Sdep := Sdep.Last + 1;

      while C = 'D' loop
         Checkc (' ');
         Skip_Space;
         Sdep.Increment_Last;
         Sdep.Table (Sdep.Last).Sfile := Get_Name (Lower => True);
         Sdep.Table (Sdep.Last).Stamp := Get_Stamp;
         Sdep.Table (Sdep.Last).Dummy_Entry :=
           (Sdep.Table (Sdep.Last).Stamp = Dummy_Time_Stamp);

         --  Acquire checksum value

         Skip_Space;

         declare
            Ctr : Natural;
            Chk : Word;

         begin
            Ctr := 0;
            Chk := 0;

            loop
               exit when At_Eol or else Ctr = 8;

               if Nextc in '0' .. '9' then
                  Chk := Chk * 16 +
                           Character'Pos (Nextc) - Character'Pos ('0');

               elsif Nextc in 'a' .. 'f' then
                  Chk := Chk * 16 +
                           Character'Pos (Nextc) - Character'Pos ('a') + 10;

               else
                  exit;
               end if;

               Ctr := Ctr + 1;
               P := P + 1;
            end loop;

            if Ctr = 8 and then At_End_Of_Field then
               Sdep.Table (Sdep.Last).Checksum := Chk;
            else
               Fatal_Error;
            end if;
         end;

         --  Acquire subunit and reference file name entries

         Sdep.Table (Sdep.Last).Subunit_Name := No_Name;
         Sdep.Table (Sdep.Last).Rfile        := Sdep.Table (Sdep.Last).Sfile;
         Sdep.Table (Sdep.Last).Start_Line   := 1;

         if not At_Eol then
            Skip_Space;

            --  Here for subunit name

            if Nextc not in '0' .. '9' then
               Name_Len := 0;

               while not At_End_Of_Field loop
                  Name_Len := Name_Len + 1;
                  Name_Buffer (Name_Len) := Getc;
               end loop;

               Sdep.Table (Sdep.Last).Subunit_Name := Name_Enter;
               Skip_Space;
            end if;

            --  Here for reference file name entry

            if Nextc in '0' .. '9' then
               Sdep.Table (Sdep.Last).Start_Line := Get_Nat;
               Checkc (':');

               Name_Len := 0;

               while not At_End_Of_Field loop
                  Name_Len := Name_Len + 1;
                  Name_Buffer (Name_Len) := Getc;
               end loop;

               Sdep.Table (Sdep.Last).Rfile := Name_Enter;
            end if;
         end if;

         Skip_Eol;
         C := Getc;
      end loop;

      ALIs.Table (Id).Last_Sdep := Sdep.Last;

      --  Loop through Xref sections (skip loop if not reading xref stuff)

      while Read_Xref and then C = 'X' loop

         --  Make new entry in section table

         Xref_Section.Increment_Last;

         Read_Refs_For_One_File : declare
            XS : Xref_Section_Record renames
                   Xref_Section.Table (Xref_Section.Last);

            Current_File_Num : Sdep_Id;
            --  Keeps track of the current file number (changed by nn|)

         begin
            XS.File_Num     := Sdep_Id (Get_Nat + Nat (First_Sdep_Entry) - 1);
            XS.File_Name    := Get_Name;
            XS.First_Entity := Xref_Entity.Last + 1;

            Current_File_Num := XS.File_Num;

            Skip_Eol;
            C := Nextc;

            --  Loop through Xref entities

            while C /= 'X' and then C /= EOF loop
               Xref_Entity.Increment_Last;

               Read_Refs_For_One_Entity : declare

                  XE : Xref_Entity_Record renames
                         Xref_Entity.Table (Xref_Entity.Last);

                  N : Nat;

                  procedure Read_Instantiation_Reference;
                  --  Acquire instantiation reference. Caller has checked
                  --  that current character is '[' and on return the cursor
                  --  is skipped past the corresponding closing ']'.

                  ----------------------------------
                  -- Read_Instantiation_Reference --
                  ----------------------------------

                  procedure Read_Instantiation_Reference is
                  begin
                     Xref.Increment_Last;

                     declare
                        XR : Xref_Record renames Xref.Table (Xref.Last);

                     begin
                        P := P + 1; -- skip [
                        N := Get_Nat;

                        if Nextc = '|' then
                           XR.File_Num :=
                             Sdep_Id (N + Nat (First_Sdep_Entry) - 1);
                           Current_File_Num := XR.File_Num;
                           P := P + 1;
                           N := Get_Nat;

                        else
                           XR.File_Num := Current_File_Num;
                        end if;

                        XR.Line  := N;
                        XR.Rtype := ' ';
                        XR.Col   := 0;

                        --  Recursive call for next reference

                        if Nextc = '[' then
                           pragma Warnings (Off); -- kill recursion warning
                           Read_Instantiation_Reference;
                           pragma Warnings (On);
                        end if;

                        --  Skip closing bracket after recursive call

                        P := P + 1;
                     end;
                  end Read_Instantiation_Reference;

               --  Start of processing for Read_Refs_For_One_Entity

               begin
                  XE.Line   := Get_Nat;
                  XE.Etype  := Getc;
                  XE.Col    := Get_Nat;
                  XE.Lib    := (Getc = '*');
                  XE.Entity := Get_Name;

                  --  Renaming reference is present

                  if Nextc = '=' then
                     P := P + 1;
                     XE.Rref_Line := Get_Nat;

                     if Getc /= ':' then
                        Fatal_Error;
                     end if;

                     XE.Rref_Col := Get_Nat;

                  --  No renaming reference present

                  else
                     XE.Rref_Line := 0;
                     XE.Rref_Col  := 0;
                  end if;

                  Skip_Space;

                  --  See if type reference present

                  case Nextc is
                     when '<'    => XE.Tref := Tref_Derived;
                     when '('    => XE.Tref := Tref_Access;
                     when '{'    => XE.Tref := Tref_Type;
                     when others => XE.Tref := Tref_None;
                  end case;

                  --  Case of typeref field present

                  if XE.Tref /= Tref_None then
                     P := P + 1; -- skip opening bracket

                     if Nextc in 'a' .. 'z' then
                        XE.Tref_File_Num        := No_Sdep_Id;
                        XE.Tref_Line            := 0;
                        XE.Tref_Type            := ' ';
                        XE.Tref_Col             := 0;
                        XE.Tref_Standard_Entity := Get_Name;

                     else
                        N := Get_Nat;

                        if Nextc = '|' then
                           XE.Tref_File_Num :=
                             Sdep_Id (N + Nat (First_Sdep_Entry) - 1);
                           P := P + 1;
                           N := Get_Nat;

                        else
                           XE.Tref_File_Num := Current_File_Num;
                        end if;

                        XE.Tref_Line            := N;
                        XE.Tref_Type            := Getc;
                        XE.Tref_Col             := Get_Nat;
                        XE.Tref_Standard_Entity := No_Name;
                     end if;

                     P := P + 1; -- skip closing bracket
                     Skip_Space;

                  --  No typeref entry present

                  else
                     XE.Tref_File_Num        := No_Sdep_Id;
                     XE.Tref_Line            := 0;
                     XE.Tref_Type            := ' ';
                     XE.Tref_Col             := 0;
                     XE.Tref_Standard_Entity := No_Name;
                  end if;

                  XE.First_Xref := Xref.Last + 1;

                  --  Loop through cross-references for this entity

                  Current_File_Num := XS.File_Num;

                  loop
                     Skip_Space;

                     if At_Eol then
                        Skip_Eol;
                        exit when Nextc /= '.';
                        P := P + 1;
                     end if;

                     Xref.Increment_Last;

                     declare
                        XR : Xref_Record renames Xref.Table (Xref.Last);

                     begin
                        N := Get_Nat;

                        if Nextc = '|' then
                           XR.File_Num :=
                             Sdep_Id (N + Nat (First_Sdep_Entry) - 1);
                           Current_File_Num := XR.File_Num;
                           P := P + 1;
                           N := Get_Nat;

                        else
                           XR.File_Num := Current_File_Num;
                        end if;

                        XR.Line  := N;
                        XR.Rtype := Getc;
                        XR.Col   := Get_Nat;

                        if Nextc = '[' then
                           Read_Instantiation_Reference;
                        end if;
                     end;
                  end loop;

                  --  Record last cross-reference

                  XE.Last_Xref := Xref.Last;
                  C := Nextc;

               end Read_Refs_For_One_Entity;
            end loop;

            --  Record last entity

            XS.Last_Entity := Xref_Entity.Last;

         end Read_Refs_For_One_File;

         C := Getc;
      end loop;

      --  Here after dealing with xref sections

      if C /= EOF and then C /= 'X' then
         Fatal_Error;
      end if;

      return Id;

   exception
      when Bad_ALI_Format =>
         return No_ALI_Id;

   end Scan_ALI;

   ---------
   -- SEq --
   ---------

   function SEq (F1, F2 : String_Ptr) return Boolean is
   begin
      return F1.all = F2.all;
   end SEq;

   -----------
   -- SHash --
   -----------

   function SHash (S : String_Ptr) return Vindex is
      H : Word;

   begin
      H := 0;
      for J in S.all'Range loop
         H := H * 2 + Character'Pos (S (J));
      end loop;

      return Vindex (Vindex'First + Vindex (H mod Vindex'Range_Length));
   end SHash;

end ALI;