aboutsummaryrefslogtreecommitdiff
path: root/gcc
diff options
context:
space:
mode:
authorArnaud Charlet <charlet@gcc.gnu.org>2014-01-20 16:47:03 +0100
committerArnaud Charlet <charlet@gcc.gnu.org>2014-01-20 16:47:03 +0100
commit061828e3c2ece9a7327081c4f8e0283587175ff7 (patch)
tree20e082023d177655c2761b1671694c8dcac5d825 /gcc
parentff4e28eb7d01f36d8848a328d0ad7cf4b8c1d3c5 (diff)
downloadgcc-061828e3c2ece9a7327081c4f8e0283587175ff7.zip
gcc-061828e3c2ece9a7327081c4f8e0283587175ff7.tar.gz
gcc-061828e3c2ece9a7327081c4f8e0283587175ff7.tar.bz2
[multiple changes]
2014-01-20 Robert Dewar <dewar@adacore.com> * s-tataat.adb: Minor reformatting. 2014-01-20 Robert Dewar <dewar@adacore.com> * einfo.adb (Is_Descendent_Of_Address): Now applies to all entities, and also fix documentation to remove mention of visible integer type, since this is not what the implementation does. * einfo.ads (Is_Descendent_Of_Address): Now applies to all entities, and also fix documentation to remove mention of visible integer type, since this is not what the implementation does. * gnat_rm.texi: Minor clarification of Allow_Integer_Address function. * sem_ch4.adb (Analyze_One_Call): Handle Allow_Integer_Address case for parameter type check. * sem_res.adb (Resolve): Use new function Address_Integer_Convert_OK. * sem_type.adb: Minor code reorganization (use Ekind_In) Minor reformatting throughout. * sem_util.adb (Address_Integer_Convert_OK): New function. * sem_util.ads: Minor reformatting (put specs in alpha order) (Address_Integer_Convert_OK): New function. 2014-01-20 Thomas Quinot <quinot@adacore.com> * exp_ch7.adb (Wrap_Transient_Expression): Insertion extra conditional expression only if Opt.Suppress_Control_Flow_Optimizations is set. From-SVN: r206832
Diffstat (limited to 'gcc')
-rw-r--r--gcc/ada/ChangeLog30
-rw-r--r--gcc/ada/einfo.adb1
-rw-r--r--gcc/ada/einfo.ads9
-rw-r--r--gcc/ada/exp_ch7.adb11
-rw-r--r--gcc/ada/gnat_rm.texi6
-rw-r--r--gcc/ada/s-tataat.adb3
-rw-r--r--gcc/ada/sem_ch4.adb19
-rw-r--r--gcc/ada/sem_res.adb24
-rw-r--r--gcc/ada/sem_type.adb225
-rw-r--r--gcc/ada/sem_util.adb21
-rw-r--r--gcc/ada/sem_util.ads42
11 files changed, 209 insertions, 182 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 99cfe83..93c1d9f 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,33 @@
+2014-01-20 Robert Dewar <dewar@adacore.com>
+
+ * s-tataat.adb: Minor reformatting.
+
+2014-01-20 Robert Dewar <dewar@adacore.com>
+
+ * einfo.adb (Is_Descendent_Of_Address): Now applies to all
+ entities, and also fix documentation to remove mention of visible
+ integer type, since this is not what the implementation does.
+ * einfo.ads (Is_Descendent_Of_Address): Now applies to all
+ entities, and also fix documentation to remove mention of visible
+ integer type, since this is not what the implementation does.
+ * gnat_rm.texi: Minor clarification of Allow_Integer_Address
+ function.
+ * sem_ch4.adb (Analyze_One_Call): Handle Allow_Integer_Address
+ case for parameter type check.
+ * sem_res.adb (Resolve): Use new function
+ Address_Integer_Convert_OK.
+ * sem_type.adb: Minor code reorganization (use Ekind_In) Minor
+ reformatting throughout.
+ * sem_util.adb (Address_Integer_Convert_OK): New function.
+ * sem_util.ads: Minor reformatting (put specs in alpha order)
+ (Address_Integer_Convert_OK): New function.
+
+2014-01-20 Thomas Quinot <quinot@adacore.com>
+
+ * exp_ch7.adb (Wrap_Transient_Expression):
+ Insertion extra conditional expression only if
+ Opt.Suppress_Control_Flow_Optimizations is set.
+
2014-01-20 Arnaud Charlet <charlet@adacore.com>
* s-tataat.adb (Initialize_Attributes): Abort might already be
diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb
index 3ae9786..399afa8 100644
--- a/gcc/ada/einfo.adb
+++ b/gcc/ada/einfo.adb
@@ -1927,7 +1927,6 @@ package body Einfo is
function Is_Descendent_Of_Address (Id : E) return B is
begin
- pragma Assert (Is_Type (Id));
return Flag223 (Id);
end Is_Descendent_Of_Address;
diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads
index 548090e..9f4726c 100644
--- a/gcc/ada/einfo.ads
+++ b/gcc/ada/einfo.ads
@@ -2216,10 +2216,8 @@ package Einfo is
-- types and subtypes.
-- Is_Descendent_Of_Address (Flag223)
--- Defined in all type and subtype entities. Indicates that a type is an
--- address type that is visibly a numeric type. Used for semantic checks
--- on VMS to remove ambiguities in universal integer expressions that may
--- have an address interpretation
+-- Defined in all entities. True if the entity is type System.Address,
+-- or (recursively) a subtype or derived type of System.Address.
-- Is_Discrete_Type (synthesized)
-- Applies to all entities, true for all discrete types and subtypes
@@ -4961,6 +4959,7 @@ package Einfo is
-- Is_Child_Unit (Flag73)
-- Is_Compilation_Unit (Flag149)
-- Is_Completely_Hidden (Flag103)
+ -- Is_Descendent_Of_Address (Flag223)
-- Is_Discrim_SO_Function (Flag176)
-- Is_Dispatch_Table_Entity (Flag234)
-- Is_Dispatching_Operation (Flag6)
@@ -6451,6 +6450,7 @@ package Einfo is
function Is_Constructor (Id : E) return B;
function Is_Controlled (Id : E) return B;
function Is_Controlling_Formal (Id : E) return B;
+ function Is_Descendent_Of_Address (Id : E) return B;
function Is_Discrim_SO_Function (Id : E) return B;
function Is_Dispatch_Table_Entity (Id : E) return B;
function Is_Dispatching_Operation (Id : E) return B;
@@ -6666,7 +6666,6 @@ package Einfo is
function Is_Concurrent_Type (Id : E) return B;
function Is_Decimal_Fixed_Point_Type (Id : E) return B;
function Is_Digits_Type (Id : E) return B;
- function Is_Descendent_Of_Address (Id : E) return B;
function Is_Discrete_Or_Fixed_Point_Type (Id : E) return B;
function Is_Discrete_Type (Id : E) return B;
function Is_Elementary_Type (Id : E) return B;
diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb
index 8a16033..42d499b 100644
--- a/gcc/ada/exp_ch7.adb
+++ b/gcc/ada/exp_ch7.adb
@@ -7982,16 +7982,13 @@ package body Exp_Ch7 is
-- end;
-- A special case is made for Boolean expressions so that the back-end
- -- knows to generate a conditional branch instruction if running with
+ -- knows to generate a conditional branch instruction, if running with
-- -fpreserve-control-flow. This ensures that a control flow change
-- signalling the decision outcome occurs before the cleanup actions.
- -- In the absence of -fpreserve-control-flow, the back-end will
- -- optimize away the extra conditional expression, so we can do this
- -- modification unconditionally here.
- -- Why don't we add a test of Opt.Preserve_Control_Flow here???
-
- if Is_Boolean_Type (Typ) then
+ if Opt.Suppress_Control_Flow_Optimizations
+ and then Is_Boolean_Type (Typ)
+ then
Expr :=
Make_If_Expression (Loc,
Expressions => New_List (
diff --git a/gcc/ada/gnat_rm.texi b/gcc/ada/gnat_rm.texi
index 8b349b4..53286d8 100644
--- a/gcc/ada/gnat_rm.texi
+++ b/gcc/ada/gnat_rm.texi
@@ -1263,6 +1263,12 @@ package AddrAsInt is
end AddrAsInt;
@end smallexample
+@noindent
+Note that these automatic conversions do not apply to expressions used
+as subprogram arguments, because in general overloading can take place,
+so that the required type is not fixed by the context. If necessary
+adjust the type of the subprogram argument, e.g. by adding a conversion.
+
@node Pragma Annotate
@unnumberedsec Pragma Annotate
@findex Annotate
diff --git a/gcc/ada/s-tataat.adb b/gcc/ada/s-tataat.adb
index c785430..e812d14 100644
--- a/gcc/ada/s-tataat.adb
+++ b/gcc/ada/s-tataat.adb
@@ -186,6 +186,9 @@ package body System.Tasking.Task_Attributes is
Self_Id : constant Task_Id := Self;
begin
+ -- Note: we call [Un]Defer_Abort_Nestable, rather than [Un]Defer_Abort,
+ -- because Abort might already be deferred in Create_Task.
+
Defer_Abort_Nestable (Self_Id);
Lock_RTS;
diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb
index 457b581..daf8afe 100644
--- a/gcc/ada/sem_ch4.adb
+++ b/gcc/ada/sem_ch4.adb
@@ -3189,6 +3189,23 @@ package body Sem_Ch4 is
Next_Actual (Actual);
Next_Formal (Formal);
+ -- In Allow_Integer_Address mode, we allow an actual integer to
+ -- match a formal address type and vice versa. We only do this
+ -- if we are certain that an error will otherwise be issued
+
+ elsif Address_Integer_Convert_OK
+ (Etype (Actual), Etype (Formal))
+ and then (Report and not Is_Indexed and not Is_Indirect)
+ then
+ -- Handle this case by introducing an unchecked conversion
+
+ Rewrite (Actual,
+ Unchecked_Convert_To (Etype (Formal),
+ Relocate_Node (Actual)));
+ Analyze_And_Resolve (Actual, Etype (Formal));
+ Next_Actual (Actual);
+ Next_Formal (Formal);
+
else
if Debug_Flag_E then
Write_Str (" type checking fails in call ");
@@ -3200,6 +3217,8 @@ package body Sem_Ch4 is
Write_Eol;
end if;
+ -- Comment needed on the following test???
+
if Report and not Is_Indexed and not Is_Indirect then
-- Ada 2005 (AI-251): Complete the error notification
diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb
index 2dc9291..89fbb75 100644
--- a/gcc/ada/sem_res.adb
+++ b/gcc/ada/sem_res.adb
@@ -2619,17 +2619,10 @@ package body Sem_Res is
-- treated as an Address. The reverse case of integer wanted,
-- Address found, is treated in an analogous manner.
- if Allow_Integer_Address then
- if (Is_RTE (Typ, RE_Address)
- and then Is_Integer_Type (Etype (N)))
- or else
- (Is_Integer_Type (Typ)
- and then Is_RTE (Etype (N), RE_Address))
- then
- Rewrite (N, Unchecked_Convert_To (Typ, Relocate_Node (N)));
- Analyze_And_Resolve (N, Typ);
- return;
- end if;
+ if Address_Integer_Convert_OK (Typ, Etype (N)) then
+ Rewrite (N, Unchecked_Convert_To (Typ, Relocate_Node (N)));
+ Analyze_And_Resolve (N, Typ);
+ return;
end if;
-- That special Allow_Integer_Address check did not appply, so we
@@ -11095,14 +11088,7 @@ package body Sem_Res is
-- Allow_Integer_Address is in effect. We convert the conversion to
-- an unchecked conversion in this case and we are all done!
- if Allow_Integer_Address
- and then
- ((Is_RTE (Target_Type, RE_Address)
- and then Is_Integer_Type (Opnd_Type))
- or else
- (Is_RTE (Opnd_Type, RE_Address)
- and then Is_Integer_Type (Target_Type)))
- then
+ if Address_Integer_Convert_OK (Opnd_Type, Target_Type) then
Rewrite (N, Unchecked_Convert_To (Target_Type, Expression (N)));
Analyze_And_Resolve (N, Target_Type);
return True;
diff --git a/gcc/ada/sem_type.adb b/gcc/ada/sem_type.adb
index 8e0fd5f..b7371b7 100644
--- a/gcc/ada/sem_type.adb
+++ b/gcc/ada/sem_type.adb
@@ -252,10 +252,9 @@ package body Sem_Type is
-- preference rule applies.
if (((Ekind (Name) = E_Function or else Ekind (Name) = E_Procedure)
- and then Ekind (Name) = Ekind (It.Nam))
- or else (Ekind (Name) = E_Operator
- and then Ekind (It.Nam) = E_Function))
-
+ and then Ekind (Name) = Ekind (It.Nam))
+ or else (Ekind (Name) = E_Operator
+ and then Ekind (It.Nam) = E_Function))
and then Is_Immediately_Visible (It.Nam)
and then Type_Conformant (Name, It.Nam)
and then Base_Type (It.Typ) = Base_Type (T)
@@ -269,9 +268,9 @@ package body Sem_Type is
-- predefined operator in any case.
elsif Nkind (N) = N_Operator_Symbol
- or else (Nkind (N) = N_Expanded_Name
- and then
- Nkind (Selector_Name (N)) = N_Operator_Symbol)
+ or else
+ (Nkind (N) = N_Expanded_Name
+ and then Nkind (Selector_Name (N)) = N_Operator_Symbol)
then
exit;
@@ -373,7 +372,7 @@ package body Sem_Type is
or else Is_Potentially_Use_Visible (Vis_Type)
or else In_Use (Vis_Type)
or else (In_Use (Scope (Vis_Type))
- and then not Is_Hidden (Vis_Type))
+ and then not Is_Hidden (Vis_Type))
or else Nkind (N) = N_Expanded_Name
or else (Nkind (N) in N_Op and then E = Entity (N))
or else In_Instance
@@ -390,8 +389,8 @@ package body Sem_Type is
elsif Nkind (N) = N_Function_Call
and then Nkind (Name (N)) = N_Expanded_Name
and then (Entity (Prefix (Name (N))) = Scope (Base_Type (T))
- or else Entity (Prefix (Name (N))) = Scope (Vis_Type)
- or else Scope (Vis_Type) = System_Aux_Id)
+ or else Entity (Prefix (Name (N))) = Scope (Vis_Type)
+ or else Scope (Vis_Type) = System_Aux_Id)
then
null;
@@ -472,7 +471,7 @@ package body Sem_Type is
elsif Interp_Map.Last < 0
or else
(Interp_Map.Table (Interp_Map.Last).Node /= N
- and then not Is_Overloaded (N))
+ and then not Is_Overloaded (N))
then
New_Interps (N);
@@ -601,6 +600,7 @@ package body Sem_Type is
if Scop = Inst then
return True;
end if;
+
Scop := Scope (Scop);
end loop;
@@ -641,9 +641,8 @@ package body Sem_Type is
exit when (not Is_Overloadable (H))
and then Is_Immediately_Visible (H);
- if Is_Immediately_Visible (H)
- and then H /= Ent
- then
+ if Is_Immediately_Visible (H) and then H /= Ent then
+
-- Only add interpretation if not hidden by an inner
-- immediately visible one.
@@ -766,9 +765,9 @@ package body Sem_Type is
Is_Private_Type (Typ1)
and then
((Present (Full_View (Typ1))
- and then Covers (Full_View (Typ1), Typ2))
- or else Base_Type (Typ1) = Typ2
- or else Base_Type (Typ2) = Typ1);
+ and then Covers (Full_View (Typ1), Typ2))
+ or else Base_Type (Typ1) = Typ2
+ or else Base_Type (Typ2) = Typ1);
end Full_View_Covers;
-----------------
@@ -979,7 +978,7 @@ package body Sem_Type is
elsif Is_Class_Wide_Type (T2)
and then
(Class_Wide_Type (T1) = Class_Wide_Type (T2)
- or else Base_Type (Root_Type (T2)) = BT1)
+ or else Base_Type (Root_Type (T2)) = BT1)
then
return True;
@@ -998,9 +997,7 @@ package body Sem_Type is
-- An aggregate is compatible with an array or record type
- elsif T2 = Any_Composite
- and then Is_Aggregate_Type (T1)
- then
+ elsif T2 = Any_Composite and then Is_Aggregate_Type (T1) then
return True;
-- If the expected type is an anonymous access, the designated type must
@@ -1037,12 +1034,9 @@ package body Sem_Type is
and then (not Comes_From_Source (T1)
or else not Comes_From_Source (T2))
and then (Is_Overloadable (Designated_Type (T2))
- or else
- Ekind (Designated_Type (T2)) = E_Subprogram_Type)
- and then
- Type_Conformant (Designated_Type (T1), Designated_Type (T2))
- and then
- Mode_Conformant (Designated_Type (T1), Designated_Type (T2))
+ or else Ekind (Designated_Type (T2)) = E_Subprogram_Type)
+ and then Type_Conformant (Designated_Type (T1), Designated_Type (T2))
+ and then Mode_Conformant (Designated_Type (T1), Designated_Type (T2))
then
return True;
@@ -1058,12 +1052,9 @@ package body Sem_Type is
and then (not Comes_From_Source (T1)
or else not Comes_From_Source (T2))
and then (Is_Overloadable (Designated_Type (T2))
- or else
- Ekind (Designated_Type (T2)) = E_Subprogram_Type)
- and then
- Type_Conformant (Designated_Type (T1), Designated_Type (T2))
- and then
- Mode_Conformant (Designated_Type (T1), Designated_Type (T2))
+ or else Ekind (Designated_Type (T2)) = E_Subprogram_Type)
+ and then Type_Conformant (Designated_Type (T1), Designated_Type (T2))
+ and then Mode_Conformant (Designated_Type (T1), Designated_Type (T2))
then
return True;
@@ -1072,8 +1063,7 @@ package body Sem_Type is
-- vice versa.
elsif Is_Record_Type (T1)
- and then (Is_Remote_Call_Interface (T1)
- or else Is_Remote_Types (T1))
+ and then (Is_Remote_Call_Interface (T1) or else Is_Remote_Types (T1))
and then Present (Corresponding_Remote_Type (T1))
then
return Covers (Corresponding_Remote_Type (T1), T2);
@@ -1081,8 +1071,7 @@ package body Sem_Type is
-- and conversely.
elsif Is_Record_Type (T2)
- and then (Is_Remote_Call_Interface (T2)
- or else Is_Remote_Types (T2))
+ and then (Is_Remote_Call_Interface (T2) or else Is_Remote_Types (T2))
and then Present (Corresponding_Remote_Type (T2))
then
return Covers (Corresponding_Remote_Type (T2), T1);
@@ -1122,20 +1111,16 @@ package body Sem_Type is
-- Ditto for allocators, which eventually resolve to the context type
- elsif Ekind (T2) = E_Allocator_Type
- and then Is_Access_Type (T1)
- then
+ elsif Ekind (T2) = E_Allocator_Type and then Is_Access_Type (T1) then
return Covers (Designated_Type (T1), Designated_Type (T2))
- or else
- (From_Limited_With (Designated_Type (T1))
- and then Covers (Designated_Type (T2), Designated_Type (T1)));
+ or else
+ (From_Limited_With (Designated_Type (T1))
+ and then Covers (Designated_Type (T2), Designated_Type (T1)));
-- A boolean operation on integer literals is compatible with modular
-- context.
- elsif T2 = Any_Modular
- and then Is_Modular_Integer_Type (T1)
- then
+ elsif T2 = Any_Modular and then Is_Modular_Integer_Type (T1) then
return True;
-- The actual type may be the result of a previous error
@@ -1167,9 +1152,7 @@ package body Sem_Type is
-- legal, to prevent cascaded errors.
elsif In_Instance
- and then
- (Full_View_Covers (T1, T2)
- or else Full_View_Covers (T2, T1))
+ and then (Full_View_Covers (T1, T2) or else Full_View_Covers (T2, T1))
then
return True;
@@ -1190,15 +1173,16 @@ package body Sem_Type is
elsif In_Inlined_Body
and then (Underlying_Type (T1) = Underlying_Type (T2)
- or else (Is_Access_Type (T1)
- and then Is_Access_Type (T2)
- and then
- Designated_Type (T1) = Designated_Type (T2))
- or else (T1 = Any_Access
- and then Is_Access_Type (Underlying_Type (T2)))
- or else (T2 = Any_Composite
- and then
- Is_Composite_Type (Underlying_Type (T1))))
+ or else
+ (Is_Access_Type (T1)
+ and then Is_Access_Type (T2)
+ and then Designated_Type (T1) = Designated_Type (T2))
+ or else
+ (T1 = Any_Access
+ and then Is_Access_Type (Underlying_Type (T2)))
+ or else
+ (T2 = Any_Composite
+ and then Is_Composite_Type (Underlying_Type (T1))))
then
return True;
@@ -1364,8 +1348,8 @@ package body Sem_Type is
else
return Is_Entity_Name (Subtype_Indication (Type_Definition (Par)))
and then
- Is_Generic_Actual_Type (
- Entity (Subtype_Indication (Type_Definition (Par))));
+ Is_Generic_Actual_Type (
+ Entity (Subtype_Indication (Type_Definition (Par))));
end if;
end Inherited_From_Actual;
@@ -1383,10 +1367,10 @@ package body Sem_Type is
return In_Same_List (Parent (Typ), Op_Decl)
or else
(Ekind_In (Scop, E_Package, E_Generic_Package)
- and then List_Containing (Op_Decl) =
- Visible_Declarations (Parent (Scop))
- and then List_Containing (Parent (Typ)) =
- Private_Declarations (Parent (Scop)));
+ and then List_Containing (Op_Decl) =
+ Visible_Declarations (Parent (Scop))
+ and then List_Containing (Parent (Typ)) =
+ Private_Declarations (Parent (Scop)));
end In_Same_Declaration_List;
--------------------------
@@ -1765,8 +1749,7 @@ package body Sem_Type is
begin
Get_First_Interp (N, I, It);
while Present (It.Typ) loop
- if (Covers (Typ, It.Typ)
- or else Typ = Any_Type)
+ if (Covers (Typ, It.Typ) or else Typ = Any_Type)
and then
(It.Typ = Universal_Integer
or else It.Typ = Universal_Real)
@@ -1917,9 +1900,7 @@ package body Sem_Type is
-- handled here as well. We test Comes_From_Source to exclude this
-- treatment for implicit renamings created for formal subprograms.
- elsif In_Instance
- and then not In_Generic_Actual (N)
- then
+ elsif In_Instance and then not In_Generic_Actual (N) then
if Nkind (N) in N_Subprogram_Call
or else
(Nkind (N) in N_Has_Entity
@@ -2053,7 +2034,7 @@ package body Sem_Type is
else
if (In_Open_Scopes (Scope (User_Subp))
- or else Is_Potentially_Use_Visible (User_Subp))
+ or else Is_Potentially_Use_Visible (User_Subp))
and then not In_Instance
then
if Is_Fixed_Point_Type (Typ)
@@ -2149,14 +2130,10 @@ package body Sem_Type is
then
return Type_Conformant (New_S, Old_S);
- elsif Ekind (New_S) = E_Function
- and then Ekind (Old_S) = E_Operator
- then
+ elsif Ekind (New_S) = E_Function and then Ekind (Old_S) = E_Operator then
return Operator_Matches_Spec (Old_S, New_S);
- elsif Ekind (New_S) = E_Procedure
- and then Is_Entry (Old_S)
- then
+ elsif Ekind (New_S) = E_Procedure and then Is_Entry (Old_S) then
return Type_Conformant (New_S, Old_S);
else
@@ -2184,7 +2161,6 @@ package body Sem_Type is
-- apply preference rule.
if TR /= Any_Type then
-
if (T = Universal_Integer or else T = Universal_Real)
and then It.Typ = T
then
@@ -2230,19 +2206,16 @@ package body Sem_Type is
-- is no rule in 4.6 that allows "access Integer" to be converted to P.
elsif Ada_Version >= Ada_2005
- and then
- (Ekind (Etype (L)) = E_Anonymous_Access_Type
- or else
- Ekind (Etype (L)) = E_Anonymous_Access_Subprogram_Type)
+ and then Ekind_In (Etype (L), E_Anonymous_Access_Type,
+ E_Anonymous_Access_Subprogram_Type)
and then Is_Access_Type (Etype (R))
and then Ekind (Etype (R)) /= E_Access_Type
then
return Etype (L);
elsif Ada_Version >= Ada_2005
- and then
- (Ekind (Etype (R)) = E_Anonymous_Access_Type
- or else Ekind (Etype (R)) = E_Anonymous_Access_Subprogram_Type)
+ and then Ekind_In (Etype (R), E_Anonymous_Access_Type,
+ E_Anonymous_Access_Subprogram_Type)
and then Is_Access_Type (Etype (L))
and then Ekind (Etype (L)) /= E_Access_Type
then
@@ -2273,9 +2246,7 @@ package body Sem_Type is
if Is_Overloaded (N) and then Is_Overloadable (E) then
Act_Parm := First_Actual (N);
Form_Parm := First_Formal (E);
- while Present (Act_Parm)
- and then Present (Form_Parm)
- loop
+ while Present (Act_Parm) and then Present (Form_Parm) loop
Act := Act_Parm;
if Nkind (Act) = N_Parameter_Association then
@@ -2379,20 +2350,22 @@ package body Sem_Type is
or else
(Is_Record_Type (Typ)
- and then Is_Concurrent_Type (Etype (N))
- and then Present (Corresponding_Record_Type (Etype (N)))
- and then Covers (Typ, Corresponding_Record_Type (Etype (N))))
+ and then Is_Concurrent_Type (Etype (N))
+ and then Present (Corresponding_Record_Type (Etype (N)))
+ and then Covers (Typ, Corresponding_Record_Type (Etype (N))))
or else
(Is_Concurrent_Type (Typ)
- and then Is_Record_Type (Etype (N))
- and then Present (Corresponding_Record_Type (Typ))
- and then Covers (Corresponding_Record_Type (Typ), Etype (N)))
+ and then Is_Record_Type (Etype (N))
+ and then Present (Corresponding_Record_Type (Typ))
+ and then Covers (Corresponding_Record_Type (Typ), Etype (N)))
or else
(not Is_Tagged_Type (Typ)
- and then Ekind (Typ) /= E_Anonymous_Access_Type
- and then Covers (Etype (N), Typ));
+ and then Ekind (Typ) /= E_Anonymous_Access_Type
+ and then Covers (Etype (N), Typ));
+
+ -- Overloaded case
else
Get_First_Interp (N, I, It);
@@ -2474,10 +2447,10 @@ package body Sem_Type is
begin
return Operator_Matches_Spec (Op, F)
and then (In_Open_Scopes (Scope (F))
- or else Scope (F) = Scope (Btyp)
- or else (not In_Open_Scopes (Scope (Btyp))
- and then not In_Use (Btyp)
- and then not In_Use (Scope (Btyp))));
+ or else Scope (F) = Scope (Btyp)
+ or else (not In_Open_Scopes (Scope (Btyp))
+ and then not In_Use (Btyp)
+ and then not In_Use (Scope (Btyp))));
end Hides_Op;
------------------------
@@ -2621,7 +2594,7 @@ package body Sem_Type is
return True;
elsif Present (Interfaces (Etype (AI)))
- and then Iface_Present_In_Ancestor (Etype (AI))
+ and then Iface_Present_In_Ancestor (Etype (AI))
then
return True;
end if;
@@ -2727,11 +2700,10 @@ package body Sem_Type is
-- Ada 2005 (AI-251): Complete the error notification
elsif Is_Class_Wide_Type (Etype (R))
- and then Is_Interface (Etype (Class_Wide_Type (Etype (R))))
+ and then Is_Interface (Etype (Class_Wide_Type (Etype (R))))
then
Error_Msg_NE ("(Ada 2005) does not implement interface }",
L, Etype (Class_Wide_Type (Etype (R))));
-
else
Error_Msg_N ("incompatible types", Parent (L));
end if;
@@ -2843,8 +2815,8 @@ package body Sem_Type is
elsif BT1 = Base_Type (Par)
or else (Is_Private_Type (T1)
- and then Present (Full_View (T1))
- and then Base_Type (Par) = Base_Type (Full_View (T1)))
+ and then Present (Full_View (T1))
+ and then Base_Type (Par) = Base_Type (Full_View (T1)))
then
return True;
@@ -3162,10 +3134,10 @@ package body Sem_Type is
return Is_Array_Type (T)
and then (Base_Type (T) = Base_Type (Etype (Op)))
and then (Base_Type (T1) = Base_Type (T)
- or else
+ or else
Base_Type (T1) = Base_Type (Component_Type (T)))
and then (Base_Type (T2) = Base_Type (T)
- or else
+ or else
Base_Type (T2) = Base_Type (Component_Type (T)));
else
@@ -3314,14 +3286,10 @@ package body Sem_Type is
then
return T1;
- elsif T2 = Any_Composite
- and then Is_Aggregate_Type (T1)
- then
+ elsif T2 = Any_Composite and then Is_Aggregate_Type (T1) then
return T1;
- elsif T1 = Any_Composite
- and then Is_Aggregate_Type (T2)
- then
+ elsif T1 = Any_Composite and then Is_Aggregate_Type (T2) then
return T2;
elsif T1 = Any_Modular and then Is_Modular_Integer_Type (T2) then
@@ -3349,7 +3317,7 @@ package body Sem_Type is
elsif Is_Class_Wide_Type (T2)
and then Is_Interface (Etype (T2))
- and then Interface_Present_In_Ancestor (Typ => T1,
+ and then Interface_Present_In_Ancestor (Typ => T1,
Iface => Etype (T2))
then
return T1;
@@ -3364,32 +3332,30 @@ package body Sem_Type is
then
return T2;
- elsif (Ekind (B1) = E_Access_Subprogram_Type
- or else
- Ekind (B1) = E_Access_Protected_Subprogram_Type)
+ elsif Ekind_In (B1, E_Access_Subprogram_Type,
+ E_Access_Protected_Subprogram_Type)
and then Ekind (Designated_Type (B1)) /= E_Subprogram_Type
and then Is_Access_Type (T2)
then
return T2;
- elsif (Ekind (B2) = E_Access_Subprogram_Type
- or else
- Ekind (B2) = E_Access_Protected_Subprogram_Type)
+ elsif Ekind_In (B2, E_Access_Subprogram_Type,
+ E_Access_Protected_Subprogram_Type)
and then Ekind (Designated_Type (B2)) /= E_Subprogram_Type
and then Is_Access_Type (T1)
then
return T1;
- elsif (Ekind (T1) = E_Allocator_Type
- or else Ekind (T1) = E_Access_Attribute_Type
- or else Ekind (T1) = E_Anonymous_Access_Type)
+ elsif Ekind_In (T1, E_Allocator_Type,
+ E_Access_Attribute_Type,
+ E_Anonymous_Access_Type)
and then Is_Access_Type (T2)
then
return T2;
- elsif (Ekind (T2) = E_Allocator_Type
- or else Ekind (T2) = E_Access_Attribute_Type
- or else Ekind (T2) = E_Anonymous_Access_Type)
+ elsif Ekind_In (T2, E_Allocator_Type,
+ E_Access_Attribute_Type,
+ E_Anonymous_Access_Type)
and then Is_Access_Type (T1)
then
return T1;
@@ -3435,8 +3401,7 @@ package body Sem_Type is
and then Number_Dimensions (T) = 1
and then Is_Boolean_Type (Component_Type (T))
and then
- ((not Is_Private_Composite (T)
- and then not Is_Limited_Composite (T))
+ ((not Is_Private_Composite (T) and then not Is_Limited_Composite (T))
or else In_Instance
or else Available_Full_View_Of_Component (T))
then
@@ -3465,10 +3430,8 @@ package body Sem_Type is
elsif Is_Array_Type (T)
and then Number_Dimensions (T) = 1
and then Is_Discrete_Type (Component_Type (T))
- and then (not Is_Private_Composite (T)
- or else In_Instance)
- and then (not Is_Limited_Composite (T)
- or else In_Instance)
+ and then (not Is_Private_Composite (T) or else In_Instance)
+ and then (not Is_Limited_Composite (T) or else In_Instance)
then
return True;
diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
index e646854..7664e60 100644
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -361,6 +361,27 @@ package body Sem_Util is
Analyze (N);
end Add_Global_Declaration;
+ --------------------------------
+ -- Address_Integer_Convert_OK --
+ --------------------------------
+
+ function Address_Integer_Convert_OK (T1, T2 : Entity_Id) return Boolean is
+ begin
+ if Allow_Integer_Address
+ and then ((Is_Descendent_Of_Address (T1)
+ and then Is_Private_Type (T1)
+ and then Is_Integer_Type (T2))
+ or else
+ (Is_Descendent_Of_Address (T2)
+ and then Is_Private_Type (T2)
+ and then Is_Integer_Type (T1)))
+ then
+ return True;
+ else
+ return False;
+ end if;
+ end Address_Integer_Convert_OK;
+
-----------------
-- Addressable --
-----------------
diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads
index 8b95413..4c6dde9 100644
--- a/gcc/ada/sem_util.ads
+++ b/gcc/ada/sem_util.ads
@@ -67,6 +67,11 @@ package Sem_Util is
-- for the current unit. The declarations are added in the current scope,
-- so the caller should push a new scope as required before the call.
+ function Address_Integer_Convert_OK (T1, T2 : Entity_Id) return Boolean;
+ -- Given two types, returns True if we are in Allow_Integer_Address mode
+ -- and one of the types is (a descendent of) System.Address (and this type
+ -- is private), and the other type is any integer type.
+
function Addressable (V : Uint) return Boolean;
function Addressable (V : Int) return Boolean;
pragma Inline (Addressable);
@@ -398,12 +403,12 @@ package Sem_Util is
-- * Array-of-scalars with specified Default_Component_Value
-- * Array type with fully default initialized component type
-- * Record or protected type with components that either have a
- -- default expression or their related types are fully default
- -- initialized.
+ -- default expression or their related types are fully default
+ -- initialized.
-- * Scalar type with specified Default_Value
-- * Task type
-- * Type extension of a type with full default initialization where
- -- the extension components are also fully default initialized
+ -- the extension components are also fully default initialized.
Mixed_Initialization,
-- This value applies to a type where some of its internals are fully
@@ -415,8 +420,7 @@ package Sem_Util is
function Default_Initialization
(Typ : Entity_Id) return Default_Initialization_Kind;
- -- Determine the default initialization kind that applies to a particular
- -- type.
+ -- Determine default initialization kind that applies to a particular type
function Deepest_Type_Access_Level (Typ : Entity_Id) return Uint;
-- Same as Type_Access_Level, except that if the type is the type of an Ada
@@ -973,6 +977,20 @@ package Sem_Util is
function Is_CPP_Constructor_Call (N : Node_Id) return Boolean;
-- Returns True if N is a call to a CPP constructor
+ function Is_Child_Or_Sibling
+ (Pack_1 : Entity_Id;
+ Pack_2 : Entity_Id;
+ Private_Child : Boolean) return Boolean;
+ -- Determine the following relations between two arbitrary packages:
+ -- 1) One package is the parent of a child package
+ -- 2) Both packages are siblings and share a common parent
+ -- If flag Private_Child is set, then the child in case 1) or both siblings
+ -- in case 2) must be private.
+
+ function Is_Concurrent_Interface (T : Entity_Id) return Boolean;
+ -- First determine whether type T is an interface and then check whether
+ -- it is of protected, synchronized or task kind.
+
function Is_Dependent_Component_Of_Mutable_Object
(Object : Node_Id) return Boolean;
-- Returns True if Object is the name of a subcomponent that depends on
@@ -991,20 +1009,6 @@ package Sem_Util is
-- This is the RM definition, a type is a descendent of another type if it
-- is the same type or is derived from a descendent of the other type.
- function Is_Child_Or_Sibling
- (Pack_1 : Entity_Id;
- Pack_2 : Entity_Id;
- Private_Child : Boolean) return Boolean;
- -- Determine the following relations between two arbitrary packages:
- -- 1) One package is the parent of a child package
- -- 2) Both packages are siblings and share a common parent
- -- If flag Private_Child is set, then the child in case 1) or both siblings
- -- in case 2) must be private.
-
- function Is_Concurrent_Interface (T : Entity_Id) return Boolean;
- -- First determine whether type T is an interface and then check whether
- -- it is of protected, synchronized or task kind.
-
function Is_Expression_Function (Subp : Entity_Id) return Boolean;
-- Predicate to determine whether a scope entity comes from a rewritten
-- expression function call, and should be inlined unconditionally. Also