diff options
author | Arnaud Charlet <charlet@gcc.gnu.org> | 2014-01-20 16:47:03 +0100 |
---|---|---|
committer | Arnaud Charlet <charlet@gcc.gnu.org> | 2014-01-20 16:47:03 +0100 |
commit | 061828e3c2ece9a7327081c4f8e0283587175ff7 (patch) | |
tree | 20e082023d177655c2761b1671694c8dcac5d825 /gcc | |
parent | ff4e28eb7d01f36d8848a328d0ad7cf4b8c1d3c5 (diff) | |
download | gcc-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/ChangeLog | 30 | ||||
-rw-r--r-- | gcc/ada/einfo.adb | 1 | ||||
-rw-r--r-- | gcc/ada/einfo.ads | 9 | ||||
-rw-r--r-- | gcc/ada/exp_ch7.adb | 11 | ||||
-rw-r--r-- | gcc/ada/gnat_rm.texi | 6 | ||||
-rw-r--r-- | gcc/ada/s-tataat.adb | 3 | ||||
-rw-r--r-- | gcc/ada/sem_ch4.adb | 19 | ||||
-rw-r--r-- | gcc/ada/sem_res.adb | 24 | ||||
-rw-r--r-- | gcc/ada/sem_type.adb | 225 | ||||
-rw-r--r-- | gcc/ada/sem_util.adb | 21 | ||||
-rw-r--r-- | gcc/ada/sem_util.ads | 42 |
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 |