← Back to branch summary

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

« back to all changes in this revision

Viewing changes to src/rules-declaration.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-declaration.adb
 
1
----------------------------------------------------------------------
 
2
--  Rules.Declaration - 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
-- Ada
 
33
with
 
34
  Ada.Strings.Wide_Unbounded;
 
35
 
 
36
-- ASIS
 
37
with
 
38
  ASIS.Elements,
 
39
  ASIS.Declarations;
 
40
 
 
41
-- Adalog
 
42
with
 
43
  Utilities;
 
44
 
 
45
-- Adactl
 
46
with
 
47
  Framework.Language,
 
48
  Framework.Rules_Manager,
 
49
  Framework.Reports;
 
50
 
 
51
package body Rules.Declaration is
 
52
   use Framework;
 
53
 
 
54
   type Declaration_Names is (Decl_Access,    Decl_Access_Subprogram, Decl_Aliased,
 
55
                              Decl_Exception, Decl_Tagged,            Decl_Task);
 
56
 
 
57
   -----------
 
58
   -- Image --
 
59
   -----------
 
60
 
 
61
   function Image (Stmt : Declaration_Names) return Wide_String is
 
62
      use Utilities;
 
63
      Img : constant Wide_String := To_Lower (Declaration_Names'Wide_Image (Stmt));
 
64
   begin
 
65
      -- Remove "DECL_"
 
66
      return Img (6 .. Img'Last);
 
67
   end Image;
 
68
 
 
69
   type Usage_Flags is array (Declaration_Names) of Boolean;
 
70
   Rule_Used : Usage_Flags := (others => False);
 
71
   Save_Used : Usage_Flags;
 
72
   Usage     : array (Declaration_Names) of Simple_Context;
 
73
 
 
74
   ----------
 
75
   -- Help --
 
76
   ----------
 
77
 
 
78
   procedure Help is
 
79
      use Utilities;
 
80
   begin
 
81
      User_Message ("Rule: " & Rule_Id);
 
82
      User_Message ("Parameter(s): access | access_subprogram | aliased | exception | tagged | task");
 
83
      User_Message ("Control occurrences of Ada declarations");
 
84
   end Help;
 
85
 
 
86
   -------------
 
87
   -- Add_Use --
 
88
   -------------
 
89
 
 
90
   procedure Add_Use (Label     : in Wide_String;
 
91
                      Rule_Type : in Rule_Types) is
 
92
      use Ada.Strings.Wide_Unbounded;
 
93
      use Framework.Language;
 
94
      Decl    : Declaration_Names;
 
95
 
 
96
      function Get_Declaration_Parameter is new Get_Flag_Parameter (Flags     => Declaration_Names,
 
97
                                                                    Allow_Any => False,
 
98
                                                                    Prefix    => "DECL_");
 
99
   begin
 
100
      if not Parameter_Exists then
 
101
         Parameter_Error ("At least one parameter required for rule " & Rule_Id);
 
102
      end if;
 
103
 
 
104
      while Parameter_Exists loop
 
105
         Decl := Get_Declaration_Parameter;
 
106
         if Rule_Used (Decl) then
 
107
            Parameter_Error ("Declaration already given for rule " & Rule_Id
 
108
                             & ": " & Image (Decl));
 
109
         end if;
 
110
 
 
111
         Rule_Used (Decl) := True;
 
112
         Usage (Decl)     := (Rule_Type, To_Unbounded_Wide_String (Label));
 
113
      end loop;
 
114
   end Add_Use;
 
115
 
 
116
   -------------
 
117
   -- Command --
 
118
   -------------
 
119
 
 
120
   procedure Command (Action : Framework.Rules_Manager.Rule_Action) is
 
121
      use Framework.Rules_Manager;
 
122
   begin
 
123
      case Action is
 
124
         when Clear =>
 
125
            Rule_Used := (others => False);
 
126
         when Suspend =>
 
127
            Save_Used := Rule_Used;
 
128
            Rule_Used := (others => False);
 
129
         when Resume =>
 
130
            Rule_Used := Save_Used;
 
131
      end case;
 
132
   end Command;
 
133
 
 
134
   -------------------------
 
135
   -- Process_Declaration --
 
136
   -------------------------
 
137
 
 
138
   procedure Process_Declaration (Element : in Asis.Declaration) is
 
139
      use Ada.Strings.Wide_Unbounded, Asis, Asis.Elements, Asis.Declarations, Framework.Reports;
 
140
      Decl : Declaration_Names;
 
141
   begin
 
142
      if Rule_Used = (Declaration_Names => False) then
 
143
         return;
 
144
      end if;
 
145
      Rules_Manager.Enter (Rule_Id);
 
146
 
 
147
      case Declaration_Kind (Element) is
 
148
         when An_Ordinary_Type_Declaration =>
 
149
            case Type_Kind (Type_Declaration_View (Element)) is
 
150
               when An_Access_Type_Definition =>
 
151
                  case Access_Type_Kind (Type_Declaration_View (Element)) is
 
152
                     when Access_To_Subprogram_Definition =>
 
153
                        if Rule_Used (Decl_Access_Subprogram) then
 
154
                           Decl := Decl_Access_Subprogram;
 
155
                        else
 
156
                           Decl := Decl_Access;
 
157
                        end if;
 
158
                     when others =>
 
159
                        Decl := Decl_Access;
 
160
                  end case;
 
161
 
 
162
               when A_Tagged_Record_Type_Definition =>
 
163
                  Decl := Decl_Tagged;
 
164
 
 
165
               when others =>
 
166
                  return;
 
167
            end case;
 
168
 
 
169
         when A_Variable_Declaration
 
170
           | A_Constant_Declaration =>
 
171
            case Trait_Kind (Element) is
 
172
               when An_Aliased_Trait =>
 
173
                  Decl := Decl_Aliased;
 
174
               when others =>
 
175
                  return;
 
176
            end case;
 
177
 
 
178
         when A_Task_Type_Declaration =>
 
179
            Decl := Decl_Task;
 
180
 
 
181
         when A_Single_Task_Declaration =>
 
182
            Decl := Decl_Task;
 
183
 
 
184
         when An_Exception_Declaration =>
 
185
            Decl := Decl_Exception;
 
186
 
 
187
         when others =>
 
188
            return;
 
189
      end case;
 
190
 
 
191
      if not Rule_Used (Decl) then
 
192
         return;
 
193
      end if;
 
194
 
 
195
      Report (Rule_Id,
 
196
              To_Wide_String (Usage(Decl).Rule_Label),
 
197
              Usage (Decl).Rule_Type,
 
198
              Get_Location (Element),
 
199
              "use of declaration """ & Image (Decl) & '"');
 
200
   end Process_Declaration;
 
201
 
 
202
begin
 
203
   Framework.Rules_Manager.Register (Rule_Id,
 
204
                                     Help    => Help'Access,
 
205
                                     Add_Use => Add_Use'Access,
 
206
                                     Command => Command'Access);
 
207
end Rules.Declaration;