← Back to branch summary

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

« back to all changes in this revision

Viewing changes to src/rules-unsafe_unchecked_conversion.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-unsafe_unchecked_conversion.adb
 
1
----------------------------------------------------------------------
 
2
--  Rules.Unsafe_Unchecked_Conversion - Package body                --
 
3
--                                                                  --
 
4
--  This software  is (c) SAGEM DS and  Adalog  2004-2006.  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.Clauses,
 
34
  Asis.Declarations,
 
35
  Asis.Elements,
 
36
  Asis.Expressions;
 
37
 
 
38
-- Adalog
 
39
with
 
40
  A4G_Bugs,
 
41
  Thick_Queries,
 
42
  Utilities;
 
43
 
 
44
-- Adactl
 
45
with
 
46
  Framework.Language,
 
47
  Framework.Rules_Manager,
 
48
  Framework.Reports;
 
49
 
 
50
package body Rules.Unsafe_Unchecked_Conversion is
 
51
   use Framework;
 
52
 
 
53
   Rule_Used : Boolean := False;
 
54
   Save_Used : Boolean;
 
55
   Context   : Framework.Basic_Rule_Context;
 
56
 
 
57
   ----------
 
58
   -- Help --
 
59
   ----------
 
60
 
 
61
   procedure Help is
 
62
      use Utilities;
 
63
   begin
 
64
      User_Message ("Rule: " & Rule_Id);
 
65
      User_Message ("Parameter(s): none");
 
66
      User_Message ("Control unsafe usage of Unchecked_Conversion");
 
67
   end Help;
 
68
 
 
69
   -------------
 
70
   -- Add_Use --
 
71
   -------------
 
72
 
 
73
   procedure Add_Use (Label : in Wide_String; Rule_Type : in Rule_Types) is
 
74
      use Framework.Language;
 
75
 
 
76
   begin
 
77
      if Rule_Used then
 
78
         Parameter_Error (Rule_Id, "rule already specified");
 
79
      end if;
 
80
 
 
81
      if Parameter_Exists then
 
82
         Parameter_Error (Rule_Id, "no parameter for rule");
 
83
      end if;
 
84
 
 
85
      Context   := Basic.New_Context (Rule_Type, Label);
 
86
      Rule_Used := True;
 
87
   end Add_Use;
 
88
 
 
89
   -------------
 
90
   -- Command --
 
91
   -------------
 
92
 
 
93
   procedure Command (Action : Framework.Rules_Manager.Rule_Action) is
 
94
      use Framework.Rules_Manager;
 
95
   begin
 
96
      case Action is
 
97
         when Clear =>
 
98
            Rule_Used := False;
 
99
         when Suspend =>
 
100
            Save_Used := Rule_Used;
 
101
            Rule_Used := False;
 
102
         when Resume =>
 
103
            Rule_Used := Save_Used;
 
104
      end case;
 
105
   end Command;
 
106
 
 
107
 
 
108
   --------------------------
 
109
   -- Process_Instantation --
 
110
   --------------------------
 
111
 
 
112
   procedure Process_Instantiation (Instantiation : in Asis.Declaration) is
 
113
      use Asis, Asis.Declarations, Asis.Elements, Asis.Expressions;
 
114
      use Framework.Reports, Thick_Queries, Utilities;
 
115
 
 
116
      Source, Target : Asis.Expression;
 
117
      S_Size, T_Size : Integer;
 
118
      Assocs : Asis.Association_List (1..2);
 
119
 
 
120
      Not_Specified : constant Integer := -1;
 
121
      Class_Wide    : constant Integer := -2;
 
122
 
 
123
      function Size_Value (Type_Name : Asis.Expression) return Integer is
 
124
         use Asis.Clauses;
 
125
         Good_Name : Asis.Expression := Type_Name;
 
126
      begin
 
127
         if Expression_Kind (Good_Name) = An_Attribute_Reference then
 
128
            case A4G_Bugs.Attribute_Kind (Good_Name) is
 
129
               when A_Base_Attribute =>
 
130
                  Good_Name := Prefix (Good_Name);
 
131
               when A_Class_Attribute =>
 
132
                  return Class_Wide;
 
133
               when others =>
 
134
                  Failure ("unexpected attribute", Good_Name);
 
135
            end case;
 
136
         end if;
 
137
 
 
138
         declare
 
139
            Reprs : constant Asis.Representation_Clause_List
 
140
              := Corresponding_Representation_Clauses (Corresponding_Name_Declaration (Good_Name));
 
141
         begin
 
142
            for R in Reprs'Range loop
 
143
               if Representation_Clause_Kind (Reprs (R)) = An_Attribute_Definition_Clause
 
144
                 and then A4G_Bugs.Attribute_Kind (Representation_Clause_Name (Reprs (R))) = A_Size_Attribute
 
145
               then
 
146
                  declare
 
147
                     Val_Img : constant Wide_String := Static_Expression_Value_Image
 
148
                       (Representation_Clause_Expression (Reprs (R)));
 
149
                  begin
 
150
                     if Val_Img = "" then
 
151
                        Uncheckable (Rule_Id,
 
152
                                     False_Positive,
 
153
                                     Get_Location (Representation_Clause_Expression (Reprs (R))),
 
154
                                     "unable to evaluate size clause value");
 
155
                        return Not_Specified;
 
156
                     else
 
157
                        return Integer'Wide_Value (Val_Img);
 
158
                     end if;
 
159
                  end;
 
160
               end if;
 
161
            end loop;
 
162
 
 
163
            -- No size clause found
 
164
            return Not_Specified;
 
165
         end;
 
166
      end Size_Value;
 
167
 
 
168
      Reported : Boolean := False;
 
169
   begin
 
170
      if not Rule_Used then
 
171
         return;
 
172
      end if;
 
173
      Rules_Manager.Enter (Rule_Id);
 
174
 
 
175
      declare
 
176
         Name_Image : constant Wide_String := To_Upper (Full_Name_Image
 
177
                                                        (Ultimate_Name
 
178
                                                         (Generic_Unit_Name (Instantiation))));
 
179
      begin
 
180
         if Name_Image /= "ADA.UNCHECKED_CONVERSION" and Name_Image /= "UNCHECKED_CONVERSION" then
 
181
            -- In Gnat, Unchecked_Conversion is not a renaming of Ada.Unchecked_Conversion
 
182
            return;
 
183
         end if;
 
184
      end;
 
185
 
 
186
      Assocs := Generic_Actual_Part (Instantiation);
 
187
      Source := Actual_Parameter (Assocs (1));
 
188
      if Expression_Kind (Source) = A_Selected_Component then
 
189
         Source := Selector (Source);
 
190
      end if;
 
191
      Target := Actual_Parameter (Assocs (2));
 
192
      if Expression_Kind (Target) = A_Selected_Component then
 
193
         Target := Selector (Target);
 
194
      end if;
 
195
 
 
196
      S_Size := Size_Value (Source);
 
197
      T_Size := Size_Value (Target);
 
198
 
 
199
      if S_Size = Not_Specified then
 
200
         Report (Rule_Id,
 
201
                 Context,
 
202
                 Get_Location (Source),
 
203
                 "no size clause given for Source");
 
204
         Reported := True;
 
205
      end if;
 
206
      if T_Size = Not_Specified then
 
207
         Report (Rule_Id,
 
208
                 Context,
 
209
                 Get_Location (Target),
 
210
                 "no size clause given for Target");
 
211
         Reported := True;
 
212
      end if;
 
213
 
 
214
      if S_Size = Class_Wide then
 
215
         Report (Rule_Id,
 
216
                 Context,
 
217
                 Get_Location (Source),
 
218
                 "class-wide type given for Source");
 
219
         Reported := True;
 
220
      end if;
 
221
      if T_Size = Class_Wide then
 
222
         Report (Rule_Id,
 
223
                 Context,
 
224
                 Get_Location (Target),
 
225
                 "class-wide type given for Target");
 
226
         Reported := True;
 
227
      end if;
 
228
 
 
229
      if Reported then
 
230
         return;
 
231
      end if;
 
232
 
 
233
      -- Here, S_Size and T_Size are known
 
234
      if S_Size /= T_Size then
 
235
         Report (Rule_Id,
 
236
                 Context,
 
237
                 Get_Location (Source),
 
238
                 "Source size (" & Integer_Img (S_Size) & ") /= Target size (" & Integer_Img (T_Size) & ')');
 
239
      end if;
 
240
 
 
241
   end Process_Instantiation;
 
242
 
 
243
begin
 
244
   Framework.Rules_Manager.Register_Semantic (Rule_Id,
 
245
                                              Help    => Help'Access,
 
246
                                              Add_Use => Add_Use'Access,
 
247
                                              Command => Command'Access);
 
248
end Rules.Unsafe_Unchecked_Conversion;