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