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