← Back to branch summary

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

« back to all changes in this revision

Viewing changes to src/rules-local_hiding.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-local_hiding.adb
38
38
 
39
39
-- Adalog
40
40
with
 
41
  A4G_Bugs,
41
42
  Thick_Queries,
42
43
  Utilities;
43
44
 
47
48
  Framework.Rules_Manager,
48
49
  Framework.Reports,
49
50
  Framework.Scope_Manager;
 
51
pragma Elaborate (Framework.Language);
50
52
 
51
53
package body Rules.Local_Hiding is
52
54
   use Framework, Utilities;
61
63
   -- is already the procedure itself, but the name must be attached to where the procedure is declared,
62
64
   -- i.e. the enclosing scope.
63
65
 
64
 
   Rule_Used    : Boolean := False;
65
 
   Save_Used    : Boolean;
66
 
   Rule_Context : Basic_Rule_Context;
 
66
   type Subrules is (Strict, Overloading, Both);
 
67
   subtype True_Subrules is Subrules range Strict .. Overloading;
 
68
   package Subrules_Flag_Utilities is new Framework.Language.Flag_Utilities (Subrules);
 
69
 
 
70
   type Rule_Usage is array (True_Subrules) of Boolean;
 
71
   Not_Used : constant Rule_Usage := (others => False);
 
72
 
 
73
   Rule_Used    : Rule_Usage := Not_Used;
 
74
   Save_Used    : Rule_Usage;
 
75
   Rule_Context : array (True_Subrules) of Basic_Rule_Context;
67
76
 
68
77
   type Identifier_Data (Length : Positive) is
69
78
      record
70
79
         Name        : Wide_String (1..Length);
71
80
         Short_Last  : Positive;
72
81
         Elem        : Asis.Element;
 
82
         Other_Elem  : Asis.Element;
73
83
         Is_Callable : Boolean;
74
84
      end record;
75
85
   package Visible_Identifiers is new Framework.Scope_Manager.Scoped_Store (Identifier_Data);
79
89
   ----------
80
90
 
81
91
   procedure Help is
 
92
      use Subrules_Flag_Utilities;
82
93
   begin
83
94
      User_Message ("Rule: " & Rule_Id);
84
 
      User_Message ("Parameter(s): none");
 
95
      Help_On_Flags ("Parameter(s): ", Footer => "(default = strict)");
85
96
      User_Message ("Control occurrences of local identifiers that hide an outer identical name");
86
97
   end Help;
87
98
 
88
 
   -------------
89
 
   -- Add_Use --
90
 
   -------------
91
 
 
92
 
   procedure Add_Use (Label         : in Wide_String;
93
 
                      Rule_Use_Type : in Rule_Types) is
94
 
      use Framework.Language;
95
 
 
 
99
   -----------------
 
100
   -- Add_Control --
 
101
   -----------------
 
102
 
 
103
   procedure Add_Control (Ctl_Label : in Wide_String; Ctl_Kind : in Control_Kinds) is
 
104
      use Framework.Language, Subrules_Flag_Utilities;
 
105
      Subrule : Subrules;
96
106
   begin
97
 
      if Rule_Used then
98
 
         Parameter_Error (Rule_Id, "this rule can be specified only once");
99
 
      end if;
100
 
 
101
 
      if  Parameter_Exists then
102
 
         Parameter_Error (Rule_Id, "No parameter allowed");
103
 
      end if;
104
 
 
105
 
      Rule_Context := Basic.New_Context (Rule_Use_Type, Label);
106
 
      Rule_Used    := True;
107
 
   end Add_Use;
 
107
      if Parameter_Exists then
 
108
         while Parameter_Exists loop
 
109
            Subrule := Get_Flag_Parameter (Allow_Any => False);
 
110
            case Subrule is
 
111
               when True_Subrules =>
 
112
                  if Rule_Used (Subrule) then
 
113
                     Parameter_Error (Rule_Id, "subrule already specified");
 
114
                  end if;
 
115
                  Rule_Used    (Subrule) := True;
 
116
                  Rule_Context (Subrule) := Basic.New_Context (Ctl_Kind, Ctl_Label);
 
117
               when Both =>
 
118
                  if Rule_Used /= (True_Subrules => False) then
 
119
                     Parameter_Error (Rule_Id, "subrule already specified");
 
120
                  end if;
 
121
                  Rule_Used    := (others => True);
 
122
                  Rule_Context := (others => Basic.New_Context (Ctl_Kind, Ctl_Label));
 
123
            end case;
 
124
         end loop;
 
125
      else
 
126
         Rule_Used    (Strict) := True;
 
127
         Rule_Context (Strict) := Basic.New_Context (Ctl_Kind, Ctl_Label);
 
128
      end if;
 
129
   end Add_Control;
108
130
 
109
131
   -------------
110
132
   -- Command --
115
137
   begin
116
138
      case Action is
117
139
         when Clear =>
118
 
            Rule_Used  := False;
 
140
            Rule_Used  := Not_Used;
119
141
         when Suspend =>
120
142
            Save_Used := Rule_Used;
121
 
            Rule_Used := False;
 
143
            Rule_Used := Not_Used;
122
144
         when Resume =>
123
145
            Rule_Used := Save_Used;
124
146
      end case;
125
147
   end Command;
126
148
 
 
149
   -------------
 
150
   -- Prepare --
 
151
   -------------
 
152
 
 
153
   procedure Prepare is
 
154
   begin
 
155
      if Rule_Used /= (True_Subrules => False) then
 
156
         Visible_Identifiers.Activate;
 
157
      end if;
 
158
   end Prepare;
 
159
 
127
160
   ---------------------------
128
161
   -- Process_Defining_Name --
129
162
   ---------------------------
130
163
 
131
164
   procedure Process_Defining_Name (Name : in Asis.Defining_Name) is
132
 
      use Thick_Queries, Asis, Asis.Elements, Asis.Declarations;
 
165
      use Asis, Asis.Elements, Asis.Declarations;
 
166
      use Thick_Queries, Framework.Scope_Manager;
133
167
 
134
168
      Scope : Asis.Element;
135
169
 
136
 
      -- This function detects names that are not to be processed by this rule, since
137
 
      -- they do not hide anything nor can they be hidden:
138
 
      --   - Names of record components (but not protected components)
139
 
      --   - Names of formal parameters in a SP renaming declaration
140
 
      --   - Names of formal parameters in the declaration of an access to SP type
141
170
      function Not_An_Appropriate_Name return Boolean is
 
171
         -- This function detects names that are not to be processed by this rule, since
 
172
         -- they do not hide anything nor can they be hidden:
 
173
         --   - Names of record components (but not protected components), including discriminants
 
174
         --   - Names of formal parameters in a SP renaming declaration
 
175
         --   - Names of formal parameters in the declaration of an access to SP type
142
176
         Decl           : constant Asis.Declaration := Enclosing_Element (Name);
143
177
         Decl_Enclosing : constant Asis.Element     := Enclosing_Element (Decl);
144
178
      begin
145
179
         case Declaration_Kind (Decl) is
146
180
            when A_Component_Declaration =>
147
181
               return Definition_Kind (Decl_Enclosing) /= A_Protected_Definition;
 
182
            when A_Discriminant_Specification =>
 
183
               return True;
148
184
            when A_Parameter_Specification =>
149
185
               case Element_Kind (Decl_Enclosing) is
150
186
                  when A_Definition =>
162
198
         end case;
163
199
      end Not_An_Appropriate_Name;
164
200
 
165
 
      -- This function returns True if Left and Right are the same scopes,
166
 
      -- or if Left is a body and Right is the corresponding specification
167
 
      function Are_Equivalent_Scopes (Left, Right : Asis.Element) return Boolean is
 
201
      function Other_Part (Elem : Asis.Defining_Name) return Asis.Element is
 
202
         -- Returns the declaration of the completion of Elem if any
168
203
         Decl : Asis.Declaration;
169
204
      begin
170
 
         if Is_Equal (Left, Right) then
171
 
            return True;
172
 
         end if;
173
 
         case Element_Kind (Left) is
174
 
            when A_Statement
175
 
              | An_Exception_Handler
176
 
              =>
177
 
               return False;
178
 
            when others =>
179
 
               -- Corresponding_Declaration cannot be called on some declarations
180
 
               -- if it were, it would simply return its argument, so let's do it by hand
181
 
               case Declaration_Kind (Left) is
182
 
                  when An_Entry_Declaration
183
 
                    | A_Formal_Procedure_Declaration
184
 
                    | A_Formal_Function_Declaration
185
 
                    =>
186
 
                     Decl := Left;
187
 
                  when others =>
188
 
                     Decl := Corresponding_Declaration (Left);
189
 
               end case;
190
 
               if Is_Nil (Decl) then
191
 
                  -- No corresponding specification
192
 
                  return False;
 
205
         Decl := Enclosing_Element (Elem);
 
206
         case Declaration_Kind (Decl) is
 
207
            when A_Private_Type_Declaration
 
208
               | A_Private_Extension_Declaration
 
209
               | An_Incomplete_Type_Declaration
 
210
                 =>
 
211
               return Corresponding_Type_Declaration (Decl);
 
212
            when A_Deferred_Constant_Declaration =>
 
213
               return Corresponding_Constant_Declaration (Elem);
 
214
            when A_Function_Declaration
 
215
               | A_Generic_Package_Declaration
 
216
               | A_Generic_Procedure_Declaration
 
217
               | A_Generic_Function_Declaration
 
218
               | A_Package_Declaration
 
219
               | A_Procedure_Declaration
 
220
               | A_Single_Task_Declaration
 
221
               | A_Task_Type_Declaration
 
222
               | A_Protected_Type_Declaration
 
223
               | A_Single_Protected_Declaration
 
224
                 =>
 
225
               return Corresponding_Body (Decl);
 
226
            when An_Entry_Declaration =>
 
227
               if Is_Task_Entry (Decl) then
 
228
                  -- Task entries have no body...
 
229
                  return Nil_Element;
193
230
               else
194
 
                  return Is_Equal (Decl, Right);
 
231
                  return Corresponding_Body (Decl);
195
232
               end if;
 
233
            when others =>
 
234
               return Nil_Element;
196
235
         end case;
197
 
      end Are_Equivalent_Scopes;
 
236
      end Other_Part;
198
237
 
199
238
   begin   -- Process_Defining_Name
200
 
      if not Rule_Used then
 
239
      if Rule_Used = Not_Used then
201
240
         return;
202
241
      end if;
203
242
      Rules_Manager.Enter (Rule_Id);
207
246
      end if;
208
247
 
209
248
      declare
210
 
         use Framework.Reports, Framework.Scope_Manager;
 
249
         use Framework.Reports;
211
250
         function Enclosing_Scope (N : Asis.Element) return Asis.Element is
212
251
            Result : Asis.Element := Enclosing_Element (N);
213
252
         begin
223
262
         Is_Scope_Name : constant Boolean     := Is_Equal (Enclosing_Scope (Name), Current_Scope);
224
263
         -- Is_Scope_Name is True if Name is the defining name for the current scope
225
264
         -- => it belongs to the enclosing scope
 
265
         Already_There : Boolean;
226
266
 
227
 
         function Is_Same (Check : Identifier_Data) return Boolean is
228
 
            -- If both are callable entities, compare with profiles
229
 
            -- otherwise, compare without profile
 
267
         type Hiding_Kinds is (Hides, Overloads, Not_Hiding);
 
268
         function Hiding_Kind (Check : Identifier_Data) return Hiding_Kinds is
230
269
         begin
231
 
            if Callable_Name then
232
 
               if Check.Is_Callable then
233
 
                  return Check.Name = Full_Name;
 
270
            if not Callable_Name or else not Check.Is_Callable then
 
271
               -- At least one is not a callable entity => no overloading
 
272
               if Check.Name (1 .. Check.Short_Last) = Short_Name then
 
273
                  return Hides;
234
274
               else
235
 
                  return Check.Name (1 .. Check.Short_Last) = Short_Name;
 
275
                  return Not_Hiding;
236
276
               end if;
 
277
            elsif Check.Name = Full_Name then
 
278
               -- Overloadable and names match with profile
 
279
               return Hides;
 
280
            elsif Check.Name (1 .. Check.Short_Last) = Short_Name then
 
281
               -- Overloadable and names match without profile
 
282
               return Overloads;
237
283
            else
238
 
               return Check.Name (1 .. Check.Short_Last) = Short_Name;
 
284
               return Not_Hiding;
239
285
            end if;
240
 
         end Is_Same;
 
286
         end Hiding_Kind;
241
287
 
242
288
      begin
243
289
         if Is_Scope_Name then
246
292
            Scope := Current_Scope;
247
293
         end if;
248
294
 
 
295
         Already_There := False;
249
296
         -- If scope is nil, it is the defining name of a library unit
250
297
         -- => cannot hide anything
251
298
         if not Is_Nil (Scope) then
252
299
            Visible_Identifiers.Reset (All_Scopes);
 
300
 
253
301
            while Visible_Identifiers.Data_Available loop
254
 
               if Is_Same (Visible_Identifiers.Current_Data) then
255
 
 
256
 
                  -- Discard the case where we find a name declared within a scope equivalent
257
 
                  -- to the scope of Name:
258
 
                  -- this corresponds for example to a spec and corresponding body, incomplete
259
 
                  -- type and corresponding full declarations...
260
 
                  -- These must correspond to the same entity, otherwise it would not be allowed
261
 
                  -- by the compiler.
262
 
                  if not Are_Equivalent_Scopes (Scope, Visible_Identifiers.Current_Data_Scope) then
263
 
                     Report (Rule_Id,
264
 
                             Rule_Context,
265
 
                             Get_Location (Name),
266
 
                             '"' & Framework.Language.Adjust_Image (To_Title (Full_Name))
267
 
                             & """ hides declaration at "
268
 
                             & Image (Get_Location (Visible_Identifiers.Current_Data.Elem)));
269
 
                     exit;
270
 
                  end if;
 
302
               -- Discard the case where we find the definition of another view
 
303
               -- of the same entity
 
304
               if Is_Equal (Visible_Identifiers.Current_Data.Other_Elem,
 
305
                            Enclosing_Element (Name))
 
306
               then
 
307
                  Already_There := True;
 
308
               else
 
309
                  case Hiding_Kind (Visible_Identifiers.Current_Data) is
 
310
                     when Hides =>
 
311
                        if Rule_Used (Strict) then
 
312
                           Report (Rule_Id,
 
313
                                   Rule_Context (Strict),
 
314
                                   Get_Location (Name),
 
315
                                   '"' & Framework.Language.Adjust_Image (To_Title (Full_Name))
 
316
                                   & """ hides declaration at "
 
317
                                   & Image (Get_Location (Visible_Identifiers.Current_Data.Elem)));
 
318
                        end if;
 
319
                     when Overloads =>
 
320
                        if Rule_Used (Overloading) then
 
321
                           Report (Rule_Id,
 
322
                                   Rule_Context (Overloading),
 
323
                                   Get_Location (Name),
 
324
                                   '"' & Framework.Language.Adjust_Image (To_Title (Full_Name))
 
325
                                   & """ overloads declaration at "
 
326
                                   & Image (Get_Location (Visible_Identifiers.Current_Data.Elem)));
 
327
                        end if;
 
328
                     when Not_Hiding =>
 
329
                        null;
 
330
                  end case;
271
331
               end if;
272
332
               Visible_Identifiers.Next;
273
333
            end loop;
274
334
         end if;
275
335
 
276
 
         if Is_Scope_Name then
277
 
            -- This is the defining name of the program unit that defines the current scope
278
 
            -- it must be associated to the enclosing scope
279
 
            Visible_Identifiers.Push_Enclosing ((Full_Name'Length,
280
 
                                                 Full_Name,
281
 
                                                 Short_Name'Length,
282
 
                                                 Name,
283
 
                                                 Callable_Name));
284
 
         else
285
 
            Visible_Identifiers.Push ((Full_Name'Length,
286
 
                                       Full_Name,
287
 
                                       Short_Name'Length,
288
 
                                       Name,
289
 
                                       Callable_Name));
 
336
         if not Already_There then
 
337
            if Is_Scope_Name then
 
338
               -- This is the defining name of the program unit that defines the current scope
 
339
               -- it must be associated to the enclosing scope
 
340
               Visible_Identifiers.Push_Enclosing ((Full_Name'Length,
 
341
                                                    Full_Name,
 
342
                                                    Short_Name'Length,
 
343
                                                    Name,
 
344
                                                    Other_Part (Name),
 
345
                                                    Callable_Name));
 
346
            else
 
347
               Visible_Identifiers.Push ((Full_Name'Length,
 
348
                                          Full_Name,
 
349
                                          Short_Name'Length,
 
350
                                          Name,
 
351
                                          Other_Part (Name),
 
352
                                          Callable_Name));
 
353
            end if;
290
354
         end if;
291
355
      end;
292
356
   end Process_Defining_Name;
295
359
   -- Process_With_Clause --
296
360
   -------------------------
297
361
 
298
 
   procedure Process_With_Clause (With_Clause : Asis.Clause) is
 
362
   procedure Process_With_Clause (With_Clause : in Asis.Clause) is
299
363
      -- Names in with clauses cannot hide anything, but can be hidden
300
364
      use Asis, Asis.Clauses, Asis.Elements, Asis.Expressions, Thick_Queries;
301
365
   begin
302
 
      if not Rule_Used then
 
366
      if Rule_Used = Not_Used then
303
367
         return;
304
368
      end if;
305
369
      Rules_Manager.Enter (Rule_Id);
321
385
                     Failure ("Unexpected name in with clause", All_Names (I));
322
386
               end case;
323
387
               declare
324
 
                  Short_Name : constant Wide_String := To_Upper (Name_Image (Name));
 
388
                  Short_Name : constant Wide_String := To_Upper (A4G_Bugs.Name_Image (Name));
325
389
                  Full_Name  : constant Wide_String := Short_Name & Profile_Image (Name, With_Profile => False);
326
390
               begin
327
391
                  -- Bind names to scope 0
328
392
                  Visible_Identifiers.Push_Enclosing ((Full_Name'Length, Full_Name,
329
393
                                                       Short_Name'Length, Name,
 
394
                                                       Nil_Element,
330
395
                                                       Is_Callable_Construct (Name)));
331
396
               end;
332
397
               exit when Expression_Kind (Current) = An_Identifier;
337
402
   end Process_With_Clause;
338
403
 
339
404
begin
340
 
   Framework.Rules_Manager.Register_Semantic (Rule_Id,
341
 
                                              Help    => Help'Access,
342
 
                                              Add_Use => Add_Use'Access,
343
 
                                              Command => Command'Access);
 
405
   Framework.Rules_Manager.Register (Rule_Id,
 
406
                                     Rules_Manager.Semantic,
 
407
                                     Help_CB        => Help'Access,
 
408
                                     Add_Control_CB => Add_Control'Access,
 
409
                                     Command_CB     => Command'Access,
 
410
                                     Prepare_CB     => Prepare'Access);
344
411
end Rules.Local_Hiding;