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-2007, 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 3,  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 COPYING3.  If not, go to --
  19 -- http://www.gnu.org/licenses for a complete copy of the license.          --
  20 --                                                                          --
  21 -- GNAT was originally developed  by the GNAT team at  New York University. --
  22 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  23 --                                                                          --
  24 ------------------------------------------------------------------------------
  25
  26 with ALI;      use ALI;
  27 with ALI.Util; use ALI.Util;
  28 with Binderr;  use Binderr;
  29 with Butil;    use Butil;
  30 with Casing;   use Casing;
  31 with Fname;    use Fname;
  32 with Namet;    use Namet;
  33 with Opt;      use Opt;
  34 with Osint;
  35 with Output;   use Output;
  36 with Rident;   use Rident;
  37 with Types;    use Types;
  38
  39 package body Bcheck is
  40
  41    -----------------------
  42    -- Local Subprograms --
  43    -----------------------
  44
  45    --  The following checking subprograms make up the parts of the
  46    --  configuration consistency check.
  47
  48    procedure Check_Consistent_Dispatching_Policy;
  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 : Unit_Name_Type; 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_Configuration_Consistency --
  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       Check_Consistent_Dispatching_Policy;
  94    end Check_Configuration_Consistency;
  95
  96    -----------------------
  97    -- Check_Consistency --
  98    -----------------------
  99
 100    procedure Check_Consistency is
 101       Src : Source_Id;
 102       --  Source file Id for this Sdep entry
 103
 104       ALI_Path_Id : File_Name_Type;
 105
 106    begin
 107       --  First, we go through the source table to see if there are any cases
 108       --  in which we should go after source files and compute checksums of
 109       --  the source files. We need to do this for any file for which we have
 110       --  mismatching time stamps and (so far) matching checksums.
 111
 112       for S in Source.First .. Source.Last loop
 113
 114          --  If all time stamps for a file match, then there is nothing to
 115          --  do, since we will not be checking checksums in that case anyway
 116
 117          if Source.Table (S).All_Timestamps_Match then
 118             null;
 119
 120          --  If we did not find the source file, then we can't compute its
 121          --  checksum anyway. Note that when we have a time stamp mismatch,
 122          --  we try to find the source file unconditionally (i.e. if
 123          --  Check_Source_Files is False).
 124
 125          elsif not Source.Table (S).Source_Found then
 126             null;
 127
 128          --  If we already have non-matching or missing checksums, then no
 129          --  need to try going after source file, since we won't trust the
 130          --  checksums in any case.
 131
 132          elsif not Source.Table (S).All_Checksums_Match then
 133             null;
 134
 135          --  Now we have the case where we have time stamp mismatches, and
 136          --  the source file is around, but so far all checksums match. This
 137          --  is the case where we need to compute the checksum from the source
 138          --  file, since otherwise we would ignore the time stamp mismatches,
 139          --  and that is wrong if the checksum of the source does not agree
 140          --  with the checksums in the ALI files.
 141
 142          elsif Check_Source_Files then
 143             if not Checksums_Match
 144               (Source.Table (S).Checksum,
 145                Get_File_Checksum (Source.Table (S).Sfile))
 146             then
 147                Source.Table (S).All_Checksums_Match := False;
 148             end if;
 149          end if;
 150       end loop;
 151
 152       --  Loop through ALI files
 153
 154       ALIs_Loop : for A in ALIs.First .. ALIs.Last loop
 155
 156          --  Loop through Sdep entries in one ALI file
 157
 158          Sdep_Loop : for D in
 159            ALIs.Table (A).First_Sdep .. ALIs.Table (A).Last_Sdep
 160          loop
 161             if Sdep.Table (D).Dummy_Entry then
 162                goto Continue;
 163             end if;
 164
 165             Src := Source_Id (Get_Name_Table_Info (Sdep.Table (D).Sfile));
 166
 167             --  If the time stamps match, or all checksums match, then we
 168             --  are OK, otherwise we have a definite error.
 169
 170             if Sdep.Table (D).Stamp /= Source.Table (Src).Stamp
 171               and then not Source.Table (Src).All_Checksums_Match
 172             then
 173                Error_Msg_File_1 := ALIs.Table (A).Sfile;
 174                Error_Msg_File_2 := Sdep.Table (D).Sfile;
 175
 176                --  Two styles of message, depending on whether or not
 177                --  the updated file is the one that must be recompiled
 178
 179                if Error_Msg_File_1 = Error_Msg_File_2 then
 180                   if Tolerate_Consistency_Errors then
 181                      Error_Msg
 182                         ("?{ has been modified and should be recompiled");
 183                   else
 184                      Error_Msg
 185                        ("{ has been modified and must be recompiled");
 186                   end if;
 187
 188                else
 189                   ALI_Path_Id :=
 190                     Osint.Find_File ((ALIs.Table (A).Afile), Osint.Library);
 191                   if Osint.Is_Readonly_Library (ALI_Path_Id) then
 192                      if Tolerate_Consistency_Errors then
 193                         Error_Msg ("?{ should be recompiled");
 194                         Error_Msg_File_1 := ALI_Path_Id;
 195                         Error_Msg ("?({ is obsolete and read-only)");
 196                      else
 197                         Error_Msg ("{ must be compiled");
 198                         Error_Msg_File_1 := ALI_Path_Id;
 199                         Error_Msg ("({ is obsolete and read-only)");
 200                      end if;
 201
 202                   elsif Tolerate_Consistency_Errors then
 203                      Error_Msg
 204                        ("?{ should be recompiled ({ has been modified)");
 205
 206                   else
 207                      Error_Msg ("{ must be recompiled ({ has been modified)");
 208                   end if;
 209                end if;
 210
 211                if (not Tolerate_Consistency_Errors) and Verbose_Mode then
 212                   Error_Msg_File_1 := Sdep.Table (D).Sfile;
 213                   Error_Msg
 214                     ("{ time stamp " & String (Source.Table (Src).Stamp));
 215
 216                   Error_Msg_File_1 := Sdep.Table (D).Sfile;
 217                   --  Something wrong here, should be different file ???
 218
 219                   Error_Msg
 220                     (" conflicts with { timestamp " &
 221                      String (Sdep.Table (D).Stamp));
 222                end if;
 223
 224                --  Exit from the loop through Sdep entries once we find one
 225                --  that does not match.
 226
 227                exit Sdep_Loop;
 228             end if;
 229
 230          <<Continue>>
 231             null;
 232          end loop Sdep_Loop;
 233       end loop ALIs_Loop;
 234    end Check_Consistency;
 235
 236    -----------------------------------------
 237    -- Check_Consistent_Dispatching_Policy --
 238    -----------------------------------------
 239
 240    --  The rule is that all files for which the dispatching policy is
 241    --  significant must meet the following rules:
 242
 243    --    1. All files for which a task dispatching policy is significant must
 244    --    be compiled with the same setting.
 245
 246    --    2. If a partition contains one or more Priority_Specific_Dispatching
 247    --    pragmas it cannot contain a Task_Dispatching_Policy pragma.
 248
 249    --    3. No overlap is allowed in the priority ranges specified in
 250    --    Priority_Specific_Dispatching pragmas within the same partition.
 251
 252    --    4. If a partition contains one or more Priority_Specific_Dispatching
 253    --    pragmas then the Ceiling_Locking policy is the only one allowed for
 254    --    the partition.
 255
 256    procedure Check_Consistent_Dispatching_Policy is
 257       Max_Prio : Nat := 0;
 258       --  Maximum priority value for which a Priority_Specific_Dispatching
 259       --  pragma has been specified.
 260
 261       TDP_Pragma_Afile : ALI_Id := No_ALI_Id;
 262       --  ALI file where a Task_Dispatching_Policy pragma appears
 263
 264    begin
 265       --  Consistency checks in units specifying a Task_Dispatching_Policy
 266
 267       if Task_Dispatching_Policy_Specified /= ' ' then
 268          Find_Policy : for A1 in ALIs.First .. ALIs.Last loop
 269             if ALIs.Table (A1).Task_Dispatching_Policy /= ' ' then
 270
 271                --  Store the place where the first task dispatching pragma
 272                --  appears. We may need this value for issuing consistency
 273                --  errors if Priority_Specific_Dispatching pragmas are used.
 274
 275                TDP_Pragma_Afile := A1;
 276
 277                Check_Policy : declare
 278                   Policy : constant Character :=
 279                              ALIs.Table (A1).Task_Dispatching_Policy;
 280
 281                begin
 282                   for A2 in A1 + 1 .. ALIs.Last loop
 283                      if ALIs.Table (A2).Task_Dispatching_Policy /= ' '
 284                           and then
 285                         ALIs.Table (A2).Task_Dispatching_Policy /= Policy
 286                      then
 287                         Error_Msg_File_1 := ALIs.Table (A1).Sfile;
 288                         Error_Msg_File_2 := ALIs.Table (A2).Sfile;
 289
 290                         Consistency_Error_Msg
 291                           ("{ and { compiled with different task" &
 292                            " dispatching policies");
 293                         exit Find_Policy;
 294                      end if;
 295                   end loop;
 296                end Check_Policy;
 297
 298                exit Find_Policy;
 299             end if;
 300          end loop Find_Policy;
 301       end if;
 302
 303       --  If no Priority_Specific_Dispatching entries, nothing else to do
 304
 305       if Specific_Dispatching.Last >= Specific_Dispatching.First then
 306
 307          --  Find out the maximum priority value for which one of the
 308          --  Priority_Specific_Dispatching pragmas applies.
 309
 310          Max_Prio := 0;
 311          for J in Specific_Dispatching.First .. Specific_Dispatching.Last loop
 312             if Specific_Dispatching.Table (J).Last_Priority > Max_Prio then
 313                Max_Prio := Specific_Dispatching.Table (J).Last_Priority;
 314             end if;
 315          end loop;
 316
 317          --  Now establish tables to be used for consistency checking
 318
 319          declare
 320             --  The following record type is used to record locations of the
 321             --  Priority_Specific_Dispatching pragmas applying to the Priority.
 322
 323             type Specific_Dispatching_Entry is record
 324                Dispatching_Policy : Character := ' ';
 325                --  First character (upper case) of corresponding policy name
 326
 327                Afile : ALI_Id := No_ALI_Id;
 328                --  ALI file that generated Priority Specific Dispatching
 329                --  entry for consistency message.
 330
 331                Loc : Nat := 0;
 332                --  Line numbers from Priority_Specific_Dispatching pragma
 333             end record;
 334
 335             PSD_Table  : array (0 .. Max_Prio) of Specific_Dispatching_Entry :=
 336                            (others => Specific_Dispatching_Entry'
 337                               (Dispatching_Policy => ' ',
 338                                Afile              => No_ALI_Id,
 339                                Loc                => 0));
 340             --  Array containing an entry per priority containing the location
 341             --  where there is a Priority_Specific_Dispatching pragma that
 342             --  applies to the priority.
 343
 344          begin
 345             for F in ALIs.First .. ALIs.Last loop
 346                for K in ALIs.Table (F).First_Specific_Dispatching ..
 347                         ALIs.Table (F).Last_Specific_Dispatching
 348                loop
 349                   declare
 350                      DTK : Specific_Dispatching_Record
 351                              renames Specific_Dispatching.Table (K);
 352                   begin
 353                      --  Check whether pragma Task_Dispatching_Policy and
 354                      --  pragma Priority_Specific_Dispatching are used in the
 355                      --  same partition.
 356
 357                      if Task_Dispatching_Policy_Specified /= ' ' then
 358                         Error_Msg_File_1 := ALIs.Table (F).Sfile;
 359                         Error_Msg_File_2 :=
 360                           ALIs.Table (TDP_Pragma_Afile).Sfile;
 361
 362                         Error_Msg_Nat_1 := DTK.PSD_Pragma_Line;
 363
 364                         Consistency_Error_Msg
 365                           ("Priority_Specific_Dispatching at {:#" &
 366                            " incompatible with Task_Dispatching_Policy at {");
 367                      end if;
 368
 369                      --  Ceiling_Locking must also be specified for a partition
 370                      --  with at least one Priority_Specific_Dispatching
 371                      --  pragma.
 372
 373                      if Locking_Policy_Specified /= ' '
 374                        and then Locking_Policy_Specified /= 'C'
 375                      then
 376                         for A in ALIs.First .. ALIs.Last loop
 377                            if ALIs.Table (A).Locking_Policy /= ' '
 378                              and then ALIs.Table (A).Locking_Policy /= 'C'
 379                            then
 380                               Error_Msg_File_1 := ALIs.Table (F).Sfile;
 381                               Error_Msg_File_2 := ALIs.Table (A).Sfile;
 382
 383                               Error_Msg_Nat_1  := DTK.PSD_Pragma_Line;
 384
 385                               Consistency_Error_Msg
 386                                 ("Priority_Specific_Dispatching at {:#" &
 387                                  " incompatible with Locking_Policy at {");
 388                            end if;
 389                         end loop;
 390                      end if;
 391
 392                      --  Check overlapping priority ranges
 393
 394                      Find_Overlapping : for Prio in
 395                        DTK.First_Priority .. DTK.Last_Priority
 396                      loop
 397                         if PSD_Table (Prio).Afile = No_ALI_Id then
 398                            PSD_Table (Prio) :=
 399                              (Dispatching_Policy => DTK.Dispatching_Policy,
 400                               Afile => F, Loc => DTK.PSD_Pragma_Line);
 401
 402                         elsif PSD_Table (Prio).Dispatching_Policy /=
 403                               DTK.Dispatching_Policy
 404
 405                         then
 406                            Error_Msg_File_1 :=
 407                              ALIs.Table (PSD_Table (Prio).Afile).Sfile;
 408                            Error_Msg_File_2 := ALIs.Table (F).Sfile;
 409                            Error_Msg_Nat_1  := PSD_Table (Prio).Loc;
 410                            Error_Msg_Nat_2  := DTK.PSD_Pragma_Line;
 411
 412                            Consistency_Error_Msg
 413                              ("overlapping priority ranges at {:# and {:#");
 414
 415                            exit Find_Overlapping;
 416                         end if;
 417                      end loop Find_Overlapping;
 418                   end;
 419                end loop;
 420             end loop;
 421          end;
 422       end if;
 423    end Check_Consistent_Dispatching_Policy;
 424
 425    ---------------------------------------------------
 426    -- Check_Consistent_Dynamic_Elaboration_Checking --
 427    ---------------------------------------------------
 428
 429    --  The rule here is that if a unit has dynamic elaboration checks,
 430    --  then any unit it withs must meeting one of the following criteria:
 431
 432    --    1. There is a pragma Elaborate_All for the with'ed unit
 433    --    2. The with'ed unit was compiled with dynamic elaboration checks
 434    --    3. The with'ed unit has pragma Preelaborate or Pure
 435    --    4. It is an internal GNAT unit (including children of GNAT)
 436
 437    procedure Check_Consistent_Dynamic_Elaboration_Checking is
 438    begin
 439       if Dynamic_Elaboration_Checks_Specified then
 440          for U in First_Unit_Entry .. Units.Last loop
 441             declare
 442                UR : Unit_Record renames Units.Table (U);
 443
 444             begin
 445                if UR.Dynamic_Elab then
 446                   for W in UR.First_With .. UR.Last_With loop
 447                      declare
 448                         WR : With_Record renames Withs.Table (W);
 449
 450                      begin
 451                         if Get_Name_Table_Info (WR.Uname) /= 0 then
 452                            declare
 453                               WU : Unit_Record renames
 454                                      Units.Table
 455                                        (Unit_Id
 456                                          (Get_Name_Table_Info (WR.Uname)));
 457
 458                            begin
 459                               --  Case 1. Elaborate_All for with'ed unit
 460
 461                               if WR.Elaborate_All then
 462                                  null;
 463
 464                               --  Case 2. With'ed unit has dynamic elab checks
 465
 466                               elsif WU.Dynamic_Elab then
 467                                  null;
 468
 469                               --  Case 3. With'ed unit is Preelaborate or Pure
 470
 471                               elsif WU.Preelab or WU.Pure then
 472                                  null;
 473
 474                               --  Case 4. With'ed unit is internal file
 475
 476                               elsif Is_Internal_File_Name (WU.Sfile) then
 477                                  null;
 478
 479                               --  Issue warning, not one of the safe cases
 480
 481                               else
 482                                  Error_Msg_File_1 := UR.Sfile;
 483                                  Error_Msg
 484                                    ("?{ has dynamic elaboration checks " &
 485                                                                  "and with's");
 486
 487                                  Error_Msg_File_1 := WU.Sfile;
 488                                  Error_Msg
 489                                    ("?  { which has static elaboration " &
 490                                                                      "checks");
 491
 492                                  Warnings_Detected := Warnings_Detected - 1;
 493                               end if;
 494                            end;
 495                         end if;
 496                      end;
 497                   end loop;
 498                end if;
 499             end;
 500          end loop;
 501       end if;
 502    end Check_Consistent_Dynamic_Elaboration_Checking;
 503
 504    --------------------------------------------
 505    -- Check_Consistent_Floating_Point_Format --
 506    --------------------------------------------
 507
 508    --  The rule is that all files must be compiled with the same setting
 509    --  for the floating-point format.
 510
 511    procedure Check_Consistent_Floating_Point_Format is
 512    begin
 513       --  First search for a unit specifying a floating-point format and then
 514       --  check all remaining units against it.
 515
 516       Find_Format : for A1 in ALIs.First .. ALIs.Last loop
 517          if ALIs.Table (A1).Float_Format /= ' ' then
 518             Check_Format : declare
 519                Format : constant Character := ALIs.Table (A1).Float_Format;
 520             begin
 521                for A2 in A1 + 1 .. ALIs.Last loop
 522                   if ALIs.Table (A2).Float_Format /= Format then
 523                      Error_Msg_File_1 := ALIs.Table (A1).Sfile;
 524                      Error_Msg_File_2 := ALIs.Table (A2).Sfile;
 525
 526                      Consistency_Error_Msg
 527                        ("{ and { compiled with different " &
 528                         "floating-point representations");
 529                      exit Find_Format;
 530                   end if;
 531                end loop;
 532             end Check_Format;
 533
 534             exit Find_Format;
 535          end if;
 536       end loop Find_Format;
 537    end Check_Consistent_Floating_Point_Format;
 538
 539    ---------------------------------------
 540    -- Check_Consistent_Interrupt_States --
 541    ---------------------------------------
 542
 543    --  The rule is that if the state of a given interrupt is specified
 544    --  in more than one unit, it must be specified with a consistent state.
 545
 546    procedure Check_Consistent_Interrupt_States is
 547       Max_Intrup : Nat;
 548
 549    begin
 550       --  If no Interrupt_State entries, nothing to do
 551
 552       if Interrupt_States.Last < Interrupt_States.First then
 553          return;
 554       end if;
 555
 556       --  First find out the maximum interrupt value
 557
 558       Max_Intrup := 0;
 559       for J in Interrupt_States.First .. Interrupt_States.Last loop
 560          if Interrupt_States.Table (J).Interrupt_Id > Max_Intrup then
 561             Max_Intrup := Interrupt_States.Table (J).Interrupt_Id;
 562          end if;
 563       end loop;
 564
 565       --  Now establish tables to be used for consistency checking
 566
 567       declare
 568          Istate : array (0 .. Max_Intrup) of Character := (others => 'n');
 569          --  Interrupt state entries, 'u'/'s'/'r' or 'n' to indicate an
 570          --  entry that has not been set.
 571
 572          Afile : array (0 .. Max_Intrup) of ALI_Id;
 573          --  ALI file that generated Istate entry for consistency message
 574
 575          Loc : array (0 .. Max_Intrup) of Nat;
 576          --  Line numbers from IS pragma generating Istate entry
 577
 578          Inum : Nat;
 579          --  Interrupt number from entry being tested
 580
 581          Stat : Character;
 582          --  Interrupt state from entry being tested
 583
 584          Lnum : Nat;
 585          --  Line number from entry being tested
 586
 587       begin
 588          for F in ALIs.First .. ALIs.Last loop
 589             for K in ALIs.Table (F).First_Interrupt_State ..
 590                      ALIs.Table (F).Last_Interrupt_State
 591             loop
 592                Inum := Interrupt_States.Table (K).Interrupt_Id;
 593                Stat := Interrupt_States.Table (K).Interrupt_State;
 594                Lnum := Interrupt_States.Table (K).IS_Pragma_Line;
 595
 596                if Istate (Inum) = 'n' then
 597                   Istate (Inum) := Stat;
 598                   Afile  (Inum) := F;
 599                   Loc    (Inum) := Lnum;
 600
 601                elsif Istate (Inum) /= Stat then
 602                   Error_Msg_File_1 := ALIs.Table (Afile (Inum)).Sfile;
 603                   Error_Msg_File_2 := ALIs.Table (F).Sfile;
 604                   Error_Msg_Nat_1  := Loc (Inum);
 605                   Error_Msg_Nat_2  := Lnum;
 606
 607                   Consistency_Error_Msg
 608                     ("inconsistent interrupt states at {:# and {:#");
 609                end if;
 610             end loop;
 611          end loop;
 612       end;
 613    end Check_Consistent_Interrupt_States;
 614
 615    -------------------------------------
 616    -- Check_Consistent_Locking_Policy --
 617    -------------------------------------
 618
 619    --  The rule is that all files for which the locking policy is
 620    --  significant must be compiled with the same setting.
 621
 622    procedure Check_Consistent_Locking_Policy is
 623    begin
 624       --  First search for a unit specifying a policy and then
 625       --  check all remaining units against it.
 626
 627       Find_Policy : for A1 in ALIs.First .. ALIs.Last loop
 628          if ALIs.Table (A1).Locking_Policy /= ' ' then
 629             Check_Policy : declare
 630                Policy : constant Character := ALIs.Table (A1).Locking_Policy;
 631
 632             begin
 633                for A2 in A1 + 1 .. ALIs.Last loop
 634                   if ALIs.Table (A2).Locking_Policy /= ' ' and
 635                      ALIs.Table (A2).Locking_Policy /= Policy
 636                   then
 637                      Error_Msg_File_1 := ALIs.Table (A1).Sfile;
 638                      Error_Msg_File_2 := ALIs.Table (A2).Sfile;
 639
 640                      Consistency_Error_Msg
 641                        ("{ and { compiled with different locking policies");
 642                      exit Find_Policy;
 643                   end if;
 644                end loop;
 645             end Check_Policy;
 646
 647             exit Find_Policy;
 648          end if;
 649       end loop Find_Policy;
 650    end Check_Consistent_Locking_Policy;
 651
 652    ----------------------------------------
 653    -- Check_Consistent_Normalize_Scalars --
 654    ----------------------------------------
 655
 656    --  The rule is that if any unit is compiled with Normalized_Scalars,
 657    --  then all other units in the partition must also be compiled with
 658    --  Normalized_Scalars in effect.
 659
 660    --  There is some issue as to whether this consistency check is
 661    --  desirable, it is certainly required at the moment by the RM.
 662    --  We should keep a watch on the ARG and HRG deliberations here.
 663    --  GNAT no longer depends on this consistency (it used to do so,
 664    --  but that has been corrected in the latest version, since the
 665    --  Initialize_Scalars pragma does not require consistency.
 666
 667    procedure Check_Consistent_Normalize_Scalars is
 668    begin
 669       if Normalize_Scalars_Specified and No_Normalize_Scalars_Specified then
 670          Consistency_Error_Msg
 671               ("some but not all files compiled with Normalize_Scalars");
 672
 673          Write_Eol;
 674          Write_Str ("files compiled with Normalize_Scalars");
 675          Write_Eol;
 676
 677          for A1 in ALIs.First .. ALIs.Last loop
 678             if ALIs.Table (A1).Normalize_Scalars then
 679                Write_Str ("  ");
 680                Write_Name (ALIs.Table (A1).Sfile);
 681                Write_Eol;
 682             end if;
 683          end loop;
 684
 685          Write_Eol;
 686          Write_Str ("files compiled without Normalize_Scalars");
 687          Write_Eol;
 688
 689          for A1 in ALIs.First .. ALIs.Last loop
 690             if not ALIs.Table (A1).Normalize_Scalars then
 691                Write_Str ("  ");
 692                Write_Name (ALIs.Table (A1).Sfile);
 693                Write_Eol;
 694             end if;
 695          end loop;
 696       end if;
 697    end Check_Consistent_Normalize_Scalars;
 698
 699    -------------------------------------
 700    -- Check_Consistent_Queuing_Policy --
 701    -------------------------------------
 702
 703    --  The rule is that all files for which the queuing policy is
 704    --  significant must be compiled with the same setting.
 705
 706    procedure Check_Consistent_Queuing_Policy is
 707    begin
 708       --  First search for a unit specifying a policy and then
 709       --  check all remaining units against it.
 710
 711       Find_Policy : for A1 in ALIs.First .. ALIs.Last loop
 712          if ALIs.Table (A1).Queuing_Policy /= ' ' then
 713             Check_Policy : declare
 714                Policy : constant Character := ALIs.Table (A1).Queuing_Policy;
 715             begin
 716                for A2 in A1 + 1 .. ALIs.Last loop
 717                   if ALIs.Table (A2).Queuing_Policy /= ' '
 718                        and then
 719                      ALIs.Table (A2).Queuing_Policy /= Policy
 720                   then
 721                      Error_Msg_File_1 := ALIs.Table (A1).Sfile;
 722                      Error_Msg_File_2 := ALIs.Table (A2).Sfile;
 723
 724                      Consistency_Error_Msg
 725                        ("{ and { compiled with different queuing policies");
 726                      exit Find_Policy;
 727                   end if;
 728                end loop;
 729             end Check_Policy;
 730
 731             exit Find_Policy;
 732          end if;
 733       end loop Find_Policy;
 734    end Check_Consistent_Queuing_Policy;
 735
 736    -----------------------------------
 737    -- Check_Consistent_Restrictions --
 738    -----------------------------------
 739
 740    --  The rule is that if a restriction is specified in any unit,
 741    --  then all units must obey the restriction. The check applies
 742    --  only to restrictions which require partition wide consistency,
 743    --  and not to internal units.
 744
 745    procedure Check_Consistent_Restrictions is
 746       Restriction_File_Output : Boolean;
 747       --  Shows if we have output header messages for restriction violation
 748
 749       procedure Print_Restriction_File (R : All_Restrictions);
 750       --  Print header line for R if not printed yet
 751
 752       ----------------------------
 753       -- Print_Restriction_File --
 754       ----------------------------
 755
 756       procedure Print_Restriction_File (R : All_Restrictions) is
 757       begin
 758          if not Restriction_File_Output then
 759             Restriction_File_Output := True;
 760
 761             --  Find an ali file specifying the restriction
 762
 763             for A in ALIs.First .. ALIs.Last loop
 764                if ALIs.Table (A).Restrictions.Set (R)
 765                  and then (R in All_Boolean_Restrictions
 766                              or else ALIs.Table (A).Restrictions.Value (R) =
 767                                      Cumulative_Restrictions.Value (R))
 768                then
 769                   --  We have found that ALI file A specifies the restriction
 770                   --  that is being violated (the minimum value is specified
 771                   --  in the case of a parameter restriction).
 772
 773                   declare
 774                      M1 : constant String := "{ has restriction ";
 775                      S  : constant String := Restriction_Id'Image (R);
 776                      M2 : String (1 .. 200); -- big enough!
 777                      P  : Integer;
 778
 779                   begin
 780                      Name_Buffer (1 .. S'Length) := S;
 781                      Name_Len := S'Length;
 782                      Set_Casing (Mixed_Case);
 783
 784                      M2 (M1'Range) := M1;
 785                      P := M1'Length + 1;
 786                      M2 (P .. P + S'Length - 1) := Name_Buffer (1 .. S'Length);
 787                      P := P + S'Length;
 788
 789                      if R in All_Parameter_Restrictions then
 790                         M2 (P .. P + 4) := " => #";
 791                         Error_Msg_Nat_1 :=
 792                           Int (Cumulative_Restrictions.Value (R));
 793                         P := P + 5;
 794                      end if;
 795
 796                      Error_Msg_File_1 := ALIs.Table (A).Sfile;
 797                      Consistency_Error_Msg (M2 (1 .. P - 1));
 798                      Consistency_Error_Msg
 799                        ("but the following files violate this restriction:");
 800                      return;
 801                   end;
 802                end if;
 803             end loop;
 804          end if;
 805       end Print_Restriction_File;
 806
 807    --  Start of processing for Check_Consistent_Restrictions
 808
 809    begin
 810       --  Loop through all restriction violations
 811
 812       for R in All_Restrictions loop
 813
 814          --  Check for violation of this restriction
 815
 816          if Cumulative_Restrictions.Set (R)
 817            and then Cumulative_Restrictions.Violated (R)
 818            and then (R in Partition_Boolean_Restrictions
 819                        or else (R in All_Parameter_Restrictions
 820                                    and then
 821                                      Cumulative_Restrictions.Count (R) >
 822                                      Cumulative_Restrictions.Value (R)))
 823          then
 824             Restriction_File_Output := False;
 825
 826             --  Loop through files looking for violators
 827
 828             for A2 in ALIs.First .. ALIs.Last loop
 829                declare
 830                   T : ALIs_Record renames ALIs.Table (A2);
 831
 832                begin
 833                   if T.Restrictions.Violated (R) then
 834
 835                      --  We exclude predefined files from the list of
 836                      --  violators. This should be rethought. It is not
 837                      --  clear that this is the right thing to do, that
 838                      --  is particularly the case for restricted runtimes.
 839
 840                      if not Is_Internal_File_Name (T.Sfile) then
 841
 842                         --  Case of Boolean restriction, just print file name
 843
 844                         if R in All_Boolean_Restrictions then
 845                            Print_Restriction_File (R);
 846                            Error_Msg_File_1 := T.Sfile;
 847                            Consistency_Error_Msg ("  {");
 848
 849                         --  Case of Parameter restriction where violation
 850                         --  count exceeds restriction value, print file
 851                         --  name and count, adding "at least" if the
 852                         --  exact count is not known.
 853
 854                         elsif R in Checked_Add_Parameter_Restrictions
 855                           or else T.Restrictions.Count (R) >
 856                           Cumulative_Restrictions.Value (R)
 857                         then
 858                            Print_Restriction_File (R);
 859                            Error_Msg_File_1 := T.Sfile;
 860                            Error_Msg_Nat_1 := Int (T.Restrictions.Count (R));
 861
 862                            if T.Restrictions.Unknown (R) then
 863                               Consistency_Error_Msg
 864                                 ("  { (count = at least #)");
 865                            else
 866                               Consistency_Error_Msg
 867                                 ("  % (count = #)");
 868                            end if;
 869                         end if;
 870                      end if;
 871                   end if;
 872                end;
 873             end loop;
 874          end if;
 875       end loop;
 876
 877       --  Now deal with No_Dependence indications. Note that we put the loop
 878       --  through entries in the no dependency table first, since this loop
 879       --  is most often empty (no such pragma Restrictions in use).
 880
 881       for ND in No_Deps.First .. No_Deps.Last loop
 882          declare
 883             ND_Unit : constant Name_Id :=
 884                         No_Deps.Table (ND).No_Dep_Unit;
 885
 886          begin
 887             for J in ALIs.First .. ALIs.Last loop
 888                declare
 889                   A : ALIs_Record renames ALIs.Table (J);
 890
 891                begin
 892                   for K in A.First_Unit .. A.Last_Unit loop
 893                      declare
 894                         U : Unit_Record renames Units.Table (K);
 895                      begin
 896                         for L in U.First_With .. U.Last_With loop
 897                            if Same_Unit
 898                              (Withs.Table (L).Uname, ND_Unit)
 899                            then
 900                               Error_Msg_File_1 := U.Sfile;
 901                               Error_Msg_Name_1 := ND_Unit;
 902                               Consistency_Error_Msg
 903                                 ("file { violates restriction " &
 904                                  "No_Dependence => %");
 905                            end if;
 906                         end loop;
 907                      end;
 908                   end loop;
 909                end;
 910             end loop;
 911          end;
 912       end loop;
 913    end Check_Consistent_Restrictions;
 914
 915    ---------------------------------------------------
 916    -- Check_Consistent_Zero_Cost_Exception_Handling --
 917    ---------------------------------------------------
 918
 919    --  Check consistent zero cost exception handling. The rule is that
 920    --  all units must have the same exception handling mechanism.
 921
 922    procedure Check_Consistent_Zero_Cost_Exception_Handling is
 923    begin
 924       Check_Mechanism : for A1 in ALIs.First + 1 .. ALIs.Last loop
 925          if ALIs.Table (A1).Zero_Cost_Exceptions /=
 926             ALIs.Table (ALIs.First).Zero_Cost_Exceptions
 927          then
 928             Error_Msg_File_1 := ALIs.Table (A1).Sfile;
 929             Error_Msg_File_2 := ALIs.Table (ALIs.First).Sfile;
 930
 931             Consistency_Error_Msg ("{ and { compiled with different "
 932                                             & "exception handling mechanisms");
 933          end if;
 934       end loop Check_Mechanism;
 935    end Check_Consistent_Zero_Cost_Exception_Handling;
 936
 937    -------------------------------
 938    -- Check_Duplicated_Subunits --
 939    -------------------------------
 940
 941    procedure Check_Duplicated_Subunits is
 942    begin
 943       for J in Sdep.First .. Sdep.Last loop
 944          if Sdep.Table (J).Subunit_Name /= No_Name then
 945             Get_Decoded_Name_String (Sdep.Table (J).Subunit_Name);
 946             Name_Len := Name_Len + 2;
 947             Name_Buffer (Name_Len - 1) := '%';
 948
 949             --  See if there is a body or spec with the same name
 950
 951             for K in Boolean loop
 952                if K then
 953                   Name_Buffer (Name_Len) := 'b';
 954                else
 955                   Name_Buffer (Name_Len) := 's';
 956                end if;
 957
 958                declare
 959                   Unit : constant Unit_Name_Type := Name_Find;
 960                   Info : constant Int := Get_Name_Table_Info (Unit);
 961
 962                begin
 963                   if Info /= 0 then
 964                      Set_Standard_Error;
 965                      Write_Str ("error: subunit """);
 966                      Write_Name_Decoded (Sdep.Table (J).Subunit_Name);
 967                      Write_Str (""" in file """);
 968                      Write_Name_Decoded (Sdep.Table (J).Sfile);
 969                      Write_Char ('"');
 970                      Write_Eol;
 971                      Write_Str ("       has same name as unit """);
 972                      Write_Unit_Name (Units.Table (Unit_Id (Info)).Uname);
 973                      Write_Str (""" found in file """);
 974                      Write_Name_Decoded (Units.Table (Unit_Id (Info)).Sfile);
 975                      Write_Char ('"');
 976                      Write_Eol;
 977                      Write_Str ("       this is not allowed within a single "
 978                                 & "partition (RM 10.2(19))");
 979                      Write_Eol;
 980                      Osint.Exit_Program (Osint.E_Fatal);
 981                   end if;
 982                end;
 983             end loop;
 984          end if;
 985       end loop;
 986    end Check_Duplicated_Subunits;
 987
 988    --------------------
 989    -- Check_Versions --
 990    --------------------
 991
 992    procedure Check_Versions is
 993       VL : constant Natural := ALIs.Table (ALIs.First).Ver_Len;
 994
 995    begin
 996       for A in ALIs.First .. ALIs.Last loop
 997          if ALIs.Table (A).Ver_Len /= VL
 998            or else ALIs.Table (A).Ver          (1 .. VL) /=
 999                    ALIs.Table (ALIs.First).Ver (1 .. VL)
1000          then
1001             Error_Msg_File_1 := ALIs.Table (A).Sfile;
1002             Error_Msg_File_2 := ALIs.Table (ALIs.First).Sfile;
1003
1004             Consistency_Error_Msg
1005                ("{ and { compiled with different GNAT versions");
1006          end if;
1007       end loop;
1008    end Check_Versions;
1009
1010    ---------------------------
1011    -- Consistency_Error_Msg --
1012    ---------------------------
1013
1014    procedure Consistency_Error_Msg (Msg : String) is
1015    begin
1016       if Tolerate_Consistency_Errors then
1017
1018          --  If consistency errors are tolerated,
1019          --  output the message as a warning.
1020
1021          declare
1022             Warning_Msg : String (1 .. Msg'Length + 1);
1023
1024          begin
1025             Warning_Msg (1) := '?';
1026             Warning_Msg (2 .. Warning_Msg'Last) := Msg;
1027
1028             Error_Msg (Warning_Msg);
1029          end;
1030
1031       --  Otherwise the consistency error is a true error
1032
1033       else
1034          Error_Msg (Msg);
1035       end if;
1036    end Consistency_Error_Msg;
1037
1038    ---------------
1039    -- Same_Unit --
1040    ---------------
1041
1042    function Same_Unit (U1 : Unit_Name_Type; U2 : Name_Id) return Boolean is
1043    begin
1044       --  Note, the string U1 has a terminating %s or %b, U2 does not
1045
1046       if Length_Of_Name (U1) - 2 = Length_Of_Name (U2) then
1047          Get_Name_String (U1);
1048
1049          declare
1050             U1_Str : constant String := Name_Buffer (1 .. Name_Len - 2);
1051          begin
1052             Get_Name_String (U2);
1053             return U1_Str = Name_Buffer (1 .. Name_Len);
1054          end;
1055
1056       else
1057          return False;
1058       end if;
1059    end Same_Unit;
1060
1061 end Bcheck;