OSDN Git Service

PR preprocessor/20348
[pf3gnuchains/gcc-fork.git] / gcc / ada / restrict.adb
1 ------------------------------------------------------------------------------
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-2004 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 2,  or (at your option) any later ver- --
14 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
17 -- for  more details.  You should have  received  a copy of the GNU General --
18 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
19 -- to  the  Free Software Foundation,  51  Franklin  Street,  Fifth  Floor, --
20 -- Boston, MA 02110-1301, USA.                                              --
21 --                                                                          --
22 -- GNAT was originally developed  by the GNAT team at  New York University. --
23 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
24 --                                                                          --
25 ------------------------------------------------------------------------------
26
27 with Atree;    use Atree;
28 with Casing;   use Casing;
29 with Errout;   use Errout;
30 with Fname;    use Fname;
31 with Fname.UF; use Fname.UF;
32 with Lib;      use Lib;
33 with Namet;    use Namet;
34 with Opt;      use Opt;
35 with Sinfo;    use Sinfo;
36 with Sinput;   use Sinput;
37 with Snames;   use Snames;
38 with Uname;    use Uname;
39
40 package body Restrict is
41
42    Restricted_Profile_Result : Boolean := False;
43    --  This switch memoizes the result of Restricted_Profile function
44    --  calls for improved efficiency. Its setting is valid only if
45    --  Restricted_Profile_Cached is True. Note that if this switch
46    --  is ever set True, it need never be turned off again.
47
48    Restricted_Profile_Cached : Boolean := False;
49    --  This flag is set to True if the Restricted_Profile_Result
50    --  contains the correct cached result of Restricted_Profile calls.
51
52    -----------------------
53    -- Local Subprograms --
54    -----------------------
55
56    procedure Restriction_Msg (Msg : String; R : String; N : Node_Id);
57    --  Output error message at node N with given text, replacing the
58    --  '%' in the message with the name of the restriction given as R,
59    --  cased according to the current identifier casing. We do not use
60    --  the normal insertion mechanism, since this requires an entry
61    --  in the Names table, and this table will be locked if we are
62    --  generating a message from gigi.
63
64    function Same_Unit (U1, U2 : Node_Id) return Boolean;
65    --  Returns True iff U1 and U2 represent the same library unit. Used for
66    --  handling of No_Dependence => Unit restriction case.
67
68    function Suppress_Restriction_Message (N : Node_Id) return Boolean;
69    --  N is the node for a possible restriction violation message, but
70    --  the message is to be suppressed if this is an internal file and
71    --  this file is not the main unit.
72
73    -------------------
74    -- Abort_Allowed --
75    -------------------
76
77    function Abort_Allowed return Boolean is
78    begin
79       if Restrictions.Set (No_Abort_Statements)
80         and then Restrictions.Set (Max_Asynchronous_Select_Nesting)
81         and then Restrictions.Value (Max_Asynchronous_Select_Nesting) = 0
82       then
83          return False;
84       else
85          return True;
86       end if;
87    end Abort_Allowed;
88
89    ------------------------------------
90    -- Check_Elaboration_Code_Allowed --
91    ------------------------------------
92
93    procedure Check_Elaboration_Code_Allowed (N : Node_Id) is
94    begin
95       --  Avoid calling Namet.Unlock/Lock except when there is an error.
96       --  Even in the error case it is a bit dubious, either gigi needs
97       --  the table locked or it does not! ???
98
99       if Restrictions.Set (No_Elaboration_Code)
100         and then not Suppress_Restriction_Message (N)
101       then
102          Namet.Unlock;
103          Check_Restriction (Restriction_Id'(No_Elaboration_Code), N);
104          Namet.Lock;
105       end if;
106    end Check_Elaboration_Code_Allowed;
107
108    ----------------------------------
109    -- Check_No_Implicit_Heap_Alloc --
110    ----------------------------------
111
112    procedure Check_No_Implicit_Heap_Alloc (N : Node_Id) is
113    begin
114       Check_Restriction (Restriction_Id'(No_Implicit_Heap_Allocations), N);
115    end Check_No_Implicit_Heap_Alloc;
116
117    ---------------------------
118    -- Check_Restricted_Unit --
119    ---------------------------
120
121    procedure Check_Restricted_Unit (U : Unit_Name_Type; N : Node_Id) is
122    begin
123       if Suppress_Restriction_Message (N) then
124          return;
125
126       elsif Is_Spec_Name (U) then
127          declare
128             Fnam : constant File_Name_Type :=
129                      Get_File_Name (U, Subunit => False);
130
131          begin
132             if not Is_Predefined_File_Name (Fnam) then
133                return;
134
135             --  Predefined spec, needs checking against list
136
137             else
138                --  Pad name to 8 characters with blanks
139
140                Get_Name_String (Fnam);
141                Name_Len := Name_Len - 4;
142
143                while Name_Len < 8 loop
144                   Name_Len := Name_Len + 1;
145                   Name_Buffer (Name_Len) := ' ';
146                end loop;
147
148                for J in Unit_Array'Range loop
149                   if Name_Len = 8
150                     and then Name_Buffer (1 .. 8) = Unit_Array (J).Filenm
151                   then
152                      Check_Restriction (Unit_Array (J).Res_Id, N);
153                   end if;
154                end loop;
155             end if;
156          end;
157       end if;
158    end Check_Restricted_Unit;
159
160    -----------------------
161    -- Check_Restriction --
162    -----------------------
163
164    procedure Check_Restriction
165      (R : Restriction_Id;
166       N : Node_Id;
167       V : Uint := Uint_Minus_1)
168    is
169       Rimage : constant String := Restriction_Id'Image (R);
170
171       VV : Integer;
172       --  V converted to integer form. If V is greater than Integer'Last,
173       --  it is reset to minus 1 (unknown value).
174
175       procedure Update_Restrictions (Info : in out Restrictions_Info);
176       --  Update violation information in Info.Violated and Info.Count
177
178       -------------------------
179       -- Update_Restrictions --
180       -------------------------
181
182       procedure Update_Restrictions (Info : in out Restrictions_Info) is
183       begin
184          --  If not violated, set as violated now
185
186          if not Info.Violated (R) then
187             Info.Violated (R) := True;
188
189             if R in All_Parameter_Restrictions then
190                if VV < 0 then
191                   Info.Unknown (R) := True;
192                   Info.Count (R) := 1;
193                else
194                   Info.Count (R) := VV;
195                end if;
196             end if;
197
198          --  Otherwise if violated already and a parameter restriction,
199          --  update count by maximizing or summing depending on restriction.
200
201          elsif R in All_Parameter_Restrictions then
202
203             --  If new value is unknown, result is unknown
204
205             if VV < 0 then
206                Info.Unknown (R) := True;
207
208             --  If checked by maximization, do maximization
209
210             elsif R in Checked_Max_Parameter_Restrictions then
211                Info.Count (R) := Integer'Max (Info.Count (R), VV);
212
213             --  If checked by adding, do add, checking for overflow
214
215             elsif R in Checked_Add_Parameter_Restrictions then
216                declare
217                   pragma Unsuppress (Overflow_Check);
218                begin
219                   Info.Count (R) := Info.Count (R) + VV;
220                exception
221                   when Constraint_Error =>
222                      Info.Count (R) := Integer'Last;
223                      Info.Unknown (R) := True;
224                end;
225
226             --  Should not be able to come here, known counts should only
227             --  occur for restrictions that are Checked_max or Checked_Sum.
228
229             else
230                raise Program_Error;
231             end if;
232          end if;
233       end Update_Restrictions;
234
235    --  Start of processing for Check_Restriction
236
237    begin
238       if UI_Is_In_Int_Range (V) then
239          VV := Integer (UI_To_Int (V));
240       else
241          VV := -1;
242       end if;
243
244       --  Count can only be specified in the checked val parameter case
245
246       pragma Assert (VV < 0 or else R in Checked_Val_Parameter_Restrictions);
247
248       --  Nothing to do if value of zero specified for parameter restriction
249
250       if VV = 0 then
251          return;
252       end if;
253
254       --  Update current restrictions
255
256       Update_Restrictions (Restrictions);
257
258       --  If in main extended unit, update main restrictions as well
259
260       if Current_Sem_Unit = Main_Unit
261         or else In_Extended_Main_Source_Unit (N)
262       then
263          Update_Restrictions (Main_Restrictions);
264       end if;
265
266       --  Nothing to do if restriction message suppressed
267
268       if Suppress_Restriction_Message (N) then
269          null;
270
271       --  If restriction not set, nothing to do
272
273       elsif not Restrictions.Set (R) then
274          null;
275
276       --  Here if restriction set, check for violation (either this is a
277       --  Boolean restriction, or a parameter restriction with a value of
278       --  zero and an unknown count, or a parameter restriction with a
279       --  known value that exceeds the restriction count).
280
281       elsif R in All_Boolean_Restrictions
282         or else (Restrictions.Unknown (R)
283                    and then Restrictions.Value (R) = 0)
284         or else Restrictions.Count (R) > Restrictions.Value (R)
285       then
286          Error_Msg_Sloc := Restrictions_Loc (R);
287
288          --  If we have a location for the Restrictions pragma, output it
289
290          if Error_Msg_Sloc > No_Location
291            or else Error_Msg_Sloc = System_Location
292          then
293             if Restriction_Warnings (R) then
294                Restriction_Msg ("|violation of restriction %#?", Rimage, N);
295             else
296                Restriction_Msg ("|violation of restriction %#", Rimage, N);
297             end if;
298
299          --  Otherwise we have the case of an implicit restriction
300          --  (e.g. a restriction implicitly set by another pragma)
301
302          else
303             Restriction_Msg
304               ("|violation of implicit restriction %", Rimage, N);
305          end if;
306       end if;
307    end Check_Restriction;
308
309    -------------------------------------
310    -- Check_Restriction_No_Dependence --
311    -------------------------------------
312
313    procedure Check_Restriction_No_Dependence (U : Node_Id; Err : Node_Id) is
314       DU : Node_Id;
315
316    begin
317       for J in No_Dependence.First .. No_Dependence.Last loop
318          DU := No_Dependence.Table (J).Unit;
319
320          if Same_Unit (U, DU) then
321             Error_Msg_Sloc := Sloc (DU);
322             Error_Msg_Node_1 := DU;
323
324             if No_Dependence.Table (J).Warn then
325                Error_Msg
326                  ("?violation of restriction `No_Dependence '='> &`#",
327                   Sloc (Err));
328             else
329                Error_Msg
330                  ("|violation of restriction `No_Dependence '='> &`#",
331                   Sloc (Err));
332             end if;
333
334             return;
335          end if;
336       end loop;
337    end Check_Restriction_No_Dependence;
338
339    ----------------------------------------
340    -- Cunit_Boolean_Restrictions_Restore --
341    ----------------------------------------
342
343    procedure Cunit_Boolean_Restrictions_Restore
344      (R : Save_Cunit_Boolean_Restrictions)
345    is
346    begin
347       for J in Cunit_Boolean_Restrictions loop
348          Restrictions.Set (J) := R (J);
349       end loop;
350    end Cunit_Boolean_Restrictions_Restore;
351
352    -------------------------------------
353    -- Cunit_Boolean_Restrictions_Save --
354    -------------------------------------
355
356    function Cunit_Boolean_Restrictions_Save
357      return Save_Cunit_Boolean_Restrictions
358    is
359       R : Save_Cunit_Boolean_Restrictions;
360
361    begin
362       for J in Cunit_Boolean_Restrictions loop
363          R (J) := Restrictions.Set (J);
364          Restrictions.Set (J) := False;
365       end loop;
366
367       return R;
368    end Cunit_Boolean_Restrictions_Save;
369
370    ------------------------
371    -- Get_Restriction_Id --
372    ------------------------
373
374    function Get_Restriction_Id
375      (N : Name_Id) return Restriction_Id
376    is
377    begin
378       Get_Name_String (N);
379       Set_Casing (All_Upper_Case);
380
381       for J in All_Restrictions loop
382          declare
383             S : constant String := Restriction_Id'Image (J);
384          begin
385             if S = Name_Buffer (1 .. Name_Len) then
386                return J;
387             end if;
388          end;
389       end loop;
390
391       return Not_A_Restriction_Id;
392    end Get_Restriction_Id;
393
394    -------------------------------
395    -- No_Exception_Handlers_Set --
396    -------------------------------
397
398    function No_Exception_Handlers_Set return Boolean is
399    begin
400       return Restrictions.Set (No_Exception_Handlers);
401    end No_Exception_Handlers_Set;
402
403    ----------------------------------
404    -- Process_Restriction_Synonyms --
405    ----------------------------------
406
407    --  Note: body of this function must be coordinated with list of
408    --  renaming declarations in System.Rident.
409
410    function Process_Restriction_Synonyms (N : Node_Id) return Name_Id
411    is
412       Old_Name : constant Name_Id := Chars (N);
413       New_Name : Name_Id;
414
415    begin
416       case Old_Name is
417          when Name_Boolean_Entry_Barriers =>
418             New_Name := Name_Simple_Barriers;
419
420          when Name_Max_Entry_Queue_Depth =>
421             New_Name := Name_Max_Entry_Queue_Length;
422
423          when Name_No_Dynamic_Interrupts =>
424             New_Name := Name_No_Dynamic_Attachment;
425
426          when Name_No_Requeue =>
427             New_Name := Name_No_Requeue_Statements;
428
429          when Name_No_Task_Attributes =>
430             New_Name := Name_No_Task_Attributes_Package;
431
432          when others =>
433             return Old_Name;
434       end case;
435
436       if Warn_On_Obsolescent_Feature then
437          Error_Msg_Name_1 := Old_Name;
438          Error_Msg_N ("restriction identifier % is obsolescent?", N);
439          Error_Msg_Name_1 := New_Name;
440          Error_Msg_N ("|use restriction identifier % instead", N);
441       end if;
442
443       return New_Name;
444    end Process_Restriction_Synonyms;
445
446    ------------------------
447    -- Restricted_Profile --
448    ------------------------
449
450    function Restricted_Profile return Boolean is
451    begin
452       if Restricted_Profile_Cached then
453          return Restricted_Profile_Result;
454
455       else
456          Restricted_Profile_Result := True;
457          Restricted_Profile_Cached := True;
458
459          declare
460             R : Restriction_Flags  renames Profile_Info (Restricted).Set;
461             V : Restriction_Values renames Profile_Info (Restricted).Value;
462          begin
463             for J in R'Range loop
464                if R (J)
465                  and then (Restrictions.Set (J) = False
466                              or else Restriction_Warnings (J)
467                              or else
468                                (J in All_Parameter_Restrictions
469                                   and then Restrictions.Value (J) > V (J)))
470                then
471                   Restricted_Profile_Result := False;
472                   exit;
473                end if;
474             end loop;
475
476             return Restricted_Profile_Result;
477          end;
478       end if;
479    end Restricted_Profile;
480
481    ------------------------
482    -- Restriction_Active --
483    ------------------------
484
485    function Restriction_Active (R : All_Restrictions) return Boolean is
486    begin
487       return Restrictions.Set (R);
488    end Restriction_Active;
489
490    ---------------------
491    -- Restriction_Msg --
492    ---------------------
493
494    procedure Restriction_Msg (Msg : String; R : String; N : Node_Id) is
495       B : String (1 .. Msg'Length + 2 * R'Length + 1);
496       P : Natural := 1;
497
498    begin
499       Name_Buffer (1 .. R'Last) := R;
500       Name_Len := R'Length;
501       Set_Casing (Identifier_Casing (Get_Source_File_Index (Sloc (N))));
502
503       P := 0;
504       for J in Msg'Range loop
505          if Msg (J) = '%' then
506             P := P + 1;
507             B (P) := '`';
508
509             --  Put characters of image in message, quoting upper case letters
510
511             for J in 1 .. Name_Len loop
512                if Name_Buffer (J) in 'A' .. 'Z' then
513                   P := P + 1;
514                   B (P) := ''';
515                end if;
516
517                P := P + 1;
518                B (P) := Name_Buffer (J);
519             end loop;
520
521             P := P + 1;
522             B (P) := '`';
523
524          else
525             P := P + 1;
526             B (P) := Msg (J);
527          end if;
528       end loop;
529
530       Error_Msg_N (B (1 .. P), N);
531    end Restriction_Msg;
532
533    ---------------
534    -- Same_Unit --
535    ---------------
536
537    function Same_Unit (U1, U2 : Node_Id) return Boolean is
538    begin
539       if Nkind (U1) = N_Identifier then
540          return Nkind (U2) = N_Identifier and then Chars (U1) = Chars (U2);
541
542       elsif Nkind (U2) = N_Identifier then
543          return False;
544
545       elsif (Nkind (U1) = N_Selected_Component
546              or else Nkind (U1) = N_Expanded_Name)
547         and then
548           (Nkind (U2) = N_Selected_Component
549            or else Nkind (U2) = N_Expanded_Name)
550       then
551          return Same_Unit (Prefix (U1), Prefix (U2))
552            and then Same_Unit (Selector_Name (U1), Selector_Name (U2));
553       else
554          return False;
555       end if;
556    end Same_Unit;
557
558    ------------------------------
559    -- Set_Profile_Restrictions --
560    ------------------------------
561
562    procedure Set_Profile_Restrictions
563      (P    : Profile_Name;
564       N    : Node_Id;
565       Warn : Boolean)
566    is
567       R : Restriction_Flags  renames Profile_Info (P).Set;
568       V : Restriction_Values renames Profile_Info (P).Value;
569
570    begin
571       for J in R'Range loop
572          if R (J) then
573             if J in All_Boolean_Restrictions then
574                Set_Restriction (J, N);
575             else
576                Set_Restriction (J, N, V (J));
577             end if;
578
579             Restriction_Warnings (J) := Warn;
580          end if;
581       end loop;
582    end Set_Profile_Restrictions;
583
584    ---------------------
585    -- Set_Restriction --
586    ---------------------
587
588    --  Case of Boolean restriction
589
590    procedure Set_Restriction
591      (R : All_Boolean_Restrictions;
592       N : Node_Id)
593    is
594    begin
595       Restrictions.Set (R) := True;
596
597       if Restricted_Profile_Cached and Restricted_Profile_Result then
598          null;
599       else
600          Restricted_Profile_Cached := False;
601       end if;
602
603       --  Set location, but preserve location of system
604       --  restriction for nice error msg with run time name
605
606       if Restrictions_Loc (R) /= System_Location then
607          Restrictions_Loc (R) := Sloc (N);
608       end if;
609
610       --  Record the restriction if we are in the main unit,
611       --  or in the extended main unit. The reason that we
612       --  test separately for Main_Unit is that gnat.adc is
613       --  processed with Current_Sem_Unit = Main_Unit, but
614       --  nodes in gnat.adc do not appear to be the extended
615       --  main source unit (they probably should do ???)
616
617       if Current_Sem_Unit = Main_Unit
618         or else In_Extended_Main_Source_Unit (N)
619       then
620          if not Restriction_Warnings (R) then
621             Main_Restrictions.Set (R) := True;
622          end if;
623       end if;
624    end Set_Restriction;
625
626    --  Case of parameter restriction
627
628    procedure Set_Restriction
629      (R : All_Parameter_Restrictions;
630       N : Node_Id;
631       V : Integer)
632    is
633    begin
634       if Restricted_Profile_Cached and Restricted_Profile_Result then
635          null;
636       else
637          Restricted_Profile_Cached := False;
638       end if;
639
640       if Restrictions.Set (R) then
641          if V < Restrictions.Value (R) then
642             Restrictions.Value (R) := V;
643             Restrictions_Loc (R) := Sloc (N);
644          end if;
645
646       else
647          Restrictions.Set (R) := True;
648          Restrictions.Value (R) := V;
649          Restrictions_Loc (R) := Sloc (N);
650       end if;
651
652       --  Record the restriction if we are in the main unit,
653       --  or in the extended main unit. The reason that we
654       --  test separately for Main_Unit is that gnat.adc is
655       --  processed with Current_Sem_Unit = Main_Unit, but
656       --  nodes in gnat.adc do not appear to be the extended
657       --  main source unit (they probably should do ???)
658
659       if Current_Sem_Unit = Main_Unit
660         or else In_Extended_Main_Source_Unit (N)
661       then
662          if Main_Restrictions.Set (R) then
663             if V < Main_Restrictions.Value (R) then
664                Main_Restrictions.Value (R) := V;
665             end if;
666
667          elsif not Restriction_Warnings (R) then
668             Main_Restrictions.Set (R) := True;
669             Main_Restrictions.Value (R) := V;
670          end if;
671       end if;
672    end Set_Restriction;
673
674    -----------------------------------
675    -- Set_Restriction_No_Dependence --
676    -----------------------------------
677
678    procedure Set_Restriction_No_Dependence
679      (Unit : Node_Id;
680       Warn : Boolean)
681    is
682    begin
683       --  Loop to check for duplicate entry
684
685       for J in No_Dependence.First .. No_Dependence.Last loop
686
687          --  Case of entry already in table
688
689          if Same_Unit (Unit, No_Dependence.Table (J).Unit) then
690
691             --  Error has precedence over warning
692
693             if not Warn then
694                No_Dependence.Table (J).Warn := False;
695             end if;
696
697             return;
698          end if;
699       end loop;
700
701       --  Entry is in table
702
703       No_Dependence.Append ((Unit, Warn));
704    end Set_Restriction_No_Dependence;
705
706    ----------------------------------
707    -- Suppress_Restriction_Message --
708    ----------------------------------
709
710    function Suppress_Restriction_Message (N : Node_Id) return Boolean is
711    begin
712       --  We only output messages for the extended main source unit
713
714       if In_Extended_Main_Source_Unit (N) then
715          return False;
716
717       --  If loaded by rtsfind, then suppress message
718
719       elsif Sloc (N) <= No_Location then
720          return True;
721
722       --  Otherwise suppress message if internal file
723
724       else
725          return Is_Internal_File_Name (Unit_File_Name (Get_Source_Unit (N)));
726       end if;
727    end Suppress_Restriction_Message;
728
729    ---------------------
730    -- Tasking_Allowed --
731    ---------------------
732
733    function Tasking_Allowed return Boolean is
734    begin
735       return not Restrictions.Set (No_Tasking)
736         and then (not Restrictions.Set (Max_Tasks)
737                     or else Restrictions.Value (Max_Tasks) > 0);
738    end Tasking_Allowed;
739
740 end Restrict;