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