| ------------------------------------------------------------------------------ |
| -- -- |
| -- 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; |
