From ed3fe8cc27a62cbc21fcb5427ca5b2919878d94f Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Fri, 6 Jan 2017 11:28:06 +0100 Subject: [PATCH] [multiple changes] 2017-01-06 Hristian Kirtchev * exp_attr.adb (Rewrite_Stream_Proc_Call): Use an unchecked type conversion when performing a view conversion to/from a private type. In all other cases use a regular type conversion to ensure that any relevant checks are properly installed. 2017-01-06 Hristian Kirtchev * sem_prag.adb, sem_ch8.adb: Minor reformatting. 2017-01-06 Ed Schonberg * sem_case.adb (Explain_Non_Static_Bound): Suppress cascaded error on case expression that is an entity, when coverage is incomplete and entity has a static value obtained by local propagation. (Handle_Static_Predicate): New procedure, subsidiary of Check_Choices, to handle case alternatives that are either subtype names or subtype indications involving subtypes that have static predicates. 2017-01-06 Thomas Quinot * s-oscons-tmplt.c, g-socket.adb, g-socket.ads, g-sothco.ads: (GNAT.Socket): Add support for Busy_Polling and Generic_Option 2017-01-06 Bob Duff * sem_elab.adb (Activate_Elaborate_All_Desirable): Don't add Elaborate_All(P) to P itself. That could happen in obscure cases, and always introduced a cycle (P body must be elaborated before P body). * lib-writ.ads: Comment clarification. * ali-util.ads: Minor comment fix. * ali.adb: Minor reformatting. 2017-01-06 Tristan Gingold * a-exexpr-gcc.adb: Improve comment. From-SVN: r244125 --- gcc/ada/ChangeLog | 42 ++++++++++++++++ gcc/ada/a-exexpr-gcc.adb | 5 +- gcc/ada/ali-util.ads | 4 +- gcc/ada/ali.adb | 5 +- gcc/ada/exp_attr.adb | 40 +++++++++------- gcc/ada/g-socket.adb | 91 +++++++++++++++++++++++++---------- gcc/ada/g-socket.ads | 28 ++++++++--- gcc/ada/g-sothco.ads | 5 +- gcc/ada/lib-writ.ads | 8 ++-- gcc/ada/s-oscons-tmplt.c | 7 ++- gcc/ada/sem_case.adb | 101 +++++++++++++++++++++++++++++---------- gcc/ada/sem_ch8.adb | 7 +-- gcc/ada/sem_elab.adb | 15 ++++-- gcc/ada/sem_prag.adb | 4 +- 14 files changed, 267 insertions(+), 95 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index fae89b94bfd..7150bc26d0b 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,45 @@ +2017-01-06 Hristian Kirtchev + + * exp_attr.adb (Rewrite_Stream_Proc_Call): Use + an unchecked type conversion when performing a view conversion + to/from a private type. In all other cases use a regular type + conversion to ensure that any relevant checks are properly + installed. + +2017-01-06 Hristian Kirtchev + + * sem_prag.adb, sem_ch8.adb: Minor reformatting. + +2017-01-06 Ed Schonberg + + * sem_case.adb (Explain_Non_Static_Bound): Suppress cascaded + error on case expression that is an entity, when coverage is + incomplete and entity has a static value obtained by local + propagation. + (Handle_Static_Predicate): New procedure, subsidiary of + Check_Choices, to handle case alternatives that are either + subtype names or subtype indications involving subtypes that + have static predicates. + +2017-01-06 Thomas Quinot + + * s-oscons-tmplt.c, g-socket.adb, g-socket.ads, g-sothco.ads: + (GNAT.Socket): Add support for Busy_Polling and Generic_Option + +2017-01-06 Bob Duff + + * sem_elab.adb (Activate_Elaborate_All_Desirable): Don't add + Elaborate_All(P) to P itself. That could happen in obscure cases, + and always introduced a cycle (P body must be elaborated before + P body). + * lib-writ.ads: Comment clarification. + * ali-util.ads: Minor comment fix. + * ali.adb: Minor reformatting. + +2017-01-06 Tristan Gingold + + * a-exexpr-gcc.adb: Improve comment. + 2017-01-03 James Cowgill * s-linux-mips.ads: Use correct signal and errno constants. diff --git a/gcc/ada/a-exexpr-gcc.adb b/gcc/ada/a-exexpr-gcc.adb index 3208027a72b..91fb5f5cd67 100644 --- a/gcc/ada/a-exexpr-gcc.adb +++ b/gcc/ada/a-exexpr-gcc.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2016, 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- -- @@ -115,7 +115,8 @@ package body Exception_Propagation is GCC_Exception : not null GCC_Exception_Access); pragma Export (C, Set_Exception_Parameter, "__gnat_set_exception_parameter"); - -- Called inserted by gigi to initialize the exception parameter + -- Called inserted by gigi to set the exception choice parameter from the + -- gcc occurrence. procedure Set_Foreign_Occurrence (Excep : EOA; Mo : System.Address); -- Utility routine to initialize occurrence Excep from a foreign exception diff --git a/gcc/ada/ali-util.ads b/gcc/ada/ali-util.ads index 251f3e7c5af..c9abc5c2d5d 100644 --- a/gcc/ada/ali-util.ads +++ b/gcc/ada/ali-util.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2016, 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- -- @@ -24,7 +24,7 @@ ------------------------------------------------------------------------------ -- This child unit provides utility data structures and procedures used --- for manipulation of ALI data by the gnatbind and gnatmake. +-- for manipulation of ALI data by gnatbind and gnatmake. package ALI.Util is diff --git a/gcc/ada/ali.adb b/gcc/ada/ali.adb index d07b3df781a..7508e810eb4 100644 --- a/gcc/ada/ali.adb +++ b/gcc/ada/ali.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2016, 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- -- @@ -2056,8 +2056,7 @@ package body ALI is -- Store AD indication unless ignore required if not Ignore_ED then - Withs.Table (Withs.Last).Elab_All_Desirable := - True; + Withs.Table (Withs.Last).Elab_All_Desirable := True; end if; elsif Nextc = 'E' then diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index 04929b5aa57..9e77ae0cafa 100644 --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -1568,9 +1568,10 @@ package body Exp_Attr is procedure Rewrite_Stream_Proc_Call (Pname : Entity_Id) is Item : constant Node_Id := Next (First (Exprs)); + Item_Typ : constant Entity_Id := Etype (Item); Formal : constant Entity_Id := Next_Formal (First_Formal (Pname)); Formal_Typ : constant Entity_Id := Etype (Formal); - Is_Written : constant Boolean := (Ekind (Formal) /= E_In_Parameter); + Is_Written : constant Boolean := Ekind (Formal) /= E_In_Parameter; begin -- The expansion depends on Item, the second actual, which is @@ -1583,7 +1584,7 @@ package body Exp_Attr is if Nkind (Item) = N_Indexed_Component and then Is_Packed (Base_Type (Etype (Prefix (Item)))) - and then Base_Type (Etype (Item)) /= Base_Type (Formal_Typ) + and then Base_Type (Item_Typ) /= Base_Type (Formal_Typ) and then Is_Written then declare @@ -1595,23 +1596,22 @@ package body Exp_Attr is Decl := Make_Object_Declaration (Loc, Defining_Identifier => Temp, - Object_Definition => - New_Occurrence_Of (Formal_Typ, Loc)); + Object_Definition => New_Occurrence_Of (Formal_Typ, Loc)); Set_Etype (Temp, Formal_Typ); Assn := Make_Assignment_Statement (Loc, - Name => New_Copy_Tree (Item), + Name => New_Copy_Tree (Item), Expression => Unchecked_Convert_To - (Etype (Item), New_Occurrence_Of (Temp, Loc))); + (Item_Typ, New_Occurrence_Of (Temp, Loc))); Rewrite (Item, New_Occurrence_Of (Temp, Loc)); Insert_Actions (N, New_List ( Decl, Make_Procedure_Call_Statement (Loc, - Name => New_Occurrence_Of (Pname, Loc), + Name => New_Occurrence_Of (Pname, Loc), Parameter_Associations => Exprs), Assn)); @@ -1626,17 +1626,25 @@ package body Exp_Attr is -- operation is not inherited), we are all set, and can use the -- argument unchanged. - -- For all other cases we do an unchecked conversion of the second - -- parameter to the type of the formal of the procedure we are - -- calling. This deals with the private type cases, and with going - -- to the root type as required in elementary type case. - if not Is_Class_Wide_Type (Entity (Pref)) and then not Is_Class_Wide_Type (Etype (Item)) - and then Base_Type (Etype (Item)) /= Base_Type (Formal_Typ) + and then Base_Type (Item_Typ) /= Base_Type (Formal_Typ) then - Rewrite (Item, - Unchecked_Convert_To (Formal_Typ, Relocate_Node (Item))); + -- Perform a view conversion when either the argument or the + -- formal parameter are of a private type. + + if Is_Private_Type (Formal_Typ) + or else Is_Private_Type (Item_Typ) + then + Rewrite (Item, + Unchecked_Convert_To (Formal_Typ, Relocate_Node (Item))); + + -- Otherwise perform a regular type conversion to ensure that all + -- relevant checks are installed. + + else + Rewrite (Item, Convert_To (Formal_Typ, Relocate_Node (Item))); + end if; -- For untagged derived types set Assignment_OK, to prevent -- copies from being created when the unchecked conversion @@ -1665,7 +1673,7 @@ package body Exp_Attr is Rewrite (N, Make_Procedure_Call_Statement (Loc, - Name => New_Occurrence_Of (Pname, Loc), + Name => New_Occurrence_Of (Pname, Loc), Parameter_Associations => Exprs)); Analyze (N); diff --git a/gcc/ada/g-socket.adb b/gcc/ada/g-socket.adb index 75dc58de1a8..29ede344b04 100644 --- a/gcc/ada/g-socket.adb +++ b/gcc/ada/g-socket.adb @@ -50,8 +50,6 @@ package body GNAT.Sockets is package C renames Interfaces.C; - use type C.int; - ENOERROR : constant := 0; Netdb_Buffer_Size : constant := SOSC.Need_Netdb_Buffer * 1024; @@ -82,7 +80,7 @@ package body GNAT.Sockets is (Non_Blocking_IO => SOSC.FIONBIO, N_Bytes_To_Read => SOSC.FIONREAD); - Options : constant array (Option_Name) of C.int := + Options : constant array (Specific_Option_Name) of C.int := (Keep_Alive => SOSC.SO_KEEPALIVE, Reuse_Address => SOSC.SO_REUSEADDR, Broadcast => SOSC.SO_BROADCAST, @@ -98,7 +96,8 @@ package body GNAT.Sockets is Multicast_Loop => SOSC.IP_MULTICAST_LOOP, Receive_Packet_Info => SOSC.IP_PKTINFO, Send_Timeout => SOSC.SO_SNDTIMEO, - Receive_Timeout => SOSC.SO_RCVTIMEO); + Receive_Timeout => SOSC.SO_RCVTIMEO, + Busy_Polling => SOSC.SO_BUSY_POLL); -- ??? Note: for OpenSolaris, Receive_Packet_Info should be IP_RECVPKTINFO, -- but for Linux compatibility this constant is the same as IP_PKTINFO. @@ -1140,9 +1139,10 @@ package body GNAT.Sockets is ----------------------- function Get_Socket_Option - (Socket : Socket_Type; - Level : Level_Type := Socket_Level; - Name : Option_Name) return Option_Type + (Socket : Socket_Type; + Level : Level_Type := Socket_Level; + Name : Option_Name; + Optname : Interfaces.C.int := -1) return Option_Type is use SOSC; use type C.unsigned_char; @@ -1155,8 +1155,19 @@ package body GNAT.Sockets is Add : System.Address; Res : C.int; Opt : Option_Type (Name); + Onm : Interfaces.C.int; begin + if Name in Specific_Option_Name then + Onm := Options (Name); + + elsif Optname = -1 then + raise Socket_Error with "optname must be specified"; + + else + Onm := Optname; + end if; + case Name is when Multicast_Loop | Multicast_TTL | @@ -1164,14 +1175,16 @@ package body GNAT.Sockets is Len := V1'Size / 8; Add := V1'Address; - when Keep_Alive | - Reuse_Address | - Broadcast | - No_Delay | - Send_Buffer | - Receive_Buffer | - Multicast_If | - Error => + when Generic_Option | + Keep_Alive | + Reuse_Address | + Broadcast | + No_Delay | + Send_Buffer | + Receive_Buffer | + Multicast_If | + Error | + Busy_Polling => Len := V4'Size / 8; Add := V4'Address; @@ -1203,7 +1216,7 @@ package body GNAT.Sockets is C_Getsockopt (C.int (Socket), Levels (Level), - Options (Name), + Onm, Add, Len'Access); if Res = Failure then @@ -1211,12 +1224,19 @@ package body GNAT.Sockets is end if; case Name is - when Keep_Alive | - Reuse_Address | - Broadcast | - No_Delay => + when Generic_Option => + Opt.Optname := Onm; + Opt.Optval := V4; + + when Keep_Alive | + Reuse_Address | + Broadcast | + No_Delay => Opt.Enabled := (V4 /= 0); + when Busy_Polling => + Opt.Microseconds := Natural (V4); + when Linger => Opt.Enabled := (V8 (V8'First) /= 0); Opt.Seconds := Natural (V8 (V8'Last)); @@ -2267,17 +2287,28 @@ package body GNAT.Sockets is Len : C.int; Add : System.Address := Null_Address; Res : C.int; + Onm : C.int; begin case Option.Name is - when Keep_Alive | - Reuse_Address | - Broadcast | - No_Delay => + when Generic_Option => + V4 := Option.Optval; + Len := V4'Size / 8; + Add := V4'Address; + + when Keep_Alive | + Reuse_Address | + Broadcast | + No_Delay => V4 := C.int (Boolean'Pos (Option.Enabled)); Len := V4'Size / 8; Add := V4'Address; + when Busy_Polling => + V4 := C.int (Option.Microseconds); + Len := V4'Size / 8; + Add := V4'Address; + when Linger => V8 (V8'First) := C.int (Boolean'Pos (Option.Enabled)); V8 (V8'Last) := C.int (Option.Seconds); @@ -2347,10 +2378,20 @@ package body GNAT.Sockets is end case; + if Option.Name in Specific_Option_Name then + Onm := Options (Option.Name); + + elsif Option.Optname = -1 then + raise Socket_Error with "optname must be specified"; + + else + Onm := Option.Optname; + end if; + Res := C_Setsockopt (C.int (Socket), Levels (Level), - Options (Option.Name), + Onm, Add, Len); if Res = Failure then diff --git a/gcc/ada/g-socket.ads b/gcc/ada/g-socket.ads index 9957e2ca49b..d80f0ad2667 100644 --- a/gcc/ada/g-socket.ads +++ b/gcc/ada/g-socket.ads @@ -373,6 +373,9 @@ package GNAT.Sockets is -- entities declared therein are not meant for direct access by users, -- including through this renaming. + use type Interfaces.C.int; + -- Need visibility on "-" operator so that we can write -1 + procedure Initialize; pragma Obsolescent (Entity => Initialize, @@ -676,7 +679,8 @@ package GNAT.Sockets is -- a boolean to enable or disable this option. type Option_Name is - (Keep_Alive, -- Enable sending of keep-alive messages + (Generic_Option, + Keep_Alive, -- Enable sending of keep-alive messages Reuse_Address, -- Allow bind to reuse local address Broadcast, -- Enable datagram sockets to recv/send broadcasts Send_Buffer, -- Set/get the maximum socket send buffer in bytes @@ -691,10 +695,17 @@ package GNAT.Sockets is Multicast_Loop, -- Sent multicast packets are looped to local socket Receive_Packet_Info, -- Receive low level packet info as ancillary data Send_Timeout, -- Set timeout value for output - Receive_Timeout); -- Set timeout value for input + Receive_Timeout, -- Set timeout value for input + Busy_Polling); -- Set busy polling mode + subtype Specific_Option_Name is + Option_Name range Keep_Alive .. Option_Name'Last; type Option_Type (Name : Option_Name := Keep_Alive) is record case Name is + when Generic_Option => + Optname : Interfaces.C.int := -1; + Optval : Interfaces.C.int; + when Keep_Alive | Reuse_Address | Broadcast | @@ -711,6 +722,9 @@ package GNAT.Sockets is null; end case; + when Busy_Polling => + Microseconds : Natural; + when Send_Buffer | Receive_Buffer => Size : Natural; @@ -876,10 +890,12 @@ package GNAT.Sockets is -- No_Sock_Addr on error (e.g. socket closed or not locally bound). function Get_Socket_Option - (Socket : Socket_Type; - Level : Level_Type := Socket_Level; - Name : Option_Name) return Option_Type; - -- Get the options associated with a socket. Raises Socket_Error on error + (Socket : Socket_Type; + Level : Level_Type := Socket_Level; + Name : Option_Name; + Optname : Interfaces.C.int := -1) return Option_Type; + -- Get the options associated with a socket. Raises Socket_Error on error. + -- Optname identifies specific option when Name is Generic_Option. procedure Listen_Socket (Socket : Socket_Type; diff --git a/gcc/ada/g-sothco.ads b/gcc/ada/g-sothco.ads index 0d77dd75ef9..c25f4edc701 100644 --- a/gcc/ada/g-sothco.ads +++ b/gcc/ada/g-sothco.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2008-2014, AdaCore -- +-- Copyright (C) 2008-2016, AdaCore -- -- -- -- 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- -- @@ -41,9 +41,6 @@ package GNAT.Sockets.Thin_Common is package C renames Interfaces.C; - use type C.int; - -- This is so we can declare the Failure constant below - Success : constant C.int := 0; Failure : constant C.int := -1; diff --git a/gcc/ada/lib-writ.ads b/gcc/ada/lib-writ.ads index dce65f04eed..b38003be45c 100644 --- a/gcc/ada/lib-writ.ads +++ b/gcc/ada/lib-writ.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2016, 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- -- @@ -649,8 +649,10 @@ package Lib.Writ is -- AD Elaborate_All_Desirable set for this unit, which means that -- there is no Elaborate_All, but the analysis suggests that -- Program_Error may be raised if the Elaborate_All conditions - -- cannot be satisfied. The binder will attempt to treat AD as - -- EA if it can. + -- cannot be satisfied. In dynamic elaboration mode, the binder + -- will attempt to treat AD as EA if it can. In static + -- elaboration mode, the binder will treat AD as EA, even if it + -- introduces cycles. -- The parameter source-name and lib-name are omitted for the case of a -- generic unit compiled with earlier versions of GNAT which did not diff --git a/gcc/ada/s-oscons-tmplt.c b/gcc/ada/s-oscons-tmplt.c index d1b522d6701..26140170f4b 100644 --- a/gcc/ada/s-oscons-tmplt.c +++ b/gcc/ada/s-oscons-tmplt.c @@ -7,7 +7,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2000-2015, Free Software Foundation, Inc. -- +-- Copyright (C) 2000-2016, 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- -- @@ -1264,6 +1264,11 @@ CND(SO_RCVTIMEO, "Reception timeout") #endif CND(SO_ERROR, "Get/clear error status") +#ifndef SO_BUSY_POLL +# define SO_BUSY_POLL -1 +#endif +CND(SO_BUSY_POLL, "Busy polling") + #ifndef IP_MULTICAST_IF # define IP_MULTICAST_IF -1 #endif diff --git a/gcc/ada/sem_case.adb b/gcc/ada/sem_case.adb index f8368536c50..9a220bb6bb4 100644 --- a/gcc/ada/sem_case.adb +++ b/gcc/ada/sem_case.adb @@ -628,9 +628,11 @@ package body Sem_Case is -- Otherwise the expression is not static, even if the bounds of the -- type are, or else there are missing alternatives. If both, the - -- additional information may be redundant but harmless. + -- additional information may be redundant but harmless. Examine + -- whether original node is an entity, because it may have been + -- constant-folded to a literal if value is known. - elsif not Is_Entity_Name (Expr) then + elsif not Is_Entity_Name (Original_Node (Expr)) then Error_Msg_N ("subtype of expression is not static, " & "alternatives must cover base type!", Expr); @@ -1362,6 +1364,15 @@ package body Sem_Case is -- later entry into the choices table so that they can be sorted -- later on. + procedure Handle_Static_Predicate + (Typ : Entity_Id; + Lo : Node_Id; + Hi : Node_Id); + -- If the type of the alternative has predicates, we must examine + -- each subset of the predicate rather than the bounds of the + -- type itself. This is relevant when the choice is a subtype mark + -- or a subtype indication. + ----------- -- Check -- ----------- @@ -1474,6 +1485,56 @@ package body Sem_Case is Num_Choices := Num_Choices + 1; end Check; + ----------------------------- + -- Handle_Static_Predicate -- + ----------------------------- + + procedure Handle_Static_Predicate + (Typ : Entity_Id; + Lo : Node_Id; + Hi : Node_Id) + is + P : Node_Id; + C : Node_Id; + + begin + -- Loop through entries in predicate list, checking each entry. + -- Note that if the list is empty, corresponding to a False + -- predicate, then no choices are checked. If the choice comes + -- from a subtype indication, the given range may have bounds + -- that narrow the predicate choices themselves, so we must + -- consider only those entries within the range of the given + -- subtype indication.. + + P := First (Static_Discrete_Predicate (Typ)); + while Present (P) loop + + -- Check that part of the predicate choice is included in + -- the given bounds. + + if Expr_Value (High_Bound (P)) >= Expr_Value (Lo) + and then Expr_Value (Low_Bound (P)) <= Expr_Value (Hi) + then + C := New_Copy (P); + Set_Sloc (C, Sloc (Choice)); + + if Expr_Value (Low_Bound (C)) < Expr_Value (Lo) then + Set_Low_Bound (C, Lo); + end if; + + if Expr_Value (High_Bound (C)) > Expr_Value (Hi) then + Set_High_Bound (C, Hi); + end if; + + Check (C, Low_Bound (C), High_Bound (C)); + end if; + + Next (P); + end loop; + + Set_Has_SP_Choice (Alt); + end Handle_Static_Predicate; + -- Start of processing for Check_Choices begin @@ -1582,29 +1643,12 @@ package body Sem_Case is & "predicate as case alternative", Choice, E, Suggest_Static => True); - -- Static predicate case + -- Static predicate case. The bounds are + -- those of the given subtype. else - declare - P : Node_Id; - C : Node_Id; - - begin - -- Loop through entries in predicate list, - -- checking each entry. Note that if the - -- list is empty, corresponding to a False - -- predicate, then no choices are checked. - - P := First (Static_Discrete_Predicate (E)); - while Present (P) loop - C := New_Copy (P); - Set_Sloc (C, Sloc (Choice)); - Check (C, Low_Bound (C), High_Bound (C)); - Next (P); - end loop; - end; - - Set_Has_SP_Choice (Alt); + Handle_Static_Predicate (E, + Type_Low_Bound (E), Type_High_Bound (E)); end if; -- Not predicated subtype case @@ -1658,7 +1702,16 @@ package body Sem_Case is end if; end if; - Check (Choice, L, H); + if Has_Static_Predicate (E) then + + -- Check applicable predicate values within the + -- bounds of the given range. + + Handle_Static_Predicate (E, L, H); + + else + Check (Choice, L, H); + end if; end if; end; end if; diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb index 54fca501f48..f9b4698dafb 100644 --- a/gcc/ada/sem_ch8.adb +++ b/gcc/ada/sem_ch8.adb @@ -7744,9 +7744,9 @@ package body Sem_Ch8 is New_T := Etype (New_F); Old_T := Etype (Old_F); - -- If the new type is a renaming of the old one, as is the - -- case for actuals in instances, retain its name, to simplify - -- later disambiguation. + -- If the new type is a renaming of the old one, as is the case + -- for actuals in instances, retain its name, to simplify later + -- disambiguation. if Nkind (Parent (New_T)) = N_Subtype_Declaration and then Is_Entity_Name (Subtype_Indication (Parent (New_T))) @@ -7760,6 +7760,7 @@ package body Sem_Ch8 is Next_Formal (New_F); Next_Formal (Old_F); end loop; + pragma Assert (No (Old_F)); if Ekind_In (Old_S, E_Function, E_Enumeration_Literal) then diff --git a/gcc/ada/sem_elab.adb b/gcc/ada/sem_elab.adb index 66eaca70e27..7fa4845dac2 100644 --- a/gcc/ada/sem_elab.adb +++ b/gcc/ada/sem_elab.adb @@ -446,6 +446,15 @@ package body Sem_Elab is return; end if; + -- If an instance of a generic package contains a controlled object (so + -- we're calling Initialize at elaboration time), and the instance is in + -- a package body P that says "with P;", then we need to return without + -- adding "pragma Elaborate_All (P);" to P. + + if U = Main_Unit_Entity then + return; + end if; + Itm := First (CI); while Present (Itm) loop if Nkind (Itm) = N_With_Clause then @@ -495,10 +504,8 @@ package body Sem_Elab is end if; -- Here if we do not find with clause on spec or body. We just ignore - -- this case, it means that the elaboration involves some other unit + -- this case; it means that the elaboration involves some other unit -- than the unit being compiled, and will be caught elsewhere. - - null; end Activate_Elaborate_All_Desirable; ------------------ @@ -528,7 +535,7 @@ package body Sem_Elab is -- Generate a call to Error_Msg_NE with parameters Msg_D or Msg_S (for -- dynamic or static elaboration model), N and Ent. Msg_D is a real -- warning (output if Msg_D is non-null and Elab_Warnings is set), - -- Msg_S is an info message (output if Elab_Info_Messages is set. + -- Msg_S is an info message (output if Elab_Info_Messages is set). function Find_W_Scope return Entity_Id; -- Find top-level scope for called entity (not following renamings diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 4351f32c3c2..3e4fe0a62ff 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -24599,7 +24599,7 @@ package body Sem_Prag is In_Out_Items : Elist_Id := No_Elist; Out_Items : Elist_Id := No_Elist; Proof_In_Items : Elist_Id := No_Elist; - -- These list contain the entities of all Input, In_Out, Output and + -- These lists contain the entities of all Input, In_Out, Output and -- Proof_In items defined in the corresponding Global pragma. Repeat_Items : Elist_Id := No_Elist; @@ -24656,7 +24656,7 @@ package body Sem_Prag is procedure Collect_Global_Items (List : Node_Id; Mode : Name_Id := Name_Input); - -- Gather all input, in out, output and Proof_In items from node List + -- Gather all Input, In_Out, Output and Proof_In items from node List -- and separate them in lists In_Items, In_Out_Items, Out_Items and -- Proof_In_Items. Flags Has_In_State, Has_In_Out_State, Has_Out_State -- and Has_Proof_In_State are set when there is at least one abstract -- 2.30.2