1
----------------------------------------------------------------------
2
-- Rules.Simplifiable_Expressions - Package body --
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. --
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. --
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 --
30
----------------------------------------------------------------------
34
Ada.Strings.Wide_Unbounded;
54
Framework.Rules_Manager,
57
package body Rules.Simplifiable_expressions is
58
use Framework, Ada.Strings.Wide_Unbounded;
60
type Keywords is (K_Range, K_Logical_True, K_Logical_False, K_Parentheses, K_Logical);
61
subtype To_Check is Keywords range Keywords'First .. Keywords'Pred (K_Logical);
65
Used : Boolean := False;
66
Label : Unbounded_Wide_String;
68
type Usages is array (To_Check) of Usage_Entry;
70
Context : array (Rule_Types) of Usages;
78
function Image (Check : To_Check) return Wide_String is
80
Img : constant Wide_String := To_Lower (To_Check'Wide_Image (Check));
83
return Img (3 .. Img'Last);
93
User_Message ("Rule: " & Rule_Id);
94
User_Message ("Parameter(s): ranges | logical | logical_true | logical_false");
95
User_Message (" | parentheses (optional, default=all)");
96
User_Message ("Control occurrence of various forms of expressions that could be made simpler:");
97
User_Message (" T'FIRST .. T'LAST that can be replaced by T'RANGE or T.");
98
User_Message (" <expression> = (/=) True/False");
99
User_Message (" if (<expression>) or case (<expression>)");
106
procedure Add_Use (Label : in Wide_String;
107
Rule_Use_Type : in Rule_Types) is
108
use Ada.Strings.Wide_Unbounded, Framework.Language;
111
function Get_Check_Parameter is new Get_Flag_Parameter (Flags => Keywords,
115
procedure Add_Check (Check : To_Check) is
117
if Context (Rule_Use_Type)(Check).Used then
118
Parameter_Error ("Check already given for rule " & Rule_Id
119
& ": " & Image (Check));
121
Context (Rule_Use_Type)(Check) := (Used => True, Label => To_Unbounded_Wide_String (Add_Use.Label));
125
if Parameter_Exists then
126
while Parameter_Exists loop
127
Key := Get_Check_Parameter;
128
if Key = K_Logical then
129
Add_Check (K_Logical_True);
130
Add_Check (K_Logical_False);
137
Add_Check (K_Logical_True);
138
Add_Check (K_Logical_False);
139
Add_Check (K_Parentheses);
148
procedure Command (Action : Framework.Rules_Manager.Rule_Action) is
149
use Framework.Rules_Manager;
153
--The following aggregate hangs Gnat, but the explicit loop is OK...
154
--Context := (others => (others => (Used => False, Label => Null_Unbounded_Wide_String)));
155
for I in Context'Range loop
156
for J in Usages'Range loop
157
Context (I)(J) := (Used => False, Label => Null_Unbounded_Wide_String);
162
Save_Used := Rule_Used;
165
Rule_Used := Save_Used;
173
procedure Process_Call (Call : in Asis.Expression) is
174
use Ada.Strings.Wide_Unbounded, Asis,
175
Asis.Elements, Asis.Expressions, Framework.Reports, Thick_Queries;
177
type Param_Kind is (Static_True, Static_False, Expr);
178
function "+" (Left : Wide_String) return Unbounded_Wide_String renames To_Unbounded_Wide_String;
180
-- Message_Table (Operator, Left, Right)
181
Message_Table : constant array (Operator_Kinds range An_Equal_Operator .. A_Not_Equal_Operator,
183
Param_Kind) of Unbounded_Wide_String
184
:= (An_Equal_Operator =>
186
(Static_True => +"Simplify expression: statically True", -- True = True
187
Static_False => +"Simplify expression: statically False", -- True = False
188
Expr => +"Simplify expression 'True = <expr>' to just '<expr>'"), -- True = <Expr>
190
(Static_True => +"Simplify expression: statically False", -- False = True
191
Static_False => +"Simplify expression: statically True", -- False = False
192
Expr => +"Simplify expression 'False = <expr>' to 'not <expr>'"), -- False = <Expr>
194
(Static_True => +"Simplify expression '<expr> = True' to just '<expr>'", -- <Expr> = True
195
Static_False => +"Simplify expression '<expr> = False' to 'not <expr>'", -- <Expr> = False
196
Expr => +"")), -- <Expr> = <Expr>
197
A_Not_Equal_Operator =>
199
(Static_True => +"Simplify expression: statically False", -- True /= True
200
Static_False => +"Simplify expression: statically True", -- True /= False
201
Expr => + "Simplify expression 'True /= <expr>' to 'not <expr>'"), -- True /= <Expr>
203
(Static_True => +"Simplify expression: statically True", -- False /= True
204
Static_False => +"Simplify expression: statically False", -- False /= False
205
Expr => +"Simplify expression 'False /= <expr>' to just '<expr>'"), -- False /= <Expr>
207
(Static_True => +"Simplify expression '<expr> /= True' to 'not <expr>'", -- <Expr> /= True
208
Static_False => +"Simplify expression '<expr> /= False' to just '<expr>'", -- <Expr> /= False
209
Expr => +""))); -- <Expr> /= <Expr>
210
Op : constant Asis.Operator_Kinds := Operator_Kind (Prefix (Call));
212
function Get_Kind (Param : Asis.Expression) return Param_Kind is
215
if Expression_Kind (Param) = An_Enumeration_Literal
216
and then To_Upper (Full_Name_Image (Param)) = "STANDARD.FALSE"
219
elsif Expression_Kind (Param) = An_Enumeration_Literal
220
and then To_Upper (Full_Name_Image (Param)) = "STANDARD.TRUE"
228
if not Rule_Used then
231
Rules_Manager.Enter (Rule_Id);
233
if Op in An_Equal_Operator .. A_Not_Equal_Operator then
235
P : constant Asis.Association_List := Function_Call_Parameters (Call);
236
L : constant Param_Kind := Get_Kind (Actual_Parameter (P(1)));
237
R : constant Param_Kind := Get_Kind (Actual_Parameter (P(2)));
239
if Message_Table (Op, L, R) /= Null_Unbounded_Wide_String then
240
-- Report the highest priority from Check/Search
241
if Context (Check)(K_Logical_False).Used and then (L = Static_False or R = Static_False) then
243
To_Wide_String (Context (Check)(K_Logical_False).Label),
246
To_Wide_String (Message_Table (Op, L, R)));
247
elsif Context (Check)(K_Logical_True).Used and then (L = Static_True or R = Static_True) then
249
To_Wide_String (Context (Check)(K_Logical_True).Label),
252
To_Wide_String (Message_Table (Op, L, R)));
253
elsif Context (Search)(K_Logical_False).Used and then (L = Static_False or R = Static_False) then
255
To_Wide_String (Context (Search)(K_Logical_False).Label),
258
To_Wide_String (Message_Table (Op, L, R)));
259
elsif Context (Search)(K_Logical_True).Used and then (L = Static_True or R = Static_True) then
261
To_Wide_String (Context (Search) (K_Logical_True).Label),
264
To_Wide_String (Message_Table (Op, L, R)));
267
-- Always report Count
268
if Context (Count)(K_Logical_False).Used and then (L = Static_False or R = Static_False) then
270
To_Wide_String (Context (Count) (K_Logical_False).Label),
273
To_Wide_String (Message_Table (Op, L, R)));
274
elsif Context (Count)(K_Logical_True).Used and then (L = Static_True or R = Static_True) then
276
To_Wide_String (Context (Count) (K_Logical_True).Label),
279
To_Wide_String (Message_Table (Op, L, R)));
290
procedure Process_Range (Definition : in Asis.Definition) is
291
use Ada.Strings.Wide_Unbounded, Asis, Asis.Declarations, Asis.Definitions,
292
Asis.Elements, Asis.Expressions, Framework.Reports, Thick_Queries, Utilities;
294
procedure Do_Reports (Message : Wide_String) is
296
if Context (Check)(K_Range).Used then
298
To_Wide_String (Context (Check)(K_Range).Label),
300
Get_Location (Definition),
302
elsif Context (Search)(K_Range).Used then
304
To_Wide_String (Context (Search)(K_Range).Label),
306
Get_Location (Definition),
310
if Context (Count)(K_Range).Used then
312
To_Wide_String (Context (Count)(K_Range).Label),
314
Get_Location (Definition),
319
if not Rule_Used then
322
Rules_Manager.Enter (Rule_Id);
324
case Discrete_Range_Kind (Definition) is
325
when A_Discrete_Simple_Expression_Range =>
327
LB : constant Expression := Lower_Bound (Definition);
328
UB : constant Expression := Upper_Bound (Definition);
330
if A4G_Bugs.Attribute_Kind (LB) /= A_First_Attribute
331
or A4G_Bugs.Attribute_Kind (UB) /= A_Last_Attribute
336
-- Must deal with the following cases when determining 'T':-
341
-- We must also not fall into the trap of recommending
342
-- T'BASE'FIRST .. T'LAST or T'FIRST (X) .. T'LAST (Y) for simplification.
344
-- First we remove the 'FIRST and 'LAST attributes.
345
LP : Asis.Expression := Prefix (LB);
346
UP : Asis.Expression := Prefix (UB);
347
ALB : constant Expression_List := Attribute_Designator_Expressions (LB);
348
AUB : constant Expression_List := Attribute_Designator_Expressions (UB);
350
-- Both the first and last attributes must have either no attribute designators expressions
351
-- or else have the same value.
352
-- Take the Wide_Value below for the case of the naughty user who wrote something like
353
---Tab'First (10#1#) .. Tab'Last (1).
354
-- Note that attribute designator expressions can only ever have a length of 0 or 1,
355
-- and are satic integers.
356
if ALB'LENGTH /= AUB'LENGTH
357
or else (ALB'LENGTH = 1 -- Implies AUB'LENGTH = 1
358
and then Asis_Integer'Wide_Value (Value_Image (ALB (1))) /=
359
Asis_Integer'Wide_Value (Value_Image (AUB (1))))
364
-- Remove the 'BASE attribute but only if it is applied to both attributes.
365
if Expression_Kind (LP) = An_Attribute_Reference then
366
if Expression_Kind (UP) = An_Attribute_Reference then
372
elsif Expression_Kind (UP) = An_Attribute_Reference then
376
-- Remove indexings and selectors for record elements.
377
-- If in doubt, give up.
379
case Expression_Kind (LP) is
380
when An_Identifier =>
383
when A_Selected_Component =>
384
case Declaration_Kind (Corresponding_Name_Declaration (Selector (LP))) is
385
when A_Component_Declaration | A_Discriminant_Specification =>
386
if Expression_Kind (UP) /= A_Selected_Component then
390
-- It's a record field, a protected type field...
391
if Is_Equal (Corresponding_Name_Declaration (Selector (LP)),
392
Corresponding_Name_Declaration (Selector (UP)))
399
when A_Variable_Declaration
400
| An_Object_Renaming_Declaration
401
| A_Subtype_Declaration
402
| An_Ordinary_Type_Declaration
404
-- Its a Pack.Var or Pack.T selector
407
Failure ("Wrong selected component",
408
Corresponding_Name_Declaration (Selector (LP)));
411
when An_Indexed_Component =>
412
if Expression_Kind (UP) /= An_Indexed_Component then
416
-- Check that the indexing expressions are statically the same.
417
-- We currently recognize as identical indexing expressions that are:
418
-- - Integer litterals
419
-- - Enumeration litterals
420
-- - Identical constants and loop control parameters
422
L_Indexers : constant Asis.Expression_List := Index_Expressions (LP);
423
U_Indexers : constant Asis.Expression_List := Index_Expressions (UP);
425
if L_Indexers'Length /= U_Indexers'Length then
428
for I in L_Indexers'Range loop
429
if Expression_Kind (L_Indexers (I)) /= Expression_Kind (U_Indexers (I)) then
433
case Expression_Kind (L_Indexers (I)) is
434
when An_Integer_Literal =>
435
if Asis_Integer'Wide_Value (Value_Image (L_Indexers (I)))
436
/= Asis_Integer'Wide_Value (Value_Image (U_Indexers (I)))
440
when An_Enumeration_Literal =>
441
if To_Upper (Value_Image (L_Indexers (I)))
442
/= To_Upper (Value_Image (U_Indexers (I)))
446
when An_Identifier =>
447
case Declaration_Kind (Corresponding_Name_Declaration (L_Indexers (I))) is
448
when A_Constant_Declaration
449
| A_Deferred_Constant_Declaration
450
| A_Loop_Parameter_Specification
452
if not Is_Equal (Corresponding_Name_Definition (L_Indexers (I)),
453
Corresponding_Name_Definition (U_Indexers (I)))
466
-- Here, both indexings are the same
471
Failure ("Unexpected expression kind", LP);
476
-- If we still have a selected name, the prefixes are packages
477
-- => Get rid of them
478
-- To be honnest: maybe not for UP, but then it will fail later
479
if Expression_Kind (LP) = A_Selected_Component then
482
if Expression_Kind (UP) = A_Selected_Component then
486
-- Here we have a "clean" name for lower/upper prefix
487
-- Check the full expanded names of both bounds.
488
if Full_Name_Image (LP) = Full_Name_Image (UP) then
489
case Declaration_Kind (Corresponding_Name_Declaration (LP)) is
490
when A_Subtype_Declaration
491
| An_Ordinary_Type_Declaration
492
| A_Formal_Type_Declaration
494
Do_Reports ("(T)'First .. (T)'Last replaceable with (sub)type(T)");
495
when A_Variable_Declaration
496
| A_Constant_Declaration
497
| An_Object_Renaming_Declaration
498
| A_Deferred_Constant_Declaration
499
| A_Formal_Object_Declaration
500
| A_Parameter_Specification
501
| A_Component_Declaration
503
Do_Reports ("(T)'First .. (T)'Last replaceable with (T)'Range");
505
Failure ("Unexpected Element_Kind 1: " &
506
Declaration_Kinds'WIDE_IMAGE (Declaration_Kind
507
(Corresponding_Name_Declaration
514
when A_Discrete_Range_Attribute_Reference =>
515
-- We are interested only in the case where the prefix is a (sub)type
517
P : Asis.Expression := Prefix (Range_Attribute (Definition));
518
Decl : Asis.Declaration;
519
Def : Asis.Definition;
521
case Expression_Kind (P) is
522
when An_Identifier =>
524
when A_Selected_Component =>
528
-- Prefix cannot denote a (sub)type
532
-- Get rid of subtypes
533
Decl := Corresponding_Name_Declaration (P);
534
if Declaration_Kind (Decl) = A_Subtype_Declaration then
535
Decl := Corresponding_First_Subtype (Decl);
538
case Declaration_Kind (Decl) is
539
when An_Ordinary_Type_Declaration
540
| A_Formal_Type_Declaration
542
-- Get rid of derived types, including formal derived type
543
-- We can of course have a type derived from a formal derived type,
544
-- and conversely. To any depth.
545
Def := Type_Declaration_View (Decl);
547
if Type_Kind (Def) in A_Derived_Type_Definition .. A_Derived_Record_Extension_Definition then
548
Def := Type_Declaration_View (Corresponding_Root_Type (Def));
549
elsif Formal_Type_Kind (Def) = A_Formal_Derived_Type_Definition then
550
Def := Type_Declaration_View (Corresponding_First_Subtype
551
(Corresponding_Name_Declaration
552
(Definitions.Subtype_Mark (Def))));
558
case Type_Kind (Def) is
559
when An_Enumeration_Type_Definition
560
| A_Signed_Integer_Type_Definition
561
| A_Modular_Type_Definition
562
| A_Floating_Point_Definition
563
| An_Ordinary_Fixed_Point_Definition
564
| A_Decimal_Fixed_Point_Definition
566
Do_Reports ("(T)'RANGE replaceable with (sub)type(T)");
567
when An_Unconstrained_Array_Definition
568
| A_Constrained_Array_Definition
571
when Not_A_Type_Definition =>
572
-- Can be a formal type here
573
case Formal_Type_Kind (Def) is
574
when A_Formal_Discrete_Type_Definition
575
| A_Formal_Signed_Integer_Type_Definition
576
| A_Formal_Modular_Type_Definition
577
| A_Formal_Floating_Point_Definition
578
| A_Formal_Ordinary_Fixed_Point_Definition
579
| A_Formal_Decimal_Fixed_Point_Definition
581
Do_Reports ("(T)'RANGE replaceable with (sub)type(T)");
582
when A_Formal_Unconstrained_Array_Definition
583
| A_Formal_Constrained_Array_Definition
587
Failure ("Unexpected formal type kind: "
588
& Formal_Type_Kinds'Wide_Image(Formal_Type_Kind (Def)), P);
592
Failure ("Unexpected type kind: " & Type_Kinds'Wide_Image(Type_Kind (Def)), P);
595
when A_Variable_Declaration
596
| A_Constant_Declaration
597
| A_Deferred_Constant_Declaration
598
| A_Formal_Object_Declaration
599
| A_Parameter_Specification
600
| A_Component_Declaration
601
| An_Object_Renaming_Declaration
605
Failure ("Unexpected Element_Kind 2: " &
606
Declaration_Kinds'Wide_Image (Declaration_Kind
607
(Corresponding_Name_Declaration
612
when A_Discrete_Subtype_Indication =>
613
-- Nothing simplifiable here
616
when Not_A_Discrete_Range =>
617
Failure ("Not a discrete range");
621
------------------------
622
-- Process_Case_Or_If --
623
------------------------
625
procedure Process_Case_Or_If (Stmt : in Asis.Element) is
626
use Asis, Asis.Elements, Asis.Statements, Utilities, Framework.Reports;
628
Expr : Asis.Expression;
629
Message : constant Wide_String := "Unnecessary parentheses in expression of ""if"" or ""case""";
631
if not Rule_Used then
634
Rules_Manager.Enter (Rule_Id);
636
if Statement_Kind (Stmt) = A_Case_Statement then
637
Expr := Case_Expression (Stmt);
638
elsif Path_Kind (Stmt) in An_If_Path .. An_Elsif_Path then
639
Expr := Condition_Expression (Stmt);
641
Failure ("Not a case or if statement");
644
if Expression_Kind (Expr) = A_Parenthesized_Expression then
645
if Context (Check)(K_Parentheses).Used then
647
To_Wide_String (Context (Check)(K_Parentheses).Label),
651
elsif Context (Search)(K_Parentheses).Used then
653
To_Wide_String (Context (Search)(K_Parentheses).Label),
659
if Context (Count)(K_Parentheses).Used then
661
To_Wide_String (Context (Count)(K_Parentheses).Label),
667
end Process_Case_Or_If;
670
Framework.Rules_Manager.Register (Rule_Id,
672
Add_Use => Add_Use'Access,
673
Command => Command'Access);
674
end Rules.Simplifiable_expressions;
added
removed
src/rules-simplifiable_expressions.adb
