aboutsummaryrefslogtreecommitdiffstats
path: root/gcc-4.8.3/gcc/ada/bcheck.adb
diff options
context:
space:
mode:
Diffstat (limited to 'gcc-4.8.3/gcc/ada/bcheck.adb')
-rw-r--r--gcc-4.8.3/gcc/ada/bcheck.adb1241
1 files changed, 1241 insertions, 0 deletions
diff --git a/gcc-4.8.3/gcc/ada/bcheck.adb b/gcc-4.8.3/gcc/ada/bcheck.adb
new file mode 100644
index 000000000..09354ecbc
--- /dev/null
+++ b/gcc-4.8.3/gcc/ada/bcheck.adb
@@ -0,0 +1,1241 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- B C H E C K --
+-- --
+-- 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 ALI; use ALI;
+with ALI.Util; use ALI.Util;
+with Binderr; use Binderr;
+with Butil; use Butil;
+with Casing; use Casing;
+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
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ -- The following checking subprograms make up the parts of the
+ -- configuration consistency check. See bodies for details of checks.
+
+ procedure Check_Consistent_Dispatching_Policy;
+ procedure Check_Consistent_Dynamic_Elaboration_Checking;
+ procedure Check_Consistent_Floating_Point_Format;
+ procedure Check_Consistent_Interrupt_States;
+ procedure Check_Consistent_Locking_Policy;
+ procedure Check_Consistent_Normalize_Scalars;
+ procedure Check_Consistent_Optimize_Alignment;
+ procedure Check_Consistent_Partition_Elaboration_Policy;
+ 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 : 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.
+
+ -------------------------------------
+ -- Check_Configuration_Consistency --
+ -------------------------------------
+
+ 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 Partition_Elaboration_Policy_Specified /= ' ' then
+ Check_Consistent_Partition_Elaboration_Policy;
+ end if;
+
+ if Zero_Cost_Exceptions_Specified then
+ Check_Consistent_Zero_Cost_Exception_Handling;
+ 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;
+
+ -----------------------
+ -- Check_Consistency --
+ -----------------------
+
+ procedure Check_Consistency is
+ Src : Source_Id;
+ -- Source file Id for this Sdep entry
+
+ ALI_Path_Id : File_Name_Type;
+
+ begin
+ -- First, we go through the source table to see if there are any cases
+ -- in which we should go after source files and compute checksums of
+ -- the source files. We need to do this for any file for which we have
+ -- mismatching time stamps and (so far) matching checksums.
+
+ for S in Source.First .. Source.Last loop
+
+ -- If all time stamps for a file match, then there is nothing to
+ -- do, since we will not be checking checksums in that case anyway
+
+ if Source.Table (S).All_Timestamps_Match then
+ null;
+
+ -- If we did not find the source file, then we can't compute its
+ -- checksum anyway. Note that when we have a time stamp mismatch,
+ -- we try to find the source file unconditionally (i.e. if
+ -- Check_Source_Files is False).
+
+ elsif not Source.Table (S).Source_Found then
+ null;
+
+ -- If we already have non-matching or missing checksums, then no
+ -- need to try going after source file, since we won't trust the
+ -- checksums in any case.
+
+ elsif not Source.Table (S).All_Checksums_Match then
+ null;
+
+ -- Now we have the case where we have time stamp mismatches, and
+ -- the source file is around, but so far all checksums match. This
+ -- is the case where we need to compute the checksum from the source
+ -- file, since otherwise we would ignore the time stamp mismatches,
+ -- and that is wrong if the checksum of the source does not agree
+ -- with the checksums in the ALI files.
+
+ 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;
+
+ -- Loop through ALI files
+
+ ALIs_Loop : for A in ALIs.First .. ALIs.Last loop
+
+ -- Loop through Sdep entries in one ALI file
+
+ 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 the time stamps match, or all checksums match, then we
+ -- are OK, otherwise we have a definite error.
+
+ if Sdep.Table (D).Stamp /= Source.Table (Src).Stamp
+ and then not Source.Table (Src).All_Checksums_Match
+ then
+ 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_File_1 = Error_Msg_File_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
+ ALI_Path_Id :=
+ Osint.Full_Lib_File_Name (ALIs.Table (A).Afile);
+
+ if Osint.Is_Readonly_Library (ALI_Path_Id) then
+ if Tolerate_Consistency_Errors then
+ 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_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)");
+
+ else
+ Error_Msg ("{ must be recompiled ({ has been modified)");
+ end if;
+ end if;
+
+ if (not Tolerate_Consistency_Errors) and Verbose_Mode then
+ Error_Msg_File_1 := Sdep.Table (D).Sfile;
+ Error_Msg
+ ("{ time stamp " & String (Source.Table (Src).Stamp));
+
+ Error_Msg_File_1 := Sdep.Table (D).Sfile;
+ -- Something wrong here, should be different file ???
+
+ Error_Msg
+ (" conflicts with { timestamp " &
+ String (Sdep.Table (D).Stamp));
+ end if;
+
+ -- Exit from the loop through Sdep entries once we find one
+ -- that does not match.
+
+ exit Sdep_Loop;
+ end if;
+
+ <<Continue>>
+ null;
+ end loop Sdep_Loop;
+ end loop ALIs_Loop;
+ end Check_Consistency;
+
+ -----------------------------------------
+ -- Check_Consistent_Dispatching_Policy --
+ -----------------------------------------
+
+ -- The rule is that all files for which the dispatching policy is
+ -- significant must meet the following rules:
+
+ -- 1. All files for which a task dispatching policy is significant must
+ -- be compiled with the same setting.
+
+ -- 2. If a partition contains one or more Priority_Specific_Dispatching
+ -- pragmas it cannot contain a Task_Dispatching_Policy pragma.
+
+ -- 3. No overlap is allowed in the priority ranges specified in
+ -- Priority_Specific_Dispatching pragmas within the same partition.
+
+ -- 4. If a partition contains one or more Priority_Specific_Dispatching
+ -- pragmas then the Ceiling_Locking policy is the only one allowed for
+ -- the partition.
+
+ procedure Check_Consistent_Dispatching_Policy is
+ Max_Prio : Nat := 0;
+ -- Maximum priority value for which a Priority_Specific_Dispatching
+ -- pragma has been specified.
+
+ TDP_Pragma_Afile : ALI_Id := No_ALI_Id;
+ -- ALI file where a Task_Dispatching_Policy pragma appears
+
+ begin
+ -- Consistency checks in units specifying a Task_Dispatching_Policy
+
+ if Task_Dispatching_Policy_Specified /= ' ' then
+ Find_Policy : for A1 in ALIs.First .. ALIs.Last loop
+ if ALIs.Table (A1).Task_Dispatching_Policy /= ' ' then
+
+ -- Store the place where the first task dispatching pragma
+ -- appears. We may need this value for issuing consistency
+ -- errors if Priority_Specific_Dispatching pragmas are used.
+
+ TDP_Pragma_Afile := A1;
+
+ Check_Policy : declare
+ Policy : constant Character :=
+ ALIs.Table (A1).Task_Dispatching_Policy;
+
+ begin
+ for A2 in A1 + 1 .. ALIs.Last loop
+ if ALIs.Table (A2).Task_Dispatching_Policy /= ' '
+ and then
+ ALIs.Table (A2).Task_Dispatching_Policy /= Policy
+ then
+ Error_Msg_File_1 := ALIs.Table (A1).Sfile;
+ Error_Msg_File_2 := ALIs.Table (A2).Sfile;
+
+ Consistency_Error_Msg
+ ("{ and { compiled with different task" &
+ " dispatching policies");
+ exit Find_Policy;
+ end if;
+ end loop;
+ end Check_Policy;
+
+ exit Find_Policy;
+ end if;
+ end loop Find_Policy;
+ end if;
+
+ -- If no Priority_Specific_Dispatching entries, nothing else to do
+
+ if Specific_Dispatching.Last >= Specific_Dispatching.First then
+
+ -- Find out the maximum priority value for which one of the
+ -- Priority_Specific_Dispatching pragmas applies.
+
+ Max_Prio := 0;
+ for J in Specific_Dispatching.First .. Specific_Dispatching.Last loop
+ if Specific_Dispatching.Table (J).Last_Priority > Max_Prio then
+ Max_Prio := Specific_Dispatching.Table (J).Last_Priority;
+ end if;
+ end loop;
+
+ -- Now establish tables to be used for consistency checking
+
+ declare
+ -- The following record type is used to record locations of the
+ -- Priority_Specific_Dispatching pragmas applying to the Priority.
+
+ type Specific_Dispatching_Entry is record
+ Dispatching_Policy : Character := ' ';
+ -- First character (upper case) of corresponding policy name
+
+ Afile : ALI_Id := No_ALI_Id;
+ -- ALI file that generated Priority Specific Dispatching
+ -- entry for consistency message.
+
+ Loc : Nat := 0;
+ -- Line numbers from Priority_Specific_Dispatching pragma
+ end record;
+
+ PSD_Table : array (0 .. Max_Prio) of Specific_Dispatching_Entry :=
+ (others => Specific_Dispatching_Entry'
+ (Dispatching_Policy => ' ',
+ Afile => No_ALI_Id,
+ Loc => 0));
+ -- Array containing an entry per priority containing the location
+ -- where there is a Priority_Specific_Dispatching pragma that
+ -- applies to the priority.
+
+ begin
+ for F in ALIs.First .. ALIs.Last loop
+ for K in ALIs.Table (F).First_Specific_Dispatching ..
+ ALIs.Table (F).Last_Specific_Dispatching
+ loop
+ declare
+ DTK : Specific_Dispatching_Record
+ renames Specific_Dispatching.Table (K);
+ begin
+ -- Check whether pragma Task_Dispatching_Policy and
+ -- pragma Priority_Specific_Dispatching are used in the
+ -- same partition.
+
+ if Task_Dispatching_Policy_Specified /= ' ' then
+ 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;
+
+ Consistency_Error_Msg
+ ("Priority_Specific_Dispatching at {:#" &
+ " incompatible with Task_Dispatching_Policy at {");
+ end if;
+
+ -- Ceiling_Locking must also be specified for a partition
+ -- with at least one Priority_Specific_Dispatching
+ -- pragma.
+
+ if Locking_Policy_Specified /= ' '
+ and then Locking_Policy_Specified /= 'C'
+ then
+ for A in ALIs.First .. ALIs.Last loop
+ if ALIs.Table (A).Locking_Policy /= ' '
+ and then ALIs.Table (A).Locking_Policy /= 'C'
+ then
+ 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 {");
+ end if;
+ end loop;
+ end if;
+
+ -- Check overlapping priority ranges
+
+ Find_Overlapping : for Prio in
+ DTK.First_Priority .. DTK.Last_Priority
+ loop
+ if PSD_Table (Prio).Afile = No_ALI_Id then
+ PSD_Table (Prio) :=
+ (Dispatching_Policy => DTK.Dispatching_Policy,
+ Afile => F, Loc => DTK.PSD_Pragma_Line);
+
+ elsif PSD_Table (Prio).Dispatching_Policy /=
+ DTK.Dispatching_Policy
+
+ then
+ Error_Msg_File_1 :=
+ ALIs.Table (PSD_Table (Prio).Afile).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 {:#");
+
+ exit Find_Overlapping;
+ end if;
+ end loop Find_Overlapping;
+ end;
+ end loop;
+ end loop;
+ end;
+ end if;
+ end Check_Consistent_Dispatching_Policy;
+
+ ---------------------------------------------------
+ -- Check_Consistent_Dynamic_Elaboration_Checking --
+ ---------------------------------------------------
+
+ -- The rule here is that if a unit has dynamic elaboration checks,
+ -- then any unit it withs must meeting one of the following criteria:
+
+ -- 1. There is a pragma Elaborate_All for the with'ed unit
+ -- 2. The with'ed unit was compiled with dynamic elaboration checks
+ -- 3. The with'ed unit has pragma Preelaborate or Pure
+ -- 4. It is an internal GNAT unit (including children of GNAT)
+
+ 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
+ -- Case 1. Elaborate_All for with'ed unit
+
+ if WR.Elaborate_All then
+ null;
+
+ -- Case 2. With'ed unit has dynamic elab checks
+
+ elsif WU.Dynamic_Elab then
+ null;
+
+ -- Case 3. With'ed unit is Preelaborate or Pure
+
+ elsif WU.Preelab or else WU.Pure then
+ null;
+
+ -- Case 4. With'ed unit is internal file
+
+ elsif Is_Internal_File_Name (WU.Sfile) then
+ null;
+
+ -- Issue warning, not one of the safe cases
+
+ else
+ Error_Msg_File_1 := UR.Sfile;
+ Error_Msg
+ ("?{ has dynamic elaboration checks " &
+ "and with's");
+
+ Error_Msg_File_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;
+
+ --------------------------------------------
+ -- Check_Consistent_Floating_Point_Format --
+ --------------------------------------------
+
+ -- The rule is that all files must be compiled with the same setting
+ -- for the floating-point format.
+
+ procedure Check_Consistent_Floating_Point_Format is
+ begin
+ -- First search for a unit specifying a floating-point format and then
+ -- check all remaining units against it.
+
+ 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_File_1 := ALIs.Table (A1).Sfile;
+ Error_Msg_File_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;
+
+ ---------------------------------------
+ -- Check_Consistent_Interrupt_States --
+ ---------------------------------------
+
+ -- The rule is that if the state of a given interrupt is specified
+ -- in more than one unit, it must be specified with a consistent state.
+
+ procedure Check_Consistent_Interrupt_States is
+ Max_Intrup : Nat;
+
+ begin
+ -- If no Interrupt_State entries, nothing to do
+
+ if Interrupt_States.Last < Interrupt_States.First then
+ return;
+ end if;
+
+ -- First find out the maximum interrupt value
+
+ Max_Intrup := 0;
+ for J in Interrupt_States.First .. Interrupt_States.Last loop
+ if Interrupt_States.Table (J).Interrupt_Id > Max_Intrup then
+ Max_Intrup := Interrupt_States.Table (J).Interrupt_Id;
+ end if;
+ end loop;
+
+ -- Now establish tables to be used for consistency checking
+
+ declare
+ Istate : array (0 .. Max_Intrup) of Character := (others => 'n');
+ -- Interrupt state entries, 'u'/'s'/'r' or 'n' to indicate an
+ -- entry that has not been set.
+
+ Afile : array (0 .. Max_Intrup) of ALI_Id;
+ -- ALI file that generated Istate entry for consistency message
+
+ Loc : array (0 .. Max_Intrup) of Nat;
+ -- Line numbers from IS pragma generating Istate entry
+
+ Inum : Nat;
+ -- Interrupt number from entry being tested
+
+ Stat : Character;
+ -- Interrupt state from entry being tested
+
+ Lnum : Nat;
+ -- Line number from entry being tested
+
+ begin
+ for F in ALIs.First .. ALIs.Last loop
+ for K in ALIs.Table (F).First_Interrupt_State ..
+ ALIs.Table (F).Last_Interrupt_State
+ loop
+ Inum := Interrupt_States.Table (K).Interrupt_Id;
+ Stat := Interrupt_States.Table (K).Interrupt_State;
+ Lnum := Interrupt_States.Table (K).IS_Pragma_Line;
+
+ if Istate (Inum) = 'n' then
+ Istate (Inum) := Stat;
+ Afile (Inum) := F;
+ Loc (Inum) := Lnum;
+
+ elsif Istate (Inum) /= Stat then
+ 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 {:#");
+ end if;
+ end loop;
+ end loop;
+ end;
+ end Check_Consistent_Interrupt_States;
+
+ -------------------------------------
+ -- Check_Consistent_Locking_Policy --
+ -------------------------------------
+
+ -- The rule is that all files for which the locking policy is
+ -- significant must be compiled with the same setting.
+
+ procedure Check_Consistent_Locking_Policy is
+ begin
+ -- First search for a unit specifying a policy and then
+ -- check all remaining units against it.
+
+ 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 then
+ ALIs.Table (A2).Locking_Policy /= Policy
+ then
+ 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");
+ exit Find_Policy;
+ end if;
+ end loop;
+ end Check_Policy;
+
+ exit Find_Policy;
+ end if;
+ end loop Find_Policy;
+ end Check_Consistent_Locking_Policy;
+
+ ----------------------------------------
+ -- Check_Consistent_Normalize_Scalars --
+ ----------------------------------------
+
+ -- The rule is that if any unit is compiled with Normalized_Scalars,
+ -- 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 is no longer the case, since
+ -- pragma Initialize_Scalars pragma does not require consistency.)
+
+ 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;
+
+ -----------------------------------------
+ -- 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_Partition_Elaboration_Policy --
+ ---------------------------------------------------
+
+ -- The rule is that all files for which the partition elaboration policy is
+ -- significant must be compiled with the same setting.
+
+ procedure Check_Consistent_Partition_Elaboration_Policy is
+ begin
+ -- First search for a unit specifying a policy and then
+ -- check all remaining units against it.
+
+ Find_Policy : for A1 in ALIs.First .. ALIs.Last loop
+ if ALIs.Table (A1).Partition_Elaboration_Policy /= ' ' then
+ Check_Policy : declare
+ Policy : constant Character :=
+ ALIs.Table (A1).Partition_Elaboration_Policy;
+
+ begin
+ for A2 in A1 + 1 .. ALIs.Last loop
+ if ALIs.Table (A2).Partition_Elaboration_Policy /= ' '
+ and then
+ ALIs.Table (A2).Partition_Elaboration_Policy /= Policy
+ then
+ Error_Msg_File_1 := ALIs.Table (A1).Sfile;
+ Error_Msg_File_2 := ALIs.Table (A2).Sfile;
+
+ Consistency_Error_Msg
+ ("{ and { compiled with different partition "
+ & "elaboration policies");
+ exit Find_Policy;
+ end if;
+ end loop;
+ end Check_Policy;
+
+ -- A No_Task_Hierarchy restriction must be specified for the
+ -- Sequential policy (RM H.6(6/2)).
+
+ if Partition_Elaboration_Policy_Specified = 'S'
+ and then not Cumulative_Restrictions.Set (No_Task_Hierarchy)
+ then
+ Error_Msg_File_1 := ALIs.Table (A1).Sfile;
+ Error_Msg
+ ("{ has sequential partition elaboration policy, but no");
+ Error_Msg
+ ("pragma Restrictions (No_Task_Hierarchy) was specified");
+ end if;
+
+ exit Find_Policy;
+ end if;
+ end loop Find_Policy;
+ end Check_Consistent_Partition_Elaboration_Policy;
+
+ -------------------------------------
+ -- Check_Consistent_Queuing_Policy --
+ -------------------------------------
+
+ -- The rule is that all files for which the queuing policy is
+ -- significant must be compiled with the same setting.
+
+ procedure Check_Consistent_Queuing_Policy is
+ begin
+ -- First search for a unit specifying a policy and then
+ -- check all remaining units against it.
+
+ 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_File_1 := ALIs.Table (A1).Sfile;
+ Error_Msg_File_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;
+
+ -----------------------------------
+ -- 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.
+
+ procedure Check_Consistent_Restrictions is
+ Restriction_File_Output : Boolean;
+ -- Shows if we have output header messages for restriction violation
+
+ procedure Print_Restriction_File (R : All_Restrictions);
+ -- Print header line for R if not printed yet
+
+ ----------------------------
+ -- Print_Restriction_File --
+ ----------------------------
+
+ procedure Print_Restriction_File (R : All_Restrictions) is
+ begin
+ if not Restriction_File_Output then
+ Restriction_File_Output := True;
+
+ -- Find an ali file specifying the restriction
+
+ for A in ALIs.First .. ALIs.Last loop
+ if ALIs.Table (A).Restrictions.Set (R)
+ and then (R in All_Boolean_Restrictions
+ or else ALIs.Table (A).Restrictions.Value (R) =
+ Cumulative_Restrictions.Value (R))
+ then
+ -- We have found that ALI file A specifies the restriction
+ -- that is being violated (the minimum value is specified
+ -- in the case of a parameter restriction).
+
+ declare
+ M1 : constant String := "{ has restriction ";
+ S : constant String := Restriction_Id'Image (R);
+ M2 : String (1 .. 2000); -- big enough!
+ P : Integer;
+
+ begin
+ Name_Buffer (1 .. S'Length) := S;
+ Name_Len := S'Length;
+ Set_Casing (Mixed_Case);
+
+ M2 (M1'Range) := M1;
+ P := M1'Length + 1;
+ M2 (P .. P + S'Length - 1) := Name_Buffer (1 .. S'Length);
+ P := P + S'Length;
+
+ if R in All_Parameter_Restrictions then
+ M2 (P .. P + 4) := " => #";
+ Error_Msg_Nat_1 :=
+ Int (Cumulative_Restrictions.Value (R));
+ P := P + 5;
+ end if;
+
+ 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:");
+ return;
+ end;
+ end if;
+ end loop;
+ end if;
+ end Print_Restriction_File;
+
+ -- Start of processing for Check_Consistent_Restrictions
+
+ begin
+ -- A special test, if we have a main program, then if it has an
+ -- allocator in the body, this is considered to be a violation of
+ -- the restriction No_Allocators_After_Elaboration. We just mark
+ -- this restriction and then the normal circuit will flag it.
+
+ if Bind_Main_Program
+ and then ALIs.Table (ALIs.First).Main_Program /= None
+ and then not No_Main_Subprogram
+ and then ALIs.Table (ALIs.First).Allocator_In_Body
+ then
+ Cumulative_Restrictions.Violated
+ (No_Allocators_After_Elaboration) := True;
+ ALIs.Table (ALIs.First).Restrictions.Violated
+ (No_Allocators_After_Elaboration) := True;
+ end if;
+
+ -- Loop through all restriction violations
+
+ for R in All_Restrictions loop
+
+ -- Check for violation of this restriction
+
+ if Cumulative_Restrictions.Set (R)
+ and then Cumulative_Restrictions.Violated (R)
+ and then (R in Partition_Boolean_Restrictions
+ or else (R in All_Parameter_Restrictions
+ and then
+ Cumulative_Restrictions.Count (R) >
+ Cumulative_Restrictions.Value (R)))
+ then
+ Restriction_File_Output := False;
+
+ -- Loop through files looking for violators
+
+ for A2 in ALIs.First .. ALIs.Last loop
+ declare
+ T : ALIs_Record renames ALIs.Table (A2);
+
+ begin
+ if T.Restrictions.Violated (R) then
+
+ -- We exclude predefined files from the list of
+ -- violators. This should be rethought. It is not
+ -- clear that this is the right thing to do, that
+ -- is particularly the case for restricted runtimes.
+
+ if not Is_Internal_File_Name (T.Sfile) then
+
+ -- Case of Boolean restriction, just print file name
+
+ if R in All_Boolean_Restrictions then
+ Print_Restriction_File (R);
+ Error_Msg_File_1 := T.Sfile;
+ Consistency_Error_Msg (" {");
+
+ -- Case of Parameter restriction where violation
+ -- count exceeds restriction value, print file
+ -- name and count, adding "at least" if the
+ -- exact count is not known.
+
+ elsif R in Checked_Add_Parameter_Restrictions
+ or else T.Restrictions.Count (R) >
+ Cumulative_Restrictions.Value (R)
+ then
+ Print_Restriction_File (R);
+ 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 #)");
+ else
+ Consistency_Error_Msg
+ (" { (count = #)");
+ end if;
+ end if;
+ end if;
+ end if;
+ end;
+ end loop;
+ end if;
+ end loop;
+
+ -- Now deal with No_Dependence indications. Note that we put the loop
+ -- through entries in the no dependency table first, since this loop
+ -- is most often empty (no such pragma Restrictions in use).
+
+ for ND in No_Deps.First .. No_Deps.Last loop
+ declare
+ ND_Unit : constant Name_Id := No_Deps.Table (ND).No_Dep_Unit;
+ begin
+ for J in ALIs.First .. ALIs.Last loop
+ declare
+ A : ALIs_Record renames ALIs.Table (J);
+
+ begin
+ for K in A.First_Unit .. A.Last_Unit loop
+ declare
+ 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_File_1 := U.Sfile;
+ Error_Msg_Name_1 := ND_Unit;
+ Consistency_Error_Msg
+ ("file { violates restriction " &
+ "No_Dependence => %");
+ end if;
+ end loop;
+ end;
+ end loop;
+ end;
+ end loop;
+ end;
+ 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 --
+ ---------------------------------------------------
+
+ -- Check consistent zero cost exception handling. The rule is that
+ -- all units must have the same exception handling mechanism.
+
+ 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_File_1 := ALIs.Table (A1).Sfile;
+ Error_Msg_File_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;
+
+ -------------------------------
+ -- Check_Duplicated_Subunits --
+ -------------------------------
+
+ 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) := '%';
+
+ -- See if there is a body or spec with the same name
+
+ for K in Boolean loop
+ if K then
+ Name_Buffer (Name_Len) := 'b';
+ else
+ Name_Buffer (Name_Len) := 's';
+ end if;
+
+ declare
+ Unit : constant Unit_Name_Type := Name_Find;
+ Info : constant Int := Get_Name_Table_Info (Unit);
+
+ 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;
+
+ --------------------
+ -- Check_Versions --
+ --------------------
+
+ 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_File_1 := ALIs.Table (A).Sfile;
+ Error_Msg_File_2 := ALIs.Table (ALIs.First).Sfile;
+
+ Consistency_Error_Msg
+ ("{ and { compiled with different GNAT versions");
+ end if;
+ end loop;
+ end Check_Versions;
+
+ ---------------------------
+ -- Consistency_Error_Msg --
+ ---------------------------
+
+ procedure Consistency_Error_Msg (Msg : String) is
+ begin
+ if Tolerate_Consistency_Errors then
+
+ -- If consistency errors are tolerated,
+ -- output the message as a warning.
+
+ Error_Msg ('?' & Msg);
+
+ -- Otherwise the consistency error is a true error
+
+ else
+ Error_Msg (Msg);
+ end if;
+ end Consistency_Error_Msg;
+
+ ---------------
+ -- Same_Unit --
+ ---------------
+
+ 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
+
+ if Length_Of_Name (U1) - 2 = Length_Of_Name (U2) then
+ Get_Name_String (U1);
+
+ declare
+ U1_Str : constant String := Name_Buffer (1 .. Name_Len - 2);
+ begin
+ Get_Name_String (U2);
+ return U1_Str = Name_Buffer (1 .. Name_Len);
+ end;
+
+ else
+ return False;
+ end if;
+ end Same_Unit;
+
+end Bcheck;