+2015-11-18 Pascal Obry <obry@adacore.com>
+
+ * adaint.c, s-os_lib.adb, s-os_lib.ads (Kill_Process_Tree): New.
+
+2015-11-18 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * sem_util.adb (Check_Nonvolatile_Function_Profile): Place the error
+ message concerning the return type on the result definition.
+ (Is_Volatile_Function): A function with a parameter of a protected
+ type is a protected function if it is defined within a protected
+ definition.
+
+2015-11-18 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch4.adb (Try_Container_Indexing): When building the
+ parameter list for the function call on indexing functions,
+ preserve overloading of the parameters, which may themselves be
+ generalized indexing operations.
+
2015-11-13 Arnaud Charlet <charlet@adacore.com>
PR ada/68345
#include <windows.h>
#include <accctrl.h>
#include <aclapi.h>
+#include <tlhelp32.h>
#undef DIR_SEPARATOR
#define DIR_SEPARATOR '\\'
#endif
}
+void __gnat_killprocesstree (int pid, int sig_num)
+{
+#if defined(_WIN32)
+ HANDLE hWnd;
+ PROCESSENTRY32 pe;
+
+ memset(&pe, 0, sizeof(PROCESSENTRY32));
+ pe.dwSize = sizeof(PROCESSENTRY32);
+
+ HANDLE hSnap = CreateToolhelp32Snapshot (TH32CS_SNAPPROCESS, 0);
+
+ /* cannot take snapshot, just kill the parent process */
+
+ if (hSnap == INVALID_HANDLE_VALUE)
+ {
+ __gnat_kill (pid, sig_num, 1);
+ return;
+ }
+
+ if (Process32First(hSnap, &pe))
+ {
+ BOOL bContinue = TRUE;
+
+ /* kill child processes first */
+
+ while (bContinue)
+ {
+ if (pe.th32ParentProcessID == (int)pid)
+ __gnat_killprocesstree (pe.th32ProcessID, sig_num);
+
+ bContinue = Process32Next (hSnap, &pe);
+ }
+ }
+
+ CloseHandle (hSnap);
+
+ /* kill process */
+
+ __gnat_kill (pid, sig_num, 1);
+#else
+ DIR *dir;
+ struct dirent *d;
+
+ /* read all processes' pid and ppid */
+
+ dir = opendir ("/proc");
+
+ /* cannot open proc, just kill the parent process */
+
+ if (!dir)
+ {
+ __gnat_kill (pid, sig_num, 1);
+ return;
+ }
+
+ /* kill child processes first */
+
+ while (d = readdir (dir))
+ {
+ if ((d->d_type & DT_DIR) == DT_DIR)
+ {
+ char statfile[64] = { 0 };
+ int _pid, _ppid;
+
+ /* read /proc/<PID>/stat */
+
+ strncpy (statfile, "/proc/", sizeof(statfile));
+ strncat (statfile, d->d_name, sizeof(statfile));
+ strncat (statfile, "/stat", sizeof(statfile));
+
+ FILE *fd = fopen (statfile, "r");
+
+ if (fd)
+ {
+ const int match = fscanf (fd, "%d %*s %*s %d", &_pid, &_ppid);
+ fclose (fd);
+
+ if (match == 2 && _ppid == pid)
+ __gnat_killprocesstree (_pid, sig_num);
+ }
+ }
+ }
+
+ closedir (dir);
+
+ /* kill process */
+
+ __gnat_kill (pid, sig_num, 1);
+#endif
+ /* Note on Solaris it is possible to read /proc/<PID>/status.
+ The 5th and 6th words are the pid and the 7th and 8th the ppid.
+ See: /usr/include/sys/procfs.h (struct pstatus).
+ */
+}
+
#ifdef __cplusplus
}
#endif
end if;
end Kill;
+ -----------------------
+ -- Kill_Process_Tree --
+ -----------------------
+
+ procedure Kill_Process_Tree
+ (Pid : Process_Id; Hard_Kill : Boolean := True)
+ is
+ SIGKILL : constant := 9;
+ SIGINT : constant := 2;
+
+ procedure C_Kill_PT (Pid : Process_Id; Sig_Num : Integer);
+ pragma Import (C, C_Kill_PT, "__gnat_killprocesstree");
+
+ begin
+ if Hard_Kill then
+ C_Kill_PT (Pid, SIGKILL);
+ else
+ C_Kill_PT (Pid, SIGINT);
+ end if;
+ end Kill_Process_Tree;
+
-------------------------
-- Locate_Exec_On_Path --
-------------------------
-- POSIX OS or a ctrl-C event on Windows, allowing the process a chance to
-- terminate properly using a corresponding handler.
+ procedure Kill_Process_Tree (Pid : Process_Id; Hard_Kill : Boolean := True);
+ -- Kill the process designated by Pid and all it's children processes.
+ -- Does nothing if Pid is Invalid_Pid or on platforms where it is not
+ -- supported, such as VxWorks. Hard_Kill is True by default, and when True
+ -- the processes are terminated immediately. If Hard_Kill is False, then a
+ -- signal SIGINT is sent to the processes on POSIX OS or a ctrl-C event
+ -- on Windows, allowing the processes a chance to terminate properly
+ -- using a corresponding handler.
+ --
+ -- Note that this routine is not atomic and is supported only on Linux
+ -- and Windows. On other OS it will only kill the process identified by
+ -- Pid.
+
function Non_Blocking_Spawn
(Program_Name : String;
Args : Argument_List) return Process_Id;
Check_Compiler_Unit ("generalized indexing", N);
end if;
+ -- Create argument list for function call that represents generalized
+ -- indexing. Note that indices (i.e. actuals) may themselves be
+ -- overloaded.
+
declare
- Arg : Node_Id;
+ Arg : Node_Id;
+ New_Arg : Node_Id;
+
begin
Arg := First (Exprs);
while Present (Arg) loop
- Append (Relocate_Node (Arg), Assoc);
+ New_Arg := Relocate_Node (Arg);
+ Save_Interps (Arg, New_Arg);
+ Append (New_Arg, Assoc);
Next (Arg);
end loop;
end;
-- Inspect the return type
if Is_Effectively_Volatile (Etype (Func_Id)) then
- Error_Msg_N
+ Error_Msg_NE
("nonvolatile function & cannot have a volatile return type",
- Func_Id);
+ Result_Definition (Parent (Func_Id)), Func_Id);
end if;
end Check_Nonvolatile_Function_Profile;
if Is_Primitive (Func_Id)
and then Present (First_Formal (Func_Id))
and then Is_Protected_Type (Etype (First_Formal (Func_Id)))
+ and then Etype (First_Formal (Func_Id)) = Scope (Func_Id)
then
return True;
projects / gcc.git / commitdiff