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