mirrors/ecl
1
Fork 0
mirror of https://gitlab.com/embeddable-common-lisp/ecl.git synced 2026-04-22 01:30:45 -07:00
Code Issues Projects Releases Packages Wiki Activity

Code to implement mp:interrupt-process in Windows:

Browse source 
* unixint.d: capture exceptions caused by page guards.
* unixint.d: to interrupt a Windows thread, set up a page guard onto the
  ECL environment and in addition queue an APC call that accesses the
  environment to trigger that exception.
* stacks.h: CL_CATCH_ALL uses _try/_except to enforce ECL's exception
  handler. Without it, Windows behaves randomly and sometimes uses the
  default handler and sometimes it simply aborts.
* threads.d: we use ordinary handlers to identify threads.
* time.d: SLEEP now uses Windows' SleepEx, leaving the thread in an
  alertable state -- that is, it can be interrupted.
* top.lsp: fixed and improved the code that handles console interrupts,
  by first using ordinary conditions and then using an interactive
  query function to decide which process to interrupt.
This commit is contained in:
Juan Jose Garcia Ripoll 2009-09-22 20:13:23 +02:00
parent 161926ac93
commit 78e9859bd2
13 changed files with 226 additions and 95 deletions
Download patch file Download diff file Expand all files Collapse all files

7
msvc/Makefile
View file

@ -10,8 +10,8 @@ srcdir = ..\src
SHORT_SITE_NAME =
LONG_SITE_NAME =
ECL_VERSION = 9.8.4
ECL_VERSION_NUMBER= 90804
ECL_VERSION = 9.9.1
ECL_VERSION_NUMBER= 90901
ARCHITECTURE = PENTIUM4
SOFTWARE_TYPE = NT
SOFTWARE_VERSION = 5.0
@ -26,6 +26,9 @@ THEHOST = win32
GMP_TYPE = gc
# Set it to non-empty to include Win32 thread support
# Currently it is NOT SUPPORTED to build ECL without threads. The reason
# is that certain exception handlers in Windows always use new threads.
# Without them, ECL would be an even more fragile piece of software.
ECL_THREADS = 1
# Set it to non-empty to include support for Unicode characters

3
msvc/ecl/config.h.msvc6
View file

@ -101,6 +101,9 @@
/* Use mprotect for fast interrupt dispatch */
/* #undef ECL_USE_MPROTECT */
#if defined(_MSC_VER) || defined(mingw32)
# define ECL_USE_GUARD_PAGE
#endif
/* Integer types */
#define ecl_uint8_t unsigned char

8
src/c/error.d
View file

@ -287,9 +287,6 @@ FEwin32_error(const char *msg, int narg, ...)
cl_object rest, win_msg_obj;
char *win_msg;
cl_va_start(args, narg, narg, 0);
rest = cl_grab_rest_args(args);
if (FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM|FORMAT_MESSAGE_ALLOCATE_BUFFER,
0, GetLastError(), 0, (void*)&win_msg, 0, NULL) == 0)
win_msg_obj = make_simple_base_string("[Unable to get error message]");
@ -298,7 +295,10 @@ FEwin32_error(const char *msg, int narg, ...)
LocalFree(win_msg);
}
FEerror("~?~%Explanation: ~A.", 3, make_constant_base_string(msg), rest,
cl_va_start(args, narg, narg, 0);
rest = cl_grab_rest_args(args);
FEerror("~?~%Explanation: ~A.", 3,
make_constant_base_string(msg), rest,
win_msg_obj);
}
#endif

3
src/c/main.d
View file

@ -302,7 +302,8 @@ _ecl_alloc_env()
ecl_internal_error("Unable to allocate environment structure.");
#else
# if defined(ECL_USE_GUARD_PAGE)
output = VirtualAlloc(0, sizeof(*output), MEM_COMMIT);
output = VirtualAlloc(0, sizeof(*output), MEM_COMMIT,
PAGE_READWRITE);
if (output == NULL)
ecl_internal_error("Unable to allocate environment structure.");
# else

64
src/c/threads.d
View file

@ -19,7 +19,9 @@
#ifndef __sun__ /* See unixinit.d for this */
#define _XOPEN_SOURCE 600 /* For pthread mutex attributes */
#endif
#if !defined(_MSC_VER) && !defined(mingw32)
#if defined(_MSC_VER) || defined(mingw32)
# include <windows.h>
#else
# include <pthread.h>
#endif
#include <errno.h>
@ -52,12 +54,10 @@ extern HANDLE WINAPI GC_CreateThread(
# ifndef WITH___THREAD
DWORD cl_env_key;
# endif
static DWORD main_thread;
#else
# ifndef WITH___THREAD
static pthread_key_t cl_env_key;
# endif
static pthread_t main_thread;
static pthread_attr_t pthreadattr;
static pthread_mutexattr_t mutexattr_error, mutexattr_recursive;
#endif /* _MSC_VER || mingw32 */
@ -136,6 +136,11 @@ thread_cleanup(void *aux)
process->process.env = NULL;
}
#ifdef ECL_WINDOWS_THREADS
extern LONG WINAPI
_ecl_w32_exception_filter(struct _EXCEPTION_POINTERS* ep);
#endif
#ifdef ECL_WINDOWS_THREADS
static DWORD WINAPI thread_entry_point(void *arg)
#else
@ -146,10 +151,10 @@ thread_entry_point(void *arg)
cl_object process = (cl_object)arg;
cl_env_ptr env;
/* 1) Setup the environment for the execution of the thread */
#ifndef ECL_WINDOWS_THREADS
pthread_cleanup_push(thread_cleanup, (void *)process);
#endif
/* 1) Setup the environment for the execution of the thread */
process->process.env = env = _ecl_alloc_env();
env->own_process = process;
ecl_set_process_env(env);
@ -159,7 +164,7 @@ thread_entry_point(void *arg)
ecl_init_env(env);
env->bindings_hash = process->process.initial_bindings;
ecl_enable_interrupts_env(env);
env->trap_fpe_bits = process->process.parent->process.env->trap_fpe_bits;
env->trap_fpe_bits = process->process.trap_fpe_bits;
si_trap_fpe(@'last', Ct);
/* 2) Execute the code. The CATCH_ALL point is the destination
@ -219,9 +224,22 @@ ecl_import_current_thread(cl_object name, cl_object bindings)
pthread_t current;
cl_env_ptr env;
#ifdef ECL_WINDOWS_THREADS
current = GetCurrentThread();
{
HANDLE aux = GetCurrentThread();
DuplicateHandle(GetCurrentProcess(),
aux,
GetCurrentProcess(),
&current,
0,
FALSE,
DUPLICATE_SAME_ACCESS);
CloseHandle(current);
}
#else
current = pthread_self();
#endif
#ifdef GBC_BOEHM
GC_register_my_thread((void*)&name);
#endif
for (l = cl_core.processes; l != Cnil; l = ECL_CONS_CDR(l)) {
cl_object p = ECL_CONS_CAR(l);
@ -240,6 +258,8 @@ ecl_import_current_thread(cl_object name, cl_object bindings)
THREAD_OP_UNLOCK();
ecl_init_env(env);
env->bindings_hash = process->process.initial_bindings;
mp_get_lock(1, process->process.exit_lock);
process->process.active = 1;
ecl_enable_interrupts_env(env);
return 1;
}
@ -248,6 +268,9 @@ void
ecl_release_current_thread(void)
{
thread_cleanup(ecl_process_env()->own_process);
#ifdef GBC_BOEHM
GC_unregister_my_thread();
#endif
}
@(defun mp::make-process (&key name ((:initial-bindings initial_bindings) Ct))
@ -285,7 +308,7 @@ mp_suspend_loop()
cl_env_ptr env = ecl_process_env();
CL_CATCH_BEGIN(env,@'mp::suspend-loop') {
for ( ; ; ) {
cl_sleep(MAKE_FIXNUM(1000));
cl_sleep(MAKE_FIXNUM(100));
}
} CL_CATCH_END;
}
@ -342,6 +365,8 @@ mp_process_enable(cl_object process)
if (mp_process_active_p(process) != Cnil)
FEerror("Cannot enable the running process ~A.", 1, process);
process->process.parent = mp_current_process();
process->process.trap_fpe_bits =
process->process.parent->process.env->trap_fpe_bits;
code = (HANDLE)CreateThread(NULL, 0, thread_entry_point, process, 0, &threadId);
output = (process->process.thread = code)? process : Cnil;
#else
@ -374,11 +399,6 @@ mp_process_enable(cl_object process)
cl_object
mp_exit_process(void)
{
#ifdef ECL_WINDOWS_THREADS
int same = GetCurrentThreadId() == main_thread;
#else
int same = pthread_equal(pthread_self(), main_thread);
#endif
/* We simply undo the whole of the frame stack. This brings up
back to the thread entry point, going through all possible
UNWIND-PROTECT.
@ -580,13 +600,13 @@ mp_giveup_lock(cl_object lock)
}
if (--lock->lock.counter == 0) {
lock->lock.holder = Cnil;
}
#ifdef ECL_WINDOWS_THREADS
if (ReleaseMutex(lock->lock.mutex) == 0)
FEwin32_error("Unable to release Win32 Mutex", 0);
if (ReleaseMutex(lock->lock.mutex) == 0)
FEwin32_error("Unable to release Win32 Mutex", 0);
#else
pthread_mutex_unlock(&lock->lock.mutex);
pthread_mutex_unlock(&lock->lock.mutex);
#endif
}
@(return Ct)
}
@ -764,6 +784,7 @@ void
init_threads(cl_env_ptr env)
{
cl_object process;
pthread_t main_thread;
#ifdef ECL_WINDOWS_THREADS
cl_core.global_lock = CreateMutex(NULL, FALSE, NULL);
@ -790,7 +811,16 @@ init_threads(cl_env_ptr env)
ecl_set_process_env(env);
#ifdef ECL_WINDOWS_THREADS
main_thread = GetCurrentThreadId();
{
HANDLE aux = GetCurrentThread();
DuplicateHandle(GetCurrentProcess(),
aux,
GetCurrentProcess(),
&main_thread,
0,
FALSE,
DUPLICATE_SAME_ACCESS);
}
#else
main_thread = pthread_self();
#endif

2
src/c/time.d
View file

@ -142,7 +142,7 @@ cl_sleep(cl_object z)
#if defined (mingw32) || defined(_MSC_VER)
{
double r = ecl_to_double(z) * 1000;
Sleep((long)r);
SleepEx((long)r, TRUE);
}
#else
z = ecl_round1(z);

122
src/c/unixint.d
View file

@ -88,6 +88,7 @@
#endif
#if defined(mingw32) || defined(_MSC_VER)
# include <windows.h>
# define ECL_WINDOWS_THREADS
#endif
#if !defined(_MSC_VER)
# include <unistd.h>
@ -383,10 +384,10 @@ si_handle_signal(cl_object signal_code)
static void
create_signal_queue(cl_index size)
{
cl_object base = cl_make_list(2, MAKE_FIXNUM(size));
cl_object base = cl_make_list(1, MAKE_FIXNUM(size));
#ifdef ECL_THREADS
{
cl_object lock = mp_make_lock(0);
cl_object lock = mp_make_lock(2, @':name', @'mp::interrupt-process');
mp_get_lock(1, lock);
cl_core.signal_queue = base;
cl_core.signal_queue_lock = lock;
@ -410,7 +411,7 @@ queue_signal(cl_env_ptr env, cl_object code)
mp_get_lock(1, lock);
#endif
record = cl_core.signal_queue;
cl_core.signal_queue = ECL_CDR(record);
cl_core.signal_queue = CDR(record);
#ifdef ECL_THREADS
mp_giveup_lock(lock);
#endif
@ -637,6 +638,14 @@ si_catch_signal(cl_object code, cl_object boolean)
}
#ifdef ECL_THREADS
static VOID CALLBACK
wakeup_function(ULONG_PTR foo)
{
cl_env_ptr env = ecl_process_env();
volatile i = env->nvalues;
env->nvalues = i;
}
static bool
do_interrupt_thread(cl_object process)
{
@ -644,24 +653,60 @@ do_interrupt_thread(cl_object process)
# ifndef ECL_USE_GUARD_PAGE
# error "Cannot implement ecl_interrupt_process without guard pages"
# endif
HANDLE thread = process->process.thread;
HANDLE thread = (HANDLE)process->process.thread;
CONTEXT context;
void *trap_address = process->process.env;
int ok = 0;
if (SuspendThread(thread) == (DWORD)-1) goto EXIT;
DWORD guard = PAGE_GUARD | PAGE_READWRITE;
int ok = 1;
if (SuspendThread(thread) == (DWORD)-1) {
FEwin32_error("Unable to suspend thread ~A", 1,
process);
ok = 0;
goto EXIT;
}
#if 0
context.ContextFlags = CONTEXT_FULL;
if (!GetThreadContext(thread, &context)) goto RESUME;
if (!GetThreadContext(thread, &context)) {
FEwin32_error("Unable to query context in thread ~A", 1,
process);
ok = 0;
goto RESUME;
}
# ifdef _AMD64_
trap_address = context.Rsp;
trap_address = (void*)context.Rsp;
# endif
# ifdef _X86_
trap_address = context.Esp;
trap_address = (void*)context.Esp;
# endif
process->process.interrupt = Ct;
VirtualProtect(trap_address, 1, PAGE_GUARD, NULL);
if (!VirtualProtect(trap_address, 1, guard, &guard)) {
FEwin32_error("Unable to protect memory from thread ~A",
1, process);
ok = 0;
#else
process->process.interrupt = Ct;
if (!VirtualProtect(process->process.env,
sizeof(struct cl_env_struct),
guard,
&guard))
{
FEwin32_error("Unable to protect memory from thread ~A",
1, process);
ok = 0;
}
#endif
RESUME:
if (ResumeThread(thread) == (DWORD)-1) goto EXIT;
ok = 1;
if (!QueueUserAPC(wakeup_function, thread, 0)) {
FEwin32_error("Unable to queue APC call to thread ~A",
1, process);
ok = 0;
}
if (ResumeThread(thread) == (DWORD)-1) {
FEwin32_error("Unable to resume thread ~A", 1,
process);
ok = 0;
goto EXIT;
}
EXIT:
return ok;
# else
@ -699,14 +744,28 @@ ecl_interrupt_process(cl_object process, cl_object function)
#ifdef ECL_WINDOWS_THREADS
static LPTOP_LEVEL_EXCEPTION_FILTER old_W32_exception_filter = NULL;
static LONG WINAPI
W32_exception_filter(struct _EXCEPTION_POINTERS* ep)
LONG WINAPI
_ecl_w32_exception_filter(struct _EXCEPTION_POINTERS* ep)
{
LONG excpt_result;
excpt_result = EXCEPTION_CONTINUE_EXECUTION;
switch (ep->ExceptionRecord->ExceptionCode)
{
/* Access to guard page */
case STATUS_GUARD_PAGE_VIOLATION: {
cl_env_ptr env = ecl_process_env();
cl_object process = env->own_process;
if (!Null(process->process.interrupt)) {
cl_object signal = pop_signal(env);
process->process.interrupt = Cnil;
while (signal != Cnil && signal) {
handle_signal_now(signal);
signal = pop_signal(env);
}
return EXCEPTION_CONTINUE_EXECUTION;
}
}
/* Catch all arithmetic exceptions */
case EXCEPTION_INT_DIVIDE_BY_ZERO:
handle_or_queue(@'division-by-zero', 0);
@ -741,21 +800,6 @@ W32_exception_filter(struct _EXCEPTION_POINTERS* ep)
case EXCEPTION_ILLEGAL_INSTRUCTION:
handle_or_queue(MAKE_FIXNUM(SIGILL), 0);
return EXCEPTION_CONTINUE_EXECUTION;
/* Access to guard page */
case STATUS_GUARD_PAGE_VIOLATION: {
cl_env_ptr env = ecl_process_env();
cl_object process = process->process.interrupt;
if (!Null(process->process.interrupt)) {
cl_object signal = pop_signal(the_env);
process->process.interrupt = Cnil;
while (signal != Cnil && signal) {
handle_signal_now(signal);
signal = pop_signal(the_env);
}
return EXCEPTION_CONTINUE_EXECUTION;
}
break;
}
/* Do not catch anything else */
default:
excpt_result = EXCEPTION_CONTINUE_SEARCH;
@ -770,10 +814,9 @@ static cl_object
W32_handle_in_new_thread(cl_object signal_code)
{
int outside_ecl = ecl_import_current_thread(@'si::handle-signal', Cnil);
mp_process_run_function(3, @'si::handle-signal', @'si::handle-signal',
mp_process_run_function(3, @'si::handle-signal',
@'si::handle-signal',
signal_code);
if (outside_ecl) ecl_release_current_thread();
}
@ -782,13 +825,16 @@ BOOL WINAPI W32_console_ctrl_handler(DWORD type)
switch (type)
{
/* Catch CTRL-C */
case CTRL_C_EVENT:
W32_handle_in_new_thread(@'si::terminal-interrupt');
return TRUE;
case CTRL_C_EVENT: {
cl_object function = SYM_FUN(@'si::terminal-interrupt');
if (function)
W32_handle_in_new_thread(function);
return TRUE;
}
}
return FALSE;
}
#endif
#endif /* ECL_WINDOWS_THREADS */
#if defined(ECL_THREADS) && defined(HAVE_SIGPROCMASK)
static cl_object
@ -919,9 +965,9 @@ install_asynchronous_signal_handlers()
pthread_sigmask(SIG_SETMASK, &sigmask, NULL);
cl_core.default_sigmask = &sigmask;
#endif
#ifdef _MSC_VER
#ifdef ECL_WINDOWS_THREADS
old_W32_exception_filter =
SetUnhandledExceptionFilter(W32_exception_filter);
SetUnhandledExceptionFilter(_ecl_w32_exception_filter);
if (ecl_get_option(ECL_OPT_TRAP_SIGINT)) {
SetConsoleCtrlHandler(W32_console_ctrl_handler, TRUE);
}

18
src/configure vendored
View file

@ -1,7 +1,7 @@
#! /bin/sh
# From configure.in Revision.
# Guess values for system-dependent variables and create Makefiles.
# Generated by GNU Autoconf 2.63 for ecl 9.8.4.
# Generated by GNU Autoconf 2.63 for ecl 9.9.1.
#
# Copyright (C) 1992, 1993, 1994, 1995, 1996, 1998, 1999, 2000, 2001,
# 2002, 2003, 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc.
@ -595,8 +595,8 @@ SHELL=${CONFIG_SHELL-/bin/sh}
# Identity of this package.
PACKAGE_NAME='ecl'
PACKAGE_TARNAME='ecl'
PACKAGE_VERSION='9.8.4'
PACKAGE_STRING='ecl 9.8.4'
PACKAGE_VERSION='9.9.1'
PACKAGE_STRING='ecl 9.9.1'
PACKAGE_BUGREPORT=''
ac_unique_file="bare.lsp.in"
@ -1369,7 +1369,7 @@ if test "$ac_init_help" = "long"; then
# Omit some internal or obsolete options to make the list less imposing.
# This message is too long to be a string in the A/UX 3.1 sh.
cat <<_ACEOF
\`configure' configures ecl 9.8.4 to adapt to many kinds of systems.
\`configure' configures ecl 9.9.1 to adapt to many kinds of systems.
Usage: $0 [OPTION]... [VAR=VALUE]...
@ -1438,7 +1438,7 @@ fi
if test -n "$ac_init_help"; then
case $ac_init_help in
short | recursive ) echo "Configuration of ecl 9.8.4:";;
short | recursive ) echo "Configuration of ecl 9.9.1:";;
esac
cat <<\_ACEOF
@ -1593,7 +1593,7 @@ fi
test -n "$ac_init_help" && exit $ac_status
if $ac_init_version; then
cat <<\_ACEOF
ecl configure 9.8.4
ecl configure 9.9.1
generated by GNU Autoconf 2.63
Copyright (C) 1992, 1993, 1994, 1995, 1996, 1998, 1999, 2000, 2001,
@ -1607,7 +1607,7 @@ cat >config.log <<_ACEOF
This file contains any messages produced by compilers while
running configure, to aid debugging if configure makes a mistake.
It was created by ecl $as_me 9.8.4, which was
It was created by ecl $as_me 9.9.1, which was
generated by GNU Autoconf 2.63. Invocation command line was
$ $0 $@
@ -14242,7 +14242,7 @@ exec 6>&1
# report actual input values of CONFIG_FILES etc. instead of their
# values after options handling.
ac_log="
This file was extended by ecl $as_me 9.8.4, which was
This file was extended by ecl $as_me 9.9.1, which was
generated by GNU Autoconf 2.63. Invocation command line was
CONFIG_FILES = $CONFIG_FILES
@ -14301,7 +14301,7 @@ Report bugs to <bug-autoconf@gnu.org>."
_ACEOF
cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1
ac_cs_version="\\
ecl config.status 9.8.4
ecl config.status 9.9.1
configured by $0, generated by GNU Autoconf 2.63,
with options \\"`$as_echo "$ac_configure_args" | sed 's/^ //; s/[\\""\`\$]/\\\\&/g'`\\"

2
src/configure.in
View file

@ -8,7 +8,7 @@ dnl AUTOCONF configuration for ECL
dnl Giuseppe Attardi 25.1.1994
dnl
AC_INIT([ecl],[9.8.4],[])
AC_INIT([ecl],[9.9.1],[])
AC_REVISION([$Revision$])
AC_CONFIG_SRCDIR([bare.lsp.in])
AC_CONFIG_AUX_DIR([${srcdir}/gmp])

6
src/h/external.h
View file

@ -127,6 +127,9 @@ struct cl_env_struct {
/* Floating point interrupts which are trapped */
int trap_fpe_bits;
/* Old exception filter. Needed by windows. */
void *old_exception_filter;
};
#ifndef __GNUC__
@ -1717,6 +1720,9 @@ extern ECL_API cl_object si_check_pending_interrupts(void);
extern ECL_API cl_object si_disable_interrupts(void);
extern ECL_API cl_object si_enable_interrupts(void);
extern ECL_API cl_object si_trap_fpe(cl_object condition, cl_object flag);
#if defined(_MSC_VER) || defined(mingw32)
extern LONG WINAPI _ecl_w32_exception_filter(struct _EXCEPTION_POINTERS*);
#endif
extern ECL_API void ecl_check_pending_interrupts(void);
/* unixsys.c */

1
src/h/object.h
View file

@ -835,6 +835,7 @@ struct ecl_process {
cl_object initial_bindings;
cl_object parent;
cl_object exit_lock;
int trap_fpe_bits;
};
struct ecl_lock {

22
src/h/stacks.h
View file

@ -309,14 +309,26 @@ extern ECL_API ecl_frame_ptr _ecl_frs_push(register cl_env_ptr, register cl_obje
#define CL_CATCH_END } \
ecl_frs_pop(__the_env); } while (0)
#define CL_CATCH_ALL_BEGIN(the_env) do { \
#if defined(_MSC_VER)
# define CL_CATCH_ALL_BEGIN(the_env) do { \
const cl_env_ptr __the_env = (the_env); \
_try { \
const cl_env_ptr __the_env = (the_env); \
if (ecl_frs_push(__the_env,ECL_PROTECT_TAG) == 0) {
# define CL_CATCH_ALL_IF_CAUGHT } else {
# define CL_CATCH_ALL_END }} \
_except(_ecl_w32_exception_filter(GetExceptionInformation())) \
{ (void)0; } \
ecl_frs_pop(__the_env); } while(0)
#else
# define CL_CATCH_ALL_BEGIN(the_env) do { \
const cl_env_ptr __the_env = (the_env); \
if (ecl_frs_push(__the_env,ECL_PROTECT_TAG) == 0) {
#define CL_CATCH_ALL_IF_CAUGHT } else {
#define CL_CATCH_ALL_END } \
# define CL_CATCH_ALL_IF_CAUGHT } else {
# define CL_CATCH_ALL_END } \
ecl_frs_pop(__the_env); } while(0)
#endif
#ifdef __cplusplus
}

63
src/lsp/top.lsp
View file

@ -477,8 +477,46 @@ under certain conditions; see file 'Copyright' for details.")
(defun simple-terminal-interrupt ()
(let ((*break-enable* t))
(format t "Signalling console interrupt")
(error "Console interrupt -- cannot continue.")))
(error 'ext:interactive-interrupt)))
#+threads
(defun apply-process-filter (process-filter process)
(declare (si::c-local))
(typecase process-filter
((null) nil)
((cons) (member process process-filter :test #'eq))
((or symbol function)
(funcall process-filter process))
((t) (eq process process-filter))))
#+threads
(defun show-process-list (&optional process-filter)
(loop with current = mp:*current-process*
with rank = 1
for process in (mp:all-processes)
unless (apply-process-filter process-filter process)
collect (progn
(format t (if (eq process current)
"~% >~D: ~s"
"~% ~D: ~s")
rank process)
(incf rank)
process)))
#+threads
(defun query-process (&optional (process-filter mp:*current-process*))
(format t "~&Choose the integer code of process to interrupt.
Use special code 0 to cancel this operation.")
(loop for process-list = (show-process-list process-filter)
for code = (progn
(tpl-prompt)
(tpl-read))
do (cond ((zerop code)
(return nil))
((and (fixnump code) (<= 1 code (length process-list)))
(return (list (elt process-list (1- code)))))
(t
(format t "~&Not a valid process number")))))
(defun terminal-interrupt (&optional (correctablep t))
#+threads
@ -493,26 +531,18 @@ under certain conditions; see file 'Copyright' for details.")
(push i suspended)
(mp:process-suspend i)))
(mp:with-local-interrupts
(restart-case (simple-terminal-interrupt correctablep)
(restart-case (simple-terminal-interrupt)
(continue () (return-from terminal-interrupt))
(mp:interrupt-process (&optional (process-number 1))
(mp:interrupt-process (process)
:interactive query-process
:report (lambda (stream) (princ "Interrupt a certain process." stream))
(loop for processes = (mp:all-processes)
while (not (and (fixnump process-number)
(<= 1 process-number (length processes))))
do (restart-case (cerror "Continue without breaking"
"Not a valid process index ~D"
process-number)
(continue ())
(store-value (new-value) (setf process-number new-value))))
(setf break-process (elt (mp:all-processes) (1+ process-number))))))
(setf break-process process))))
(loop for process in suspended
unless (eq process break-process)
do (mp:process-resume suspended))
do (mp:process-resume process))
(when break-process
(mp:interrupt-process break-process
#'(lambda ()
(simple-terminal-interrupt correctablep))))))
#'simple-terminal-interrupt))))
#-threads
(restart-case (simple-terminal-interrupt)
(continue ())))
@ -658,7 +688,6 @@ under certain conditions; see file 'Copyright' for details.")
`(tpl-unknown-command ',name)))
((eq (third c) :restart)
`(progn
;;(format t "~&About to invoke restart: ~A.~%" ,(second c))
(invoke-restart-interactively ,(second c))))
((eq (third c) :eval)
`(,(second c) . ,(tpl-parse-forms line)))