Skip to content

R
riscv-gcc-1
Commit ed3fe8cc by Arnaud Charlet
Options

[multiple changes] 

2017-01-06  Hristian Kirtchev  <kirtchev@adacore.com>

	* 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  <kirtchev@adacore.com>

	* sem_prag.adb, sem_ch8.adb: Minor reformatting.

2017-01-06  Ed Schonberg  <schonberg@adacore.com>

	* 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  <quinot@adacore.com>

	* 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  <duff@adacore.com>

	* 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  <gingold@adacore.com>

	* a-exexpr-gcc.adb: Improve comment.

From-SVN: r244125
parent 43934e8c
Showing with 243 additions and 71 deletions
gcc/ada/ChangeLog
2017-01-06 Hristian Kirtchev <kirtchev@adacore.com>
* 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 <kirtchev@adacore.com>
* sem_prag.adb, sem_ch8.adb: Minor reformatting.
2017-01-06 Ed Schonberg <schonberg@adacore.com>
* 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 <quinot@adacore.com>
* 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 <duff@adacore.com>
* 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 <gingold@adacore.com>
* a-exexpr-gcc.adb: Improve comment.
2017-01-03 James Cowgill <James.Cowgill@imgtec.com> 2017-01-03 James Cowgill <James.Cowgill@imgtec.com>
* s-linux-mips.ads: Use correct signal and errno constants. * s-linux-mips.ads: Use correct signal and errno constants.
......
gcc/ada/a-exexpr-gcc.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -115,7 +115,8 @@ package body Exception_Propagation is ...@@ -115,7 +115,8 @@ package body Exception_Propagation is
GCC_Exception : not null GCC_Exception_Access); GCC_Exception : not null GCC_Exception_Access);
pragma Export pragma Export
(C, Set_Exception_Parameter, "__gnat_set_exception_parameter"); (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); procedure Set_Foreign_Occurrence (Excep : EOA; Mo : System.Address);
-- Utility routine to initialize occurrence Excep from a foreign exception -- Utility routine to initialize occurrence Excep from a foreign exception
......
gcc/ada/ali-util.ads
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -24,7 +24,7 @@ ...@@ -24,7 +24,7 @@
------------------------------------------------------------------------------ ------------------------------------------------------------------------------
-- This child unit provides utility data structures and procedures used -- 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 package ALI.Util is
......
gcc/ada/ali.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -2056,8 +2056,7 @@ package body ALI is ...@@ -2056,8 +2056,7 @@ package body ALI is
-- Store AD indication unless ignore required -- Store AD indication unless ignore required
if not Ignore_ED then if not Ignore_ED then
Withs.Table (Withs.Last).Elab_All_Desirable := Withs.Table (Withs.Last).Elab_All_Desirable := True;
True;
end if; end if;
elsif Nextc = 'E' then elsif Nextc = 'E' then
......
gcc/ada/exp_attr.adb
...@@ -1568,9 +1568,10 @@ package body Exp_Attr is ...@@ -1568,9 +1568,10 @@ package body Exp_Attr is
procedure Rewrite_Stream_Proc_Call (Pname : Entity_Id) is procedure Rewrite_Stream_Proc_Call (Pname : Entity_Id) is
Item : constant Node_Id := Next (First (Exprs)); Item : constant Node_Id := Next (First (Exprs));
Item_Typ : constant Entity_Id := Etype (Item);
Formal : constant Entity_Id := Next_Formal (First_Formal (Pname)); Formal : constant Entity_Id := Next_Formal (First_Formal (Pname));
Formal_Typ : constant Entity_Id := Etype (Formal); 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 begin
-- The expansion depends on Item, the second actual, which is -- The expansion depends on Item, the second actual, which is
...@@ -1583,7 +1584,7 @@ package body Exp_Attr is ...@@ -1583,7 +1584,7 @@ package body Exp_Attr is
if Nkind (Item) = N_Indexed_Component if Nkind (Item) = N_Indexed_Component
and then Is_Packed (Base_Type (Etype (Prefix (Item)))) 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 and then Is_Written
then then
declare declare
...@@ -1595,8 +1596,7 @@ package body Exp_Attr is ...@@ -1595,8 +1596,7 @@ package body Exp_Attr is
Decl := Decl :=
Make_Object_Declaration (Loc, Make_Object_Declaration (Loc,
Defining_Identifier => Temp, Defining_Identifier => Temp,
Object_Definition => Object_Definition => New_Occurrence_Of (Formal_Typ, Loc));
New_Occurrence_Of (Formal_Typ, Loc));
Set_Etype (Temp, Formal_Typ); Set_Etype (Temp, Formal_Typ);
Assn := Assn :=
...@@ -1604,7 +1604,7 @@ package body Exp_Attr is ...@@ -1604,7 +1604,7 @@ package body Exp_Attr is
Name => New_Copy_Tree (Item), Name => New_Copy_Tree (Item),
Expression => Expression =>
Unchecked_Convert_To Unchecked_Convert_To
(Etype (Item), New_Occurrence_Of (Temp, Loc))); (Item_Typ, New_Occurrence_Of (Temp, Loc)));
Rewrite (Item, New_Occurrence_Of (Temp, Loc)); Rewrite (Item, New_Occurrence_Of (Temp, Loc));
Insert_Actions (N, Insert_Actions (N,
...@@ -1626,18 +1626,26 @@ package body Exp_Attr is ...@@ -1626,18 +1626,26 @@ package body Exp_Attr is
-- operation is not inherited), we are all set, and can use the -- operation is not inherited), we are all set, and can use the
-- argument unchanged. -- 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)) if not Is_Class_Wide_Type (Entity (Pref))
and then not Is_Class_Wide_Type (Etype (Item)) 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
-- 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 then
Rewrite (Item, Rewrite (Item,
Unchecked_Convert_To (Formal_Typ, Relocate_Node (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 -- For untagged derived types set Assignment_OK, to prevent
-- copies from being created when the unchecked conversion -- copies from being created when the unchecked conversion
-- is expanded (which would happen in Remove_Side_Effects -- is expanded (which would happen in Remove_Side_Effects
......
gcc/ada/g-socket.adb
...@@ -50,8 +50,6 @@ package body GNAT.Sockets is ...@@ -50,8 +50,6 @@ package body GNAT.Sockets is
package C renames Interfaces.C; package C renames Interfaces.C;
use type C.int;
ENOERROR : constant := 0; ENOERROR : constant := 0;
Netdb_Buffer_Size : constant := SOSC.Need_Netdb_Buffer * 1024; Netdb_Buffer_Size : constant := SOSC.Need_Netdb_Buffer * 1024;
...@@ -82,7 +80,7 @@ package body GNAT.Sockets is ...@@ -82,7 +80,7 @@ package body GNAT.Sockets is
(Non_Blocking_IO => SOSC.FIONBIO, (Non_Blocking_IO => SOSC.FIONBIO,
N_Bytes_To_Read => SOSC.FIONREAD); 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, (Keep_Alive => SOSC.SO_KEEPALIVE,
Reuse_Address => SOSC.SO_REUSEADDR, Reuse_Address => SOSC.SO_REUSEADDR,
Broadcast => SOSC.SO_BROADCAST, Broadcast => SOSC.SO_BROADCAST,
...@@ -98,7 +96,8 @@ package body GNAT.Sockets is ...@@ -98,7 +96,8 @@ package body GNAT.Sockets is
Multicast_Loop => SOSC.IP_MULTICAST_LOOP, Multicast_Loop => SOSC.IP_MULTICAST_LOOP,
Receive_Packet_Info => SOSC.IP_PKTINFO, Receive_Packet_Info => SOSC.IP_PKTINFO,
Send_Timeout => SOSC.SO_SNDTIMEO, 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, -- ??? Note: for OpenSolaris, Receive_Packet_Info should be IP_RECVPKTINFO,
-- but for Linux compatibility this constant is the same as IP_PKTINFO. -- but for Linux compatibility this constant is the same as IP_PKTINFO.
...@@ -1142,7 +1141,8 @@ package body GNAT.Sockets is ...@@ -1142,7 +1141,8 @@ package body GNAT.Sockets is
function Get_Socket_Option function Get_Socket_Option
(Socket : Socket_Type; (Socket : Socket_Type;
Level : Level_Type := Socket_Level; Level : Level_Type := Socket_Level;
Name : Option_Name) return Option_Type Name : Option_Name;
Optname : Interfaces.C.int := -1) return Option_Type
is is
use SOSC; use SOSC;
use type C.unsigned_char; use type C.unsigned_char;
...@@ -1155,8 +1155,19 @@ package body GNAT.Sockets is ...@@ -1155,8 +1155,19 @@ package body GNAT.Sockets is
Add : System.Address; Add : System.Address;
Res : C.int; Res : C.int;
Opt : Option_Type (Name); Opt : Option_Type (Name);
Onm : Interfaces.C.int;
begin 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 case Name is
when Multicast_Loop | when Multicast_Loop |
Multicast_TTL | Multicast_TTL |
...@@ -1164,14 +1175,16 @@ package body GNAT.Sockets is ...@@ -1164,14 +1175,16 @@ package body GNAT.Sockets is
Len := V1'Size / 8; Len := V1'Size / 8;
Add := V1'Address; Add := V1'Address;
when Keep_Alive | when Generic_Option |
Keep_Alive |
Reuse_Address | Reuse_Address |
Broadcast | Broadcast |
No_Delay | No_Delay |
Send_Buffer | Send_Buffer |
Receive_Buffer | Receive_Buffer |
Multicast_If | Multicast_If |
Error => Error |
Busy_Polling =>
Len := V4'Size / 8; Len := V4'Size / 8;
Add := V4'Address; Add := V4'Address;
...@@ -1203,7 +1216,7 @@ package body GNAT.Sockets is ...@@ -1203,7 +1216,7 @@ package body GNAT.Sockets is
C_Getsockopt C_Getsockopt
(C.int (Socket), (C.int (Socket),
Levels (Level), Levels (Level),
Options (Name), Onm,
Add, Len'Access); Add, Len'Access);
if Res = Failure then if Res = Failure then
...@@ -1211,12 +1224,19 @@ package body GNAT.Sockets is ...@@ -1211,12 +1224,19 @@ package body GNAT.Sockets is
end if; end if;
case Name is case Name is
when Generic_Option =>
Opt.Optname := Onm;
Opt.Optval := V4;
when Keep_Alive | when Keep_Alive |
Reuse_Address | Reuse_Address |
Broadcast | Broadcast |
No_Delay => No_Delay =>
Opt.Enabled := (V4 /= 0); Opt.Enabled := (V4 /= 0);
when Busy_Polling =>
Opt.Microseconds := Natural (V4);
when Linger => when Linger =>
Opt.Enabled := (V8 (V8'First) /= 0); Opt.Enabled := (V8 (V8'First) /= 0);
Opt.Seconds := Natural (V8 (V8'Last)); Opt.Seconds := Natural (V8 (V8'Last));
...@@ -2267,9 +2287,15 @@ package body GNAT.Sockets is ...@@ -2267,9 +2287,15 @@ package body GNAT.Sockets is
Len : C.int; Len : C.int;
Add : System.Address := Null_Address; Add : System.Address := Null_Address;
Res : C.int; Res : C.int;
Onm : C.int;
begin begin
case Option.Name is case Option.Name is
when Generic_Option =>
V4 := Option.Optval;
Len := V4'Size / 8;
Add := V4'Address;
when Keep_Alive | when Keep_Alive |
Reuse_Address | Reuse_Address |
Broadcast | Broadcast |
...@@ -2278,6 +2304,11 @@ package body GNAT.Sockets is ...@@ -2278,6 +2304,11 @@ package body GNAT.Sockets is
Len := V4'Size / 8; Len := V4'Size / 8;
Add := V4'Address; Add := V4'Address;
when Busy_Polling =>
V4 := C.int (Option.Microseconds);
Len := V4'Size / 8;
Add := V4'Address;
when Linger => when Linger =>
V8 (V8'First) := C.int (Boolean'Pos (Option.Enabled)); V8 (V8'First) := C.int (Boolean'Pos (Option.Enabled));
V8 (V8'Last) := C.int (Option.Seconds); V8 (V8'Last) := C.int (Option.Seconds);
...@@ -2347,10 +2378,20 @@ package body GNAT.Sockets is ...@@ -2347,10 +2378,20 @@ package body GNAT.Sockets is
end case; 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 Res := C_Setsockopt
(C.int (Socket), (C.int (Socket),
Levels (Level), Levels (Level),
Options (Option.Name), Onm,
Add, Len); Add, Len);
if Res = Failure then if Res = Failure then
......
gcc/ada/g-socket.ads
...@@ -373,6 +373,9 @@ package GNAT.Sockets is ...@@ -373,6 +373,9 @@ package GNAT.Sockets is
-- entities declared therein are not meant for direct access by users, -- entities declared therein are not meant for direct access by users,
-- including through this renaming. -- including through this renaming.
use type Interfaces.C.int;
-- Need visibility on "-" operator so that we can write -1
procedure Initialize; procedure Initialize;
pragma Obsolescent pragma Obsolescent
(Entity => Initialize, (Entity => Initialize,
...@@ -676,7 +679,8 @@ package GNAT.Sockets is ...@@ -676,7 +679,8 @@ package GNAT.Sockets is
-- a boolean to enable or disable this option. -- a boolean to enable or disable this option.
type Option_Name is 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 Reuse_Address, -- Allow bind to reuse local address
Broadcast, -- Enable datagram sockets to recv/send broadcasts Broadcast, -- Enable datagram sockets to recv/send broadcasts
Send_Buffer, -- Set/get the maximum socket send buffer in bytes Send_Buffer, -- Set/get the maximum socket send buffer in bytes
...@@ -691,10 +695,17 @@ package GNAT.Sockets is ...@@ -691,10 +695,17 @@ package GNAT.Sockets is
Multicast_Loop, -- Sent multicast packets are looped to local socket Multicast_Loop, -- Sent multicast packets are looped to local socket
Receive_Packet_Info, -- Receive low level packet info as ancillary data Receive_Packet_Info, -- Receive low level packet info as ancillary data
Send_Timeout, -- Set timeout value for output 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 type Option_Type (Name : Option_Name := Keep_Alive) is record
case Name is case Name is
when Generic_Option =>
Optname : Interfaces.C.int := -1;
Optval : Interfaces.C.int;
when Keep_Alive | when Keep_Alive |
Reuse_Address | Reuse_Address |
Broadcast | Broadcast |
...@@ -711,6 +722,9 @@ package GNAT.Sockets is ...@@ -711,6 +722,9 @@ package GNAT.Sockets is
null; null;
end case; end case;
when Busy_Polling =>
Microseconds : Natural;
when Send_Buffer | when Send_Buffer |
Receive_Buffer => Receive_Buffer =>
Size : Natural; Size : Natural;
...@@ -878,8 +892,10 @@ package GNAT.Sockets is ...@@ -878,8 +892,10 @@ package GNAT.Sockets is
function Get_Socket_Option function Get_Socket_Option
(Socket : Socket_Type; (Socket : Socket_Type;
Level : Level_Type := Socket_Level; Level : Level_Type := Socket_Level;
Name : Option_Name) return Option_Type; Name : Option_Name;
-- Get the options associated with a socket. Raises Socket_Error on error 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 procedure Listen_Socket
(Socket : Socket_Type; (Socket : Socket_Type;
......
gcc/ada/g-sothco.ads
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -41,9 +41,6 @@ package GNAT.Sockets.Thin_Common is ...@@ -41,9 +41,6 @@ package GNAT.Sockets.Thin_Common is
package C renames Interfaces.C; package C renames Interfaces.C;
use type C.int;
-- This is so we can declare the Failure constant below
Success : constant C.int := 0; Success : constant C.int := 0;
Failure : constant C.int := -1; Failure : constant C.int := -1;
......
gcc/ada/lib-writ.ads
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -649,8 +649,10 @@ package Lib.Writ is ...@@ -649,8 +649,10 @@ package Lib.Writ is
-- AD Elaborate_All_Desirable set for this unit, which means that -- AD Elaborate_All_Desirable set for this unit, which means that
-- there is no Elaborate_All, but the analysis suggests that -- there is no Elaborate_All, but the analysis suggests that
-- Program_Error may be raised if the Elaborate_All conditions -- Program_Error may be raised if the Elaborate_All conditions
-- cannot be satisfied. The binder will attempt to treat AD as -- cannot be satisfied. In dynamic elaboration mode, the binder
-- EA if it can. -- 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 -- 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 -- generic unit compiled with earlier versions of GNAT which did not
......
gcc/ada/s-oscons-tmplt.c
...@@ -7,7 +7,7 @@ ...@@ -7,7 +7,7 @@
-- -- -- --
-- S p e c -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -1264,6 +1264,11 @@ CND(SO_RCVTIMEO, "Reception timeout") ...@@ -1264,6 +1264,11 @@ CND(SO_RCVTIMEO, "Reception timeout")
#endif #endif
CND(SO_ERROR, "Get/clear error status") 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 #ifndef IP_MULTICAST_IF
# define IP_MULTICAST_IF -1 # define IP_MULTICAST_IF -1
#endif #endif
......
gcc/ada/sem_case.adb
...@@ -628,9 +628,11 @@ package body Sem_Case is ...@@ -628,9 +628,11 @@ package body Sem_Case is
-- Otherwise the expression is not static, even if the bounds of the -- Otherwise the expression is not static, even if the bounds of the
-- type are, or else there are missing alternatives. If both, 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 Error_Msg_N
("subtype of expression is not static, " ("subtype of expression is not static, "
& "alternatives must cover base type!", Expr); & "alternatives must cover base type!", Expr);
...@@ -1362,6 +1364,15 @@ package body Sem_Case is ...@@ -1362,6 +1364,15 @@ package body Sem_Case is
-- later entry into the choices table so that they can be sorted -- later entry into the choices table so that they can be sorted
-- later on. -- 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 -- -- Check --
----------- -----------
...@@ -1474,6 +1485,56 @@ package body Sem_Case is ...@@ -1474,6 +1485,56 @@ package body Sem_Case is
Num_Choices := Num_Choices + 1; Num_Choices := Num_Choices + 1;
end Check; 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 -- Start of processing for Check_Choices
begin begin
...@@ -1582,29 +1643,12 @@ package body Sem_Case is ...@@ -1582,29 +1643,12 @@ package body Sem_Case is
& "predicate as case alternative", & "predicate as case alternative",
Choice, E, Suggest_Static => True); Choice, E, Suggest_Static => True);
-- Static predicate case -- Static predicate case. The bounds are
-- those of the given subtype.
else else
declare Handle_Static_Predicate (E,
P : Node_Id; Type_Low_Bound (E), Type_High_Bound (E));
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);
end if; end if;
-- Not predicated subtype case -- Not predicated subtype case
...@@ -1658,8 +1702,17 @@ package body Sem_Case is ...@@ -1658,8 +1702,17 @@ package body Sem_Case is
end if; end if;
end if; end if;
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); Check (Choice, L, H);
end if; end if;
end if;
end; end;
end if; end if;
......
gcc/ada/sem_ch8.adb
...@@ -7744,9 +7744,9 @@ package body Sem_Ch8 is ...@@ -7744,9 +7744,9 @@ package body Sem_Ch8 is
New_T := Etype (New_F); New_T := Etype (New_F);
Old_T := Etype (Old_F); Old_T := Etype (Old_F);
-- If the new type is a renaming of the old one, as is the -- If the new type is a renaming of the old one, as is the case
-- case for actuals in instances, retain its name, to simplify -- for actuals in instances, retain its name, to simplify later
-- later disambiguation. -- disambiguation.
if Nkind (Parent (New_T)) = N_Subtype_Declaration if Nkind (Parent (New_T)) = N_Subtype_Declaration
and then Is_Entity_Name (Subtype_Indication (Parent (New_T))) and then Is_Entity_Name (Subtype_Indication (Parent (New_T)))
...@@ -7760,6 +7760,7 @@ package body Sem_Ch8 is ...@@ -7760,6 +7760,7 @@ package body Sem_Ch8 is
Next_Formal (New_F); Next_Formal (New_F);
Next_Formal (Old_F); Next_Formal (Old_F);
end loop; end loop;
pragma Assert (No (Old_F)); pragma Assert (No (Old_F));
if Ekind_In (Old_S, E_Function, E_Enumeration_Literal) then if Ekind_In (Old_S, E_Function, E_Enumeration_Literal) then
......
gcc/ada/sem_elab.adb
...@@ -446,6 +446,15 @@ package body Sem_Elab is ...@@ -446,6 +446,15 @@ package body Sem_Elab is
return; return;
end if; 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); Itm := First (CI);
while Present (Itm) loop while Present (Itm) loop
if Nkind (Itm) = N_With_Clause then if Nkind (Itm) = N_With_Clause then
...@@ -495,10 +504,8 @@ package body Sem_Elab is ...@@ -495,10 +504,8 @@ package body Sem_Elab is
end if; end if;
-- Here if we do not find with clause on spec or body. We just ignore -- 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. -- than the unit being compiled, and will be caught elsewhere.
null;
end Activate_Elaborate_All_Desirable; end Activate_Elaborate_All_Desirable;
------------------ ------------------
...@@ -528,7 +535,7 @@ package body Sem_Elab is ...@@ -528,7 +535,7 @@ package body Sem_Elab is
-- Generate a call to Error_Msg_NE with parameters Msg_D or Msg_S (for -- 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 -- 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), -- 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; function Find_W_Scope return Entity_Id;
-- Find top-level scope for called entity (not following renamings -- Find top-level scope for called entity (not following renamings
......
gcc/ada/sem_prag.adb
...@@ -24599,7 +24599,7 @@ package body Sem_Prag is ...@@ -24599,7 +24599,7 @@ package body Sem_Prag is
In_Out_Items : Elist_Id := No_Elist; In_Out_Items : Elist_Id := No_Elist;
Out_Items : Elist_Id := No_Elist; Out_Items : Elist_Id := No_Elist;
Proof_In_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. -- Proof_In items defined in the corresponding Global pragma.
Repeat_Items : Elist_Id := No_Elist; Repeat_Items : Elist_Id := No_Elist;
...@@ -24656,7 +24656,7 @@ package body Sem_Prag is ...@@ -24656,7 +24656,7 @@ package body Sem_Prag is
procedure Collect_Global_Items procedure Collect_Global_Items
(List : Node_Id; (List : Node_Id;
Mode : Name_Id := Name_Input); 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 -- 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 -- 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 -- and Has_Proof_In_State are set when there is at least one abstract
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment