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