diff options
| author | Arnaud Charlet <charlet@gcc.gnu.org> | 2017-09-07 12:09:17 +0200 |
|---|---|---|
| committer | Arnaud Charlet <charlet@gcc.gnu.org> | 2017-09-07 12:09:17 +0200 |
| commit | ed323421344929d7b6104566d8301ce4f88fd00c (patch) | |
| tree | 0f38ba31444dfb438c849f40a21b0eeeaab079ff | |
| parent | c8e072dafbfc0b07d56d457c5b92d3ac77fb4cfe (diff) | |
| download | gcc-ed323421344929d7b6104566d8301ce4f88fd00c.tar.gz | |
[multiple changes]
2017-09-07 Yannick Moy <moy@adacore.com>
* a-exetim-mingw.ads: Add contract Global=>null
on all operations that are modeled as having no read or write
of global variables in SPARK.
2017-09-07 Raphael Amiard <amiard@adacore.com>
* a-chtgop.adb, a-chtgop.ads (Generic_Iteration_With_Position): Added
to Hmaps.Generic_Ops.
* a-cohama.adb (Ada.Containers.Hmaps.Iterate): Pass proper position in
cursors.
* a-cihama.adb (Ada.Containers.Indefinite_Hmaps.Iterate): Pass pos in
cursors.
* a-cohase.adb (Ada.Containers.Hashed_Sets.Iterate): Pass proper
position in cursors.
2017-09-07 Javier Miranda <miranda@adacore.com>
* sem_elab.adb (Check_Task_Activation): Adding switch -gnatd.y to
allow disabling the generation of implicit pragma Elaborate_All
on task bodies.
2017-09-07 Javier Miranda <miranda@adacore.com>
* exp_disp.adb (Make_Tags): Avoid suffix counter
in the external name of the elaboration flag. Required to fix
the regressions introduced by the initial version of this patch.
2017-09-07 Bob Duff <duff@adacore.com>
* sem_ch6.adb (Analyze_Function_Return): Do not
insert an explicit conversion to force the displacement of the
"this" pointer to reference the secondary dispatch table in the
case where the return statement is returning a raise expression,
as in "return raise ...".
2017-09-07 Arnaud Charlet <charlet@adacore.com>
* sem_disp.adb (Is_User_Defined_Equality): Removed procedure.
* sem_util.ads, sem_util.adb (Is_User_Defined_Equality): Copied
procedure from sem_disp.adb.
* sem_ch12.ads (Get_Unit_Instantiation_Node): rename Package
with Unit.
* sem_ch12.adb (Get_Unit_Instantiation_Node): function extended to
return the instantiation node for subprograms. Update references
to Get_Unit_Instantiation_Node.
* sem_ch7.adb (Install_Parent_Private_Declarations): update
reference to Get_Unit_Instantiation_Node.
* exp_dist.adb (Build_Package_Stubs): update reference to
Get_Unit_Instantiation_Node.
* sem_ch9.adb: minor typo in comment.
* lib-xref-spark_specific.adb
(Traverse_Declaration_Or_Statement): traverse into task type
definition.
2017-09-07 Ed Schonberg <schonberg@adacore.com>
* sem_dim.adb (Analyze_Dimension_Type_Conversion): New procedure
to handle properly various cases of type conversions where the
target type and/or the expression carry dimension information.
(Dimension_System_Root); If a subtype carries dimension
information, obtain the source parent type that carries the
Dimension aspect.
2017-09-07 Dmitriy Anisimkov <anisimko@adacore.com>
* g-socket.adb, g-socket.ads (GNAT.Sockets.To_Ada): New routine.
2017-09-07 Ed Schonberg <schonberg@adacore.com>
* exp_attr.adb (Expand_N_Attribute_Reference, case 'Constrained):
If the prefix is a reference to an object, rewrite it as an
explicit dereference, as required by 3.7.2 (2) and as is done
with most other attributes whose prefix is an access value.
2017-09-07 Bob Duff <duff@adacore.com>
* par-ch13.adb: Set the Inside_Depends flag if we are inside a
Refined_Depends aspect.
* par-ch2.adb: Set the Inside_Depends flag if we are inside a
Refined_Depends pragma.
* scans.ads: Fix documentation of Inside_Depends flag.
* styleg.adb, styleg.ads: Minor reformatting and comment fixes.
2017-09-07 Hristian Kirtchev <kirtchev@adacore.com>
* exp_ch7.adb (Insert_Actions_In_Scope_Around):
Account for the case where the are no lists to insert, but the
secondary stack still requires management.
* a-chtgop.adb, a-cihama.adb, a-cohama.adb, a-cohase.adb, a-tags.adb,
comperr.adb, einfo.adb, exp_aggr.adb, exp_ch3.adb, exp_disp.adb,
lib-xref.adb, lib-xref-spark_specific.adb, sem_ch12.adb, sem_ch13.adb,
sem_ch6.adb, sem_dim.adb, sem_dim.ads, sem_elab.adb, sem_prag.adb:
Minor reformatting.
From-SVN: r251842
40 files changed, 418 insertions, 169 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index d46957c41f3..eb6fe7ad554 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,99 @@ +2017-09-07 Yannick Moy <moy@adacore.com> + + * a-exetim-mingw.ads: Add contract Global=>null + on all operations that are modeled as having no read or write + of global variables in SPARK. + +2017-09-07 Raphael Amiard <amiard@adacore.com> + + * a-chtgop.adb, a-chtgop.ads (Generic_Iteration_With_Position): Added + to Hmaps.Generic_Ops. + * a-cohama.adb (Ada.Containers.Hmaps.Iterate): Pass proper position in + cursors. + * a-cihama.adb (Ada.Containers.Indefinite_Hmaps.Iterate): Pass pos in + cursors. + * a-cohase.adb (Ada.Containers.Hashed_Sets.Iterate): Pass proper + position in cursors. + +2017-09-07 Javier Miranda <miranda@adacore.com> + + * sem_elab.adb (Check_Task_Activation): Adding switch -gnatd.y to + allow disabling the generation of implicit pragma Elaborate_All + on task bodies. + +2017-09-07 Javier Miranda <miranda@adacore.com> + + * exp_disp.adb (Make_Tags): Avoid suffix counter + in the external name of the elaboration flag. Required to fix + the regressions introduced by the initial version of this patch. + +2017-09-07 Bob Duff <duff@adacore.com> + + * sem_ch6.adb (Analyze_Function_Return): Do not + insert an explicit conversion to force the displacement of the + "this" pointer to reference the secondary dispatch table in the + case where the return statement is returning a raise expression, + as in "return raise ...". + +2017-09-07 Arnaud Charlet <charlet@adacore.com> + + * sem_disp.adb (Is_User_Defined_Equality): Removed procedure. + * sem_util.ads, sem_util.adb (Is_User_Defined_Equality): Copied + procedure from sem_disp.adb. + * sem_ch12.ads (Get_Unit_Instantiation_Node): rename Package + with Unit. + * sem_ch12.adb (Get_Unit_Instantiation_Node): function extended to + return the instantiation node for subprograms. Update references + to Get_Unit_Instantiation_Node. + * sem_ch7.adb (Install_Parent_Private_Declarations): update + reference to Get_Unit_Instantiation_Node. + * exp_dist.adb (Build_Package_Stubs): update reference to + Get_Unit_Instantiation_Node. + * sem_ch9.adb: minor typo in comment. + * lib-xref-spark_specific.adb + (Traverse_Declaration_Or_Statement): traverse into task type + definition. + +2017-09-07 Ed Schonberg <schonberg@adacore.com> + + * sem_dim.adb (Analyze_Dimension_Type_Conversion): New procedure + to handle properly various cases of type conversions where the + target type and/or the expression carry dimension information. + (Dimension_System_Root); If a subtype carries dimension + information, obtain the source parent type that carries the + Dimension aspect. + +2017-09-07 Dmitriy Anisimkov <anisimko@adacore.com> + + * g-socket.adb, g-socket.ads (GNAT.Sockets.To_Ada): New routine. + +2017-09-07 Ed Schonberg <schonberg@adacore.com> + + * exp_attr.adb (Expand_N_Attribute_Reference, case 'Constrained): + If the prefix is a reference to an object, rewrite it as an + explicit dereference, as required by 3.7.2 (2) and as is done + with most other attributes whose prefix is an access value. + +2017-09-07 Bob Duff <duff@adacore.com> + + * par-ch13.adb: Set the Inside_Depends flag if we are inside a + Refined_Depends aspect. + * par-ch2.adb: Set the Inside_Depends flag if we are inside a + Refined_Depends pragma. + * scans.ads: Fix documentation of Inside_Depends flag. + * styleg.adb, styleg.ads: Minor reformatting and comment fixes. + +2017-09-07 Hristian Kirtchev <kirtchev@adacore.com> + + * exp_ch7.adb (Insert_Actions_In_Scope_Around): + Account for the case where the are no lists to insert, but the + secondary stack still requires management. + * a-chtgop.adb, a-cihama.adb, a-cohama.adb, a-cohase.adb, a-tags.adb, + comperr.adb, einfo.adb, exp_aggr.adb, exp_ch3.adb, exp_disp.adb, + lib-xref.adb, lib-xref-spark_specific.adb, sem_ch12.adb, sem_ch13.adb, + sem_ch6.adb, sem_dim.adb, sem_dim.ads, sem_elab.adb, sem_prag.adb: + Minor reformatting. + 2017-09-07 Vincent Celier <celier@adacore.com> * clean.adb: Do not get the target parameters before calling diff --git a/gcc/ada/a-chtgop.adb b/gcc/ada/a-chtgop.adb index 2b85b29e9d5..ad951e452dd 100644 --- a/gcc/ada/a-chtgop.adb +++ b/gcc/ada/a-chtgop.adb @@ -439,6 +439,33 @@ package body Ada.Containers.Hash_Tables.Generic_Operations is ----------------------- procedure Generic_Iteration (HT : Hash_Table_Type) is + procedure Wrapper (Node : Node_Access; Dummy_Pos : Hash_Type); + + ------------- + -- Wrapper -- + ------------- + + procedure Wrapper (Node : Node_Access; Dummy_Pos : Hash_Type) is + begin + Process (Node); + end Wrapper; + + procedure Internal_With_Pos is + new Generic_Iteration_With_Position (Wrapper); + + -- Start of processing for Generic_Iteration + + begin + Internal_With_Pos (HT); + end Generic_Iteration; + + ------------------------------------- + -- Generic_Iteration_With_Position -- + ------------------------------------- + + procedure Generic_Iteration_With_Position + (HT : Hash_Table_Type) + is Node : Node_Access; begin @@ -449,11 +476,11 @@ package body Ada.Containers.Hash_Tables.Generic_Operations is for Indx in HT.Buckets'Range loop Node := HT.Buckets (Indx); while Node /= null loop - Process (Node); + Process (Node, Indx); Node := Next (Node); end loop; end loop; - end Generic_Iteration; + end Generic_Iteration_With_Position; ------------------ -- Generic_Read -- diff --git a/gcc/ada/a-chtgop.ads b/gcc/ada/a-chtgop.ads index ba68b2dd772..ea2209bf7fb 100644 --- a/gcc/ada/a-chtgop.ads +++ b/gcc/ada/a-chtgop.ads @@ -169,6 +169,11 @@ package Ada.Containers.Hash_Tables.Generic_Operations is -- can implement efficient iterators. generic + with procedure Process (Node : Node_Access; Position : Hash_Type); + procedure Generic_Iteration_With_Position (HT : Hash_Table_Type); + -- Calls Process for each node in hash table HT + + generic with procedure Process (Node : Node_Access); procedure Generic_Iteration (HT : Hash_Table_Type); -- Calls Process for each node in hash table HT diff --git a/gcc/ada/a-cihama.adb b/gcc/ada/a-cihama.adb index 0d843795ab8..43a03806dce 100644 --- a/gcc/ada/a-cihama.adb +++ b/gcc/ada/a-cihama.adb @@ -770,20 +770,19 @@ package body Ada.Containers.Indefinite_Hashed_Maps is (Container : Map; Process : not null access procedure (Position : Cursor)) is - procedure Process_Node (Node : Node_Access); + procedure Process_Node (Node : Node_Access; Position : Hash_Type); pragma Inline (Process_Node); procedure Local_Iterate is - new HT_Ops.Generic_Iteration (Process_Node); + new HT_Ops.Generic_Iteration_With_Position (Process_Node); ------------------ -- Process_Node -- ------------------ - procedure Process_Node (Node : Node_Access) is + procedure Process_Node (Node : Node_Access; Position : Hash_Type) is begin - Process - (Cursor'(Container'Unrestricted_Access, Node, Hash_Type'Last)); + Process (Cursor'(Container'Unrestricted_Access, Node, Position)); end Process_Node; Busy : With_Busy (Container.HT.TC'Unrestricted_Access); diff --git a/gcc/ada/a-cohama.adb b/gcc/ada/a-cohama.adb index d4a0d591ce9..c71576c1f84 100644 --- a/gcc/ada/a-cohama.adb +++ b/gcc/ada/a-cohama.adb @@ -699,19 +699,19 @@ package body Ada.Containers.Hashed_Maps is (Container : Map; Process : not null access procedure (Position : Cursor)) is - procedure Process_Node (Node : Node_Access); + procedure Process_Node (Node : Node_Access; Position : Hash_Type); pragma Inline (Process_Node); - procedure Local_Iterate is new HT_Ops.Generic_Iteration (Process_Node); + procedure Local_Iterate is + new HT_Ops.Generic_Iteration_With_Position (Process_Node); ------------------ -- Process_Node -- ------------------ - procedure Process_Node (Node : Node_Access) is + procedure Process_Node (Node : Node_Access; Position : Hash_Type) is begin - Process - (Cursor'(Container'Unrestricted_Access, Node, Hash_Type'Last)); + Process (Cursor'(Container'Unrestricted_Access, Node, Position)); end Process_Node; Busy : With_Busy (Container.HT.TC'Unrestricted_Access); diff --git a/gcc/ada/a-cohase.adb b/gcc/ada/a-cohase.adb index eab8a4056fe..bde87049485 100644 --- a/gcc/ada/a-cohase.adb +++ b/gcc/ada/a-cohase.adb @@ -977,20 +977,19 @@ package body Ada.Containers.Hashed_Sets is (Container : Set; Process : not null access procedure (Position : Cursor)) is - procedure Process_Node (Node : Node_Access); + procedure Process_Node (Node : Node_Access; Position : Hash_Type); pragma Inline (Process_Node); procedure Iterate is - new HT_Ops.Generic_Iteration (Process_Node); + new HT_Ops.Generic_Iteration_With_Position (Process_Node); ------------------ -- Process_Node -- ------------------ - procedure Process_Node (Node : Node_Access) is + procedure Process_Node (Node : Node_Access; Position : Hash_Type) is begin - Process - (Cursor'(Container'Unrestricted_Access, Node, Hash_Type'Last)); + Process (Cursor'(Container'Unrestricted_Access, Node, Position)); end Process_Node; Busy : With_Busy (Container.HT.TC'Unrestricted_Access); diff --git a/gcc/ada/a-exetim-mingw.ads b/gcc/ada/a-exetim-mingw.ads index 4224d66033e..d4295c6f1ca 100644 --- a/gcc/ada/a-exetim-mingw.ads +++ b/gcc/ada/a-exetim-mingw.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2009-2015, Free Software Foundation, Inc. -- +-- Copyright (C) 2009-2017, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -79,7 +79,9 @@ is function "-" (Left : CPU_Time; - Right : CPU_Time) return Ada.Real_Time.Time_Span; + Right : CPU_Time) return Ada.Real_Time.Time_Span + with + Global => null; function "<" (Left, Right : CPU_Time) return Boolean with Global => null; diff --git a/gcc/ada/a-tags.adb b/gcc/ada/a-tags.adb index fd997829203..b15c990a03b 100644 --- a/gcc/ada/a-tags.adb +++ b/gcc/ada/a-tags.adb @@ -915,6 +915,7 @@ package body Ada.Tags is Prim_DT : constant Dispatch_Table_Ptr := DT (Prim_T); Iface_Table : constant Interface_Data_Ptr := To_Type_Specific_Data_Ptr (Prim_DT.TSD).Interfaces_Table; + begin -- Save Offset_Value in the table of interfaces of the primary DT. -- This data will be used by the subprogram "Displace" to give support @@ -927,11 +928,11 @@ package body Ada.Tags is if Iface_Table.Ifaces_Table (Id).Iface_Tag = Interface_T then if Is_Static or else Offset_Value = 0 then Iface_Table.Ifaces_Table (Id).Static_Offset_To_Top := True; - Iface_Table.Ifaces_Table (Id).Offset_To_Top_Value := + Iface_Table.Ifaces_Table (Id).Offset_To_Top_Value := Offset_Value; else Iface_Table.Ifaces_Table (Id).Static_Offset_To_Top := False; - Iface_Table.Ifaces_Table (Id).Offset_To_Top_Func := + Iface_Table.Ifaces_Table (Id).Offset_To_Top_Func := Offset_Func; end if; diff --git a/gcc/ada/comperr.adb b/gcc/ada/comperr.adb index 67df3431ed1..1b5aa3ebfe5 100644 --- a/gcc/ada/comperr.adb +++ b/gcc/ada/comperr.adb @@ -476,8 +476,8 @@ package body Comperr is when N_Package_Body => Unit_Name := Corresponding_Spec (Main); - when N_Package_Renaming_Declaration - | N_Package_Instantiation + when N_Package_Instantiation + | N_Package_Renaming_Declaration => Unit_Name := Defining_Unit_Name (Main); diff --git a/gcc/ada/debug.adb b/gcc/ada/debug.adb index 7e1940940d4..46a5d0e2afc 100644 --- a/gcc/ada/debug.adb +++ b/gcc/ada/debug.adb @@ -115,7 +115,7 @@ package body Debug is -- d.v -- d.w Do not check for infinite loops -- d.x No exception handlers - -- d.y + -- d.y Disable implicit pragma Elaborate_All on task bodies -- d.z Restore previous support for frontend handling of Inline_Always -- d.A Read/write Aspect_Specifications hash table to tree @@ -603,6 +603,12 @@ package body Debug is -- fully compiled and analyzed, they just get eliminated from the -- code generation step. + -- d.y Disable implicit pragma Elaborate_All on task bodies. When a task + -- body calls a procedure in the same package, and that procedure + -- calls a procedure in another package, the static elaboration + -- machinery adds an implicit Elaborate_All on the other package. This + -- switch disables the addition of the implicit pragma in such cases. + -- -- d.z Restore previous front-end support for Inline_Always. In default -- mode, for targets that use the GCC back end, Inline_Always is -- handled by the back end. Use of this switch restores the previous diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index 3ecf3229b8a..c0d48b7b36c 100644 --- a/gcc/ada/einfo.adb +++ b/gcc/ada/einfo.adb @@ -719,17 +719,17 @@ package body Einfo is function Access_Disp_Table (Id : E) return L is begin - pragma Assert (Ekind_In (Id, E_Record_Type, - E_Record_Type_With_Private, - E_Record_Subtype)); + pragma Assert (Ekind_In (Id, E_Record_Subtype, + E_Record_Type, + E_Record_Type_With_Private)); return Elist16 (Implementation_Base_Type (Id)); end Access_Disp_Table; function Access_Disp_Table_Elab_Flag (Id : E) return E is begin - pragma Assert (Ekind_In (Id, E_Record_Type, - E_Record_Type_With_Private, - E_Record_Subtype)); + pragma Assert (Ekind_In (Id, E_Record_Subtype, + E_Record_Type, + E_Record_Type_With_Private)); return Node30 (Implementation_Base_Type (Id)); end Access_Disp_Table_Elab_Flag; diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb index 71f2840b63b..55fdde5b899 100644 --- a/gcc/ada/exp_aggr.adb +++ b/gcc/ada/exp_aggr.adb @@ -3322,9 +3322,9 @@ package body Exp_Aggr is if Has_Interfaces (Base_Type (Typ)) then Init_Secondary_Tags - (Typ => Base_Type (Typ), - Target => Target, - Stmts_List => Assign, + (Typ => Base_Type (Typ), + Target => Target, + Stmts_List => Assign, Init_Tags_List => Assign); end if; end if; @@ -3858,9 +3858,9 @@ package body Exp_Aggr is if Has_Interfaces (Base_Type (Typ)) then Init_Secondary_Tags - (Typ => Base_Type (Typ), - Target => Target, - Stmts_List => L, + (Typ => Base_Type (Typ), + Target => Target, + Stmts_List => L, Init_Tags_List => L); end if; end if; diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index ce115b98327..62ccc4be725 100644 --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -2671,6 +2671,18 @@ package body Exp_Attr is New_Occurrence_Of (Extra_Constrained (Formal_Ent), Sloc (N))); + -- If the prefix is an access to object, the attribute applies to + -- the designated object, so rewrite with an explicit dereference. + + elsif Is_Access_Type (Etype (Pref)) + and then + (not Is_Entity_Name (Pref) or else Is_Object (Entity (Pref))) + then + Rewrite (Pref, + Make_Explicit_Dereference (Loc, Relocate_Node (Pref))); + Analyze_And_Resolve (N, Standard_Boolean); + return; + -- For variables with a Extra_Constrained field, we use the -- corresponding entity. diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 69db5dd6a44..6ed0f0feffa 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -2489,20 +2489,19 @@ package body Exp_Ch3 is Append_To (Elab_Sec_DT_Stmts_List, Make_Assignment_Statement (Loc, - Name => + Name => New_Occurrence_Of (Access_Disp_Table_Elab_Flag (Rec_Type), Loc), Expression => New_Occurrence_Of (Standard_False, Loc))); - Prepend_List_To (Body_Stmts, - New_List ( - Make_If_Statement (Loc, - Condition => New_Occurrence_Of (Set_Tag, Loc), - Then_Statements => Init_Tags_List), + Prepend_List_To (Body_Stmts, New_List ( + Make_If_Statement (Loc, + Condition => New_Occurrence_Of (Set_Tag, Loc), + Then_Statements => Init_Tags_List), Make_If_Statement (Loc, - Condition => + Condition => New_Occurrence_Of (Access_Disp_Table_Elab_Flag (Rec_Type), Loc), Then_Statements => Elab_Sec_DT_Stmts_List))); @@ -2510,7 +2509,7 @@ package body Exp_Ch3 is else Prepend_To (Body_Stmts, Make_If_Statement (Loc, - Condition => New_Occurrence_Of (Set_Tag, Loc), + Condition => New_Occurrence_Of (Set_Tag, Loc), Then_Statements => Init_Tags_List)); end if; diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb index 28950fca8a4..2ca42de1939 100644 --- a/gcc/ada/exp_ch7.adb +++ b/gcc/ada/exp_ch7.adb @@ -5297,7 +5297,14 @@ package body Exp_Ch7 is -- Start of processing for Insert_Actions_In_Scope_Around begin - if No (Act_Before) and then No (Act_After) and then No (Act_Cleanup) then + -- Nothing to do if the scope does not manage the secondary stack or + -- does not contain meaninful actions for insertion. + + if not Manage_SS + and then No (Act_Before) + and then No (Act_After) + and then No (Act_Cleanup) + then return; end if; diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb index dd0266fdcc6..2abd7d17cc8 100644 --- a/gcc/ada/exp_disp.adb +++ b/gcc/ada/exp_disp.adb @@ -6700,7 +6700,7 @@ package body Exp_Disp is if Elab_Flag_Needed (Typ) then Set_Access_Disp_Table_Elab_Flag (Typ, Make_Defining_Identifier (Loc, - New_External_Name (Tname, 'F', Suffix_Index => -1))); + Chars => New_External_Name (Tname, 'F'))); Append_To (Result, Make_Object_Declaration (Loc, diff --git a/gcc/ada/exp_dist.adb b/gcc/ada/exp_dist.adb index 70f07fc3e42..89cf665b077 100644 --- a/gcc/ada/exp_dist.adb +++ b/gcc/ada/exp_dist.adb @@ -977,7 +977,7 @@ package body Exp_Dist is or else (Is_Generic_Instance (Pkg_Ent) and then Comes_From_Source - (Get_Package_Instantiation_Node (Pkg_Ent))) + (Get_Unit_Instantiation_Node (Pkg_Ent))) then Visit_Nested_Pkg (Decl); end if; diff --git a/gcc/ada/g-socket.adb b/gcc/ada/g-socket.adb index 688fc82a4e2..9b2ad7f74fb 100644 --- a/gcc/ada/g-socket.adb +++ b/gcc/ada/g-socket.adb @@ -2478,6 +2478,15 @@ package body GNAT.Sockets is return Stream_Access (S); end Stream; + ------------ + -- To_Ada -- + ------------ + + function To_Ada (Fd : Integer) return Socket_Type is + begin + return Socket_Type (Fd); + end To_Ada; + ---------- -- To_C -- ---------- diff --git a/gcc/ada/g-socket.ads b/gcc/ada/g-socket.ads index aa64c008368..06d7a85b202 100644 --- a/gcc/ada/g-socket.ads +++ b/gcc/ada/g-socket.ads @@ -456,7 +456,11 @@ package GNAT.Sockets is function Image (Socket : Socket_Type) return String; -- Return a printable string for Socket - function To_C (Socket : Socket_Type) return Integer; + function To_Ada (Fd : Integer) return Socket_Type with Inline; + -- Convert a file descriptor to Socket_Type. This is useful when a socket + -- file descriptor is obtained from an external library call. + + function To_C (Socket : Socket_Type) return Integer with Inline; -- Return a file descriptor to be used by external subprograms. This is -- useful for C functions that are not yet interfaced in this package. diff --git a/gcc/ada/lib-xref-spark_specific.adb b/gcc/ada/lib-xref-spark_specific.adb index dfbe4dd3419..b627a8e59ee 100644 --- a/gcc/ada/lib-xref-spark_specific.adb +++ b/gcc/ada/lib-xref-spark_specific.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2011-2016, Free Software Foundation, Inc. -- +-- Copyright (C) 2011-2017, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -1307,8 +1307,18 @@ package body SPARK_Specific is when N_Protected_Type_Declaration => Traverse_Visible_And_Private_Parts (Protected_Definition (N)); - when N_Task_Definition => - Traverse_Visible_And_Private_Parts (N); + when N_Task_Type_Declaration => + + -- Task type definition is optional (unlike protected type + -- definition, which is mandatory). + + declare + Task_Def : constant Node_Id := Task_Definition (N); + begin + if Present (Task_Def) then + Traverse_Visible_And_Private_Parts (Task_Def); + end if; + end; when N_Task_Body => Traverse_Task_Body (N); diff --git a/gcc/ada/lib-xref.adb b/gcc/ada/lib-xref.adb index 9cc54ebb958..eb6ac0a629f 100644 --- a/gcc/ada/lib-xref.adb +++ b/gcc/ada/lib-xref.adb @@ -1126,12 +1126,14 @@ package body Lib.Xref is -- Comment needed here for special SPARK code ??? if GNATprove_Mode then - -- Ignore reference to an entity that is a Part_Of single + + -- Ignore references to an entity which is a Part_Of single -- concurrent object. Ideally we would prefer to add it as a -- reference to the corresponding concurrent type, but it is quite -- difficult (as such references are not currently added even for) -- reads/writes of private protected components) and not worth the -- effort. + if Ekind_In (Ent, E_Abstract_State, E_Constant, E_Variable) and then Present (Encapsulating_State (Ent)) and then Is_Single_Concurrent_Object (Encapsulating_State (Ent)) diff --git a/gcc/ada/par-ch13.adb b/gcc/ada/par-ch13.adb index fc8874bfd58..a238d66d9cb 100644 --- a/gcc/ada/par-ch13.adb +++ b/gcc/ada/par-ch13.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -520,9 +520,11 @@ package body Ch13 is end if; end if; - -- Note if inside Depends aspect + -- Note if inside Depends or Refined_Depends aspect - if A_Id = Aspect_Depends then + if A_Id = Aspect_Depends + or else A_Id = Aspect_Refined_Depends + then Inside_Depends := True; end if; diff --git a/gcc/ada/par-ch2.adb b/gcc/ada/par-ch2.adb index fc8d9cbd721..a97ed81238e 100644 --- a/gcc/ada/par-ch2.adb +++ b/gcc/ada/par-ch2.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2016, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -304,7 +304,9 @@ package body Ch2 is -- Set global to indicate if we are within a Depends pragma - if Chars (Ident_Node) = Name_Depends then + if Chars (Ident_Node) = Name_Depends + or else Chars (Ident_Node) = Name_Refined_Depends + then Inside_Depends := True; end if; diff --git a/gcc/ada/scans.ads b/gcc/ada/scans.ads index 428c1a5b975..faa06f2087d 100644 --- a/gcc/ada/scans.ads +++ b/gcc/ada/scans.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2016, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -485,8 +485,9 @@ package Scans is -- about the case of Wide_Wide_Characters??? Inside_Depends : Boolean := False; - -- True while parsing the argument of a Depends pragma or aspect (used to - -- allow/require non-standard style rules for =>+ with -gnatyt). + -- True while parsing the argument of a Depends or Refined_Depends pragma + -- or aspect. Used to allow/require nonstandard style rules for =>+ with + -- -gnatyt. Inside_If_Expression : Nat := 0; -- This is a counter that is set non-zero while scanning out an if diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index 38180dd469c..f1e659c4bab 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -8431,7 +8431,7 @@ package body Sem_Ch12 is -- The parent was a premature instantiation. Insert freeze node at -- the end the current declarative part. - if ABE_Is_Certain (Get_Package_Instantiation_Node (Par)) then + if ABE_Is_Certain (Get_Unit_Instantiation_Node (Par)) then Insert_Freeze_Node_For_Instance (Inst_Node, F_Node); -- Handle the following case: @@ -8452,7 +8452,7 @@ package body Sem_Ch12 is -- after that of Parent_Inst. This relation is established by -- comparing the Slocs of Parent_Inst freeze node and Inst. - elsif List_Containing (Get_Package_Instantiation_Node (Par)) = + elsif List_Containing (Get_Unit_Instantiation_Node (Par)) = List_Containing (Inst_Node) and then Sloc (Freeze_Node (Par)) < Sloc (Inst_Node) then @@ -8574,11 +8574,11 @@ package body Sem_Ch12 is end if; end Get_Instance_Of; - ------------------------------------ - -- Get_Package_Instantiation_Node -- - ------------------------------------ + --------------------------------- + -- Get_Unit_Instantiation_Node -- + --------------------------------- - function Get_Package_Instantiation_Node (A : Entity_Id) return Node_Id is + function Get_Unit_Instantiation_Node (A : Entity_Id) return Node_Id is Decl : Node_Id := Unit_Declaration_Node (A); Inst : Node_Id; @@ -8624,7 +8624,10 @@ package body Sem_Ch12 is Decl := Unit_Declaration_Node (Corresponding_Body (Decl)); end if; - if Nkind (Original_Node (Decl)) = N_Package_Instantiation then + if Nkind_In (Original_Node (Decl), N_Function_Instantiation, + N_Package_Instantiation, + N_Procedure_Instantiation) + then return Original_Node (Decl); else return Unit (Parent (Decl)); @@ -8637,15 +8640,17 @@ package body Sem_Ch12 is else Inst := Next (Decl); - while not Nkind_In (Inst, N_Package_Instantiation, - N_Formal_Package_Declaration) + while not Nkind_In (Inst, N_Formal_Package_Declaration, + N_Function_Instantiation, + N_Package_Instantiation, + N_Procedure_Instantiation) loop Next (Inst); end loop; return Inst; end if; - end Get_Package_Instantiation_Node; + end Get_Unit_Instantiation_Node; ------------------------ -- Has_Been_Exchanged -- @@ -9311,7 +9316,7 @@ package body Sem_Ch12 is -- Parent_Inst. This relation is established by comparing -- the Slocs of Parent_Inst freeze node and Inst. - if List_Containing (Get_Package_Instantiation_Node (Par)) = + if List_Containing (Get_Unit_Instantiation_Node (Par)) = List_Containing (N) and then Sloc (Freeze_Node (Par)) < Sloc (N) then @@ -9572,7 +9577,7 @@ package body Sem_Ch12 is -- Load grandparent instance as well - Inst_Node := Get_Package_Instantiation_Node (Inst_Par); + Inst_Node := Get_Unit_Instantiation_Node (Inst_Par); if Nkind (Name (Inst_Node)) = N_Expanded_Name then Inst_Par := Entity (Prefix (Name (Inst_Node))); diff --git a/gcc/ada/sem_ch12.ads b/gcc/ada/sem_ch12.ads index 82a093afae3..114a45af9aa 100644 --- a/gcc/ada/sem_ch12.ads +++ b/gcc/ada/sem_ch12.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2016, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -93,7 +93,7 @@ package Sem_Ch12 is -- Retrieve actual associated with given generic parameter. -- If A is uninstantiated or not a generic parameter, return A. - function Get_Package_Instantiation_Node (A : Entity_Id) return Node_Id; + function Get_Unit_Instantiation_Node (A : Entity_Id) return Node_Id; -- Given the entity of a unit that is an instantiation, retrieve the -- original instance node. This is used when loading the instantiations -- of the ancestors of a child generic that is being instantiated. diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 1bd332daee1..20619964bd2 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -9280,8 +9280,9 @@ package body Sem_Ch13 is T := Standard_Integer; when Aspect_Small => - -- Note that the expression can be of any real type (not just - -- a real universal literal) as long as it is a static constant. + + -- Note that the expression can be of any real type (not just a + -- real universal literal) as long as it is a static constant. T := Any_Real; diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 7e2225565ab..c5b2aa75275 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -910,7 +910,7 @@ package body Sem_Ch6 is if Expander_Active and then Serious_Errors_Detected = 0 and then Is_Access_Type (R_Type) - and then Nkind (Expr) /= N_Null + and then not Nkind_In (Expr, N_Null, N_Raise_Expression) and then Is_Interface (Designated_Type (R_Type)) and then Is_Progenitor (Designated_Type (R_Type), Designated_Type (Etype (Expr))) diff --git a/gcc/ada/sem_ch7.adb b/gcc/ada/sem_ch7.adb index 241e6fe8dcc..7b0761b8200 100644 --- a/gcc/ada/sem_ch7.adb +++ b/gcc/ada/sem_ch7.adb @@ -1411,7 +1411,7 @@ package body Sem_Ch7 is Gen_Par := Generic_Parent (Specification (Unit_Declaration_Node (Inst_Par))); while Present (Gen_Par) and then Is_Child_Unit (Gen_Par) loop - Inst_Node := Get_Package_Instantiation_Node (Inst_Par); + Inst_Node := Get_Unit_Instantiation_Node (Inst_Par); if Nkind_In (Inst_Node, N_Package_Instantiation, N_Formal_Package_Declaration) diff --git a/gcc/ada/sem_ch9.adb b/gcc/ada/sem_ch9.adb index 184fe43e50c..2fb8ebdc942 100644 --- a/gcc/ada/sem_ch9.adb +++ b/gcc/ada/sem_ch9.adb @@ -2773,7 +2773,7 @@ package body Sem_Ch9 is Generate_Definition (Obj_Id); Tasking_Used := True; - -- A single task declaration is transformed into a pait of an anonymous + -- A single task declaration is transformed into a pair of an anonymous -- task type and an object of that type. Generate: -- task type Typ is ...; diff --git a/gcc/ada/sem_dim.adb b/gcc/ada/sem_dim.adb index 6aae74b8ec8..baa56391358 100644 --- a/gcc/ada/sem_dim.adb +++ b/gcc/ada/sem_dim.adb @@ -35,6 +35,7 @@ with Nmake; use Nmake; with Opt; use Opt; with Rtsfind; use Rtsfind; with Sem; use Sem; +with Sem_Aux; use Sem_Aux; with Sem_Eval; use Sem_Eval; with Sem_Res; use Sem_Res; with Sem_Util; use Sem_Util; @@ -280,6 +281,14 @@ package body Sem_Dim is -- both the identifier and the parent type of N are not dimensionless, -- return an error. + procedure Analyze_Dimension_Type_Conversion (N : Node_Id); + -- Type conversions handle conversions between literals and dimensioned + -- types, from dimensioned types to their base type, and between different + -- dimensioned systems. Dimensions of the conversion are obtained either + -- from those of the expression, or from the target type, and dimensional + -- consistency must be checked when converting between values belonging + -- to different dimensioned systems. + procedure Analyze_Dimension_Unary_Op (N : Node_Id); -- Subroutine of Analyze_Dimension for unary operators. For Plus, Minus and -- Abs operators, propagate the dimensions from the operand to N. @@ -301,6 +310,11 @@ package body Sem_Dim is -- dimension" if Description_Needed. if N is dimensionless, return "'[']", -- or "is dimensionless" if Description_Needed. + function Dimension_System_Root (T : Entity_Id) return Entity_Id; + -- Given a type that has dimension information, return the type that is the + -- root of its dimension system, e.g. Mks_Type. If T is not a dimensioned + -- type, i.e. a standard numeric type, return Empty. + procedure Dim_Warning_For_Numeric_Literal (N : Node_Id; Typ : Entity_Id); -- Issue a warning on the given numeric literal N to indicate that the -- compiler made the assumption that the literal is not dimensionless @@ -1191,13 +1205,7 @@ package body Sem_Dim is Analyze_Dimension_Subtype_Declaration (N); when N_Type_Conversion => - if In_Instance - and then Exists (Dimensions_Of (Expression (N))) - then - Set_Dimensions (N, Dimensions_Of (Expression (N))); - else - Analyze_Dimension_Has_Etype (N); - end if; + Analyze_Dimension_Type_Conversion (N); when N_Unary_Op => Analyze_Dimension_Unary_Op (N); @@ -1384,26 +1392,6 @@ package body Sem_Dim is return Dimensions_Of (Etype (N)); end if; - -- A type conversion may have been inserted to rewrite other - -- expressions, e.g. function returns. Dimensions are those of - -- the target type, unless this is a conversion in an instance, - -- in which case the proper dimensions are those of the operand, - - elsif Nkind (N) = N_Type_Conversion then - if In_Instance - and then Is_Generic_Actual_Type (Etype (Expression (N))) - then - return Dimensions_Of (Etype (Expression (N))); - - elsif In_Instance - and then Exists (Dimensions_Of (Expression (N))) - then - return Dimensions_Of (Expression (N)); - - else - return Dimensions_Of (Etype (N)); - end if; - -- Otherwise return the default dimensions else @@ -2339,6 +2327,56 @@ package body Sem_Dim is end if; end Analyze_Dimension_Subtype_Declaration; + --------------------------------------- + -- Analyze_Dimension_Type_Conversion -- + --------------------------------------- + + procedure Analyze_Dimension_Type_Conversion (N : Node_Id) is + Expr_Root : constant Entity_Id := + Dimension_System_Root (Etype (Expression (N))); + Target_Root : constant Entity_Id := + Dimension_System_Root (Etype (N)); + + begin + -- If the expression has dimensions and the target type has dimensions, + -- the conversion has the dimensions of the expression. Consistency is + -- checked below. Converting to a non-dimensioned type such as Float + -- ignores the dimensions of the expression. + + if Exists (Dimensions_Of (Expression (N))) + and then Present (Target_Root) + then + Set_Dimensions (N, Dimensions_Of (Expression (N))); + + -- Otherwise the dimensions are those of the target type. + + else + Analyze_Dimension_Has_Etype (N); + end if; + + -- A conversion between types in different dimension systems (e.g. MKS + -- and British units) must respect the dimensions of expression and + -- type, It is up to the user to provide proper conversion factors. + + -- Upward conversions to root type of a dimensioned system are legal, + -- and correspond to "view conversions", i.e. preserve the dimensions + -- of the expression; otherwise conversion must be between types with + -- then same dimensions. Conversions to a non-dimensioned type such as + -- Float lose the dimensions of the expression. + + if Present (Expr_Root) + and then Present (Target_Root) + and then Etype (N) /= Target_Root + and then Dimensions_Of (Expression (N)) /= Dimensions_Of (Etype (N)) + then + Error_Msg_N ("dimensions mismatch in conversion", N); + Error_Msg_N + ("\expression " & Dimensions_Msg_Of (Expression (N), True), N); + Error_Msg_N + ("\target type " & Dimensions_Msg_Of (Etype (N), True), N); + end if; + end Analyze_Dimension_Type_Conversion; + -------------------------------- -- Analyze_Dimension_Unary_Op -- -------------------------------- @@ -2665,6 +2703,24 @@ package body Sem_Dim is or else Dimensions_Of (T1) = Dimensions_Of (T2); end Dimensions_Match; + --------------------------- + -- Dimension_System_Root -- + --------------------------- + + function Dimension_System_Root (T : Entity_Id) return Entity_Id is + Root : Entity_Id; + + begin + Root := Base_Type (T); + + if Has_Dimension_System (Root) then + return First_Subtype (Root); -- for example Dim_Mks + + else + return Empty; + end if; + end Dimension_System_Root; + ---------------------------------------- -- Eval_Op_Expon_For_Dimensioned_Type -- ---------------------------------------- diff --git a/gcc/ada/sem_dim.ads b/gcc/ada/sem_dim.ads index 9452d7a84fb..7ee2e79f110 100644 --- a/gcc/ada/sem_dim.ads +++ b/gcc/ada/sem_dim.ads @@ -195,14 +195,6 @@ package Sem_Dim is -- a full copy of the type declaration of the parent, and the dimension -- information of individual components must be transferred explicitly. - function New_Copy_Tree_And_Copy_Dimensions - (Source : Node_Id; - Map : Elist_Id := No_Elist; - New_Sloc : Source_Ptr := No_Location; - New_Scope : Entity_Id := Empty) return Node_Id; - -- Same as New_Copy_Tree (defined in Sem_Util), except that this routine - -- also copies the dimensions of Source to the returned node. - function Dimensions_Match (T1 : Entity_Id; T2 : Entity_Id) return Boolean; -- If the common base type has a dimension system, verify that two -- subtypes have the same dimensions. Used for conformance checking. @@ -228,6 +220,14 @@ package Sem_Dim is -- Return True if N is a package instantiation of System.Dim.Integer_IO or -- of System.Dim.Float_IO. + function New_Copy_Tree_And_Copy_Dimensions + (Source : Node_Id; + Map : Elist_Id := No_Elist; + New_Sloc : Source_Ptr := No_Location; + New_Scope : Entity_Id := Empty) return Node_Id; + -- Same as New_Copy_Tree (defined in Sem_Util), except that this routine + -- also copies the dimensions of Source to the returned node. + procedure Remove_Dimension_In_Statement (Stmt : Node_Id); -- Remove the dimensions associated with Stmt diff --git a/gcc/ada/sem_disp.adb b/gcc/ada/sem_disp.adb index 0dff74fcb37..974edd35679 100644 --- a/gcc/ada/sem_disp.adb +++ b/gcc/ada/sem_disp.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2016, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -427,29 +427,6 @@ package body Sem_Disp is procedure Check_Direct_Call is Typ : Entity_Id := Etype (Control); - - function Is_User_Defined_Equality (Id : Entity_Id) return Boolean; - -- Determine whether an entity denotes a user-defined equality - - ------------------------------ - -- Is_User_Defined_Equality -- - ------------------------------ - - function Is_User_Defined_Equality (Id : Entity_Id) return Boolean is - begin - return - Ekind (Id) = E_Function - and then Chars (Id) = Name_Op_Eq - and then Comes_From_Source (Id) - - -- Internally generated equalities have a full type declaration - -- as their parent. - - and then Nkind (Parent (Id)) = N_Function_Specification; - end Is_User_Defined_Equality; - - -- Start of processing for Check_Direct_Call - begin -- Predefined primitives do not receive wrappers since they are built -- from scratch for the corresponding record of synchronized types. diff --git a/gcc/ada/sem_elab.adb b/gcc/ada/sem_elab.adb index 25c3d4433ff..6d920e49477 100644 --- a/gcc/ada/sem_elab.adb +++ b/gcc/ada/sem_elab.adb @@ -2961,19 +2961,21 @@ package body Sem_Elab is Next_Elmt (Elmt); end loop; - -- For tasks declared in the current unit, trace other calls within - -- the task procedure bodies, which are available. + -- For tasks declared in the current unit, trace other calls within the + -- task procedure bodies, which are available. - In_Task_Activation := True; + if not Debug_Flag_Dot_Y then + In_Task_Activation := True; - Elmt := First_Elmt (Intra_Procs); - while Present (Elmt) loop - Ent := Node (Elmt); - Check_Internal_Call_Continue (N, Ent, Enclosing, Ent); - Next_Elmt (Elmt); - end loop; + Elmt := First_Elmt (Intra_Procs); + while Present (Elmt) loop + Ent := Node (Elmt); + Check_Internal_Call_Continue (N, Ent, Enclosing, Ent); + Next_Elmt (Elmt); + end loop; - In_Task_Activation := False; + In_Task_Activation := False; + end if; end Check_Task_Activation; ------------------------------- diff --git a/gcc/ada/sem_elab.ads b/gcc/ada/sem_elab.ads index c8aec6601bc..d2465827681 100644 --- a/gcc/ada/sem_elab.ads +++ b/gcc/ada/sem_elab.ads @@ -71,7 +71,7 @@ package Sem_Elab is -- output a warning. -- For calls to a subprogram in a with'ed unit or a 'Access or variable - -- refernece (SPARK mode case), we require that a pragma Elaborate_All + -- reference (SPARK mode case), we require that a pragma Elaborate_All -- or pragma Elaborate be present, or that the referenced unit have a -- pragma Preelaborate, pragma Pure, or pragma Elaborate_Body. If none -- of these conditions is met, then a warning is generated that a pragma diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 4104e756e31..9cf91556922 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -3076,9 +3076,11 @@ package body Sem_Prag is and then Nkind (Decl) = N_Object_Declaration then Append_New_Elmt (Defining_Entity (Decl), States_And_Objs); + elsif Is_Single_Concurrent_Type_Declaration (Decl) then - Append_New_Elmt (Anonymous_Object (Defining_Entity (Decl)), - States_And_Objs); + Append_New_Elmt + (Anonymous_Object (Defining_Entity (Decl)), + States_And_Objs); end if; Next (Decl); diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 8573203cfd0..e9bcdada873 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -15730,6 +15730,22 @@ package body Sem_Util is return T = Universal_Integer or else T = Universal_Real; end Is_Universal_Numeric_Type; + ------------------------------ + -- Is_User_Defined_Equality -- + ------------------------------ + + function Is_User_Defined_Equality (Id : Entity_Id) return Boolean is + begin + return Ekind (Id) = E_Function + and then Chars (Id) = Name_Op_Eq + and then Comes_From_Source (Id) + + -- Internally generated equalities have a full type declaration + -- as their parent. + + and then Nkind (Parent (Id)) = N_Function_Specification; + end Is_User_Defined_Equality; + -------------------------------------- -- Is_Validation_Variable_Reference -- -------------------------------------- diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index bc7622425f5..b8f4bed7996 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -1875,6 +1875,9 @@ package Sem_Util is pragma Inline (Is_Universal_Numeric_Type); -- True if T is Universal_Integer or Universal_Real + function Is_User_Defined_Equality (Id : Entity_Id) return Boolean; + -- Determine whether an entity denotes a user-defined equality + function Is_Validation_Variable_Reference (N : Node_Id) return Boolean; -- Determine whether N denotes a reference to a variable which captures the -- value of an object for validation purposes. diff --git a/gcc/ada/styleg.adb b/gcc/ada/styleg.adb index f785205fe10..14a63c0a42b 100644 --- a/gcc/ada/styleg.adb +++ b/gcc/ada/styleg.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2016, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -127,20 +127,17 @@ package body Styleg is ----------------- -- In check tokens mode (-gnatys), arrow must be surrounded by spaces, - -- except that within the argument of a Depends macro the required format - -- is =>+ rather than => +). + -- except that within the argument of a Depends or Refined_Depends aspect + -- or pragma the required format is "=>+ " rather than "=> +"). procedure Check_Arrow (Inside_Depends : Boolean := False) is begin if Style_Check_Tokens then Require_Preceding_Space; - if not Inside_Depends then - Require_Following_Space; - - -- Special handling for Inside_Depends + -- Special handling for Depends and Refined_Depends - else + if Inside_Depends then if Source (Scan_Ptr) = ' ' and then Source (Scan_Ptr + 1) = '+' then @@ -151,6 +148,11 @@ package body Styleg is then Require_Following_Space; end if; + + -- Normal case + + else + Require_Following_Space; end if; end if; end Check_Arrow; @@ -1054,16 +1056,17 @@ package body Styleg is -- In check token mode (-gnatyt), unary plus or minus must not be -- followed by a space. - -- Annoying exception: if we have the sequence =>+ within a Depends pragma - -- or aspect, then we insist on a space rather than forbidding it. + -- Annoying exception: if we have the sequence =>+ within a Depends or + -- Refined_Depends pragma or aspect, then we insist on a space rather + -- than forbidding it. procedure Check_Unary_Plus_Or_Minus (Inside_Depends : Boolean := False) is begin if Style_Check_Tokens then - if not Inside_Depends then - Check_No_Space_After; - else + if Inside_Depends then Require_Following_Space; + else + Check_No_Space_After; end if; end if; end Check_Unary_Plus_Or_Minus; diff --git a/gcc/ada/styleg.ads b/gcc/ada/styleg.ads index 141c1143578..7b23d2e72da 100644 --- a/gcc/ada/styleg.ads +++ b/gcc/ada/styleg.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -54,8 +54,8 @@ package Styleg is procedure Check_Arrow (Inside_Depends : Boolean := False); -- Called after scanning out an arrow to check spacing. Inside_Depends is - -- true if the call is from an argument of the Depends pragma (where the - -- allowed/required format is =>+). + -- True if the call is from an argument of the Depends or Refined_Depends + -- aspect or pragma (where the allowed/required format is =>+). procedure Check_Attribute_Name (Reserved : Boolean); -- The current token is an attribute designator. Check that it @@ -147,8 +147,9 @@ package Styleg is procedure Check_Unary_Plus_Or_Minus (Inside_Depends : Boolean := False); -- Called after scanning a unary plus or minus to check spacing. The flag - -- Inside_Depends is set if we are scanning within a Depends pragma or - -- Aspect, in which case =>+ requires a following space). + -- Inside_Depends is set if we are scanning within a Depends or + -- Refined_Depends pragma or Aspect, in which case =>+ requires a + -- following space. procedure Check_Vertical_Bar; -- Called after scanning a vertical bar to check spacing |