-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2008, 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 2, or (at your option) any later ver- --
+-- 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 COPYING. If not, write --
--- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
--- Boston, MA 02110-1301, USA. --
+-- 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. --
-----------------------
-- The following checking subprograms make up the parts of the
- -- configuration consistency check.
+ -- configuration consistency check. See bodies for details of checks.
procedure Check_Consistent_Dispatching_Policy;
procedure Check_Consistent_Dynamic_Elaboration_Checking;
procedure Check_Consistent_Interrupt_States;
procedure Check_Consistent_Locking_Policy;
procedure Check_Consistent_Normalize_Scalars;
+ procedure Check_Consistent_Optimize_Alignment;
procedure Check_Consistent_Queuing_Policy;
procedure Check_Consistent_Restrictions;
+ procedure Check_Consistent_Restriction_No_Default_Initialization;
procedure Check_Consistent_Zero_Cost_Exception_Handling;
procedure Consistency_Error_Msg (Msg : String);
-- Produce an error or a warning message, depending on whether an
-- inconsistent configuration is permitted or not.
- function Same_Unit (U1 : Name_Id; U2 : Name_Id) return Boolean;
+ function Same_Unit (U1 : Unit_Name_Type; U2 : Name_Id) return Boolean;
-- Used to compare two unit names for No_Dependence checks. U1 is in
-- standard unit name format, and U2 is in literal form with periods.
end if;
Check_Consistent_Normalize_Scalars;
+ Check_Consistent_Optimize_Alignment;
Check_Consistent_Dynamic_Elaboration_Checking;
-
Check_Consistent_Restrictions;
+ Check_Consistent_Restriction_No_Default_Initialization;
Check_Consistent_Interrupt_States;
Check_Consistent_Dispatching_Policy;
end Check_Configuration_Consistency;
Src : Source_Id;
-- Source file Id for this Sdep entry
- ALI_Path_Id : Name_Id;
+ ALI_Path_Id : File_Name_Type;
begin
-- First, we go through the source table to see if there are any cases
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;
+ Error_Msg_File_1 := ALIs.Table (A).Sfile;
+ Error_Msg_File_2 := Sdep.Table (D).Sfile;
-- Two styles of message, depending on whether or not
-- the updated file is the one that must be recompiled
- if Error_Msg_Name_1 = Error_Msg_Name_2 then
+ if Error_Msg_File_1 = Error_Msg_File_2 then
if Tolerate_Consistency_Errors then
Error_Msg
- ("?% has been modified and should be recompiled");
+ ("?{ has been modified and should be recompiled");
else
Error_Msg
- ("% has been modified and must be recompiled");
+ ("{ has been modified and must be recompiled");
end if;
else
Osint.Find_File ((ALIs.Table (A).Afile), Osint.Library);
if Osint.Is_Readonly_Library (ALI_Path_Id) then
if Tolerate_Consistency_Errors then
- Error_Msg ("?% should be recompiled");
- Error_Msg_Name_1 := ALI_Path_Id;
- Error_Msg ("?(% is obsolete and read-only)");
-
+ Error_Msg ("?{ should be recompiled");
+ Error_Msg_File_1 := ALI_Path_Id;
+ Error_Msg ("?({ is obsolete and read-only)");
else
- Error_Msg ("% must be compiled");
- Error_Msg_Name_1 := ALI_Path_Id;
- Error_Msg ("(% is obsolete and read-only)");
+ Error_Msg ("{ must be compiled");
+ Error_Msg_File_1 := ALI_Path_Id;
+ Error_Msg ("({ is obsolete and read-only)");
end if;
elsif Tolerate_Consistency_Errors then
Error_Msg
- ("?% should be recompiled (% has been modified)");
+ ("?{ should be recompiled ({ has been modified)");
else
- Error_Msg ("% must be recompiled (% has been modified)");
+ 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 := "% 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 := Sdep.Table (D).Sfile;
- Error_Msg (Buf);
- end;
+ Error_Msg_File_1 := Sdep.Table (D).Sfile;
+ Error_Msg
+ ("{ time stamp " & String (Source.Table (Src).Stamp));
- declare
- Msg : constant String := " conflicts with % timestamp ";
- Buf : String (1 .. Msg'Length + Time_Stamp_Length);
+ Error_Msg_File_1 := Sdep.Table (D).Sfile;
+ -- Something wrong here, should be different file ???
- begin
- Buf (1 .. Msg'Length) := Msg;
- Buf (Msg'Length + 1 .. Buf'Length) :=
- String (Sdep.Table (D).Stamp);
- Error_Msg_Name_1 := Sdep.Table (D).Sfile;
- Error_Msg (Buf);
- end;
+ Error_Msg
+ (" conflicts with { timestamp " &
+ String (Sdep.Table (D).Stamp));
end if;
-- Exit from the loop through Sdep entries once we find one
and then
ALIs.Table (A2).Task_Dispatching_Policy /= Policy
then
- Error_Msg_Name_1 := ALIs.Table (A1).Sfile;
- Error_Msg_Name_2 := ALIs.Table (A2).Sfile;
+ Error_Msg_File_1 := ALIs.Table (A1).Sfile;
+ Error_Msg_File_2 := ALIs.Table (A2).Sfile;
Consistency_Error_Msg
- ("% and % compiled with different task" &
+ ("{ and { compiled with different task" &
" dispatching policies");
exit Find_Policy;
end if;
-- same partition.
if Task_Dispatching_Policy_Specified /= ' ' then
- Error_Msg_Name_1 := ALIs.Table (F).Sfile;
- Error_Msg_Name_2 :=
+ Error_Msg_File_1 := ALIs.Table (F).Sfile;
+ Error_Msg_File_2 :=
ALIs.Table (TDP_Pragma_Afile).Sfile;
- Error_Msg_Nat_1 := DTK.PSD_Pragma_Line;
+ Error_Msg_Nat_1 := DTK.PSD_Pragma_Line;
Consistency_Error_Msg
- ("Priority_Specific_Dispatching at %:#" &
- " incompatible with Task_Dispatching_Policy at %");
+ ("Priority_Specific_Dispatching at {:#" &
+ " incompatible with Task_Dispatching_Policy at {");
end if;
-- Ceiling_Locking must also be specified for a partition
if ALIs.Table (A).Locking_Policy /= ' '
and then ALIs.Table (A).Locking_Policy /= 'C'
then
- Error_Msg_Name_1 := ALIs.Table (F).Sfile;
- Error_Msg_Name_2 := ALIs.Table (A).Sfile;
+ Error_Msg_File_1 := ALIs.Table (F).Sfile;
+ Error_Msg_File_2 := ALIs.Table (A).Sfile;
Error_Msg_Nat_1 := DTK.PSD_Pragma_Line;
Consistency_Error_Msg
- ("Priority_Specific_Dispatching at %:#" &
- " incompatible with Locking_Policy at %");
+ ("Priority_Specific_Dispatching at {:#" &
+ " incompatible with Locking_Policy at {");
end if;
end loop;
end if;
DTK.Dispatching_Policy
then
- Error_Msg_Name_1 :=
+ Error_Msg_File_1 :=
ALIs.Table (PSD_Table (Prio).Afile).Sfile;
- Error_Msg_Name_2 := ALIs.Table (F).Sfile;
+ Error_Msg_File_2 := ALIs.Table (F).Sfile;
Error_Msg_Nat_1 := PSD_Table (Prio).Loc;
Error_Msg_Nat_2 := DTK.PSD_Pragma_Line;
Consistency_Error_Msg
- ("overlapping priority ranges at %:# and %:#");
+ ("overlapping priority ranges at {:# and {:#");
exit Find_Overlapping;
end if;
-- Issue warning, not one of the safe cases
else
- Error_Msg_Name_1 := UR.Sfile;
+ Error_Msg_File_1 := UR.Sfile;
Error_Msg
- ("?% has dynamic elaboration checks " &
+ ("?{ has dynamic elaboration checks " &
"and with's");
- Error_Msg_Name_1 := WU.Sfile;
+ Error_Msg_File_1 := WU.Sfile;
Error_Msg
- ("? % which has static elaboration " &
+ ("? { which has static elaboration " &
"checks");
Warnings_Detected := Warnings_Detected - 1;
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;
+ Error_Msg_File_1 := ALIs.Table (A1).Sfile;
+ Error_Msg_File_2 := ALIs.Table (A2).Sfile;
Consistency_Error_Msg
- ("% and % compiled with different " &
+ ("{ and { compiled with different " &
"floating-point representations");
exit Find_Format;
end if;
Loc (Inum) := Lnum;
elsif Istate (Inum) /= Stat then
- Error_Msg_Name_1 := ALIs.Table (Afile (Inum)).Sfile;
- Error_Msg_Name_2 := ALIs.Table (F).Sfile;
+ Error_Msg_File_1 := ALIs.Table (Afile (Inum)).Sfile;
+ Error_Msg_File_2 := ALIs.Table (F).Sfile;
Error_Msg_Nat_1 := Loc (Inum);
Error_Msg_Nat_2 := Lnum;
Consistency_Error_Msg
- ("inconsistent interrupt states at %:# and %:#");
+ ("inconsistent interrupt states at {:# and {:#");
end if;
end loop;
end 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;
+ Error_Msg_File_1 := ALIs.Table (A1).Sfile;
+ Error_Msg_File_2 := ALIs.Table (A2).Sfile;
Consistency_Error_Msg
- ("% and % compiled with different locking policies");
+ ("{ and { compiled with different locking policies");
exit Find_Policy;
end if;
end loop;
-- then all other units in the partition must also be compiled with
-- Normalized_Scalars in effect.
- -- There is some issue as to whether this consistency check is
- -- desirable, it is certainly required at the moment by the RM.
- -- We should keep a watch on the ARG and HRG deliberations here.
- -- GNAT no longer depends on this consistency (it used to do so,
- -- but that has been corrected in the latest version, since the
- -- Initialize_Scalars pragma does not require consistency.
+ -- There is some issue as to whether this consistency check is desirable,
+ -- it is certainly required at the moment by the RM. We should keep a watch
+ -- on the ARG and HRG deliberations here. GNAT no longer depends on this
+ -- consistency (it used to do so, but that is no longer the case, since
+ -- pragma Initialize_Scalars pragma does not require consistency.)
procedure Check_Consistent_Normalize_Scalars is
begin
end if;
end Check_Consistent_Normalize_Scalars;
+ -----------------------------------------
+ -- Check_Consistent_Optimize_Alignment --
+ -----------------------------------------
+
+ -- The rule is that all units which depend on the global default setting
+ -- of Optimize_Alignment must be compiled with the same setting for this
+ -- default. Units which specify an explicit local value for this setting
+ -- are exempt from the consistency rule (this includes all internal units).
+
+ procedure Check_Consistent_Optimize_Alignment is
+ OA_Setting : Character := ' ';
+ -- Reset when we find a unit that depends on the default and does
+ -- not have a local specification of the Optimize_Alignment setting.
+
+ OA_Unit : Unit_Id;
+ -- Id of unit from which OA_Setting was set
+
+ C : Character;
+
+ begin
+ for U in First_Unit_Entry .. Units.Last loop
+ C := Units.Table (U).Optimize_Alignment;
+
+ if C /= 'L' then
+ if OA_Setting = ' ' then
+ OA_Setting := C;
+ OA_Unit := U;
+
+ elsif OA_Setting = C then
+ null;
+
+ else
+ Error_Msg_Unit_1 := Units.Table (OA_Unit).Uname;
+ Error_Msg_Unit_2 := Units.Table (U).Uname;
+
+ Consistency_Error_Msg
+ ("$ and $ compiled with different "
+ & "default Optimize_Alignment settings");
+ return;
+ end if;
+ end if;
+ end loop;
+ end Check_Consistent_Optimize_Alignment;
+
-------------------------------------
-- Check_Consistent_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;
+ Error_Msg_File_1 := ALIs.Table (A1).Sfile;
+ Error_Msg_File_2 := ALIs.Table (A2).Sfile;
Consistency_Error_Msg
- ("% and % compiled with different queuing policies");
+ ("{ and { compiled with different queuing policies");
exit Find_Policy;
end if;
end loop;
-- Check_Consistent_Restrictions --
-----------------------------------
- -- The rule is that if a restriction is specified in any unit,
- -- then all units must obey the restriction. The check applies
- -- only to restrictions which require partition wide consistency,
- -- and not to internal units.
+ -- The rule is that if a restriction is specified in any unit, then all
+ -- units must obey the restriction. The check applies only to restrictions
+ -- which require partition wide consistency, and not to internal units.
procedure Check_Consistent_Restrictions is
Restriction_File_Output : Boolean;
-- in the case of a parameter restriction).
declare
- M1 : constant String := "% has restriction ";
+ M1 : constant String := "{ has restriction ";
S : constant String := Restriction_Id'Image (R);
- M2 : String (1 .. 200); -- big enough!
+ M2 : String (1 .. 2000); -- big enough!
P : Integer;
begin
P := P + 5;
end if;
- Error_Msg_Name_1 := ALIs.Table (A).Sfile;
+ Error_Msg_File_1 := ALIs.Table (A).Sfile;
Consistency_Error_Msg (M2 (1 .. P - 1));
Consistency_Error_Msg
("but the following files violate this restriction:");
if R in All_Boolean_Restrictions then
Print_Restriction_File (R);
- Error_Msg_Name_1 := T.Sfile;
- Consistency_Error_Msg (" %");
+ Error_Msg_File_1 := T.Sfile;
+ Consistency_Error_Msg (" {");
-- Case of Parameter restriction where violation
-- count exceeds restriction value, print file
Cumulative_Restrictions.Value (R)
then
Print_Restriction_File (R);
- Error_Msg_Name_1 := T.Sfile;
+ Error_Msg_File_1 := T.Sfile;
Error_Msg_Nat_1 := Int (T.Restrictions.Count (R));
if T.Restrictions.Unknown (R) then
Consistency_Error_Msg
- (" % (count = at least #)");
+ (" { (count = at least #)");
else
Consistency_Error_Msg
- (" % (count = #)");
+ (" { (count = #)");
end if;
end if;
end if;
for ND in No_Deps.First .. No_Deps.Last loop
declare
- ND_Unit : constant Name_Id := No_Deps.Table (ND).No_Dep_Unit;
+ ND_Unit : constant Name_Id :=
+ No_Deps.Table (ND).No_Dep_Unit;
begin
for J in ALIs.First .. ALIs.Last loop
U : Unit_Record renames Units.Table (K);
begin
for L in U.First_With .. U.Last_With loop
- if Same_Unit (Withs.Table (L).Uname, ND_Unit) then
- Error_Msg_Name_1 := U.Uname;
- Error_Msg_Name_2 := ND_Unit;
+ if Same_Unit
+ (Withs.Table (L).Uname, ND_Unit)
+ then
+ Error_Msg_File_1 := U.Sfile;
+ Error_Msg_Name_1 := ND_Unit;
Consistency_Error_Msg
- ("unit & violates restriction " &
+ ("file { violates restriction " &
"No_Dependence => %");
end if;
end loop;
end loop;
end Check_Consistent_Restrictions;
+ ------------------------------------------------------------
+ -- Check_Consistent_Restriction_No_Default_Initialization --
+ ------------------------------------------------------------
+
+ -- The Restriction (No_Default_Initialization) has special consistency
+ -- rules. The rule is that no unit compiled without this restriction
+ -- that violates the restriction can WITH a unit that is compiled with
+ -- the restriction.
+
+ procedure Check_Consistent_Restriction_No_Default_Initialization is
+ begin
+ -- Nothing to do if no one set this restriction
+
+ if not Cumulative_Restrictions.Set (No_Default_Initialization) then
+ return;
+ end if;
+
+ -- Nothing to do if no one violates the restriction
+
+ if not Cumulative_Restrictions.Violated (No_Default_Initialization) then
+ return;
+ end if;
+
+ -- Otherwise we go into a full scan to find possible problems
+
+ for U in Units.First .. Units.Last loop
+ declare
+ UTE : Unit_Record renames Units.Table (U);
+ ATE : ALIs_Record renames ALIs.Table (UTE.My_ALI);
+
+ begin
+ if ATE.Restrictions.Violated (No_Default_Initialization) then
+ for W in UTE.First_With .. UTE.Last_With loop
+ declare
+ AFN : constant File_Name_Type := Withs.Table (W).Afile;
+
+ begin
+ -- The file name may not be present for withs of certain
+ -- generic run-time files. The test can be safely left
+ -- out in such cases anyway.
+
+ if AFN /= No_File then
+ declare
+ WAI : constant ALI_Id :=
+ ALI_Id (Get_Name_Table_Info (AFN));
+ WTE : ALIs_Record renames ALIs.Table (WAI);
+
+ begin
+ if WTE.Restrictions.Set
+ (No_Default_Initialization)
+ then
+ Error_Msg_Unit_1 := UTE.Uname;
+ Consistency_Error_Msg
+ ("unit $ compiled without restriction "
+ & "No_Default_Initialization");
+ Error_Msg_Unit_1 := Withs.Table (W).Uname;
+ Consistency_Error_Msg
+ ("withs unit $, compiled with restriction "
+ & "No_Default_Initialization");
+ end if;
+ end;
+ end if;
+ end;
+ end loop;
+ end if;
+ end;
+ end loop;
+ end Check_Consistent_Restriction_No_Default_Initialization;
+
---------------------------------------------------
-- Check_Consistent_Zero_Cost_Exception_Handling --
---------------------------------------------------
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;
+ Error_Msg_File_1 := ALIs.Table (A1).Sfile;
+ Error_Msg_File_2 := ALIs.Table (ALIs.First).Sfile;
- Consistency_Error_Msg ("% and % compiled with different "
+ Consistency_Error_Msg ("{ and { compiled with different "
& "exception handling mechanisms");
end if;
end loop Check_Mechanism;
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);
+ Unit : constant Unit_Name_Type := Name_Find;
+ Info : constant Int := Get_Name_Table_Info (Unit);
begin
if Info /= 0 then
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;
+ Error_Msg_File_1 := ALIs.Table (A).Sfile;
+ Error_Msg_File_2 := ALIs.Table (ALIs.First).Sfile;
Consistency_Error_Msg
- ("% and % compiled with different GNAT versions");
+ ("{ and { compiled with different GNAT versions");
end if;
end loop;
end Check_Versions;
-- If consistency errors are tolerated,
-- output the message as a warning.
- declare
- Warning_Msg : String (1 .. Msg'Length + 1);
-
- begin
- Warning_Msg (1) := '?';
- Warning_Msg (2 .. Warning_Msg'Last) := Msg;
-
- Error_Msg (Warning_Msg);
- end;
+ Error_Msg ('?' & Msg);
-- Otherwise the consistency error is a true error
-- Same_Unit --
---------------
- function Same_Unit (U1 : Name_Id; U2 : Name_Id) return Boolean is
+ function Same_Unit (U1 : Unit_Name_Type; U2 : Name_Id) return Boolean is
begin
-- Note, the string U1 has a terminating %s or %b, U2 does not
OSDN Git Service
