-- 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.
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);
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;
-- --
-- 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- --
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);
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;
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);
projects / thirdparty / gcc.git / commitdiff
