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