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