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-2021, 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 26with ALI; use ALI; 27with ALI.Util; use ALI.Util; 28with Binderr; use Binderr; 29with Butil; use Butil; 30with Casing; use Casing; 31with Fname; use Fname; 32with Gnatvsn; 33with Namet; use Namet; 34with Opt; use Opt; 35with Osint; 36with Output; use Output; 37with Rident; use Rident; 38with Types; use Types; 39 40package 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. See bodies for details of checks. 48 49 procedure Check_Consistent_Dispatching_Policy; 50 procedure Check_Consistent_Dynamic_Elaboration_Checking; 51 procedure Check_Consistent_Interrupt_States; 52 procedure Check_Consistent_Locking_Policy; 53 procedure Check_Consistent_No_Component_Reordering; 54 procedure Check_Consistent_Normalize_Scalars; 55 procedure Check_Consistent_Optimize_Alignment; 56 procedure Check_Consistent_Partition_Elaboration_Policy; 57 procedure Check_Consistent_Queuing_Policy; 58 procedure Check_Consistent_Restrictions; 59 procedure Check_Consistent_Restriction_No_Default_Initialization; 60 procedure Check_Consistent_SSO_Default; 61 procedure Check_Consistent_Exception_Handling; 62 63 procedure Consistency_Error_Msg (Msg : String); 64 -- Produce an error or a warning message, depending on whether an 65 -- inconsistent configuration is permitted or not. 66 67 function Same_Unit (U1 : Unit_Name_Type; U2 : Name_Id) return Boolean; 68 -- Used to compare two unit names for No_Dependence checks. U1 is in 69 -- standard unit name format, and U2 is in literal form with periods. 70 71 ------------------------------------- 72 -- Check_Configuration_Consistency -- 73 ------------------------------------- 74 75 procedure Check_Configuration_Consistency is 76 begin 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 No_Component_Reordering_Specified then 86 Check_Consistent_No_Component_Reordering; 87 end if; 88 89 if Partition_Elaboration_Policy_Specified /= ' ' then 90 Check_Consistent_Partition_Elaboration_Policy; 91 end if; 92 93 if SSO_Default_Specified then 94 Check_Consistent_SSO_Default; 95 end if; 96 97 if Zero_Cost_Exceptions_Specified 98 or else Frontend_Exceptions_Specified 99 then 100 Check_Consistent_Exception_Handling; 101 end if; 102 103 Check_Consistent_Normalize_Scalars; 104 Check_Consistent_Optimize_Alignment; 105 Check_Consistent_Dynamic_Elaboration_Checking; 106 Check_Consistent_Restrictions; 107 Check_Consistent_Restriction_No_Default_Initialization; 108 Check_Consistent_Interrupt_States; 109 Check_Consistent_Dispatching_Policy; 110 end Check_Configuration_Consistency; 111 112 ----------------------- 113 -- Check_Consistency -- 114 ----------------------- 115 116 procedure Check_Consistency is 117 Src : Source_Id; 118 -- Source file Id for this Sdep entry 119 120 ALI_Path_Id : File_Name_Type; 121 122 begin 123 -- First, we go through the source table to see if there are any cases 124 -- in which we should go after source files and compute checksums of 125 -- the source files. We need to do this for any file for which we have 126 -- mismatching time stamps and (so far) matching checksums. 127 128 for S in Source.First .. Source.Last loop 129 130 -- If all time stamps for a file match, then there is nothing to 131 -- do, since we will not be checking checksums in that case anyway 132 133 if Source.Table (S).All_Timestamps_Match then 134 null; 135 136 -- If we did not find the source file, then we can't compute its 137 -- checksum anyway. Note that when we have a time stamp mismatch, 138 -- we try to find the source file unconditionally (i.e. if 139 -- Check_Source_Files is False). 140 141 elsif not Source.Table (S).Source_Found then 142 null; 143 144 -- If we already have non-matching or missing checksums, then no 145 -- need to try going after source file, since we won't trust the 146 -- checksums in any case. 147 148 elsif not Source.Table (S).All_Checksums_Match then 149 null; 150 151 -- Now we have the case where we have time stamp mismatches, and 152 -- the source file is around, but so far all checksums match. This 153 -- is the case where we need to compute the checksum from the source 154 -- file, since otherwise we would ignore the time stamp mismatches, 155 -- and that is wrong if the checksum of the source does not agree 156 -- with the checksums in the ALI files. 157 158 elsif Check_Source_Files then 159 if not Checksums_Match 160 (Source.Table (S).Checksum, 161 Get_File_Checksum (Source.Table (S).Sfile)) 162 then 163 Source.Table (S).All_Checksums_Match := False; 164 end if; 165 end if; 166 end loop; 167 168 -- Loop through ALI files 169 170 ALIs_Loop : for A in ALIs.First .. ALIs.Last loop 171 172 -- Loop through Sdep entries in one ALI file 173 174 Sdep_Loop : for D in 175 ALIs.Table (A).First_Sdep .. ALIs.Table (A).Last_Sdep 176 loop 177 if Sdep.Table (D).Dummy_Entry then 178 goto Continue; 179 end if; 180 181 Src := Source_Id (Get_Name_Table_Int (Sdep.Table (D).Sfile)); 182 183 -- If the time stamps match, or all checksums match, then we 184 -- are OK, otherwise we have a definite error. 185 186 if Sdep.Table (D).Stamp /= Source.Table (Src).Stamp 187 and then not Source.Table (Src).All_Checksums_Match 188 then 189 Error_Msg_File_1 := ALIs.Table (A).Sfile; 190 Error_Msg_File_2 := Sdep.Table (D).Sfile; 191 192 -- Two styles of message, depending on whether or not 193 -- the updated file is the one that must be recompiled 194 195 if Error_Msg_File_1 = Error_Msg_File_2 then 196 if Tolerate_Consistency_Errors then 197 Error_Msg 198 ("?{ has been modified and should be recompiled"); 199 else 200 Error_Msg 201 ("{ has been modified and must be recompiled"); 202 end if; 203 204 else 205 ALI_Path_Id := 206 Osint.Full_Lib_File_Name (ALIs.Table (A).Afile); 207 208 if Osint.Is_Readonly_Library (ALI_Path_Id) then 209 if Tolerate_Consistency_Errors then 210 Error_Msg ("?{ should be recompiled"); 211 Error_Msg_File_1 := ALI_Path_Id; 212 Error_Msg ("?({ is obsolete and read-only)"); 213 else 214 Error_Msg ("{ must be compiled"); 215 Error_Msg_File_1 := ALI_Path_Id; 216 Error_Msg ("({ is obsolete and read-only)"); 217 end if; 218 219 elsif Tolerate_Consistency_Errors then 220 Error_Msg 221 ("?{ should be recompiled ({ has been modified)"); 222 223 else 224 Error_Msg ("{ must be recompiled ({ has been modified)"); 225 end if; 226 end if; 227 228 if (not Tolerate_Consistency_Errors) and Verbose_Mode then 229 Error_Msg_File_1 := Source.Table (Src).Stamp_File; 230 231 if Source.Table (Src).Source_Found then 232 Error_Msg_File_1 := 233 Osint.Full_Source_Name (Error_Msg_File_1); 234 else 235 Error_Msg_File_1 := 236 Osint.Full_Lib_File_Name (Error_Msg_File_1); 237 end if; 238 239 Error_Msg 240 ("time stamp from { " & String (Source.Table (Src).Stamp)); 241 242 Error_Msg_File_1 := Sdep.Table (D).Sfile; 243 Error_Msg 244 (" conflicts with { timestamp " & 245 String (Sdep.Table (D).Stamp)); 246 247 Error_Msg_File_1 := 248 Osint.Full_Lib_File_Name (ALIs.Table (A).Afile); 249 Error_Msg (" from {"); 250 end if; 251 252 -- Exit from the loop through Sdep entries once we find one 253 -- that does not match. 254 255 exit Sdep_Loop; 256 end if; 257 258 <<Continue>> 259 null; 260 end loop Sdep_Loop; 261 end loop ALIs_Loop; 262 end Check_Consistency; 263 264 ----------------------------------------- 265 -- Check_Consistent_Dispatching_Policy -- 266 ----------------------------------------- 267 268 -- The rule is that all files for which the dispatching policy is 269 -- significant must meet the following rules: 270 271 -- 1. All files for which a task dispatching policy is significant must 272 -- be compiled with the same setting. 273 274 -- 2. If a partition contains one or more Priority_Specific_Dispatching 275 -- pragmas it cannot contain a Task_Dispatching_Policy pragma. 276 277 -- 3. No overlap is allowed in the priority ranges specified in 278 -- Priority_Specific_Dispatching pragmas within the same partition. 279 280 -- 4. If a partition contains one or more Priority_Specific_Dispatching 281 -- pragmas then the Ceiling_Locking policy is the only one allowed for 282 -- the partition. 283 284 procedure Check_Consistent_Dispatching_Policy is 285 Max_Prio : Nat := 0; 286 -- Maximum priority value for which a Priority_Specific_Dispatching 287 -- pragma has been specified. 288 289 TDP_Pragma_Afile : ALI_Id := No_ALI_Id; 290 -- ALI file where a Task_Dispatching_Policy pragma appears 291 292 begin 293 -- Consistency checks in units specifying a Task_Dispatching_Policy 294 295 if Task_Dispatching_Policy_Specified /= ' ' then 296 Find_Policy : for A1 in ALIs.First .. ALIs.Last loop 297 if ALIs.Table (A1).Task_Dispatching_Policy /= ' ' then 298 299 -- Store the place where the first task dispatching pragma 300 -- appears. We may need this value for issuing consistency 301 -- errors if Priority_Specific_Dispatching pragmas are used. 302 303 TDP_Pragma_Afile := A1; 304 305 Check_Policy : declare 306 Policy : constant Character := 307 ALIs.Table (A1).Task_Dispatching_Policy; 308 309 begin 310 for A2 in A1 + 1 .. ALIs.Last loop 311 if ALIs.Table (A2).Task_Dispatching_Policy /= ' ' 312 and then 313 ALIs.Table (A2).Task_Dispatching_Policy /= Policy 314 then 315 Error_Msg_File_1 := ALIs.Table (A1).Sfile; 316 Error_Msg_File_2 := ALIs.Table (A2).Sfile; 317 318 Consistency_Error_Msg 319 ("{ and { compiled with different task" & 320 " dispatching policies"); 321 exit Find_Policy; 322 end if; 323 end loop; 324 end Check_Policy; 325 326 exit Find_Policy; 327 end if; 328 end loop Find_Policy; 329 end if; 330 331 -- If no Priority_Specific_Dispatching entries, nothing else to do 332 333 if Specific_Dispatching.Last >= Specific_Dispatching.First then 334 335 -- Find out the maximum priority value for which one of the 336 -- Priority_Specific_Dispatching pragmas applies. 337 338 Max_Prio := 0; 339 for J in Specific_Dispatching.First .. Specific_Dispatching.Last loop 340 if Specific_Dispatching.Table (J).Last_Priority > Max_Prio then 341 Max_Prio := Specific_Dispatching.Table (J).Last_Priority; 342 end if; 343 end loop; 344 345 -- Now establish tables to be used for consistency checking 346 347 declare 348 -- The following record type is used to record locations of the 349 -- Priority_Specific_Dispatching pragmas applying to the Priority. 350 351 type Specific_Dispatching_Entry is record 352 Dispatching_Policy : Character := ' '; 353 -- First character (upper case) of corresponding policy name 354 355 Afile : ALI_Id := No_ALI_Id; 356 -- ALI file that generated Priority Specific Dispatching 357 -- entry for consistency message. 358 359 Loc : Nat := 0; 360 -- Line numbers from Priority_Specific_Dispatching pragma 361 end record; 362 363 PSD_Table : array (0 .. Max_Prio) of Specific_Dispatching_Entry := 364 (others => Specific_Dispatching_Entry' 365 (Dispatching_Policy => ' ', 366 Afile => No_ALI_Id, 367 Loc => 0)); 368 -- Array containing an entry per priority containing the location 369 -- where there is a Priority_Specific_Dispatching pragma that 370 -- applies to the priority. 371 372 begin 373 for F in ALIs.First .. ALIs.Last loop 374 for K in ALIs.Table (F).First_Specific_Dispatching .. 375 ALIs.Table (F).Last_Specific_Dispatching 376 loop 377 declare 378 DTK : Specific_Dispatching_Record 379 renames Specific_Dispatching.Table (K); 380 begin 381 -- Check whether pragma Task_Dispatching_Policy and 382 -- pragma Priority_Specific_Dispatching are used in the 383 -- same partition. 384 385 if Task_Dispatching_Policy_Specified /= ' ' then 386 Error_Msg_File_1 := ALIs.Table (F).Sfile; 387 Error_Msg_File_2 := 388 ALIs.Table (TDP_Pragma_Afile).Sfile; 389 390 Error_Msg_Nat_1 := DTK.PSD_Pragma_Line; 391 392 Consistency_Error_Msg 393 ("Priority_Specific_Dispatching at {:#" & 394 " incompatible with Task_Dispatching_Policy at {"); 395 end if; 396 397 -- Ceiling_Locking must also be specified for a partition 398 -- with at least one Priority_Specific_Dispatching 399 -- pragma. 400 401 if Locking_Policy_Specified /= ' ' 402 and then Locking_Policy_Specified /= 'C' 403 then 404 for A in ALIs.First .. ALIs.Last loop 405 if ALIs.Table (A).Locking_Policy /= ' ' 406 and then ALIs.Table (A).Locking_Policy /= 'C' 407 then 408 Error_Msg_File_1 := ALIs.Table (F).Sfile; 409 Error_Msg_File_2 := ALIs.Table (A).Sfile; 410 411 Error_Msg_Nat_1 := DTK.PSD_Pragma_Line; 412 413 Consistency_Error_Msg 414 ("Priority_Specific_Dispatching at {:#" & 415 " incompatible with Locking_Policy at {"); 416 end if; 417 end loop; 418 end if; 419 420 -- Check overlapping priority ranges 421 422 Find_Overlapping : for Prio in 423 DTK.First_Priority .. DTK.Last_Priority 424 loop 425 if PSD_Table (Prio).Afile = No_ALI_Id then 426 PSD_Table (Prio) := 427 (Dispatching_Policy => DTK.Dispatching_Policy, 428 Afile => F, Loc => DTK.PSD_Pragma_Line); 429 430 elsif PSD_Table (Prio).Dispatching_Policy /= 431 DTK.Dispatching_Policy 432 433 then 434 Error_Msg_File_1 := 435 ALIs.Table (PSD_Table (Prio).Afile).Sfile; 436 Error_Msg_File_2 := ALIs.Table (F).Sfile; 437 Error_Msg_Nat_1 := PSD_Table (Prio).Loc; 438 Error_Msg_Nat_2 := DTK.PSD_Pragma_Line; 439 440 Consistency_Error_Msg 441 ("overlapping priority ranges at {:# and {:#"); 442 443 exit Find_Overlapping; 444 end if; 445 end loop Find_Overlapping; 446 end; 447 end loop; 448 end loop; 449 end; 450 end if; 451 end Check_Consistent_Dispatching_Policy; 452 453 --------------------------------------------------- 454 -- Check_Consistent_Dynamic_Elaboration_Checking -- 455 --------------------------------------------------- 456 457 -- The rule here is that if a unit has dynamic elaboration checks, 458 -- then any unit it withs must meet one of the following criteria: 459 460 -- 1. There is a pragma Elaborate_All for the with'ed unit 461 -- 2. The with'ed unit was compiled with dynamic elaboration checks 462 -- 3. The with'ed unit has pragma Preelaborate or Pure 463 -- 4. It is an internal GNAT unit (including children of GNAT) 464 -- 5. It is an interface of a Stand-Alone Library 465 466 procedure Check_Consistent_Dynamic_Elaboration_Checking is 467 begin 468 if Dynamic_Elaboration_Checks_Specified then 469 for U in First_Unit_Entry .. Units.Last loop 470 declare 471 UR : Unit_Record renames Units.Table (U); 472 473 begin 474 if UR.Dynamic_Elab then 475 for W in UR.First_With .. UR.Last_With loop 476 declare 477 WR : With_Record renames Withs.Table (W); 478 479 begin 480 if Get_Name_Table_Int (WR.Uname) /= 0 then 481 declare 482 WU : Unit_Record renames 483 Units.Table 484 (Unit_Id 485 (Get_Name_Table_Int (WR.Uname))); 486 487 begin 488 -- Case 1. Elaborate_All for with'ed unit 489 490 if WR.Elaborate_All then 491 null; 492 493 -- Case 2. With'ed unit has dynamic elab checks 494 495 elsif WU.Dynamic_Elab then 496 null; 497 498 -- Case 3. With'ed unit is Preelaborate or Pure 499 500 elsif WU.Preelab or else WU.Pure then 501 null; 502 503 -- Case 4. With'ed unit is internal file 504 505 elsif Is_Internal_File_Name (WU.Sfile) then 506 null; 507 508 -- Case 5. With'ed unit is a SAL interface 509 510 elsif WU.SAL_Interface then 511 null; 512 513 -- Issue warning, not one of the safe cases 514 515 else 516 Error_Msg_File_1 := UR.Sfile; 517 Error_Msg 518 ("?{ has dynamic elaboration checks " & 519 "and with's"); 520 521 Error_Msg_File_1 := WU.Sfile; 522 Error_Msg 523 ("? { which has static elaboration " & 524 "checks"); 525 526 Warnings_Detected := Warnings_Detected + 1; 527 end if; 528 end; 529 end if; 530 end; 531 end loop; 532 end if; 533 end; 534 end loop; 535 end if; 536 end Check_Consistent_Dynamic_Elaboration_Checking; 537 538 --------------------------------------- 539 -- Check_Consistent_Interrupt_States -- 540 --------------------------------------- 541 542 -- The rule is that if the state of a given interrupt is specified 543 -- in more than one unit, it must be specified with a consistent state. 544 545 procedure Check_Consistent_Interrupt_States is 546 Max_Intrup : Nat; 547 548 begin 549 -- If no Interrupt_State entries, nothing to do 550 551 if Interrupt_States.Last < Interrupt_States.First then 552 return; 553 end if; 554 555 -- First find out the maximum interrupt value 556 557 Max_Intrup := 0; 558 for J in Interrupt_States.First .. Interrupt_States.Last loop 559 if Interrupt_States.Table (J).Interrupt_Id > Max_Intrup then 560 Max_Intrup := Interrupt_States.Table (J).Interrupt_Id; 561 end if; 562 end loop; 563 564 -- Now establish tables to be used for consistency checking 565 566 declare 567 Istate : array (0 .. Max_Intrup) of Character := (others => 'n'); 568 -- Interrupt state entries, 'u'/'s'/'r' or 'n' to indicate an 569 -- entry that has not been set. 570 571 Afile : array (0 .. Max_Intrup) of ALI_Id; 572 -- ALI file that generated Istate entry for consistency message 573 574 Loc : array (0 .. Max_Intrup) of Nat; 575 -- Line numbers from IS pragma generating Istate entry 576 577 Inum : Nat; 578 -- Interrupt number from entry being tested 579 580 Stat : Character; 581 -- Interrupt state from entry being tested 582 583 Lnum : Nat; 584 -- Line number from entry being tested 585 586 begin 587 for F in ALIs.First .. ALIs.Last loop 588 for K in ALIs.Table (F).First_Interrupt_State .. 589 ALIs.Table (F).Last_Interrupt_State 590 loop 591 Inum := Interrupt_States.Table (K).Interrupt_Id; 592 Stat := Interrupt_States.Table (K).Interrupt_State; 593 Lnum := Interrupt_States.Table (K).IS_Pragma_Line; 594 595 if Istate (Inum) = 'n' then 596 Istate (Inum) := Stat; 597 Afile (Inum) := F; 598 Loc (Inum) := Lnum; 599 600 elsif Istate (Inum) /= Stat then 601 Error_Msg_File_1 := ALIs.Table (Afile (Inum)).Sfile; 602 Error_Msg_File_2 := ALIs.Table (F).Sfile; 603 Error_Msg_Nat_1 := Loc (Inum); 604 Error_Msg_Nat_2 := Lnum; 605 606 Consistency_Error_Msg 607 ("inconsistent interrupt states at {:# and {:#"); 608 end if; 609 end loop; 610 end loop; 611 end; 612 end Check_Consistent_Interrupt_States; 613 614 ------------------------------------- 615 -- Check_Consistent_Locking_Policy -- 616 ------------------------------------- 617 618 -- The rule is that all files for which the locking policy is 619 -- significant must be compiled with the same setting. 620 621 procedure Check_Consistent_Locking_Policy is 622 begin 623 -- First search for a unit specifying a policy and then 624 -- check all remaining units against it. 625 626 Find_Policy : for A1 in ALIs.First .. ALIs.Last loop 627 if ALIs.Table (A1).Locking_Policy /= ' ' then 628 Check_Policy : declare 629 Policy : constant Character := ALIs.Table (A1).Locking_Policy; 630 631 begin 632 for A2 in A1 + 1 .. ALIs.Last loop 633 if ALIs.Table (A2).Locking_Policy /= ' ' 634 and then 635 ALIs.Table (A2).Locking_Policy /= Policy 636 then 637 Error_Msg_File_1 := ALIs.Table (A1).Sfile; 638 Error_Msg_File_2 := ALIs.Table (A2).Sfile; 639 640 Consistency_Error_Msg 641 ("{ and { compiled with different locking policies"); 642 exit Find_Policy; 643 end if; 644 end loop; 645 end Check_Policy; 646 647 exit Find_Policy; 648 end if; 649 end loop Find_Policy; 650 end Check_Consistent_Locking_Policy; 651 652 ---------------------------------------------- 653 -- Check_Consistent_No_Component_Reordering -- 654 ---------------------------------------------- 655 656 -- This routine checks for a consistent No_Component_Reordering setting. 657 -- Note that internal units are excluded from this check, since we don't 658 -- in any case allow the pragma to affect types in internal units, and 659 -- there is thus no requirement to recompile the run-time with the setting. 660 661 procedure Check_Consistent_No_Component_Reordering is 662 OK : Boolean := True; 663 begin 664 -- Check that all entries have No_Component_Reordering set 665 666 for A1 in ALIs.First .. ALIs.Last loop 667 if not Is_Internal_File_Name (ALIs.Table (A1).Sfile) 668 and then not ALIs.Table (A1).No_Component_Reordering 669 then 670 OK := False; 671 exit; 672 end if; 673 end loop; 674 675 -- All do, return 676 677 if OK then 678 return; 679 end if; 680 681 -- Here we have an inconsistency 682 683 Consistency_Error_Msg 684 ("some but not all files compiled with No_Component_Reordering"); 685 686 Write_Eol; 687 Write_Str ("files compiled with No_Component_Reordering"); 688 Write_Eol; 689 690 for A1 in ALIs.First .. ALIs.Last loop 691 if not Is_Internal_File_Name (ALIs.Table (A1).Sfile) 692 and then ALIs.Table (A1).No_Component_Reordering 693 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 No_Component_Reordering"); 702 Write_Eol; 703 704 for A1 in ALIs.First .. ALIs.Last loop 705 if not Is_Internal_File_Name (ALIs.Table (A1).Sfile) 706 and then not ALIs.Table (A1).No_Component_Reordering 707 then 708 Write_Str (" "); 709 Write_Name (ALIs.Table (A1).Sfile); 710 Write_Eol; 711 end if; 712 end loop; 713 end Check_Consistent_No_Component_Reordering; 714 715 ---------------------------------------- 716 -- Check_Consistent_Normalize_Scalars -- 717 ---------------------------------------- 718 719 -- The rule is that if any unit is compiled with Normalize_Scalars, 720 -- then all other units in the partition must also be compiled with 721 -- Normalize_Scalars in effect. 722 723 -- There is some issue as to whether this consistency check is desirable, 724 -- it is certainly required at the moment by the RM. We should keep a watch 725 -- on the ARG and HRG deliberations here. GNAT no longer depends on this 726 -- consistency (it used to do so, but that is no longer the case, since 727 -- pragma Initialize_Scalars pragma does not require consistency.) 728 729 procedure Check_Consistent_Normalize_Scalars is 730 begin 731 if Normalize_Scalars_Specified and No_Normalize_Scalars_Specified then 732 Consistency_Error_Msg 733 ("some but not all files compiled with Normalize_Scalars"); 734 735 Write_Eol; 736 Write_Str ("files compiled with Normalize_Scalars"); 737 Write_Eol; 738 739 for A1 in ALIs.First .. ALIs.Last loop 740 if ALIs.Table (A1).Normalize_Scalars then 741 Write_Str (" "); 742 Write_Name (ALIs.Table (A1).Sfile); 743 Write_Eol; 744 end if; 745 end loop; 746 747 Write_Eol; 748 Write_Str ("files compiled without Normalize_Scalars"); 749 Write_Eol; 750 751 for A1 in ALIs.First .. ALIs.Last loop 752 if not ALIs.Table (A1).Normalize_Scalars then 753 Write_Str (" "); 754 Write_Name (ALIs.Table (A1).Sfile); 755 Write_Eol; 756 end if; 757 end loop; 758 end if; 759 end Check_Consistent_Normalize_Scalars; 760 761 ----------------------------------------- 762 -- Check_Consistent_Optimize_Alignment -- 763 ----------------------------------------- 764 765 -- The rule is that all units which depend on the global default setting 766 -- of Optimize_Alignment must be compiled with the same setting for this 767 -- default. Units which specify an explicit local value for this setting 768 -- are exempt from the consistency rule (this includes all internal units). 769 770 procedure Check_Consistent_Optimize_Alignment is 771 OA_Setting : Character := ' '; 772 -- Reset when we find a unit that depends on the default and does 773 -- not have a local specification of the Optimize_Alignment setting. 774 775 OA_Unit : Unit_Id := No_Unit_Id; 776 -- Id of unit from which OA_Setting was set 777 778 C : Character; 779 780 begin 781 for U in First_Unit_Entry .. Units.Last loop 782 C := Units.Table (U).Optimize_Alignment; 783 784 if C /= 'L' then 785 if OA_Setting = ' ' then 786 OA_Setting := C; 787 OA_Unit := U; 788 789 elsif OA_Setting = C then 790 null; 791 792 else 793 pragma Assert (Present (OA_Unit)); 794 Error_Msg_Unit_1 := Units.Table (OA_Unit).Uname; 795 Error_Msg_Unit_2 := Units.Table (U).Uname; 796 797 Consistency_Error_Msg 798 ("$ and $ compiled with different " 799 & "default Optimize_Alignment settings"); 800 return; 801 end if; 802 end if; 803 end loop; 804 end Check_Consistent_Optimize_Alignment; 805 806 --------------------------------------------------- 807 -- Check_Consistent_Partition_Elaboration_Policy -- 808 --------------------------------------------------- 809 810 -- The rule is that all files for which the partition elaboration policy is 811 -- significant must be compiled with the same setting. 812 813 procedure Check_Consistent_Partition_Elaboration_Policy is 814 begin 815 -- First search for a unit specifying a policy and then 816 -- check all remaining units against it. 817 818 Find_Policy : for A1 in ALIs.First .. ALIs.Last loop 819 if ALIs.Table (A1).Partition_Elaboration_Policy /= ' ' then 820 Check_Policy : declare 821 Policy : constant Character := 822 ALIs.Table (A1).Partition_Elaboration_Policy; 823 824 begin 825 for A2 in A1 + 1 .. ALIs.Last loop 826 if ALIs.Table (A2).Partition_Elaboration_Policy /= ' ' 827 and then 828 ALIs.Table (A2).Partition_Elaboration_Policy /= Policy 829 then 830 Error_Msg_File_1 := ALIs.Table (A1).Sfile; 831 Error_Msg_File_2 := ALIs.Table (A2).Sfile; 832 833 Consistency_Error_Msg 834 ("{ and { compiled with different partition " 835 & "elaboration policies"); 836 exit Find_Policy; 837 end if; 838 end loop; 839 end Check_Policy; 840 841 -- A No_Task_Hierarchy restriction must be specified for the 842 -- Sequential policy (RM H.6(6/2)). 843 844 if Partition_Elaboration_Policy_Specified = 'S' 845 and then not Cumulative_Restrictions.Set (No_Task_Hierarchy) 846 then 847 Error_Msg_File_1 := ALIs.Table (A1).Sfile; 848 Error_Msg 849 ("{ has sequential partition elaboration policy, but no"); 850 Error_Msg 851 ("pragma Restrictions (No_Task_Hierarchy) was specified"); 852 end if; 853 854 exit Find_Policy; 855 end if; 856 end loop Find_Policy; 857 end Check_Consistent_Partition_Elaboration_Policy; 858 859 ------------------------------------- 860 -- Check_Consistent_Queuing_Policy -- 861 ------------------------------------- 862 863 -- The rule is that all files for which the queuing policy is 864 -- significant must be compiled with the same setting. 865 866 procedure Check_Consistent_Queuing_Policy is 867 begin 868 -- First search for a unit specifying a policy and then 869 -- check all remaining units against it. 870 871 Find_Policy : for A1 in ALIs.First .. ALIs.Last loop 872 if ALIs.Table (A1).Queuing_Policy /= ' ' then 873 Check_Policy : declare 874 Policy : constant Character := ALIs.Table (A1).Queuing_Policy; 875 begin 876 for A2 in A1 + 1 .. ALIs.Last loop 877 if ALIs.Table (A2).Queuing_Policy /= ' ' 878 and then 879 ALIs.Table (A2).Queuing_Policy /= Policy 880 then 881 Error_Msg_File_1 := ALIs.Table (A1).Sfile; 882 Error_Msg_File_2 := ALIs.Table (A2).Sfile; 883 884 Consistency_Error_Msg 885 ("{ and { compiled with different queuing policies"); 886 exit Find_Policy; 887 end if; 888 end loop; 889 end Check_Policy; 890 891 exit Find_Policy; 892 end if; 893 end loop Find_Policy; 894 end Check_Consistent_Queuing_Policy; 895 896 ----------------------------------- 897 -- Check_Consistent_Restrictions -- 898 ----------------------------------- 899 900 -- The rule is that if a restriction is specified in any unit, then all 901 -- units must obey the restriction. The check applies only to restrictions 902 -- which require partition wide consistency, and not to internal units. 903 904 procedure Check_Consistent_Restrictions is 905 Restriction_File_Output : Boolean; 906 -- Shows if we have output header messages for restriction violation 907 908 procedure Print_Restriction_File (R : All_Restrictions); 909 -- Print header line for R if not printed yet 910 911 ---------------------------- 912 -- Print_Restriction_File -- 913 ---------------------------- 914 915 procedure Print_Restriction_File (R : All_Restrictions) is 916 begin 917 if not Restriction_File_Output then 918 Restriction_File_Output := True; 919 920 -- Find an ali file specifying the restriction 921 922 for A in ALIs.First .. ALIs.Last loop 923 if ALIs.Table (A).Restrictions.Set (R) 924 and then (R in All_Boolean_Restrictions 925 or else ALIs.Table (A).Restrictions.Value (R) = 926 Cumulative_Restrictions.Value (R)) 927 then 928 -- We have found that ALI file A specifies the restriction 929 -- that is being violated (the minimum value is specified 930 -- in the case of a parameter restriction). 931 932 declare 933 M1 : constant String := "{ has restriction "; 934 S : constant String := Restriction_Id'Image (R); 935 M2 : String (1 .. 2000); -- big enough 936 P : Integer; 937 938 begin 939 Name_Buffer (1 .. S'Length) := S; 940 Name_Len := S'Length; 941 Set_Casing (Mixed_Case); 942 943 M2 (M1'Range) := M1; 944 P := M1'Length + 1; 945 M2 (P .. P + S'Length - 1) := Name_Buffer (1 .. S'Length); 946 P := P + S'Length; 947 948 if R in All_Parameter_Restrictions then 949 M2 (P .. P + 4) := " => #"; 950 Error_Msg_Nat_1 := 951 Int (Cumulative_Restrictions.Value (R)); 952 P := P + 5; 953 end if; 954 955 Error_Msg_File_1 := ALIs.Table (A).Sfile; 956 Consistency_Error_Msg (M2 (1 .. P - 1)); 957 Consistency_Error_Msg 958 ("but the following files violate this restriction:"); 959 return; 960 end; 961 end if; 962 end loop; 963 end if; 964 end Print_Restriction_File; 965 966 -- Start of processing for Check_Consistent_Restrictions 967 968 begin 969 -- We used to have a special test here: 970 971 -- A special test, if we have a main program, then if it has an 972 -- allocator in the body, this is considered to be a violation of 973 -- the restriction No_Allocators_After_Elaboration. We just mark 974 -- this restriction and then the normal circuit will flag it. 975 976 -- But we don't do that any more, because in the final version of Ada 977 -- 2012, it is statically illegal to have an allocator in a library- 978 -- level subprogram, so we don't need this bind time test any more. 979 -- If we have a main program with parameters (which GNAT allows), then 980 -- allocators in that will be caught by the run-time check. 981 982 -- Loop through all restriction violations 983 984 for R in All_Restrictions loop 985 986 -- Check for violation of this restriction 987 988 if Cumulative_Restrictions.Set (R) 989 and then Cumulative_Restrictions.Violated (R) 990 and then (R in Partition_Boolean_Restrictions 991 or else (R in All_Parameter_Restrictions 992 and then 993 Cumulative_Restrictions.Count (R) > 994 Cumulative_Restrictions.Value (R))) 995 then 996 Restriction_File_Output := False; 997 998 -- Loop through files looking for violators 999 1000 for A2 in ALIs.First .. ALIs.Last loop 1001 declare 1002 T : ALIs_Record renames ALIs.Table (A2); 1003 1004 begin 1005 if T.Restrictions.Violated (R) then 1006 1007 -- We exclude predefined files from the list of 1008 -- violators. This should be rethought. It is not 1009 -- clear that this is the right thing to do, that 1010 -- is particularly the case for restricted runtimes. 1011 1012 if not Is_Internal_File_Name (T.Sfile) then 1013 1014 -- Case of Boolean restriction, just print file name 1015 1016 if R in All_Boolean_Restrictions then 1017 Print_Restriction_File (R); 1018 Error_Msg_File_1 := T.Sfile; 1019 Consistency_Error_Msg (" {"); 1020 1021 -- Case of Parameter restriction where violation 1022 -- count exceeds restriction value, print file 1023 -- name and count, adding "at least" if the 1024 -- exact count is not known. 1025 1026 elsif R in Checked_Add_Parameter_Restrictions 1027 or else T.Restrictions.Count (R) > 1028 Cumulative_Restrictions.Value (R) 1029 then 1030 Print_Restriction_File (R); 1031 Error_Msg_File_1 := T.Sfile; 1032 Error_Msg_Nat_1 := Int (T.Restrictions.Count (R)); 1033 1034 if T.Restrictions.Unknown (R) then 1035 Consistency_Error_Msg 1036 (" { (count = at least #)"); 1037 else 1038 Consistency_Error_Msg 1039 (" { (count = #)"); 1040 end if; 1041 end if; 1042 end if; 1043 end if; 1044 end; 1045 end loop; 1046 end if; 1047 end loop; 1048 1049 -- Now deal with No_Dependence indications. Note that we put the loop 1050 -- through entries in the no dependency table first, since this loop 1051 -- is most often empty (no such pragma Restrictions in use). 1052 1053 for ND in No_Deps.First .. No_Deps.Last loop 1054 declare 1055 ND_Unit : constant Name_Id := No_Deps.Table (ND).No_Dep_Unit; 1056 begin 1057 for J in ALIs.First .. ALIs.Last loop 1058 declare 1059 A : ALIs_Record renames ALIs.Table (J); 1060 begin 1061 for K in A.First_Unit .. A.Last_Unit loop 1062 declare 1063 U : Unit_Record renames Units.Table (K); 1064 begin 1065 -- Exclude runtime units from this check since the 1066 -- user does not care how a runtime unit is 1067 -- implemented. 1068 1069 if not Is_Internal_File_Name (U.Sfile) then 1070 for L in U.First_With .. U.Last_With loop 1071 if Same_Unit (Withs.Table (L).Uname, ND_Unit) 1072 then 1073 Error_Msg_File_1 := U.Sfile; 1074 Error_Msg_Name_1 := ND_Unit; 1075 Consistency_Error_Msg 1076 ("file { violates restriction " & 1077 "No_Dependence => %"); 1078 end if; 1079 end loop; 1080 end if; 1081 end; 1082 end loop; 1083 end; 1084 end loop; 1085 end; 1086 end loop; 1087 end Check_Consistent_Restrictions; 1088 1089 ------------------------------------------------------------ 1090 -- Check_Consistent_Restriction_No_Default_Initialization -- 1091 ------------------------------------------------------------ 1092 1093 -- The Restriction (No_Default_Initialization) has special consistency 1094 -- rules. The rule is that no unit compiled without this restriction 1095 -- that violates the restriction can WITH a unit that is compiled with 1096 -- the restriction. 1097 1098 procedure Check_Consistent_Restriction_No_Default_Initialization is 1099 begin 1100 -- Nothing to do if no one set this restriction 1101 1102 if not Cumulative_Restrictions.Set (No_Default_Initialization) then 1103 return; 1104 end if; 1105 1106 -- Nothing to do if no one violates the restriction 1107 1108 if not Cumulative_Restrictions.Violated (No_Default_Initialization) then 1109 return; 1110 end if; 1111 1112 -- Otherwise we go into a full scan to find possible problems 1113 1114 for U in Units.First .. Units.Last loop 1115 declare 1116 UTE : Unit_Record renames Units.Table (U); 1117 ATE : ALIs_Record renames ALIs.Table (UTE.My_ALI); 1118 1119 begin 1120 if ATE.Restrictions.Violated (No_Default_Initialization) then 1121 for W in UTE.First_With .. UTE.Last_With loop 1122 declare 1123 AFN : constant File_Name_Type := Withs.Table (W).Afile; 1124 1125 begin 1126 -- The file name may not be present for withs of certain 1127 -- generic run-time files. The test can be safely left 1128 -- out in such cases anyway. 1129 1130 if AFN /= No_File then 1131 declare 1132 WAI : constant ALI_Id := 1133 ALI_Id (Get_Name_Table_Int (AFN)); 1134 WTE : ALIs_Record renames ALIs.Table (WAI); 1135 1136 begin 1137 if WTE.Restrictions.Set 1138 (No_Default_Initialization) 1139 then 1140 Error_Msg_Unit_1 := UTE.Uname; 1141 Consistency_Error_Msg 1142 ("unit $ compiled without restriction " 1143 & "No_Default_Initialization"); 1144 Error_Msg_Unit_1 := Withs.Table (W).Uname; 1145 Consistency_Error_Msg 1146 ("withs unit $, compiled with restriction " 1147 & "No_Default_Initialization"); 1148 end if; 1149 end; 1150 end if; 1151 end; 1152 end loop; 1153 end if; 1154 end; 1155 end loop; 1156 end Check_Consistent_Restriction_No_Default_Initialization; 1157 1158 ---------------------------------- 1159 -- Check_Consistent_SSO_Default -- 1160 ---------------------------------- 1161 1162 -- This routine checks for a consistent SSO default setting. Note that 1163 -- internal units are excluded from this check, since we don't in any 1164 -- case allow the pragma to affect types in internal units, and there 1165 -- is thus no requirement to recompile the run-time with the default set. 1166 1167 procedure Check_Consistent_SSO_Default is 1168 Default : Character; 1169 1170 begin 1171 Default := ALIs.Table (ALIs.First).SSO_Default; 1172 1173 -- The default must be set from a non-internal unit 1174 1175 pragma Assert 1176 (not Is_Internal_File_Name (ALIs.Table (ALIs.First).Sfile)); 1177 1178 -- Check all entries match the default above from the first entry 1179 1180 for A1 in ALIs.First + 1 .. ALIs.Last loop 1181 if not Is_Internal_File_Name (ALIs.Table (A1).Sfile) 1182 and then ALIs.Table (A1).SSO_Default /= Default 1183 then 1184 Default := '?'; 1185 exit; 1186 end if; 1187 end loop; 1188 1189 -- All match, return 1190 1191 if Default /= '?' then 1192 return; 1193 end if; 1194 1195 -- Here we have a mismatch 1196 1197 Consistency_Error_Msg 1198 ("files not compiled with same Default_Scalar_Storage_Order"); 1199 1200 Write_Eol; 1201 Write_Str ("files compiled with High_Order_First"); 1202 Write_Eol; 1203 1204 for A1 in ALIs.First .. ALIs.Last loop 1205 if ALIs.Table (A1).SSO_Default = 'H' then 1206 Write_Str (" "); 1207 Write_Name (ALIs.Table (A1).Sfile); 1208 Write_Eol; 1209 end if; 1210 end loop; 1211 1212 Write_Eol; 1213 Write_Str ("files compiled with Low_Order_First"); 1214 Write_Eol; 1215 1216 for A1 in ALIs.First .. ALIs.Last loop 1217 if ALIs.Table (A1).SSO_Default = 'L' then 1218 Write_Str (" "); 1219 Write_Name (ALIs.Table (A1).Sfile); 1220 Write_Eol; 1221 end if; 1222 end loop; 1223 1224 Write_Eol; 1225 Write_Str ("files compiled with no Default_Scalar_Storage_Order"); 1226 Write_Eol; 1227 1228 for A1 in ALIs.First .. ALIs.Last loop 1229 if not Is_Internal_File_Name (ALIs.Table (A1).Sfile) 1230 and then ALIs.Table (A1).SSO_Default = ' ' 1231 then 1232 Write_Str (" "); 1233 Write_Name (ALIs.Table (A1).Sfile); 1234 Write_Eol; 1235 end if; 1236 end loop; 1237 end Check_Consistent_SSO_Default; 1238 1239 ----------------------------------------- 1240 -- Check_Consistent_Exception_Handling -- 1241 ----------------------------------------- 1242 1243 -- All units must have the same exception handling mechanism. 1244 1245 procedure Check_Consistent_Exception_Handling is 1246 begin 1247 Check_Mechanism : for A1 in ALIs.First + 1 .. ALIs.Last loop 1248 if (ALIs.Table (A1).Zero_Cost_Exceptions /= 1249 ALIs.Table (ALIs.First).Zero_Cost_Exceptions) 1250 or else 1251 (ALIs.Table (A1).Frontend_Exceptions /= 1252 ALIs.Table (ALIs.First).Frontend_Exceptions) 1253 then 1254 Error_Msg_File_1 := ALIs.Table (A1).Sfile; 1255 Error_Msg_File_2 := ALIs.Table (ALIs.First).Sfile; 1256 1257 Consistency_Error_Msg 1258 ("{ and { compiled with different exception handling " 1259 & "mechanisms"); 1260 end if; 1261 end loop Check_Mechanism; 1262 end Check_Consistent_Exception_Handling; 1263 1264 ------------------------------- 1265 -- Check_Duplicated_Subunits -- 1266 ------------------------------- 1267 1268 procedure Check_Duplicated_Subunits is 1269 begin 1270 for J in Sdep.First .. Sdep.Last loop 1271 if Sdep.Table (J).Subunit_Name /= No_Name then 1272 Get_Decoded_Name_String (Sdep.Table (J).Subunit_Name); 1273 Name_Len := Name_Len + 2; 1274 Name_Buffer (Name_Len - 1) := '%'; 1275 1276 -- See if there is a body or spec with the same name 1277 1278 for K in Boolean loop 1279 if K then 1280 Name_Buffer (Name_Len) := 'b'; 1281 else 1282 Name_Buffer (Name_Len) := 's'; 1283 end if; 1284 1285 declare 1286 Unit : constant Unit_Name_Type := Name_Find; 1287 Info : constant Int := Get_Name_Table_Int (Unit); 1288 1289 begin 1290 if Info /= 0 then 1291 Set_Standard_Error; 1292 Write_Str ("error: subunit """); 1293 Write_Name_Decoded (Sdep.Table (J).Subunit_Name); 1294 Write_Str (""" in file """); 1295 Write_Name_Decoded (Sdep.Table (J).Sfile); 1296 Write_Char ('"'); 1297 Write_Eol; 1298 Write_Str (" has same name as unit """); 1299 Write_Unit_Name (Units.Table (Unit_Id (Info)).Uname); 1300 Write_Str (""" found in file """); 1301 Write_Name_Decoded (Units.Table (Unit_Id (Info)).Sfile); 1302 Write_Char ('"'); 1303 Write_Eol; 1304 Write_Str (" this is not allowed within a single " 1305 & "partition (RM 10.2(19))"); 1306 Write_Eol; 1307 Osint.Exit_Program (Osint.E_Fatal); 1308 end if; 1309 end; 1310 end loop; 1311 end if; 1312 end loop; 1313 end Check_Duplicated_Subunits; 1314 1315 -------------------- 1316 -- Check_Versions -- 1317 -------------------- 1318 1319 procedure Check_Versions is 1320 VL : constant Natural := ALIs.Table (ALIs.First).Ver_Len; 1321 1322 begin 1323 for A in ALIs.First .. ALIs.Last loop 1324 if ALIs.Table (A).Ver_Len /= VL 1325 or else ALIs.Table (A).Ver (1 .. VL) /= 1326 ALIs.Table (ALIs.First).Ver (1 .. VL) 1327 then 1328 -- Version mismatch found; generate error message. 1329 1330 declare 1331 use Gnatvsn; 1332 1333 Prefix : constant String := 1334 Verbose_Library_Version 1335 (1 .. Verbose_Library_Version'Length 1336 - Library_Version'Length); 1337 1338 type ALI_Version is record 1339 Primary, Secondary : Int range -1 .. Int'Last; 1340 end record; 1341 1342 No_Version : constant ALI_Version := (-1, -1); 1343 1344 function Remove_Prefix (S : String) return String is 1345 (S (S'First + Prefix'Length .. S'Last)); 1346 1347 function Extract_Version (S : String) return ALI_Version; 1348 -- Attempts to extract and return a pair of nonnegative library 1349 -- version numbers from the given string; if unsuccessful, 1350 -- then returns No_Version. 1351 1352 --------------------- 1353 -- Extract_Version -- 1354 --------------------- 1355 1356 function Extract_Version (S : String) return ALI_Version is 1357 pragma Assert (S'First = 1); 1358 1359 function Int_Value (Img : String) return Int; 1360 -- Using Int'Value leads to complications in 1361 -- building the binder, so DIY. 1362 1363 --------------- 1364 -- Int_Value -- 1365 --------------- 1366 1367 function Int_Value (Img : String) return Int is 1368 Result : Nat := 0; 1369 begin 1370 if Img'Length in 1 .. 9 1371 and then (for all C of Img => C in '0' .. '9') 1372 then 1373 for C of Img loop 1374 Result := (10 * Result) + 1375 (Character'Pos (C) - Character'Pos ('0')); 1376 end loop; 1377 return Result; 1378 else 1379 return -1; 1380 end if; 1381 end Int_Value; 1382 1383 begin 1384 if S'Length > Prefix'Length 1385 and then S (1 .. Prefix'Length) = Prefix 1386 then 1387 declare 1388 Suffix : constant String := Remove_Prefix (S); 1389 Dot_Found : Boolean := False; 1390 Primary, Secondary : Int; 1391 begin 1392 for Dot_Index in Suffix'Range loop 1393 if Suffix (Dot_Index) = '.' then 1394 Dot_Found := True; 1395 Primary := 1396 Int_Value (Suffix (Suffix'First 1397 .. Dot_Index - 1)); 1398 Secondary := 1399 Int_Value (Suffix (Dot_Index + 1 1400 .. Suffix'Last)); 1401 exit; 1402 end if; 1403 end loop; 1404 1405 if not Dot_Found then 1406 Primary := Int_Value (Suffix); 1407 Secondary := 0; 1408 end if; 1409 1410 if (Primary /= -1) and (Secondary /= -1) then 1411 return (Primary => Primary, 1412 Secondary => Secondary); 1413 end if; 1414 end; 1415 end if; 1416 return No_Version; 1417 end Extract_Version; 1418 1419 -- Local constants 1420 1421 V1_Text : constant String := 1422 ALIs.Table (A).Ver (1 .. ALIs.Table (A).Ver_Len); 1423 V2_Text : constant String := 1424 ALIs.Table (ALIs.First).Ver (1 .. VL); 1425 V1 : constant ALI_Version := Extract_Version (V1_Text); 1426 V2 : constant ALI_Version := Extract_Version (V2_Text); 1427 1428 Include_Version_Numbers_In_Message : constant Boolean := 1429 (V1 /= V2) and (V1 /= No_Version) and (V2 /= No_Version); 1430 begin 1431 Error_Msg_File_1 := ALIs.Table (A).Sfile; 1432 Error_Msg_File_2 := ALIs.Table (ALIs.First).Sfile; 1433 1434 if Include_Version_Numbers_In_Message then 1435 if V1.Secondary = V2.Secondary then 1436 -- Excluding equal secondary values from error 1437 -- message text matters for generating reproducible 1438 -- regression test outputs. 1439 1440 Error_Msg_Nat_1 := V1.Primary; 1441 Error_Msg_Nat_2 := V2.Primary; 1442 Consistency_Error_Msg 1443 ("{ and { compiled with different GNAT versions" 1444 & ", v# and v#"); 1445 else 1446 Consistency_Error_Msg 1447 ("{ and { compiled with different GNAT versions" 1448 & ", v" 1449 & Remove_Prefix (V1_Text) 1450 & " and v" 1451 & Remove_Prefix (V2_Text)); 1452 end if; 1453 else 1454 Consistency_Error_Msg 1455 ("{ and { compiled with different GNAT versions"); 1456 end if; 1457 end; 1458 end if; 1459 end loop; 1460 end Check_Versions; 1461 1462 --------------------------- 1463 -- Consistency_Error_Msg -- 1464 --------------------------- 1465 1466 procedure Consistency_Error_Msg (Msg : String) is 1467 begin 1468 if Tolerate_Consistency_Errors then 1469 1470 -- If consistency errors are tolerated, 1471 -- output the message as a warning. 1472 1473 Error_Msg ('?' & Msg); 1474 1475 -- Otherwise the consistency error is a true error 1476 1477 else 1478 Error_Msg (Msg); 1479 end if; 1480 end Consistency_Error_Msg; 1481 1482 --------------- 1483 -- Same_Unit -- 1484 --------------- 1485 1486 function Same_Unit (U1 : Unit_Name_Type; U2 : Name_Id) return Boolean is 1487 begin 1488 -- Note, the string U1 has a terminating %s or %b, U2 does not 1489 1490 if Length_Of_Name (U1) - 2 = Length_Of_Name (U2) then 1491 Get_Name_String (U1); 1492 1493 declare 1494 U1_Str : constant String := Name_Buffer (1 .. Name_Len - 2); 1495 begin 1496 Get_Name_String (U2); 1497 return U1_Str = Name_Buffer (1 .. Name_Len); 1498 end; 1499 1500 else 1501 return False; 1502 end if; 1503 end Same_Unit; 1504 1505end Bcheck; 1506