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