gcc/ada/bcheck.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                               B C H E C K                                --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 1992-2004 Free Software Foundation, Inc.          --
  10 --                                                                          --
  11 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  12 -- terms of the  GNU General Public License as published  by the Free Soft- --
  13 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  14 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  16 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  17 -- for  more details.  You should have  received  a copy of the GNU General --
  18 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  19 -- to  the  Free Software Foundation,  51  Franklin  Street,  Fifth  Floor, --
  20 -- Boston, MA 02110-1301, USA.                                              --
  21 --                                                                          --
  22 -- GNAT was originally developed  by the GNAT team at  New York University. --
  23 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  24 --                                                                          --
  25 ------------------------------------------------------------------------------
  26
  27 with ALI;      use ALI;
  28 with ALI.Util; use ALI.Util;
  29 with Binderr;  use Binderr;
  30 with Butil;    use Butil;
  31 with Casing;   use Casing;
  32 with Fname;    use Fname;
  33 with Namet;    use Namet;
  34 with Opt;      use Opt;
  35 with Osint;
  36 with Output;   use Output;
  37 with Rident;   use Rident;
  38 with Types;    use Types;
  39
  40 package body Bcheck is
  41
  42    -----------------------
  43    -- Local Subprograms --
  44    -----------------------
  45
  46    --  The following checking subprograms make up the parts of the
  47    --  configuration consistency check.
  48
  49    procedure Check_Consistent_Dynamic_Elaboration_Checking;
  50    procedure Check_Consistent_Floating_Point_Format;
  51    procedure Check_Consistent_Interrupt_States;
  52    procedure Check_Consistent_Locking_Policy;
  53    procedure Check_Consistent_Normalize_Scalars;
  54    procedure Check_Consistent_Queuing_Policy;
  55    procedure Check_Consistent_Restrictions;
  56    procedure Check_Consistent_Zero_Cost_Exception_Handling;
  57
  58    procedure Consistency_Error_Msg (Msg : String);
  59    --  Produce an error or a warning message, depending on whether an
  60    --  inconsistent configuration is permitted or not.
  61
  62    function Same_Unit (U1 : Name_Id; U2 : Name_Id) return Boolean;
  63    --  Used to compare two unit names for No_Dependence checks. U1 is in
  64    --  standard unit name format, and U2 is in literal form with periods.
  65
  66    ------------------------------------
  67    -- Check_Consistent_Configuration --
  68    ------------------------------------
  69
  70    procedure Check_Configuration_Consistency is
  71    begin
  72       if Float_Format_Specified /= ' ' then
  73          Check_Consistent_Floating_Point_Format;
  74       end if;
  75
  76       if Queuing_Policy_Specified /= ' ' then
  77          Check_Consistent_Queuing_Policy;
  78       end if;
  79
  80       if Locking_Policy_Specified /= ' ' then
  81          Check_Consistent_Locking_Policy;
  82       end if;
  83
  84       if Zero_Cost_Exceptions_Specified then
  85          Check_Consistent_Zero_Cost_Exception_Handling;
  86       end if;
  87
  88       Check_Consistent_Normalize_Scalars;
  89       Check_Consistent_Dynamic_Elaboration_Checking;
  90
  91       Check_Consistent_Restrictions;
  92       Check_Consistent_Interrupt_States;
  93    end Check_Configuration_Consistency;
  94
  95    ---------------------------------------------------
  96    -- Check_Consistent_Dynamic_Elaboration_Checking --
  97    ---------------------------------------------------
  98
  99    --  The rule here is that if a unit has dynamic elaboration checks,
 100    --  then any unit it withs must meeting one of the following criteria:
 101
 102    --    1. There is a pragma Elaborate_All for the with'ed unit
 103    --    2. The with'ed unit was compiled with dynamic elaboration checks
 104    --    3. The with'ed unit has pragma Preelaborate or Pure
 105    --    4. It is an internal GNAT unit (including children of GNAT)
 106
 107    procedure Check_Consistent_Dynamic_Elaboration_Checking is
 108    begin
 109       if Dynamic_Elaboration_Checks_Specified then
 110          for U in First_Unit_Entry .. Units.Last loop
 111             declare
 112                UR : Unit_Record renames Units.Table (U);
 113
 114             begin
 115                if UR.Dynamic_Elab then
 116                   for W in UR.First_With .. UR.Last_With loop
 117                      declare
 118                         WR : With_Record renames Withs.Table (W);
 119
 120                      begin
 121                         if Get_Name_Table_Info (WR.Uname) /= 0 then
 122                            declare
 123                               WU : Unit_Record renames
 124                                      Units.Table
 125                                        (Unit_Id
 126                                          (Get_Name_Table_Info (WR.Uname)));
 127
 128                            begin
 129                               --  Case 1. Elaborate_All for with'ed unit
 130
 131                               if WR.Elaborate_All then
 132                                  null;
 133
 134                               --  Case 2. With'ed unit has dynamic elab checks
 135
 136                               elsif WU.Dynamic_Elab then
 137                                  null;
 138
 139                               --  Case 3. With'ed unit is Preelaborate or Pure
 140
 141                               elsif WU.Preelab or WU.Pure then
 142                                  null;
 143
 144                               --  Case 4. With'ed unit is internal file
 145
 146                               elsif Is_Internal_File_Name (WU.Sfile) then
 147                                  null;
 148
 149                               --  Issue warning, not one of the safe cases
 150
 151                               else
 152                                  Error_Msg_Name_1 := UR.Sfile;
 153                                  Error_Msg
 154                                    ("?% has dynamic elaboration checks " &
 155                                                                  "and with's");
 156
 157                                  Error_Msg_Name_1 := WU.Sfile;
 158                                  Error_Msg
 159                                    ("?  % which has static elaboration " &
 160                                                                      "checks");
 161
 162                                  Warnings_Detected := Warnings_Detected - 1;
 163                               end if;
 164                            end;
 165                         end if;
 166                      end;
 167                   end loop;
 168                end if;
 169             end;
 170          end loop;
 171       end if;
 172    end Check_Consistent_Dynamic_Elaboration_Checking;
 173
 174    --------------------------------------------
 175    -- Check_Consistent_Floating_Point_Format --
 176    --------------------------------------------
 177
 178    --  The rule is that all files must be compiled with the same setting
 179    --  for the floating-point format.
 180
 181    procedure Check_Consistent_Floating_Point_Format is
 182    begin
 183       --  First search for a unit specifying a floating-point format and then
 184       --  check all remaining units against it.
 185
 186       Find_Format : for A1 in ALIs.First .. ALIs.Last loop
 187          if ALIs.Table (A1).Float_Format /= ' ' then
 188             Check_Format : declare
 189                Format : constant Character := ALIs.Table (A1).Float_Format;
 190             begin
 191                for A2 in A1 + 1 .. ALIs.Last loop
 192                   if ALIs.Table (A2).Float_Format /= Format then
 193                      Error_Msg_Name_1 := ALIs.Table (A1).Sfile;
 194                      Error_Msg_Name_2 := ALIs.Table (A2).Sfile;
 195
 196                      Consistency_Error_Msg
 197                        ("% and % compiled with different " &
 198                         "floating-point representations");
 199                      exit Find_Format;
 200                   end if;
 201                end loop;
 202             end Check_Format;
 203
 204             exit Find_Format;
 205          end if;
 206       end loop Find_Format;
 207    end Check_Consistent_Floating_Point_Format;
 208
 209    ---------------------------------------
 210    -- Check_Consistent_Interrupt_States --
 211    ---------------------------------------
 212
 213    --  The rule is that if the state of a given interrupt is specified
 214    --  in more than one unit, it must be specified with a consistent state.
 215
 216    procedure Check_Consistent_Interrupt_States is
 217       Max_Intrup : Nat;
 218
 219    begin
 220       --  If no Interrupt_State entries, nothing to do
 221
 222       if Interrupt_States.Last < Interrupt_States.First then
 223          return;
 224       end if;
 225
 226       --  First find out the maximum interrupt value
 227
 228       Max_Intrup := 0;
 229       for J in Interrupt_States.First .. Interrupt_States.Last loop
 230          if Interrupt_States.Table (J).Interrupt_Id > Max_Intrup then
 231             Max_Intrup := Interrupt_States.Table (J).Interrupt_Id;
 232          end if;
 233       end loop;
 234
 235       --  Now establish tables to be used for consistency checking
 236
 237       declare
 238          Istate : array (0 .. Max_Intrup) of Character := (others => 'n');
 239          --  Interrupt state entries, 'u'/'s'/'r' or 'n' to indicate an
 240          --  entry that has not been set.
 241
 242          Afile : array (0 .. Max_Intrup) of ALI_Id;
 243          --  ALI file that generated Istate entry for consistency message
 244
 245          Loc : array (0 .. Max_Intrup) of Nat;
 246          --  Line numbers from IS pragma generating Istate entry
 247
 248          Inum : Nat;
 249          --  Interrupt number from entry being tested
 250
 251          Stat : Character;
 252          --  Interrupt state from entry being tested
 253
 254          Lnum : Nat;
 255          --  Line number from entry being tested
 256
 257       begin
 258          for F in ALIs.First .. ALIs.Last loop
 259             for K in ALIs.Table (F).First_Interrupt_State ..
 260                      ALIs.Table (F).Last_Interrupt_State
 261             loop
 262                Inum := Interrupt_States.Table (K).Interrupt_Id;
 263                Stat := Interrupt_States.Table (K).Interrupt_State;
 264                Lnum := Interrupt_States.Table (K).IS_Pragma_Line;
 265
 266                if Istate (Inum) = 'n' then
 267                   Istate (Inum) := Stat;
 268                   Afile  (Inum) := F;
 269                   Loc    (Inum) := Lnum;
 270
 271                elsif Istate (Inum) /= Stat then
 272                   Error_Msg_Name_1 := ALIs.Table (Afile (Inum)).Sfile;
 273                   Error_Msg_Name_2 := ALIs.Table (F).Sfile;
 274                   Error_Msg_Nat_1  := Loc (Inum);
 275                   Error_Msg_Nat_2  := Lnum;
 276
 277                   Consistency_Error_Msg
 278                     ("inconsistent interrupt states at %:# and %:#");
 279                end if;
 280             end loop;
 281          end loop;
 282       end;
 283    end Check_Consistent_Interrupt_States;
 284
 285    -------------------------------------
 286    -- Check_Consistent_Locking_Policy --
 287    -------------------------------------
 288
 289    --  The rule is that all files for which the locking policy is
 290    --  significant must be compiled with the same setting.
 291
 292    procedure Check_Consistent_Locking_Policy is
 293    begin
 294       --  First search for a unit specifying a policy and then
 295       --  check all remaining units against it.
 296
 297       Find_Policy : for A1 in ALIs.First .. ALIs.Last loop
 298          if ALIs.Table (A1).Locking_Policy /= ' ' then
 299             Check_Policy : declare
 300                Policy : constant Character := ALIs.Table (A1).Locking_Policy;
 301
 302             begin
 303                for A2 in A1 + 1 .. ALIs.Last loop
 304                   if ALIs.Table (A2).Locking_Policy /= ' ' and
 305                      ALIs.Table (A2).Locking_Policy /= Policy
 306                   then
 307                      Error_Msg_Name_1 := ALIs.Table (A1).Sfile;
 308                      Error_Msg_Name_2 := ALIs.Table (A2).Sfile;
 309
 310                      Consistency_Error_Msg
 311                        ("% and % compiled with different locking policies");
 312                      exit Find_Policy;
 313                   end if;
 314                end loop;
 315             end Check_Policy;
 316
 317             exit Find_Policy;
 318          end if;
 319       end loop Find_Policy;
 320    end Check_Consistent_Locking_Policy;
 321
 322    ----------------------------------------
 323    -- Check_Consistent_Normalize_Scalars --
 324    ----------------------------------------
 325
 326    --  The rule is that if any unit is compiled with Normalized_Scalars,
 327    --  then all other units in the partition must also be compiled with
 328    --  Normalized_Scalars in effect.
 329
 330    --  There is some issue as to whether this consistency check is
 331    --  desirable, it is certainly required at the moment by the RM.
 332    --  We should keep a watch on the ARG and HRG deliberations here.
 333    --  GNAT no longer depends on this consistency (it used to do so,
 334    --  but that has been corrected in the latest version, since the
 335    --  Initialize_Scalars pragma does not require consistency.
 336
 337    procedure Check_Consistent_Normalize_Scalars is
 338    begin
 339       if Normalize_Scalars_Specified and No_Normalize_Scalars_Specified then
 340          Consistency_Error_Msg
 341               ("some but not all files compiled with Normalize_Scalars");
 342
 343          Write_Eol;
 344          Write_Str ("files compiled with Normalize_Scalars");
 345          Write_Eol;
 346
 347          for A1 in ALIs.First .. ALIs.Last loop
 348             if ALIs.Table (A1).Normalize_Scalars then
 349                Write_Str ("  ");
 350                Write_Name (ALIs.Table (A1).Sfile);
 351                Write_Eol;
 352             end if;
 353          end loop;
 354
 355          Write_Eol;
 356          Write_Str ("files compiled without Normalize_Scalars");
 357          Write_Eol;
 358
 359          for A1 in ALIs.First .. ALIs.Last loop
 360             if not ALIs.Table (A1).Normalize_Scalars then
 361                Write_Str ("  ");
 362                Write_Name (ALIs.Table (A1).Sfile);
 363                Write_Eol;
 364             end if;
 365          end loop;
 366       end if;
 367    end Check_Consistent_Normalize_Scalars;
 368
 369    -------------------------------------
 370    -- Check_Consistent_Queuing_Policy --
 371    -------------------------------------
 372
 373    --  The rule is that all files for which the queuing policy is
 374    --  significant must be compiled with the same setting.
 375
 376    procedure Check_Consistent_Queuing_Policy is
 377    begin
 378       --  First search for a unit specifying a policy and then
 379       --  check all remaining units against it.
 380
 381       Find_Policy : for A1 in ALIs.First .. ALIs.Last loop
 382          if ALIs.Table (A1).Queuing_Policy /= ' ' then
 383             Check_Policy : declare
 384                Policy : constant Character := ALIs.Table (A1).Queuing_Policy;
 385             begin
 386                for A2 in A1 + 1 .. ALIs.Last loop
 387                   if ALIs.Table (A2).Queuing_Policy /= ' '
 388                        and then
 389                      ALIs.Table (A2).Queuing_Policy /= Policy
 390                   then
 391                      Error_Msg_Name_1 := ALIs.Table (A1).Sfile;
 392                      Error_Msg_Name_2 := ALIs.Table (A2).Sfile;
 393
 394                      Consistency_Error_Msg
 395                        ("% and % compiled with different queuing policies");
 396                      exit Find_Policy;
 397                   end if;
 398                end loop;
 399             end Check_Policy;
 400
 401             exit Find_Policy;
 402          end if;
 403       end loop Find_Policy;
 404    end Check_Consistent_Queuing_Policy;
 405
 406    -----------------------------------
 407    -- Check_Consistent_Restrictions --
 408    -----------------------------------
 409
 410    --  The rule is that if a restriction is specified in any unit,
 411    --  then all units must obey the restriction. The check applies
 412    --  only to restrictions which require partition wide consistency,
 413    --  and not to internal units.
 414
 415    procedure Check_Consistent_Restrictions is
 416       Restriction_File_Output : Boolean;
 417       --  Shows if we have output header messages for restriction violation
 418
 419       procedure Print_Restriction_File (R : All_Restrictions);
 420       --  Print header line for R if not printed yet
 421
 422       ----------------------------
 423       -- Print_Restriction_File --
 424       ----------------------------
 425
 426       procedure Print_Restriction_File (R : All_Restrictions) is
 427       begin
 428          if not Restriction_File_Output then
 429             Restriction_File_Output := True;
 430
 431             --  Find an ali file specifying the restriction
 432
 433             for A in ALIs.First .. ALIs.Last loop
 434                if ALIs.Table (A).Restrictions.Set (R)
 435                  and then (R in All_Boolean_Restrictions
 436                              or else ALIs.Table (A).Restrictions.Value (R) =
 437                                      Cumulative_Restrictions.Value (R))
 438                then
 439                   --  We have found that ALI file A specifies the restriction
 440                   --  that is being violated (the minimum value is specified
 441                   --  in the case of a parameter restriction).
 442
 443                   declare
 444                      M1 : constant String := "% has restriction ";
 445                      S  : constant String := Restriction_Id'Image (R);
 446                      M2 : String (1 .. 200); -- big enough!
 447                      P  : Integer;
 448
 449                   begin
 450                      Name_Buffer (1 .. S'Length) := S;
 451                      Name_Len := S'Length;
 452                      Set_Casing (Mixed_Case);
 453
 454                      M2 (M1'Range) := M1;
 455                      P := M1'Length + 1;
 456                      M2 (P .. P + S'Length - 1) := Name_Buffer (1 .. S'Length);
 457                      P := P + S'Length;
 458
 459                      if R in All_Parameter_Restrictions then
 460                         M2 (P .. P + 4) := " => #";
 461                         Error_Msg_Nat_1 :=
 462                           Int (Cumulative_Restrictions.Value (R));
 463                         P := P + 5;
 464                      end if;
 465
 466                      Error_Msg_Name_1 := ALIs.Table (A).Sfile;
 467                      Consistency_Error_Msg (M2 (1 .. P - 1));
 468                      Consistency_Error_Msg
 469                        ("but the following files violate this restriction:");
 470                      return;
 471                   end;
 472                end if;
 473             end loop;
 474          end if;
 475       end Print_Restriction_File;
 476
 477    --  Start of processing for Check_Consistent_Restrictions
 478
 479    begin
 480       --  Loop through all restriction violations
 481
 482       for R in All_Restrictions loop
 483
 484          --  Check for violation of this restriction
 485
 486          if Cumulative_Restrictions.Set (R)
 487            and then Cumulative_Restrictions.Violated (R)
 488            and then (R in Partition_Boolean_Restrictions
 489                        or else (R in All_Parameter_Restrictions
 490                                    and then
 491                                      Cumulative_Restrictions.Count (R) >
 492                                      Cumulative_Restrictions.Value (R)))
 493          then
 494             Restriction_File_Output := False;
 495
 496             --  Loop through files looking for violators
 497
 498             for A2 in ALIs.First .. ALIs.Last loop
 499                declare
 500                   T : ALIs_Record renames ALIs.Table (A2);
 501
 502                begin
 503                   if T.Restrictions.Violated (R) then
 504
 505                      --  We exclude predefined files from the list of
 506                      --  violators. This should be rethought. It is not
 507                      --  clear that this is the right thing to do, that
 508                      --  is particularly the case for restricted runtimes.
 509
 510                      if not Is_Internal_File_Name (T.Sfile) then
 511
 512                         --  Case of Boolean restriction, just print file name
 513
 514                         if R in All_Boolean_Restrictions then
 515                            Print_Restriction_File (R);
 516                            Error_Msg_Name_1 := T.Sfile;
 517                            Consistency_Error_Msg ("  %");
 518
 519                         --  Case of Parameter restriction where violation
 520                         --  count exceeds restriction value, print file
 521                         --  name and count, adding "at least" if the
 522                         --  exact count is not known.
 523
 524                         elsif R in Checked_Add_Parameter_Restrictions
 525                           or else T.Restrictions.Count (R) >
 526                           Cumulative_Restrictions.Value (R)
 527                         then
 528                            Print_Restriction_File (R);
 529                            Error_Msg_Name_1 := T.Sfile;
 530                            Error_Msg_Nat_1 := Int (T.Restrictions.Count (R));
 531
 532                            if T.Restrictions.Unknown (R) then
 533                               Consistency_Error_Msg
 534                                 ("  % (count = at least #)");
 535                            else
 536                               Consistency_Error_Msg
 537                                 ("  % (count = #)");
 538                            end if;
 539                         end if;
 540                      end if;
 541                   end if;
 542                end;
 543             end loop;
 544          end if;
 545       end loop;
 546
 547       --  Now deal with No_Dependence indications. Note that we put the loop
 548       --  through entries in the no dependency table first, since this loop
 549       --  is most often empty (no such pragma Restrictions in use).
 550
 551       for ND in No_Deps.First .. No_Deps.Last loop
 552          declare
 553             ND_Unit : constant Name_Id := No_Deps.Table (ND).No_Dep_Unit;
 554
 555          begin
 556             for J in ALIs.First .. ALIs.Last loop
 557                declare
 558                   A : ALIs_Record renames ALIs.Table (J);
 559
 560                begin
 561                   for K in A.First_Unit .. A.Last_Unit loop
 562                      declare
 563                         U : Unit_Record renames Units.Table (K);
 564                      begin
 565                         for L in U.First_With .. U.Last_With loop
 566                            if Same_Unit (Withs.Table (L).Uname, ND_Unit) then
 567                               Error_Msg_Name_1 := U.Uname;
 568                               Error_Msg_Name_2 := ND_Unit;
 569                               Consistency_Error_Msg
 570                                 ("unit & violates restriction " &
 571                                  "No_Dependence => %");
 572                            end if;
 573                         end loop;
 574                      end;
 575                   end loop;
 576                end;
 577             end loop;
 578          end;
 579       end loop;
 580    end Check_Consistent_Restrictions;
 581
 582    ---------------
 583    -- Same_Unit --
 584    ---------------
 585
 586    function Same_Unit (U1 : Name_Id; U2 : Name_Id) return Boolean is
 587    begin
 588       --  Note, the string U1 has a terminating %s or %b, U2 does not
 589
 590       if Length_Of_Name (U1) - 2 = Length_Of_Name (U2) then
 591          Get_Name_String (U1);
 592
 593          declare
 594             U1_Str : constant String := Name_Buffer (1 .. Name_Len - 2);
 595          begin
 596             Get_Name_String (U2);
 597             return U1_Str = Name_Buffer (1 .. Name_Len);
 598          end;
 599
 600       else
 601          return False;
 602       end if;
 603    end Same_Unit;
 604
 605    ---------------------------------------------------
 606    -- Check_Consistent_Zero_Cost_Exception_Handling --
 607    ---------------------------------------------------
 608
 609    --  Check consistent zero cost exception handling. The rule is that
 610    --  all units must have the same exception handling mechanism.
 611
 612    procedure Check_Consistent_Zero_Cost_Exception_Handling is
 613    begin
 614       Check_Mechanism : for A1 in ALIs.First + 1 .. ALIs.Last loop
 615          if ALIs.Table (A1).Zero_Cost_Exceptions /=
 616             ALIs.Table (ALIs.First).Zero_Cost_Exceptions
 617
 618          then
 619             Error_Msg_Name_1 := ALIs.Table (A1).Sfile;
 620             Error_Msg_Name_2 := ALIs.Table (ALIs.First).Sfile;
 621
 622             Consistency_Error_Msg ("% and % compiled with different "
 623                                             & "exception handling mechanisms");
 624          end if;
 625       end loop Check_Mechanism;
 626    end Check_Consistent_Zero_Cost_Exception_Handling;
 627
 628    -----------------------
 629    -- Check_Consistency --
 630    -----------------------
 631
 632    procedure Check_Consistency is
 633       Src : Source_Id;
 634       --  Source file Id for this Sdep entry
 635
 636       ALI_Path_Id : Name_Id;
 637
 638    begin
 639       --  First, we go through the source table to see if there are any cases
 640       --  in which we should go after source files and compute checksums of
 641       --  the source files. We need to do this for any file for which we have
 642       --  mismatching time stamps and (so far) matching checksums.
 643
 644       for S in Source.First .. Source.Last loop
 645
 646          --  If all time stamps for a file match, then there is nothing to
 647          --  do, since we will not be checking checksums in that case anyway
 648
 649          if Source.Table (S).All_Timestamps_Match then
 650             null;
 651
 652          --  If we did not find the source file, then we can't compute its
 653          --  checksum anyway. Note that when we have a time stamp mismatch,
 654          --  we try to find the source file unconditionally (i.e. if
 655          --  Check_Source_Files is False).
 656
 657          elsif not Source.Table (S).Source_Found then
 658             null;
 659
 660          --  If we already have non-matching or missing checksums, then no
 661          --  need to try going after source file, since we won't trust the
 662          --  checksums in any case.
 663
 664          elsif not Source.Table (S).All_Checksums_Match then
 665             null;
 666
 667          --  Now we have the case where we have time stamp mismatches, and
 668          --  the source file is around, but so far all checksums match. This
 669          --  is the case where we need to compute the checksum from the source
 670          --  file, since otherwise we would ignore the time stamp mismatches,
 671          --  and that is wrong if the checksum of the source does not agree
 672          --  with the checksums in the ALI files.
 673
 674          elsif Check_Source_Files then
 675             if not Checksums_Match
 676               (Source.Table (S).Checksum,
 677                Get_File_Checksum (Source.Table (S).Sfile))
 678             then
 679                Source.Table (S).All_Checksums_Match := False;
 680             end if;
 681          end if;
 682       end loop;
 683
 684       --  Loop through ALI files
 685
 686       ALIs_Loop : for A in ALIs.First .. ALIs.Last loop
 687
 688          --  Loop through Sdep entries in one ALI file
 689
 690          Sdep_Loop : for D in
 691            ALIs.Table (A).First_Sdep .. ALIs.Table (A).Last_Sdep
 692          loop
 693             if Sdep.Table (D).Dummy_Entry then
 694                goto Continue;
 695             end if;
 696
 697             Src := Source_Id (Get_Name_Table_Info (Sdep.Table (D).Sfile));
 698
 699             --  If the time stamps match, or all checksums match, then we
 700             --  are OK, otherwise we have a definite error.
 701
 702             if Sdep.Table (D).Stamp /= Source.Table (Src).Stamp
 703               and then not Source.Table (Src).All_Checksums_Match
 704             then
 705                Error_Msg_Name_1 := ALIs.Table (A).Sfile;
 706                Error_Msg_Name_2 := Sdep.Table (D).Sfile;
 707
 708                --  Two styles of message, depending on whether or not
 709                --  the updated file is the one that must be recompiled
 710
 711                if Error_Msg_Name_1 = Error_Msg_Name_2 then
 712                   if Tolerate_Consistency_Errors then
 713                      Error_Msg
 714                         ("?% has been modified and should be recompiled");
 715                   else
 716                      Error_Msg
 717                        ("% has been modified and must be recompiled");
 718                   end if;
 719
 720                else
 721                   ALI_Path_Id :=
 722                     Osint.Find_File ((ALIs.Table (A).Afile), Osint.Library);
 723                   if Osint.Is_Readonly_Library (ALI_Path_Id) then
 724                      if Tolerate_Consistency_Errors then
 725                         Error_Msg ("?% should be recompiled");
 726                         Error_Msg_Name_1 := ALI_Path_Id;
 727                         Error_Msg ("?(% is obsolete and read-only)");
 728
 729                      else
 730                         Error_Msg ("% must be compiled");
 731                         Error_Msg_Name_1 := ALI_Path_Id;
 732                         Error_Msg ("(% is obsolete and read-only)");
 733                      end if;
 734
 735                   elsif Tolerate_Consistency_Errors then
 736                      Error_Msg
 737                        ("?% should be recompiled (% has been modified)");
 738
 739                   else
 740                      Error_Msg ("% must be recompiled (% has been modified)");
 741                   end if;
 742                end if;
 743
 744                if (not Tolerate_Consistency_Errors) and Verbose_Mode then
 745                   declare
 746                      Msg : constant String := "% time stamp ";
 747                      Buf : String (1 .. Msg'Length + Time_Stamp_Length);
 748
 749                   begin
 750                      Buf (1 .. Msg'Length) := Msg;
 751                      Buf (Msg'Length + 1 .. Buf'Length) :=
 752                        String (Source.Table (Src).Stamp);
 753                      Error_Msg_Name_1 := Sdep.Table (D).Sfile;
 754                      Error_Msg (Buf);
 755                   end;
 756
 757                   declare
 758                      Msg : constant String := " conflicts with % timestamp ";
 759                      Buf : String (1 .. Msg'Length + Time_Stamp_Length);
 760
 761                   begin
 762                      Buf (1 .. Msg'Length) := Msg;
 763                      Buf (Msg'Length + 1 .. Buf'Length) :=
 764                        String (Sdep.Table (D).Stamp);
 765                      Error_Msg_Name_1 := Sdep.Table (D).Sfile;
 766                      Error_Msg (Buf);
 767                   end;
 768                end if;
 769
 770                --  Exit from the loop through Sdep entries once we find one
 771                --  that does not match.
 772
 773                exit Sdep_Loop;
 774             end if;
 775
 776          <<Continue>>
 777             null;
 778          end loop Sdep_Loop;
 779       end loop ALIs_Loop;
 780    end Check_Consistency;
 781
 782    -------------------------------
 783    -- Check_Duplicated_Subunits --
 784    -------------------------------
 785
 786    procedure Check_Duplicated_Subunits is
 787    begin
 788       for J in Sdep.First .. Sdep.Last loop
 789          if Sdep.Table (J).Subunit_Name /= No_Name then
 790             Get_Decoded_Name_String (Sdep.Table (J).Subunit_Name);
 791             Name_Len := Name_Len + 2;
 792             Name_Buffer (Name_Len - 1) := '%';
 793
 794             --  See if there is a body or spec with the same name
 795
 796             for K in Boolean loop
 797                if K then
 798                   Name_Buffer (Name_Len) := 'b';
 799
 800                else
 801                   Name_Buffer (Name_Len) := 's';
 802                end if;
 803
 804                declare
 805                   Info : constant Int := Get_Name_Table_Info (Name_Find);
 806
 807                begin
 808                   if Info /= 0 then
 809                      Set_Standard_Error;
 810                      Write_Str ("error: subunit """);
 811                      Write_Name_Decoded (Sdep.Table (J).Subunit_Name);
 812                      Write_Str (""" in file """);
 813                      Write_Name_Decoded (Sdep.Table (J).Sfile);
 814                      Write_Char ('"');
 815                      Write_Eol;
 816                      Write_Str ("       has same name as unit """);
 817                      Write_Unit_Name (Units.Table (Unit_Id (Info)).Uname);
 818                      Write_Str (""" found in file """);
 819                      Write_Name_Decoded (Units.Table (Unit_Id (Info)).Sfile);
 820                      Write_Char ('"');
 821                      Write_Eol;
 822                      Write_Str ("       this is not allowed within a single "
 823                                 & "partition (RM 10.2(19))");
 824                      Write_Eol;
 825                      Osint.Exit_Program (Osint.E_Fatal);
 826                   end if;
 827                end;
 828             end loop;
 829          end if;
 830       end loop;
 831    end Check_Duplicated_Subunits;
 832
 833    --------------------
 834    -- Check_Versions --
 835    --------------------
 836
 837    procedure Check_Versions is
 838       VL : constant Natural := ALIs.Table (ALIs.First).Ver_Len;
 839
 840    begin
 841       for A in ALIs.First .. ALIs.Last loop
 842          if ALIs.Table (A).Ver_Len /= VL
 843            or else ALIs.Table (A).Ver          (1 .. VL) /=
 844                    ALIs.Table (ALIs.First).Ver (1 .. VL)
 845          then
 846             Error_Msg_Name_1 := ALIs.Table (A).Sfile;
 847             Error_Msg_Name_2 := ALIs.Table (ALIs.First).Sfile;
 848
 849             Consistency_Error_Msg
 850                ("% and % compiled with different GNAT versions");
 851          end if;
 852       end loop;
 853    end Check_Versions;
 854
 855    ---------------------------
 856    -- Consistency_Error_Msg --
 857    ---------------------------
 858
 859    procedure Consistency_Error_Msg (Msg : String) is
 860    begin
 861       if Tolerate_Consistency_Errors then
 862
 863          --  If consistency errors are tolerated,
 864          --  output the message as a warning.
 865
 866          declare
 867             Warning_Msg : String (1 .. Msg'Length + 1);
 868
 869          begin
 870             Warning_Msg (1) := '?';
 871             Warning_Msg (2 .. Warning_Msg'Last) := Msg;
 872
 873             Error_Msg (Warning_Msg);
 874          end;
 875
 876       --  Otherwise the consistency error is a true error
 877
 878       else
 879          Error_Msg (Msg);
 880       end if;
 881    end Consistency_Error_Msg;
 882
 883 end Bcheck;