From 022ed1787e398b279fa7afba30e4c9847d56bb9f Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Thu, 31 Jul 2014 12:13:59 +0200 Subject: [PATCH] [multiple changes] 2014-07-31 Ed Schonberg * exp_ch9.adb (Expand_N_Protected_Type_Declaration): New predicate Discriminated_Size, to distinguish between private components that depend on discriminants from those whose size depends on some other non-static expression. 2014-07-31 Nicolas Setton * g-exptty.adb (Close): Fix binding to Waitpid: use the tty version. From-SVN: r213341 --- gcc/ada/ChangeLog | 12 ++++++ gcc/ada/exp_ch9.adb | 93 ++++++++++++++++++++++++++++++++++++++++---- gcc/ada/g-exptty.adb | 24 +++++++----- 3 files changed, 111 insertions(+), 18 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index c4d668a1beb..8daa4dc2a37 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,15 @@ +2014-07-31 Ed Schonberg + + * exp_ch9.adb (Expand_N_Protected_Type_Declaration): New + predicate Discriminated_Size, to distinguish between private + components that depend on discriminants from those whose size + depends on some other non-static expression. + +2014-07-31 Nicolas Setton + + * g-exptty.adb (Close): Fix binding to Waitpid: use the + tty version. + 2014-07-31 Ed Schonberg * sem_ch3.adb (Make_Index): Reject properly the use of 'Length diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb index b3a45420970..cbd522e3608 100644 --- a/gcc/ada/exp_ch9.adb +++ b/gcc/ada/exp_ch9.adb @@ -8877,6 +8877,12 @@ package body Exp_Ch9 is -- to the internal body, for possible inlining later on. The source -- operation is invisible to the back-end and is never actually called. + function Discriminated_Size (Comp : Entity_Id) return Boolean; + -- If a component size is not static then a warning will be emitted + -- in Ravenscar or other restricted contexts. When a component is non- + -- static because of a discriminant constraint we can specialize the + -- warning by mentioning discriminants explicitly. + procedure Expand_Entry_Declaration (Comp : Entity_Id); -- Create the subprograms for the barrier and for the body, and append -- then to Entry_Bodies_Array. @@ -8904,9 +8910,65 @@ package body Exp_Ch9 is end if; end Check_Inlining; - --------------------------------- - -- Check_Static_Component_Size -- - --------------------------------- + ------------------------ + -- Discriminated_Size -- + ------------------------ + + function Discriminated_Size (Comp : Entity_Id) return Boolean + is + Typ : constant Entity_Id := Etype (Comp); + Index : Node_Id; + + function Non_Static_Bound (Bound : Node_Id) return Boolean; + -- Check whether the bound of an index is non-static and does + -- denote a discriminant, in which case any protected object of + -- the type will have a non-static size. + + ---------------------- + -- Non_Static_Bound -- + ---------------------- + + function Non_Static_Bound (Bound : Node_Id) return Boolean is + begin + if Is_Static_Expression (Bound) then + return False; + + elsif Is_Entity_Name (Bound) + and then Present (Discriminal_Link (Entity (Bound))) + then + return False; + + else + return True; + end if; + end Non_Static_Bound; + + begin + if not Is_Array_Type (Typ) then + return False; + end if; + + if Ekind (Typ) = E_Array_Subtype then + Index := First_Index (Typ); + while Present (Index) loop + if Non_Static_Bound (Low_Bound (Index)) + or else Non_Static_Bound (High_Bound (Index)) + then + return False; + end if; + + Next_Index (Index); + end loop; + + return True; + end if; + + return False; + end Discriminated_Size; + + --------------------------- + -- Static_Component_Size -- + --------------------------- function Static_Component_Size (Comp : Entity_Id) return Boolean is Typ : constant Entity_Id := Etype (Comp); @@ -9100,11 +9162,26 @@ package body Exp_Ch9 is Check_Restriction (No_Implicit_Heap_Allocations, Priv); elsif Restriction_Active (No_Implicit_Heap_Allocations) then - Error_Msg_N ("component has non-static size??", Priv); - Error_Msg_NE - ("\creation of protected object of type& will violate" - & " restriction No_Implicit_Heap_Allocations??", - Priv, Prot_Typ); + if not Discriminated_Size (Defining_Identifier (Priv)) + then + + -- Any object of the type will be non-static. + + Error_Msg_N ("component has non-static size??", Priv); + Error_Msg_NE + ("\creation of protected object of type& will" + & " violate restriction " + & "No_Implicit_Heap_Allocations??", Priv, Prot_Typ); + else + + -- Object will be non-static if discriminants are. + + Error_Msg_NE + ("creation of protected object of type& with " + & "non-static discriminants will violate" + & " restriction No_Implicit_Heap_Allocations??", + Priv, Prot_Typ); + end if; end if; end if; diff --git a/gcc/ada/g-exptty.adb b/gcc/ada/g-exptty.adb index 7ec04727d07..3e7819369a5 100644 --- a/gcc/ada/g-exptty.adb +++ b/gcc/ada/g-exptty.adb @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2000-2011, AdaCore -- +-- Copyright (C) 2000-2014, 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- -- @@ -50,7 +50,7 @@ package body GNAT.Expect.TTY is pragma Import (C, Terminate_Process, "__gnat_terminate_process"); function Waitpid (Process : System.Address) return Integer; - pragma Import (C, Waitpid, "__gnat_waitpid"); + pragma Import (C, Waitpid, "__gnat_tty_waitpid"); -- Wait for a specific process id, and return its exit code procedure Free_Process (Process : System.Address); @@ -66,6 +66,18 @@ package body GNAT.Expect.TTY is Status := -1; else + -- Send a Ctrl-C to the process first. This way, if the + -- launched process is a "sh" or "cmd", the child processes + -- will get terminated as well. Otherwise, terminating the + -- main process brutally will leave the children running. + -- + -- Note: special characters are sent to the terminal to generate + -- the signal, so this needs to be done while the file descriptors + -- are still open. + + Interrupt (Descriptor); + delay (0.05); + if Descriptor.Input_Fd /= Invalid_FD then Close (Descriptor.Input_Fd); end if; @@ -80,14 +92,6 @@ package body GNAT.Expect.TTY is Close (Descriptor.Output_Fd); end if; - -- Send a Ctrl-C to the process first. This way, if the - -- launched process is a "sh" or "cmd", the child processes - -- will get terminated as well. Otherwise, terminating the - -- main process brutally will leave the children running. - - Interrupt (Descriptor); - delay 0.05; - Terminate_Process (Descriptor.Process); Status := Waitpid (Descriptor.Process); -- 2.30.2