2017-04-25 Ed Schonberg <schonberg@adacore.com>
* sem_prag.adb (Inherits_Class_Wide_Pre): Cleanup code, handle
properly type derived from generic formal types, to handle
properly modified version of ACATS 4.1B
B611017.
2017-04-25 Javier Miranda <miranda@adacore.com>
* exp_unst.adb (Subp_Index): Adding missing
support for renamings and functions that return a constrained
array type (i.e. functions for which the frontend built a
procedure with an extra out parameter).
2017-04-25 Pascal Obry <obry@adacore.com>
* s-string.adb: Minor code clean-up.
2017-04-25 Bob Duff <duff@adacore.com>
* s-os_lib.ads, s-os_lib.adb (Non_Blocking_Wait_Process): New
procedure.
* adaint.h, adaint.c (__gnat_portable_no_block_wait): C support
function for Non_Blocking_Wait_Process.
2017-04-25 Bob Duff <duff@adacore.com>
* prep.adb (Preprocess): Remove incorrect
Assert. Current character can be ASCII.CR.
From-SVN: r247177
+2017-04-25 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_prag.adb (Inherits_Class_Wide_Pre): Cleanup code, handle
+ properly type derived from generic formal types, to handle
+ properly modified version of ACATS 4.1B B611017.
+
+2017-04-25 Javier Miranda <miranda@adacore.com>
+
+ * exp_unst.adb (Subp_Index): Adding missing
+ support for renamings and functions that return a constrained
+ array type (i.e. functions for which the frontend built a
+ procedure with an extra out parameter).
+
+2017-04-25 Pascal Obry <obry@adacore.com>
+
+ * s-string.adb: Minor code clean-up.
+
+2017-04-25 Bob Duff <duff@adacore.com>
+
+ * s-os_lib.ads, s-os_lib.adb (Non_Blocking_Wait_Process): New
+ procedure.
+ * adaint.h, adaint.c (__gnat_portable_no_block_wait): C support
+ function for Non_Blocking_Wait_Process.
+
+2017-04-25 Bob Duff <duff@adacore.com>
+
+ * prep.adb (Preprocess): Remove incorrect
+ Assert. Current character can be ASCII.CR.
+
2017-04-25 Ed Schonberg <schonberg@adacore.com>
* sem_prag.adb (Set_Convention_From_Pragma): Cleanup code for
RTPs. */
return -1;
#elif defined (__PikeOS__)
- /* Not supported. */
+ /* Not supported. */
return -1;
#elif defined (_WIN32)
/* Special case when oldfd and newfd are identical and are the standard
return pid;
}
+int
+__gnat_portable_no_block_wait (int *process_status)
+{
+ int status = 0;
+ int pid = 0;
+
+#if defined (__vxworks) || defined (__PikeOS__) || defined (_WIN32)
+ /* Not supported. */
+ status = -1;
+
+#else
+
+ pid = waitpid (-1, &status, WNOHANG);
+ status = status & 0xffff;
+#endif
+
+ *process_status = status;
+ return pid;
+}
+
void
__gnat_os_exit (int status)
{
extern int __gnat_portable_spawn (char *[]);
extern int __gnat_portable_no_block_spawn (char *[]);
extern int __gnat_portable_wait (int *);
+extern int __gnat_portable_no_block_wait (int *);
extern int __gnat_current_process_id (void);
extern char *__gnat_locate_exec (char *, char *);
extern char *__gnat_locate_exec_on_path (char *);
with Output; use Output;
with Rtsfind; use Rtsfind;
with Sem; use Sem;
+with Sem_Aux; use Sem_Aux;
with Sem_Ch8; use Sem_Ch8;
with Sem_Mech; use Sem_Mech;
with Sem_Res; use Sem_Res;
----------------
function Subp_Index (Sub : Entity_Id) return SI_Type is
+ E : Entity_Id := Sub;
+
begin
- pragma Assert (Is_Subprogram (Sub));
- return SI_Type (UI_To_Int (Subps_Index (Sub)));
+ pragma Assert (Is_Subprogram (E));
+
+ if Subps_Index (E) = Uint_0 then
+ E := Ultimate_Alias (E);
+
+ if Ekind (E) = E_Function
+ and then Rewritten_For_C (E)
+ and then Present (Corresponding_Procedure (E))
+ then
+ E := Corresponding_Procedure (E);
+ end if;
+ end if;
+
+ pragma Assert (Subps_Index (E) /= Uint_0);
+ return SI_Type (UI_To_Int (Subps_Index (E)));
end Subp_Index;
-----------------------
then
Start_Of_Processing := Token_Ptr + 2;
else
- pragma Assert (Sinput.Source (Token_Ptr) = ASCII.LF);
Start_Of_Processing := Token_Ptr + 1;
end if;
end if;
return Result;
end Non_Blocking_Spawn;
+ -------------------------------
+ -- Non_Blocking_Wait_Process --
+ -------------------------------
+
+ procedure Non_Blocking_Wait_Process
+ (Pid : out Process_Id; Success : out Boolean)
+ is
+ Status : Integer;
+
+ function Portable_No_Block_Wait (S : Address) return Process_Id;
+ pragma Import
+ (C, Portable_No_Block_Wait, "__gnat_portable_no_block_wait");
+
+ begin
+ Pid := Portable_No_Block_Wait (Status'Address);
+ Success := (Status = 0);
+
+ if Pid = 0 then
+ Pid := Invalid_Pid;
+ end if;
+ end Non_Blocking_Wait_Process;
+
-------------------------
-- Normalize_Arguments --
-------------------------
-- This function will always set success to False under VxWorks, since
-- there is no notion of executables under this OS.
+ procedure Non_Blocking_Wait_Process
+ (Pid : out Process_Id; Success : out Boolean);
+ -- Same as Wait_Process, except if there are no completed child processes,
+ -- return immediately without blocking, and return Invalid_Pid in Pid.
+ -- Not supported on all platforms; Success = False if not supported.
+
-------------------------------------
-- NOTE: Spawn in Tasking Programs --
-------------------------------------
-- --
-- B o d y --
-- --
--- Copyright (C) 1995-2013, Free Software Foundation, Inc. --
+-- Copyright (C) 1995-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- --
----------
procedure Free (Arg : in out String_List_Access) is
- X : String_Access;
procedure Free_Array is new Ada.Unchecked_Deallocation
(Object => String_List, Name => String_List_Access);
if Arg /= null then
for J in Arg'Range loop
- X := Arg (J);
- Free (X);
+ Free (Arg (J));
end loop;
end if;
-----------------------------
function Inherits_Class_Wide_Pre (E : Entity_Id) return Boolean is
- Prev : Entity_Id := Overridden_Operation (E);
+ Typ : constant Entity_Id := Find_Dispatching_Type (E);
+ Prev : Entity_Id := Overridden_Operation (E);
Cont : Node_Id;
Prag : Node_Id;
- Typ : Entity_Id;
begin
-- Check ancestors on the overriding operation to examine the
end loop;
end if;
- Prev := Overridden_Operation (Prev);
+ -- For a type derived from a generic formal type, the
+ -- operation inheriting the condition is a renaming, not
+ -- an overriding of the operation of the formal.
+
+ if Is_Generic_Type (Find_Dispatching_Type (Prev)) then
+ Prev := Alias (Prev);
+ else
+ Prev := Overridden_Operation (Prev);
+ end if;
end loop;
-- If the controlling type of the subprogram has progenitors, an
-- interface operation implemented by the current operation may
-- have a class-wide precondition.
- Typ := Find_Dispatching_Type (E);
if Has_Interfaces (Typ) then
declare
Elmt : Elmt_Id;
declare
E : constant Entity_Id := Defining_Entity (Subp_Decl);
- H : constant Entity_Id := Homonym (E);
begin
if Class_Present (N)
Error_Msg_N
("illegal class-wide precondition on overriding operation",
Corresponding_Aspect (N));
-
- -- If the operation is declared in the private part of an
- -- instance it may not override any visible operations, but
- -- still have a parent operation that carries a precondition.
-
- elsif In_Instance
- and then In_Private_Part (Current_Scope)
- and then Present (H)
- and then Scope (E) = Scope (H)
- and then Is_Inherited_Operation (H)
- and then Present (Overridden_Operation (H))
- and then not Inherits_Class_Wide_Pre (H)
- then
- Error_Msg_N
- ("illegal class-wide precondition on overriding "
- & "operation in instance", Corresponding_Aspect (N));
end if;
end;
projects / gcc.git / commitdiff