From 554fd8c5195424bdbcabf5de30fdc183aba391bd Mon Sep 17 00:00:00 2001 From: upstream source tree Date: Sun, 15 Mar 2015 20:14:05 -0400 Subject: obtained gcc-4.6.4.tar.bz2 from upstream website; verified gcc-4.6.4.tar.bz2.sig; imported gcc-4.6.4 source tree from verified upstream tarball. downloading a git-generated archive based on the 'upstream' tag should provide you with a source tree that is binary identical to the one extracted from the above tarball. if you have obtained the source via the command 'git clone', however, do note that line-endings of files in your working directory might differ from line-endings of the respective files in the upstream repository. --- gcc/ada/ali.adb | 2475 +++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 2475 insertions(+) create mode 100644 gcc/ada/ali.adb (limited to 'gcc/ada/ali.adb') diff --git a/gcc/ada/ali.adb b/gcc/ada/ali.adb new file mode 100644 index 000000000..4ea38e2ef --- /dev/null +++ b/gcc/ada/ali.adb @@ -0,0 +1,2475 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- A L I -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2010, 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 + 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; + 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 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' | '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, + 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 + + if Name_Buffer (1 .. Name_Len) = "-fstack-check" 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 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; + + -- Acquire 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; + + if Ignore ('R') then + Skip_Line; + + -- Process restrictions line + + 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) + + begin + 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 + + -- Acquire restrictions pragma information + + 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); + pragma Unsuppress (Overflow_Check); + + 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 + Cumulative_Restrictions.Count (RP) := + Cumulative_Restrictions.Count (RP) + N; + end if; + + exception + when Constraint_Error => + + -- A constraint error comes from the addition in + -- the else branch. 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; + + if Nextc = '+' then + Skipc; + ALIs.Table (Id).Restrictions.Unknown (RP) := True; + Cumulative_Restrictions.Unknown (RP) := True; + end if; + + when others => + raise Bad_R_Line; + end case; + end loop; + + Skip_Eol; + + -- 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. + + if Ignore_Errors then + Cumulative_Restrictions := Save_R; + ALIs.Table (Id).Restrictions := No_Restrictions; + Skip_Eol; + + -- 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 + + C := Getc; + 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'; + + 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; + + -- PR/PU/PK parameters + + elsif C = 'P' then + C := Getc; + + if 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'; + + 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'); + + -- 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: + -- 494b25 + -- ??? Simply skipped for now + + if Nextc = '<' then + while Getc /= '>' loop + null; + end loop; + 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 + + 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; -- cgit v1.2.3