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