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