← Back to branch summary

~ubuntu-branches/ubuntu/maverick/adacontrol/maverick

« back to all changes in this revision

Viewing changes to src/rules-declarations.adb

  • Committer: Bazaar Package Importer
  • Author(s): Ludovic Brenta
  • Date: 2006-12-06 19:59:00 UTC
  • mfrom: (1.1.2 upstream) (2.1.1 etch)
  • Revision ID: james.westby@ubuntu.com-20061206195900-xnfcv9mmhb22lq95
Tags: 1.6r8-1

* New upstream version.
* debian/rules: add a copyright statement.  Use all available CPUs to
  build.  Install predefined rules files in /usr/share/adacontrol.
* debian/adacontrol.gpr: work around a compiler (GCC 4.1) bug triggered
  by two of AdaControl's source files.
* debian/README.Debian: new; explain about the predefined rule files.

Show diffs side-by-side

added added

removed removed

Lines of Context:
src/rules-declarations.adb
39
39
 
40
40
-- Adalog
41
41
with
 
42
  A4G_Bugs,
42
43
  Thick_Queries,
43
44
  Utilities;
44
45
 
46
47
with
47
48
  Framework.Language,
48
49
  Framework.Rules_Manager,
49
 
  Framework.Reports;
 
50
  Framework.Reports,
 
51
  Framework.Scope_Manager;
50
52
pragma Elaborate (Framework.Language);
51
53
package body Rules.Declarations is
52
54
   use Framework;
53
55
 
54
 
   type Declaration_Names is (D_Access_Protected_Type,       D_Access_Subprogram_Type,    D_Access_Task_Type,
55
 
                              D_Access_Type,                 D_Aliased,                   D_Array,
56
 
                              D_Array_Type,                  D_Child_Unit,                D_Constant,
57
 
                              D_Constrained_Array_Type,      D_Decimal_Fixed_Type,        D_Defaulted_Discriminant,
58
 
                              D_Defaulted_Generic_Parameter, D_Defaulted_Parameter,       D_Derived_Type,
59
 
                              D_Discriminant,                D_Enumeration_Type,          D_Entry,
60
 
                              D_Exception,                   D_Extension,                 D_Fixed_Type,
61
 
                              D_Float_Type,                  D_Formal_Function,           D_Formal_In_Out,
62
 
                              D_Formal_Package,              D_Formal_Procedure,          D_Generic,
63
 
                              D_Handlers,                    D_Integer_Type,              D_Modular_Type,
64
 
                              D_Multiple_Names,              D_Named_Number,              D_Not_Operator_Renames,
65
 
                              D_Null_Extension,              D_Null_Ordinary_Record_Type, D_Null_Tagged_Type,
66
 
                              D_Operator,                    D_Ordinary_Fixed_Type,       D_Ordinary_Record_Type,
67
 
                              D_Package_Statements,          D_Protected,                 D_Protected_Entry,
68
 
                              D_Protected_Type,              D_Record_Type,               D_Renames,
69
 
                              D_Separate,                    D_Signed_Type,               D_Single_Array,
70
 
                              D_Single_Protected,            D_Single_Task,               D_Subtype,
71
 
                              D_Tagged_Type,                 D_Task,                      D_Task_Entry,
72
 
                              D_Task_Type,                   D_Type,                      D_Unconstrained_Array_Type);
 
56
   type Declaration_Names is (D_Access_Protected_Type,        D_Access_Subprogram_Type,    D_Access_Task_Type,
 
57
                              D_Access_Type,                  D_Aliased,                   D_Array,
 
58
                              D_Array_Type,                   D_Child_Unit,                D_Constant,
 
59
                              D_Constrained_Array_Type,       D_Decimal_Fixed_Type,        D_Defaulted_Discriminant,
 
60
                              D_Defaulted_Generic_Parameter,  D_Defaulted_Parameter,       D_Derived_Type,
 
61
                              D_Discriminant,                 D_Enumeration_Type,          D_Entry,
 
62
                              D_Exception,                    D_Extension,                 D_Fixed_Type,
 
63
                              D_Float_Type,                   D_Formal_Function,           D_Formal_Package,
 
64
                              D_Formal_Procedure,             D_Generic,                   D_Handlers,
 
65
                              D_In_Out_Generic_Parameter,     D_In_Out_Parameter,          D_Initialized_Record_Field,
 
66
                              D_Initialized_Protected_Field,  D_Integer_Type,              D_Limited_Private_Type,
 
67
                              D_Modular_Type,                 D_Multiple_Names,            D_Named_Number,
 
68
                              D_Nested_Package,               D_Nested_Generic_Function,   D_Nested_Generic_Package,
 
69
                              D_Nested_Generic_Procedure,     D_Nested_Function_Instantiation,
 
70
                              D_Nested_Package_Instantiation, D_Nested_Procedure_Instantiation,
 
71
                              D_Non_Identical_Renaming,       D_Non_Limited_Private_Type,  D_Not_Operator_Renaming,
 
72
                              D_Null_Extension,               D_Null_Ordinary_Record_Type, D_Null_Tagged_Type,
 
73
                              D_Operator,                     D_Operator_Renaming,         D_Ordinary_Fixed_Type,
 
74
                              D_Ordinary_Record_Type,         D_Out_Parameter,             D_Package_Statements,
 
75
                              D_Private_Extension,            D_Protected,                 D_Protected_Entry,
 
76
                              D_Protected_Type,               D_Record_Type,               D_Renaming,
 
77
                              D_Separate,                     D_Signed_Type,               D_Single_Array,
 
78
                              D_Single_Protected ,            D_Single_Task,               D_Subtype,
 
79
                              D_Tagged_Type,                  D_Task,                      D_Task_Entry,
 
80
                              D_Task_Type,                    D_Type,                      D_Unconstrained_Array_Type,
 
81
                              D_Uninitialized_Record_Field,   D_Uninitialized_Protected_Field);
73
82
   type Declaration_Names_List is array (Positive range <>) of Declaration_Names;
74
83
 
75
84
   package Usage_Flags_Utilities is new Framework.Language.Flag_Utilities (Declaration_Names, "D_");
88
97
      use Utilities;
89
98
   begin
90
99
      User_Message ("Rule: " & Rule_Id);
91
 
      Help_On_Flags (Header => "Parameter (s):");
 
100
      Help_On_Flags (Header => "Parameter(s):");
92
101
      User_Message ("Control occurrences of Ada declarations");
93
102
   end Help;
94
103
 
99
108
   procedure Add_Use (Label     : in Wide_String;
100
109
                      Rule_Type : in Rule_Types) is
101
110
      use Framework.Language;
102
 
      Decl    : Declaration_Names;
 
111
      Decl : Declaration_Names;
103
112
 
104
113
   begin
105
114
      if not Parameter_Exists then
106
 
         Parameter_Error ("At least one parameter required for rule " & Rule_Id);
 
115
         Parameter_Error (Rule_Id, "at least one parameter required");
107
116
      end if;
108
117
 
109
118
      while Parameter_Exists loop
110
119
         Decl := Get_Flag_Parameter (Allow_Any => False);
111
120
         if Rule_Used (Decl) then
112
 
            Parameter_Error ("Declaration already given for rule " & Rule_Id
113
 
                             & ": " & Image (Decl));
 
121
            Parameter_Error (Rule_Id, "declaration already given" & ": " & Image (Decl));
114
122
         end if;
115
123
 
116
124
         Rule_Used (Decl) := True;
186
194
   -------------------------
187
195
 
188
196
   procedure Process_Declaration (Element : in Asis.Declaration) is
189
 
      use Asis, Asis.Elements, Asis.Expressions, Asis.Declarations, Asis.Definitions, Thick_Queries, Utilities;
190
 
      Accessed_Type : Asis.Element;
191
 
      Renamed_Func  : Asis.Name;
 
197
      use Asis, Asis.Elements, Asis.Expressions, Asis.Declarations, Asis.Definitions;
 
198
      use Framework.Scope_Manager, Thick_Queries, Utilities;
 
199
 
 
200
      Accessed_Type  : Asis.Element;
 
201
      Renamed_Entity : Asis.Name;
 
202
      Enclosing      : Asis.Element;
192
203
 
193
204
      procedure Check_Discriminant (Discr : Asis.Definition) is
194
205
      begin
333
344
 
334
345
            Check_Discriminant (Discriminant_Part (Element));
335
346
 
 
347
         when A_Private_Type_Declaration =>
 
348
            if Trait_Kind (Element) = A_Limited_Private_Trait then
 
349
               Do_Report (D_Limited_Private_Type, Get_Location (Element));
 
350
            else
 
351
               Do_Report (D_Non_Limited_Private_Type, Get_Location (Element));
 
352
            end if;
 
353
 
 
354
         when A_Private_Extension_Declaration =>
 
355
            Do_Report (D_Private_Extension, Get_Location (Element));
 
356
 
336
357
         when A_Subtype_Declaration =>
337
358
            Do_Report (D_Subtype, Get_Location (Element));
338
359
 
367
388
               Do_Report ((D_Array, D_Single_Array), Get_Location (Element));
368
389
            end if;
369
390
 
 
391
         when A_Component_Declaration =>
 
392
            if Definition_Kind (Enclosing_Element (Element)) = A_Protected_Definition then
 
393
               if Is_Nil (Initialization_Expression (Element)) then
 
394
                  Do_Report (D_Uninitialized_Protected_Field, Get_Location (Element));
 
395
               else
 
396
                  Do_Report (D_Initialized_Protected_Field, Get_Location (Element));
 
397
               end if;
 
398
            else
 
399
               if Is_Nil (Initialization_Expression (Element)) then
 
400
                  Do_Report (D_Uninitialized_Record_Field, Get_Location (Element));
 
401
               else
 
402
                  Do_Report (D_Initialized_Record_Field, Get_Location (Element));
 
403
               end if;
 
404
            end if;
 
405
 
370
406
         when A_Parameter_Specification =>
371
 
            if not Is_Nil (Initialization_Expression (Element)) then
372
 
               Do_Report (D_Defaulted_Parameter, Get_Location (Element));
 
407
            -- Do not print message if the parameter is for a procedure or function body
 
408
            -- with an explicit specification
 
409
            Enclosing := Enclosing_Element (Element);
 
410
            if Declaration_Kind (Enclosing) not in A_Procedure_Body_Declaration .. A_Function_Body_Declaration
 
411
              or else Is_Nil (Corresponding_Declaration (Enclosing))
 
412
            then
 
413
               if not Is_Nil (Initialization_Expression (Element)) then
 
414
                  Do_Report (D_Defaulted_Parameter, Get_Location (Element));
 
415
               end if;
 
416
 
 
417
               case Mode_Kind (Element) is
 
418
                  when An_Out_Mode =>
 
419
                     Do_Report (D_Out_Parameter, Get_Location (Element));
 
420
                  when An_In_Out_Mode =>
 
421
                     Do_Report (D_In_Out_Parameter, Get_Location (Element));
 
422
                  when others =>
 
423
                     null;
 
424
               end case;
373
425
            end if;
374
426
 
375
427
         when A_Formal_Object_Declaration =>
378
430
            end if;
379
431
 
380
432
            if Mode_Kind (Element) = An_In_Out_Mode then
381
 
               Do_Report (D_Formal_In_Out, Get_Location (Element));
 
433
               Do_Report (D_In_Out_Generic_Parameter, Get_Location (Element));
 
434
            end if;
 
435
 
 
436
         when A_Package_Declaration =>
 
437
            if Current_Depth /= 1 then
 
438
               Do_Report (D_Nested_Package, Get_Location (Element));
382
439
            end if;
383
440
 
384
441
         when A_Package_Body_Declaration =>
406
463
            if Defining_Name_Kind (Names (Element)(1)) = A_Defining_Operator_Symbol
407
464
              and then Is_Nil (Corresponding_Declaration (Element))
408
465
            then
409
 
               -- If there is an explicit spec, we give the message on the spec
 
466
               -- If there is an explicit spec, we give the message on the spec (only)
410
467
               Do_Report (D_Operator, Get_Location (Element));
411
468
            end if;
412
469
 
437
494
         when An_Exception_Declaration =>
438
495
            Do_Report (D_Exception, Get_Location (Element));
439
496
 
440
 
         when A_Generic_Declaration =>
441
 
            Do_Report (D_Generic, Get_Location (Element));
 
497
         when A_Generic_Function_Declaration =>
 
498
            if Current_Depth /= 1 then
 
499
               Do_Report ((D_Generic, D_Nested_Generic_Function), Get_Location (Element));
 
500
            else
 
501
               Do_Report (D_Generic, Get_Location (Element));
 
502
            end if;
 
503
 
 
504
         when A_Generic_Package_Declaration =>
 
505
            if Current_Depth /= 1 then
 
506
               Do_Report ((D_Generic, D_Nested_Generic_Package), Get_Location (Element));
 
507
            else
 
508
               Do_Report (D_Generic, Get_Location (Element));
 
509
            end if;
 
510
 
 
511
         when A_Generic_Procedure_Declaration =>
 
512
            if Current_Depth /= 1 then
 
513
               Do_Report ((D_Generic, D_Nested_Generic_Procedure), Get_Location (Element));
 
514
            else
 
515
               Do_Report (D_Generic, Get_Location (Element));
 
516
            end if;
 
517
 
 
518
         when A_Function_Instantiation =>
 
519
            if Current_Depth /= 1 then
 
520
               Do_Report (D_Nested_Function_Instantiation, Get_Location (Element));
 
521
            end if;
 
522
 
 
523
         when A_Package_Instantiation =>
 
524
            if Current_Depth /= 1 then
 
525
               Do_Report (D_Nested_Package_Instantiation, Get_Location (Element));
 
526
            end if;
 
527
 
 
528
         when A_Procedure_Instantiation =>
 
529
            if Current_Depth /= 1 then
 
530
               Do_Report (D_Nested_Procedure_Instantiation, Get_Location (Element));
 
531
            end if;
442
532
 
443
533
         when A_Body_Stub =>
444
534
            Do_Report (D_Separate, Get_Location (Element));
445
535
 
446
536
         when A_Function_Renaming_Declaration
447
537
           | A_Generic_Function_Renaming_Declaration
448
 
           =>
449
 
            if Rule_Used (D_Not_Operator_Renames) then
450
 
               Renamed_Func := Renamed_Entity (Element);
451
 
               if Expression_Kind (Renamed_Func) = A_Selected_Component then
452
 
                  Renamed_Func := Selector (Renamed_Func);
453
 
               end if;
454
 
               if Expression_Kind (Renamed_Func) /= An_Operator_Symbol then
455
 
                  Do_Report (D_Not_Operator_Renames, Get_Location (Element));
456
 
               end if;
 
538
              =>
 
539
            Do_Report (D_Renaming, Get_Location (Element));
 
540
 
 
541
            if   Rule_Used (D_Not_Operator_Renaming)
 
542
              or Rule_Used (D_Non_Identical_Renaming)
 
543
              or Rule_Used (D_Operator_Renaming)
 
544
            then
 
545
               Renamed_Entity := A4G_Bugs.Renamed_Entity (Element);
 
546
               if  Expression_Kind (Renamed_Entity) = A_Selected_Component then
 
547
                  Renamed_Entity := Selector (Renamed_Entity);
 
548
               end if;
 
549
 
 
550
               case Expression_Kind (Renamed_Entity) is
 
551
                  when An_Explicit_Dereference
 
552
                     | An_Attribute_Reference
 
553
                     | A_Character_Literal
 
554
                       =>
 
555
                     Do_Report (D_Not_Operator_Renaming, Get_Location (Element));
 
556
                     -- Cannot be identical name
 
557
                     Do_Report (D_Non_Identical_Renaming, Get_Location (Element));
 
558
                  when An_Operator_Symbol =>
 
559
                     Do_Report (D_Operator_Renaming, Get_Location (Element));
 
560
                     if   To_Upper (Defining_Name_Image (Names (Element) (1)))
 
561
                       /= To_Upper (Name_Image (Renamed_Entity))
 
562
                     then
 
563
                        Do_Report (D_Non_Identical_Renaming, Get_Location (Element));
 
564
                     end if;
 
565
                  when An_Identifier
 
566
                     | An_Enumeration_Literal
 
567
                       =>
 
568
                     Do_Report (D_Not_Operator_Renaming, Get_Location (Element));
 
569
                     if   To_Upper (Defining_Name_Image (Names (Element) (1)))
 
570
                       /= To_Upper (Name_Image (Renamed_Entity))
 
571
                     then
 
572
                        Do_Report (D_Non_Identical_Renaming, Get_Location (Element));
 
573
                     end if;
 
574
                  when others =>
 
575
                     Failure ("Not a function name in function renaming");
 
576
               end case;
457
577
            end if;
458
 
            Do_Report (D_Renames, Get_Location (Element));
459
578
 
460
579
         when An_Object_Renaming_Declaration
461
580
           | An_Exception_Renaming_Declaration
464
583
           | A_Generic_Package_Renaming_Declaration
465
584
           | A_Generic_Procedure_Renaming_Declaration
466
585
           =>
467
 
            if Rule_Used (D_Not_Operator_Renames) then
468
 
               Do_Report (D_Not_Operator_Renames, Get_Location (Element));
469
 
            end if;
470
 
            Do_Report (D_Renames, Get_Location (Element));
 
586
            if Rule_Used (D_Not_Operator_Renaming) then
 
587
               Do_Report (D_Not_Operator_Renaming, Get_Location (Element));
 
588
            end if;
 
589
            if Rule_Used (D_Non_Identical_Renaming) then
 
590
               Renamed_Entity := A4G_Bugs.Renamed_Entity (Element);
 
591
               loop
 
592
                  case Expression_Kind (Renamed_Entity) is
 
593
                     when An_Explicit_Dereference
 
594
                        | An_Indexed_Component
 
595
                        | A_Slice
 
596
                        | An_Attribute_Reference
 
597
                        | A_Function_Call
 
598
                        | A_Character_Literal
 
599
                          =>
 
600
                        -- Always triggered
 
601
                        Do_Report (D_Non_Identical_Renaming, Get_Location (Element));
 
602
                        exit;
 
603
                     when A_Selected_Component =>
 
604
                        Renamed_Entity := Selector (Renamed_Entity);
 
605
                     when A_Type_Conversion =>
 
606
                        Renamed_Entity := Converted_Or_Qualified_Expression (Renamed_Entity);
 
607
                     when An_Identifier | An_Operator_Symbol | An_Enumeration_Literal =>
 
608
                        if To_Upper (Defining_Name_Image (Names (Element)(1))) /= To_Upper (Name_Image (Renamed_Entity))
 
609
                        then
 
610
                           Do_Report (D_Non_Identical_Renaming, Get_Location (Element));
 
611
                        end if;
 
612
                        exit;
 
613
                     when others =>
 
614
                        Failure ("Not a name in renaming");
 
615
                  end case;
 
616
               end loop;
 
617
            end if;
 
618
            Do_Report (D_Renaming, Get_Location (Element));
471
619
 
472
620
         when A_Formal_Function_Declaration =>
473
621
            Do_Report (D_Formal_Function, Get_Location (Element));