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