New Language: Ada

git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@45954 138bc75d-0d04-0410-961f-82ee72b054a4

1 files changed, 694 insertions, 0 deletions

diff --git a/gcc/ada/bcheck.adb b/gcc/ada/bcheck.adb
new file mode 100644
index 00000000000..1d38f96153f
--- /dev/null
+++ b/gcc/ada/bcheck.adb
@@ -0,0 +1,694 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                               B C H E C K                                --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--                            $Revision: 1.39 $
+--                                                                          --
+--          Copyright (C) 1992-2001 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- --
+-- 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,  59 Temple Place - Suite 330,  Boston, --
+-- MA 02111-1307, USA.                                                      --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+--                                                                          --
+------------------------------------------------------------------------------
+
+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
+
+   --  Local subprograms
+
+   --  The following checking subprograms make up the parts
+   --  of the configuration consistency check.
+
+   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);
+   --  Produce an error or a warning message, depending on whether
+   --  an inconsistent configuration is permitted or not.
+
+   ------------------------------------
+   -- Check_Consistent_Configuration --
+   ------------------------------------
+
+   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;
+
+   ---------------------------------------------------
+   -- 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 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_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;
+
+   --------------------------------------------
+   -- 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_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;
+
+   -------------------------------------
+   -- 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
+                     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;
+
+   ----------------------------------------
+   -- 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 has been corrected in the latest version, since the
+   --  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_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_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;
+
+   ---------------------------------------------------
+   -- 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_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;
+
+   ----------------------------------
+   -- Check_Partition_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 check is done in two steps. First for every restriction
+   --  a unit specifying that restriction is found, if any.
+   --  Second, all units are verified against the specified restrictions.
+
+   procedure Check_Partition_Restrictions is
+
+      R : array (Partition_Restrictions) of ALI_Id := (others => No_ALI_Id);
+      --  Record the first unit specifying each partition restriction
+
+      V : array (Partition_Restrictions) of ALI_Id := (others => No_ALI_Id);
+      --  Record the last unit violating each partition restriction
+
+      procedure List_Applicable_Restrictions;
+      --  Output a list of restrictions that may be applied to the partition,
+      --  without causing bind errors.
+
+      ----------------------------------
+      -- List_Applicable_Restrictions --
+      ----------------------------------
+
+      procedure List_Applicable_Restrictions is
+         Additional_Restrictions_Listed : Boolean := False;
+
+      begin
+         --  List any restrictions which were not violated and not specified
+
+         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;
+
+   --  Start of processing for Check_Partition_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
+               --  A violation of a restriction was found, so check whether
+               --  that restriction was actually in effect. If so, give an
+               --  error message.
+
+               --  Note that all such violations found are reported.
+
+               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;
+
+   -----------------------
+   -- Check_Consistency --
+   -----------------------
+
+   procedure Check_Consistency is
+      Src : Source_Id;
+      --  Source file Id for this Sdep entry
+
+   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 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
+            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_Name_1 := ALIs.Table (A).Sfile;
+               Error_Msg_Name_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 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 from the loop through Sdep entries once we find one
+               --  that does not match.
+
+               exit Sdep_Loop;
+            end if;
+
+         end loop Sdep_Loop;
+      end loop ALIs_Loop;
+   end Check_Consistency;
+
+   -------------------------------
+   -- 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
+                  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;
+
+   --------------------
+   -- 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_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;
+
+   ---------------------------
+   -- 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.
+
+         declare
+            Warning_Msg : String (1 .. Msg'Length + 1);
+
+         begin
+            Warning_Msg (1) := '?';
+            Warning_Msg (2 .. Warning_Msg'Last) := Msg;
+
+            Error_Msg (Warning_Msg);
+         end;
+
+      --  Otherwise the consistency error is a true error
+
+      else
+         Error_Msg (Msg);
+      end if;
+   end Consistency_Error_Msg;
+
+end Bcheck;