This patch corrects removes some code duplication within the GNAT
compiler.
Tested on x86_64-pc-linux-gnu, committed on trunk
gcc/ada/
* exp_util.adb (Remove_Side_Effects): Combine identical
branches.
* sem_attr.adb (Analyze_Attribute): Combine identical cases
Attribute_Has_Same_Storage and Attribute_Overlaps_Storage.
* sem_prag.adb (Check_Role): Combine E_Out_Parameter case with
general case for parameters.
* sem_util.adb (Accessibility_Level): Combine identical
branches.
* sprint.adb (Sprint_Node_Actual): Combine cases for
N_Real_Range_Specification and N_Signed_Integer_Type_Definition.diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb
--- a/gcc/ada/exp_util.adb
+++ b/gcc/ada/exp_util.adb
@@ -12017,31 +12017,23 @@ package body Exp_Util is
-- renaming is handled by the front end, as the back end may balk at
-- the nonstandard representation (see Evaluation_Required in Exp_Ch8).
- elsif Nkind (Exp) in N_Indexed_Component | N_Selected_Component
- and then Has_Non_Standard_Rep (Etype (Prefix (Exp)))
- then
- Def_Id := Build_Temporary (Loc, 'R', Exp);
- Res := New_Occurrence_Of (Def_Id, Loc);
-
- Insert_Action (Exp,
- Make_Object_Renaming_Declaration (Loc,
- Defining_Identifier => Def_Id,
- Subtype_Mark => New_Occurrence_Of (Exp_Type, Loc),
- Name => Relocate_Node (Exp)));
+ elsif (Nkind (Exp) in N_Indexed_Component | N_Selected_Component
+ and then Has_Non_Standard_Rep (Etype (Prefix (Exp))))
- -- For an expression that denotes a name, we can use a renaming scheme.
- -- This is needed for correctness in the case of a volatile object of
- -- a nonvolatile type because the Make_Reference call of the "default"
- -- approach would generate an illegal access value (an access value
- -- cannot designate such an object - see Analyze_Reference).
+ -- For an expression that denotes a name, we can use a renaming
+ -- scheme. This is needed for correctness in the case of a volatile
+ -- object of a nonvolatile type because the Make_Reference call of the
+ -- "default" approach would generate an illegal access value (an
+ -- access value cannot designate such an object - see
+ -- Analyze_Reference).
- elsif Is_Name_Reference (Exp)
+ or else (Is_Name_Reference (Exp)
- -- We skip using this scheme if we have an object of a volatile
- -- type and we do not have Name_Req set true (see comments for
- -- Side_Effect_Free).
+ -- We skip using this scheme if we have an object of a volatile
+ -- type and we do not have Name_Req set true (see comments for
+ -- Side_Effect_Free).
- and then (Name_Req or else not Treat_As_Volatile (Exp_Type))
+ and then (Name_Req or else not Treat_As_Volatile (Exp_Type)))
then
Def_Id := Build_Temporary (Loc, 'R', Exp);
Res := New_Occurrence_Of (Def_Id, Loc);
diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb
--- a/gcc/ada/sem_attr.adb
+++ b/gcc/ada/sem_attr.adb
@@ -4451,7 +4451,9 @@ package body Sem_Attr is
-- Has_Same_Storage --
----------------------
- when Attribute_Has_Same_Storage =>
+ when Attribute_Has_Same_Storage
+ | Attribute_Overlaps_Storage
+ =>
Check_E1;
-- The arguments must be objects of any type
@@ -5563,21 +5565,6 @@ package body Sem_Attr is
end if;
end Old;
- ----------------------
- -- Overlaps_Storage --
- ----------------------
-
- when Attribute_Overlaps_Storage =>
- Check_E1;
-
- -- Both arguments must be objects of any type
-
- Analyze_And_Resolve (P);
- Analyze_And_Resolve (E1);
- Check_Object_Reference (P);
- Check_Object_Reference (E1);
- Set_Etype (N, Standard_Boolean);
-
------------
-- Output --
------------
diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb
--- a/gcc/ada/sem_prag.adb
+++ b/gcc/ada/sem_prag.adb
@@ -1361,36 +1361,15 @@ package body Sem_Prag is
when E_Generic_In_Out_Parameter
| E_In_Out_Parameter
+ | E_Out_Parameter
| E_Variable
=>
- -- When pragma Global is present it determines the mode of
- -- the object.
-
- if Global_Seen then
-
- -- A variable has mode IN when its type is unconstrained
- -- or tagged because array bounds, discriminants or tags
- -- can be read.
-
- Item_Is_Input :=
- Appears_In (Subp_Inputs, Item_Id)
- or else Is_Unconstrained_Or_Tagged_Item (Item_Id);
-
- Item_Is_Output := Appears_In (Subp_Outputs, Item_Id);
-
- -- Otherwise the variable has a default IN OUT mode
-
- else
- Item_Is_Input := True;
- Item_Is_Output := True;
- end if;
-
- when E_Out_Parameter =>
-
-- An OUT parameter of the related subprogram; it cannot
-- appear in Global.
- if Scope (Item_Id) = Spec_Id then
+ if Adjusted_Kind = E_Out_Parameter
+ and then Scope (Item_Id) = Spec_Id
+ then
-- The parameter has mode IN if its type is unconstrained
-- or tagged because array bounds, discriminants or tags
@@ -1401,8 +1380,8 @@ package body Sem_Prag is
Item_Is_Output := True;
- -- An OUT parameter of an enclosing subprogram; it can
- -- appear in Global and behaves as a read-write variable.
+ -- A parameter of an enclosing subprogram; it can appear
+ -- in Global and behaves as a read-write variable.
else
-- When pragma Global is present it determines the mode
@@ -1411,8 +1390,8 @@ package body Sem_Prag is
if Global_Seen then
-- A variable has mode IN when its type is
- -- unconstrained or tagged because array
- -- bounds, discriminants or tags can be read.
+ -- unconstrained or tagged because array bounds,
+ -- discriminants, or tags can be read.
Item_Is_Input :=
Appears_In (Subp_Inputs, Item_Id)
diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -798,44 +798,30 @@ package body Sem_Util is
-- in effect we treat discriminant components as regular
-- components.
- elsif Nkind (E) = N_Selected_Component
- and then Ekind (Etype (E)) = E_Anonymous_Access_Type
- and then Ekind (Etype (Pre)) /= E_Anonymous_Access_Type
- and then (not (Nkind (Selector_Name (E)) in N_Has_Entity
- and then Ekind (Entity (Selector_Name (E)))
- = E_Discriminant)
-
- -- The alternative accessibility models both treat
- -- discriminants as regular components.
-
- or else (No_Dynamic_Accessibility_Checks_Enabled (E)
- and then Allow_Alt_Model))
- then
- -- When restriction No_Dynamic_Accessibility_Checks is active
- -- and -gnatd_b set, the level is that of the designated type.
-
- if Allow_Alt_Model
- and then No_Dynamic_Accessibility_Checks_Enabled (E)
- and then Debug_Flag_Underscore_B
- then
- return Make_Level_Literal
- (Typ_Access_Level (Etype (E)));
- end if;
+ elsif
+ (Nkind (E) = N_Selected_Component
+ and then Ekind (Etype (E)) = E_Anonymous_Access_Type
+ and then Ekind (Etype (Pre)) /= E_Anonymous_Access_Type
+ and then (not (Nkind (Selector_Name (E)) in N_Has_Entity
+ and then Ekind (Entity (Selector_Name (E)))
+ = E_Discriminant)
- -- Otherwise proceed normally
+ -- The alternative accessibility models both treat
+ -- discriminants as regular components.
- return Make_Level_Literal
- (Typ_Access_Level (Etype (Prefix (E))));
+ or else (No_Dynamic_Accessibility_Checks_Enabled (E)
+ and then Allow_Alt_Model)))
- -- Similar to the previous case - arrays featuring components of
- -- anonymous access components get their corresponding level from
- -- their containing type's declaration.
+ -- Arrays featuring components of anonymous access components
+ -- get their corresponding level from their containing type's
+ -- declaration.
- elsif Nkind (E) = N_Indexed_Component
- and then Ekind (Etype (E)) = E_Anonymous_Access_Type
- and then Ekind (Etype (Pre)) in Array_Kind
- and then Ekind (Component_Type (Base_Type (Etype (Pre))))
- = E_Anonymous_Access_Type
+ or else
+ (Nkind (E) = N_Indexed_Component
+ and then Ekind (Etype (E)) = E_Anonymous_Access_Type
+ and then Ekind (Etype (Pre)) in Array_Kind
+ and then Ekind (Component_Type (Base_Type (Etype (Pre))))
+ = E_Anonymous_Access_Type)
then
-- When restriction No_Dynamic_Accessibility_Checks is active
-- and -gnatd_b set, the level is that of the designated type.
diff --git a/gcc/ada/sprint.adb b/gcc/ada/sprint.adb
--- a/gcc/ada/sprint.adb
+++ b/gcc/ada/sprint.adb
@@ -3132,7 +3132,9 @@ package body Sprint is
when N_Real_Literal =>
Write_Ureal_With_Col_Check_Sloc (Realval (Node));
- when N_Real_Range_Specification =>
+ when N_Real_Range_Specification
+ | N_Signed_Integer_Type_Definition
+ =>
Write_Str_With_Col_Check_Sloc ("range ");
Sprint_Node (Low_Bound (Node));
Write_Str (" .. ");
@@ -3248,12 +3250,6 @@ package body Sprint is
Write_Indent_Str ("end select;");
- when N_Signed_Integer_Type_Definition =>
- Write_Str_With_Col_Check_Sloc ("range ");
- Sprint_Node (Low_Bound (Node));
- Write_Str (" .. ");
- Sprint_Node (High_Bound (Node));
-
when N_Single_Protected_Declaration =>
Write_Indent_Str_Sloc ("protected ");
Write_Id (Defining_Identifier (Node));
