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-2009, 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 else 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 /= ' '
 638                        and then
 639                      ALIs.Table (A2).Locking_Policy /= Policy
 640                   then
 641                      Error_Msg_File_1 := ALIs.Table (A1).Sfile;
 642                      Error_Msg_File_2 := ALIs.Table (A2).Sfile;
 643
 644                      Consistency_Error_Msg
 645                        ("{ and { compiled with different locking policies");
 646                      exit Find_Policy;
 647                   end if;
 648                end loop;
 649             end Check_Policy;
 650
 651             exit Find_Policy;
 652          end if;
 653       end loop Find_Policy;
 654    end Check_Consistent_Locking_Policy;
 655
 656    ----------------------------------------
 657    -- Check_Consistent_Normalize_Scalars --
 658    ----------------------------------------
 659
 660    --  The rule is that if any unit is compiled with Normalized_Scalars,
 661    --  then all other units in the partition must also be compiled with
 662    --  Normalized_Scalars in effect.
 663
 664    --  There is some issue as to whether this consistency check is desirable,
 665    --  it is certainly required at the moment by the RM. We should keep a watch
 666    --  on the ARG and HRG deliberations here. GNAT no longer depends on this
 667    --  consistency (it used to do so, but that is no longer the case, since
 668    --  pragma Initialize_Scalars pragma does not require consistency.)
 669
 670    procedure Check_Consistent_Normalize_Scalars is
 671    begin
 672       if Normalize_Scalars_Specified and No_Normalize_Scalars_Specified then
 673          Consistency_Error_Msg
 674               ("some but not all files compiled with Normalize_Scalars");
 675
 676          Write_Eol;
 677          Write_Str ("files compiled with Normalize_Scalars");
 678          Write_Eol;
 679
 680          for A1 in ALIs.First .. ALIs.Last loop
 681             if ALIs.Table (A1).Normalize_Scalars then
 682                Write_Str ("  ");
 683                Write_Name (ALIs.Table (A1).Sfile);
 684                Write_Eol;
 685             end if;
 686          end loop;
 687
 688          Write_Eol;
 689          Write_Str ("files compiled without Normalize_Scalars");
 690          Write_Eol;
 691
 692          for A1 in ALIs.First .. ALIs.Last loop
 693             if not ALIs.Table (A1).Normalize_Scalars then
 694                Write_Str ("  ");
 695                Write_Name (ALIs.Table (A1).Sfile);
 696                Write_Eol;
 697             end if;
 698          end loop;
 699       end if;
 700    end Check_Consistent_Normalize_Scalars;
 701
 702    -----------------------------------------
 703    -- Check_Consistent_Optimize_Alignment --
 704    -----------------------------------------
 705
 706    --  The rule is that all units which depend on the global default setting
 707    --  of Optimize_Alignment must be compiled with the same setting for this
 708    --  default. Units which specify an explicit local value for this setting
 709    --  are exempt from the consistency rule (this includes all internal units).
 710
 711    procedure Check_Consistent_Optimize_Alignment is
 712       OA_Setting : Character := ' ';
 713       --  Reset when we find a unit that depends on the default and does
 714       --  not have a local specification of the Optimize_Alignment setting.
 715
 716       OA_Unit : Unit_Id;
 717       --  Id of unit from which OA_Setting was set
 718
 719       C : Character;
 720
 721    begin
 722       for U in First_Unit_Entry .. Units.Last loop
 723          C := Units.Table (U).Optimize_Alignment;
 724
 725          if C /= 'L' then
 726             if OA_Setting = ' ' then
 727                OA_Setting := C;
 728                OA_Unit := U;
 729
 730             elsif OA_Setting = C then
 731                null;
 732
 733             else
 734                Error_Msg_Unit_1 := Units.Table (OA_Unit).Uname;
 735                Error_Msg_Unit_2 := Units.Table (U).Uname;
 736
 737                Consistency_Error_Msg
 738                  ("$ and $ compiled with different "
 739                   & "default Optimize_Alignment settings");
 740                return;
 741             end if;
 742          end if;
 743       end loop;
 744    end Check_Consistent_Optimize_Alignment;
 745
 746    -------------------------------------
 747    -- Check_Consistent_Queuing_Policy --
 748    -------------------------------------
 749
 750    --  The rule is that all files for which the queuing policy is
 751    --  significant must be compiled with the same setting.
 752
 753    procedure Check_Consistent_Queuing_Policy is
 754    begin
 755       --  First search for a unit specifying a policy and then
 756       --  check all remaining units against it.
 757
 758       Find_Policy : for A1 in ALIs.First .. ALIs.Last loop
 759          if ALIs.Table (A1).Queuing_Policy /= ' ' then
 760             Check_Policy : declare
 761                Policy : constant Character := ALIs.Table (A1).Queuing_Policy;
 762             begin
 763                for A2 in A1 + 1 .. ALIs.Last loop
 764                   if ALIs.Table (A2).Queuing_Policy /= ' '
 765                        and then
 766                      ALIs.Table (A2).Queuing_Policy /= Policy
 767                   then
 768                      Error_Msg_File_1 := ALIs.Table (A1).Sfile;
 769                      Error_Msg_File_2 := ALIs.Table (A2).Sfile;
 770
 771                      Consistency_Error_Msg
 772                        ("{ and { compiled with different queuing policies");
 773                      exit Find_Policy;
 774                   end if;
 775                end loop;
 776             end Check_Policy;
 777
 778             exit Find_Policy;
 779          end if;
 780       end loop Find_Policy;
 781    end Check_Consistent_Queuing_Policy;
 782
 783    -----------------------------------
 784    -- Check_Consistent_Restrictions --
 785    -----------------------------------
 786
 787    --  The rule is that if a restriction is specified in any unit, then all
 788    --  units must obey the restriction. The check applies only to restrictions
 789    --  which require partition wide consistency, and not to internal units.
 790
 791    procedure Check_Consistent_Restrictions is
 792       Restriction_File_Output : Boolean;
 793       --  Shows if we have output header messages for restriction violation
 794
 795       procedure Print_Restriction_File (R : All_Restrictions);
 796       --  Print header line for R if not printed yet
 797
 798       ----------------------------
 799       -- Print_Restriction_File --
 800       ----------------------------
 801
 802       procedure Print_Restriction_File (R : All_Restrictions) is
 803       begin
 804          if not Restriction_File_Output then
 805             Restriction_File_Output := True;
 806
 807             --  Find an ali file specifying the restriction
 808
 809             for A in ALIs.First .. ALIs.Last loop
 810                if ALIs.Table (A).Restrictions.Set (R)
 811                  and then (R in All_Boolean_Restrictions
 812                              or else ALIs.Table (A).Restrictions.Value (R) =
 813                                      Cumulative_Restrictions.Value (R))
 814                then
 815                   --  We have found that ALI file A specifies the restriction
 816                   --  that is being violated (the minimum value is specified
 817                   --  in the case of a parameter restriction).
 818
 819                   declare
 820                      M1 : constant String := "{ has restriction ";
 821                      S  : constant String := Restriction_Id'Image (R);
 822                      M2 : String (1 .. 2000); -- big enough!
 823                      P  : Integer;
 824
 825                   begin
 826                      Name_Buffer (1 .. S'Length) := S;
 827                      Name_Len := S'Length;
 828                      Set_Casing (Mixed_Case);
 829
 830                      M2 (M1'Range) := M1;
 831                      P := M1'Length + 1;
 832                      M2 (P .. P + S'Length - 1) := Name_Buffer (1 .. S'Length);
 833                      P := P + S'Length;
 834
 835                      if R in All_Parameter_Restrictions then
 836                         M2 (P .. P + 4) := " => #";
 837                         Error_Msg_Nat_1 :=
 838                           Int (Cumulative_Restrictions.Value (R));
 839                         P := P + 5;
 840                      end if;
 841
 842                      Error_Msg_File_1 := ALIs.Table (A).Sfile;
 843                      Consistency_Error_Msg (M2 (1 .. P - 1));
 844                      Consistency_Error_Msg
 845                        ("but the following files violate this restriction:");
 846                      return;
 847                   end;
 848                end if;
 849             end loop;
 850          end if;
 851       end Print_Restriction_File;
 852
 853    --  Start of processing for Check_Consistent_Restrictions
 854
 855    begin
 856       --  Loop through all restriction violations
 857
 858       for R in All_Restrictions loop
 859
 860          --  Check for violation of this restriction
 861
 862          if Cumulative_Restrictions.Set (R)
 863            and then Cumulative_Restrictions.Violated (R)
 864            and then (R in Partition_Boolean_Restrictions
 865                        or else (R in All_Parameter_Restrictions
 866                                    and then
 867                                      Cumulative_Restrictions.Count (R) >
 868                                      Cumulative_Restrictions.Value (R)))
 869          then
 870             Restriction_File_Output := False;
 871
 872             --  Loop through files looking for violators
 873
 874             for A2 in ALIs.First .. ALIs.Last loop
 875                declare
 876                   T : ALIs_Record renames ALIs.Table (A2);
 877
 878                begin
 879                   if T.Restrictions.Violated (R) then
 880
 881                      --  We exclude predefined files from the list of
 882                      --  violators. This should be rethought. It is not
 883                      --  clear that this is the right thing to do, that
 884                      --  is particularly the case for restricted runtimes.
 885
 886                      if not Is_Internal_File_Name (T.Sfile) then
 887
 888                         --  Case of Boolean restriction, just print file name
 889
 890                         if R in All_Boolean_Restrictions then
 891                            Print_Restriction_File (R);
 892                            Error_Msg_File_1 := T.Sfile;
 893                            Consistency_Error_Msg ("  {");
 894
 895                         --  Case of Parameter restriction where violation
 896                         --  count exceeds restriction value, print file
 897                         --  name and count, adding "at least" if the
 898                         --  exact count is not known.
 899
 900                         elsif R in Checked_Add_Parameter_Restrictions
 901                           or else T.Restrictions.Count (R) >
 902                           Cumulative_Restrictions.Value (R)
 903                         then
 904                            Print_Restriction_File (R);
 905                            Error_Msg_File_1 := T.Sfile;
 906                            Error_Msg_Nat_1 := Int (T.Restrictions.Count (R));
 907
 908                            if T.Restrictions.Unknown (R) then
 909                               Consistency_Error_Msg
 910                                 ("  { (count = at least #)");
 911                            else
 912                               Consistency_Error_Msg
 913                                 ("  { (count = #)");
 914                            end if;
 915                         end if;
 916                      end if;
 917                   end if;
 918                end;
 919             end loop;
 920          end if;
 921       end loop;
 922
 923       --  Now deal with No_Dependence indications. Note that we put the loop
 924       --  through entries in the no dependency table first, since this loop
 925       --  is most often empty (no such pragma Restrictions in use).
 926
 927       for ND in No_Deps.First .. No_Deps.Last loop
 928          declare
 929             ND_Unit : constant Name_Id :=
 930                         No_Deps.Table (ND).No_Dep_Unit;
 931
 932          begin
 933             for J in ALIs.First .. ALIs.Last loop
 934                declare
 935                   A : ALIs_Record renames ALIs.Table (J);
 936
 937                begin
 938                   for K in A.First_Unit .. A.Last_Unit loop
 939                      declare
 940                         U : Unit_Record renames Units.Table (K);
 941                      begin
 942                         for L in U.First_With .. U.Last_With loop
 943                            if Same_Unit
 944                              (Withs.Table (L).Uname, ND_Unit)
 945                            then
 946                               Error_Msg_File_1 := U.Sfile;
 947                               Error_Msg_Name_1 := ND_Unit;
 948                               Consistency_Error_Msg
 949                                 ("file { violates restriction " &
 950                                  "No_Dependence => %");
 951                            end if;
 952                         end loop;
 953                      end;
 954                   end loop;
 955                end;
 956             end loop;
 957          end;
 958       end loop;
 959    end Check_Consistent_Restrictions;
 960
 961    ------------------------------------------------------------
 962    -- Check_Consistent_Restriction_No_Default_Initialization --
 963    ------------------------------------------------------------
 964
 965    --  The Restriction (No_Default_Initialization) has special consistency
 966    --  rules. The rule is that no unit compiled without this restriction
 967    --  that violates the restriction can WITH a unit that is compiled with
 968    --  the restriction.
 969
 970    procedure Check_Consistent_Restriction_No_Default_Initialization is
 971    begin
 972       --  Nothing to do if no one set this restriction
 973
 974       if not Cumulative_Restrictions.Set (No_Default_Initialization) then
 975          return;
 976       end if;
 977
 978       --  Nothing to do if no one violates the restriction
 979
 980       if not Cumulative_Restrictions.Violated (No_Default_Initialization) then
 981          return;
 982       end if;
 983
 984       --  Otherwise we go into a full scan to find possible problems
 985
 986       for U in Units.First .. Units.Last loop
 987          declare
 988             UTE : Unit_Record renames Units.Table (U);
 989             ATE : ALIs_Record renames ALIs.Table (UTE.My_ALI);
 990
 991          begin
 992             if ATE.Restrictions.Violated (No_Default_Initialization) then
 993                for W in UTE.First_With .. UTE.Last_With loop
 994                   declare
 995                      AFN : constant File_Name_Type := Withs.Table (W).Afile;
 996
 997                   begin
 998                      --  The file name may not be present for withs of certain
 999                      --  generic run-time files. The test can be safely left
1000                      --  out in such cases anyway.
1001
1002                      if AFN /= No_File then
1003                         declare
1004                            WAI : constant ALI_Id :=
1005                                    ALI_Id (Get_Name_Table_Info (AFN));
1006                            WTE : ALIs_Record renames ALIs.Table (WAI);
1007
1008                         begin
1009                            if WTE.Restrictions.Set
1010                                (No_Default_Initialization)
1011                            then
1012                               Error_Msg_Unit_1 := UTE.Uname;
1013                               Consistency_Error_Msg
1014                                 ("unit $ compiled without restriction "
1015                                  & "No_Default_Initialization");
1016                               Error_Msg_Unit_1 := Withs.Table (W).Uname;
1017                               Consistency_Error_Msg
1018                                 ("withs unit $, compiled with restriction "
1019                                  & "No_Default_Initialization");
1020                            end if;
1021                         end;
1022                      end if;
1023                   end;
1024                end loop;
1025             end if;
1026          end;
1027       end loop;
1028    end Check_Consistent_Restriction_No_Default_Initialization;
1029
1030    ---------------------------------------------------
1031    -- Check_Consistent_Zero_Cost_Exception_Handling --
1032    ---------------------------------------------------
1033
1034    --  Check consistent zero cost exception handling. The rule is that
1035    --  all units must have the same exception handling mechanism.
1036
1037    procedure Check_Consistent_Zero_Cost_Exception_Handling is
1038    begin
1039       Check_Mechanism : for A1 in ALIs.First + 1 .. ALIs.Last loop
1040          if ALIs.Table (A1).Zero_Cost_Exceptions /=
1041             ALIs.Table (ALIs.First).Zero_Cost_Exceptions
1042          then
1043             Error_Msg_File_1 := ALIs.Table (A1).Sfile;
1044             Error_Msg_File_2 := ALIs.Table (ALIs.First).Sfile;
1045
1046             Consistency_Error_Msg ("{ and { compiled with different "
1047                                             & "exception handling mechanisms");
1048          end if;
1049       end loop Check_Mechanism;
1050    end Check_Consistent_Zero_Cost_Exception_Handling;
1051
1052    -------------------------------
1053    -- Check_Duplicated_Subunits --
1054    -------------------------------
1055
1056    procedure Check_Duplicated_Subunits is
1057    begin
1058       for J in Sdep.First .. Sdep.Last loop
1059          if Sdep.Table (J).Subunit_Name /= No_Name then
1060             Get_Decoded_Name_String (Sdep.Table (J).Subunit_Name);
1061             Name_Len := Name_Len + 2;
1062             Name_Buffer (Name_Len - 1) := '%';
1063
1064             --  See if there is a body or spec with the same name
1065
1066             for K in Boolean loop
1067                if K then
1068                   Name_Buffer (Name_Len) := 'b';
1069                else
1070                   Name_Buffer (Name_Len) := 's';
1071                end if;
1072
1073                declare
1074                   Unit : constant Unit_Name_Type := Name_Find;
1075                   Info : constant Int := Get_Name_Table_Info (Unit);
1076
1077                begin
1078                   if Info /= 0 then
1079                      Set_Standard_Error;
1080                      Write_Str ("error: subunit """);
1081                      Write_Name_Decoded (Sdep.Table (J).Subunit_Name);
1082                      Write_Str (""" in file """);
1083                      Write_Name_Decoded (Sdep.Table (J).Sfile);
1084                      Write_Char ('"');
1085                      Write_Eol;
1086                      Write_Str ("       has same name as unit """);
1087                      Write_Unit_Name (Units.Table (Unit_Id (Info)).Uname);
1088                      Write_Str (""" found in file """);
1089                      Write_Name_Decoded (Units.Table (Unit_Id (Info)).Sfile);
1090                      Write_Char ('"');
1091                      Write_Eol;
1092                      Write_Str ("       this is not allowed within a single "
1093                                 & "partition (RM 10.2(19))");
1094                      Write_Eol;
1095                      Osint.Exit_Program (Osint.E_Fatal);
1096                   end if;
1097                end;
1098             end loop;
1099          end if;
1100       end loop;
1101    end Check_Duplicated_Subunits;
1102
1103    --------------------
1104    -- Check_Versions --
1105    --------------------
1106
1107    procedure Check_Versions is
1108       VL : constant Natural := ALIs.Table (ALIs.First).Ver_Len;
1109
1110    begin
1111       for A in ALIs.First .. ALIs.Last loop
1112          if ALIs.Table (A).Ver_Len /= VL
1113            or else ALIs.Table (A).Ver          (1 .. VL) /=
1114                    ALIs.Table (ALIs.First).Ver (1 .. VL)
1115          then
1116             Error_Msg_File_1 := ALIs.Table (A).Sfile;
1117             Error_Msg_File_2 := ALIs.Table (ALIs.First).Sfile;
1118
1119             Consistency_Error_Msg
1120                ("{ and { compiled with different GNAT versions");
1121          end if;
1122       end loop;
1123    end Check_Versions;
1124
1125    ---------------------------
1126    -- Consistency_Error_Msg --
1127    ---------------------------
1128
1129    procedure Consistency_Error_Msg (Msg : String) is
1130    begin
1131       if Tolerate_Consistency_Errors then
1132
1133          --  If consistency errors are tolerated,
1134          --  output the message as a warning.
1135
1136          Error_Msg ('?' & Msg);
1137
1138       --  Otherwise the consistency error is a true error
1139
1140       else
1141          Error_Msg (Msg);
1142       end if;
1143    end Consistency_Error_Msg;
1144
1145    ---------------
1146    -- Same_Unit --
1147    ---------------
1148
1149    function Same_Unit (U1 : Unit_Name_Type; U2 : Name_Id) return Boolean is
1150    begin
1151       --  Note, the string U1 has a terminating %s or %b, U2 does not
1152
1153       if Length_Of_Name (U1) - 2 = Length_Of_Name (U2) then
1154          Get_Name_String (U1);
1155
1156          declare
1157             U1_Str : constant String := Name_Buffer (1 .. Name_Len - 2);
1158          begin
1159             Get_Name_String (U2);
1160             return U1_Str = Name_Buffer (1 .. Name_Len);
1161          end;
1162
1163       else
1164          return False;
1165       end if;
1166    end Same_Unit;
1167
1168 end Bcheck;