aboutsummaryrefslogtreecommitdiffstats
path: root/gcc-4.8.3/gcc/ada/ali.adb
diff options
context:
space:
mode:
Diffstat (limited to 'gcc-4.8.3/gcc/ada/ali.adb')
-rw-r--r--gcc-4.8.3/gcc/ada/ali.adb2709
1 files changed, 2709 insertions, 0 deletions
diff --git a/gcc-4.8.3/gcc/ada/ali.adb b/gcc-4.8.3/gcc/ada/ali.adb
new file mode 100644
index 000000000..0386c05fe
--- /dev/null
+++ b/gcc-4.8.3/gcc/ada/ali.adb
@@ -0,0 +1,2709 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- A L I --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1992-2012, 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 3, 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 COPYING3. If not, go to --
+-- http://www.gnu.org/licenses for a complete copy of the license. --
+-- --
+-- 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 Opt; use Opt;
+with Osint; use Osint;
+with Output; use Output;
+
+package body ALI is
+
+ use ASCII;
+ -- Make control characters visible
+
+ -- The following variable records which characters currently are
+ -- used as line type markers in the ALI file. This is used in
+ -- Scan_ALI to detect (or skip) invalid lines.
+
+ Known_ALI_Lines : constant array (Character range 'A' .. 'Z') of Boolean :=
+ ('V' => True, -- version
+ 'M' => True, -- main program
+ 'A' => True, -- argument
+ 'P' => True, -- program
+ 'R' => True, -- restriction
+ 'I' => True, -- interrupt
+ 'U' => True, -- unit
+ 'W' => True, -- with
+ 'L' => True, -- linker option
+ 'N' => True, -- notes
+ 'E' => True, -- external
+ 'D' => True, -- dependency
+ 'X' => True, -- xref
+ 'S' => True, -- specific dispatching
+ 'Y' => True, -- limited_with
+ 'Z' => True, -- implicit with from instantiation
+ 'C' => True, -- SCO information
+ 'F' => True, -- Alfa information
+ others => False);
+
+ --------------------
+ -- 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.
+ -- These two loops are 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;
+
+ for J in Units.First .. Units.Last loop
+ Set_Name_Table_Info (Units.Table (J).Uname, 0);
+ end loop;
+
+ -- Free argument table strings
+
+ for J in Args.First .. Args.Last loop
+ Free (Args.Table (J));
+ end loop;
+
+ -- Initialize all tables
+
+ ALIs.Init;
+ No_Deps.Init;
+ Units.Init;
+ Withs.Init;
+ Sdep.Init;
+ Linker_Options.Init;
+ Notes.Init;
+ Xref_Section.Init;
+ Xref_Entity.Init;
+ Xref.Init;
+ Version_Ref.Reset;
+
+ -- Add dummy zero'th item in Linker_Options and Notes for sort calls
+
+ Linker_Options.Increment_Last;
+ Notes.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;
+ Partition_Elaboration_Policy_Specified := ' ';
+ 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;
+ Read_Lines : String := "";
+ Ignore_Lines : String := "X";
+ Ignore_Errors : Boolean := False;
+ Directly_Scanned : 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;
+
+ Ignore : array (Character range 'A' .. 'Z') of Boolean;
+ -- Ignore (X) is set to True if lines starting with X are to
+ -- be ignored by Scan_ALI and skipped, and False if the lines
+ -- are to be read and processed.
+
+ Bad_ALI_Format : exception;
+ -- Exception raised by Fatal_Error if Err is True
+
+ 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
+
+ procedure Check_Unknown_Line;
+ -- If Ignore_Errors mode, then checks C to make sure that it is not
+ -- an unknown ALI line type characters, and if so, skips lines
+ -- until the first character of the line is one of these characters,
+ -- at which point it does a Getc to put that character in C. The
+ -- call has no effect if C is already an appropriate character.
+ -- If not in Ignore_Errors mode, a fatal error is signalled if the
+ -- line is unknown. Note that if C is an EOL on entry, the line is
+ -- skipped (it is assumed that blank lines are never significant).
+ -- If C is EOF on entry, the call has no effect (it is assumed that
+ -- the caller will properly handle this case).
+
+ 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.
+
+ procedure Fatal_Error_Ignore;
+ pragma Inline (Fatal_Error_Ignore);
+ -- In Ignore_Errors mode, has no effect, otherwise same as Fatal_Error
+
+ function Getc return Character;
+ -- Get next character, bumping P past the character obtained
+
+ function Get_File_Name (Lower : Boolean := False) return File_Name_Type;
+ -- Skip blanks, then scan out a file name (name is left in Name_Buffer
+ -- with length in Name_Len, as well as returning a File_Name_Type value.
+ -- If lower is false, the case is unchanged, if Lower is True then the
+ -- result is forced 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 scan
+ -- is terminated by a end of line, space or horizontal tab. Any other
+ -- special characters are included in the returned name.
+
+ function Get_Name
+ (Ignore_Spaces : Boolean := False;
+ Ignore_Special : 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 termination condition depends
+ -- on the settings of Ignore_Spaces and Ignore_Special:
+ --
+ -- If Ignore_Spaces is False (normal case), then scan is terminated
+ -- by the normal end of field condition (EOL, space, horizontal tab)
+ --
+ -- If Ignore_Special is False (normal case), the scan is terminated by
+ -- a typeref bracket or an equal sign except for the special case of
+ -- an operator name starting with a double quote which is terminated
+ -- by another double quote.
+ --
+ -- It is an error to set both Ignore_Spaces and Ignore_Special to True.
+ -- This function handles wide characters properly.
+
+ function Get_Nat return Nat;
+ -- Skip blanks, then scan out an unsigned integer value in Nat range
+ -- raises ALI_Reading_Error if the encoutered type is not natural.
+
+ function Get_Stamp return Time_Stamp_Type;
+ -- Skip blanks, then scan out a time stamp
+
+ function Get_Unit_Name return Unit_Name_Type;
+ -- Skip blanks, then scan out a file name (name is left in Name_Buffer
+ -- with length in Name_Len, as well as returning a Unit_Name_Type value.
+ -- The case is unchanged and terminated by a normal end of field.
+
+ function Nextc return Character;
+ -- Return current character without modifying pointer P
+
+ procedure Get_Typeref
+ (Current_File_Num : Sdep_Id;
+ Ref : out Tref_Kind;
+ File_Num : out Sdep_Id;
+ Line : out Nat;
+ Ref_Type : out Character;
+ Col : out Nat;
+ Standard_Entity : out Name_Id);
+ -- Parse the definition of a typeref (<...>, {...} or (...))
+
+ procedure Skip_Eol;
+ -- Skip past spaces, then skip past end of line (fatal error if not
+ -- at end of line). Also skips past any following blank lines.
+
+ procedure Skip_Line;
+ -- Skip rest of current line and any following blank lines
+
+ procedure Skip_Space;
+ -- Skip past white space (blanks or horizontal tab)
+
+ procedure Skipc;
+ -- Skip past next character, does not affect value in C. This call
+ -- is like calling Getc and ignoring the returned result.
+
+ ---------------------
+ -- 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
+ if Ignore_Errors then
+ while Nextc > ' ' loop
+ P := P + 1;
+ end loop;
+ else
+ Fatal_Error;
+ end if;
+ end if;
+ end Check_At_End_Of_Field;
+
+ ------------------------
+ -- Check_Unknown_Line --
+ ------------------------
+
+ procedure Check_Unknown_Line is
+ begin
+ while C not in 'A' .. 'Z'
+ or else not Known_ALI_Lines (C)
+ loop
+ if C = CR or else C = LF then
+ Skip_Line;
+ C := Nextc;
+
+ elsif C = EOF then
+ return;
+
+ elsif Ignore_Errors then
+ Skip_Line;
+ C := Getc;
+
+ else
+ Fatal_Error;
+ end if;
+ end loop;
+ end Check_Unknown_Line;
+
+ ------------
+ -- Checkc --
+ ------------
+
+ procedure Checkc (C : Character) is
+ begin
+ if Nextc = C then
+ P := P + 1;
+ elsif Ignore_Errors 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 " &
+
+ -- Split the following line so that it can easily be transformed for
+ -- e.g. JVM/.NET back-ends where the compiler has a different name.
+
+ "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;
+
+ ------------------------
+ -- Fatal_Error_Ignore --
+ ------------------------
+
+ procedure Fatal_Error_Ignore is
+ begin
+ if not Ignore_Errors then
+ Fatal_Error;
+ end if;
+ end Fatal_Error_Ignore;
+
+ -------------------
+ -- Get_File_Name --
+ -------------------
+
+ function Get_File_Name
+ (Lower : Boolean := False) return File_Name_Type
+ is
+ F : Name_Id;
+
+ begin
+ F := Get_Name (Ignore_Special => True);
+
+ -- 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));
+ return Name_Find;
+ else
+ return File_Name_Type (F);
+ end if;
+ end Get_File_Name;
+
+ --------------
+ -- Get_Name --
+ --------------
+
+ function Get_Name
+ (Ignore_Spaces : Boolean := False;
+ Ignore_Special : Boolean := False) return Name_Id
+ is
+ begin
+ Name_Len := 0;
+ Skip_Space;
+
+ if At_Eol then
+ if Ignore_Errors then
+ return Error_Name;
+ else
+ Fatal_Error;
+ end if;
+ end if;
+
+ loop
+ Add_Char_To_Name_Buffer (Getc);
+
+ exit when At_End_Of_Field and then not Ignore_Spaces;
+
+ if not Ignore_Special then
+ if Name_Buffer (1) = '"' then
+ exit when Name_Len > 1 and then Name_Buffer (Name_Len) = '"';
+
+ else
+ -- Terminate on parens or angle brackets or equal sign
+
+ exit when Nextc = '(' or else Nextc = ')'
+ or else Nextc = '{' or else Nextc = '}'
+ or else Nextc = '<' or else Nextc = '>'
+ or else Nextc = '=';
+
+ -- Terminate on comma
+
+ exit when Nextc = ',';
+
+ -- Terminate if left bracket not part of wide char sequence
+ -- Note that we only recognize brackets notation so far ???
+
+ exit when Nextc = '[' and then T (P + 1) /= '"';
+
+ -- Terminate if right bracket not part of wide char sequence
+
+ exit when Nextc = ']' and then T (P - 1) /= '"';
+ end if;
+ end if;
+ end loop;
+
+ return Name_Find;
+ end Get_Name;
+
+ -------------------
+ -- Get_Unit_Name --
+ -------------------
+
+ function Get_Unit_Name return Unit_Name_Type is
+ begin
+ return Unit_Name_Type (Get_Name);
+ end Get_Unit_Name;
+
+ -------------
+ -- Get_Nat --
+ -------------
+
+ function Get_Nat return Nat is
+ V : Nat;
+
+ begin
+ Skip_Space;
+
+ -- Check if we are on a number. In the case of bad ALI files, this
+ -- may not be true.
+
+ if not (Nextc in '0' .. '9') then
+ Fatal_Error;
+ end if;
+
+ V := 0;
+ loop
+ V := V * 10 + (Character'Pos (Getc) - Character'Pos ('0'));
+
+ exit when At_End_Of_Field;
+ exit when Nextc < '0' or else 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
+ if Ignore_Errors then
+ return Dummy_Time_Stamp;
+ else
+ Fatal_Error;
+ end if;
+ 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;
+
+ -----------------
+ -- Get_Typeref --
+ -----------------
+
+ procedure Get_Typeref
+ (Current_File_Num : Sdep_Id;
+ Ref : out Tref_Kind;
+ File_Num : out Sdep_Id;
+ Line : out Nat;
+ Ref_Type : out Character;
+ Col : out Nat;
+ Standard_Entity : out Name_Id)
+ is
+ N : Nat;
+ begin
+ case Nextc is
+ when '<' => Ref := Tref_Derived;
+ when '(' => Ref := Tref_Access;
+ when '{' => Ref := Tref_Type;
+ when others => Ref := Tref_None;
+ end case;
+
+ -- Case of typeref field present
+
+ if Ref /= Tref_None then
+ P := P + 1; -- skip opening bracket
+
+ if Nextc in 'a' .. 'z' then
+ File_Num := No_Sdep_Id;
+ Line := 0;
+ Ref_Type := ' ';
+ Col := 0;
+ Standard_Entity := Get_Name (Ignore_Spaces => True);
+ else
+ N := Get_Nat;
+
+ if Nextc = '|' then
+ File_Num := Sdep_Id (N + Nat (First_Sdep_Entry) - 1);
+ P := P + 1;
+ N := Get_Nat;
+ else
+ File_Num := Current_File_Num;
+ end if;
+
+ Line := N;
+ Ref_Type := Getc;
+ Col := Get_Nat;
+ Standard_Entity := No_Name;
+ end if;
+
+ -- ??? Temporary workaround for nested generics case:
+ -- 4i4 Directories{1|4I9[4|6[3|3]]}
+ -- See C918-002
+
+ declare
+ Nested_Brackets : Natural := 0;
+
+ begin
+ loop
+ case Nextc is
+ when '[' =>
+ Nested_Brackets := Nested_Brackets + 1;
+ when ']' =>
+ Nested_Brackets := Nested_Brackets - 1;
+ when others =>
+ if Nested_Brackets = 0 then
+ exit;
+ end if;
+ end case;
+
+ Skipc;
+ end loop;
+ end;
+
+ P := P + 1; -- skip closing bracket
+ Skip_Space;
+
+ -- No typeref entry present
+
+ else
+ File_Num := No_Sdep_Id;
+ Line := 0;
+ Ref_Type := ' ';
+ Col := 0;
+ Standard_Entity := No_Name;
+ end if;
+ end Get_Typeref;
+
+ ----------
+ -- 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
+ if Ignore_Errors then
+ while not At_Eol loop
+ P := P + 1;
+ end loop;
+ else
+ Fatal_Error;
+ end if;
+ 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_Line --
+ ---------------
+
+ procedure Skip_Line is
+ begin
+ while not At_Eol loop
+ P := P + 1;
+ end loop;
+
+ Skip_Eol;
+ end Skip_Line;
+
+ ----------------
+ -- Skip_Space --
+ ----------------
+
+ procedure Skip_Space is
+ begin
+ while Nextc = ' ' or else Nextc = HT loop
+ P := P + 1;
+ end loop;
+ end Skip_Space;
+
+ -----------
+ -- Skipc --
+ -----------
+
+ procedure Skipc is
+ begin
+ if P /= T'Last then
+ P := P + 1;
+ end if;
+ end Skipc;
+
+ -- Start of processing for Scan_ALI
+
+ begin
+ First_Sdep_Entry := Sdep.Last + 1;
+
+ -- Acquire lines to be ignored
+
+ if Read_Xref then
+ Ignore :=
+ ('U' | 'W' | 'Y' | 'Z' | 'D' | 'X' => False, others => True);
+
+ -- Read_Lines parameter given
+
+ elsif Read_Lines /= "" then
+ Ignore := ('U' => False, others => True);
+
+ for J in Read_Lines'Range loop
+ Ignore (Read_Lines (J)) := False;
+ end loop;
+
+ -- Process Ignore_Lines parameter
+
+ else
+ Ignore := (others => False);
+
+ for J in Ignore_Lines'Range loop
+ pragma Assert (Ignore_Lines (J) /= 'U');
+ Ignore (Ignore_Lines (J)) := True;
+ end loop;
+ end if;
+
+ -- Setup ALI Table entry with appropriate defaults
+
+ ALIs.Increment_Last;
+ Id := ALIs.Last;
+ Set_Name_Table_Info (F, Int (Id));
+
+ ALIs.Table (Id) := (
+ Afile => F,
+ Compile_Errors => False,
+ First_Interrupt_State => Interrupt_States.Last + 1,
+ First_Sdep => No_Sdep_Id,
+ First_Specific_Dispatching => Specific_Dispatching.Last + 1,
+ First_Unit => No_Unit_Id,
+ Float_Format => 'I',
+ Last_Interrupt_State => Interrupt_States.Last,
+ Last_Sdep => No_Sdep_Id,
+ Last_Specific_Dispatching => Specific_Dispatching.Last,
+ Last_Unit => No_Unit_Id,
+ Locking_Policy => ' ',
+ Main_Priority => -1,
+ Main_CPU => -1,
+ Main_Program => None,
+ No_Object => False,
+ Normalize_Scalars => False,
+ Ofile_Full_Name => Full_Object_File_Name,
+ Partition_Elaboration_Policy => ' ',
+ Queuing_Policy => ' ',
+ Restrictions => No_Restrictions,
+ SAL_Interface => False,
+ Sfile => No_File,
+ Task_Dispatching_Policy => ' ',
+ Time_Slice_Value => -1,
+ Allocator_In_Body => False,
+ WC_Encoding => 'b',
+ Unit_Exception_Table => False,
+ Ver => (others => ' '),
+ Ver_Len => 0,
+ Zero_Cost_Exceptions => False);
+
+ -- Now we acquire the input lines from the ALI file. Note that the
+ -- convention in the following code is that as we enter each section,
+ -- C is set to contain the first character of the following line.
+
+ C := Getc;
+ Check_Unknown_Line;
+
+ -- Acquire library version
+
+ if C /= 'V' then
+
+ -- The V line missing really indicates trouble, most likely it
+ -- means we don't have an ALI file at all, so here we give a
+ -- fatal error even if we are in Ignore_Errors mode.
+
+ Fatal_Error;
+
+ elsif Ignore ('V') then
+ Skip_Line;
+
+ else
+ 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;
+ end if;
+
+ C := Getc;
+ Check_Unknown_Line;
+
+ -- Acquire main program line if present
+
+ if C = 'M' then
+ if Ignore ('M') then
+ Skip_Line;
+
+ else
+ 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;
+
+ if Nextc = 'A' then
+ P := P + 1;
+ Checkc ('B');
+ ALIs.Table (Id).Allocator_In_Body := True;
+ end if;
+
+ Skip_Space;
+
+ if Nextc = 'C' then
+ P := P + 1;
+ Checkc ('=');
+ ALIs.Table (Id).Main_CPU := Get_Nat;
+ end if;
+
+ Skip_Space;
+
+ Checkc ('W');
+ Checkc ('=');
+ ALIs.Table (Id).WC_Encoding := Getc;
+ end if;
+
+ Skip_Eol;
+ end if;
+
+ C := Getc;
+ end if;
+
+ -- Acquire argument lines
+
+ First_Arg := Args.Last + 1;
+
+ A_Loop : loop
+ Check_Unknown_Line;
+ exit A_Loop when C /= 'A';
+
+ if Ignore ('A') then
+ Skip_Line;
+
+ else
+ Checkc (' ');
+
+ -- Scan out argument
+
+ Name_Len := 0;
+ while not At_Eol loop
+ Add_Char_To_Name_Buffer (Getc);
+ end loop;
+
+ -- If -fstack-check, record that it occurred. Note that an
+ -- additional string parameter can be specified, in the form of
+ -- -fstack-check={no|generic|specific}. "no" means no checking,
+ -- "generic" means force the use of old-style checking, and
+ -- "specific" means use the best checking method.
+
+ if Name_Len >= 13
+ and then Name_Buffer (1 .. 13) = "-fstack-check"
+ and then Name_Buffer (1 .. Name_Len) /= "-fstack-check=no"
+ then
+ Stack_Check_Switch_Set := True;
+ end if;
+
+ -- Store the argument
+
+ Args.Increment_Last;
+ Args.Table (Args.Last) := new String'(Name_Buffer (1 .. Name_Len));
+
+ Skip_Eol;
+ end if;
+
+ C := Getc;
+ end loop A_Loop;
+
+ -- Acquire P line
+
+ Check_Unknown_Line;
+
+ while C /= 'P' loop
+ if Ignore_Errors then
+ if C = EOF then
+ Fatal_Error;
+ else
+ Skip_Line;
+ C := Nextc;
+ end if;
+ else
+ Fatal_Error;
+ end if;
+ end loop;
+
+ if Ignore ('P') then
+ Skip_Line;
+
+ -- Process P line
+
+ else
+ NS_Found := False;
+
+ while not At_Eol loop
+ Checkc (' ');
+ Skip_Space;
+ C := Getc;
+
+ -- Processing for CE
+
+ if C = 'C' then
+ Checkc ('E');
+ ALIs.Table (Id).Compile_Errors := True;
+
+ -- Processing for DB
+
+ elsif C = 'D' then
+ Checkc ('B');
+ Detect_Blocking := True;
+
+ -- Processing for Ex
+
+ elsif C = 'E' then
+ Partition_Elaboration_Policy_Specified := Getc;
+ ALIs.Table (Id).Partition_Elaboration_Policy :=
+ Partition_Elaboration_Policy_Specified;
+
+ -- Processing for FD/FG/FI
+
+ elsif C = 'F' then
+ Float_Format_Specified := Getc;
+ ALIs.Table (Id).Float_Format := Float_Format_Specified;
+
+ -- Processing for Lx
+
+ elsif C = 'L' then
+ Locking_Policy_Specified := Getc;
+ ALIs.Table (Id).Locking_Policy := Locking_Policy_Specified;
+
+ -- Processing for flags starting with N
+
+ elsif C = 'N' then
+ C := Getc;
+
+ -- Processing for NO
+
+ if C = 'O' then
+ ALIs.Table (Id).No_Object := True;
+ No_Object_Specified := True;
+
+ -- Processing for NR
+
+ elsif C = 'R' then
+ No_Run_Time_Mode := True;
+ Configurable_Run_Time_Mode := True;
+
+ -- Processing for NS
+
+ elsif C = 'S' then
+ ALIs.Table (Id).Normalize_Scalars := True;
+ Normalize_Scalars_Specified := True;
+ NS_Found := True;
+
+ -- Invalid switch starting with N
+
+ else
+ Fatal_Error_Ignore;
+ end if;
+
+ -- Processing for Qx
+
+ elsif C = 'Q' then
+ Queuing_Policy_Specified := Getc;
+ ALIs.Table (Id).Queuing_Policy := Queuing_Policy_Specified;
+
+ -- Processing for flags starting with S
+
+ elsif C = 'S' then
+ C := Getc;
+
+ -- Processing for SL
+
+ if C = 'L' then
+ ALIs.Table (Id).SAL_Interface := True;
+
+ -- Processing for SS
+
+ elsif C = 'S' then
+ Opt.Sec_Stack_Used := True;
+
+ -- Invalid switch starting with S
+
+ else
+ Fatal_Error_Ignore;
+ end if;
+
+ -- Processing for Tx
+
+ elsif C = 'T' then
+ Task_Dispatching_Policy_Specified := Getc;
+ ALIs.Table (Id).Task_Dispatching_Policy :=
+ Task_Dispatching_Policy_Specified;
+
+ -- Processing for switch starting with U
+
+ elsif C = 'U' then
+ C := Getc;
+
+ -- Processing for UA
+
+ if C = 'A' then
+ Unreserve_All_Interrupts_Specified := True;
+
+ -- Processing for UX
+
+ elsif C = 'X' then
+ ALIs.Table (Id).Unit_Exception_Table := True;
+
+ -- Invalid switches starting with U
+
+ else
+ Fatal_Error_Ignore;
+ end if;
+
+ -- Processing for ZX
+
+ elsif C = 'Z' then
+ C := Getc;
+
+ if C = 'X' then
+ ALIs.Table (Id).Zero_Cost_Exceptions := True;
+ Zero_Cost_Exceptions_Specified := True;
+ else
+ Fatal_Error_Ignore;
+ end if;
+
+ -- Invalid parameter
+
+ else
+ C := Getc;
+ Fatal_Error_Ignore;
+ end if;
+ end loop;
+
+ if not NS_Found then
+ No_Normalize_Scalars_Specified := True;
+ end if;
+
+ Skip_Eol;
+ end if;
+
+ C := Getc;
+ Check_Unknown_Line;
+
+ -- Loop to skip to first restrictions line
+
+ while C /= 'R' loop
+ if Ignore_Errors then
+ if C = EOF then
+ Fatal_Error;
+ else
+ Skip_Line;
+ C := Nextc;
+ end if;
+ else
+ Fatal_Error;
+ end if;
+ end loop;
+
+ -- Ignore all 'R' lines if that is required
+
+ if Ignore ('R') then
+ while C = 'R' loop
+ Skip_Line;
+ C := Getc;
+ end loop;
+
+ -- Here we process the restrictions lines (other than unit name cases)
+
+ else
+ Scan_Restrictions : declare
+ Save_R : constant Restrictions_Info := Cumulative_Restrictions;
+ -- Save cumulative restrictions in case we have a fatal error
+
+ Bad_R_Line : exception;
+ -- Signal bad restrictions line (raised on unexpected character)
+
+ Typ : Character;
+ R : Restriction_Id;
+ N : Natural;
+
+ begin
+ -- Named restriction case
+
+ if Nextc = 'N' then
+ Skip_Line;
+ C := Getc;
+
+ -- Loop through RR and RV lines
+
+ while C = 'R' and then Nextc /= ' ' loop
+ Typ := Getc;
+ Checkc (' ');
+
+ -- Acquire restriction name
+
+ Name_Len := 0;
+ while not At_Eol and then Nextc /= '=' loop
+ Name_Len := Name_Len + 1;
+ Name_Buffer (Name_Len) := Getc;
+ end loop;
+
+ -- Now search list of restrictions to find match
+
+ declare
+ RN : String renames Name_Buffer (1 .. Name_Len);
+
+ begin
+ R := Restriction_Id'First;
+ while R < Not_A_Restriction_Id loop
+ if Restriction_Id'Image (R) = RN then
+ goto R_Found;
+ end if;
+
+ R := Restriction_Id'Succ (R);
+ end loop;
+
+ -- We don't recognize the restriction. This might be
+ -- thought of as an error, and it really is, but we
+ -- want to allow building with inconsistent versions
+ -- of the binder and ali files (see comments at the
+ -- start of package System.Rident), so we just ignore
+ -- this situation.
+
+ goto Done_With_Restriction_Line;
+ end;
+
+ <<R_Found>>
+
+ case R is
+
+ -- Boolean restriction case
+
+ when All_Boolean_Restrictions =>
+ case Typ is
+ when 'V' =>
+ ALIs.Table (Id).Restrictions.Violated (R) :=
+ True;
+ Cumulative_Restrictions.Violated (R) := True;
+
+ when 'R' =>
+ ALIs.Table (Id).Restrictions.Set (R) := True;
+ Cumulative_Restrictions.Set (R) := True;
+
+ when others =>
+ raise Bad_R_Line;
+ end case;
+
+ -- Parameter restriction case
+
+ when All_Parameter_Restrictions =>
+ if At_Eol or else Nextc /= '=' then
+ raise Bad_R_Line;
+ else
+ Skipc;
+ end if;
+
+ N := Natural (Get_Nat);
+
+ case Typ is
+
+ -- Restriction set
+
+ when 'R' =>
+ ALIs.Table (Id).Restrictions.Set (R) := True;
+ ALIs.Table (Id).Restrictions.Value (R) := N;
+
+ if Cumulative_Restrictions.Set (R) then
+ Cumulative_Restrictions.Value (R) :=
+ Integer'Min
+ (Cumulative_Restrictions.Value (R), N);
+ else
+ Cumulative_Restrictions.Set (R) := True;
+ Cumulative_Restrictions.Value (R) := N;
+ end if;
+
+ -- Restriction violated
+
+ when 'V' =>
+ ALIs.Table (Id).Restrictions.Violated (R) :=
+ True;
+ Cumulative_Restrictions.Violated (R) := True;
+ ALIs.Table (Id).Restrictions.Count (R) := N;
+
+ -- Checked Max_Parameter case
+
+ if R in Checked_Max_Parameter_Restrictions then
+ Cumulative_Restrictions.Count (R) :=
+ Integer'Max
+ (Cumulative_Restrictions.Count (R), N);
+
+ -- Other checked parameter cases
+
+ else
+ declare
+ pragma Unsuppress (Overflow_Check);
+
+ begin
+ Cumulative_Restrictions.Count (R) :=
+ Cumulative_Restrictions.Count (R) + N;
+
+ exception
+ when Constraint_Error =>
+
+ -- A constraint error comes from the
+ -- additionh. We reset to the maximum
+ -- and indicate that the real value is
+ -- now unknown.
+
+ Cumulative_Restrictions.Value (R) :=
+ Integer'Last;
+ Cumulative_Restrictions.Unknown (R) :=
+ True;
+ end;
+ end if;
+
+ -- Deal with + case
+
+ if Nextc = '+' then
+ Skipc;
+ ALIs.Table (Id).Restrictions.Unknown (R) :=
+ True;
+ Cumulative_Restrictions.Unknown (R) := True;
+ end if;
+
+ -- Other than 'R' or 'V'
+
+ when others =>
+ raise Bad_R_Line;
+ end case;
+
+ if not At_Eol then
+ raise Bad_R_Line;
+ end if;
+
+ -- Bizarre error case NOT_A_RESTRICTION
+
+ when Not_A_Restriction_Id =>
+ raise Bad_R_Line;
+ end case;
+
+ if not At_Eol then
+ raise Bad_R_Line;
+ end if;
+
+ <<Done_With_Restriction_Line>>
+ Skip_Line;
+ C := Getc;
+ end loop;
+
+ -- Positional restriction case
+
+ else
+ Checkc (' ');
+ Skip_Space;
+
+ -- Acquire information for boolean restrictions
+
+ for R in All_Boolean_Restrictions loop
+ C := Getc;
+
+ case C is
+ when 'v' =>
+ ALIs.Table (Id).Restrictions.Violated (R) := True;
+ Cumulative_Restrictions.Violated (R) := True;
+
+ when 'r' =>
+ ALIs.Table (Id).Restrictions.Set (R) := True;
+ Cumulative_Restrictions.Set (R) := True;
+
+ when 'n' =>
+ null;
+
+ when others =>
+ raise Bad_R_Line;
+ end case;
+ end loop;
+
+ -- Acquire information for parameter restrictions
+
+ for RP in All_Parameter_Restrictions loop
+ case Getc is
+ when 'n' =>
+ null;
+
+ when 'r' =>
+ ALIs.Table (Id).Restrictions.Set (RP) := True;
+
+ declare
+ N : constant Integer := Integer (Get_Nat);
+ begin
+ ALIs.Table (Id).Restrictions.Value (RP) := N;
+
+ if Cumulative_Restrictions.Set (RP) then
+ Cumulative_Restrictions.Value (RP) :=
+ Integer'Min
+ (Cumulative_Restrictions.Value (RP), N);
+ else
+ Cumulative_Restrictions.Set (RP) := True;
+ Cumulative_Restrictions.Value (RP) := N;
+ end if;
+ end;
+
+ when others =>
+ raise Bad_R_Line;
+ end case;
+
+ -- Acquire restrictions violations information
+
+ case Getc is
+
+ when 'n' =>
+ null;
+
+ when 'v' =>
+ ALIs.Table (Id).Restrictions.Violated (RP) := True;
+ Cumulative_Restrictions.Violated (RP) := True;
+
+ declare
+ N : constant Integer := Integer (Get_Nat);
+
+ begin
+ ALIs.Table (Id).Restrictions.Count (RP) := N;
+
+ if RP in Checked_Max_Parameter_Restrictions then
+ Cumulative_Restrictions.Count (RP) :=
+ Integer'Max
+ (Cumulative_Restrictions.Count (RP), N);
+
+ else
+ declare
+ pragma Unsuppress (Overflow_Check);
+
+ begin
+ Cumulative_Restrictions.Count (RP) :=
+ Cumulative_Restrictions.Count (RP) + N;
+
+ exception
+ when Constraint_Error =>
+
+ -- A constraint error comes from the add. We
+ -- reset to the maximum and indicate that the
+ -- real value is now unknown.
+
+ Cumulative_Restrictions.Value (RP) :=
+ Integer'Last;
+ Cumulative_Restrictions.Unknown (RP) := True;
+ end;
+ end if;
+
+ if Nextc = '+' then
+ Skipc;
+ ALIs.Table (Id).Restrictions.Unknown (RP) := True;
+ Cumulative_Restrictions.Unknown (RP) := True;
+ end if;
+ end;
+
+ when others =>
+ raise Bad_R_Line;
+ end case;
+ end loop;
+
+ if not At_Eol then
+ raise Bad_R_Line;
+ else
+ Skip_Line;
+ C := Getc;
+ end if;
+ end if;
+
+ -- Here if error during scanning of restrictions line
+
+ exception
+ when Bad_R_Line =>
+
+ -- In Ignore_Errors mode, undo any changes to restrictions
+ -- from this unit, and continue on, skipping remaining R
+ -- lines for this unit.
+
+ if Ignore_Errors then
+ Cumulative_Restrictions := Save_R;
+ ALIs.Table (Id).Restrictions := No_Restrictions;
+
+ loop
+ Skip_Eol;
+ C := Getc;
+ exit when C /= 'R';
+ end loop;
+
+ -- In normal mode, this is a fatal error
+
+ else
+ Fatal_Error;
+ end if;
+ end Scan_Restrictions;
+ end if;
+
+ -- Acquire additional restrictions (No_Dependence) lines if present
+
+ while C = 'R' loop
+ if Ignore ('R') then
+ Skip_Line;
+ else
+ Skip_Space;
+ No_Deps.Append ((Id, Get_Name));
+ Skip_Eol;
+ end if;
+
+ C := Getc;
+ end loop;
+
+ -- Acquire 'I' lines if present
+
+ Check_Unknown_Line;
+
+ while C = 'I' loop
+ if Ignore ('I') then
+ Skip_Line;
+
+ else
+ declare
+ Int_Num : Nat;
+ I_State : Character;
+ Line_No : Nat;
+
+ begin
+ Int_Num := Get_Nat;
+ Skip_Space;
+ I_State := Getc;
+ Line_No := Get_Nat;
+
+ Interrupt_States.Append (
+ (Interrupt_Id => Int_Num,
+ Interrupt_State => I_State,
+ IS_Pragma_Line => Line_No));
+
+ ALIs.Table (Id).Last_Interrupt_State := Interrupt_States.Last;
+ Skip_Eol;
+ end;
+ end if;
+
+ C := Getc;
+ end loop;
+
+ -- Acquire 'S' lines if present
+
+ Check_Unknown_Line;
+
+ while C = 'S' loop
+ if Ignore ('S') then
+ Skip_Line;
+
+ else
+ declare
+ Policy : Character;
+ First_Prio : Nat;
+ Last_Prio : Nat;
+ Line_No : Nat;
+
+ begin
+ Checkc (' ');
+ Skip_Space;
+
+ Policy := Getc;
+ Skip_Space;
+ First_Prio := Get_Nat;
+ Last_Prio := Get_Nat;
+ Line_No := Get_Nat;
+
+ Specific_Dispatching.Append (
+ (Dispatching_Policy => Policy,
+ First_Priority => First_Prio,
+ Last_Priority => Last_Prio,
+ PSD_Pragma_Line => Line_No));
+
+ ALIs.Table (Id).Last_Specific_Dispatching :=
+ Specific_Dispatching.Last;
+
+ Skip_Eol;
+ end;
+ end if;
+
+ C := Getc;
+ end loop;
+
+ -- Loop to acquire unit entries
+
+ U_Loop : loop
+ Check_Unknown_Line;
+ exit U_Loop when C /= 'U';
+
+ -- Note: as per spec, we never ignore U lines
+
+ 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;
+
+ declare
+ UL : Unit_Record renames Units.Table (Units.Last);
+
+ begin
+ UL.Uname := Get_Unit_Name;
+ UL.Predefined := Is_Predefined_Unit;
+ UL.Internal := Is_Internal_Unit;
+ UL.My_ALI := Id;
+ UL.Sfile := Get_File_Name (Lower => True);
+ UL.Pure := False;
+ UL.Preelab := False;
+ UL.No_Elab := False;
+ UL.Shared_Passive := False;
+ UL.RCI := False;
+ UL.Remote_Types := False;
+ UL.Has_RACW := False;
+ UL.Init_Scalars := False;
+ UL.Is_Generic := False;
+ UL.Icasing := Mixed_Case;
+ UL.Kcasing := All_Lower_Case;
+ UL.Dynamic_Elab := False;
+ UL.Elaborate_Body := False;
+ UL.Set_Elab_Entity := False;
+ UL.Version := "00000000";
+ UL.First_With := Withs.Last + 1;
+ UL.First_Arg := First_Arg;
+ UL.Elab_Position := 0;
+ UL.SAL_Interface := ALIs.Table (Id).SAL_Interface;
+ UL.Directly_Scanned := Directly_Scanned;
+ UL.Body_Needed_For_SAL := False;
+ UL.Elaborate_Body_Desirable := False;
+ UL.Optimize_Alignment := 'O';
+ UL.Has_Finalizer := False;
+
+ if Debug_Flag_U then
+ Write_Str (" ----> reading unit ");
+ Write_Int (Int (Units.Last));
+ Write_Str (" ");
+ Write_Unit_Name (UL.Uname);
+ Write_Str (" from file ");
+ Write_Name (UL.Sfile);
+ Write_Eol;
+ end if;
+ end;
+
+ -- 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;
+
+ -- BD/BN parameters
+
+ elsif C = 'B' then
+ C := Getc;
+
+ if C = 'D' then
+ Check_At_End_Of_Field;
+ Units.Table (Units.Last).Elaborate_Body_Desirable := True;
+
+ elsif C = 'N' then
+ Check_At_End_Of_Field;
+ Units.Table (Units.Last).Body_Needed_For_SAL := True;
+
+ else
+ Fatal_Error_Ignore;
+ end if;
+
+ -- DE parameter (Dynamic elaboration checks)
+
+ elsif C = 'D' then
+ C := Getc;
+
+ if C = 'E' then
+ Check_At_End_Of_Field;
+ Units.Table (Units.Last).Dynamic_Elab := True;
+ Dynamic_Elaboration_Checks_Specified := True;
+ else
+ Fatal_Error_Ignore;
+ end if;
+
+ -- 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_Ignore;
+ end if;
+
+ Check_At_End_Of_Field;
+
+ -- GE parameter (generic)
+
+ elsif C = 'G' then
+ C := Getc;
+
+ if C = 'E' then
+ Check_At_End_Of_Field;
+ Units.Table (Units.Last).Is_Generic := True;
+ else
+ Fatal_Error_Ignore;
+ end if;
+
+ -- 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_Ignore;
+ 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_Ignore;
+ end if;
+
+ Check_At_End_Of_Field;
+
+ -- NE parameter
+
+ elsif C = 'N' then
+ C := Getc;
+
+ if C = 'E' then
+ Units.Table (Units.Last).No_Elab := True;
+ Check_At_End_Of_Field;
+ else
+ Fatal_Error_Ignore;
+ end if;
+
+ -- PF/PR/PU/PK parameters
+
+ elsif C = 'P' then
+ C := Getc;
+
+ if C = 'F' then
+ Units.Table (Units.Last).Has_Finalizer := True;
+ elsif C = 'R' then
+ Units.Table (Units.Last).Preelab := True;
+ elsif C = 'U' then
+ Units.Table (Units.Last).Pure := True;
+ elsif C = 'K' then
+ Units.Table (Units.Last).Unit_Kind := 'p';
+ else
+ Fatal_Error_Ignore;
+ end if;
+
+ Check_At_End_Of_Field;
+
+ -- OL/OO/OS/OT parameters
+
+ elsif C = 'O' then
+ C := Getc;
+
+ if C = 'L' or else C = 'O' or else C = 'S' or else C = 'T' then
+ Units.Table (Units.Last).Optimize_Alignment := C;
+ else
+ Fatal_Error_Ignore;
+ end if;
+
+ Check_At_End_Of_Field;
+
+ -- RC/RT parameters
+
+ elsif C = 'R' then
+ C := Getc;
+
+ if C = 'C' then
+ Units.Table (Units.Last).RCI := True;
+ elsif C = 'T' then
+ Units.Table (Units.Last).Remote_Types := True;
+ elsif C = 'A' then
+ Units.Table (Units.Last).Has_RACW := True;
+ else
+ Fatal_Error_Ignore;
+ end if;
+
+ Check_At_End_Of_Field;
+
+ elsif C = 'S' then
+ C := Getc;
+
+ if C = 'P' then
+ Units.Table (Units.Last).Shared_Passive := True;
+ elsif C = 'U' then
+ Units.Table (Units.Last).Unit_Kind := 's';
+ else
+ Fatal_Error_Ignore;
+ end if;
+
+ Check_At_End_Of_Field;
+
+ else
+ C := Getc;
+ Fatal_Error_Ignore;
+ 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;
+
+ C := Getc;
+
+ -- Scan out With lines for this unit
+
+ With_Loop : loop
+ Check_Unknown_Line;
+ exit With_Loop when C /= 'W' and then C /= 'Y' and then C /= 'Z';
+
+ if Ignore ('W') then
+ Skip_Line;
+
+ else
+ Checkc (' ');
+ Skip_Space;
+ Withs.Increment_Last;
+ Withs.Table (Withs.Last).Uname := Get_Unit_Name;
+ Withs.Table (Withs.Last).Elaborate := False;
+ Withs.Table (Withs.Last).Elaborate_All := False;
+ Withs.Table (Withs.Last).Elab_Desirable := False;
+ Withs.Table (Withs.Last).Elab_All_Desirable := False;
+ Withs.Table (Withs.Last).SAL_Interface := False;
+ Withs.Table (Withs.Last).Limited_With := (C = 'Y');
+ Withs.Table (Withs.Last).Implicit_With_From_Instantiation
+ := (C = 'Z');
+
+ -- 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_File_Name
+ (Lower => True);
+ Withs.Table (Withs.Last).Afile := Get_File_Name
+ (Lower => True);
+
+ -- Scan out possible E, EA, ED, and AD parameters
+
+ while not At_Eol loop
+ Skip_Space;
+
+ if Nextc = 'A' then
+ P := P + 1;
+ Checkc ('D');
+ Check_At_End_Of_Field;
+
+ -- Store AD indication unless ignore required
+
+ if not Ignore_ED then
+ Withs.Table (Withs.Last).Elab_All_Desirable :=
+ True;
+ end if;
+
+ elsif 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_Desirable :=
+ True;
+ end if;
+ end if;
+
+ else
+ Fatal_Error;
+ end if;
+ end loop;
+ end if;
+
+ Skip_Eol;
+ end if;
+
+ 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 : loop
+ Check_Unknown_Line;
+ exit Linker_Options_Loop when C /= 'L';
+
+ if Ignore ('L') then
+ Skip_Line;
+
+ else
+ Checkc (' ');
+ Skip_Space;
+ Checkc ('"');
+
+ loop
+ C := Getc;
+
+ if C < Character'Val (16#20#)
+ or else C > Character'Val (16#7E#)
+ then
+ Fatal_Error_Ignore;
+
+ 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_Ignore;
+ 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;
+ end if;
+
+ C := Getc;
+ end loop Linker_Options_Loop;
+
+ -- Store the linker options entry if one was found
+
+ 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;
+
+ -- If there are notes present, scan them
+
+ Notes_Loop : loop
+ Check_Unknown_Line;
+ exit Notes_Loop when C /= 'N';
+
+ if Ignore ('N') then
+ Skip_Line;
+
+ else
+ Checkc (' ');
+
+ Notes.Increment_Last;
+ Notes.Table (Notes.Last).Pragma_Type := Getc;
+ Notes.Table (Notes.Last).Pragma_Line := Get_Nat;
+ Checkc (':');
+ Notes.Table (Notes.Last).Pragma_Col := Get_Nat;
+ Notes.Table (Notes.Last).Unit := Units.Last;
+
+ if At_Eol then
+ Notes.Table (Notes.Last).Pragma_Args := No_Name;
+
+ else
+ Checkc (' ');
+
+ Name_Len := 0;
+ while not At_Eol loop
+ Add_Char_To_Name_Buffer (Getc);
+ end loop;
+
+ Notes.Table (Notes.Last).Pragma_Args := Name_Enter;
+ end if;
+
+ Skip_Eol;
+ end if;
+
+ C := Getc;
+ end loop Notes_Loop;
+ end loop U_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
+
+ E_Loop : loop
+ Check_Unknown_Line;
+ exit E_Loop when C /= 'E';
+
+ if Ignore ('E') then
+ Skip_Line;
+
+ else
+ 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;
+ end if;
+
+ C := Getc;
+ end loop E_Loop;
+
+ -- Scan out source dependency lines for this ALI file
+
+ ALIs.Table (Id).First_Sdep := Sdep.Last + 1;
+
+ D_Loop : loop
+ Check_Unknown_Line;
+ exit D_Loop when C /= 'D';
+
+ if Ignore ('D') then
+ Skip_Line;
+
+ else
+ Checkc (' ');
+ Skip_Space;
+ Sdep.Increment_Last;
+
+ -- In the following call, Lower is not set to True, this is either
+ -- a bug, or it deserves a special comment as to why this is so???
+
+ Sdep.Table (Sdep.Last).Sfile := Get_File_Name;
+
+ 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
+ Add_Char_To_Name_Buffer (Getc);
+ end loop;
+
+ -- Set the subunit name. Note that we use Name_Find rather
+ -- than Name_Enter here as the subunit name may already
+ -- have been put in the name table by the Project Manager.
+
+ Sdep.Table (Sdep.Last).Subunit_Name := Name_Find;
+
+ 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
+ Add_Char_To_Name_Buffer (Getc);
+ end loop;
+
+ Sdep.Table (Sdep.Last).Rfile := Name_Enter;
+ end if;
+ end if;
+
+ Skip_Eol;
+ end if;
+
+ C := Getc;
+ end loop D_Loop;
+
+ ALIs.Table (Id).Last_Sdep := Sdep.Last;
+
+ -- We must at this stage be at an Xref line or the end of file
+
+ if C = EOF then
+ return Id;
+ end if;
+
+ Check_Unknown_Line;
+
+ if C /= 'X' then
+ Fatal_Error;
+ end if;
+
+ -- If we are ignoring Xref sections we are done (we ignore all
+ -- remaining lines since only xref related lines follow X).
+
+ if Ignore ('X') and then not Debug_Flag_X then
+ return Id;
+ end if;
+
+ -- Loop through Xref sections
+
+ X_Loop : loop
+ Check_Unknown_Line;
+ exit X_Loop when C /= 'X';
+
+ -- 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_File_Name;
+ XS.First_Entity := Xref_Entity.Last + 1;
+
+ Current_File_Num := XS.File_Num;
+
+ Skip_Space;
+
+ 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
+ Local_File_Num : Sdep_Id := Current_File_Num;
+
+ 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);
+ Local_File_Num := XR.File_Num;
+ P := P + 1;
+ N := Get_Nat;
+
+ else
+ XR.File_Num := Local_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;
+
+ case Getc is
+ when '*' =>
+ XE.Visibility := Global;
+ when '+' =>
+ XE.Visibility := Static;
+ when others =>
+ XE.Visibility := Other;
+ end case;
+
+ XE.Entity := Get_Name;
+
+ -- Handle the information about generic instantiations
+
+ if Nextc = '[' then
+ Skipc; -- Opening '['
+ N := Get_Nat;
+
+ if Nextc /= '|' then
+ XE.Iref_File_Num := Current_File_Num;
+ XE.Iref_Line := N;
+ else
+ XE.Iref_File_Num :=
+ Sdep_Id (N + Nat (First_Sdep_Entry) - 1);
+ Skipc;
+ XE.Iref_Line := Get_Nat;
+ end if;
+
+ if Getc /= ']' then
+ Fatal_Error;
+ end if;
+
+ else
+ XE.Iref_File_Num := No_Sdep_Id;
+ XE.Iref_Line := 0;
+ end if;
+
+ Current_File_Num := XS.File_Num;
+
+ -- 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;
+
+ XE.Oref_File_Num := No_Sdep_Id;
+ XE.Tref_File_Num := No_Sdep_Id;
+ XE.Tref := Tref_None;
+ XE.First_Xref := Xref.Last + 1;
+
+ -- Loop to check for additional info present
+
+ loop
+ declare
+ Ref : Tref_Kind;
+ File : Sdep_Id;
+ Line : Nat;
+ Typ : Character;
+ Col : Nat;
+ Std : Name_Id;
+
+ begin
+ Get_Typeref
+ (Current_File_Num, Ref, File, Line, Typ, Col, Std);
+ exit when Ref = Tref_None;
+
+ -- Do we have an overriding procedure?
+
+ if Ref = Tref_Derived and then Typ = 'p' then
+ XE.Oref_File_Num := File;
+ XE.Oref_Line := Line;
+ XE.Oref_Col := Col;
+
+ -- Arrays never override anything, and <> points to
+ -- the index types instead
+
+ elsif Ref = Tref_Derived and then XE.Etype = 'A' then
+
+ -- Index types are stored in the list of references
+
+ Xref.Increment_Last;
+
+ declare
+ XR : Xref_Record renames Xref.Table (Xref.Last);
+ begin
+ XR.File_Num := File;
+ XR.Line := Line;
+ XR.Rtype := Array_Index_Reference;
+ XR.Col := Col;
+ XR.Name := Std;
+ end;
+
+ -- Interfaces are stored in the list of references,
+ -- although the parent type itself is stored in XE.
+ -- The first interface (when there are only
+ -- interfaces) is stored in XE.Tref*)
+
+ elsif Ref = Tref_Derived
+ and then Typ = 'R'
+ and then XE.Tref_File_Num /= No_Sdep_Id
+ then
+ Xref.Increment_Last;
+
+ declare
+ XR : Xref_Record renames Xref.Table (Xref.Last);
+ begin
+ XR.File_Num := File;
+ XR.Line := Line;
+ XR.Rtype := Interface_Reference;
+ XR.Col := Col;
+ XR.Name := Std;
+ end;
+
+ else
+ XE.Tref := Ref;
+ XE.Tref_File_Num := File;
+ XE.Tref_Line := Line;
+ XE.Tref_Type := Typ;
+ XE.Tref_Col := Col;
+ XE.Tref_Standard_Entity := Std;
+ end if;
+ end;
+ end loop;
+
+ -- Loop through cross-references for this entity
+
+ 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;
+
+ -- Imported entities reference as in:
+ -- 494b<c,__gnat_copy_attribs>25
+
+ if Nextc = '<' then
+ Skipc;
+ XR.Imported_Lang := Get_Name;
+
+ pragma Assert (Nextc = ',');
+ Skipc;
+
+ XR.Imported_Name := Get_Name;
+
+ pragma Assert (Nextc = '>');
+ Skipc;
+
+ else
+ XR.Imported_Lang := No_Name;
+ XR.Imported_Name := No_Name;
+ end if;
+
+ 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;
+
+ exception
+ when Bad_ALI_Format =>
+
+ -- If ignoring errors, then we skip a line with an
+ -- unexpected error, and try to continue subsequent
+ -- xref lines.
+
+ if Ignore_Errors then
+ Xref_Entity.Decrement_Last;
+ Skip_Line;
+ C := Nextc;
+
+ -- Otherwise, we reraise the fatal exception
+
+ else
+ raise;
+ end if;
+ 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 X_Loop;
+
+ -- Here after dealing with xref sections
+
+ -- Ignore remaining lines, which belong to an additional section of the
+ -- ALI file not considered here (like SCO or Alfa).
+
+ Check_Unknown_Line;
+
+ 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;