← Back to branch summary

~ubuntu-branches/ubuntu/jaunty/adacontrol/jaunty

« back to all changes in this revision

Viewing changes to src/rules-duplicate_initialization_calls.adb

  • Committer: Bazaar Package Importer
  • Author(s): Ludovic Brenta
  • Date: 2008-04-27 15:25:59 UTC
  • mfrom: (1.1.3 upstream)
  • Revision ID: james.westby@ubuntu.com-20080427152559-qrlic533a1x02flu
Tags: 1.8r8-1

* New upstream version.
* debian/adacontrol.gpr: delete; use upstream's project file instead.
* patches/build.patch: patch upstream's project file to change Object_Dir
  and Exec_Dir.
* Build-depend on asis 2007 and gnat-4.3.
* Add support for mips, mipsel and ppc64.
* Build and provide ptree.
* ptree.1: new.
* adactl.1: update; new options and rules are available.

Show diffs side-by-side

added added

removed removed

Lines of Context:
src/rules-duplicate_initialization_calls.adb
 
1
----------------------------------------------------------------------
 
2
--  Rules.Duplicate_Initialization_Calls - Package body             --
 
3
--                                                                  --
 
4
--  This software  is (c) The European Organisation  for the Safety --
 
5
--  of Air  Navigation (EUROCONTROL) and Adalog  2004-2007. The Ada --
 
6
--  Controller  is  free software;  you can redistribute  it and/or --
 
7
--  modify  it under  terms of  the GNU  General Public  License as --
 
8
--  published by the Free Software Foundation; either version 2, or --
 
9
--  (at your  option) any later version.  This  unit is distributed --
 
10
--  in the hope  that it will be useful,  but WITHOUT ANY WARRANTY; --
 
11
--  without even the implied warranty of MERCHANTABILITY or FITNESS --
 
12
--  FOR A  PARTICULAR PURPOSE.  See the GNU  General Public License --
 
13
--  for more details.   You should have received a  copy of the GNU --
 
14
--  General Public License distributed  with this program; see file --
 
15
--  COPYING.   If not, write  to the  Free Software  Foundation, 59 --
 
16
--  Temple Place - Suite 330, Boston, MA 02111-1307, USA.           --
 
17
--                                                                  --
 
18
--  As  a special  exception, if  other files  instantiate generics --
 
19
--  from the units  of this program, or if you  link this unit with --
 
20
--  other files  to produce  an executable, this  unit does  not by --
 
21
--  itself cause the resulting executable  to be covered by the GNU --
 
22
--  General  Public  License.   This  exception  does  not  however --
 
23
--  invalidate any  other reasons why the executable  file might be --
 
24
--  covered by the GNU Public License.                              --
 
25
--                                                                  --
 
26
--  This  software is  distributed  in  the hope  that  it will  be --
 
27
--  useful,  but WITHOUT  ANY  WARRANTY; without  even the  implied --
 
28
--  warranty  of  MERCHANTABILITY   or  FITNESS  FOR  A  PARTICULAR --
 
29
--  PURPOSE.                                                        --
 
30
----------------------------------------------------------------------
 
31
 
 
32
-- Asis
 
33
with
 
34
  Asis.Elements,
 
35
  Asis.Expressions;
 
36
 
 
37
-- Adalog
 
38
with
 
39
  Thick_Queries,
 
40
  Utilities;
 
41
 
 
42
-- Adactl
 
43
with
 
44
  Framework.Element_Queues,
 
45
  Framework.Language,
 
46
  Framework.Rules_Manager,
 
47
  Framework.Reports;
 
48
 
 
49
package body Rules.Duplicate_Initialization_Calls is
 
50
   use Framework;
 
51
 
 
52
   -- Algorithm
 
53
   --
 
54
   -- We simply keep in the context of each indicated procedure a list of all encountered calls.
 
55
   -- A new call is checked against all existing calls, then added to the list.
 
56
 
 
57
   type Procedure_Context is new Basic_Rule_Context with
 
58
      record
 
59
         Profile_Checked : Boolean;
 
60
         Has_Out         : Boolean;
 
61
         Other_Calls     : Framework.Element_Queues.Queue;
 
62
      end record;
 
63
 
 
64
   Rule_Used : Boolean := False;
 
65
   Save_Used : Boolean;
 
66
 
 
67
   Applicable_Calls  : Context_Store;
 
68
 
 
69
   ----------
 
70
   -- Help --
 
71
   ----------
 
72
 
 
73
   procedure Help is
 
74
      use Utilities;
 
75
   begin
 
76
      User_Message ("Rule: " & Rule_Id);
 
77
      User_Message ("Parameter(s): <Procedure name>");
 
78
      User_Message ("Control that indicated procedures are not called twice with identical in parameters,");
 
79
      User_Message ("or twice on the same out actual parameter");
 
80
   end Help;
 
81
 
 
82
   -----------------
 
83
   -- Add_Control --
 
84
   -----------------
 
85
 
 
86
   procedure Add_Control (Ctl_Label     : in Wide_String; Ctl_Kind : in Control_Kinds) is
 
87
      use Framework.Language, Framework.Element_Queues;
 
88
 
 
89
   begin
 
90
      if not Parameter_Exists then
 
91
         Parameter_Error (Rule_Id, "at least one parameter required");
 
92
      end if;
 
93
 
 
94
      while Parameter_Exists loop
 
95
         declare
 
96
            Entity : constant Entity_Specification := Get_Entity_Parameter;
 
97
         begin
 
98
            Associate (Applicable_Calls,
 
99
                       Entity,
 
100
                       Procedure_Context'(Basic.New_Context (Ctl_Kind, Ctl_Label) with
 
101
                                          Profile_Checked => False,
 
102
                                          Has_Out         => False,
 
103
                                          Other_Calls     => Empty_Queue));
 
104
         exception
 
105
            when Already_In_Store =>
 
106
               Parameter_Error (Rule_Id, "entity already given: " & Image (Entity));
 
107
         end;
 
108
      end loop;
 
109
 
 
110
      Rule_Used := True;
 
111
   end Add_Control;
 
112
 
 
113
   -------------
 
114
   -- Command --
 
115
   -------------
 
116
 
 
117
   procedure Command (Action : Framework.Rules_Manager.Rule_Action) is
 
118
      use Framework.Rules_Manager;
 
119
   begin
 
120
      case Action is
 
121
         when Clear =>
 
122
            Rule_Used := False;
 
123
            Clear (Applicable_Calls);
 
124
         when Suspend =>
 
125
            Save_Used := Rule_Used;
 
126
            Rule_Used := False;
 
127
         when Resume =>
 
128
            Rule_Used := Save_Used;
 
129
      end case;
 
130
   end Command;
 
131
 
 
132
   -------------
 
133
   -- Prepare --
 
134
   -------------
 
135
 
 
136
   procedure Prepare is
 
137
   begin
 
138
      Balance (Applicable_Calls);
 
139
   end Prepare;
 
140
 
 
141
   ----------------------------
 
142
   -- Process_Procedure_Call --
 
143
   ----------------------------
 
144
 
 
145
   procedure Process_Procedure_Call (Call : in Asis.Statement) is
 
146
      use Framework.Element_Queues, Framework.Reports, Thick_Queries, Utilities;
 
147
      use Asis, Asis.Elements, Asis.Expressions;
 
148
 
 
149
      procedure Check_Profile (Formals             : in  Asis.Parameter_Specification_List;
 
150
                               Out_Parameter_Found : out Boolean)
 
151
      is
 
152
         -- Check that the profile includes only in parameters, except possibly one out parameter
 
153
         use Framework.Language;
 
154
      begin
 
155
         Out_Parameter_Found := False;
 
156
         for I in Formals'Range loop
 
157
            case Mode_Kind (Formals (I)) is
 
158
               when Not_A_Mode =>
 
159
                  Failure ("not a mode in parameter specification");
 
160
               when A_Default_In_Mode | An_In_Mode =>
 
161
                  null;
 
162
               when An_Out_Mode =>
 
163
                  if Out_Parameter_Found then
 
164
                     Parameter_Error (Rule_Id,
 
165
                                      "not a proper initialization procedure, more than one out parameter ("
 
166
                                      & Adjust_Image (Full_Name_Image (Formal_Parameter (Formals (I))))
 
167
                                      & ')'
 
168
                                     );
 
169
                  end if;
 
170
                  Out_Parameter_Found := True;
 
171
               when An_In_Out_Mode =>
 
172
                  Parameter_Error (Rule_Id,
 
173
                                   "not a proper initialization procedure, parameter "
 
174
                                   & Adjust_Image (Full_Name_Image (Formal_Parameter (Formals (I))))
 
175
                                   & " has in out mode"
 
176
                                  );
 
177
            end case;
 
178
         end loop;
 
179
      end Check_Profile;
 
180
 
 
181
      procedure Check_Actuals (Actuals : Asis.Association_List; Context : Procedure_Context) is
 
182
         -- Check that all parameters are static (case where there is no out parameter)
 
183
      begin
 
184
         for I in Actuals'Range loop
 
185
            if Static_Expression_Value_Image (Actual_Parameter (Actuals (I))) = "" then
 
186
               Report (Rule_Id,
 
187
                       Context,
 
188
                       Get_Location (Actual_Parameter (Actuals (I))),
 
189
                       "non static value in call to initialization procedure");
 
190
            end if;
 
191
         end loop;
 
192
      end Check_Actuals;
 
193
 
 
194
      function Are_Equivalent_Calls (Formals   : Asis.Parameter_Specification_List;
 
195
                                     L_Actuals : Asis.Association_List;
 
196
                                     R_Call    : Asis.Statement)
 
197
                                     return Boolean
 
198
      is
 
199
         -- check that calls do not have the same parameters
 
200
         R_Actuals : constant Asis.Association_List := Actual_Parameters (R_Call, Normalized => True);
 
201
 
 
202
         All_In_Parameters_Equal : Boolean := True;
 
203
         Var_Proximity           : Proximity;
 
204
      begin
 
205
         for I in Formals'Range loop
 
206
            case Mode_Kind (Formals (I)) is
 
207
               when Not_A_Mode | An_In_Out_Mode =>
 
208
                  Failure ("bad mode in Are_Equivalent_Calls");
 
209
               when A_Default_In_Mode | An_In_Mode =>
 
210
                  if not Same_Value (Actual_Parameter (L_Actuals (I)), Actual_Parameter (R_Actuals (I))) then
 
211
                     All_In_Parameters_Equal := False;
 
212
                  end if;
 
213
               when An_Out_Mode =>
 
214
                  -- At this point, there can be only one out parameter
 
215
                  -- (checked by Check_Profile)
 
216
                  Var_Proximity := Variables_Proximity (Actual_Parameter (L_Actuals (I)),
 
217
                                                        Actual_Parameter (R_Actuals (I)));
 
218
                  if Var_Proximity = Same_Variable then
 
219
                     return True;
 
220
                  elsif Var_Proximity = Different_Variables then
 
221
                     return False;
 
222
                  else
 
223
                     Uncheckable (Rule_Id,
 
224
                                  False_Negative,
 
225
                                  Get_Location (Actual_Parameter (L_Actuals (I))),
 
226
                                  "non statically determinable out parameter");
 
227
                     return False;
 
228
                  end if;
 
229
            end case;
 
230
         end loop;
 
231
 
 
232
         return All_In_Parameters_Equal;
 
233
      end Are_Equivalent_Calls;
 
234
 
 
235
   begin
 
236
      if not Rule_Used then
 
237
         return;
 
238
      end if;
 
239
      Rules_Manager.Enter (Rule_Id);
 
240
 
 
241
      declare
 
242
         Current_Context : Root_Context'Class
 
243
           := Matching_Context (Applicable_Calls, Ultimate_Name (Called_Simple_Name (Call)));
 
244
      begin
 
245
         if Current_Context = No_Matching_Context then
 
246
            return;
 
247
         end if;
 
248
 
 
249
         declare
 
250
            Good_Context : Procedure_Context renames Procedure_Context (Current_Context);
 
251
            Current      : Cursor := First (Good_Context.Other_Calls);
 
252
            Formals      : constant Asis.Parameter_Specification_List := Called_Profile (Call);
 
253
            L_Actuals    : constant Asis.Association_List             := Actual_Parameters (Call, Normalized => True);
 
254
         begin
 
255
            if not Good_Context.Profile_Checked then
 
256
               Check_Profile (Formals, Good_Context.Has_Out);
 
257
               Good_Context.Profile_Checked := True;
 
258
            end if;
 
259
 
 
260
            if not Good_Context.Has_Out then
 
261
               Check_Actuals (L_Actuals, Good_Context);
 
262
            end if;
 
263
 
 
264
            while Has_Element (Current) loop
 
265
               if Are_Equivalent_Calls (Formals, L_Actuals, Fetch (Current)) then
 
266
                  Report (Rule_Id,
 
267
                          Current_Context,
 
268
                          Get_Location (Call),
 
269
                          "initialization call duplicates call at " & Image (Get_Location (Fetch (Current))));
 
270
                  return;
 
271
                  -- No need to add this call to the queue
 
272
               end if;
 
273
               Current := Next (Current);
 
274
            end loop;
 
275
            Append (Good_Context.Other_Calls, Call);
 
276
         end;
 
277
         Update (Applicable_Calls, Current_Context);
 
278
      end;
 
279
   end Process_Procedure_Call;
 
280
 
 
281
begin
 
282
   Framework.Rules_Manager.Register (Rule_Id,
 
283
                                     Rules_Manager.Semantic,
 
284
                                     Help_CB        => Help'Access,
 
285
                                     Add_Control_CB => Add_Control'Access,
 
286
                                     Command_CB     => Command'Access,
 
287
                                     Prepare_CB     => Prepare'Access);
 
288
end Rules.Duplicate_Initialization_Calls;