← Back to branch summary

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

« back to all changes in this revision

Viewing changes to src/rules-naming_convention.adb

  • Committer: Bazaar Package Importer
  • Author(s): Ludovic Brenta
  • Date: 2006-10-12 19:17:22 UTC
  • mfrom: (1.1.1 upstream)
  • Revision ID: james.westby@ubuntu.com-20061012191722-fo5bcn4k5r0iubgd
Tags: 1.5r24-1

* New upstream release.
* debian/control (Depends): add gnat-4.1.
  (Enhances): add gnat-gps.
* debian/adacontrol.gpr: build pfni.
* debian/rules: install the new gnat-gps plug-in, and pfni.
* debian/pfni.1: new.
* patches/gps-integration.patch: new.

Show diffs side-by-side

added added

removed removed

Lines of Context:
src/rules-naming_convention.adb
31
31
 
32
32
-- Ada
33
33
with
34
 
  Ada.Unchecked_Deallocation,
35
 
  Ada.Strings.Wide_Fixed,
36
 
  Ada.Strings.Wide_Unbounded;
 
34
  Ada.Characters.Handling,
 
35
  Ada.Exceptions,
 
36
  Ada.Unchecked_Deallocation;
37
37
 
38
38
-- ASIS
39
39
with
40
40
  Asis.Declarations,
41
41
  Asis.Definitions,
42
42
  Asis.Elements,
 
43
  Asis.Exceptions,
43
44
  Asis.Expressions,
44
45
  Asis.Statements;
45
46
 
54
55
with
55
56
  Framework.Language,
56
57
  Framework.Rules_Manager,
57
 
  Framework.Reports;
58
 
 
 
58
  Framework.Reports,
 
59
  Framework.Scope_Manager;
 
60
pragma Elaborate (Framework.Language);
59
61
 
60
62
package body Rules.Naming_Convention is
61
 
   use Framework, Ada.Strings.Wide_Unbounded;
 
63
   use Framework;
62
64
 
63
65
   Rule_Used : Boolean := False;
64
66
   Save_Used : Boolean;
90
92
                           K_Access_To_SP_Type,
91
93
                           K_Access_To_Task_Type,
92
94
                           K_Access_To_Protected_Type,
93
 
                      K_Private_Type,
 
95
                       K_Private_Type,
94
96
                          K_Private_Extension,
95
97
                       K_Generic_Formal_Type,
96
98
                    K_Variable,
129
131
                       K_Entry,
130
132
                          K_Task_Entry,
131
133
                          K_Protected_Entry,
132
 
                   K_Package,
 
134
                    K_Package,
133
135
                       K_Regular_Package,
134
136
                       K_Generic_Formal_Package,
135
137
                    K_Task,
144
146
                       K_Generic_Sp,
145
147
                          K_Generic_Procedure,
146
148
                          K_Generic_Function
147
 
                );
 
149
                 );
 
150
 
 
151
   package Keys_Flags_Utilities is new Framework.Language.Flag_Utilities (Keys, "K_");
 
152
   use Keys_Flags_Utilities;
 
153
 
148
154
   type Key_Set_Index is range 1 .. Keys'Pos (Keys'Last) + 1;
149
155
   type Key_Set is array (Key_Set_Index range <>) of Keys;
150
156
 
 
157
   type Visibility is (Scope_Any, Scope_Global, Scope_Local);
 
158
   function Get_Visibility_Modifier is new Framework.Language.Get_Enumerated_Modifier (Index => Visibility);
 
159
 
151
160
   type Usage_Rec;
152
161
   type Usage_Rec_Access is access Usage_Rec;
153
162
   type Pattern_Access is access String_Matching.Compiled_Pattern;
154
 
   type Usage_Rec is new Simple_Context with
 
163
   type Usage_Rec is new Basic_Rule_Context with
155
164
      record
 
165
         Scope   : Visibility;
156
166
         Is_Not  : Boolean;
157
167
         Pattern : Pattern_Access;
158
168
         Next    : Usage_Rec_Access;
172
182
   procedure Clear (Rec : in out Usage_Rec_Access) is
173
183
      procedure Free is new Ada.Unchecked_Deallocation (Usage_Rec, Usage_Rec_Access);
174
184
      procedure Free is new Ada.Unchecked_Deallocation (String_Matching.Compiled_Pattern, Pattern_Access);
175
 
      Temp : Usage_Rec_Access := Rec;
 
185
      Temp : Usage_Rec_Access;
176
186
   begin
177
187
      while Rec /= null loop
178
188
         Temp := Rec.Next;
182
192
      end loop;
183
193
   end Clear;
184
194
 
185
 
   -----------
186
 
   -- Image --
187
 
   -----------
188
 
 
189
 
   function Image (Key : Keys) return Wide_String is
190
 
      use Utilities;
191
 
      Img : constant Wide_String := To_Lower (Keys'Wide_Image (Key));
192
 
   begin
193
 
      -- Remove "K_"
194
 
      return Img (3 .. Img'Last);
195
 
   end Image;
196
 
 
197
195
   ----------
198
196
   -- Help --
199
197
   ----------
200
198
 
201
199
   procedure Help is
202
200
      use Utilities;
203
 
      procedure Print_Kw is
204
 
         Header : constant Wide_String := "Parameter 1: ";
205
 
         use Ada.Strings.Wide_Fixed;
206
 
 
207
 
         Spacing : constant Natural     := Keys'Wide_Width - 2 + 1;
208
 
         Line    : Wide_String (1..79)  := (others => ' ');
209
 
         Pos     : Natural;
210
 
      begin
211
 
         Overwrite (Line, 1, Header);
212
 
         Pos := Header'Length + 1;
213
 
         Overwrite (Line, Pos, Image (Keys'First));
214
 
         Pos := Pos + Spacing;
215
 
 
216
 
         for Value in Keys range Keys'Succ(Keys'First) .. Keys'Last loop
217
 
            Overwrite (Line, Pos, "| " & Image (Value));
218
 
            Pos := Pos +  2 + Spacing;
219
 
            if Pos + Keys'Wide_Width -1 > Line'Last then
220
 
               User_Message (Line (1 .. Pos-2));
221
 
               Line := (others => ' ');
222
 
               Pos := Header'Length + 1 - 2;
223
 
           end if;
224
 
         end loop;
225
 
 
226
 
         if Line /= (Line'range => ' ') then
227
 
            User_Message (Line (Line'First .. Pos-1));
228
 
         end if;
229
 
      end Print_Kw;
230
201
   begin
231
 
      User_Message ("Rule: " & Rule_Id);
232
 
      Print_Kw;
233
 
      User_Message ("Parameter 2..N: [not] [case_sensitive|case_insensitive] ""<name pattern>""");
234
 
      User_Message ("Control the form of allowed (or forbidden) names in declarations");
 
202
      User_Message  ("Rule: " & Rule_Id);
 
203
      Help_On_Flags ("Parameter 1: ");
 
204
      User_Message  ("Parameter 2..N: [any|local|global] [case_sensitive|case_insensitive] [not] ""<name pattern>""");
 
205
      User_Message  ("Control the form of allowed (or forbidden) names in declarations");
235
206
   end Help;
236
207
 
237
208
   -------------
240
211
 
241
212
   procedure Add_Use (Label     : in Wide_String;
242
213
                      Rule_Type : in Rule_Types) is
243
 
      use Framework.Language, String_Matching;
 
214
      use Ada.Characters.Handling, Ada.Exceptions, Framework.Language, String_Matching;
244
215
 
245
 
      function Get_Key_Parameter is new Get_Flag_Parameter (Flags     => Keys,
246
 
                                                            Allow_Any => False,
247
 
                                                            Prefix    => "K_");
248
216
      Key     : Keys;
249
217
      Is_Root : Boolean;
250
218
   begin
252
220
         Parameter_Error ("Kind of filter required for rule " & Rule_Id);
253
221
      end if;
254
222
      Is_Root := Get_Modifier ("ROOT");
255
 
      Key     := Get_Key_Parameter;
 
223
      Key     := Get_Flag_Parameter (Allow_Any => False);
256
224
 
257
225
      if not Parameter_Exists then
258
226
         Parameter_Error ("At least one pattern required for rule " & Rule_Id);
260
228
 
261
229
      while Parameter_Exists loop
262
230
         declare
 
231
            Scope       : constant Visibility  := Get_Visibility_Modifier (Default => Scope_Any, Prefix => "SCOPE_");
263
232
            Ignore_Case : constant Boolean     := Get_Modifier (True_KW  => "CASE_INSENSITIVE",
264
233
                                                                False_KW => "CASE_SENSITIVE",
265
 
                                                                Default => True);
 
234
                                                                Default  => True);
266
235
            Is_Not      : constant Boolean     := Get_Modifier ("NOT");
267
236
            Pattern     : constant Wide_String := Get_String_Parameter;
268
237
         begin
269
238
            Usage (Key) := (Is_Root => Usage (Key).Is_Root or Is_Root,
270
 
                            First   => new Usage_Rec'(Rule_Type,
271
 
                                                      To_Unbounded_Wide_String (Label),
 
239
                            First   => new Usage_Rec'(Basic.New_Context (Rule_Type, Label) with
 
240
                                                      Scope   => Scope,
272
241
                                                      Is_Not  => Is_Not,
273
 
                                                      Pattern => new Compiled_Pattern'(Compile (Pattern, Ignore_Case)),
 
242
                                                      Pattern =>
 
243
                                                        new Compiled_Pattern'(Compile (Pattern, Ignore_Case)),
274
244
                                                      Next    => Usage (Key).First));
275
245
         exception
276
 
            when Pattern_Error =>
277
 
               Parameter_Error ("Incorrect pattern: " & Pattern);
 
246
            when Occur: Pattern_Error =>
 
247
               Parameter_Error ("Incorrect pattern: " & Pattern
 
248
                                  & " (" & To_Wide_String (Exception_Message (Occur)) & ')');
278
249
         end;
279
250
      end loop;
280
251
 
308
279
   ---------------------------
309
280
 
310
281
   procedure Process_Defining_Name (Name : in Asis.Defining_Name) is
311
 
      use Utilities, Thick_Queries, String_Matching,
312
 
        Asis, Asis.Declarations, Asis.Definitions, Asis.Elements, Asis.Expressions,
313
 
        Asis.Statements, Framework.Reports;
314
 
 
315
 
      procedure Check_One (Name_Str : Wide_String; Key : Keys) is
 
282
      use Asis, Asis.Declarations, Asis.Definitions,
 
283
          Asis.Elements, Asis.Expressions, Asis.Statements;
 
284
      use String_Matching, Thick_Queries, Utilities;
 
285
      use Framework.Reports;
 
286
 
 
287
      procedure Check_One (Name_Str : in Wide_String; Key : in Keys) is
 
288
         use Framework.Scope_Manager;
 
289
 
316
290
         Current              : Usage_Rec_Access := Usage (Key).First;
317
291
         Matches              : Boolean;
318
292
         All_Not_Patterns     : Boolean := True;
319
293
         Positive_Match_Found : Boolean := False;
 
294
 
 
295
         Last_Checked         : Usage_Rec_Access := null;
 
296
         Is_Global            : constant Boolean := Is_Current_Scope_Global;
320
297
      begin
321
298
         if Current = null then
322
299
            -- No rule
324
301
         end if;
325
302
 
326
303
         loop
327
 
            Matches := Match (Name_Str, Current.Pattern.all);
328
 
            if Matches then
329
 
               if Current.Is_Not then
330
 
                  Report (Rule_Id,
331
 
                          To_Wide_String (Current.Rule_Label),
332
 
                          Current.Rule_Type,
333
 
                          Get_Location (Name),
334
 
                          "Name does not follow naming rule for """
335
 
                          & Image (Key)
336
 
                          & """: """
337
 
                          & Defining_Name_Image (Name)& '"');
338
 
                  return;
339
 
               else
340
 
                  -- We must continue in case there is a "not" match farther
341
 
                  Positive_Match_Found := True;
 
304
            if Current.Scope = Scope_Any
 
305
              or else (Current.Scope = Scope_Local  and then not Is_Global)
 
306
              or else (Current.Scope = Scope_Global and then     Is_Global)
 
307
            then
 
308
               Last_Checked := Current;
 
309
 
 
310
               Matches := Match (Name_Str, Current.Pattern.all);
 
311
               if Matches then
 
312
                  if Current.Is_Not then
 
313
                     Report (Rule_Id,
 
314
                             Current.all,
 
315
                             Get_Location (Name),
 
316
                             "Name does not follow naming rule for """
 
317
                             & Image (Key)
 
318
                             & """: """
 
319
                             & Defining_Name_Image (Name) & '"');
 
320
                     return;
 
321
                  else
 
322
                     -- We must continue in case there is a "not" match farther
 
323
                     Positive_Match_Found := True;
 
324
                  end if;
 
325
               elsif not Current.Is_Not then
 
326
                  All_Not_Patterns := False;
342
327
               end if;
343
 
            elsif not Current.Is_Not then
344
 
               All_Not_Patterns := False;
 
328
 
345
329
            end if;
346
330
 
347
331
            exit when Current.Next = null;
352
336
            return;
353
337
 
354
338
         -- No match found here. It is an error, unless all patterns were "not" patterns.
355
 
         -- Current points to the last rule, which is the first one specified
 
339
         -- Last_Checked points to the last applicable rule, which is the first one specified
356
340
         -- since we chain on head.
357
341
         elsif not All_Not_Patterns then
358
342
            Report (Rule_Id,
359
 
                    To_Wide_String (Current.Rule_Label),
360
 
                    Current.Rule_Type,
 
343
                    Last_Checked.all,
361
344
                    Get_Location (Name),
362
345
                    "Name does not follow naming rule for """
363
 
                    & Image (Key)
364
 
                    & """: """
365
 
                    & Defining_Name_Image (Name)& '"');
 
346
                      & Image (Key)
 
347
                      & """: """
 
348
                      & Defining_Name_Image (Name) & '"');
366
349
         end if;
367
350
      end Check_One;
368
351
 
369
 
   begin
 
352
   begin    -- Process_Defining_Name
370
353
      if not Rule_Used then
371
354
         return;
372
355
      end if;
376
359
         Decl      : Asis.Declaration     := Enclosing_Element (Name);
377
360
         Name_Str  : constant Wide_String := Defining_Name_Image (Name);
378
361
         Renamed   : Asis.Element;
 
362
         Renamed_T : Asis.Element;
379
363
         Decl_Kind : Asis.Declaration_Kinds;
380
364
         Def       : Asis.Definition;
381
365
         Accessed  : Asis.Element;
382
366
 
383
367
         -- Applicable rules must be given in order of decreasing generality
384
 
         procedure Check (Set : Key_Set) is
 
368
         procedure Check (Set : in Key_Set) is
385
369
         begin
386
370
            for I in reverse Set'Range loop
387
371
               Check_One (Name_Str, Set (I));
388
372
               exit when Usage (Set (I)).Is_Root;
389
373
            end loop;
390
374
         end Check;
 
375
 
391
376
      begin
392
 
         if Defining_Name_Kind (Decl) = A_Defining_Expanded_Name then
 
377
         while Defining_Name_Kind (Decl) = A_Defining_Expanded_Name loop
393
378
            -- Name was the name of a child compilation unit
394
379
            Decl := Enclosing_Element (Decl);
395
 
         end if;
 
380
         end loop;
396
381
 
 
382
         -- Every path in the following case statement must end with a call to Check,
 
383
         -- and perform nothing after.
 
384
         -- There is nothing after the case statement.
 
385
         -- It is therefore irrelevant whether the call to Check is followed by a return or not.
 
386
         -- In most cases, there is no return, however in some cases there is a return when the
 
387
         -- call to check is deep in the statements, to simplify the structure.
397
388
         case Element_Kind (Decl) is
398
389
            when A_Statement =>  ------------------------------------------------- Statements
399
390
               declare
424
415
            when A_Declaration =>  ----------------------------------------------- Declarations
425
416
               Decl_Kind := Declaration_Kind (Decl);
426
417
 
427
 
               if Decl_Kind in A_Full_Type_Declaration
428
 
                 and then Declaration_Kind (Corresponding_Type_Declaration (Decl))
429
 
                          in A_Private_Type_Declaration .. A_Private_Extension_Declaration
430
 
               then
431
 
                  -- This declaration is a full declaration of a private type.
432
 
                  -- It does not follow the rules for its own kind, but the ones for private
433
 
                  -- types (which are checked for the private declaration)
434
 
                  return;
435
 
               end if;
 
418
               begin
 
419
                  if Decl_Kind in A_Full_Type_Declaration
 
420
                    and then Declaration_Kind (Corresponding_Type_Declaration (Decl))
 
421
                              in A_Private_Type_Declaration .. A_Private_Extension_Declaration
 
422
                  then
 
423
                     -- This declaration is a full declaration of a private type.
 
424
                     -- It does not follow the rules for its own kind, but the ones for private
 
425
                     -- types (which are checked for the private declaration)
 
426
                     return;
 
427
                  end if;
 
428
               exception
 
429
                  when Asis.Exceptions.ASIS_Failed =>
 
430
                     -- A4G BUG in Gnat/GPL, Gnat/GAP, fixed in 5.04 and above
 
431
                     -- Corresponding_Type_Declaration fails for types declared in child units
 
432
                     -- and separate units.
 
433
                     -- Apparently, this does not happen for full declarations of private types,
 
434
                     -- therefore we can ignore the problem
 
435
                     A4G_Bugs.Trace_Bug ("Rules.Naming_Convention.Process_Defining_Name");
 
436
                     null;
 
437
               end;
436
438
 
437
439
               case Decl_Kind is
438
440
                  when A_Renaming_Declaration =>
443
445
                           -- There are cases (like renaming of an indexed component) where
444
446
                           -- we want to go up a renaming, but Corrresponding_Base_Entity doesn't.
445
447
                           -- Hence the loop.
 
448
                           -- We can't use Ultimate_Name, because we need a different treatment of dereferences
446
449
                           Going_Up_Renamings:
447
450
                             while Decl_Kind in A_Renaming_Declaration loop
448
451
                                Renamed := A4G_Bugs.Corresponding_Base_Entity (Decl);
459
462
                                         Decl_Kind := A_Constant_Declaration;
460
463
                                         exit Going_Up_Renamings;
461
464
                                      when An_Explicit_Dereference =>
462
 
                                         case Access_Type_Kind (Type_Declaration_View
463
 
                                                                (A4G_Bugs.Corresponding_Expression_Type
464
 
                                                                 (Prefix (Renamed))))
465
 
                                         is
 
465
                                         Renamed_T := A4G_Bugs.Corresponding_Expression_Type (Prefix (Renamed));
 
466
                                         if Is_Nil (Renamed_T) then
 
467
                                            -- This implies that the prefix is an access type without a real declaration
 
468
                                            -- => must be an anonymous access type, and the prefix is a formal parameter
 
469
                                            Renamed   := Prefix (Renamed);
 
470
                                            if Expression_Kind (Renamed) = A_Selected_Component then
 
471
                                               Renamed := Selector (Renamed);
 
472
                                            end if;
 
473
                                            Decl := Corresponding_Name_Declaration (Renamed);
 
474
                                            Assert (Declaration_Kind (Decl) = A_Parameter_Specification,
 
475
                                                    "wrong declaration kind with dereference of Nil accessed type");
 
476
                                            Decl_Kind := A_Parameter_Specification;
 
477
                                            exit Going_Up_Renamings;
 
478
                                        end if;
 
479
 
 
480
                                         case Access_Type_Kind (Type_Declaration_View (Renamed_T)) is
466
481
                                            when A_Pool_Specific_Access_To_Variable
467
482
                                              | An_Access_To_Variable
468
483
                                              =>
526
541
                        Def       := Type_Declaration_View (Decl);
527
542
                        if Type_Kind (Def) in A_Derived_Type_Definition .. A_Derived_Record_Extension_Definition then
528
543
                           -- Subtype of a derived type
529
 
                           Decl      := Corresponding_Root_Type (Def);
 
544
                           Decl      := A4G_Bugs.Corresponding_Root_Type (Def);
530
545
                           Decl_Kind := Declaration_Kind (Decl);
531
546
                        end if;
532
547
                     end if;
539
554
                     -- For derived types, get Decl and Decl_Kind from the corresponding type
540
555
                     Def := Type_Declaration_View (Decl);
541
556
                     if Type_Kind (Def) in A_Derived_Type_Definition .. A_Derived_Record_Extension_Definition then
542
 
                        Decl      := Corresponding_Root_Type (Def);
 
557
                        Decl      := A4G_Bugs.Corresponding_Root_Type (Def);
543
558
                        Decl_Kind := Declaration_Kind (Decl);
544
559
                     end if;
545
560
 
581
596
                           Check ((K_All, K_Type, K_Record_Type, K_Tagged_Type));
582
597
                        when An_Access_Type_Definition =>
583
598
                           if Access_Type_Kind (Def) in Access_To_Subprogram_Definition then
584
 
                              Check ((K_All, K_Type, K_Access_Type, K_Access_To_Sp_Type));
585
 
                           else
586
 
                              Accessed := Definitions.Subtype_Mark (Definitions.Access_To_Object_Definition (Def));
587
 
                              if A4G_Bugs.Attribute_Kind (Accessed) = A_Class_Attribute then
588
 
                                 -- Directly: type T is access T'Class
589
 
                                 Check ((K_All, K_Type, K_Access_Type, K_Access_To_Class_Type));
 
599
                              Check ((K_All, K_Type, K_Access_Type, K_Access_To_SP_Type));
 
600
                              return;
 
601
                           end if;
 
602
 
 
603
                           -- Here, we have an acces to object
 
604
                           Accessed := Subtype_Simple_Name (Definitions.Access_To_Object_Definition (Def));
 
605
                           if A4G_Bugs.Attribute_Kind (Accessed) = A_Class_Attribute then
 
606
                              -- Directly: type T is access T'Class
 
607
                              Check ((K_All, K_Type, K_Access_Type, K_Access_To_Class_Type));
 
608
                              return;
 
609
                           end if;
 
610
 
 
611
                           -- Ignore a possible 'Base
 
612
                           if A4G_Bugs.Attribute_Kind (Accessed) = A_Base_Attribute then
 
613
                              Accessed := Prefix (Accessed);
 
614
                           end if;
 
615
 
 
616
                           -- Remove prefixes
 
617
                           if Expression_Kind (Accessed) = A_Selected_Component then
 
618
                              Accessed := Selector (Accessed);
 
619
                           end if;
 
620
 
 
621
                           -- Here, we should have a plain (sub)type identifier
 
622
 
 
623
                           Accessed := Corresponding_Name_Declaration (Accessed);
 
624
                           if Declaration_Kind (Accessed) = An_Incomplete_Type_Declaration then
 
625
                              Accessed := Corresponding_Type_Declaration (Accessed);
 
626
                              if Is_Nil (Accessed) then
 
627
                                 -- The full declaration of the accessed type is not in the context.
 
628
                                 -- We cannot know the real nature of the accessed type.
 
629
                                 -- Limit the check to Access_Type, and hope the user will rerun AdaControl
 
630
                                 -- on the full program.
 
631
                                 Check ((K_All, K_Type, K_Access_Type));
 
632
                                 return;
 
633
                              end if;
 
634
                           end if;
 
635
 
 
636
                           if Declaration_Kind (Accessed) = A_Subtype_Declaration
 
637
                             and then Is_Class_Wide_Subtype (Accessed)
 
638
                           then
 
639
                              -- Annoying special case: the access type designates a subtype that names
 
640
                              -- a class-wide type. (i.e. subtype ST is T'Class; type Acc is access ST;)
 
641
                              Check ((K_All, K_Type, K_Access_Type, K_Access_To_Class_Type));
 
642
                              return;
 
643
                           end if;
 
644
 
 
645
                           -- Get rid of subtyping and derivations on the accessed type
 
646
                           -- But we may have a mixture of formal or non-formal derivations...
 
647
                           loop
 
648
                              Accessed := Corresponding_First_Subtype (Accessed);
 
649
                              Def      := Type_Declaration_View (Accessed);
 
650
                              if Type_Kind (Def)
 
651
                                in A_Derived_Type_Definition .. A_Derived_Record_Extension_Definition
 
652
                              then
 
653
                                 Accessed := A4G_Bugs.Corresponding_Root_Type (Def);
 
654
                              elsif Formal_Type_Kind (Def) = A_Formal_Derived_Type_Definition then
 
655
                                 Accessed := Corresponding_Name_Declaration (Subtype_Simple_Name (Def));
590
656
                              else
591
 
                                 -- Ignore a possible 'Base
592
 
                                 if A4G_Bugs.Attribute_Kind (Accessed) = A_Base_Attribute then
593
 
                                    Accessed := Prefix (Accessed);
594
 
                                 end if;
595
 
 
596
 
                                 -- Remove prefixes
597
 
                                 if Expression_Kind (Accessed) = A_Selected_Component then
598
 
                                    Accessed := Selector (Accessed);
599
 
                                 end if;
600
 
 
601
 
                                 -- Here, we should have a plain (sub)type identifier
602
 
 
603
 
                                 Accessed := Corresponding_Name_Declaration (Accessed);
604
 
                                 if Declaration_Kind (Accessed) = An_Incomplete_Type_Declaration then
605
 
                                    Accessed := Corresponding_Type_Declaration (Accessed);
606
 
                                 end if;
607
 
 
608
 
                                 if Declaration_Kind (Accessed) = A_Subtype_Declaration
609
 
                                   and then Is_Class_Wide_Subtype (Accessed)
610
 
                                 then
611
 
                                    -- Annoying special case: the access type designates a subtype that names
612
 
                                    -- a class-wide type. (i.e. subtype ST is T'Class; type Acc is access ST;)
613
 
                                    Check ((K_All, K_Type, K_Access_Type, K_Access_To_Class_Type));
614
 
 
615
 
                                 else
616
 
                                    -- Get rid of subtyping and derivations on the accessed type
617
 
                                    -- But we may have a mixture of formal or non-formal derivations...
618
 
                                    loop
619
 
                                       Accessed := Corresponding_First_Subtype (Accessed);
620
 
                                       Def      := Type_Declaration_View (Accessed);
621
 
                                       if Type_Kind (Def)
622
 
                                         in A_Derived_Type_Definition .. A_Derived_Record_Extension_Definition
623
 
                                       then
624
 
                                          Accessed := Corresponding_Root_Type (Def);
625
 
                                       elsif Formal_Type_Kind (Def) = A_Formal_Derived_Type_Definition then
626
 
                                          Accessed := Corresponding_Name_Declaration (Definitions.Subtype_Mark (Def));
627
 
                                       else
628
 
                                          exit;
629
 
                                       end if;
630
 
                                    end loop;
631
 
 
632
 
                                    case Declaration_Kind (Accessed) is
633
 
                                       when An_Ordinary_Type_Declaration =>
634
 
                                          case Type_Kind (Type_Declaration_View (Accessed)) is
635
 
                                             when Not_A_Type_Definition =>
636
 
                                                Failure ("Unexpected accessed type 1", Accessed);
637
 
                                             when A_Tagged_Record_Type_definition
638
 
                                               | A_Derived_Record_Extension_Definition
639
 
                                               =>
640
 
                                                Check ((K_All, K_Type, K_Access_Type, K_Access_To_Tagged_Type));
641
 
                                             when others =>
642
 
                                                Check ((K_All, K_Type, K_Access_Type, K_Access_To_Regular_Type));
643
 
                                          end case;
644
 
                                       when A_Task_Type_Declaration =>
645
 
                                          Check ((K_All, K_Type, K_Access_Type, K_Access_To_Task_Type));
646
 
                                       when A_Protected_Type_Declaration =>
647
 
                                          Check ((K_All, K_Type, K_Access_Type, K_Access_To_Protected_Type));
648
 
                                       when A_Private_Type_Declaration =>
649
 
                                          Check ((K_All, K_Type, K_Access_Type, K_Access_To_Regular_Type));
650
 
                                       when A_Private_Extension_Declaration =>
651
 
                                          Check ((K_All, K_Type, K_Access_Type, K_Access_To_Tagged_Type));
652
 
                                       when A_Formal_Type_Declaration  =>
653
 
                                          case Formal_Type_Kind (Type_Declaration_View (Accessed)) is
654
 
                                             when Not_A_Formal_Type_Definition =>
655
 
                                                Failure ("not a formal type definition");
656
 
                                             when A_Formal_Derived_Type_Definition =>
657
 
                                                Failure ("Unexpected formal derived type", Accessed);
658
 
                                             when A_Formal_Discrete_Type_Definition
659
 
                                               | A_Formal_Signed_Integer_Type_Definition
660
 
                                               | A_Formal_Modular_Type_Definition
661
 
                                               | A_Formal_Floating_Point_Definition
662
 
                                               | A_Formal_Ordinary_Fixed_Point_Definition
663
 
                                               | A_Formal_Decimal_Fixed_Point_Definition
664
 
                                               | A_Formal_Access_Type_Definition
665
 
                                               | A_Formal_Private_Type_Definition
666
 
                                               | A_Formal_Unconstrained_Array_Definition
667
 
                                               | A_Formal_Constrained_Array_Definition
668
 
                                                =>
669
 
                                                Check ((K_All, K_Type, K_Access_Type, K_Access_To_Regular_Type));
670
 
                                             when A_Formal_Tagged_Private_Type_Definition =>
671
 
                                                Check ((K_All, K_Type, K_Access_Type, K_Access_To_Tagged_Type));
672
 
                                          end case;
673
 
                                       when others =>
674
 
                                          Failure ("Unexpected accessed type 2", Accessed);
675
 
                                    end case;
676
 
                                 end if;
 
657
                                 exit;
677
658
                              end if;
678
 
                           end if;
 
659
                           end loop;
 
660
 
 
661
                           case Declaration_Kind (Accessed) is
 
662
                              when An_Ordinary_Type_Declaration =>
 
663
                                 case Type_Kind (Type_Declaration_View (Accessed)) is
 
664
                                    when Not_A_Type_Definition =>
 
665
                                       Failure ("Unexpected accessed type 1", Accessed);
 
666
                                    when A_Tagged_Record_Type_Definition
 
667
                                      | A_Derived_Record_Extension_Definition
 
668
                                      =>
 
669
                                       Check ((K_All, K_Type, K_Access_Type, K_Access_To_Tagged_Type));
 
670
                                    when others =>
 
671
                                       Check ((K_All, K_Type, K_Access_Type, K_Access_To_Regular_Type));
 
672
                                 end case;
 
673
                              when A_Task_Type_Declaration =>
 
674
                                 Check ((K_All, K_Type, K_Access_Type, K_Access_To_Task_Type));
 
675
                              when A_Protected_Type_Declaration =>
 
676
                                 Check ((K_All, K_Type, K_Access_Type, K_Access_To_Protected_Type));
 
677
                              when A_Private_Type_Declaration =>
 
678
                                 Check ((K_All, K_Type, K_Access_Type, K_Access_To_Regular_Type));
 
679
                              when A_Private_Extension_Declaration =>
 
680
                                 Check ((K_All, K_Type, K_Access_Type, K_Access_To_Tagged_Type));
 
681
                              when A_Formal_Type_Declaration  =>
 
682
                                 case Formal_Type_Kind (Type_Declaration_View (Accessed)) is
 
683
                                    when Not_A_Formal_Type_Definition =>
 
684
                                       Failure ("not a formal type definition");
 
685
                                    when A_Formal_Derived_Type_Definition =>
 
686
                                       Failure ("Unexpected formal derived type", Accessed);
 
687
                                    when A_Formal_Discrete_Type_Definition
 
688
                                      | A_Formal_Signed_Integer_Type_Definition
 
689
                                      | A_Formal_Modular_Type_Definition
 
690
                                      | A_Formal_Floating_Point_Definition
 
691
                                      | A_Formal_Ordinary_Fixed_Point_Definition
 
692
                                      | A_Formal_Decimal_Fixed_Point_Definition
 
693
                                      | A_Formal_Access_Type_Definition
 
694
                                      | A_Formal_Private_Type_Definition
 
695
                                      | A_Formal_Unconstrained_Array_Definition
 
696
                                      | A_Formal_Constrained_Array_Definition
 
697
                                      =>
 
698
                                       Check ((K_All, K_Type, K_Access_Type, K_Access_To_Regular_Type));
 
699
                                    when A_Formal_Tagged_Private_Type_Definition =>
 
700
                                       Check ((K_All, K_Type, K_Access_Type, K_Access_To_Tagged_Type));
 
701
                                    when others => -- Compatibility Ada 2005
 
702
                                       null;
 
703
                                 end case;
 
704
                              when others =>
 
705
                                 Failure ("Unexpected accessed type 2", Accessed);
 
706
                           end case;
 
707
 
679
708
                        when others =>
680
709
                           Failure ("Unexpected type kind: " & Type_Kinds'Wide_Image (Type_Kind (Def)));
681
710
                     end case;
771
800
                     if Type_Kind (Def)
772
801
                       in A_Derived_Type_Definition .. A_Derived_Record_Extension_Definition
773
802
                     then
774
 
                        Def := Type_Declaration_View (Corresponding_Root_Type (Def));
 
803
                        Def := Type_Declaration_View (A4G_Bugs.Corresponding_Root_Type (Def));
775
804
                        if Definition_Kind (Def) = A_Type_Definition then
776
805
                           -- Must be a record type. Go to the record definition to match the
777
806
                           -- case of the underived type
901
930
 
902
931
                  when A_Renaming_Declaration =>
903
932
                     Failure ("Unexpected renaming", Decl);
 
933
 
 
934
                  when others =>   -- Compatibility Ada 2005
 
935
                     null;
904
936
               end case;
905
937
 
906
938
            when others =>
910
942
   end Process_Defining_Name;
911
943
 
912
944
begin
913
 
   Framework.Rules_Manager.Register (Rule_Id,
914
 
                                     Help    => Help'Access,
915
 
                                     Add_Use => Add_Use'Access,
916
 
                                     Command => Command'Access);
 
945
   Framework.Rules_Manager.Register_Semantic (Rule_Id,
 
946
                                              Help    => Help'Access,
 
947
                                              Add_Use => Add_Use'Access,
 
948
                                              Command => Command'Access);
917
949
end Rules.Naming_Convention;