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