File: gch-rules-qs_4_3_1_11.adb

package info (click to toggle)
gch 19990519-6
  • links: PTS
  • area: main
  • in suites: potato
  • size: 500 kB
  • ctags: 19
  • sloc: ada: 1,780; perl: 1,330
file content (293 lines) | stat: -rw-r--r-- 11,965 bytes parent folder | download | duplicates (3)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
------------------------------------------------------------------------------
--                                                                          --
--                            GCH COMPONENTS                                --
--                                                                          --
--                          G C H . R U L E S                               --
--                                                                          --
--                             QS_4_3_1_11                                  --
--                                                                          --
--              Copyright (c) 1999, Vitali Sh.Kaufman.                      --
--                                                                          --
--  Gch is distributed as free software; that is with full sources          --
--  and in the hope that it will be useful, but WITHOUT ANY WARRANTY;       --
--  without even the implied warranty of MERCHANTABILITY or FITNESS         --
--  FOR A PARTICULAR PURPOSE. You can freely copy, modify and redistribute  --
--  this software, provided that full sources are available for the version --
--  being distribute (original and modified), and for a modified version,   --
--  any changes that you have made are clearly indicated.                   --
--                                                                          --
--  Gch was developed by Vitali Sh. Kaufman using a prototype               --
--  and consultations by Sergey I. Rybin.                                   --
------------------------------------------------------------------------------
------------------
-- QS_4_3_1_11  --
------------------

--  As a rule to check we use the following:
--  "Never let an exception propagate beyond its scope".

--    ###VK Think more: raiser inside task
--    ###VK Think more: extended calling-caller relation?

--Generally, for each raiser R of an exception Ex the rule needs to check
--if an (dynamically) enclosing block B with a handler H of Ex exists.
--So, the whole rule is impossible to check statically.
--To create some reasonable warnings, we need at least extended "calling-caller"
--relation and "enclosing" relation.

--An idea of a preliminary implementation for now is as follows.
--For each direct raiser R of an exception Ex Check_Raiser (R,Ex,U)
--checks if a handler H of Ex ends a body B
--that enclose R or a potential caller of R (extended raiser of Ex)
--inside a checked compilation unit U

--It is expensive check but it could be optimize
--using a Check_For_Subprogram_Body (Ex). The last would avoid any redundant
--check for a corresponding body that has an appropriate handler H of Ex.

--For now just a simplified version of the rule checking is implemented.
--It is not full enough and uses just a direct (not extended) raisers and
--a simplified optimization (that works for compilation unit bodies only).

--It means that Check_Raiser(R,Ex,U) need not to check any subrogram unit U
--that ends by a handler of Ex.

with Asis.Extensions.Flat_Kinds;      use Asis.Extensions.Flat_Kinds;

separate (Gch.Rules)
function QS_4_3_1_11 (E : Element) return Boolean is
   Arg_Kind : Flat_Element_Kinds := Flat_Element_Kind (E);
   --  Kind of the Element being visited.
   TempUnit : Asis.Compilation_Unit;   -- a temp for units
   Ex_Def : Element; -- Exception Name definition for checked exception
   Result : Boolean := True; -- function result ###VK-- do we really need it?

   --  search Handler_List for references to exceptions of Exc
   --  If successes then returns True
   --  If fails then returns False
   function Check_Handlers (Handler_List : Element_List) return Boolean;

   -- checks if raiser E is inside a Handler_list Handl
   -- it is made as a function to simplify possible changes
   function Is_Raised_Inside (Handl : Element_List) return Boolean;
   function Is_Raised_Inside (Handl : Element_List) return Boolean is
      Handl_Span : Span := Element_Span (Handl (Handl'First));
      Raiser_Span : Span := Element_Span (E);
   begin
      return Handl_Span.First_Line <= Raiser_Span.First_Line and then
             Handl_Span.First_Column <= Raiser_Span.First_Column;
   end Is_Raised_Inside;

   -- check if a handler for the exception Ex
   -- exists for an enclosing body for the raiser E
   function Check_Raiser (Ex : Element) return Boolean;
   function Check_Raiser (Ex : Element) return Boolean is

      --  An attempt to optimize
      --  Check_For_Subprogram_Body
      Checked_Unit : Compilation_Unit := Enclosing_Compilation_Unit (E);
      U_Kind : Unit_Kinds := Unit_Kind (Checked_Unit);

      --  ###VK to provide the optimization
      --  ###VK uncomment when compiling with ASIS version 3.11b2.2
      --  ###VK or later
--      Handler_List : Element_List := Body_Exception_Handlers
--               (Corresponding_Body
--                  (Unit_Declaration
--                     (Checked_Unit)));

      Is_Decl : Boolean := False; -- is used to prevent moving up

      -- if Ex_Def raised by Ex has a handler "enclosing" El
      function Check_Extended_Raiser (El : Element) return Boolean;
      function Check_Extended_Raiser (El : Element) return Boolean is
         El_Kind : Flat_Element_Kinds := Flat_Element_Kind (El);

         -- working with Handler_List of a statement or declaration Ext
         function Check_Ext_Handlers
            (Ext : Element; Handler_List : Element_List) return Boolean;
         function Check_Ext_Handlers
            (Ext : Element; Handler_List : Element_List) return Boolean is

            begin
            --  Handler_List is a corresponding handler list
               if Is_Nil (Handler_List) then
                  -- move up recursively till appropriate Ext_Kind
                  return Check_Extended_Raiser (Enclosing_Element (Ext));
               end if;

               -- is raiser inside the handler list?
               if Is_Raised_Inside (Handler_List) then
                  return True;
               end if;

               if Check_Handlers (Handler_List) then
                  return True;
               else
                  -- move up recursively till appropriate Ext_Kind
                  return Check_Extended_Raiser (Enclosing_Element (Ext));
               end if;
            end Check_Ext_Handlers;

      begin
         if Is_Nil (El) or else Is_Decl then
            return False;
         end if;
         -- First of all we try to find a corresponding body for E
         if not (El_Kind in Flat_Statement_Kinds
                   or else El_Kind in Flat_Declaration_Kinds) then
            -- move up recursively till appropriate Ext_Kind
            return Check_Extended_Raiser (Enclosing_Element (El));
         end if;

         case El_Kind is
            when A_Function_Body_Declaration  |
                 A_Procedure_Body_Declaration
--                | A_Task_Body_Declaration --  ###VK
--                | A_Protected_Body_Declaration  --  ###VK
                 =>
                    Is_Decl := True; -- to prevent moving up

                    --  getting corresponding handlers
                    return Check_Ext_Handlers
                                (El, Body_Exception_Handlers (El));

            when A_Block_Statement
                 => return Check_Ext_Handlers
                              (El, Block_Exception_Handlers (El));
            when An_Accept_Statement
                 --  getting corresponding handlers
                 => return Check_Ext_Handlers
                              (El, Accept_Body_Exception_Handlers (El));

            when others
                 => -- move up recursively till appropriate Ext_Kind
                    return Check_Extended_Raiser (Enclosing_Element (El));
         end case;

      end Check_Extended_Raiser;

   begin
      Ex_Def := Corresponding_Name_Definition (Ex);


      --  An attempt to optimize the check
      --  ###VK to provide the optimization
      --  ###VK uncomment when compiling with ASIS version 3.11b2.2
      --  ###VK or later
--      if U_Kind = A_Procedure or else
--         U_Kind = A_Function or else
--         U_Kind = A_Procedure_Body or else
--         U_Kind = A_Function_Body or else
--         U_Kind = A_Procedure_Body or else
--         U_Kind = A_Procedure_Body_Subunit or else
--         U_Kind = A_Function_Body_Subunit
--      then
--         if not Is_Nil (Handler_List) and then
--            Check_Handlers (Handler_list)
--         then
--            return True;
--         end if;
--      end if;

      -- if Ex_Def raised by Ex has a handler "enclosing" E
      return Check_Extended_Raiser (Enclosing_Element (E));
   end Check_Raiser;

   function Check_Handlers (Handler_List : Element_List) return Boolean is
   begin

      -- Pre-condition: not Is_Nil (Handler_List)
      declare -- Check for "other" choice
         Last_Handler : Element := Handler_List (Handler_List'Last);
         Choices : Element_List := Exception_Choices (Last_Handler);
         Last_Choice : Element := Choices (Choices'Last);
      begin
         if Definition_Kind (Last_Choice) = An_Others_Choice then
            return True;
         end if;
      end;

      for J in Handler_List'range loop
         declare
            Choices : Element_List := Exception_Choices (Handler_List (J));

         begin
            for K in Choices'range loop
               declare
                  Choice_K : Element := Choices (K);
                  Choice_Kind : Flat_Element_Kinds :=
                         Flat_Element_Kind (Choice_K);
                  Handling_Exception : Element;
               begin
                  if Choice_Kind = A_Selected_Component then
                     Handling_Exception := Corresponding_Name_Definition
                                             (Selector (Choice_K));
                  else
                     Handling_Exception := Corresponding_Name_Definition
                                             (Choice_K);
                  end if;

                  if Is_Equal (Ex_Def, Handling_Exception) then

                  -- Ex_Def is_referenced by Choices (K)
                     return True;
                  end if;
               end;
            end loop;
         end;
      end loop;

      --  No handler for the exception Exc
      return False;
   end Check_Handlers;

begin
   --  we have to ignore any predefined exception in the rule
   --  that is why we check here a rule concerning raising of
   --  predefined exceptions QS_4_3_1_10
   if not QS_4_3_1_10 (E) then
      return True;
   end if;

   case Arg_Kind is

      -- a raise statement
      when A_Raise_Statement =>
         declare
         -- check if a handler for Raised_Exception (E)
         -- exists for an enclosing body for the raiser E
            Raised : Element := Raised_Exception (E);
            Raise_Kind : Flat_Element_Kinds;
         begin
            if Is_Nil (Raised) then
               return True; -- empty raiser should be ignored
            end if;

            Raise_Kind := Flat_Element_Kind (Raised);

            if Raise_Kind = A_Selected_Component then
               Raised := Selector (Raised);
            end if;
            return Check_Raiser (Raised);
         end;

      -- nothing concerning exception raising
      when others => return True;
   end case;

   return Result;  -- do we need this here?
exception  -- ###VK to think more concerning list of exceptions
   -- and also moving such handlers one step up
   when Asis_Inappropriate_Context          |
         Asis_Inappropriate_Container        |
         Asis_Inappropriate_Compilation_Unit |
         Asis_Inappropriate_Element          |
         Asis_Inappropriate_Line             |
         Asis_Inappropriate_Line_Number      |
         Asis_Failed
         =>
      Report_Asis_Failure ("QS_4_3_1_11");
      return True;

end QS_4_3_1_11;