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