with ALI; use ALI;
with ALI.Util; use ALI.Util;
with Binderr; use Binderr;
with Butil; use Butil;
with Casing; use Casing;
with Debug; use Debug;
with Fname; use Fname;
with Namet; use Namet;
with Opt; use Opt;
with Osint;
with Output; use Output;
with Rident; use Rident;
with Types; use Types;
package body Bcheck is
procedure Check_Consistent_Dynamic_Elaboration_Checking;
procedure Check_Consistent_Floating_Point_Format;
procedure Check_Consistent_Locking_Policy;
procedure Check_Consistent_Normalize_Scalars;
procedure Check_Consistent_Queuing_Policy;
procedure Check_Consistent_Zero_Cost_Exception_Handling;
procedure Check_Partition_Restrictions;
procedure Consistency_Error_Msg (Msg : String);
procedure Check_Configuration_Consistency is
begin
if Float_Format_Specified /= ' ' then
Check_Consistent_Floating_Point_Format;
end if;
if Queuing_Policy_Specified /= ' ' then
Check_Consistent_Queuing_Policy;
end if;
if Locking_Policy_Specified /= ' ' then
Check_Consistent_Locking_Policy;
end if;
if Zero_Cost_Exceptions_Specified then
Check_Consistent_Zero_Cost_Exception_Handling;
end if;
Check_Consistent_Normalize_Scalars;
Check_Consistent_Dynamic_Elaboration_Checking;
Check_Partition_Restrictions;
end Check_Configuration_Consistency;
procedure Check_Consistent_Dynamic_Elaboration_Checking is
begin
if Dynamic_Elaboration_Checks_Specified then
for U in First_Unit_Entry .. Units.Last loop
declare
UR : Unit_Record renames Units.Table (U);
begin
if UR.Dynamic_Elab then
for W in UR.First_With .. UR.Last_With loop
declare
WR : With_Record renames Withs.Table (W);
begin
if Get_Name_Table_Info (WR.Uname) /= 0 then
declare
WU : Unit_Record renames
Units.Table
(Unit_Id
(Get_Name_Table_Info (WR.Uname)));
begin
if WR.Elaborate_All then
null;
elsif WU.Dynamic_Elab then
null;
elsif WU.Preelab or WU.Pure then
null;
elsif Is_Internal_File_Name (WU.Sfile) then
null;
else
Error_Msg_Name_1 := UR.Sfile;
Error_Msg
("?% has dynamic elaboration checks " &
"and with's");
Error_Msg_Name_1 := WU.Sfile;
Error_Msg
("? % which has static elaboration " &
"checks");
Warnings_Detected := Warnings_Detected - 1;
end if;
end;
end if;
end;
end loop;
end if;
end;
end loop;
end if;
end Check_Consistent_Dynamic_Elaboration_Checking;
procedure Check_Consistent_Floating_Point_Format is
begin
Find_Format : for A1 in ALIs.First .. ALIs.Last loop
if ALIs.Table (A1).Float_Format /= ' ' then
Check_Format : declare
Format : constant Character := ALIs.Table (A1).Float_Format;
begin
for A2 in A1 + 1 .. ALIs.Last loop
if ALIs.Table (A2).Float_Format /= Format then
Error_Msg_Name_1 := ALIs.Table (A1).Sfile;
Error_Msg_Name_2 := ALIs.Table (A2).Sfile;
Consistency_Error_Msg
("% and % compiled with different " &
"floating-point representations");
exit Find_Format;
end if;
end loop;
end Check_Format;
exit Find_Format;
end if;
end loop Find_Format;
end Check_Consistent_Floating_Point_Format;
procedure Check_Consistent_Locking_Policy is
begin
Find_Policy : for A1 in ALIs.First .. ALIs.Last loop
if ALIs.Table (A1).Locking_Policy /= ' ' then
Check_Policy : declare
Policy : constant Character := ALIs.Table (A1).Locking_Policy;
begin
for A2 in A1 + 1 .. ALIs.Last loop
if ALIs.Table (A2).Locking_Policy /= ' ' and
ALIs.Table (A2).Locking_Policy /= Policy
then
Error_Msg_Name_1 := ALIs.Table (A1).Sfile;
Error_Msg_Name_2 := ALIs.Table (A2).Sfile;
Consistency_Error_Msg
("% and % compiled with different locking policies");
exit Find_Policy;
end if;
end loop;
end Check_Policy;
exit Find_Policy;
end if;
end loop Find_Policy;
end Check_Consistent_Locking_Policy;
procedure Check_Consistent_Normalize_Scalars is
begin
if Normalize_Scalars_Specified and No_Normalize_Scalars_Specified then
Consistency_Error_Msg
("some but not all files compiled with Normalize_Scalars");
Write_Eol;
Write_Str ("files compiled with Normalize_Scalars");
Write_Eol;
for A1 in ALIs.First .. ALIs.Last loop
if ALIs.Table (A1).Normalize_Scalars then
Write_Str (" ");
Write_Name (ALIs.Table (A1).Sfile);
Write_Eol;
end if;
end loop;
Write_Eol;
Write_Str ("files compiled without Normalize_Scalars");
Write_Eol;
for A1 in ALIs.First .. ALIs.Last loop
if not ALIs.Table (A1).Normalize_Scalars then
Write_Str (" ");
Write_Name (ALIs.Table (A1).Sfile);
Write_Eol;
end if;
end loop;
end if;
end Check_Consistent_Normalize_Scalars;
procedure Check_Consistent_Queuing_Policy is
begin
Find_Policy : for A1 in ALIs.First .. ALIs.Last loop
if ALIs.Table (A1).Queuing_Policy /= ' ' then
Check_Policy : declare
Policy : constant Character := ALIs.Table (A1).Queuing_Policy;
begin
for A2 in A1 + 1 .. ALIs.Last loop
if ALIs.Table (A2).Queuing_Policy /= ' '
and then
ALIs.Table (A2).Queuing_Policy /= Policy
then
Error_Msg_Name_1 := ALIs.Table (A1).Sfile;
Error_Msg_Name_2 := ALIs.Table (A2).Sfile;
Consistency_Error_Msg
("% and % compiled with different queuing policies");
exit Find_Policy;
end if;
end loop;
end Check_Policy;
exit Find_Policy;
end if;
end loop Find_Policy;
end Check_Consistent_Queuing_Policy;
procedure Check_Consistent_Zero_Cost_Exception_Handling is
begin
Check_Mechanism : for A1 in ALIs.First + 1 .. ALIs.Last loop
if ALIs.Table (A1).Zero_Cost_Exceptions /=
ALIs.Table (ALIs.First).Zero_Cost_Exceptions
then
Error_Msg_Name_1 := ALIs.Table (A1).Sfile;
Error_Msg_Name_2 := ALIs.Table (ALIs.First).Sfile;
Consistency_Error_Msg ("% and % compiled with different "
& "exception handling mechanisms");
end if;
end loop Check_Mechanism;
end Check_Consistent_Zero_Cost_Exception_Handling;
procedure Check_Partition_Restrictions is
R : array (Partition_Restrictions) of ALI_Id := (others => No_ALI_Id);
V : array (Partition_Restrictions) of ALI_Id := (others => No_ALI_Id);
procedure List_Applicable_Restrictions;
procedure List_Applicable_Restrictions is
Additional_Restrictions_Listed : Boolean := False;
begin
for J in Partition_Restrictions loop
if V (J) = No_ALI_Id and R (J) = No_ALI_Id then
if not Additional_Restrictions_Listed then
Write_Str ("The following additional restrictions may be" &
" applied to this partition:");
Write_Eol;
Additional_Restrictions_Listed := True;
end if;
Write_Str ("pragma Restrictions (");
declare
S : constant String := Restriction_Id'Image (J);
begin
Name_Len := S'Length;
Name_Buffer (1 .. Name_Len) := S;
end;
Set_Casing (Mixed_Case);
Write_Str (Name_Buffer (1 .. Name_Len));
Write_Str (");");
Write_Eol;
end if;
end loop;
end List_Applicable_Restrictions;
begin
Find_Restrictions :
for A in ALIs.First .. ALIs.Last loop
for J in Partition_Restrictions loop
if R (J) = No_ALI_Id and ALIs.Table (A).Restrictions (J) = 'r' then
R (J) := A;
end if;
end loop;
end loop Find_Restrictions;
Find_Violations :
for A in ALIs.First .. ALIs.Last loop
for J in Partition_Restrictions loop
if ALIs.Table (A).Restrictions (J) = 'v'
and then not Is_Internal_File_Name (ALIs.Table (A).Sfile)
then
V (J) := A;
if R (J) /= No_ALI_Id then
Report_Violated_Restriction : declare
M1 : constant String := "% has Restriction (";
S : constant String := Restriction_Id'Image (J);
M2 : String (1 .. M1'Length + S'Length + 1);
begin
Name_Buffer (1 .. S'Length) := S;
Name_Len := S'Length;
Set_Casing
(Units.Table (ALIs.Table (R (J)).First_Unit).Icasing);
M2 (M1'Range) := M1;
M2 (M1'Length + 1 .. M2'Last - 1) :=
Name_Buffer (1 .. S'Length);
M2 (M2'Last) := ')';
Error_Msg_Name_1 := ALIs.Table (R (J)).Sfile;
Consistency_Error_Msg (M2);
Error_Msg_Name_1 := ALIs.Table (A).Sfile;
Consistency_Error_Msg
("but file % violates this restriction");
end Report_Violated_Restriction;
end if;
end if;
end loop;
end loop Find_Violations;
if Debug_Flag_R then
List_Applicable_Restrictions;
end if;
end Check_Partition_Restrictions;
procedure Check_Consistency is
Src : Source_Id;
begin
for S in Source.First .. Source.Last loop
if Source.Table (S).All_Timestamps_Match then
null;
elsif not Source.Table (S).Source_Found then
null;
elsif not Source.Table (S).All_Checksums_Match then
null;
elsif Check_Source_Files then
if not Checksums_Match
(Source.Table (S).Checksum,
Get_File_Checksum (Source.Table (S).Sfile))
then
Source.Table (S).All_Checksums_Match := False;
end if;
end if;
end loop;
ALIs_Loop : for A in ALIs.First .. ALIs.Last loop
Sdep_Loop : for D in
ALIs.Table (A).First_Sdep .. ALIs.Table (A).Last_Sdep
loop
if Sdep.Table (D).Dummy_Entry then
goto Continue;
end if;
Src := Source_Id (Get_Name_Table_Info (Sdep.Table (D).Sfile));
if Sdep.Table (D).Stamp /= Source.Table (Src).Stamp
and then not Source.Table (Src).All_Checksums_Match
then
Error_Msg_Name_1 := ALIs.Table (A).Sfile;
Error_Msg_Name_2 := Sdep.Table (D).Sfile;
if Error_Msg_Name_1 = Error_Msg_Name_2 then
if Tolerate_Consistency_Errors then
Error_Msg
("?% has been modified and should be recompiled");
else
Error_Msg
("% has been modified and must be recompiled");
end if;
else
if Tolerate_Consistency_Errors then
Error_Msg
("?% should be recompiled (% has been modified)");
else
Error_Msg ("% must be recompiled (% has been modified)");
end if;
end if;
if (not Tolerate_Consistency_Errors) and Verbose_Mode then
declare
Msg : constant String := "file % has time stamp ";
Buf : String (1 .. Msg'Length + Time_Stamp_Length);
begin
Buf (1 .. Msg'Length) := Msg;
Buf (Msg'Length + 1 .. Buf'Length) :=
String (Source.Table (Src).Stamp);
Error_Msg_Name_1 := ALIs.Table (A).Sfile;
Error_Msg (Buf);
Buf (Msg'Length + 1 .. Buf'Length) :=
String (Sdep.Table (D).Stamp);
Error_Msg_Name_1 := Sdep.Table (D).Sfile;
Error_Msg (Buf);
end;
end if;
exit Sdep_Loop;
end if;
<<Continue>>
null;
end loop Sdep_Loop;
end loop ALIs_Loop;
end Check_Consistency;
procedure Check_Duplicated_Subunits is
begin
for J in Sdep.First .. Sdep.Last loop
if Sdep.Table (J).Subunit_Name /= No_Name then
Get_Decoded_Name_String (Sdep.Table (J).Subunit_Name);
Name_Len := Name_Len + 2;
Name_Buffer (Name_Len - 1) := '%';
for K in Boolean loop
if K then
Name_Buffer (Name_Len) := 'b';
else
Name_Buffer (Name_Len) := 's';
end if;
declare
Info : constant Int := Get_Name_Table_Info (Name_Find);
begin
if Info /= 0 then
Set_Standard_Error;
Write_Str ("error: subunit """);
Write_Name_Decoded (Sdep.Table (J).Subunit_Name);
Write_Str (""" in file """);
Write_Name_Decoded (Sdep.Table (J).Sfile);
Write_Char ('"');
Write_Eol;
Write_Str (" has same name as 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;
Write_Str (" this is not allowed within a single "
& "partition (RM 10.2(19))");
Write_Eol;
Osint.Exit_Program (Osint.E_Fatal);
end if;
end;
end loop;
end if;
end loop;
end Check_Duplicated_Subunits;
procedure Check_Versions is
VL : constant Natural := ALIs.Table (ALIs.First).Ver_Len;
begin
for A in ALIs.First .. ALIs.Last loop
if ALIs.Table (A).Ver_Len /= VL
or else ALIs.Table (A).Ver (1 .. VL) /=
ALIs.Table (ALIs.First).Ver (1 .. VL)
then
Error_Msg_Name_1 := ALIs.Table (A).Sfile;
Error_Msg_Name_2 := ALIs.Table (ALIs.First).Sfile;
Consistency_Error_Msg
("% and % compiled with different GNAT versions");
end if;
end loop;
end Check_Versions;
procedure Consistency_Error_Msg (Msg : String) is
begin
if Tolerate_Consistency_Errors then
declare
Warning_Msg : String (1 .. Msg'Length + 1);
begin
Warning_Msg (1) := '?';
Warning_Msg (2 .. Warning_Msg'Last) := Msg;
Error_Msg (Warning_Msg);
end;
else
Error_Msg (Msg);
end if;
end Consistency_Error_Msg;
end Bcheck;