From 36357cf398c9837313d3d62dbdc1e7b883f47135 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Tue, 25 Apr 2017 12:33:46 +0200 Subject: [PATCH] [multiple changes] 2017-04-25 Ed Schonberg * 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 * 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 * s-string.adb: Minor code clean-up. 2017-04-25 Bob Duff * 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 * prep.adb (Preprocess): Remove incorrect Assert. Current character can be ASCII.CR. From-SVN: r247177 --- gcc/ada/ChangeLog | 29 +++++++++++++++++++++++++++++ gcc/ada/adaint.c | 22 +++++++++++++++++++++- gcc/ada/adaint.h | 1 + gcc/ada/exp_unst.adb | 20 ++++++++++++++++++-- gcc/ada/prep.adb | 1 - gcc/ada/s-os_lib.adb | 22 ++++++++++++++++++++++ gcc/ada/s-os_lib.ads | 6 ++++++ gcc/ada/s-string.adb | 6 ++---- gcc/ada/sem_prag.adb | 32 +++++++++++--------------------- 9 files changed, 110 insertions(+), 29 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 3d5423ca866..4ed0c7443b7 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,32 @@ +2017-04-25 Ed Schonberg + + * 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 + + * 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 + + * s-string.adb: Minor code clean-up. + +2017-04-25 Bob Duff + + * 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 + + * prep.adb (Preprocess): Remove incorrect + Assert. Current character can be ASCII.CR. + 2017-04-25 Ed Schonberg * sem_prag.adb (Set_Convention_From_Pragma): Cleanup code for diff --git a/gcc/ada/adaint.c b/gcc/ada/adaint.c index bff875a6822..5cc84caedeb 100644 --- a/gcc/ada/adaint.c +++ b/gcc/ada/adaint.c @@ -2315,7 +2315,7 @@ __gnat_dup2 (int oldfd ATTRIBUTE_UNUSED, int newfd ATTRIBUTE_UNUSED) 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 @@ -2679,6 +2679,26 @@ __gnat_portable_wait (int *process_status) 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) { diff --git a/gcc/ada/adaint.h b/gcc/ada/adaint.h index 232b5eb4371..444e04d753c 100644 --- a/gcc/ada/adaint.h +++ b/gcc/ada/adaint.h @@ -233,6 +233,7 @@ extern int __gnat_is_symbolic_link (char *name); 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 *); diff --git a/gcc/ada/exp_unst.adb b/gcc/ada/exp_unst.adb index a3e433fedb8..62d9d339f20 100644 --- a/gcc/ada/exp_unst.adb +++ b/gcc/ada/exp_unst.adb @@ -35,6 +35,7 @@ with Opt; use Opt; 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; @@ -176,9 +177,24 @@ package body Exp_Unst is ---------------- 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; ----------------------- diff --git a/gcc/ada/prep.adb b/gcc/ada/prep.adb index 02256ec66c0..ef0712da6ac 100644 --- a/gcc/ada/prep.adb +++ b/gcc/ada/prep.adb @@ -1572,7 +1572,6 @@ package body Prep is 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; diff --git a/gcc/ada/s-os_lib.adb b/gcc/ada/s-os_lib.adb index 36064e97bd3..014f6b4d66b 100644 --- a/gcc/ada/s-os_lib.adb +++ b/gcc/ada/s-os_lib.adb @@ -1927,6 +1927,28 @@ package body System.OS_Lib is 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 -- ------------------------- diff --git a/gcc/ada/s-os_lib.ads b/gcc/ada/s-os_lib.ads index 21f9ec5556f..31e171b2f70 100644 --- a/gcc/ada/s-os_lib.ads +++ b/gcc/ada/s-os_lib.ads @@ -937,6 +937,12 @@ package System.OS_Lib is -- 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 -- ------------------------------------- diff --git a/gcc/ada/s-string.adb b/gcc/ada/s-string.adb index d6e32fb5157..88439ccf2bc 100644 --- a/gcc/ada/s-string.adb +++ b/gcc/ada/s-string.adb @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -38,7 +38,6 @@ package body System.Strings is ---------- 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); @@ -48,8 +47,7 @@ package body System.Strings is if Arg /= null then for J in Arg'Range loop - X := Arg (J); - Free (X); + Free (Arg (J)); end loop; end if; diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 70e20ab875d..7e13f52ab59 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -4218,10 +4218,10 @@ package body Sem_Prag is ----------------------------- 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 @@ -4240,14 +4240,21 @@ package body Sem_Prag is 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; @@ -4414,7 +4421,6 @@ package body Sem_Prag is declare E : constant Entity_Id := Defining_Entity (Subp_Decl); - H : constant Entity_Id := Homonym (E); begin if Class_Present (N) @@ -4425,22 +4431,6 @@ package body Sem_Prag is 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; -- 2.30.2