+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.
-- --
-- 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- --
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
-- --
-- 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- --
------------------------------------------------------------------------------
-- 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
-- --
-- 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- --
-- 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
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
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
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));
-- 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
Rewrite (N,
Make_Procedure_Call_Statement (Loc,
- Name => New_Occurrence_Of (Pname, Loc),
+ Name => New_Occurrence_Of (Pname, Loc),
Parameter_Associations => Exprs));
Analyze (N);
package C renames Interfaces.C;
- use type C.int;
-
ENOERROR : constant := 0;
Netdb_Buffer_Size : constant := SOSC.Need_Netdb_Buffer * 1024;
(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,
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.
-----------------------
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;
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 |
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;
C_Getsockopt
(C.int (Socket),
Levels (Level),
- Options (Name),
+ Onm,
Add, Len'Access);
if Res = Failure then
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));
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);
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
-- 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,
-- 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
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 |
null;
end case;
+ when Busy_Polling =>
+ Microseconds : Natural;
+
when Send_Buffer |
Receive_Buffer =>
Size : Natural;
-- 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;
-- --
-- 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- --
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;
-- --
-- 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- --
-- 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
-- --
-- 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- --
#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
-- 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);
-- 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 --
-----------
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
& "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
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;
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)))
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
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
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;
------------------
-- 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
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;
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
projects / gcc.git / commitdiff