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-2013, 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 := 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_Info (WR.Uname) /= 0 then 472 declare 473 WU : Unit_Record renames 474 Units.Table 475 (Unit_Id 476 (Get_Name_Table_Info (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_Floating_Point_Format -- 526 -------------------------------------------- 527 528 -- The rule is that all files must be compiled with the same setting 529 -- for the floating-point format. 530 531 procedure Check_Consistent_Floating_Point_Format is 532 begin 533 -- First search for a unit specifying a floating-point format and then 534 -- check all remaining units against it. 535 536 Find_Format : for A1 in ALIs.First .. ALIs.Last loop 537 if ALIs.Table (A1).Float_Format /= ' ' then 538 Check_Format : declare 539 Format : constant Character := ALIs.Table (A1).Float_Format; 540 begin 541 for A2 in A1 + 1 .. ALIs.Last loop 542 if ALIs.Table (A2).Float_Format /= Format then 543 Error_Msg_File_1 := ALIs.Table (A1).Sfile; 544 Error_Msg_File_2 := ALIs.Table (A2).Sfile; 545 546 Consistency_Error_Msg 547 ("{ and { compiled with different " & 548 "floating-point representations"); 549 exit Find_Format; 550 end if; 551 end loop; 552 end Check_Format; 553 554 exit Find_Format; 555 end if; 556 end loop Find_Format; 557 end Check_Consistent_Floating_Point_Format; 558 559 --------------------------------------- 560 -- Check_Consistent_Interrupt_States -- 561 --------------------------------------- 562 563 -- The rule is that if the state of a given interrupt is specified 564 -- in more than one unit, it must be specified with a consistent state. 565 566 procedure Check_Consistent_Interrupt_States is 567 Max_Intrup : Nat; 568 569 begin 570 -- If no Interrupt_State entries, nothing to do 571 572 if Interrupt_States.Last < Interrupt_States.First then 573 return; 574 end if; 575 576 -- First find out the maximum interrupt value 577 578 Max_Intrup := 0; 579 for J in Interrupt_States.First .. Interrupt_States.Last loop 580 if Interrupt_States.Table (J).Interrupt_Id > Max_Intrup then 581 Max_Intrup := Interrupt_States.Table (J).Interrupt_Id; 582 end if; 583 end loop; 584 585 -- Now establish tables to be used for consistency checking 586 587 declare 588 Istate : array (0 .. Max_Intrup) of Character := (others => 'n'); 589 -- Interrupt state entries, 'u'/'s'/'r' or 'n' to indicate an 590 -- entry that has not been set. 591 592 Afile : array (0 .. Max_Intrup) of ALI_Id; 593 -- ALI file that generated Istate entry for consistency message 594 595 Loc : array (0 .. Max_Intrup) of Nat; 596 -- Line numbers from IS pragma generating Istate entry 597 598 Inum : Nat; 599 -- Interrupt number from entry being tested 600 601 Stat : Character; 602 -- Interrupt state from entry being tested 603 604 Lnum : Nat; 605 -- Line number from entry being tested 606 607 begin 608 for F in ALIs.First .. ALIs.Last loop 609 for K in ALIs.Table (F).First_Interrupt_State .. 610 ALIs.Table (F).Last_Interrupt_State 611 loop 612 Inum := Interrupt_States.Table (K).Interrupt_Id; 613 Stat := Interrupt_States.Table (K).Interrupt_State; 614 Lnum := Interrupt_States.Table (K).IS_Pragma_Line; 615 616 if Istate (Inum) = 'n' then 617 Istate (Inum) := Stat; 618 Afile (Inum) := F; 619 Loc (Inum) := Lnum; 620 621 elsif Istate (Inum) /= Stat then 622 Error_Msg_File_1 := ALIs.Table (Afile (Inum)).Sfile; 623 Error_Msg_File_2 := ALIs.Table (F).Sfile; 624 Error_Msg_Nat_1 := Loc (Inum); 625 Error_Msg_Nat_2 := Lnum; 626 627 Consistency_Error_Msg 628 ("inconsistent interrupt states at {:# and {:#"); 629 end if; 630 end loop; 631 end loop; 632 end; 633 end Check_Consistent_Interrupt_States; 634 635 ------------------------------------- 636 -- Check_Consistent_Locking_Policy -- 637 ------------------------------------- 638 639 -- The rule is that all files for which the locking policy is 640 -- significant must be compiled with the same setting. 641 642 procedure Check_Consistent_Locking_Policy is 643 begin 644 -- First search for a unit specifying a policy and then 645 -- check all remaining units against it. 646 647 Find_Policy : for A1 in ALIs.First .. ALIs.Last loop 648 if ALIs.Table (A1).Locking_Policy /= ' ' then 649 Check_Policy : declare 650 Policy : constant Character := ALIs.Table (A1).Locking_Policy; 651 652 begin 653 for A2 in A1 + 1 .. ALIs.Last loop 654 if ALIs.Table (A2).Locking_Policy /= ' ' 655 and then 656 ALIs.Table (A2).Locking_Policy /= Policy 657 then 658 Error_Msg_File_1 := ALIs.Table (A1).Sfile; 659 Error_Msg_File_2 := ALIs.Table (A2).Sfile; 660 661 Consistency_Error_Msg 662 ("{ and { compiled with different locking policies"); 663 exit Find_Policy; 664 end if; 665 end loop; 666 end Check_Policy; 667 668 exit Find_Policy; 669 end if; 670 end loop Find_Policy; 671 end Check_Consistent_Locking_Policy; 672 673 ---------------------------------------- 674 -- Check_Consistent_Normalize_Scalars -- 675 ---------------------------------------- 676 677 -- The rule is that if any unit is compiled with Normalized_Scalars, 678 -- then all other units in the partition must also be compiled with 679 -- Normalized_Scalars in effect. 680 681 -- There is some issue as to whether this consistency check is desirable, 682 -- it is certainly required at the moment by the RM. We should keep a watch 683 -- on the ARG and HRG deliberations here. GNAT no longer depends on this 684 -- consistency (it used to do so, but that is no longer the case, since 685 -- pragma Initialize_Scalars pragma does not require consistency.) 686 687 procedure Check_Consistent_Normalize_Scalars is 688 begin 689 if Normalize_Scalars_Specified and No_Normalize_Scalars_Specified then 690 Consistency_Error_Msg 691 ("some but not all files compiled with Normalize_Scalars"); 692 693 Write_Eol; 694 Write_Str ("files compiled with Normalize_Scalars"); 695 Write_Eol; 696 697 for A1 in ALIs.First .. ALIs.Last loop 698 if ALIs.Table (A1).Normalize_Scalars then 699 Write_Str (" "); 700 Write_Name (ALIs.Table (A1).Sfile); 701 Write_Eol; 702 end if; 703 end loop; 704 705 Write_Eol; 706 Write_Str ("files compiled without Normalize_Scalars"); 707 Write_Eol; 708 709 for A1 in ALIs.First .. ALIs.Last loop 710 if not ALIs.Table (A1).Normalize_Scalars then 711 Write_Str (" "); 712 Write_Name (ALIs.Table (A1).Sfile); 713 Write_Eol; 714 end if; 715 end loop; 716 end if; 717 end Check_Consistent_Normalize_Scalars; 718 719 ----------------------------------------- 720 -- Check_Consistent_Optimize_Alignment -- 721 ----------------------------------------- 722 723 -- The rule is that all units which depend on the global default setting 724 -- of Optimize_Alignment must be compiled with the same setting for this 725 -- default. Units which specify an explicit local value for this setting 726 -- are exempt from the consistency rule (this includes all internal units). 727 728 procedure Check_Consistent_Optimize_Alignment is 729 OA_Setting : Character := ' '; 730 -- Reset when we find a unit that depends on the default and does 731 -- not have a local specification of the Optimize_Alignment setting. 732 733 OA_Unit : Unit_Id; 734 -- Id of unit from which OA_Setting was set 735 736 C : Character; 737 738 begin 739 for U in First_Unit_Entry .. Units.Last loop 740 C := Units.Table (U).Optimize_Alignment; 741 742 if C /= 'L' then 743 if OA_Setting = ' ' then 744 OA_Setting := C; 745 OA_Unit := U; 746 747 elsif OA_Setting = C then 748 null; 749 750 else 751 Error_Msg_Unit_1 := Units.Table (OA_Unit).Uname; 752 Error_Msg_Unit_2 := Units.Table (U).Uname; 753 754 Consistency_Error_Msg 755 ("$ and $ compiled with different " 756 & "default Optimize_Alignment settings"); 757 return; 758 end if; 759 end if; 760 end loop; 761 end Check_Consistent_Optimize_Alignment; 762 763 --------------------------------------------------- 764 -- Check_Consistent_Partition_Elaboration_Policy -- 765 --------------------------------------------------- 766 767 -- The rule is that all files for which the partition elaboration policy is 768 -- significant must be compiled with the same setting. 769 770 procedure Check_Consistent_Partition_Elaboration_Policy is 771 begin 772 -- First search for a unit specifying a policy and then 773 -- check all remaining units against it. 774 775 Find_Policy : for A1 in ALIs.First .. ALIs.Last loop 776 if ALIs.Table (A1).Partition_Elaboration_Policy /= ' ' then 777 Check_Policy : declare 778 Policy : constant Character := 779 ALIs.Table (A1).Partition_Elaboration_Policy; 780 781 begin 782 for A2 in A1 + 1 .. ALIs.Last loop 783 if ALIs.Table (A2).Partition_Elaboration_Policy /= ' ' 784 and then 785 ALIs.Table (A2).Partition_Elaboration_Policy /= Policy 786 then 787 Error_Msg_File_1 := ALIs.Table (A1).Sfile; 788 Error_Msg_File_2 := ALIs.Table (A2).Sfile; 789 790 Consistency_Error_Msg 791 ("{ and { compiled with different partition " 792 & "elaboration policies"); 793 exit Find_Policy; 794 end if; 795 end loop; 796 end Check_Policy; 797 798 -- A No_Task_Hierarchy restriction must be specified for the 799 -- Sequential policy (RM H.6(6/2)). 800 801 if Partition_Elaboration_Policy_Specified = 'S' 802 and then not Cumulative_Restrictions.Set (No_Task_Hierarchy) 803 then 804 Error_Msg_File_1 := ALIs.Table (A1).Sfile; 805 Error_Msg 806 ("{ has sequential partition elaboration policy, but no"); 807 Error_Msg 808 ("pragma Restrictions (No_Task_Hierarchy) was specified"); 809 end if; 810 811 exit Find_Policy; 812 end if; 813 end loop Find_Policy; 814 end Check_Consistent_Partition_Elaboration_Policy; 815 816 ------------------------------------- 817 -- Check_Consistent_Queuing_Policy -- 818 ------------------------------------- 819 820 -- The rule is that all files for which the queuing policy is 821 -- significant must be compiled with the same setting. 822 823 procedure Check_Consistent_Queuing_Policy is 824 begin 825 -- First search for a unit specifying a policy and then 826 -- check all remaining units against it. 827 828 Find_Policy : for A1 in ALIs.First .. ALIs.Last loop 829 if ALIs.Table (A1).Queuing_Policy /= ' ' then 830 Check_Policy : declare 831 Policy : constant Character := ALIs.Table (A1).Queuing_Policy; 832 begin 833 for A2 in A1 + 1 .. ALIs.Last loop 834 if ALIs.Table (A2).Queuing_Policy /= ' ' 835 and then 836 ALIs.Table (A2).Queuing_Policy /= Policy 837 then 838 Error_Msg_File_1 := ALIs.Table (A1).Sfile; 839 Error_Msg_File_2 := ALIs.Table (A2).Sfile; 840 841 Consistency_Error_Msg 842 ("{ and { compiled with different queuing policies"); 843 exit Find_Policy; 844 end if; 845 end loop; 846 end Check_Policy; 847 848 exit Find_Policy; 849 end if; 850 end loop Find_Policy; 851 end Check_Consistent_Queuing_Policy; 852 853 ----------------------------------- 854 -- Check_Consistent_Restrictions -- 855 ----------------------------------- 856 857 -- The rule is that if a restriction is specified in any unit, then all 858 -- units must obey the restriction. The check applies only to restrictions 859 -- which require partition wide consistency, and not to internal units. 860 861 procedure Check_Consistent_Restrictions is 862 Restriction_File_Output : Boolean; 863 -- Shows if we have output header messages for restriction violation 864 865 procedure Print_Restriction_File (R : All_Restrictions); 866 -- Print header line for R if not printed yet 867 868 ---------------------------- 869 -- Print_Restriction_File -- 870 ---------------------------- 871 872 procedure Print_Restriction_File (R : All_Restrictions) is 873 begin 874 if not Restriction_File_Output then 875 Restriction_File_Output := True; 876 877 -- Find an ali file specifying the restriction 878 879 for A in ALIs.First .. ALIs.Last loop 880 if ALIs.Table (A).Restrictions.Set (R) 881 and then (R in All_Boolean_Restrictions 882 or else ALIs.Table (A).Restrictions.Value (R) = 883 Cumulative_Restrictions.Value (R)) 884 then 885 -- We have found that ALI file A specifies the restriction 886 -- that is being violated (the minimum value is specified 887 -- in the case of a parameter restriction). 888 889 declare 890 M1 : constant String := "{ has restriction "; 891 S : constant String := Restriction_Id'Image (R); 892 M2 : String (1 .. 2000); -- big enough 893 P : Integer; 894 895 begin 896 Name_Buffer (1 .. S'Length) := S; 897 Name_Len := S'Length; 898 Set_Casing (Mixed_Case); 899 900 M2 (M1'Range) := M1; 901 P := M1'Length + 1; 902 M2 (P .. P + S'Length - 1) := Name_Buffer (1 .. S'Length); 903 P := P + S'Length; 904 905 if R in All_Parameter_Restrictions then 906 M2 (P .. P + 4) := " => #"; 907 Error_Msg_Nat_1 := 908 Int (Cumulative_Restrictions.Value (R)); 909 P := P + 5; 910 end if; 911 912 Error_Msg_File_1 := ALIs.Table (A).Sfile; 913 Consistency_Error_Msg (M2 (1 .. P - 1)); 914 Consistency_Error_Msg 915 ("but the following files violate this restriction:"); 916 return; 917 end; 918 end if; 919 end loop; 920 end if; 921 end Print_Restriction_File; 922 923 -- Start of processing for Check_Consistent_Restrictions 924 925 begin 926 -- A special test, if we have a main program, then if it has an 927 -- allocator in the body, this is considered to be a violation of 928 -- the restriction No_Allocators_After_Elaboration. We just mark 929 -- this restriction and then the normal circuit will flag it. 930 931 if Bind_Main_Program 932 and then ALIs.Table (ALIs.First).Main_Program /= None 933 and then not No_Main_Subprogram 934 and then ALIs.Table (ALIs.First).Allocator_In_Body 935 then 936 Cumulative_Restrictions.Violated 937 (No_Standard_Allocators_After_Elaboration) := True; 938 ALIs.Table (ALIs.First).Restrictions.Violated 939 (No_Standard_Allocators_After_Elaboration) := True; 940 end if; 941 942 -- Loop through all restriction violations 943 944 for R in All_Restrictions loop 945 946 -- Check for violation of this restriction 947 948 if Cumulative_Restrictions.Set (R) 949 and then Cumulative_Restrictions.Violated (R) 950 and then (R in Partition_Boolean_Restrictions 951 or else (R in All_Parameter_Restrictions 952 and then 953 Cumulative_Restrictions.Count (R) > 954 Cumulative_Restrictions.Value (R))) 955 then 956 Restriction_File_Output := False; 957 958 -- Loop through files looking for violators 959 960 for A2 in ALIs.First .. ALIs.Last loop 961 declare 962 T : ALIs_Record renames ALIs.Table (A2); 963 964 begin 965 if T.Restrictions.Violated (R) then 966 967 -- We exclude predefined files from the list of 968 -- violators. This should be rethought. It is not 969 -- clear that this is the right thing to do, that 970 -- is particularly the case for restricted runtimes. 971 972 if not Is_Internal_File_Name (T.Sfile) then 973 974 -- Case of Boolean restriction, just print file name 975 976 if R in All_Boolean_Restrictions then 977 Print_Restriction_File (R); 978 Error_Msg_File_1 := T.Sfile; 979 Consistency_Error_Msg (" {"); 980 981 -- Case of Parameter restriction where violation 982 -- count exceeds restriction value, print file 983 -- name and count, adding "at least" if the 984 -- exact count is not known. 985 986 elsif R in Checked_Add_Parameter_Restrictions 987 or else T.Restrictions.Count (R) > 988 Cumulative_Restrictions.Value (R) 989 then 990 Print_Restriction_File (R); 991 Error_Msg_File_1 := T.Sfile; 992 Error_Msg_Nat_1 := Int (T.Restrictions.Count (R)); 993 994 if T.Restrictions.Unknown (R) then 995 Consistency_Error_Msg 996 (" { (count = at least #)"); 997 else 998 Consistency_Error_Msg 999 (" { (count = #)"); 1000 end if; 1001 end if; 1002 end if; 1003 end if; 1004 end; 1005 end loop; 1006 end if; 1007 end loop; 1008 1009 -- Now deal with No_Dependence indications. Note that we put the loop 1010 -- through entries in the no dependency table first, since this loop 1011 -- is most often empty (no such pragma Restrictions in use). 1012 1013 for ND in No_Deps.First .. No_Deps.Last loop 1014 declare 1015 ND_Unit : constant Name_Id := No_Deps.Table (ND).No_Dep_Unit; 1016 begin 1017 for J in ALIs.First .. ALIs.Last loop 1018 declare 1019 A : ALIs_Record renames ALIs.Table (J); 1020 1021 begin 1022 for K in A.First_Unit .. A.Last_Unit loop 1023 declare 1024 U : Unit_Record renames Units.Table (K); 1025 begin 1026 for L in U.First_With .. U.Last_With loop 1027 if Same_Unit 1028 (Withs.Table (L).Uname, ND_Unit) 1029 then 1030 Error_Msg_File_1 := U.Sfile; 1031 Error_Msg_Name_1 := ND_Unit; 1032 Consistency_Error_Msg 1033 ("file { violates restriction " & 1034 "No_Dependence => %"); 1035 end if; 1036 end loop; 1037 end; 1038 end loop; 1039 end; 1040 end loop; 1041 end; 1042 end loop; 1043 end Check_Consistent_Restrictions; 1044 1045 ------------------------------------------------------------ 1046 -- Check_Consistent_Restriction_No_Default_Initialization -- 1047 ------------------------------------------------------------ 1048 1049 -- The Restriction (No_Default_Initialization) has special consistency 1050 -- rules. The rule is that no unit compiled without this restriction 1051 -- that violates the restriction can WITH a unit that is compiled with 1052 -- the restriction. 1053 1054 procedure Check_Consistent_Restriction_No_Default_Initialization is 1055 begin 1056 -- Nothing to do if no one set this restriction 1057 1058 if not Cumulative_Restrictions.Set (No_Default_Initialization) then 1059 return; 1060 end if; 1061 1062 -- Nothing to do if no one violates the restriction 1063 1064 if not Cumulative_Restrictions.Violated (No_Default_Initialization) then 1065 return; 1066 end if; 1067 1068 -- Otherwise we go into a full scan to find possible problems 1069 1070 for U in Units.First .. Units.Last loop 1071 declare 1072 UTE : Unit_Record renames Units.Table (U); 1073 ATE : ALIs_Record renames ALIs.Table (UTE.My_ALI); 1074 1075 begin 1076 if ATE.Restrictions.Violated (No_Default_Initialization) then 1077 for W in UTE.First_With .. UTE.Last_With loop 1078 declare 1079 AFN : constant File_Name_Type := Withs.Table (W).Afile; 1080 1081 begin 1082 -- The file name may not be present for withs of certain 1083 -- generic run-time files. The test can be safely left 1084 -- out in such cases anyway. 1085 1086 if AFN /= No_File then 1087 declare 1088 WAI : constant ALI_Id := 1089 ALI_Id (Get_Name_Table_Info (AFN)); 1090 WTE : ALIs_Record renames ALIs.Table (WAI); 1091 1092 begin 1093 if WTE.Restrictions.Set 1094 (No_Default_Initialization) 1095 then 1096 Error_Msg_Unit_1 := UTE.Uname; 1097 Consistency_Error_Msg 1098 ("unit $ compiled without restriction " 1099 & "No_Default_Initialization"); 1100 Error_Msg_Unit_1 := Withs.Table (W).Uname; 1101 Consistency_Error_Msg 1102 ("withs unit $, compiled with restriction " 1103 & "No_Default_Initialization"); 1104 end if; 1105 end; 1106 end if; 1107 end; 1108 end loop; 1109 end if; 1110 end; 1111 end loop; 1112 end Check_Consistent_Restriction_No_Default_Initialization; 1113 1114 --------------------------------------------------- 1115 -- Check_Consistent_Zero_Cost_Exception_Handling -- 1116 --------------------------------------------------- 1117 1118 -- Check consistent zero cost exception handling. The rule is that 1119 -- all units must have the same exception handling mechanism. 1120 1121 procedure Check_Consistent_Zero_Cost_Exception_Handling is 1122 begin 1123 Check_Mechanism : for A1 in ALIs.First + 1 .. ALIs.Last loop 1124 if ALIs.Table (A1).Zero_Cost_Exceptions /= 1125 ALIs.Table (ALIs.First).Zero_Cost_Exceptions 1126 then 1127 Error_Msg_File_1 := ALIs.Table (A1).Sfile; 1128 Error_Msg_File_2 := ALIs.Table (ALIs.First).Sfile; 1129 1130 Consistency_Error_Msg ("{ and { compiled with different " 1131 & "exception handling mechanisms"); 1132 end if; 1133 end loop Check_Mechanism; 1134 end Check_Consistent_Zero_Cost_Exception_Handling; 1135 1136 ------------------------------- 1137 -- Check_Duplicated_Subunits -- 1138 ------------------------------- 1139 1140 procedure Check_Duplicated_Subunits is 1141 begin 1142 for J in Sdep.First .. Sdep.Last loop 1143 if Sdep.Table (J).Subunit_Name /= No_Name then 1144 Get_Decoded_Name_String (Sdep.Table (J).Subunit_Name); 1145 Name_Len := Name_Len + 2; 1146 Name_Buffer (Name_Len - 1) := '%'; 1147 1148 -- See if there is a body or spec with the same name 1149 1150 for K in Boolean loop 1151 if K then 1152 Name_Buffer (Name_Len) := 'b'; 1153 else 1154 Name_Buffer (Name_Len) := 's'; 1155 end if; 1156 1157 declare 1158 Unit : constant Unit_Name_Type := Name_Find; 1159 Info : constant Int := Get_Name_Table_Info (Unit); 1160 1161 begin 1162 if Info /= 0 then 1163 Set_Standard_Error; 1164 Write_Str ("error: subunit """); 1165 Write_Name_Decoded (Sdep.Table (J).Subunit_Name); 1166 Write_Str (""" in file """); 1167 Write_Name_Decoded (Sdep.Table (J).Sfile); 1168 Write_Char ('"'); 1169 Write_Eol; 1170 Write_Str (" has same name as unit """); 1171 Write_Unit_Name (Units.Table (Unit_Id (Info)).Uname); 1172 Write_Str (""" found in file """); 1173 Write_Name_Decoded (Units.Table (Unit_Id (Info)).Sfile); 1174 Write_Char ('"'); 1175 Write_Eol; 1176 Write_Str (" this is not allowed within a single " 1177 & "partition (RM 10.2(19))"); 1178 Write_Eol; 1179 Osint.Exit_Program (Osint.E_Fatal); 1180 end if; 1181 end; 1182 end loop; 1183 end if; 1184 end loop; 1185 end Check_Duplicated_Subunits; 1186 1187 -------------------- 1188 -- Check_Versions -- 1189 -------------------- 1190 1191 procedure Check_Versions is 1192 VL : constant Natural := ALIs.Table (ALIs.First).Ver_Len; 1193 1194 begin 1195 for A in ALIs.First .. ALIs.Last loop 1196 if ALIs.Table (A).Ver_Len /= VL 1197 or else ALIs.Table (A).Ver (1 .. VL) /= 1198 ALIs.Table (ALIs.First).Ver (1 .. VL) 1199 then 1200 Error_Msg_File_1 := ALIs.Table (A).Sfile; 1201 Error_Msg_File_2 := ALIs.Table (ALIs.First).Sfile; 1202 1203 Consistency_Error_Msg 1204 ("{ and { compiled with different GNAT versions"); 1205 end if; 1206 end loop; 1207 end Check_Versions; 1208 1209 --------------------------- 1210 -- Consistency_Error_Msg -- 1211 --------------------------- 1212 1213 procedure Consistency_Error_Msg (Msg : String) is 1214 begin 1215 if Tolerate_Consistency_Errors then 1216 1217 -- If consistency errors are tolerated, 1218 -- output the message as a warning. 1219 1220 Error_Msg ('?' & Msg); 1221 1222 -- Otherwise the consistency error is a true error 1223 1224 else 1225 Error_Msg (Msg); 1226 end if; 1227 end Consistency_Error_Msg; 1228 1229 --------------- 1230 -- Same_Unit -- 1231 --------------- 1232 1233 function Same_Unit (U1 : Unit_Name_Type; U2 : Name_Id) return Boolean is 1234 begin 1235 -- Note, the string U1 has a terminating %s or %b, U2 does not 1236 1237 if Length_Of_Name (U1) - 2 = Length_Of_Name (U2) then 1238 Get_Name_String (U1); 1239 1240 declare 1241 U1_Str : constant String := Name_Buffer (1 .. Name_Len - 2); 1242 begin 1243 Get_Name_String (U2); 1244 return U1_Str = Name_Buffer (1 .. Name_Len); 1245 end; 1246 1247 else 1248 return False; 1249 end if; 1250 end Same_Unit; 1251 1252end Bcheck; 1253