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