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-2019, 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; 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 Error_Msg_Unit_1 := Units.Table (OA_Unit).Uname; 793 Error_Msg_Unit_2 := Units.Table (U).Uname; 794 795 Consistency_Error_Msg 796 ("$ and $ compiled with different " 797 & "default Optimize_Alignment settings"); 798 return; 799 end if; 800 end if; 801 end loop; 802 end Check_Consistent_Optimize_Alignment; 803 804 --------------------------------------------------- 805 -- Check_Consistent_Partition_Elaboration_Policy -- 806 --------------------------------------------------- 807 808 -- The rule is that all files for which the partition elaboration policy is 809 -- significant must be compiled with the same setting. 810 811 procedure Check_Consistent_Partition_Elaboration_Policy is 812 begin 813 -- First search for a unit specifying a policy and then 814 -- check all remaining units against it. 815 816 Find_Policy : for A1 in ALIs.First .. ALIs.Last loop 817 if ALIs.Table (A1).Partition_Elaboration_Policy /= ' ' then 818 Check_Policy : declare 819 Policy : constant Character := 820 ALIs.Table (A1).Partition_Elaboration_Policy; 821 822 begin 823 for A2 in A1 + 1 .. ALIs.Last loop 824 if ALIs.Table (A2).Partition_Elaboration_Policy /= ' ' 825 and then 826 ALIs.Table (A2).Partition_Elaboration_Policy /= Policy 827 then 828 Error_Msg_File_1 := ALIs.Table (A1).Sfile; 829 Error_Msg_File_2 := ALIs.Table (A2).Sfile; 830 831 Consistency_Error_Msg 832 ("{ and { compiled with different partition " 833 & "elaboration policies"); 834 exit Find_Policy; 835 end if; 836 end loop; 837 end Check_Policy; 838 839 -- A No_Task_Hierarchy restriction must be specified for the 840 -- Sequential policy (RM H.6(6/2)). 841 842 if Partition_Elaboration_Policy_Specified = 'S' 843 and then not Cumulative_Restrictions.Set (No_Task_Hierarchy) 844 then 845 Error_Msg_File_1 := ALIs.Table (A1).Sfile; 846 Error_Msg 847 ("{ has sequential partition elaboration policy, but no"); 848 Error_Msg 849 ("pragma Restrictions (No_Task_Hierarchy) was specified"); 850 end if; 851 852 exit Find_Policy; 853 end if; 854 end loop Find_Policy; 855 end Check_Consistent_Partition_Elaboration_Policy; 856 857 ------------------------------------- 858 -- Check_Consistent_Queuing_Policy -- 859 ------------------------------------- 860 861 -- The rule is that all files for which the queuing policy is 862 -- significant must be compiled with the same setting. 863 864 procedure Check_Consistent_Queuing_Policy is 865 begin 866 -- First search for a unit specifying a policy and then 867 -- check all remaining units against it. 868 869 Find_Policy : for A1 in ALIs.First .. ALIs.Last loop 870 if ALIs.Table (A1).Queuing_Policy /= ' ' then 871 Check_Policy : declare 872 Policy : constant Character := ALIs.Table (A1).Queuing_Policy; 873 begin 874 for A2 in A1 + 1 .. ALIs.Last loop 875 if ALIs.Table (A2).Queuing_Policy /= ' ' 876 and then 877 ALIs.Table (A2).Queuing_Policy /= Policy 878 then 879 Error_Msg_File_1 := ALIs.Table (A1).Sfile; 880 Error_Msg_File_2 := ALIs.Table (A2).Sfile; 881 882 Consistency_Error_Msg 883 ("{ and { compiled with different queuing policies"); 884 exit Find_Policy; 885 end if; 886 end loop; 887 end Check_Policy; 888 889 exit Find_Policy; 890 end if; 891 end loop Find_Policy; 892 end Check_Consistent_Queuing_Policy; 893 894 ----------------------------------- 895 -- Check_Consistent_Restrictions -- 896 ----------------------------------- 897 898 -- The rule is that if a restriction is specified in any unit, then all 899 -- units must obey the restriction. The check applies only to restrictions 900 -- which require partition wide consistency, and not to internal units. 901 902 procedure Check_Consistent_Restrictions is 903 Restriction_File_Output : Boolean; 904 -- Shows if we have output header messages for restriction violation 905 906 procedure Print_Restriction_File (R : All_Restrictions); 907 -- Print header line for R if not printed yet 908 909 ---------------------------- 910 -- Print_Restriction_File -- 911 ---------------------------- 912 913 procedure Print_Restriction_File (R : All_Restrictions) is 914 begin 915 if not Restriction_File_Output then 916 Restriction_File_Output := True; 917 918 -- Find an ali file specifying the restriction 919 920 for A in ALIs.First .. ALIs.Last loop 921 if ALIs.Table (A).Restrictions.Set (R) 922 and then (R in All_Boolean_Restrictions 923 or else ALIs.Table (A).Restrictions.Value (R) = 924 Cumulative_Restrictions.Value (R)) 925 then 926 -- We have found that ALI file A specifies the restriction 927 -- that is being violated (the minimum value is specified 928 -- in the case of a parameter restriction). 929 930 declare 931 M1 : constant String := "{ has restriction "; 932 S : constant String := Restriction_Id'Image (R); 933 M2 : String (1 .. 2000); -- big enough 934 P : Integer; 935 936 begin 937 Name_Buffer (1 .. S'Length) := S; 938 Name_Len := S'Length; 939 Set_Casing (Mixed_Case); 940 941 M2 (M1'Range) := M1; 942 P := M1'Length + 1; 943 M2 (P .. P + S'Length - 1) := Name_Buffer (1 .. S'Length); 944 P := P + S'Length; 945 946 if R in All_Parameter_Restrictions then 947 M2 (P .. P + 4) := " => #"; 948 Error_Msg_Nat_1 := 949 Int (Cumulative_Restrictions.Value (R)); 950 P := P + 5; 951 end if; 952 953 Error_Msg_File_1 := ALIs.Table (A).Sfile; 954 Consistency_Error_Msg (M2 (1 .. P - 1)); 955 Consistency_Error_Msg 956 ("but the following files violate this restriction:"); 957 return; 958 end; 959 end if; 960 end loop; 961 end if; 962 end Print_Restriction_File; 963 964 -- Start of processing for Check_Consistent_Restrictions 965 966 begin 967 -- We used to have a special test here: 968 969 -- A special test, if we have a main program, then if it has an 970 -- allocator in the body, this is considered to be a violation of 971 -- the restriction No_Allocators_After_Elaboration. We just mark 972 -- this restriction and then the normal circuit will flag it. 973 974 -- But we don't do that any more, because in the final version of Ada 975 -- 2012, it is statically illegal to have an allocator in a library- 976 -- level subprogram, so we don't need this bind time test any more. 977 -- If we have a main program with parameters (which GNAT allows), then 978 -- allocators in that will be caught by the run-time check. 979 980 -- Loop through all restriction violations 981 982 for R in All_Restrictions loop 983 984 -- Check for violation of this restriction 985 986 if Cumulative_Restrictions.Set (R) 987 and then Cumulative_Restrictions.Violated (R) 988 and then (R in Partition_Boolean_Restrictions 989 or else (R in All_Parameter_Restrictions 990 and then 991 Cumulative_Restrictions.Count (R) > 992 Cumulative_Restrictions.Value (R))) 993 then 994 Restriction_File_Output := False; 995 996 -- Loop through files looking for violators 997 998 for A2 in ALIs.First .. ALIs.Last loop 999 declare 1000 T : ALIs_Record renames ALIs.Table (A2); 1001 1002 begin 1003 if T.Restrictions.Violated (R) then 1004 1005 -- We exclude predefined files from the list of 1006 -- violators. This should be rethought. It is not 1007 -- clear that this is the right thing to do, that 1008 -- is particularly the case for restricted runtimes. 1009 1010 if not Is_Internal_File_Name (T.Sfile) then 1011 1012 -- Case of Boolean restriction, just print file name 1013 1014 if R in All_Boolean_Restrictions then 1015 Print_Restriction_File (R); 1016 Error_Msg_File_1 := T.Sfile; 1017 Consistency_Error_Msg (" {"); 1018 1019 -- Case of Parameter restriction where violation 1020 -- count exceeds restriction value, print file 1021 -- name and count, adding "at least" if the 1022 -- exact count is not known. 1023 1024 elsif R in Checked_Add_Parameter_Restrictions 1025 or else T.Restrictions.Count (R) > 1026 Cumulative_Restrictions.Value (R) 1027 then 1028 Print_Restriction_File (R); 1029 Error_Msg_File_1 := T.Sfile; 1030 Error_Msg_Nat_1 := Int (T.Restrictions.Count (R)); 1031 1032 if T.Restrictions.Unknown (R) then 1033 Consistency_Error_Msg 1034 (" { (count = at least #)"); 1035 else 1036 Consistency_Error_Msg 1037 (" { (count = #)"); 1038 end if; 1039 end if; 1040 end if; 1041 end if; 1042 end; 1043 end loop; 1044 end if; 1045 end loop; 1046 1047 -- Now deal with No_Dependence indications. Note that we put the loop 1048 -- through entries in the no dependency table first, since this loop 1049 -- is most often empty (no such pragma Restrictions in use). 1050 1051 for ND in No_Deps.First .. No_Deps.Last loop 1052 declare 1053 ND_Unit : constant Name_Id := No_Deps.Table (ND).No_Dep_Unit; 1054 begin 1055 for J in ALIs.First .. ALIs.Last loop 1056 declare 1057 A : ALIs_Record renames ALIs.Table (J); 1058 begin 1059 for K in A.First_Unit .. A.Last_Unit loop 1060 declare 1061 U : Unit_Record renames Units.Table (K); 1062 begin 1063 -- Exclude runtime units from this check since the 1064 -- user does not care how a runtime unit is 1065 -- implemented. 1066 1067 if not Is_Internal_File_Name (U.Sfile) then 1068 for L in U.First_With .. U.Last_With loop 1069 if Same_Unit (Withs.Table (L).Uname, ND_Unit) 1070 then 1071 Error_Msg_File_1 := U.Sfile; 1072 Error_Msg_Name_1 := ND_Unit; 1073 Consistency_Error_Msg 1074 ("file { violates restriction " & 1075 "No_Dependence => %"); 1076 end if; 1077 end loop; 1078 end if; 1079 end; 1080 end loop; 1081 end; 1082 end loop; 1083 end; 1084 end loop; 1085 end Check_Consistent_Restrictions; 1086 1087 ------------------------------------------------------------ 1088 -- Check_Consistent_Restriction_No_Default_Initialization -- 1089 ------------------------------------------------------------ 1090 1091 -- The Restriction (No_Default_Initialization) has special consistency 1092 -- rules. The rule is that no unit compiled without this restriction 1093 -- that violates the restriction can WITH a unit that is compiled with 1094 -- the restriction. 1095 1096 procedure Check_Consistent_Restriction_No_Default_Initialization is 1097 begin 1098 -- Nothing to do if no one set this restriction 1099 1100 if not Cumulative_Restrictions.Set (No_Default_Initialization) then 1101 return; 1102 end if; 1103 1104 -- Nothing to do if no one violates the restriction 1105 1106 if not Cumulative_Restrictions.Violated (No_Default_Initialization) then 1107 return; 1108 end if; 1109 1110 -- Otherwise we go into a full scan to find possible problems 1111 1112 for U in Units.First .. Units.Last loop 1113 declare 1114 UTE : Unit_Record renames Units.Table (U); 1115 ATE : ALIs_Record renames ALIs.Table (UTE.My_ALI); 1116 1117 begin 1118 if ATE.Restrictions.Violated (No_Default_Initialization) then 1119 for W in UTE.First_With .. UTE.Last_With loop 1120 declare 1121 AFN : constant File_Name_Type := Withs.Table (W).Afile; 1122 1123 begin 1124 -- The file name may not be present for withs of certain 1125 -- generic run-time files. The test can be safely left 1126 -- out in such cases anyway. 1127 1128 if AFN /= No_File then 1129 declare 1130 WAI : constant ALI_Id := 1131 ALI_Id (Get_Name_Table_Int (AFN)); 1132 WTE : ALIs_Record renames ALIs.Table (WAI); 1133 1134 begin 1135 if WTE.Restrictions.Set 1136 (No_Default_Initialization) 1137 then 1138 Error_Msg_Unit_1 := UTE.Uname; 1139 Consistency_Error_Msg 1140 ("unit $ compiled without restriction " 1141 & "No_Default_Initialization"); 1142 Error_Msg_Unit_1 := Withs.Table (W).Uname; 1143 Consistency_Error_Msg 1144 ("withs unit $, compiled with restriction " 1145 & "No_Default_Initialization"); 1146 end if; 1147 end; 1148 end if; 1149 end; 1150 end loop; 1151 end if; 1152 end; 1153 end loop; 1154 end Check_Consistent_Restriction_No_Default_Initialization; 1155 1156 ---------------------------------- 1157 -- Check_Consistent_SSO_Default -- 1158 ---------------------------------- 1159 1160 -- This routine checks for a consistent SSO default setting. Note that 1161 -- internal units are excluded from this check, since we don't in any 1162 -- case allow the pragma to affect types in internal units, and there 1163 -- is thus no requirement to recompile the run-time with the default set. 1164 1165 procedure Check_Consistent_SSO_Default is 1166 Default : Character; 1167 1168 begin 1169 Default := ALIs.Table (ALIs.First).SSO_Default; 1170 1171 -- The default must be set from a non-internal unit 1172 1173 pragma Assert 1174 (not Is_Internal_File_Name (ALIs.Table (ALIs.First).Sfile)); 1175 1176 -- Check all entries match the default above from the first entry 1177 1178 for A1 in ALIs.First + 1 .. ALIs.Last loop 1179 if not Is_Internal_File_Name (ALIs.Table (A1).Sfile) 1180 and then ALIs.Table (A1).SSO_Default /= Default 1181 then 1182 Default := '?'; 1183 exit; 1184 end if; 1185 end loop; 1186 1187 -- All match, return 1188 1189 if Default /= '?' then 1190 return; 1191 end if; 1192 1193 -- Here we have a mismatch 1194 1195 Consistency_Error_Msg 1196 ("files not compiled with same Default_Scalar_Storage_Order"); 1197 1198 Write_Eol; 1199 Write_Str ("files compiled with High_Order_First"); 1200 Write_Eol; 1201 1202 for A1 in ALIs.First .. ALIs.Last loop 1203 if ALIs.Table (A1).SSO_Default = 'H' then 1204 Write_Str (" "); 1205 Write_Name (ALIs.Table (A1).Sfile); 1206 Write_Eol; 1207 end if; 1208 end loop; 1209 1210 Write_Eol; 1211 Write_Str ("files compiled with Low_Order_First"); 1212 Write_Eol; 1213 1214 for A1 in ALIs.First .. ALIs.Last loop 1215 if ALIs.Table (A1).SSO_Default = 'L' then 1216 Write_Str (" "); 1217 Write_Name (ALIs.Table (A1).Sfile); 1218 Write_Eol; 1219 end if; 1220 end loop; 1221 1222 Write_Eol; 1223 Write_Str ("files compiled with no Default_Scalar_Storage_Order"); 1224 Write_Eol; 1225 1226 for A1 in ALIs.First .. ALIs.Last loop 1227 if not Is_Internal_File_Name (ALIs.Table (A1).Sfile) 1228 and then ALIs.Table (A1).SSO_Default = ' ' 1229 then 1230 Write_Str (" "); 1231 Write_Name (ALIs.Table (A1).Sfile); 1232 Write_Eol; 1233 end if; 1234 end loop; 1235 end Check_Consistent_SSO_Default; 1236 1237 ----------------------------------------- 1238 -- Check_Consistent_Exception_Handling -- 1239 ----------------------------------------- 1240 1241 -- All units must have the same exception handling mechanism. 1242 1243 procedure Check_Consistent_Exception_Handling is 1244 begin 1245 Check_Mechanism : for A1 in ALIs.First + 1 .. ALIs.Last loop 1246 if (ALIs.Table (A1).Zero_Cost_Exceptions /= 1247 ALIs.Table (ALIs.First).Zero_Cost_Exceptions) 1248 or else 1249 (ALIs.Table (A1).Frontend_Exceptions /= 1250 ALIs.Table (ALIs.First).Frontend_Exceptions) 1251 then 1252 Error_Msg_File_1 := ALIs.Table (A1).Sfile; 1253 Error_Msg_File_2 := ALIs.Table (ALIs.First).Sfile; 1254 1255 Consistency_Error_Msg 1256 ("{ and { compiled with different exception handling " 1257 & "mechanisms"); 1258 end if; 1259 end loop Check_Mechanism; 1260 end Check_Consistent_Exception_Handling; 1261 1262 ------------------------------- 1263 -- Check_Duplicated_Subunits -- 1264 ------------------------------- 1265 1266 procedure Check_Duplicated_Subunits is 1267 begin 1268 for J in Sdep.First .. Sdep.Last loop 1269 if Sdep.Table (J).Subunit_Name /= No_Name then 1270 Get_Decoded_Name_String (Sdep.Table (J).Subunit_Name); 1271 Name_Len := Name_Len + 2; 1272 Name_Buffer (Name_Len - 1) := '%'; 1273 1274 -- See if there is a body or spec with the same name 1275 1276 for K in Boolean loop 1277 if K then 1278 Name_Buffer (Name_Len) := 'b'; 1279 else 1280 Name_Buffer (Name_Len) := 's'; 1281 end if; 1282 1283 declare 1284 Unit : constant Unit_Name_Type := Name_Find; 1285 Info : constant Int := Get_Name_Table_Int (Unit); 1286 1287 begin 1288 if Info /= 0 then 1289 Set_Standard_Error; 1290 Write_Str ("error: subunit """); 1291 Write_Name_Decoded (Sdep.Table (J).Subunit_Name); 1292 Write_Str (""" in file """); 1293 Write_Name_Decoded (Sdep.Table (J).Sfile); 1294 Write_Char ('"'); 1295 Write_Eol; 1296 Write_Str (" has same name as unit """); 1297 Write_Unit_Name (Units.Table (Unit_Id (Info)).Uname); 1298 Write_Str (""" found in file """); 1299 Write_Name_Decoded (Units.Table (Unit_Id (Info)).Sfile); 1300 Write_Char ('"'); 1301 Write_Eol; 1302 Write_Str (" this is not allowed within a single " 1303 & "partition (RM 10.2(19))"); 1304 Write_Eol; 1305 Osint.Exit_Program (Osint.E_Fatal); 1306 end if; 1307 end; 1308 end loop; 1309 end if; 1310 end loop; 1311 end Check_Duplicated_Subunits; 1312 1313 -------------------- 1314 -- Check_Versions -- 1315 -------------------- 1316 1317 procedure Check_Versions is 1318 VL : constant Natural := ALIs.Table (ALIs.First).Ver_Len; 1319 1320 begin 1321 for A in ALIs.First .. ALIs.Last loop 1322 if ALIs.Table (A).Ver_Len /= VL 1323 or else ALIs.Table (A).Ver (1 .. VL) /= 1324 ALIs.Table (ALIs.First).Ver (1 .. VL) 1325 then 1326 Error_Msg_File_1 := ALIs.Table (A).Sfile; 1327 Error_Msg_File_2 := ALIs.Table (ALIs.First).Sfile; 1328 1329 Consistency_Error_Msg 1330 ("{ and { compiled with different GNAT versions"); 1331 end if; 1332 end loop; 1333 end Check_Versions; 1334 1335 --------------------------- 1336 -- Consistency_Error_Msg -- 1337 --------------------------- 1338 1339 procedure Consistency_Error_Msg (Msg : String) is 1340 begin 1341 if Tolerate_Consistency_Errors then 1342 1343 -- If consistency errors are tolerated, 1344 -- output the message as a warning. 1345 1346 Error_Msg ('?' & Msg); 1347 1348 -- Otherwise the consistency error is a true error 1349 1350 else 1351 Error_Msg (Msg); 1352 end if; 1353 end Consistency_Error_Msg; 1354 1355 --------------- 1356 -- Same_Unit -- 1357 --------------- 1358 1359 function Same_Unit (U1 : Unit_Name_Type; U2 : Name_Id) return Boolean is 1360 begin 1361 -- Note, the string U1 has a terminating %s or %b, U2 does not 1362 1363 if Length_Of_Name (U1) - 2 = Length_Of_Name (U2) then 1364 Get_Name_String (U1); 1365 1366 declare 1367 U1_Str : constant String := Name_Buffer (1 .. Name_Len - 2); 1368 begin 1369 Get_Name_String (U2); 1370 return U1_Str = Name_Buffer (1 .. Name_Len); 1371 end; 1372 1373 else 1374 return False; 1375 end if; 1376 end Same_Unit; 1377 1378end Bcheck; 1379