OpenCores
URL https://opencores.org/ocsvn/openrisc/openrisc/trunk

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [ada/] [bcheck.adb] - Blame information for rev 729

Go to most recent revision | Details | Compare with Previous | View Log

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

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.