← Back to branch summary

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

« back to all changes in this revision

Viewing changes to src/rules-object_declarations.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-object_declarations.adb
 
1
----------------------------------------------------------------------
 
2
--  Rules.Object_Declarations - Package body                       --
 
3
--                                                                  --
 
4
--  This  software  is  (c)  CSEE  and Adalog  2004-2007.  The  Ada --
 
5
--  Controller  is  free software;  you can redistribute  it and/or --
 
6
--  modify  it under  terms of  the GNU  General Public  License as --
 
7
--  published by the Free Software Foundation; either version 2, or --
 
8
--  (at your  option) any later version.  This  unit is distributed --
 
9
--  in the hope  that it will be useful,  but WITHOUT ANY WARRANTY; --
 
10
--  without even the implied warranty of MERCHANTABILITY or FITNESS --
 
11
--  FOR A  PARTICULAR PURPOSE.  See the GNU  General Public License --
 
12
--  for more details.   You should have received a  copy of the GNU --
 
13
--  General Public License distributed  with this program; see file --
 
14
--  COPYING.   If not, write  to the  Free Software  Foundation, 59 --
 
15
--  Temple Place - Suite 330, Boston, MA 02111-1307, USA.           --
 
16
--                                                                  --
 
17
--  As  a special  exception, if  other files  instantiate generics --
 
18
--  from the units  of this program, or if you  link this unit with --
 
19
--  other files  to produce  an executable, this  unit does  not by --
 
20
--  itself cause the resulting executable  to be covered by the GNU --
 
21
--  General  Public  License.   This  exception  does  not  however --
 
22
--  invalidate any  other reasons why the executable  file might be --
 
23
--  covered by the GNU Public License.                              --
 
24
--                                                                  --
 
25
--  This  software is  distributed  in  the hope  that  it will  be --
 
26
--  useful,  but WITHOUT  ANY  WARRANTY; without  even the  implied --
 
27
--  warranty  of  MERCHANTABILITY   or  FITNESS  FOR  A  PARTICULAR --
 
28
--  PURPOSE.                                                        --
 
29
----------------------------------------------------------------------
 
30
 
 
31
-- ASIS
 
32
with
 
33
  Asis.Declarations,
 
34
  Asis.Elements,
 
35
  Asis.Expressions;
 
36
 
 
37
-- Adalog
 
38
with
 
39
  A4G_Bugs,
 
40
  Thick_Queries,
 
41
  Utilities;
 
42
 
 
43
-- Adactl
 
44
with
 
45
  Framework.Language,
 
46
  Framework.Rules_Manager,
 
47
  Framework.Reports;
 
48
pragma Elaborate (Framework.Language);
 
49
 
 
50
package body Rules.Object_Declarations is
 
51
   use Framework;
 
52
 
 
53
   type Subrules is (Min_Integer_Span);
 
54
   package Subrules_Flag_Utilities is new Framework.Language.Flag_Utilities (Subrules);
 
55
 
 
56
   type Subrule_Set is array (Subrules) of Boolean;
 
57
   No_Rule : constant Subrule_Set := (others => False);
 
58
   Rule_Used : Subrule_Set := No_Rule;
 
59
   Save_Used : Subrule_Set;
 
60
 
 
61
   type Object_Kinds is (K_All, K_Variable, K_Constant);
 
62
   package Object_Kinds_Utilities is new Framework.Language.Modifier_Utilities (Object_Kinds, "K_");
 
63
 
 
64
   type Object_Context is new Basic_Rule_Context with
 
65
      record
 
66
         Min_Values : Thick_Queries.Biggest_Natural := 0;
 
67
      end record;
 
68
   Ctl_Contexts : array (Subrules, Object_Kinds, Control_Kinds) of Object_Context;
 
69
 
 
70
   ----------
 
71
   -- Help --
 
72
   ----------
 
73
 
 
74
   procedure Help is
 
75
      use Subrules_Flag_Utilities, Utilities;
 
76
   begin
 
77
      User_Message ("Rule: " & Rule_Id);
 
78
      Help_On_Flags ("Parameter(1):");
 
79
      User_Message ("Parameter(2..)");
 
80
      User_Message ("   for Min_Integer_Span: [all|constant|variable] <value>");
 
81
      User_Message ("Control allowed forms of object declarations");
 
82
   end Help;
 
83
 
 
84
   -----------------
 
85
   -- Add_Control --
 
86
   -----------------
 
87
 
 
88
   procedure Add_Control (Ctl_Label : in Wide_String; Ctl_Kind : in Control_Kinds) is
 
89
      use Subrules_Flag_Utilities, Object_Kinds_Utilities, Thick_Queries, Framework.Language;
 
90
      Subrule : Subrules;
 
91
      Ok      : Object_Kinds;
 
92
      Vc      : Object_Context;
 
93
   begin
 
94
      if not Parameter_Exists then
 
95
         Parameter_Error (Rule_Id, "missing subrule name");
 
96
      end if;
 
97
 
 
98
      Subrule := Get_Flag_Parameter (Allow_Any => False);
 
99
 
 
100
      case Subrule is
 
101
         when Min_Integer_Span =>
 
102
            if not Parameter_Exists then
 
103
               Parameter_Error (Rule_Id, "missing number of allowed values");
 
104
            end if;
 
105
            loop
 
106
               Ok := Get_Modifier (Required => False);
 
107
               Vc := (Basic.New_Context (Ctl_Kind, Ctl_Label) with Get_Integer_Parameter (Min => 1));
 
108
               if Ok = K_All or Ok = K_Constant then
 
109
                  if Ctl_Contexts (Subrule, K_Constant, Ctl_Kind).Min_Values /= 0 then
 
110
                     Parameter_Error (Rule_Id, "rule already given for constants");
 
111
                  end if;
 
112
                  Ctl_Contexts (Subrule, K_Constant, Ctl_Kind) := Vc;
 
113
               end if;
 
114
               if Ok = K_All or Ok = K_Variable then
 
115
                  if Ctl_Contexts (Subrule, K_Variable, Ctl_Kind).Min_Values /= 0 then
 
116
                     Parameter_Error (Rule_Id, "rule already given for variables");
 
117
                  end if;
 
118
                  Ctl_Contexts (Subrule, K_Variable, Ctl_Kind) := Vc;
 
119
               end if;
 
120
               exit when not Parameter_Exists;
 
121
            end loop;
 
122
      end case;
 
123
      Rule_Used (Subrule) := True;
 
124
   end Add_Control;
 
125
 
 
126
   -------------
 
127
   -- Command --
 
128
   -------------
 
129
 
 
130
   procedure Command (Action : Framework.Rules_Manager.Rule_Action) is
 
131
      use Framework.Rules_Manager;
 
132
   begin
 
133
      case Action is
 
134
         when Clear =>
 
135
            Rule_Used := No_Rule;
 
136
            for Sr in Subrules loop
 
137
               for Ok in Object_Kinds loop
 
138
                  for Rt in Control_Kinds loop
 
139
                     Ctl_Contexts (Sr, Ok, Rt).Min_Values := 0;
 
140
                  end loop;
 
141
               end loop;
 
142
            end loop;
 
143
         when Suspend =>
 
144
            Save_Used := Rule_Used;
 
145
            Rule_Used := No_Rule;
 
146
         when Resume =>
 
147
            Rule_Used := Save_Used;
 
148
      end case;
 
149
   end Command;
 
150
 
 
151
 
 
152
   -------------------------
 
153
   -- Process_Declaration --
 
154
   -------------------------
 
155
 
 
156
   procedure Process_Declaration (Decl : in Asis.Declaration) is
 
157
      use Framework.Reports, Thick_Queries, Utilities;
 
158
      use Asis, Asis.Declarations, Asis.Elements, Asis.Expressions;
 
159
 
 
160
      Val      : Extended_Biggest_Natural;
 
161
      Def      : Asis.Definition;
 
162
      St_Name  : Asis.Expression;
 
163
      Type_Def : Asis.Declaration;
 
164
      Obj_Kind : Object_Kinds;
 
165
   begin
 
166
      if Rule_Used = No_Rule then
 
167
         return;
 
168
      end if;
 
169
      Rules_Manager.Enter (Rule_Id);
 
170
 
 
171
      -- Check we have an object of an integer type
 
172
      Def := Object_Declaration_View (Decl);
 
173
      if Definition_Kind (Def) /= A_Subtype_Indication then
 
174
         -- anonymous array
 
175
         return;
 
176
      end if;
 
177
      St_Name := Subtype_Simple_Name (Def);
 
178
      if Expression_Kind (St_Name) = An_Attribute_Reference then
 
179
         case A4G_Bugs.Attribute_Kind (St_Name) is
 
180
            when A_Base_Attribute =>
 
181
               -- for the purpose of checking if it is an integer type, the prefix will do as well
 
182
               St_Name := Prefix (St_Name);
 
183
            when A_Class_Attribute =>
 
184
               -- Certainly not an integer type...
 
185
               return;
 
186
            when others =>
 
187
               Failure ("Bad attribute", St_Name);
 
188
         end case;
 
189
      end if;
 
190
      Type_Def := Type_Declaration_View (Corresponding_Name_Declaration (St_Name));
 
191
      if Type_Kind (Type_Def) not in A_Signed_Integer_Type_Definition .. A_Modular_Type_Definition then
 
192
         return;
 
193
      end if;
 
194
 
 
195
      if Declaration_Kind (Decl) = A_Constant_Declaration then
 
196
         Obj_Kind := K_Constant;
 
197
      else
 
198
         Obj_Kind := K_Variable;
 
199
      end if;
 
200
 
 
201
      -- Check values
 
202
 
 
203
      Val := Discrete_Constraining_Lengths (Decl) (1);
 
204
 
 
205
      if Val = Not_Static then
 
206
         return;
 
207
      end if;
 
208
 
 
209
      -- Note: Unspecified values of Range/Obj_Kind/Control contain 0, and Val is >= 0
 
210
      --       No problem in the following tests
 
211
      if Val < Ctl_Contexts (Min_Integer_Span, Obj_Kind, Check).Min_Values  then
 
212
         Report (Rule_Id,
 
213
                 Ctl_Contexts (Min_Integer_Span, Obj_Kind, Check),
 
214
                 Get_Location (Decl),
 
215
                 "integer object declaration has too few values ("
 
216
                 & Biggest_Int_Img (Val)
 
217
                 & ')');
 
218
      elsif Val < Ctl_Contexts (Min_Integer_Span, Obj_Kind, Search).Min_Values  then
 
219
         Report (Rule_Id,
 
220
                 Ctl_Contexts (Min_Integer_Span, Obj_Kind, Search),
 
221
                 Get_Location (Decl),
 
222
                 "integer object declaration has too few values ("
 
223
                 & Biggest_Int_Img (Val)
 
224
                 & ')');
 
225
      end if;
 
226
 
 
227
      if Val < Ctl_Contexts (Min_Integer_Span, Obj_Kind, Count).Min_Values  then
 
228
         Report (Rule_Id,
 
229
                 Ctl_Contexts (Min_Integer_Span, Obj_Kind, Count),
 
230
                 Get_Location (Decl),
 
231
                 "");
 
232
      end if;
 
233
   end Process_Declaration;
 
234
 
 
235
begin
 
236
   Framework.Rules_Manager.Register (Rule_Id,
 
237
                                     Rules_Manager.Semantic,
 
238
                                     Help_CB        => Help'Access,
 
239
                                     Add_Control_CB => Add_Control'Access,
 
240
                                     Command_CB     => Command'Access);
 
241
end Rules.Object_Declarations;