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