-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2003 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2004 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- --
-- --
------------------------------------------------------------------------------
-with Butil; use Butil;
-with Debug; use Debug;
-with Fname; use Fname;
-with Namet; use Namet;
-with Opt; use Opt;
-with Osint; use Osint;
-with Output; use Output;
+with Butil; use Butil;
+with Debug; use Debug;
+with Fname; use Fname;
+with Namet; use Namet;
+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
+ 'E' => True, -- external
+ 'D' => True, -- dependency
+ 'X' => True, -- xref
+ others => False);
+
--------------------
-- Initialize_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")
- return ALI_Id
+ (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) return ALI_Id
is
P : Text_Ptr := T'First;
Line : Logical_Line_Number := 1;
-- be ignored by Scan_ALI and skipped, and False if the lines
-- are to be read and processed.
+ Restrictions_Initial : Rident.Restrictions_Info;
+ pragma Warnings (Off, Restrictions_Initial);
+ -- This variable, which should really be a constant (but that's not
+ -- allowed by the language) is used only for initialization, and the
+ -- reason we are declaring it is to get the default initialization
+ -- set for the object.
+
Bad_ALI_Format : exception;
-- Exception raised by Fatal_Error if Err is True
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
procedure Check_At_End_Of_Field is
begin
if not At_End_Of_Field then
- Fatal_Error;
+ 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;
begin
if Nextc = C then
P := P + 1;
+ elsif Ignore_Errors then
+ P := P + 1;
else
Fatal_Error;
end if;
end Checkc;
+ ------------------------
+ -- 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;
+
-----------------
-- Fatal_Error --
-----------------
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_Name --
--------------
- function Get_Name (Lower : Boolean := False;
- Ignore_Spaces : Boolean := False) return Name_Id is
+ function Get_Name
+ (Lower : Boolean := False;
+ Ignore_Spaces : Boolean := False) return Name_Id
+ is
begin
Name_Len := 0;
Skip_Space;
if At_Eol then
- Fatal_Error;
+ if Ignore_Errors then
+ return Error_Name;
+ else
+ Fatal_Error;
+ end if;
end if;
loop
Skip_Space;
V := 0;
-
loop
V := V * 10 + (Character'Pos (Getc) - Character'Pos ('0'));
exit when At_End_Of_Field;
Skip_Space;
if At_Eol then
- Fatal_Error;
+ 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
begin
Skip_Space;
- if not At_Eol then Fatal_Error; end if;
+ 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)
-- Start of processing for Scan_ALI
begin
+ First_Sdep_Entry := Sdep.Last + 1;
+
-- Acquire lines to be ignored
if Read_Xref then
Normalize_Scalars => False,
Ofile_Full_Name => Full_Object_File_Name,
Queuing_Policy => ' ',
- Restrictions => (others => ' '),
+ Restrictions => Restrictions_Initial,
Sfile => No_Name,
Task_Dispatching_Policy => ' ',
Time_Slice_Value => -1,
-- 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
end if;
C := Getc;
+ Check_Unknown_Line;
-- Acquire main program line if present
First_Arg := Args.Last + 1;
- Arg_Loop : while C = 'A' loop
+ A_Loop : loop
+ Check_Unknown_Line;
+ exit A_Loop when C /= 'A';
+
if Ignore ('A') then
Skip_Line;
end if;
C := Getc;
- end loop Arg_Loop;
+ end loop A_Loop;
-- Acquire P line
- if C /= 'P' then
- Fatal_Error;
+ 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;
- elsif Ignore ('P') then
+ if Ignore ('P') then
Skip_Line;
+ -- Process P line
+
else
NS_Found := False;
-- Invalid switch starting with N
else
- Fatal_Error;
+ Fatal_Error_Ignore;
end if;
-- Processing for Qx
Queuing_Policy_Specified := Getc;
ALIs.Table (Id).Queuing_Policy := Queuing_Policy_Specified;
- -- Processing fir flags starting with S
+ -- Processing for flags starting with S
elsif C = 'S' then
C := Getc;
-- Invalid switch starting with S
else
- Fatal_Error;
+ Fatal_Error_Ignore;
end if;
-- Processing for Tx
-- Invalid switches starting with U
else
- Fatal_Error;
+ Fatal_Error_Ignore;
end if;
-- Processing for ZX
elsif C = 'Z' then
- Checkc ('X');
+ 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
- Fatal_Error;
+ C := Getc;
+ Fatal_Error_Ignore;
end if;
end loop;
end if;
C := Getc;
+ Check_Unknown_Line;
-- Acquire restrictions line
- if C /= 'R' then
- Fatal_Error;
+ 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;
- elsif Ignore ('R') then
+ if Ignore ('R') then
Skip_Line;
+ -- Process restrictions line
+
else
- Checkc (' ');
- Skip_Space;
+ Scan_Restrictions : declare
+ Save_R : constant Restrictions_Info := Cumulative_Restrictions;
+ -- Save cumulative restrictions in case we have a fatal error
- for J in All_Restrictions loop
- C := Getc;
- ALIs.Table (Id).Restrictions (J) := C;
+ Bad_R_Line : exception;
+ -- Signal bad restrictions line
+
+ begin
+ Checkc (' ');
+ Skip_Space;
- case C is
- when 'v' =>
- Restrictions (J) := 'v';
+ -- Acquire information for boolean restrictions
- when 'r' =>
- if Restrictions (J) = 'n' then
- Restrictions (J) := 'r';
- end if;
+ for R in All_Boolean_Restrictions loop
+ C := Getc;
- when 'n' =>
- null;
+ 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 =>
+ Fatal_Error;
+ 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 =>
+ Fatal_Error;
+ 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 =>
+ Fatal_Error;
+ 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.
- when others =>
+ if Ignore_Errors then
+ Cumulative_Restrictions := Save_R;
+ ALIs.Table (Id).Restrictions := Restrictions_Initial;
+
+ -- In normal mode, this is a fatal error
+
+ else
Fatal_Error;
- end case;
- end loop;
+ end if;
- Skip_Eol;
+ end Scan_Restrictions;
end if;
- C := Getc;
-
-- Acquire 'I' lines if present
+ C := Getc;
+ Check_Unknown_Line;
+
while C = 'I' loop
if Ignore ('I') then
Skip_Line;
-- Loop to acquire unit entries
- Unit_Loop : while C = 'U' loop
+ U_Loop : loop
+ Check_Unknown_Line;
+ exit U_Loop when C /= 'U';
-- Note: as per spec, we never ignore U lines
-- BN parameter (Body needed)
elsif C = 'B' then
- Checkc ('N');
- Check_At_End_Of_Field;
- Units.Table (Units.Last).Body_Needed_For_SAL := True;
+ C := Getc;
- -- DE parameter (Dynamic elaboration checks
+ if 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
- Checkc ('E');
- Check_At_End_Of_Field;
- Units.Table (Units.Last).Dynamic_Elab := True;
- Dynamic_Elaboration_Checks_Specified := True;
+ 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
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;
+ Fatal_Error_Ignore;
end if;
Check_At_End_Of_Field;
-- GE parameter (generic)
elsif C = 'G' then
- Checkc ('E');
- Check_At_End_Of_Field;
- Units.Table (Units.Last).Is_Generic := True;
+ 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
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;
+ Fatal_Error_Ignore;
end if;
Check_At_End_Of_Field;
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;
+ Fatal_Error_Ignore;
end if;
Check_At_End_Of_Field;
-- NE parameter
elsif C = 'N' then
- Checkc ('E');
- Units.Table (Units.Last).No_Elab := True;
- Check_At_End_Of_Field;
+ 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;
- -- PR parameter (preelaborate)
-
if C = 'R' then
Units.Table (Units.Last).Preelab := True;
-
- -- PU parameter (pure)
-
elsif C = 'U' then
Units.Table (Units.Last).Pure := True;
-
- -- PK indicates unit is package
-
elsif C = 'K' then
Units.Table (Units.Last).Unit_Kind := 'p';
-
else
- Fatal_Error;
+ Fatal_Error_Ignore;
end if;
Check_At_End_Of_Field;
elsif C = 'R' then
C := Getc;
- -- RC parameter (remote call interface)
-
if C = 'C' then
Units.Table (Units.Last).RCI := True;
-
- -- RT parameter (remote types)
-
elsif C = 'T' then
Units.Table (Units.Last).Remote_Types := True;
-
- -- RA parameter (remote access to class wide type)
-
elsif C = 'A' then
Units.Table (Units.Last).Has_RACW := True;
-
else
- Fatal_Error;
+ Fatal_Error_Ignore;
end if;
Check_At_End_Of_Field;
elsif C = 'S' then
C := Getc;
- -- SP parameter (shared passive)
-
if C = 'P' then
Units.Table (Units.Last).Shared_Passive := True;
-
- -- SU parameter indicates unit is subprogram
-
elsif C = 'U' then
Units.Table (Units.Last).Unit_Kind := 's';
-
else
- Fatal_Error;
+ Fatal_Error_Ignore;
end if;
Check_At_End_Of_Field;
else
- Fatal_Error;
+ C := Getc;
+ Fatal_Error_Ignore;
end if;
end loop;
-- Scan out With lines for this unit
- With_Loop : while C = 'W' loop
+ With_Loop : loop
+ Check_Unknown_Line;
+ exit With_Loop when C /= 'W';
+
if Ignore ('W') then
Skip_Line;
Name_Len := 0;
- Linker_Options_Loop : while C = 'L' loop
+ Linker_Options_Loop : loop
+ Check_Unknown_Line;
+ exit Linker_Options_Loop when C /= 'L';
if Ignore ('L') then
Skip_Line;
if C < Character'Val (16#20#)
or else C > Character'Val (16#7E#)
then
- Fatal_Error;
+ Fatal_Error_Ignore;
elsif C = '{' then
C := Character'Val (0);
10;
else
- Fatal_Error;
+ Fatal_Error_Ignore;
end if;
end loop;
Linker_Options.Table (Linker_Options.Last).Original_Pos :=
Linker_Options.Last;
end if;
- end loop Unit_Loop;
+ end loop U_Loop;
-- End loop through units for one ALI file
-- Scan out external version references and put in hash table
- while C = 'E' loop
+ E_Loop : loop
+ Check_Unknown_Line;
+ exit E_Loop when C /= 'E';
+
if Ignore ('E') then
Skip_Line;
end if;
C := Getc;
- end loop;
+ end loop E_Loop;
-- Scan out source dependency lines for this ALI file
ALIs.Table (Id).First_Sdep := Sdep.Last + 1;
- while C = 'D' loop
+ D_Loop : loop
+ Check_Unknown_Line;
+ exit D_Loop when C /= 'D';
+
if Ignore ('D') then
Skip_Line;
end if;
C := Getc;
- end loop;
+ 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 and then C /= 'X' then
+ if C = EOF then
+ return Id;
+ end if;
+
+ Check_Unknown_Line;
+
+ if C /= 'X' then
Fatal_Error;
end if;
-- Loop through Xref sections
- while C = 'X' loop
+ X_Loop : loop
+ Check_Unknown_Line;
+ exit X_Loop when C /= 'X';
-- Make new entry in section table
----------------------------------
procedure Read_Instantiation_Reference is
+ Local_File_Num : Sdep_Id := Current_File_Num;
+
begin
Xref.Increment_Last;
if Nextc = '|' then
XR.File_Num :=
Sdep_Id (N + Nat (First_Sdep_Entry) - 1);
- Current_File_Num := XR.File_Num;
+ Local_File_Num := XR.File_Num;
P := P + 1;
N := Get_Nat;
else
- XR.File_Num := Current_File_Num;
+ XR.File_Num := Local_File_Num;
end if;
XR.Line := N;
end Read_Refs_For_One_File;
C := Getc;
- end loop;
+ end loop X_Loop;
-- Here after dealing with xref sections
projects / gcc.git / blobdiff