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