1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2002 Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 2, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING. If not, write --
19 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
20 -- MA 02111-1307, USA. --
22 -- GNAT was originally developed by the GNAT team at New York University. --
23 -- Extensive contributions were provided by Ada Core Technologies Inc. --
25 ------------------------------------------------------------------------------
28 with ALI
.Util
; use ALI
.Util
;
29 with Binderr
; use Binderr
;
30 with Butil
; use Butil
;
31 with Casing
; use Casing
;
32 with Fname
; use Fname
;
33 with Namet
; use Namet
;
36 with Output
; use Output
;
37 with Rident
; use Rident
;
38 with Types
; use Types
;
40 package body Bcheck
is
44 -- The following checking subprograms make up the parts
45 -- of the configuration consistency check.
47 procedure Check_Consistent_Dynamic_Elaboration_Checking
;
48 procedure Check_Consistent_Floating_Point_Format
;
49 procedure Check_Consistent_Locking_Policy
;
50 procedure Check_Consistent_Normalize_Scalars
;
51 procedure Check_Consistent_Queuing_Policy
;
52 procedure Check_Consistent_Zero_Cost_Exception_Handling
;
53 procedure Check_Partition_Restrictions
;
55 procedure Consistency_Error_Msg
(Msg
: String);
56 -- Produce an error or a warning message, depending on whether
57 -- an inconsistent configuration is permitted or not.
59 ------------------------------------
60 -- Check_Consistent_Configuration --
61 ------------------------------------
63 procedure Check_Configuration_Consistency
is
65 if Float_Format_Specified
/= ' ' then
66 Check_Consistent_Floating_Point_Format
;
69 if Queuing_Policy_Specified
/= ' ' then
70 Check_Consistent_Queuing_Policy
;
73 if Locking_Policy_Specified
/= ' ' then
74 Check_Consistent_Locking_Policy
;
77 if Zero_Cost_Exceptions_Specified
then
78 Check_Consistent_Zero_Cost_Exception_Handling
;
81 Check_Consistent_Normalize_Scalars
;
82 Check_Consistent_Dynamic_Elaboration_Checking
;
84 Check_Partition_Restrictions
;
85 end Check_Configuration_Consistency
;
87 ---------------------------------------------------
88 -- Check_Consistent_Dynamic_Elaboration_Checking --
89 ---------------------------------------------------
91 -- The rule here is that if a unit has dynamic elaboration checks,
92 -- then any unit it withs must meeting one of the following criteria:
94 -- 1. There is a pragma Elaborate_All for the with'ed unit
95 -- 2. The with'ed unit was compiled with dynamic elaboration checks
96 -- 3. The with'ed unit has pragma Preelaborate or Pure
97 -- 4. It is an internal GNAT unit (including children of GNAT)
99 procedure Check_Consistent_Dynamic_Elaboration_Checking
is
101 if Dynamic_Elaboration_Checks_Specified
then
102 for U
in First_Unit_Entry
.. Units
.Last
loop
104 UR
: Unit_Record
renames Units
.Table
(U
);
107 if UR
.Dynamic_Elab
then
108 for W
in UR
.First_With
.. UR
.Last_With
loop
110 WR
: With_Record
renames Withs
.Table
(W
);
113 if Get_Name_Table_Info
(WR
.Uname
) /= 0 then
115 WU
: Unit_Record
renames
118 (Get_Name_Table_Info
(WR
.Uname
)));
121 -- Case 1. Elaborate_All for with'ed unit
123 if WR
.Elaborate_All
then
126 -- Case 2. With'ed unit has dynamic elab checks
128 elsif WU
.Dynamic_Elab
then
131 -- Case 3. With'ed unit is Preelaborate or Pure
133 elsif WU
.Preelab
or WU
.Pure
then
136 -- Case 4. With'ed unit is internal file
138 elsif Is_Internal_File_Name
(WU
.Sfile
) then
141 -- Issue warning, not one of the safe cases
144 Error_Msg_Name_1
:= UR
.Sfile
;
146 ("?% has dynamic elaboration checks " &
149 Error_Msg_Name_1
:= WU
.Sfile
;
151 ("? % which has static elaboration " &
154 Warnings_Detected
:= Warnings_Detected
- 1;
164 end Check_Consistent_Dynamic_Elaboration_Checking
;
166 --------------------------------------------
167 -- Check_Consistent_Floating_Point_Format --
168 --------------------------------------------
170 -- The rule is that all files must be compiled with the same setting
171 -- for the floating-point format.
173 procedure Check_Consistent_Floating_Point_Format
is
175 -- First search for a unit specifying a floating-point format and then
176 -- check all remaining units against it.
178 Find_Format
: for A1
in ALIs
.First
.. ALIs
.Last
loop
179 if ALIs
.Table
(A1
).Float_Format
/= ' ' then
180 Check_Format
: declare
181 Format
: constant Character := ALIs
.Table
(A1
).Float_Format
;
183 for A2
in A1
+ 1 .. ALIs
.Last
loop
184 if ALIs
.Table
(A2
).Float_Format
/= Format
then
185 Error_Msg_Name_1
:= ALIs
.Table
(A1
).Sfile
;
186 Error_Msg_Name_2
:= ALIs
.Table
(A2
).Sfile
;
188 Consistency_Error_Msg
189 ("% and % compiled with different " &
190 "floating-point representations");
198 end loop Find_Format
;
199 end Check_Consistent_Floating_Point_Format
;
201 -------------------------------------
202 -- Check_Consistent_Locking_Policy --
203 -------------------------------------
205 -- The rule is that all files for which the locking policy is
206 -- significant must be compiled with the same setting.
208 procedure Check_Consistent_Locking_Policy
is
210 -- First search for a unit specifying a policy and then
211 -- check all remaining units against it.
213 Find_Policy
: for A1
in ALIs
.First
.. ALIs
.Last
loop
214 if ALIs
.Table
(A1
).Locking_Policy
/= ' ' then
215 Check_Policy
: declare
216 Policy
: constant Character := ALIs
.Table
(A1
).Locking_Policy
;
219 for A2
in A1
+ 1 .. ALIs
.Last
loop
220 if ALIs
.Table
(A2
).Locking_Policy
/= ' ' and
221 ALIs
.Table
(A2
).Locking_Policy
/= Policy
223 Error_Msg_Name_1
:= ALIs
.Table
(A1
).Sfile
;
224 Error_Msg_Name_2
:= ALIs
.Table
(A2
).Sfile
;
226 Consistency_Error_Msg
227 ("% and % compiled with different locking policies");
235 end loop Find_Policy
;
236 end Check_Consistent_Locking_Policy
;
238 ----------------------------------------
239 -- Check_Consistent_Normalize_Scalars --
240 ----------------------------------------
242 -- The rule is that if any unit is compiled with Normalized_Scalars,
243 -- then all other units in the partition must also be compiled with
244 -- Normalized_Scalars in effect.
246 -- There is some issue as to whether this consistency check is
247 -- desirable, it is certainly required at the moment by the RM.
248 -- We should keep a watch on the ARG and HRG deliberations here.
249 -- GNAT no longer depends on this consistency (it used to do so,
250 -- but that has been corrected in the latest version, since the
251 -- Initialize_Scalars pragma does not require consistency.
253 procedure Check_Consistent_Normalize_Scalars
is
255 if Normalize_Scalars_Specified
and No_Normalize_Scalars_Specified
then
256 Consistency_Error_Msg
257 ("some but not all files compiled with Normalize_Scalars");
260 Write_Str
("files compiled with Normalize_Scalars");
263 for A1
in ALIs
.First
.. ALIs
.Last
loop
264 if ALIs
.Table
(A1
).Normalize_Scalars
then
266 Write_Name
(ALIs
.Table
(A1
).Sfile
);
272 Write_Str
("files compiled without Normalize_Scalars");
275 for A1
in ALIs
.First
.. ALIs
.Last
loop
276 if not ALIs
.Table
(A1
).Normalize_Scalars
then
278 Write_Name
(ALIs
.Table
(A1
).Sfile
);
283 end Check_Consistent_Normalize_Scalars
;
285 -------------------------------------
286 -- Check_Consistent_Queuing_Policy --
287 -------------------------------------
289 -- The rule is that all files for which the queuing policy is
290 -- significant must be compiled with the same setting.
292 procedure Check_Consistent_Queuing_Policy
is
294 -- First search for a unit specifying a policy and then
295 -- check all remaining units against it.
297 Find_Policy
: for A1
in ALIs
.First
.. ALIs
.Last
loop
298 if ALIs
.Table
(A1
).Queuing_Policy
/= ' ' then
299 Check_Policy
: declare
300 Policy
: constant Character := ALIs
.Table
(A1
).Queuing_Policy
;
302 for A2
in A1
+ 1 .. ALIs
.Last
loop
303 if ALIs
.Table
(A2
).Queuing_Policy
/= ' '
305 ALIs
.Table
(A2
).Queuing_Policy
/= Policy
307 Error_Msg_Name_1
:= ALIs
.Table
(A1
).Sfile
;
308 Error_Msg_Name_2
:= ALIs
.Table
(A2
).Sfile
;
310 Consistency_Error_Msg
311 ("% and % compiled with different queuing policies");
319 end loop Find_Policy
;
320 end Check_Consistent_Queuing_Policy
;
322 ---------------------------------------------------
323 -- Check_Consistent_Zero_Cost_Exception_Handling --
324 ---------------------------------------------------
326 -- Check consistent zero cost exception handling. The rule is that
327 -- all units must have the same exception handling mechanism.
329 procedure Check_Consistent_Zero_Cost_Exception_Handling
is
331 Check_Mechanism
: for A1
in ALIs
.First
+ 1 .. ALIs
.Last
loop
332 if ALIs
.Table
(A1
).Zero_Cost_Exceptions
/=
333 ALIs
.Table
(ALIs
.First
).Zero_Cost_Exceptions
336 Error_Msg_Name_1
:= ALIs
.Table
(A1
).Sfile
;
337 Error_Msg_Name_2
:= ALIs
.Table
(ALIs
.First
).Sfile
;
339 Consistency_Error_Msg
("% and % compiled with different "
340 & "exception handling mechanisms");
342 end loop Check_Mechanism
;
343 end Check_Consistent_Zero_Cost_Exception_Handling
;
345 ----------------------------------
346 -- Check_Partition_Restrictions --
347 ----------------------------------
349 -- The rule is that if a restriction is specified in any unit,
350 -- then all units must obey the restriction. The check applies
351 -- only to restrictions which require partition wide consistency,
352 -- and not to internal units.
354 -- The check is done in two steps. First for every restriction
355 -- a unit specifying that restriction is found, if any.
356 -- Second, all units are verified against the specified restrictions.
358 procedure Check_Partition_Restrictions
is
359 No_Restriction_List
: array (All_Restrictions
) of Boolean :=
360 (No_Implicit_Conditionals
=> True,
361 -- This could modify and pessimize generated code
363 No_Implicit_Dynamic_Code
=> True,
364 -- This could modify and pessimize generated code
366 No_Implicit_Loops
=> True,
367 -- This could modify and pessimize generated code
369 No_Recursion
=> True,
370 -- Not checkable at compile time
372 No_Reentrancy
=> True,
373 -- Not checkable at compile time
376 -- Define those restrictions that should be output if the gnatbind -r
377 -- switch is used. Not all restrictions are output for the reasons given
378 -- above in the list, and this array is used to test whether the
379 -- corresponding pragma should be listed. True means that it should not
382 R
: array (All_Restrictions
) of ALI_Id
:= (others => No_ALI_Id
);
383 -- Record the first unit specifying each compilation unit restriction
385 V
: array (All_Restrictions
) of ALI_Id
:= (others => No_ALI_Id
);
386 -- Record the last unit violating each partition restriction. Note
387 -- that entries in this array that do not correspond to partition
388 -- restrictions can never be modified.
390 Additional_Restrictions_Listed
: Boolean := False;
391 -- Set True if we have listed header for restrictions
394 -- Loop to find restrictions
396 for A
in ALIs
.First
.. ALIs
.Last
loop
397 for J
in All_Restrictions
loop
398 if R
(J
) = No_ALI_Id
and ALIs
.Table
(A
).Restrictions
(J
) = 'r' then
404 -- Loop to find violations
406 for A
in ALIs
.First
.. ALIs
.Last
loop
407 for J
in All_Restrictions
loop
408 if ALIs
.Table
(A
).Restrictions
(J
) = 'v'
409 and then not Is_Internal_File_Name
(ALIs
.Table
(A
).Sfile
)
411 -- A violation of a restriction was found
415 -- If this is a paritition restriction, and the restriction
416 -- was specified in some unit in the partition, then this
417 -- is a violation of the consistency requirement, so we
418 -- generate an appropriate error message.
420 if R
(J
) /= No_ALI_Id
421 and then J
in Partition_Restrictions
424 M1
: constant String := "% has Restriction (";
425 S
: constant String := Restriction_Id
'Image (J
);
426 M2
: String (1 .. M1
'Length + S
'Length + 1);
429 Name_Buffer
(1 .. S
'Length) := S
;
430 Name_Len
:= S
'Length;
432 (Units
.Table
(ALIs
.Table
(R
(J
)).First_Unit
).Icasing
);
435 M2
(M1
'Length + 1 .. M2
'Last - 1) :=
436 Name_Buffer
(1 .. S
'Length);
439 Error_Msg_Name_1
:= ALIs
.Table
(R
(J
)).Sfile
;
440 Consistency_Error_Msg
(M2
);
441 Error_Msg_Name_1
:= ALIs
.Table
(A
).Sfile
;
442 Consistency_Error_Msg
443 ("but file % violates this restriction");
450 -- List applicable restrictions if option set
452 if List_Restrictions
then
454 -- List any restrictions which were not violated and not specified
456 for J
in All_Restrictions
loop
458 and then R
(J
) = No_ALI_Id
459 and then not No_Restriction_List
(J
)
461 if not Additional_Restrictions_Listed
then
464 ("The following additional restrictions may be" &
465 " applied to this partition:");
466 Additional_Restrictions_Listed
:= True;
469 Write_Str
("pragma Restrictions (");
472 S
: constant String := Restriction_Id
'Image (J
);
475 Name_Len
:= S
'Length;
476 Name_Buffer
(1 .. Name_Len
) := S
;
479 Set_Casing
(Mixed_Case
);
480 Write_Str
(Name_Buffer
(1 .. Name_Len
));
486 end Check_Partition_Restrictions
;
488 -----------------------
489 -- Check_Consistency --
490 -----------------------
492 procedure Check_Consistency
is
494 -- Source file Id for this Sdep entry
497 -- First, we go through the source table to see if there are any cases
498 -- in which we should go after source files and compute checksums of
499 -- the source files. We need to do this for any file for which we have
500 -- mismatching time stamps and (so far) matching checksums.
502 for S
in Source
.First
.. Source
.Last
loop
504 -- If all time stamps for a file match, then there is nothing to
505 -- do, since we will not be checking checksums in that case anyway
507 if Source
.Table
(S
).All_Timestamps_Match
then
510 -- If we did not find the source file, then we can't compute its
511 -- checksum anyway. Note that when we have a time stamp mismatch,
512 -- we try to find the source file unconditionally (i.e. if
513 -- Check_Source_Files is False).
515 elsif not Source
.Table
(S
).Source_Found
then
518 -- If we already have non-matching or missing checksums, then no
519 -- need to try going after source file, since we won't trust the
520 -- checksums in any case.
522 elsif not Source
.Table
(S
).All_Checksums_Match
then
525 -- Now we have the case where we have time stamp mismatches, and
526 -- the source file is around, but so far all checksums match. This
527 -- is the case where we need to compute the checksum from the source
528 -- file, since otherwise we would ignore the time stamp mismatches,
529 -- and that is wrong if the checksum of the source does not agree
530 -- with the checksums in the ALI files.
532 elsif Check_Source_Files
then
533 if not Checksums_Match
534 (Source
.Table
(S
).Checksum
,
535 Get_File_Checksum
(Source
.Table
(S
).Sfile
))
537 Source
.Table
(S
).All_Checksums_Match
:= False;
542 -- Loop through ALI files
544 ALIs_Loop
: for A
in ALIs
.First
.. ALIs
.Last
loop
546 -- Loop through Sdep entries in one ALI file
549 ALIs
.Table
(A
).First_Sdep
.. ALIs
.Table
(A
).Last_Sdep
551 if Sdep
.Table
(D
).Dummy_Entry
then
555 Src
:= Source_Id
(Get_Name_Table_Info
(Sdep
.Table
(D
).Sfile
));
557 -- If the time stamps match, or all checksums match, then we
558 -- are OK, otherwise we have a definite error.
560 if Sdep
.Table
(D
).Stamp
/= Source
.Table
(Src
).Stamp
561 and then not Source
.Table
(Src
).All_Checksums_Match
563 Error_Msg_Name_1
:= ALIs
.Table
(A
).Sfile
;
564 Error_Msg_Name_2
:= Sdep
.Table
(D
).Sfile
;
566 -- Two styles of message, depending on whether or not
567 -- the updated file is the one that must be recompiled
569 if Error_Msg_Name_1
= Error_Msg_Name_2
then
570 if Tolerate_Consistency_Errors
then
572 ("?% has been modified and should be recompiled");
575 ("% has been modified and must be recompiled");
579 if Tolerate_Consistency_Errors
then
581 ("?% should be recompiled (% has been modified)");
584 Error_Msg
("% must be recompiled (% has been modified)");
588 if (not Tolerate_Consistency_Errors
) and Verbose_Mode
then
590 Msg
: constant String := "file % has time stamp ";
591 Buf
: String (1 .. Msg
'Length + Time_Stamp_Length
);
594 Buf
(1 .. Msg
'Length) := Msg
;
595 Buf
(Msg
'Length + 1 .. Buf
'Length) :=
596 String (Source
.Table
(Src
).Stamp
);
597 Error_Msg_Name_1
:= ALIs
.Table
(A
).Sfile
;
600 Buf
(Msg
'Length + 1 .. Buf
'Length) :=
601 String (Sdep
.Table
(D
).Stamp
);
602 Error_Msg_Name_1
:= Sdep
.Table
(D
).Sfile
;
607 -- Exit from the loop through Sdep entries once we find one
608 -- that does not match.
617 end Check_Consistency
;
619 -------------------------------
620 -- Check_Duplicated_Subunits --
621 -------------------------------
623 procedure Check_Duplicated_Subunits
is
625 for J
in Sdep
.First
.. Sdep
.Last
loop
626 if Sdep
.Table
(J
).Subunit_Name
/= No_Name
then
627 Get_Decoded_Name_String
(Sdep
.Table
(J
).Subunit_Name
);
628 Name_Len
:= Name_Len
+ 2;
629 Name_Buffer
(Name_Len
- 1) := '%';
631 -- See if there is a body or spec with the same name
633 for K
in Boolean loop
635 Name_Buffer
(Name_Len
) := 'b';
638 Name_Buffer
(Name_Len
) := 's';
642 Info
: constant Int
:= Get_Name_Table_Info
(Name_Find
);
647 Write_Str
("error: subunit """);
648 Write_Name_Decoded
(Sdep
.Table
(J
).Subunit_Name
);
649 Write_Str
(""" in file """);
650 Write_Name_Decoded
(Sdep
.Table
(J
).Sfile
);
653 Write_Str
(" has same name as unit """);
654 Write_Unit_Name
(Units
.Table
(Unit_Id
(Info
)).Uname
);
655 Write_Str
(""" found in file """);
656 Write_Name_Decoded
(Units
.Table
(Unit_Id
(Info
)).Sfile
);
659 Write_Str
(" this is not allowed within a single "
660 & "partition (RM 10.2(19))");
662 Osint
.Exit_Program
(Osint
.E_Fatal
);
668 end Check_Duplicated_Subunits
;
674 procedure Check_Versions
is
675 VL
: constant Natural := ALIs
.Table
(ALIs
.First
).Ver_Len
;
678 for A
in ALIs
.First
.. ALIs
.Last
loop
679 if ALIs
.Table
(A
).Ver_Len
/= VL
680 or else ALIs
.Table
(A
).Ver
(1 .. VL
) /=
681 ALIs
.Table
(ALIs
.First
).Ver
(1 .. VL
)
683 Error_Msg_Name_1
:= ALIs
.Table
(A
).Sfile
;
684 Error_Msg_Name_2
:= ALIs
.Table
(ALIs
.First
).Sfile
;
686 Consistency_Error_Msg
687 ("% and % compiled with different GNAT versions");
692 ---------------------------
693 -- Consistency_Error_Msg --
694 ---------------------------
696 procedure Consistency_Error_Msg
(Msg
: String) is
698 if Tolerate_Consistency_Errors
then
700 -- If consistency errors are tolerated,
701 -- output the message as a warning.
704 Warning_Msg
: String (1 .. Msg
'Length + 1);
707 Warning_Msg
(1) := '?';
708 Warning_Msg
(2 .. Warning_Msg
'Last) := Msg
;
710 Error_Msg
(Warning_Msg
);
713 -- Otherwise the consistency error is a true error
718 end Consistency_Error_Msg
;