1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
10 -- Copyright (C) 1992-2002 Free Software Foundation, Inc. --
12 -- GNAT is free software; you can redistribute it and/or modify it under --
13 -- terms of the GNU General Public License as published by the Free Soft- --
14 -- ware Foundation; either version 2, or (at your option) any later ver- --
15 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
16 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
17 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
18 -- for more details. You should have received a copy of the GNU General --
19 -- Public License distributed with GNAT; see file COPYING. If not, write --
20 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
21 -- MA 02111-1307, USA. --
23 -- GNAT was originally developed by the GNAT team at New York University. --
24 -- Extensive contributions were provided by Ada Core Technologies Inc. --
26 ------------------------------------------------------------------------------
29 with ALI
.Util
; use ALI
.Util
;
30 with Binderr
; use Binderr
;
31 with Butil
; use Butil
;
32 with Casing
; use Casing
;
33 with Fname
; use Fname
;
34 with Namet
; use Namet
;
37 with Output
; use Output
;
38 with Rident
; use Rident
;
39 with Types
; use Types
;
41 package body Bcheck
is
45 -- The following checking subprograms make up the parts
46 -- of the configuration consistency check.
48 procedure Check_Consistent_Dynamic_Elaboration_Checking
;
49 procedure Check_Consistent_Floating_Point_Format
;
50 procedure Check_Consistent_Locking_Policy
;
51 procedure Check_Consistent_Normalize_Scalars
;
52 procedure Check_Consistent_Queuing_Policy
;
53 procedure Check_Consistent_Zero_Cost_Exception_Handling
;
54 procedure Check_Partition_Restrictions
;
56 procedure Consistency_Error_Msg
(Msg
: String);
57 -- Produce an error or a warning message, depending on whether
58 -- an inconsistent configuration is permitted or not.
60 ------------------------------------
61 -- Check_Consistent_Configuration --
62 ------------------------------------
64 procedure Check_Configuration_Consistency
is
66 if Float_Format_Specified
/= ' ' then
67 Check_Consistent_Floating_Point_Format
;
70 if Queuing_Policy_Specified
/= ' ' then
71 Check_Consistent_Queuing_Policy
;
74 if Locking_Policy_Specified
/= ' ' then
75 Check_Consistent_Locking_Policy
;
78 if Zero_Cost_Exceptions_Specified
then
79 Check_Consistent_Zero_Cost_Exception_Handling
;
82 Check_Consistent_Normalize_Scalars
;
83 Check_Consistent_Dynamic_Elaboration_Checking
;
85 Check_Partition_Restrictions
;
86 end Check_Configuration_Consistency
;
88 ---------------------------------------------------
89 -- Check_Consistent_Dynamic_Elaboration_Checking --
90 ---------------------------------------------------
92 -- The rule here is that if a unit has dynamic elaboration checks,
93 -- then any unit it withs must meeting one of the following criteria:
95 -- 1. There is a pragma Elaborate_All for the with'ed unit
96 -- 2. The with'ed unit was compiled with dynamic elaboration checks
97 -- 3. The with'ed unit has pragma Preelaborate or Pure
98 -- 4. It is an internal GNAT unit (including children of GNAT)
100 procedure Check_Consistent_Dynamic_Elaboration_Checking
is
102 if Dynamic_Elaboration_Checks_Specified
then
103 for U
in First_Unit_Entry
.. Units
.Last
loop
105 UR
: Unit_Record
renames Units
.Table
(U
);
108 if UR
.Dynamic_Elab
then
109 for W
in UR
.First_With
.. UR
.Last_With
loop
111 WR
: With_Record
renames Withs
.Table
(W
);
114 if Get_Name_Table_Info
(WR
.Uname
) /= 0 then
116 WU
: Unit_Record
renames
119 (Get_Name_Table_Info
(WR
.Uname
)));
122 -- Case 1. Elaborate_All for with'ed unit
124 if WR
.Elaborate_All
then
127 -- Case 2. With'ed unit has dynamic elab checks
129 elsif WU
.Dynamic_Elab
then
132 -- Case 3. With'ed unit is Preelaborate or Pure
134 elsif WU
.Preelab
or WU
.Pure
then
137 -- Case 4. With'ed unit is internal file
139 elsif Is_Internal_File_Name
(WU
.Sfile
) then
142 -- Issue warning, not one of the safe cases
145 Error_Msg_Name_1
:= UR
.Sfile
;
147 ("?% has dynamic elaboration checks " &
150 Error_Msg_Name_1
:= WU
.Sfile
;
152 ("? % which has static elaboration " &
155 Warnings_Detected
:= Warnings_Detected
- 1;
165 end Check_Consistent_Dynamic_Elaboration_Checking
;
167 --------------------------------------------
168 -- Check_Consistent_Floating_Point_Format --
169 --------------------------------------------
171 -- The rule is that all files must be compiled with the same setting
172 -- for the floating-point format.
174 procedure Check_Consistent_Floating_Point_Format
is
176 -- First search for a unit specifying a floating-point format and then
177 -- check all remaining units against it.
179 Find_Format
: for A1
in ALIs
.First
.. ALIs
.Last
loop
180 if ALIs
.Table
(A1
).Float_Format
/= ' ' then
181 Check_Format
: declare
182 Format
: constant Character := ALIs
.Table
(A1
).Float_Format
;
184 for A2
in A1
+ 1 .. ALIs
.Last
loop
185 if ALIs
.Table
(A2
).Float_Format
/= Format
then
186 Error_Msg_Name_1
:= ALIs
.Table
(A1
).Sfile
;
187 Error_Msg_Name_2
:= ALIs
.Table
(A2
).Sfile
;
189 Consistency_Error_Msg
190 ("% and % compiled with different " &
191 "floating-point representations");
199 end loop Find_Format
;
200 end Check_Consistent_Floating_Point_Format
;
202 -------------------------------------
203 -- Check_Consistent_Locking_Policy --
204 -------------------------------------
206 -- The rule is that all files for which the locking policy is
207 -- significant must be compiled with the same setting.
209 procedure Check_Consistent_Locking_Policy
is
211 -- First search for a unit specifying a policy and then
212 -- check all remaining units against it.
214 Find_Policy
: for A1
in ALIs
.First
.. ALIs
.Last
loop
215 if ALIs
.Table
(A1
).Locking_Policy
/= ' ' then
216 Check_Policy
: declare
217 Policy
: constant Character := ALIs
.Table
(A1
).Locking_Policy
;
220 for A2
in A1
+ 1 .. ALIs
.Last
loop
221 if ALIs
.Table
(A2
).Locking_Policy
/= ' ' and
222 ALIs
.Table
(A2
).Locking_Policy
/= Policy
224 Error_Msg_Name_1
:= ALIs
.Table
(A1
).Sfile
;
225 Error_Msg_Name_2
:= ALIs
.Table
(A2
).Sfile
;
227 Consistency_Error_Msg
228 ("% and % compiled with different locking policies");
236 end loop Find_Policy
;
237 end Check_Consistent_Locking_Policy
;
239 ----------------------------------------
240 -- Check_Consistent_Normalize_Scalars --
241 ----------------------------------------
243 -- The rule is that if any unit is compiled with Normalized_Scalars,
244 -- then all other units in the partition must also be compiled with
245 -- Normalized_Scalars in effect.
247 -- There is some issue as to whether this consistency check is
248 -- desirable, it is certainly required at the moment by the RM.
249 -- We should keep a watch on the ARG and HRG deliberations here.
250 -- GNAT no longer depends on this consistency (it used to do so,
251 -- but that has been corrected in the latest version, since the
252 -- Initialize_Scalars pragma does not require consistency.
254 procedure Check_Consistent_Normalize_Scalars
is
256 if Normalize_Scalars_Specified
and No_Normalize_Scalars_Specified
then
257 Consistency_Error_Msg
258 ("some but not all files compiled with Normalize_Scalars");
261 Write_Str
("files compiled with Normalize_Scalars");
264 for A1
in ALIs
.First
.. ALIs
.Last
loop
265 if ALIs
.Table
(A1
).Normalize_Scalars
then
267 Write_Name
(ALIs
.Table
(A1
).Sfile
);
273 Write_Str
("files compiled without Normalize_Scalars");
276 for A1
in ALIs
.First
.. ALIs
.Last
loop
277 if not ALIs
.Table
(A1
).Normalize_Scalars
then
279 Write_Name
(ALIs
.Table
(A1
).Sfile
);
284 end Check_Consistent_Normalize_Scalars
;
286 -------------------------------------
287 -- Check_Consistent_Queuing_Policy --
288 -------------------------------------
290 -- The rule is that all files for which the queuing policy is
291 -- significant must be compiled with the same setting.
293 procedure Check_Consistent_Queuing_Policy
is
295 -- First search for a unit specifying a policy and then
296 -- check all remaining units against it.
298 Find_Policy
: for A1
in ALIs
.First
.. ALIs
.Last
loop
299 if ALIs
.Table
(A1
).Queuing_Policy
/= ' ' then
300 Check_Policy
: declare
301 Policy
: constant Character := ALIs
.Table
(A1
).Queuing_Policy
;
303 for A2
in A1
+ 1 .. ALIs
.Last
loop
304 if ALIs
.Table
(A2
).Queuing_Policy
/= ' '
306 ALIs
.Table
(A2
).Queuing_Policy
/= Policy
308 Error_Msg_Name_1
:= ALIs
.Table
(A1
).Sfile
;
309 Error_Msg_Name_2
:= ALIs
.Table
(A2
).Sfile
;
311 Consistency_Error_Msg
312 ("% and % compiled with different queuing policies");
320 end loop Find_Policy
;
321 end Check_Consistent_Queuing_Policy
;
323 ---------------------------------------------------
324 -- Check_Consistent_Zero_Cost_Exception_Handling --
325 ---------------------------------------------------
327 -- Check consistent zero cost exception handling. The rule is that
328 -- all units must have the same exception handling mechanism.
330 procedure Check_Consistent_Zero_Cost_Exception_Handling
is
332 Check_Mechanism
: for A1
in ALIs
.First
+ 1 .. ALIs
.Last
loop
333 if ALIs
.Table
(A1
).Zero_Cost_Exceptions
/=
334 ALIs
.Table
(ALIs
.First
).Zero_Cost_Exceptions
337 Error_Msg_Name_1
:= ALIs
.Table
(A1
).Sfile
;
338 Error_Msg_Name_2
:= ALIs
.Table
(ALIs
.First
).Sfile
;
340 Consistency_Error_Msg
("% and % compiled with different "
341 & "exception handling mechanisms");
343 end loop Check_Mechanism
;
344 end Check_Consistent_Zero_Cost_Exception_Handling
;
346 ----------------------------------
347 -- Check_Partition_Restrictions --
348 ----------------------------------
350 -- The rule is that if a restriction is specified in any unit,
351 -- then all units must obey the restriction. The check applies
352 -- only to restrictions which require partition wide consistency,
353 -- and not to internal units.
355 -- The check is done in two steps. First for every restriction
356 -- a unit specifying that restriction is found, if any.
357 -- Second, all units are verified against the specified restrictions.
359 procedure Check_Partition_Restrictions
is
360 No_Restriction_List
: array (All_Restrictions
) of Boolean :=
361 (No_Implicit_Conditionals
=> True,
362 -- This could modify and pessimize generated code
364 No_Implicit_Dynamic_Code
=> True,
365 -- This could modify and pessimize generated code
367 No_Implicit_Loops
=> True,
368 -- This could modify and pessimize generated code
370 No_Recursion
=> True,
371 -- Not checkable at compile time
373 No_Reentrancy
=> True,
374 -- Not checkable at compile time
377 -- Define those restrictions that should be output if the gnatbind -r
378 -- switch is used. Not all restrictions are output for the reasons given
379 -- above in the list, and this array is used to test whether the
380 -- corresponding pragma should be listed. True means that it should not
383 R
: array (All_Restrictions
) of ALI_Id
:= (others => No_ALI_Id
);
384 -- Record the first unit specifying each compilation unit restriction
386 V
: array (All_Restrictions
) of ALI_Id
:= (others => No_ALI_Id
);
387 -- Record the last unit violating each partition restriction. Note
388 -- that entries in this array that do not correspond to partition
389 -- restrictions can never be modified.
391 Additional_Restrictions_Listed
: Boolean := False;
392 -- Set True if we have listed header for restrictions
395 -- Loop to find restrictions
397 for A
in ALIs
.First
.. ALIs
.Last
loop
398 for J
in All_Restrictions
loop
399 if R
(J
) = No_ALI_Id
and ALIs
.Table
(A
).Restrictions
(J
) = 'r' then
405 -- Loop to find violations
407 for A
in ALIs
.First
.. ALIs
.Last
loop
408 for J
in All_Restrictions
loop
409 if ALIs
.Table
(A
).Restrictions
(J
) = 'v'
410 and then not Is_Internal_File_Name
(ALIs
.Table
(A
).Sfile
)
412 -- A violation of a restriction was found
416 -- If this is a paritition restriction, and the restriction
417 -- was specified in some unit in the partition, then this
418 -- is a violation of the consistency requirement, so we
419 -- generate an appropriate error message.
421 if R
(J
) /= No_ALI_Id
422 and then J
in Partition_Restrictions
425 M1
: constant String := "% has Restriction (";
426 S
: constant String := Restriction_Id
'Image (J
);
427 M2
: String (1 .. M1
'Length + S
'Length + 1);
430 Name_Buffer
(1 .. S
'Length) := S
;
431 Name_Len
:= S
'Length;
433 (Units
.Table
(ALIs
.Table
(R
(J
)).First_Unit
).Icasing
);
436 M2
(M1
'Length + 1 .. M2
'Last - 1) :=
437 Name_Buffer
(1 .. S
'Length);
440 Error_Msg_Name_1
:= ALIs
.Table
(R
(J
)).Sfile
;
441 Consistency_Error_Msg
(M2
);
442 Error_Msg_Name_1
:= ALIs
.Table
(A
).Sfile
;
443 Consistency_Error_Msg
444 ("but file % violates this restriction");
451 -- List applicable restrictions if option set
453 if List_Restrictions
then
455 -- List any restrictions which were not violated and not specified
457 for J
in All_Restrictions
loop
459 and then R
(J
) = No_ALI_Id
460 and then not No_Restriction_List
(J
)
462 if not Additional_Restrictions_Listed
then
465 ("The following additional restrictions may be" &
466 " applied to this partition:");
467 Additional_Restrictions_Listed
:= True;
470 Write_Str
("pragma Restrictions (");
473 S
: constant String := Restriction_Id
'Image (J
);
476 Name_Len
:= S
'Length;
477 Name_Buffer
(1 .. Name_Len
) := S
;
480 Set_Casing
(Mixed_Case
);
481 Write_Str
(Name_Buffer
(1 .. Name_Len
));
487 end Check_Partition_Restrictions
;
489 -----------------------
490 -- Check_Consistency --
491 -----------------------
493 procedure Check_Consistency
is
495 -- Source file Id for this Sdep entry
498 -- First, we go through the source table to see if there are any cases
499 -- in which we should go after source files and compute checksums of
500 -- the source files. We need to do this for any file for which we have
501 -- mismatching time stamps and (so far) matching checksums.
503 for S
in Source
.First
.. Source
.Last
loop
505 -- If all time stamps for a file match, then there is nothing to
506 -- do, since we will not be checking checksums in that case anyway
508 if Source
.Table
(S
).All_Timestamps_Match
then
511 -- If we did not find the source file, then we can't compute its
512 -- checksum anyway. Note that when we have a time stamp mismatch,
513 -- we try to find the source file unconditionally (i.e. if
514 -- Check_Source_Files is False).
516 elsif not Source
.Table
(S
).Source_Found
then
519 -- If we already have non-matching or missing checksums, then no
520 -- need to try going after source file, since we won't trust the
521 -- checksums in any case.
523 elsif not Source
.Table
(S
).All_Checksums_Match
then
526 -- Now we have the case where we have time stamp mismatches, and
527 -- the source file is around, but so far all checksums match. This
528 -- is the case where we need to compute the checksum from the source
529 -- file, since otherwise we would ignore the time stamp mismatches,
530 -- and that is wrong if the checksum of the source does not agree
531 -- with the checksums in the ALI files.
533 elsif Check_Source_Files
then
534 if not Checksums_Match
535 (Source
.Table
(S
).Checksum
,
536 Get_File_Checksum
(Source
.Table
(S
).Sfile
))
538 Source
.Table
(S
).All_Checksums_Match
:= False;
543 -- Loop through ALI files
545 ALIs_Loop
: for A
in ALIs
.First
.. ALIs
.Last
loop
547 -- Loop through Sdep entries in one ALI file
550 ALIs
.Table
(A
).First_Sdep
.. ALIs
.Table
(A
).Last_Sdep
552 if Sdep
.Table
(D
).Dummy_Entry
then
556 Src
:= Source_Id
(Get_Name_Table_Info
(Sdep
.Table
(D
).Sfile
));
558 -- If the time stamps match, or all checksums match, then we
559 -- are OK, otherwise we have a definite error.
561 if Sdep
.Table
(D
).Stamp
/= Source
.Table
(Src
).Stamp
562 and then not Source
.Table
(Src
).All_Checksums_Match
564 Error_Msg_Name_1
:= ALIs
.Table
(A
).Sfile
;
565 Error_Msg_Name_2
:= Sdep
.Table
(D
).Sfile
;
567 -- Two styles of message, depending on whether or not
568 -- the updated file is the one that must be recompiled
570 if Error_Msg_Name_1
= Error_Msg_Name_2
then
571 if Tolerate_Consistency_Errors
then
573 ("?% has been modified and should be recompiled");
576 ("% has been modified and must be recompiled");
580 if Tolerate_Consistency_Errors
then
582 ("?% should be recompiled (% has been modified)");
585 Error_Msg
("% must be recompiled (% has been modified)");
589 if (not Tolerate_Consistency_Errors
) and Verbose_Mode
then
591 Msg
: constant String := "file % has time stamp ";
592 Buf
: String (1 .. Msg
'Length + Time_Stamp_Length
);
595 Buf
(1 .. Msg
'Length) := Msg
;
596 Buf
(Msg
'Length + 1 .. Buf
'Length) :=
597 String (Source
.Table
(Src
).Stamp
);
598 Error_Msg_Name_1
:= ALIs
.Table
(A
).Sfile
;
601 Buf
(Msg
'Length + 1 .. Buf
'Length) :=
602 String (Sdep
.Table
(D
).Stamp
);
603 Error_Msg_Name_1
:= Sdep
.Table
(D
).Sfile
;
608 -- Exit from the loop through Sdep entries once we find one
609 -- that does not match.
618 end Check_Consistency
;
620 -------------------------------
621 -- Check_Duplicated_Subunits --
622 -------------------------------
624 procedure Check_Duplicated_Subunits
is
626 for J
in Sdep
.First
.. Sdep
.Last
loop
627 if Sdep
.Table
(J
).Subunit_Name
/= No_Name
then
628 Get_Decoded_Name_String
(Sdep
.Table
(J
).Subunit_Name
);
629 Name_Len
:= Name_Len
+ 2;
630 Name_Buffer
(Name_Len
- 1) := '%';
632 -- See if there is a body or spec with the same name
634 for K
in Boolean loop
636 Name_Buffer
(Name_Len
) := 'b';
639 Name_Buffer
(Name_Len
) := 's';
643 Info
: constant Int
:= Get_Name_Table_Info
(Name_Find
);
648 Write_Str
("error: subunit """);
649 Write_Name_Decoded
(Sdep
.Table
(J
).Subunit_Name
);
650 Write_Str
(""" in file """);
651 Write_Name_Decoded
(Sdep
.Table
(J
).Sfile
);
654 Write_Str
(" has same name as unit """);
655 Write_Unit_Name
(Units
.Table
(Unit_Id
(Info
)).Uname
);
656 Write_Str
(""" found in file """);
657 Write_Name_Decoded
(Units
.Table
(Unit_Id
(Info
)).Sfile
);
660 Write_Str
(" this is not allowed within a single "
661 & "partition (RM 10.2(19))");
663 Osint
.Exit_Program
(Osint
.E_Fatal
);
669 end Check_Duplicated_Subunits
;
675 procedure Check_Versions
is
676 VL
: constant Natural := ALIs
.Table
(ALIs
.First
).Ver_Len
;
679 for A
in ALIs
.First
.. ALIs
.Last
loop
680 if ALIs
.Table
(A
).Ver_Len
/= VL
681 or else ALIs
.Table
(A
).Ver
(1 .. VL
) /=
682 ALIs
.Table
(ALIs
.First
).Ver
(1 .. VL
)
684 Error_Msg_Name_1
:= ALIs
.Table
(A
).Sfile
;
685 Error_Msg_Name_2
:= ALIs
.Table
(ALIs
.First
).Sfile
;
687 Consistency_Error_Msg
688 ("% and % compiled with different GNAT versions");
693 ---------------------------
694 -- Consistency_Error_Msg --
695 ---------------------------
697 procedure Consistency_Error_Msg
(Msg
: String) is
699 if Tolerate_Consistency_Errors
then
701 -- If consistency errors are tolerated,
702 -- output the message as a warning.
705 Warning_Msg
: String (1 .. Msg
'Length + 1);
708 Warning_Msg
(1) := '?';
709 Warning_Msg
(2 .. Warning_Msg
'Last) := Msg
;
711 Error_Msg
(Warning_Msg
);
714 -- Otherwise the consistency error is a true error
719 end Consistency_Error_Msg
;