← Back to branch summary

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

« back to all changes in this revision

Viewing changes to src/rules-instantiations.adb

  • Committer: Bazaar Package Importer
  • Author(s): Ludovic Brenta
  • Date: 2006-08-24 08:44:11 UTC
  • Revision ID: james.westby@ubuntu.com-20060824084411-1r15uio1h75lqgpx
Tags: upstream-1.4r20
Import upstream version 1.4r20

Show diffs side-by-side

added added

removed removed

Lines of Context:
src/rules-instantiations.adb
 
1
----------------------------------------------------------------------
 
2
--  Rules.Instantiations - Package body                             --
 
3
--                                                                  --
 
4
--  This software  is (c) The European Organisation  for the Safety --
 
5
--  of Air  Navigation (EUROCONTROL) and Adalog  2004-2005. 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.Declarations,
 
36
  Asis.Expressions;
 
37
 
 
38
-- Ada
 
39
with
 
40
  Ada.Strings.Wide_Unbounded,
 
41
  Ada.Unchecked_Deallocation;
 
42
 
 
43
-- Adalog
 
44
with
 
45
  Utilities,
 
46
  Thick_Queries;
 
47
 
 
48
-- Adactl
 
49
with
 
50
  Framework.Language,
 
51
  Framework.Rules_Manager,
 
52
  Framework.Reports;
 
53
 
 
54
package body Rules.Instantiations is
 
55
   use Framework;
 
56
 
 
57
   Rule_Used : Boolean := False;
 
58
   Save_Used : Boolean;
 
59
 
 
60
   type Generic_Parameters is array (Positive range <>)
 
61
     of Entity_Specification;
 
62
 
 
63
   type Generic_Parameter_List is access Generic_Parameters;
 
64
 
 
65
   type Instantiation_Context is new Simple_Context with
 
66
      record
 
67
         Count  : Natural;
 
68
         Values : Generic_Parameter_List;
 
69
      end record;
 
70
   procedure Clear (Context : in out Instantiation_Context);
 
71
 
 
72
   Rule_Uses : Context_Store;
 
73
 
 
74
   ----------
 
75
   -- Free --
 
76
   ----------
 
77
 
 
78
   procedure Free is
 
79
      new Ada.Unchecked_Deallocation (Generic_Parameters, Generic_Parameter_List);
 
80
 
 
81
   -----------
 
82
   -- Image --
 
83
   -----------
 
84
 
 
85
   function Image (Values : in Generic_Parameter_List) return Wide_String is
 
86
      -- Precondition: Values /= null
 
87
      use Ada.Strings.Wide_Unbounded;
 
88
 
 
89
      Dummy : Unbounded_Wide_String := Null_Unbounded_Wide_String;
 
90
   begin
 
91
      Append (Dummy, "(");
 
92
      Append (Dummy, Image (Values (Values'First)));
 
93
 
 
94
      for I in Values'First + 1 .. Values'Last loop
 
95
         Append (Dummy, ", ");
 
96
         Append (Dummy, Image (Values (I)));
 
97
      end loop;
 
98
 
 
99
      Append (Dummy, ")");
 
100
 
 
101
      return To_Wide_String (Dummy);
 
102
   end Image;
 
103
 
 
104
   ---------------
 
105
   -- Add_Value --
 
106
   ---------------
 
107
 
 
108
   procedure Add_Value (Values : in out Generic_Parameter_List; Value : in Entity_Specification) is
 
109
      New_Values : Generic_Parameter_List;
 
110
   begin
 
111
      if Values = null then
 
112
         New_Values := new Generic_Parameters' ((1 => Value));
 
113
      else
 
114
         New_Values := new Generic_Parameters' (Values.all & Value);
 
115
      end if;
 
116
 
 
117
      Free (Values);
 
118
      Values := New_Values;
 
119
   end Add_Value;
 
120
 
 
121
   ----------
 
122
   -- Help --
 
123
   ----------
 
124
 
 
125
   procedure Help is
 
126
      use Utilities;
 
127
   begin
 
128
      User_Message ("Rule: " & Rule_Id);
 
129
      User_Message ("Parameter 1     : <Generic name>");
 
130
      User_Message ("Parameter 2 .. N: <Entity name> (optional)");
 
131
      User_Message ("Control generic instantiations, either all of them");
 
132
      User_Message ("or those made with the given entities");
 
133
   end Help;
 
134
 
 
135
   -------------
 
136
   -- Add_Use --
 
137
   -------------
 
138
 
 
139
   procedure Add_Use (Label     : in Wide_String;
 
140
                      Rule_Type : in Rule_Types) is
 
141
      use Ada.Strings.Wide_Unbounded;
 
142
      use Framework.Language;
 
143
   begin
 
144
      if not Parameter_Exists then
 
145
         Parameter_Error ("At least one parameter required for rule " & Rule_Id);
 
146
      end if;
 
147
 
 
148
      declare
 
149
         Generic_Name   : constant Entity_Specification   := Get_Entity_Parameter;
 
150
         Generic_Params :          Generic_Parameter_List := null;
 
151
      begin
 
152
         while Parameter_Exists loop
 
153
            Add_Value (Generic_Params, Get_Entity_Parameter);
 
154
         end loop;
 
155
 
 
156
         Associate (Rule_Uses,
 
157
                    Generic_Name,
 
158
                    Instantiation_Context'(Rule_Type,
 
159
                                           To_Unbounded_Wide_String (Label),
 
160
                                           0,
 
161
                                           Generic_Params),
 
162
                    Additive => True);
 
163
         Rule_Used := True;
 
164
      exception
 
165
         when Already_In_Store =>
 
166
            Parameter_Error ("This combination of parameters already specified for " & Image (Generic_Name)
 
167
                             & " in rule " & Rule_ID);
 
168
      end;
 
169
   end Add_Use;
 
170
 
 
171
   -----------
 
172
   -- Clear --
 
173
   -----------
 
174
 
 
175
   procedure Clear (Context : in out Instantiation_Context) is
 
176
   begin
 
177
      Free (Context.Values);
 
178
   end Clear;
 
179
 
 
180
   -------------
 
181
   -- Command --
 
182
   -------------
 
183
 
 
184
   procedure Command (Action : Framework.Rules_Manager.Rule_Action) is
 
185
      use Framework.Rules_Manager;
 
186
   begin
 
187
      case Action is
 
188
         when Clear =>
 
189
            Rule_Used := False;
 
190
            Clear (Rule_Uses);
 
191
         when Suspend =>
 
192
            Save_Used := Rule_Used;
 
193
            Rule_Used := False;
 
194
         when Resume =>
 
195
            Rule_Used := Save_Used;
 
196
      end case;
 
197
   end Command;
 
198
 
 
199
   -------------
 
200
   -- Prepare --
 
201
   -------------
 
202
 
 
203
   procedure Prepare is
 
204
   begin
 
205
      Balance (Rule_Uses);
 
206
   end Prepare;
 
207
 
 
208
   ----------------------
 
209
   -- Is_Corresponding --
 
210
   ----------------------
 
211
 
 
212
   function Is_Corresponding (Value      : in Entity_Specification;
 
213
                              Definition : in Asis.Definition) return Boolean is
 
214
      use Asis, Asis.Elements, Asis.Declarations;
 
215
      use Utilities, Thick_Queries;
 
216
 
 
217
      Declaration : constant Asis.Declaration := Enclosing_Element (Definition);
 
218
 
 
219
      Dummy_Definition : Asis.Definition;
 
220
   begin
 
221
      case Declaration_Kind (Declaration) is
 
222
         when An_Ordinary_Type_Declaration
 
223
           | A_Task_Type_Declaration
 
224
           | A_Protected_Type_Declaration
 
225
           | A_Private_Type_Declaration
 
226
           | A_Private_Extension_Declaration
 
227
           | A_Subtype_Declaration
 
228
           | A_Formal_Type_Declaration
 
229
           =>
 
230
            Dummy_Definition := Names (Corresponding_First_Subtype (Declaration))(1);
 
231
 
 
232
         when others =>
 
233
            Dummy_Definition := Definition;
 
234
      end case;
 
235
 
 
236
      return To_Upper (Image (Value)) = To_Upper (Full_Name_Image (Dummy_Definition));
 
237
   end Is_Corresponding;
 
238
 
 
239
   -----------
 
240
   -- Match --
 
241
   -----------
 
242
 
 
243
   function Match (Actual_Part : in Asis.Association_List;
 
244
                   Values      : in Generic_Parameter_List) return Boolean is
 
245
      use Asis, Asis.Elements, Asis.Expressions;
 
246
 
 
247
      Parameter    : Expression;
 
248
      Definition   : Asis.Definition;
 
249
      Values_Index : Natural         := Values'First;
 
250
   begin
 
251
      for I in Actual_Part'Range loop
 
252
         Parameter := Actual_Parameter (Actual_Part (I));
 
253
 
 
254
         if not Is_Box (Values (Values_Index)) then
 
255
            case Expression_Kind (Parameter) is
 
256
               when An_Identifier =>
 
257
                  Definition := Corresponding_Name_Definition (Parameter);
 
258
 
 
259
               when A_Selected_Component =>
 
260
                  Definition := Corresponding_Name_Definition (Selector (Parameter));
 
261
 
 
262
               when others =>
 
263
                  -- An arithmetic expression for example, not much we can do with it
 
264
                  return False;
 
265
            end case;
 
266
 
 
267
            if not Is_Corresponding (Values (Values_Index), Definition) then
 
268
               return False;
 
269
            end if;
 
270
         end if;
 
271
 
 
272
         -- Safety if there are too many parameters specified by user:
 
273
         exit when Values_Index = Values'Last;
 
274
 
 
275
         Values_Index := Values_Index + 1;
 
276
      end loop;
 
277
 
 
278
      return True;
 
279
   end Match;
 
280
 
 
281
   ---------------------------
 
282
   -- Process_Instantiation --
 
283
   ---------------------------
 
284
 
 
285
   procedure Process_Instantiation (Instantiation : in Asis.Declaration) is
 
286
      use Asis.Declarations;
 
287
 
 
288
      procedure Process_Context (Context : Rule_Context'Class; Finished : out Boolean) is
 
289
         use Asis, Framework.Reports, Ada.Strings.Wide_Unbounded;
 
290
      begin
 
291
         if Context = No_Matching_Context then
 
292
            Finished := True;
 
293
            return;
 
294
         end if;
 
295
         Finished := False;
 
296
 
 
297
         declare
 
298
            use Utilities;
 
299
            Good_Context : Instantiation_Context := Instantiation_Context (Context);
 
300
         begin
 
301
            if Good_Context.Values = null then
 
302
               Good_Context.Count := Good_Context.Count + 1;
 
303
               Update (Rule_Uses, Good_Context);
 
304
               Report (Rule_Id,
 
305
                       To_Wide_String (Good_Context.Rule_Label),
 
306
                       Good_Context.Rule_Type,
 
307
                       Get_Location (Instantiation),
 
308
                       "instantiation of """ & To_Title (Last_Matching_Name (Rule_Uses))
 
309
                         & """ (" & Natural'Wide_Image (Good_Context.Count) & ")");
 
310
            else
 
311
               declare
 
312
                  Actual_Part : constant Asis.Association_List
 
313
                    := Generic_Actual_Part (Instantiation, Normalized => True);
 
314
               begin
 
315
                  if Match (Actual_Part, Good_Context.Values) then
 
316
                     Good_Context.Count := Good_Context.Count + 1;
 
317
                     Update (Rule_Uses, Good_Context);
 
318
                     Report (Rule_Id,
 
319
                             To_Wide_String (Good_Context.Rule_Label),
 
320
                             Good_Context.Rule_Type,
 
321
                             Get_Location (Instantiation),
 
322
                             "instantiation of """ & To_Title (Last_Matching_Name (Rule_Uses))
 
323
                               & """ (" & Natural'Wide_Image (Good_Context.Count) & ")"
 
324
                               & " with " & Image (Good_Context.Values));
 
325
                  end if;
 
326
               end;
 
327
            end if;
 
328
         end;
 
329
      end Process_Context;
 
330
 
 
331
      Finished : Boolean;
 
332
   begin
 
333
      if not Rule_Used then
 
334
         return;
 
335
      end if;
 
336
      Rules_Manager.Enter (Rule_Id);
 
337
 
 
338
      Process_Context (Matching_Context (Rule_Uses, Generic_Unit_Name (Instantiation)), Finished);
 
339
      while not Finished loop
 
340
         Process_Context (Next_Matching_Context (Rule_Uses), Finished);
 
341
      end loop;
 
342
   end Process_Instantiation;
 
343
 
 
344
begin
 
345
   Framework.Rules_Manager.Register (Rule_Id,
 
346
                                     Help    => Help'Access,
 
347
                                     Add_Use => Add_Use'Access,
 
348
                                     Command => Command'Access,
 
349
                                     Prepare => Prepare'Access);
 
350
end Rules.Instantiations;