[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
This commit is contained in:
Arnaud Charlet
parent
43934e8c1a
commit
ed3fe8cc27
@ -1,3 +1,45 @@
|
||||
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>
|
||||
|
||||
* s-linux-mips.ads: Use correct signal and errno constants.
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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);
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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;
|
||||
|
||||
@ -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;
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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;
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
Loading…
x
Reference in New Issue
Block a user