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

Subversion Repositories openrisc

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

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 706 jeremybenn
------------------------------------------------------------------------------
2
--                                                                          --
3
--                         GNAT COMPILER COMPONENTS                         --
4
--                                                                          --
5
--                             R E S T R I C T                              --
6
--                                                                          --
7
--                                 B o d y                                  --
8
--                                                                          --
9
--          Copyright (C) 1992-2012, 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 Aspects;  use Aspects;
27
with Atree;    use Atree;
28
with Casing;   use Casing;
29
with Einfo;    use Einfo;
30
with Errout;   use Errout;
31
with Debug;    use Debug;
32
with Fname;    use Fname;
33
with Fname.UF; use Fname.UF;
34
with Lib;      use Lib;
35
with Opt;      use Opt;
36
with Sinfo;    use Sinfo;
37
with Sinput;   use Sinput;
38
with Snames;   use Snames;
39
with Stand;    use Stand;
40
with Uname;    use Uname;
41
 
42
package body Restrict is
43
 
44
   Config_Cunit_Boolean_Restrictions : Save_Cunit_Boolean_Restrictions;
45
   --  Save compilation unit restrictions set by config pragma files
46
 
47
   Restricted_Profile_Result : Boolean := False;
48
   --  This switch memoizes the result of Restricted_Profile function calls for
49
   --  improved efficiency. Valid only if Restricted_Profile_Cached is True.
50
   --  Note: if this switch is ever set True, it is never turned off again.
51
 
52
   Restricted_Profile_Cached : Boolean := False;
53
   --  This flag is set to True if the Restricted_Profile_Result contains the
54
   --  correct cached result of Restricted_Profile calls.
55
 
56
   No_Specification_Of_Aspects : array (Aspect_Id) of Source_Ptr :=
57
                                   (others => No_Location);
58
   --  Entries in this array are set to point to a previously occuring pragma
59
   --  that activates a No_Specification_Of_Aspect check.
60
 
61
   No_Specification_Of_Aspect_Warning : array (Aspect_Id) of Boolean :=
62
                                          (others => True);
63
   --  An entry in this array is set False in reponse to a previous call to
64
   --  Set_No_Speficiation_Of_Aspect for pragmas in the main unit that
65
   --  specify Warning as False. Once set False, an entry is never reset.
66
 
67
   No_Specification_Of_Aspect_Set : Boolean := False;
68
   --  Set True if any entry of No_Specifcation_Of_Aspects has been set True.
69
   --  Once set True, this is never turned off again.
70
 
71
   -----------------------
72
   -- Local Subprograms --
73
   -----------------------
74
 
75
   procedure Restriction_Msg (R : Restriction_Id; N : Node_Id);
76
   --  Called if a violation of restriction R at node N is found. This routine
77
   --  outputs the appropriate message or messages taking care of warning vs
78
   --  real violation, serious vs non-serious, implicit vs explicit, the second
79
   --  message giving the profile name if needed, and the location information.
80
 
81
   function Same_Unit (U1, U2 : Node_Id) return Boolean;
82
   --  Returns True iff U1 and U2 represent the same library unit. Used for
83
   --  handling of No_Dependence => Unit restriction case.
84
 
85
   function Suppress_Restriction_Message (N : Node_Id) return Boolean;
86
   --  N is the node for a possible restriction violation message, but the
87
   --  message is to be suppressed if this is an internal file and this file is
88
   --  not the main unit. Returns True if message is to be suppressed.
89
 
90
   -------------------
91
   -- Abort_Allowed --
92
   -------------------
93
 
94
   function Abort_Allowed return Boolean is
95
   begin
96
      if Restrictions.Set (No_Abort_Statements)
97
        and then Restrictions.Set (Max_Asynchronous_Select_Nesting)
98
        and then Restrictions.Value (Max_Asynchronous_Select_Nesting) = 0
99
      then
100
         return False;
101
      else
102
         return True;
103
      end if;
104
   end Abort_Allowed;
105
 
106
   ----------------------------------------
107
   -- Add_To_Config_Boolean_Restrictions --
108
   ----------------------------------------
109
 
110
   procedure Add_To_Config_Boolean_Restrictions (R : Restriction_Id) is
111
   begin
112
      Config_Cunit_Boolean_Restrictions (R) := True;
113
   end Add_To_Config_Boolean_Restrictions;
114
   --  Add specified restriction to stored configuration boolean restrictions.
115
   --  This is used for handling the special case of No_Elaboration_Code.
116
 
117
   -------------------------
118
   -- Check_Compiler_Unit --
119
   -------------------------
120
 
121
   procedure Check_Compiler_Unit (N : Node_Id) is
122
   begin
123
      if Is_Compiler_Unit (Get_Source_Unit (N)) then
124
         Error_Msg_N ("use of construct not allowed in compiler", N);
125
      end if;
126
   end Check_Compiler_Unit;
127
 
128
   ------------------------------------
129
   -- Check_Elaboration_Code_Allowed --
130
   ------------------------------------
131
 
132
   procedure Check_Elaboration_Code_Allowed (N : Node_Id) is
133
   begin
134
      Check_Restriction (No_Elaboration_Code, N);
135
   end Check_Elaboration_Code_Allowed;
136
 
137
   -----------------------------
138
   -- Check_SPARK_Restriction --
139
   -----------------------------
140
 
141
   procedure Check_SPARK_Restriction
142
     (Msg   : String;
143
      N     : Node_Id;
144
      Force : Boolean := False)
145
   is
146
      Msg_Issued          : Boolean;
147
      Save_Error_Msg_Sloc : Source_Ptr;
148
   begin
149
      if Force or else Comes_From_Source (Original_Node (N)) then
150
 
151
         if Restriction_Check_Required (SPARK)
152
           and then Is_In_Hidden_Part_In_SPARK (Sloc (N))
153
         then
154
            return;
155
         end if;
156
 
157
         --  Since the call to Restriction_Msg from Check_Restriction may set
158
         --  Error_Msg_Sloc to the location of the pragma restriction, save and
159
         --  restore the previous value of the global variable around the call.
160
 
161
         Save_Error_Msg_Sloc := Error_Msg_Sloc;
162
         Check_Restriction (Msg_Issued, SPARK, First_Node (N));
163
         Error_Msg_Sloc := Save_Error_Msg_Sloc;
164
 
165
         if Msg_Issued then
166
            Error_Msg_F ("\\| " & Msg, N);
167
         end if;
168
      end if;
169
   end Check_SPARK_Restriction;
170
 
171
   procedure Check_SPARK_Restriction (Msg1, Msg2 : String; N : Node_Id) is
172
      Msg_Issued          : Boolean;
173
      Save_Error_Msg_Sloc : Source_Ptr;
174
   begin
175
      pragma Assert (Msg2'Length /= 0 and then Msg2 (Msg2'First) = '\');
176
 
177
      if Comes_From_Source (Original_Node (N)) then
178
 
179
         if Restriction_Check_Required (SPARK)
180
           and then Is_In_Hidden_Part_In_SPARK (Sloc (N))
181
         then
182
            return;
183
         end if;
184
 
185
         --  Since the call to Restriction_Msg from Check_Restriction may set
186
         --  Error_Msg_Sloc to the location of the pragma restriction, save and
187
         --  restore the previous value of the global variable around the call.
188
 
189
         Save_Error_Msg_Sloc := Error_Msg_Sloc;
190
         Check_Restriction (Msg_Issued, SPARK, First_Node (N));
191
         Error_Msg_Sloc := Save_Error_Msg_Sloc;
192
 
193
         if Msg_Issued then
194
            Error_Msg_F ("\\| " & Msg1, N);
195
            Error_Msg_F (Msg2, N);
196
         end if;
197
      end if;
198
   end Check_SPARK_Restriction;
199
 
200
   --------------------------------
201
   -- Check_No_Implicit_Aliasing --
202
   --------------------------------
203
 
204
   procedure Check_No_Implicit_Aliasing (Obj : Node_Id) is
205
      E : Entity_Id;
206
 
207
   begin
208
      --  If restriction not active, nothing to check
209
 
210
      if not Restriction_Active (No_Implicit_Aliasing) then
211
         return;
212
      end if;
213
 
214
      --  If we have an entity name, check entity
215
 
216
      if Is_Entity_Name (Obj) then
217
         E := Entity (Obj);
218
 
219
         --  Restriction applies to entities that are objects
220
 
221
         if Is_Object (E) then
222
            if Is_Aliased (E) then
223
               return;
224
 
225
            elsif Present (Renamed_Object (E)) then
226
               Check_No_Implicit_Aliasing (Renamed_Object (E));
227
               return;
228
            end if;
229
 
230
         --  If we don't have an object, then it's OK
231
 
232
         else
233
            return;
234
         end if;
235
 
236
      --  For selected component, check selector
237
 
238
      elsif Nkind (Obj) = N_Selected_Component then
239
         Check_No_Implicit_Aliasing (Selector_Name (Obj));
240
         return;
241
 
242
      --  Indexed component is OK if aliased components
243
 
244
      elsif Nkind (Obj) = N_Indexed_Component then
245
         if Has_Aliased_Components (Etype (Prefix (Obj)))
246
           or else
247
             (Is_Access_Type (Etype (Prefix (Obj)))
248
               and then Has_Aliased_Components
249
                          (Designated_Type (Etype (Prefix (Obj)))))
250
         then
251
            return;
252
         end if;
253
 
254
      --  For type conversion, check converted expression
255
 
256
      elsif Nkind_In (Obj, N_Unchecked_Type_Conversion, N_Type_Conversion) then
257
         Check_No_Implicit_Aliasing (Expression (Obj));
258
         return;
259
 
260
      --  Explicit dereference is always OK
261
 
262
      elsif Nkind (Obj) = N_Explicit_Dereference then
263
         return;
264
      end if;
265
 
266
      --  If we fall through, then we have an aliased view that does not meet
267
      --  the rules for being explicitly aliased, so issue restriction msg.
268
 
269
      Check_Restriction (No_Implicit_Aliasing, Obj);
270
   end Check_No_Implicit_Aliasing;
271
 
272
   -----------------------------------------
273
   -- Check_Implicit_Dynamic_Code_Allowed --
274
   -----------------------------------------
275
 
276
   procedure Check_Implicit_Dynamic_Code_Allowed (N : Node_Id) is
277
   begin
278
      Check_Restriction (No_Implicit_Dynamic_Code, N);
279
   end Check_Implicit_Dynamic_Code_Allowed;
280
 
281
   ----------------------------------
282
   -- Check_No_Implicit_Heap_Alloc --
283
   ----------------------------------
284
 
285
   procedure Check_No_Implicit_Heap_Alloc (N : Node_Id) is
286
   begin
287
      Check_Restriction (No_Implicit_Heap_Allocations, N);
288
   end Check_No_Implicit_Heap_Alloc;
289
 
290
   -----------------------------------
291
   -- Check_Obsolescent_2005_Entity --
292
   -----------------------------------
293
 
294
   procedure Check_Obsolescent_2005_Entity (E : Entity_Id; N : Node_Id) is
295
      function Chars_Is (E : Entity_Id; S : String) return Boolean;
296
      --  Return True iff Chars (E) matches S (given in lower case)
297
 
298
      function Chars_Is (E : Entity_Id; S : String) return Boolean is
299
         Nam : constant Name_Id := Chars (E);
300
      begin
301
         if Length_Of_Name (Nam) /= S'Length then
302
            return False;
303
         else
304
            return Get_Name_String (Nam) = S;
305
         end if;
306
      end Chars_Is;
307
 
308
   --  Start of processing for Check_Obsolescent_2005_Entity
309
 
310
   begin
311
      if Restriction_Check_Required (No_Obsolescent_Features)
312
        and then Ada_Version >= Ada_2005
313
        and then Chars_Is (Scope (E),                 "handling")
314
        and then Chars_Is (Scope (Scope (E)),         "characters")
315
        and then Chars_Is (Scope (Scope (Scope (E))), "ada")
316
        and then Scope (Scope (Scope (Scope (E)))) = Standard_Standard
317
      then
318
         if Chars_Is (E, "is_character")      or else
319
            Chars_Is (E, "is_string")         or else
320
            Chars_Is (E, "to_character")      or else
321
            Chars_Is (E, "to_string")         or else
322
            Chars_Is (E, "to_wide_character") or else
323
            Chars_Is (E, "to_wide_string")
324
         then
325
            Check_Restriction (No_Obsolescent_Features, N);
326
         end if;
327
      end if;
328
   end Check_Obsolescent_2005_Entity;
329
 
330
   ---------------------------
331
   -- Check_Restricted_Unit --
332
   ---------------------------
333
 
334
   procedure Check_Restricted_Unit (U : Unit_Name_Type; N : Node_Id) is
335
   begin
336
      if Suppress_Restriction_Message (N) then
337
         return;
338
 
339
      elsif Is_Spec_Name (U) then
340
         declare
341
            Fnam : constant File_Name_Type :=
342
                     Get_File_Name (U, Subunit => False);
343
 
344
         begin
345
            --  Get file name
346
 
347
            Get_Name_String (Fnam);
348
 
349
            --  Nothing to do if name not at least 5 characters long ending
350
            --  in .ads or .adb extension, which we strip.
351
 
352
            if Name_Len < 5
353
              or else (Name_Buffer (Name_Len - 3 .. Name_Len) /= ".ads"
354
                         and then
355
                       Name_Buffer (Name_Len - 3 .. Name_Len) /= ".adb")
356
            then
357
               return;
358
            end if;
359
 
360
            --  Strip extension and pad to eight characters
361
 
362
            Name_Len := Name_Len - 4;
363
            Add_Str_To_Name_Buffer ((Name_Len + 1 .. 8 => ' '));
364
 
365
            --  If predefined unit, check the list of restricted units
366
 
367
            if Is_Predefined_File_Name (Fnam) then
368
               for J in Unit_Array'Range loop
369
                  if Name_Len = 8
370
                    and then Name_Buffer (1 .. 8) = Unit_Array (J).Filenm
371
                  then
372
                     Check_Restriction (Unit_Array (J).Res_Id, N);
373
                  end if;
374
               end loop;
375
 
376
               --  If not predefined unit, then one special check still
377
               --  remains. GNAT.Current_Exception is not allowed if we have
378
               --  restriction No_Exception_Propagation active.
379
 
380
            else
381
               if Name_Buffer (1 .. 8) = "g-curexc" then
382
                  Check_Restriction (No_Exception_Propagation, N);
383
               end if;
384
            end if;
385
         end;
386
      end if;
387
   end Check_Restricted_Unit;
388
 
389
   -----------------------
390
   -- Check_Restriction --
391
   -----------------------
392
 
393
   procedure Check_Restriction
394
     (R : Restriction_Id;
395
      N : Node_Id;
396
      V : Uint := Uint_Minus_1)
397
   is
398
      Msg_Issued : Boolean;
399
      pragma Unreferenced (Msg_Issued);
400
   begin
401
      Check_Restriction (Msg_Issued, R, N, V);
402
   end Check_Restriction;
403
 
404
   procedure Check_Restriction
405
     (Msg_Issued : out Boolean;
406
      R          : Restriction_Id;
407
      N          : Node_Id;
408
      V          : Uint := Uint_Minus_1)
409
   is
410
      VV : Integer;
411
      --  V converted to integer form. If V is greater than Integer'Last,
412
      --  it is reset to minus 1 (unknown value).
413
 
414
      procedure Update_Restrictions (Info : in out Restrictions_Info);
415
      --  Update violation information in Info.Violated and Info.Count
416
 
417
      -------------------------
418
      -- Update_Restrictions --
419
      -------------------------
420
 
421
      procedure Update_Restrictions (Info : in out Restrictions_Info) is
422
      begin
423
         --  If not violated, set as violated now
424
 
425
         if not Info.Violated (R) then
426
            Info.Violated (R) := True;
427
 
428
            if R in All_Parameter_Restrictions then
429
               if VV < 0 then
430
                  Info.Unknown (R) := True;
431
                  Info.Count (R) := 1;
432
               else
433
                  Info.Count (R) := VV;
434
               end if;
435
            end if;
436
 
437
         --  Otherwise if violated already and a parameter restriction,
438
         --  update count by maximizing or summing depending on restriction.
439
 
440
         elsif R in All_Parameter_Restrictions then
441
 
442
            --  If new value is unknown, result is unknown
443
 
444
            if VV < 0 then
445
               Info.Unknown (R) := True;
446
 
447
            --  If checked by maximization, do maximization
448
 
449
            elsif R in Checked_Max_Parameter_Restrictions then
450
               Info.Count (R) := Integer'Max (Info.Count (R), VV);
451
 
452
            --  If checked by adding, do add, checking for overflow
453
 
454
            elsif R in Checked_Add_Parameter_Restrictions then
455
               declare
456
                  pragma Unsuppress (Overflow_Check);
457
               begin
458
                  Info.Count (R) := Info.Count (R) + VV;
459
               exception
460
                  when Constraint_Error =>
461
                     Info.Count (R) := Integer'Last;
462
                     Info.Unknown (R) := True;
463
               end;
464
 
465
            --  Should not be able to come here, known counts should only
466
            --  occur for restrictions that are Checked_max or Checked_Sum.
467
 
468
            else
469
               raise Program_Error;
470
            end if;
471
         end if;
472
      end Update_Restrictions;
473
 
474
   --  Start of processing for Check_Restriction
475
 
476
   begin
477
      Msg_Issued := False;
478
 
479
      --  In CodePeer and Alfa mode, we do not want to check for any
480
      --  restriction, or set additional restrictions other than those already
481
      --  set in gnat1drv.adb so that we have consistency between each
482
      --  compilation.
483
 
484
      if CodePeer_Mode or Alfa_Mode then
485
         return;
486
      end if;
487
 
488
      --  In SPARK mode, issue an error for any use of class-wide, even if the
489
      --  No_Dispatch restriction is not set.
490
 
491
      if R = No_Dispatch then
492
         Check_SPARK_Restriction ("class-wide is not allowed", N);
493
      end if;
494
 
495
      if UI_Is_In_Int_Range (V) then
496
         VV := Integer (UI_To_Int (V));
497
      else
498
         VV := -1;
499
      end if;
500
 
501
      --  Count can only be specified in the checked val parameter case
502
 
503
      pragma Assert (VV < 0 or else R in Checked_Val_Parameter_Restrictions);
504
 
505
      --  Nothing to do if value of zero specified for parameter restriction
506
 
507
      if VV = 0 then
508
         return;
509
      end if;
510
 
511
      --  Update current restrictions
512
 
513
      Update_Restrictions (Restrictions);
514
 
515
      --  If in main extended unit, update main restrictions as well. Note
516
      --  that as usual we check for Main_Unit explicitly to deal with the
517
      --  case of configuration pragma files.
518
 
519
      if Current_Sem_Unit = Main_Unit
520
        or else In_Extended_Main_Source_Unit (N)
521
      then
522
         Update_Restrictions (Main_Restrictions);
523
      end if;
524
 
525
      --  Nothing to do if restriction message suppressed
526
 
527
      if Suppress_Restriction_Message (N) then
528
         null;
529
 
530
      --  If restriction not set, nothing to do
531
 
532
      elsif not Restrictions.Set (R) then
533
         null;
534
 
535
      --  Don't complain about No_Obsolescent_Features in an instance, since we
536
      --  will complain on the template, which is much better. Are there other
537
      --  cases like this ??? Do we need a more general mechanism ???
538
 
539
      elsif R = No_Obsolescent_Features
540
        and then Instantiation_Location (Sloc (N)) /= No_Location
541
      then
542
         null;
543
 
544
      --  Here if restriction set, check for violation (either this is a
545
      --  Boolean restriction, or a parameter restriction with a value of
546
      --  zero and an unknown count, or a parameter restriction with a
547
      --  known value that exceeds the restriction count).
548
 
549
      elsif R in All_Boolean_Restrictions
550
        or else (Restrictions.Unknown (R)
551
                   and then Restrictions.Value (R) = 0)
552
        or else Restrictions.Count (R) > Restrictions.Value (R)
553
      then
554
         Msg_Issued := True;
555
         Restriction_Msg (R, N);
556
      end if;
557
   end Check_Restriction;
558
 
559
   -------------------------------------
560
   -- Check_Restriction_No_Dependence --
561
   -------------------------------------
562
 
563
   procedure Check_Restriction_No_Dependence (U : Node_Id; Err : Node_Id) is
564
      DU : Node_Id;
565
 
566
   begin
567
      --  Ignore call if node U is not in the main source unit. This avoids
568
      --  cascaded errors, e.g. when Ada.Containers units with other units.
569
 
570
      if not In_Extended_Main_Source_Unit (U) then
571
         return;
572
      end if;
573
 
574
      --  Loop through entries in No_Dependence table to check each one in turn
575
 
576
      for J in No_Dependences.First .. No_Dependences.Last loop
577
         DU := No_Dependences.Table (J).Unit;
578
 
579
         if Same_Unit (U, DU) then
580
            Error_Msg_Sloc := Sloc (DU);
581
            Error_Msg_Node_1 := DU;
582
 
583
            if No_Dependences.Table (J).Warn then
584
               Error_Msg
585
                 ("?violation of restriction `No_Dependence '='> &`#",
586
                  Sloc (Err));
587
            else
588
               Error_Msg
589
                 ("|violation of restriction `No_Dependence '='> &`#",
590
                  Sloc (Err));
591
            end if;
592
 
593
            return;
594
         end if;
595
      end loop;
596
   end Check_Restriction_No_Dependence;
597
 
598
   --------------------------------------------------
599
   -- Check_Restriction_No_Specification_Of_Aspect --
600
   --------------------------------------------------
601
 
602
   procedure Check_Restriction_No_Specification_Of_Aspect (N : Node_Id) is
603
      A_Id : Aspect_Id;
604
      Id   : Node_Id;
605
 
606
   begin
607
      --  Ignore call if no instances of this restriction set
608
 
609
      if not No_Specification_Of_Aspect_Set then
610
         return;
611
      end if;
612
 
613
      --  Ignore call if node N is not in the main source unit, since we only
614
      --  give messages for . This avoids giving messages for aspects that are
615
      --  specified in withed units.
616
 
617
      if not In_Extended_Main_Source_Unit (N) then
618
         return;
619
      end if;
620
 
621
      Id := Identifier (N);
622
      A_Id := Get_Aspect_Id (Chars (Id));
623
      pragma Assert (A_Id /= No_Aspect);
624
 
625
      Error_Msg_Sloc := No_Specification_Of_Aspects (A_Id);
626
 
627
      if Error_Msg_Sloc /= No_Location then
628
         Error_Msg_Node_1 := Id;
629
         Error_Msg_Warn := No_Specification_Of_Aspect_Warning (A_Id);
630
         Error_Msg_N
631
           ("<violation of restriction `No_Specification_Of_Aspect '='> &`#",
632
            Id);
633
      end if;
634
   end Check_Restriction_No_Specification_Of_Aspect;
635
 
636
   --------------------------------------
637
   -- Check_Wide_Character_Restriction --
638
   --------------------------------------
639
 
640
   procedure Check_Wide_Character_Restriction (E : Entity_Id; N : Node_Id) is
641
   begin
642
      if Restriction_Check_Required (No_Wide_Characters)
643
        and then Comes_From_Source (N)
644
      then
645
         declare
646
            T : constant Entity_Id := Root_Type (E);
647
         begin
648
            if T = Standard_Wide_Character      or else
649
               T = Standard_Wide_String         or else
650
               T = Standard_Wide_Wide_Character or else
651
               T = Standard_Wide_Wide_String
652
            then
653
               Check_Restriction (No_Wide_Characters, N);
654
            end if;
655
         end;
656
      end if;
657
   end Check_Wide_Character_Restriction;
658
 
659
   ----------------------------------------
660
   -- Cunit_Boolean_Restrictions_Restore --
661
   ----------------------------------------
662
 
663
   procedure Cunit_Boolean_Restrictions_Restore
664
     (R : Save_Cunit_Boolean_Restrictions)
665
   is
666
   begin
667
      for J in Cunit_Boolean_Restrictions loop
668
         Restrictions.Set (J) := R (J);
669
      end loop;
670
 
671
      --  If No_Elaboration_Code set in configuration restrictions, and we
672
      --  in the main extended source, then set it here now. This is part of
673
      --  the special processing for No_Elaboration_Code.
674
 
675
      if In_Extended_Main_Source_Unit (Cunit_Entity (Current_Sem_Unit))
676
        and then Config_Cunit_Boolean_Restrictions (No_Elaboration_Code)
677
      then
678
         Restrictions.Set (No_Elaboration_Code) := True;
679
      end if;
680
   end Cunit_Boolean_Restrictions_Restore;
681
 
682
   -------------------------------------
683
   -- Cunit_Boolean_Restrictions_Save --
684
   -------------------------------------
685
 
686
   function Cunit_Boolean_Restrictions_Save
687
     return Save_Cunit_Boolean_Restrictions
688
   is
689
      R : Save_Cunit_Boolean_Restrictions;
690
 
691
   begin
692
      for J in Cunit_Boolean_Restrictions loop
693
         R (J) := Restrictions.Set (J);
694
      end loop;
695
 
696
      return R;
697
   end Cunit_Boolean_Restrictions_Save;
698
 
699
   ------------------------
700
   -- Get_Restriction_Id --
701
   ------------------------
702
 
703
   function Get_Restriction_Id
704
     (N : Name_Id) return Restriction_Id
705
   is
706
   begin
707
      Get_Name_String (N);
708
      Set_Casing (All_Upper_Case);
709
 
710
      for J in All_Restrictions loop
711
         declare
712
            S : constant String := Restriction_Id'Image (J);
713
         begin
714
            if S = Name_Buffer (1 .. Name_Len) then
715
               return J;
716
            end if;
717
         end;
718
      end loop;
719
 
720
      return Not_A_Restriction_Id;
721
   end Get_Restriction_Id;
722
 
723
   --------------------------------
724
   -- Is_In_Hidden_Part_In_SPARK --
725
   --------------------------------
726
 
727
   function Is_In_Hidden_Part_In_SPARK (Loc : Source_Ptr) return Boolean is
728
   begin
729
      --  Loop through table of hidden ranges
730
 
731
      for J in SPARK_Hides.First .. SPARK_Hides.Last loop
732
         if SPARK_Hides.Table (J).Start <= Loc
733
           and then Loc < SPARK_Hides.Table (J).Stop
734
         then
735
            return True;
736
         end if;
737
      end loop;
738
 
739
      return False;
740
   end Is_In_Hidden_Part_In_SPARK;
741
 
742
   -------------------------------
743
   -- No_Exception_Handlers_Set --
744
   -------------------------------
745
 
746
   function No_Exception_Handlers_Set return Boolean is
747
   begin
748
      return (No_Run_Time_Mode or else Configurable_Run_Time_Mode)
749
        and then (Restrictions.Set (No_Exception_Handlers)
750
                    or else
751
                  Restrictions.Set (No_Exception_Propagation));
752
   end No_Exception_Handlers_Set;
753
 
754
   -------------------------------------
755
   -- No_Exception_Propagation_Active --
756
   -------------------------------------
757
 
758
   function No_Exception_Propagation_Active return Boolean is
759
   begin
760
      return (No_Run_Time_Mode
761
               or else Configurable_Run_Time_Mode
762
               or else Debug_Flag_Dot_G)
763
        and then Restriction_Active (No_Exception_Propagation);
764
   end No_Exception_Propagation_Active;
765
 
766
   ----------------------------------
767
   -- Process_Restriction_Synonyms --
768
   ----------------------------------
769
 
770
   --  Note: body of this function must be coordinated with list of
771
   --  renaming declarations in System.Rident.
772
 
773
   function Process_Restriction_Synonyms (N : Node_Id) return Name_Id
774
   is
775
      Old_Name : constant Name_Id := Chars (N);
776
      New_Name : Name_Id;
777
 
778
   begin
779
      case Old_Name is
780
         when Name_Boolean_Entry_Barriers =>
781
            New_Name := Name_Simple_Barriers;
782
 
783
         when Name_Max_Entry_Queue_Depth =>
784
            New_Name := Name_Max_Entry_Queue_Length;
785
 
786
         when Name_No_Dynamic_Interrupts =>
787
            New_Name := Name_No_Dynamic_Attachment;
788
 
789
         when Name_No_Requeue =>
790
            New_Name := Name_No_Requeue_Statements;
791
 
792
         when Name_No_Task_Attributes =>
793
            New_Name := Name_No_Task_Attributes_Package;
794
 
795
         when others =>
796
            return Old_Name;
797
      end case;
798
 
799
      if Warn_On_Obsolescent_Feature then
800
         Error_Msg_Name_1 := Old_Name;
801
         Error_Msg_N ("restriction identifier % is obsolescent?", N);
802
         Error_Msg_Name_1 := New_Name;
803
         Error_Msg_N ("|use restriction identifier % instead", N);
804
      end if;
805
 
806
      return New_Name;
807
   end Process_Restriction_Synonyms;
808
 
809
   --------------------------------------
810
   -- Reset_Cunit_Boolean_Restrictions --
811
   --------------------------------------
812
 
813
   procedure Reset_Cunit_Boolean_Restrictions is
814
   begin
815
      for J in Cunit_Boolean_Restrictions loop
816
         Restrictions.Set (J) := False;
817
      end loop;
818
   end Reset_Cunit_Boolean_Restrictions;
819
 
820
   -----------------------------------------------
821
   -- Restore_Config_Cunit_Boolean_Restrictions --
822
   -----------------------------------------------
823
 
824
   procedure Restore_Config_Cunit_Boolean_Restrictions is
825
   begin
826
      Cunit_Boolean_Restrictions_Restore (Config_Cunit_Boolean_Restrictions);
827
   end Restore_Config_Cunit_Boolean_Restrictions;
828
 
829
   ------------------------
830
   -- Restricted_Profile --
831
   ------------------------
832
 
833
   function Restricted_Profile return Boolean is
834
   begin
835
      if Restricted_Profile_Cached then
836
         return Restricted_Profile_Result;
837
 
838
      else
839
         Restricted_Profile_Result := True;
840
         Restricted_Profile_Cached := True;
841
 
842
         declare
843
            R : Restriction_Flags  renames Profile_Info (Restricted).Set;
844
            V : Restriction_Values renames Profile_Info (Restricted).Value;
845
         begin
846
            for J in R'Range loop
847
               if R (J)
848
                 and then (Restrictions.Set (J) = False
849
                             or else Restriction_Warnings (J)
850
                             or else
851
                               (J in All_Parameter_Restrictions
852
                                  and then Restrictions.Value (J) > V (J)))
853
               then
854
                  Restricted_Profile_Result := False;
855
                  exit;
856
               end if;
857
            end loop;
858
 
859
            return Restricted_Profile_Result;
860
         end;
861
      end if;
862
   end Restricted_Profile;
863
 
864
   ------------------------
865
   -- Restriction_Active --
866
   ------------------------
867
 
868
   function Restriction_Active (R : All_Restrictions) return Boolean is
869
   begin
870
      return Restrictions.Set (R) and then not Restriction_Warnings (R);
871
   end Restriction_Active;
872
 
873
   --------------------------------
874
   -- Restriction_Check_Required --
875
   --------------------------------
876
 
877
   function Restriction_Check_Required (R : All_Restrictions) return Boolean is
878
   begin
879
      return Restrictions.Set (R);
880
   end Restriction_Check_Required;
881
 
882
   ---------------------
883
   -- Restriction_Msg --
884
   ---------------------
885
 
886
   procedure Restriction_Msg (R : Restriction_Id; N : Node_Id) is
887
      Msg : String (1 .. 100);
888
      Len : Natural := 0;
889
 
890
      procedure Add_Char (C : Character);
891
      --  Append given character to Msg, bumping Len
892
 
893
      procedure Add_Str (S : String);
894
      --  Append given string to Msg, bumping Len appropriately
895
 
896
      procedure Id_Case (S : String; Quotes : Boolean := True);
897
      --  Given a string S, case it according to current identifier casing,
898
      --  except for SPARK (an acronym) which is set all upper case, and store
899
      --  in Error_Msg_String. Then append `~` to the message buffer to output
900
      --  the string unchanged surrounded in quotes. The quotes are suppressed
901
      --  if Quotes = False.
902
 
903
      --------------
904
      -- Add_Char --
905
      --------------
906
 
907
      procedure Add_Char (C : Character) is
908
      begin
909
         Len := Len + 1;
910
         Msg (Len) := C;
911
      end Add_Char;
912
 
913
      -------------
914
      -- Add_Str --
915
      -------------
916
 
917
      procedure Add_Str (S : String) is
918
      begin
919
         Msg (Len + 1 .. Len + S'Length) := S;
920
         Len := Len + S'Length;
921
      end Add_Str;
922
 
923
      -------------
924
      -- Id_Case --
925
      -------------
926
 
927
      procedure Id_Case (S : String; Quotes : Boolean := True) is
928
      begin
929
         Name_Buffer (1 .. S'Last) := S;
930
         Name_Len := S'Length;
931
 
932
         if R = SPARK then
933
            Set_All_Upper_Case;
934
         else
935
            Set_Casing (Identifier_Casing (Get_Source_File_Index (Sloc (N))));
936
         end if;
937
 
938
         Error_Msg_Strlen := Name_Len;
939
         Error_Msg_String (1 .. Name_Len) := Name_Buffer (1 .. Name_Len);
940
 
941
         if Quotes then
942
            Add_Str ("`~`");
943
         else
944
            Add_Char ('~');
945
         end if;
946
      end Id_Case;
947
 
948
   --  Start of processing for Restriction_Msg
949
 
950
   begin
951
      --  Set warning message if warning
952
 
953
      if Restriction_Warnings (R) then
954
         Add_Char ('?');
955
 
956
      --  If real violation (not warning), then mark it as non-serious unless
957
      --  it is a violation of No_Finalization in which case we leave it as a
958
      --  serious message, since otherwise we get crashes during attempts to
959
      --  expand stuff that is not properly formed due to assumptions made
960
      --  about no finalization being present.
961
 
962
      elsif R /= No_Finalization then
963
         Add_Char ('|');
964
      end if;
965
 
966
      Error_Msg_Sloc := Restrictions_Loc (R);
967
 
968
      --  Set main message, adding implicit if no source location
969
 
970
      if Error_Msg_Sloc > No_Location
971
        or else Error_Msg_Sloc = System_Location
972
      then
973
         Add_Str ("violation of restriction ");
974
      else
975
         Add_Str ("violation of implicit restriction ");
976
         Error_Msg_Sloc := No_Location;
977
      end if;
978
 
979
      --  Case of parameterized restriction
980
 
981
      if R in All_Parameter_Restrictions then
982
         Add_Char ('`');
983
         Id_Case (Restriction_Id'Image (R), Quotes => False);
984
         Add_Str (" = ^`");
985
         Error_Msg_Uint_1 := UI_From_Int (Int (Restrictions.Value (R)));
986
 
987
      --  Case of boolean restriction
988
 
989
      else
990
         Id_Case (Restriction_Id'Image (R));
991
      end if;
992
 
993
      --  Case of no secondary profile continuation message
994
 
995
      if Restriction_Profile_Name (R) = No_Profile then
996
         if Error_Msg_Sloc /= No_Location then
997
            Add_Char ('#');
998
         end if;
999
 
1000
         Add_Char ('!');
1001
         Error_Msg_N (Msg (1 .. Len), N);
1002
 
1003
      --  Case of secondary profile continuation message present
1004
 
1005
      else
1006
         Add_Char ('!');
1007
         Error_Msg_N (Msg (1 .. Len), N);
1008
 
1009
         Len := 0;
1010
         Add_Char ('\');
1011
 
1012
         --  Set as warning if warning case
1013
 
1014
         if Restriction_Warnings (R) then
1015
            Add_Char ('?');
1016
         end if;
1017
 
1018
         --  Set main message
1019
 
1020
         Add_Str ("from profile ");
1021
         Id_Case (Profile_Name'Image (Restriction_Profile_Name (R)));
1022
 
1023
         --  Add location if we have one
1024
 
1025
         if Error_Msg_Sloc /= No_Location then
1026
            Add_Char ('#');
1027
         end if;
1028
 
1029
         --  Output unconditional message and we are done
1030
 
1031
         Add_Char ('!');
1032
         Error_Msg_N (Msg (1 .. Len), N);
1033
      end if;
1034
   end Restriction_Msg;
1035
 
1036
   ---------------
1037
   -- Same_Unit --
1038
   ---------------
1039
 
1040
   function Same_Unit (U1, U2 : Node_Id) return Boolean is
1041
   begin
1042
      if Nkind (U1) = N_Identifier then
1043
         return Nkind (U2) = N_Identifier and then Chars (U1) = Chars (U2);
1044
 
1045
      elsif Nkind (U2) = N_Identifier then
1046
         return False;
1047
 
1048
      elsif (Nkind (U1) = N_Selected_Component
1049
             or else Nkind (U1) = N_Expanded_Name)
1050
        and then
1051
          (Nkind (U2) = N_Selected_Component
1052
           or else Nkind (U2) = N_Expanded_Name)
1053
      then
1054
         return Same_Unit (Prefix (U1), Prefix (U2))
1055
           and then Same_Unit (Selector_Name (U1), Selector_Name (U2));
1056
      else
1057
         return False;
1058
      end if;
1059
   end Same_Unit;
1060
 
1061
   --------------------------------------------
1062
   -- Save_Config_Cunit_Boolean_Restrictions --
1063
   --------------------------------------------
1064
 
1065
   procedure Save_Config_Cunit_Boolean_Restrictions is
1066
   begin
1067
      Config_Cunit_Boolean_Restrictions := Cunit_Boolean_Restrictions_Save;
1068
   end Save_Config_Cunit_Boolean_Restrictions;
1069
 
1070
   ------------------------------
1071
   -- Set_Hidden_Part_In_SPARK --
1072
   ------------------------------
1073
 
1074
   procedure Set_Hidden_Part_In_SPARK (Loc1, Loc2 : Source_Ptr) is
1075
   begin
1076
      SPARK_Hides.Increment_Last;
1077
      SPARK_Hides.Table (SPARK_Hides.Last).Start := Loc1;
1078
      SPARK_Hides.Table (SPARK_Hides.Last).Stop  := Loc2;
1079
   end Set_Hidden_Part_In_SPARK;
1080
 
1081
   ------------------------------
1082
   -- Set_Profile_Restrictions --
1083
   ------------------------------
1084
 
1085
   procedure Set_Profile_Restrictions
1086
     (P    : Profile_Name;
1087
      N    : Node_Id;
1088
      Warn : Boolean)
1089
   is
1090
      R : Restriction_Flags  renames Profile_Info (P).Set;
1091
      V : Restriction_Values renames Profile_Info (P).Value;
1092
 
1093
   begin
1094
      for J in R'Range loop
1095
         if R (J) then
1096
            declare
1097
               Already_Restricted : constant Boolean := Restriction_Active (J);
1098
 
1099
            begin
1100
               --  Set the restriction
1101
 
1102
               if J in All_Boolean_Restrictions then
1103
                  Set_Restriction (J, N);
1104
               else
1105
                  Set_Restriction (J, N, V (J));
1106
               end if;
1107
 
1108
               --  Record that this came from a Profile[_Warnings] restriction
1109
 
1110
               Restriction_Profile_Name (J) := P;
1111
 
1112
               --  Set warning flag, except that we do not set the warning
1113
               --  flag if the restriction was already active and this is
1114
               --  the warning case. That avoids a warning overriding a real
1115
               --  restriction, which should never happen.
1116
 
1117
               if not (Warn and Already_Restricted) then
1118
                  Restriction_Warnings (J) := Warn;
1119
               end if;
1120
            end;
1121
         end if;
1122
      end loop;
1123
   end Set_Profile_Restrictions;
1124
 
1125
   ---------------------
1126
   -- Set_Restriction --
1127
   ---------------------
1128
 
1129
   --  Case of Boolean restriction
1130
 
1131
   procedure Set_Restriction
1132
     (R : All_Boolean_Restrictions;
1133
      N : Node_Id)
1134
   is
1135
   begin
1136
      Restrictions.Set (R) := True;
1137
 
1138
      if Restricted_Profile_Cached and Restricted_Profile_Result then
1139
         null;
1140
      else
1141
         Restricted_Profile_Cached := False;
1142
      end if;
1143
 
1144
      --  Set location, but preserve location of system restriction for nice
1145
      --  error msg with run time name.
1146
 
1147
      if Restrictions_Loc (R) /= System_Location then
1148
         Restrictions_Loc (R) := Sloc (N);
1149
      end if;
1150
 
1151
      --  Note restriction came from restriction pragma, not profile
1152
 
1153
      Restriction_Profile_Name (R) := No_Profile;
1154
 
1155
      --  Record the restriction if we are in the main unit, or in the extended
1156
      --  main unit. The reason that we test separately for Main_Unit is that
1157
      --  gnat.adc is processed with Current_Sem_Unit = Main_Unit, but nodes in
1158
      --  gnat.adc do not appear to be in the extended main source unit (they
1159
      --  probably should do ???)
1160
 
1161
      if Current_Sem_Unit = Main_Unit
1162
        or else In_Extended_Main_Source_Unit (N)
1163
      then
1164
         if not Restriction_Warnings (R) then
1165
            Main_Restrictions.Set (R) := True;
1166
         end if;
1167
      end if;
1168
   end Set_Restriction;
1169
 
1170
   --  Case of parameter restriction
1171
 
1172
   procedure Set_Restriction
1173
     (R : All_Parameter_Restrictions;
1174
      N : Node_Id;
1175
      V : Integer)
1176
   is
1177
   begin
1178
      if Restricted_Profile_Cached and Restricted_Profile_Result then
1179
         null;
1180
      else
1181
         Restricted_Profile_Cached := False;
1182
      end if;
1183
 
1184
      if Restrictions.Set (R) then
1185
         if V < Restrictions.Value (R) then
1186
            Restrictions.Value (R) := V;
1187
            Restrictions_Loc (R) := Sloc (N);
1188
         end if;
1189
 
1190
      else
1191
         Restrictions.Set (R) := True;
1192
         Restrictions.Value (R) := V;
1193
         Restrictions_Loc (R) := Sloc (N);
1194
      end if;
1195
 
1196
      --  Record the restriction if we are in the main unit, or in the extended
1197
      --  main unit. The reason that we test separately for Main_Unit is that
1198
      --  gnat.adc is processed with Current_Sem_Unit = Main_Unit, but nodes in
1199
      --  gnat.adc do not appear to be the extended main source unit (they
1200
      --  probably should do ???)
1201
 
1202
      if Current_Sem_Unit = Main_Unit
1203
        or else In_Extended_Main_Source_Unit (N)
1204
      then
1205
         if Main_Restrictions.Set (R) then
1206
            if V < Main_Restrictions.Value (R) then
1207
               Main_Restrictions.Value (R) := V;
1208
            end if;
1209
 
1210
         elsif not Restriction_Warnings (R) then
1211
            Main_Restrictions.Set (R) := True;
1212
            Main_Restrictions.Value (R) := V;
1213
         end if;
1214
      end if;
1215
 
1216
      --  Note restriction came from restriction pragma, not profile
1217
 
1218
      Restriction_Profile_Name (R) := No_Profile;
1219
   end Set_Restriction;
1220
 
1221
   -----------------------------------
1222
   -- Set_Restriction_No_Dependence --
1223
   -----------------------------------
1224
 
1225
   procedure Set_Restriction_No_Dependence
1226
     (Unit    : Node_Id;
1227
      Warn    : Boolean;
1228
      Profile : Profile_Name := No_Profile)
1229
   is
1230
   begin
1231
      --  Loop to check for duplicate entry
1232
 
1233
      for J in No_Dependences.First .. No_Dependences.Last loop
1234
 
1235
         --  Case of entry already in table
1236
 
1237
         if Same_Unit (Unit, No_Dependences.Table (J).Unit) then
1238
 
1239
            --  Error has precedence over warning
1240
 
1241
            if not Warn then
1242
               No_Dependences.Table (J).Warn := False;
1243
            end if;
1244
 
1245
            return;
1246
         end if;
1247
      end loop;
1248
 
1249
      --  Entry is not currently in table
1250
 
1251
      No_Dependences.Append ((Unit, Warn, Profile));
1252
   end Set_Restriction_No_Dependence;
1253
 
1254
   ------------------------------------------------
1255
   -- Set_Restriction_No_Specification_Of_Aspect --
1256
   ------------------------------------------------
1257
 
1258
   procedure Set_Restriction_No_Specification_Of_Aspect
1259
     (N       : Node_Id;
1260
      Warning : Boolean)
1261
   is
1262
      A_Id : constant Aspect_Id := Get_Aspect_Id (Chars (N));
1263
      pragma Assert (A_Id /= No_Aspect);
1264
 
1265
   begin
1266
      No_Specification_Of_Aspects (A_Id) := Sloc (N);
1267
 
1268
      if Warning = False then
1269
         No_Specification_Of_Aspect_Warning (A_Id) := False;
1270
      end if;
1271
 
1272
      No_Specification_Of_Aspect_Set := True;
1273
   end Set_Restriction_No_Specification_Of_Aspect;
1274
 
1275
   ----------------------------------
1276
   -- Suppress_Restriction_Message --
1277
   ----------------------------------
1278
 
1279
   function Suppress_Restriction_Message (N : Node_Id) return Boolean is
1280
   begin
1281
      --  We only output messages for the extended main source unit
1282
 
1283
      if In_Extended_Main_Source_Unit (N) then
1284
         return False;
1285
 
1286
      --  If loaded by rtsfind, then suppress message
1287
 
1288
      elsif Sloc (N) <= No_Location then
1289
         return True;
1290
 
1291
      --  Otherwise suppress message if internal file
1292
 
1293
      else
1294
         return Is_Internal_File_Name (Unit_File_Name (Get_Source_Unit (N)));
1295
      end if;
1296
   end Suppress_Restriction_Message;
1297
 
1298
   ---------------------
1299
   -- Tasking_Allowed --
1300
   ---------------------
1301
 
1302
   function Tasking_Allowed return Boolean is
1303
   begin
1304
      return not Restrictions.Set (No_Tasking)
1305
        and then (not Restrictions.Set (Max_Tasks)
1306
                    or else Restrictions.Value (Max_Tasks) > 0);
1307
   end Tasking_Allowed;
1308
 
1309
end Restrict;

powered by: WebSVN 2.1.0

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