1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
11 -- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
13 -- GNAT is free software; you can redistribute it and/or modify it under --
14 -- terms of the GNU General Public License as published by the Free Soft- --
15 -- ware Foundation; either version 2, or (at your option) any later ver- --
16 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
17 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
18 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
19 -- for more details. You should have received a copy of the GNU General --
20 -- Public License distributed with GNAT; see file COPYING. If not, write --
21 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
22 -- MA 02111-1307, USA. --
24 -- GNAT was originally developed by the GNAT team at New York University. --
25 -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
27 ------------------------------------------------------------------------------
30 with ALI
.Util
; use ALI
.Util
;
31 with Binderr
; use Binderr
;
32 with Butil
; use Butil
;
33 with Casing
; use Casing
;
34 with Debug
; use Debug
;
35 with Fname
; use Fname
;
36 with Namet
; use Namet
;
39 with Output
; use Output
;
40 with Rident
; use Rident
;
41 with Types
; use Types
;
43 package body Bcheck
is
47 -- The following checking subprograms make up the parts
48 -- of the configuration consistency check.
50 procedure Check_Consistent_Dynamic_Elaboration_Checking
;
51 procedure Check_Consistent_Floating_Point_Format
;
52 procedure Check_Consistent_Locking_Policy
;
53 procedure Check_Consistent_Normalize_Scalars
;
54 procedure Check_Consistent_Queuing_Policy
;
55 procedure Check_Consistent_Zero_Cost_Exception_Handling
;
56 procedure Check_Partition_Restrictions
;
58 procedure Consistency_Error_Msg
(Msg
: String);
59 -- Produce an error or a warning message, depending on whether
60 -- an inconsistent configuration is permitted or not.
62 ------------------------------------
63 -- Check_Consistent_Configuration --
64 ------------------------------------
66 procedure Check_Configuration_Consistency
is
68 if Float_Format_Specified
/= ' ' then
69 Check_Consistent_Floating_Point_Format
;
72 if Queuing_Policy_Specified
/= ' ' then
73 Check_Consistent_Queuing_Policy
;
76 if Locking_Policy_Specified
/= ' ' then
77 Check_Consistent_Locking_Policy
;
80 if Zero_Cost_Exceptions_Specified
then
81 Check_Consistent_Zero_Cost_Exception_Handling
;
84 Check_Consistent_Normalize_Scalars
;
85 Check_Consistent_Dynamic_Elaboration_Checking
;
87 Check_Partition_Restrictions
;
88 end Check_Configuration_Consistency
;
90 ---------------------------------------------------
91 -- Check_Consistent_Dynamic_Elaboration_Checking --
92 ---------------------------------------------------
94 -- The rule here is that if a unit has dynamic elaboration checks,
95 -- then any unit it withs must meeting one of the following criteria:
97 -- 1. There is a pragma Elaborate_All for the with'ed unit
98 -- 2. The with'ed unit was compiled with dynamic elaboration checks
99 -- 3. The with'ed unit has pragma Preelaborate or Pure
100 -- 4. It is an internal GNAT unit (including children of GNAT)
102 procedure Check_Consistent_Dynamic_Elaboration_Checking
is
104 if Dynamic_Elaboration_Checks_Specified
then
105 for U
in First_Unit_Entry
.. Units
.Last
loop
107 UR
: Unit_Record
renames Units
.Table
(U
);
110 if UR
.Dynamic_Elab
then
111 for W
in UR
.First_With
.. UR
.Last_With
loop
113 WR
: With_Record
renames Withs
.Table
(W
);
116 if Get_Name_Table_Info
(WR
.Uname
) /= 0 then
118 WU
: Unit_Record
renames
121 (Get_Name_Table_Info
(WR
.Uname
)));
124 -- Case 1. Elaborate_All for with'ed unit
126 if WR
.Elaborate_All
then
129 -- Case 2. With'ed unit has dynamic elab checks
131 elsif WU
.Dynamic_Elab
then
134 -- Case 3. With'ed unit is Preelaborate or Pure
136 elsif WU
.Preelab
or WU
.Pure
then
139 -- Case 4. With'ed unit is internal file
141 elsif Is_Internal_File_Name
(WU
.Sfile
) then
144 -- Issue warning, not one of the safe cases
147 Error_Msg_Name_1
:= UR
.Sfile
;
149 ("?% has dynamic elaboration checks " &
152 Error_Msg_Name_1
:= WU
.Sfile
;
154 ("? % which has static elaboration " &
157 Warnings_Detected
:= Warnings_Detected
- 1;
167 end Check_Consistent_Dynamic_Elaboration_Checking
;
169 --------------------------------------------
170 -- Check_Consistent_Floating_Point_Format --
171 --------------------------------------------
173 -- The rule is that all files must be compiled with the same setting
174 -- for the floating-point format.
176 procedure Check_Consistent_Floating_Point_Format
is
178 -- First search for a unit specifying a floating-point format and then
179 -- check all remaining units against it.
181 Find_Format
: for A1
in ALIs
.First
.. ALIs
.Last
loop
182 if ALIs
.Table
(A1
).Float_Format
/= ' ' then
183 Check_Format
: declare
184 Format
: constant Character := ALIs
.Table
(A1
).Float_Format
;
186 for A2
in A1
+ 1 .. ALIs
.Last
loop
187 if ALIs
.Table
(A2
).Float_Format
/= Format
then
188 Error_Msg_Name_1
:= ALIs
.Table
(A1
).Sfile
;
189 Error_Msg_Name_2
:= ALIs
.Table
(A2
).Sfile
;
191 Consistency_Error_Msg
192 ("% and % compiled with different " &
193 "floating-point representations");
201 end loop Find_Format
;
202 end Check_Consistent_Floating_Point_Format
;
204 -------------------------------------
205 -- Check_Consistent_Locking_Policy --
206 -------------------------------------
208 -- The rule is that all files for which the locking policy is
209 -- significant must be compiled with the same setting.
211 procedure Check_Consistent_Locking_Policy
is
213 -- First search for a unit specifying a policy and then
214 -- check all remaining units against it.
216 Find_Policy
: for A1
in ALIs
.First
.. ALIs
.Last
loop
217 if ALIs
.Table
(A1
).Locking_Policy
/= ' ' then
218 Check_Policy
: declare
219 Policy
: constant Character := ALIs
.Table
(A1
).Locking_Policy
;
222 for A2
in A1
+ 1 .. ALIs
.Last
loop
223 if ALIs
.Table
(A2
).Locking_Policy
/= ' ' and
224 ALIs
.Table
(A2
).Locking_Policy
/= Policy
226 Error_Msg_Name_1
:= ALIs
.Table
(A1
).Sfile
;
227 Error_Msg_Name_2
:= ALIs
.Table
(A2
).Sfile
;
229 Consistency_Error_Msg
230 ("% and % compiled with different locking policies");
238 end loop Find_Policy
;
239 end Check_Consistent_Locking_Policy
;
241 ----------------------------------------
242 -- Check_Consistent_Normalize_Scalars --
243 ----------------------------------------
245 -- The rule is that if any unit is compiled with Normalized_Scalars,
246 -- then all other units in the partition must also be compiled with
247 -- Normalized_Scalars in effect.
249 -- There is some issue as to whether this consistency check is
250 -- desirable, it is certainly required at the moment by the RM.
251 -- We should keep a watch on the ARG and HRG deliberations here.
252 -- GNAT no longer depends on this consistency (it used to do so,
253 -- but that has been corrected in the latest version, since the
254 -- Initialize_Scalars pragma does not require consistency.
256 procedure Check_Consistent_Normalize_Scalars
is
258 if Normalize_Scalars_Specified
and No_Normalize_Scalars_Specified
then
259 Consistency_Error_Msg
260 ("some but not all files compiled with Normalize_Scalars");
263 Write_Str
("files compiled with Normalize_Scalars");
266 for A1
in ALIs
.First
.. ALIs
.Last
loop
267 if ALIs
.Table
(A1
).Normalize_Scalars
then
269 Write_Name
(ALIs
.Table
(A1
).Sfile
);
275 Write_Str
("files compiled without Normalize_Scalars");
278 for A1
in ALIs
.First
.. ALIs
.Last
loop
279 if not ALIs
.Table
(A1
).Normalize_Scalars
then
281 Write_Name
(ALIs
.Table
(A1
).Sfile
);
286 end Check_Consistent_Normalize_Scalars
;
288 -------------------------------------
289 -- Check_Consistent_Queuing_Policy --
290 -------------------------------------
292 -- The rule is that all files for which the queuing policy is
293 -- significant must be compiled with the same setting.
295 procedure Check_Consistent_Queuing_Policy
is
297 -- First search for a unit specifying a policy and then
298 -- check all remaining units against it.
300 Find_Policy
: for A1
in ALIs
.First
.. ALIs
.Last
loop
301 if ALIs
.Table
(A1
).Queuing_Policy
/= ' ' then
302 Check_Policy
: declare
303 Policy
: constant Character := ALIs
.Table
(A1
).Queuing_Policy
;
305 for A2
in A1
+ 1 .. ALIs
.Last
loop
306 if ALIs
.Table
(A2
).Queuing_Policy
/= ' '
308 ALIs
.Table
(A2
).Queuing_Policy
/= Policy
310 Error_Msg_Name_1
:= ALIs
.Table
(A1
).Sfile
;
311 Error_Msg_Name_2
:= ALIs
.Table
(A2
).Sfile
;
313 Consistency_Error_Msg
314 ("% and % compiled with different queuing policies");
322 end loop Find_Policy
;
323 end Check_Consistent_Queuing_Policy
;
325 ---------------------------------------------------
326 -- Check_Consistent_Zero_Cost_Exception_Handling --
327 ---------------------------------------------------
329 -- Check consistent zero cost exception handling. The rule is that
330 -- all units must have the same exception handling mechanism.
332 procedure Check_Consistent_Zero_Cost_Exception_Handling
is
334 Check_Mechanism
: for A1
in ALIs
.First
+ 1 .. ALIs
.Last
loop
335 if ALIs
.Table
(A1
).Zero_Cost_Exceptions
/=
336 ALIs
.Table
(ALIs
.First
).Zero_Cost_Exceptions
339 Error_Msg_Name_1
:= ALIs
.Table
(A1
).Sfile
;
340 Error_Msg_Name_2
:= ALIs
.Table
(ALIs
.First
).Sfile
;
342 Consistency_Error_Msg
("% and % compiled with different "
343 & "exception handling mechanisms");
345 end loop Check_Mechanism
;
346 end Check_Consistent_Zero_Cost_Exception_Handling
;
348 ----------------------------------
349 -- Check_Partition_Restrictions --
350 ----------------------------------
352 -- The rule is that if a restriction is specified in any unit,
353 -- then all units must obey the restriction. The check applies
354 -- only to restrictions which require partition wide consistency,
355 -- and not to internal units.
357 -- The check is done in two steps. First for every restriction
358 -- a unit specifying that restriction is found, if any.
359 -- Second, all units are verified against the specified restrictions.
361 procedure Check_Partition_Restrictions
is
363 R
: array (Partition_Restrictions
) of ALI_Id
:= (others => No_ALI_Id
);
364 -- Record the first unit specifying each partition restriction
366 V
: array (Partition_Restrictions
) of ALI_Id
:= (others => No_ALI_Id
);
367 -- Record the last unit violating each partition restriction
369 procedure List_Applicable_Restrictions
;
370 -- Output a list of restrictions that may be applied to the partition,
371 -- without causing bind errors.
373 ----------------------------------
374 -- List_Applicable_Restrictions --
375 ----------------------------------
377 procedure List_Applicable_Restrictions
is
378 Additional_Restrictions_Listed
: Boolean := False;
381 -- List any restrictions which were not violated and not specified
383 for J
in Partition_Restrictions
loop
384 if V
(J
) = No_ALI_Id
and R
(J
) = No_ALI_Id
then
385 if not Additional_Restrictions_Listed
then
386 Write_Str
("The following additional restrictions may be" &
387 " applied to this partition:");
389 Additional_Restrictions_Listed
:= True;
392 Write_Str
("pragma Restrictions (");
395 S
: constant String := Restriction_Id
'Image (J
);
398 Name_Len
:= S
'Length;
399 Name_Buffer
(1 .. Name_Len
) := S
;
402 Set_Casing
(Mixed_Case
);
403 Write_Str
(Name_Buffer
(1 .. Name_Len
));
408 end List_Applicable_Restrictions
;
410 -- Start of processing for Check_Partition_Restrictions
414 for A
in ALIs
.First
.. ALIs
.Last
loop
415 for J
in Partition_Restrictions
loop
416 if R
(J
) = No_ALI_Id
and ALIs
.Table
(A
).Restrictions
(J
) = 'r' then
420 end loop Find_Restrictions
;
423 for A
in ALIs
.First
.. ALIs
.Last
loop
424 for J
in Partition_Restrictions
loop
425 if ALIs
.Table
(A
).Restrictions
(J
) = 'v'
426 and then not Is_Internal_File_Name
(ALIs
.Table
(A
).Sfile
)
428 -- A violation of a restriction was found, so check whether
429 -- that restriction was actually in effect. If so, give an
432 -- Note that all such violations found are reported.
436 if R
(J
) /= No_ALI_Id
then
437 Report_Violated_Restriction
: declare
438 M1
: constant String := "% has Restriction (";
439 S
: constant String := Restriction_Id
'Image (J
);
440 M2
: String (1 .. M1
'Length + S
'Length + 1);
443 Name_Buffer
(1 .. S
'Length) := S
;
444 Name_Len
:= S
'Length;
446 (Units
.Table
(ALIs
.Table
(R
(J
)).First_Unit
).Icasing
);
449 M2
(M1
'Length + 1 .. M2
'Last - 1) :=
450 Name_Buffer
(1 .. S
'Length);
453 Error_Msg_Name_1
:= ALIs
.Table
(R
(J
)).Sfile
;
454 Consistency_Error_Msg
(M2
);
455 Error_Msg_Name_1
:= ALIs
.Table
(A
).Sfile
;
456 Consistency_Error_Msg
457 ("but file % violates this restriction");
458 end Report_Violated_Restriction
;
462 end loop Find_Violations
;
465 List_Applicable_Restrictions
;
467 end Check_Partition_Restrictions
;
469 -----------------------
470 -- Check_Consistency --
471 -----------------------
473 procedure Check_Consistency
is
475 -- Source file Id for this Sdep entry
478 -- First, we go through the source table to see if there are any cases
479 -- in which we should go after source files and compute checksums of
480 -- the source files. We need to do this for any file for which we have
481 -- mismatching time stamps and (so far) matching checksums.
483 for S
in Source
.First
.. Source
.Last
loop
485 -- If all time stamps for a file match, then there is nothing to
486 -- do, since we will not be checking checksums in that case anyway
488 if Source
.Table
(S
).All_Timestamps_Match
then
491 -- If we did not find the source file, then we can't compute its
492 -- checksum anyway. Note that when we have a time stamp mismatch,
493 -- we try to find the source file unconditionally (i.e. if
494 -- Check_Source_Files is False).
496 elsif not Source
.Table
(S
).Source_Found
then
499 -- If we already have non-matching or missing checksums, then no
500 -- need to try going after source file, since we won't trust the
501 -- checksums in any case.
503 elsif not Source
.Table
(S
).All_Checksums_Match
then
506 -- Now we have the case where we have time stamp mismatches, and
507 -- the source file is around, but so far all checksums match. This
508 -- is the case where we need to compute the checksum from the source
509 -- file, since otherwise we would ignore the time stamp mismatches,
510 -- and that is wrong if the checksum of the source does not agree
511 -- with the checksums in the ALI files.
513 elsif Check_Source_Files
then
514 if not Checksums_Match
515 (Source
.Table
(S
).Checksum
,
516 Get_File_Checksum
(Source
.Table
(S
).Sfile
))
518 Source
.Table
(S
).All_Checksums_Match
:= False;
523 -- Loop through ALI files
525 ALIs_Loop
: for A
in ALIs
.First
.. ALIs
.Last
loop
527 -- Loop through Sdep entries in one ALI file
530 ALIs
.Table
(A
).First_Sdep
.. ALIs
.Table
(A
).Last_Sdep
532 if Sdep
.Table
(D
).Dummy_Entry
then
536 Src
:= Source_Id
(Get_Name_Table_Info
(Sdep
.Table
(D
).Sfile
));
538 -- If the time stamps match, or all checksums match, then we
539 -- are OK, otherwise we have a definite error.
541 if Sdep
.Table
(D
).Stamp
/= Source
.Table
(Src
).Stamp
542 and then not Source
.Table
(Src
).All_Checksums_Match
544 Error_Msg_Name_1
:= ALIs
.Table
(A
).Sfile
;
545 Error_Msg_Name_2
:= Sdep
.Table
(D
).Sfile
;
547 -- Two styles of message, depending on whether or not
548 -- the updated file is the one that must be recompiled
550 if Error_Msg_Name_1
= Error_Msg_Name_2
then
551 if Tolerate_Consistency_Errors
then
553 ("?% has been modified and should be recompiled");
556 ("% has been modified and must be recompiled");
560 if Tolerate_Consistency_Errors
then
562 ("?% should be recompiled (% has been modified)");
565 Error_Msg
("% must be recompiled (% has been modified)");
569 if (not Tolerate_Consistency_Errors
) and Verbose_Mode
then
571 Msg
: constant String := "file % has time stamp ";
572 Buf
: String (1 .. Msg
'Length + Time_Stamp_Length
);
575 Buf
(1 .. Msg
'Length) := Msg
;
576 Buf
(Msg
'Length + 1 .. Buf
'Length) :=
577 String (Source
.Table
(Src
).Stamp
);
578 Error_Msg_Name_1
:= ALIs
.Table
(A
).Sfile
;
581 Buf
(Msg
'Length + 1 .. Buf
'Length) :=
582 String (Sdep
.Table
(D
).Stamp
);
583 Error_Msg_Name_1
:= Sdep
.Table
(D
).Sfile
;
588 -- Exit from the loop through Sdep entries once we find one
589 -- that does not match.
598 end Check_Consistency
;
600 -------------------------------
601 -- Check_Duplicated_Subunits --
602 -------------------------------
604 procedure Check_Duplicated_Subunits
is
606 for J
in Sdep
.First
.. Sdep
.Last
loop
607 if Sdep
.Table
(J
).Subunit_Name
/= No_Name
then
608 Get_Decoded_Name_String
(Sdep
.Table
(J
).Subunit_Name
);
609 Name_Len
:= Name_Len
+ 2;
610 Name_Buffer
(Name_Len
- 1) := '%';
612 -- See if there is a body or spec with the same name
614 for K
in Boolean loop
616 Name_Buffer
(Name_Len
) := 'b';
619 Name_Buffer
(Name_Len
) := 's';
623 Info
: constant Int
:= Get_Name_Table_Info
(Name_Find
);
628 Write_Str
("error: subunit """);
629 Write_Name_Decoded
(Sdep
.Table
(J
).Subunit_Name
);
630 Write_Str
(""" in file """);
631 Write_Name_Decoded
(Sdep
.Table
(J
).Sfile
);
634 Write_Str
(" has same name as unit """);
635 Write_Unit_Name
(Units
.Table
(Unit_Id
(Info
)).Uname
);
636 Write_Str
(""" found in file """);
637 Write_Name_Decoded
(Units
.Table
(Unit_Id
(Info
)).Sfile
);
640 Write_Str
(" this is not allowed within a single "
641 & "partition (RM 10.2(19))");
643 Osint
.Exit_Program
(Osint
.E_Fatal
);
649 end Check_Duplicated_Subunits
;
655 procedure Check_Versions
is
656 VL
: constant Natural := ALIs
.Table
(ALIs
.First
).Ver_Len
;
659 for A
in ALIs
.First
.. ALIs
.Last
loop
660 if ALIs
.Table
(A
).Ver_Len
/= VL
661 or else ALIs
.Table
(A
).Ver
(1 .. VL
) /=
662 ALIs
.Table
(ALIs
.First
).Ver
(1 .. VL
)
664 Error_Msg_Name_1
:= ALIs
.Table
(A
).Sfile
;
665 Error_Msg_Name_2
:= ALIs
.Table
(ALIs
.First
).Sfile
;
667 Consistency_Error_Msg
668 ("% and % compiled with different GNAT versions");
673 ---------------------------
674 -- Consistency_Error_Msg --
675 ---------------------------
677 procedure Consistency_Error_Msg
(Msg
: String) is
679 if Tolerate_Consistency_Errors
then
681 -- If consistency errors are tolerated,
682 -- output the message as a warning.
685 Warning_Msg
: String (1 .. Msg
'Length + 1);
688 Warning_Msg
(1) := '?';
689 Warning_Msg
(2 .. Warning_Msg
'Last) := Msg
;
691 Error_Msg
(Warning_Msg
);
694 -- Otherwise the consistency error is a true error
699 end Consistency_Error_Msg
;