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