Index: guile-core/libguile/Makefile.am
===================================================================
RCS file: /cvsroot/guile/guile/guile-core/libguile/Makefile.am,v
retrieving revision 1.195
diff -a -u -r1.195 Makefile.am
--- guile-core/libguile/Makefile.am	24 Sep 2004 02:12:09 -0000	1.195
+++ guile-core/libguile/Makefile.am	7 Nov 2004 02:43:34 -0000
@@ -104,10 +104,11 @@
     lang.c list.c							    \
     load.c macros.c mallocs.c modules.c numbers.c objects.c objprop.c	    \
     options.c pairs.c ports.c print.c procprop.c procs.c properties.c	    \
-    random.c rdelim.c read.c root.c rw.c scmsigs.c script.c simpos.c smob.c \
-    sort.c srcprop.c stackchk.c stacks.c stime.c strings.c srfi-13.c srfi-14.c \
-    strorder.c strports.c struct.c symbols.c threads.c throw.c values.c	    \
-    variable.c vectors.c version.c vports.c weaks.c
+    pthread-threads.c random.c rdelim.c read.c root.c rw.c scmsigs.c        \
+    script.c simpos.c smob.c sort.c srcprop.c stackchk.c stacks.c stime.c   \
+    strings.c srfi-13.c srfi-14.c strorder.c strports.c struct.c symbols.c  \
+    threads.c threads-plugin.c throw.c values.c variable.c vectors.c        \
+    version.c vports.c weaks.c
 
 DOT_X_FILES = alist.x arbiters.x async.x backtrace.x boolean.x chars.x	 \
     continuations.x debug.x deprecation.x deprecated.x discouraged.x	 \
@@ -208,12 +209,10 @@
 # and people feel like maintaining them.  For now, this is not the case.
 noinst_SCRIPTS = guile-doc-snarf guile-snarf-docs guile-func-name-check
 
-EXTRA_DIST = ChangeLog-gh ChangeLog-scm ChangeLog-threads		\
-    ChangeLog-1996-1999 ChangeLog-2000 cpp_signal.c			\
-    cpp_errno.c cpp_err_symbols.in cpp_err_symbols.c		\
-    cpp_sig_symbols.c cpp_sig_symbols.in cpp_cnvt.awk	\
-    c-tokenize.lex threads-plugin.c version.h.in pthread-threads.c \
-    scmconfig.h.top gettext.h
+EXTRA_DIST = ChangeLog-gh ChangeLog-scm ChangeLog-threads ChangeLog-1996-1999 \
+    ChangeLog-2000 cpp_signal.c	cpp_errno.c cpp_err_symbols.in                \
+    cpp_err_symbols.c cpp_sig_symbols.c cpp_sig_symbols.in cpp_cnvt.awk	      \
+    c-tokenize.lex version.h.in scmconfig.h.top gettext.h
 #    $(DOT_DOC_FILES) $(EXTRA_DOT_DOC_FILES) \
 #    guile-procedures.txt guile.texi
 
Index: guile-core/libguile/pthread-threads.c
===================================================================
RCS file: /cvsroot/guile/guile/guile-core/libguile/pthread-threads.c,v
retrieving revision 1.9
diff -a -u -r1.9 pthread-threads.c
--- guile-core/libguile/pthread-threads.c	5 Apr 2003 19:10:22 -0000	1.9
+++ guile-core/libguile/pthread-threads.c	7 Nov 2004 02:43:39 -0000
@@ -22,7 +22,9 @@
 #  include <config.h>
 #endif
 
-#include "libguile/scmconfig.h"
+#include "pthread-threads.h"
+#include "scmconfig.h"
+#include "threads-plugin.h"
 
 /* Should go to threads-plugin */
 scm_t_mutexattr scm_i_plugin_mutex;
Index: guile-core/libguile/pthread-threads.h
===================================================================
RCS file: /cvsroot/guile/guile/guile-core/libguile/pthread-threads.h,v
retrieving revision 1.9
diff -a -u -r1.9 pthread-threads.h
--- guile-core/libguile/pthread-threads.h	5 Apr 2003 19:10:22 -0000	1.9
+++ guile-core/libguile/pthread-threads.h	7 Nov 2004 02:43:40 -0000
@@ -46,6 +46,15 @@
 #define scm_i_plugin_thread_detach	pthread_detach 
 #define scm_i_plugin_thread_self	pthread_self
 #define scm_i_plugin_thread_yield	sched_yield
+#define scm_i_plugin_thread_equal       pthread_equal
+
+/* N.B.: pthread_cleanup_push and _pop are macros! */
+#define scm_i_plugin_thread_cancel      pthread_cancel
+#define scm_i_plugin_thread_cleanup_push pthread_cleanup_push
+#define scm_i_plugin_thread_cleanup_pop  pthread_cleanup_pop
+#define scm_i_plugin_thread_setcancelstate	pthread_setcancelstate
+#define SCM_THREAD_CANCEL_ENABLE	PTHREAD_CANCEL_ENABLE
+#define SCM_THREAD_CANCEL_DISABLE	PTHREAD_CANCEL_DISABLE
 
 extern scm_t_mutexattr scm_i_plugin_mutex; /* The "fast" mutex. */
 
Index: guile-core/libguile/threads-plugin.c
===================================================================
RCS file: /cvsroot/guile/guile/guile-core/libguile/threads-plugin.c,v
retrieving revision 1.4
diff -a -u -r1.4 threads-plugin.c
--- guile-core/libguile/threads-plugin.c	5 Apr 2003 19:10:22 -0000	1.4
+++ guile-core/libguile/threads-plugin.c	7 Nov 2004 02:43:40 -0000
@@ -22,6 +22,12 @@
 #  include <config.h>
 #endif
 
+#include <errno.h>
+#include <stdio.h>
+
+#include "pthread-threads.h"
+#include "threads.h"
+
 int scm_i_plugin_mutex_size = 0;
 int (*scm_i_plugin_mutex_init) (scm_t_mutex *, const scm_t_mutexattr *);
 int (*scm_i_plugin_mutex_lock) (scm_t_mutex *);
Index: guile-core/libguile/threads-plugin.h
===================================================================
RCS file: /cvsroot/guile/guile/guile-core/libguile/threads-plugin.h,v
retrieving revision 1.5
diff -a -u -r1.5 threads-plugin.h
--- guile-core/libguile/threads-plugin.h	27 Apr 2004 22:59:04 -0000	1.5
+++ guile-core/libguile/threads-plugin.h	7 Nov 2004 02:43:40 -0000
@@ -21,7 +21,8 @@
  */
 
 
-#include <pthread.h> /* This file should *not* need to include pthread.h */
+
+#include "scmconfig.h"
 
 /* Size is checked in scm_init_threads_plugin.
    For reference, sizes encountered include,
@@ -59,6 +60,7 @@
 extern scm_t_rec_mutex_trylock scm_i_plugin_rec_mutex_trylock;
 extern scm_t_rec_mutex_unlock scm_i_plugin_rec_mutex_unlock;
 
+
 /*fixme*/
 #define scm_t_cond			pthread_cond_t
 
Index: guile-core/libguile/threads.c
===================================================================
RCS file: /cvsroot/guile/guile/guile-core/libguile/threads.c,v
retrieving revision 1.68
diff -a -u -r1.68 threads.c
--- guile-core/libguile/threads.c	22 Sep 2004 17:41:37 -0000	1.68
+++ guile-core/libguile/threads.c	7 Nov 2004 02:43:43 -0000
@@ -33,6 +33,8 @@
 #include <sys/time.h>
 #endif
 
+#include <signal.h>
+
 #include "libguile/validate.h"
 #include "libguile/root.h"
 #include "libguile/eval.h"
@@ -114,6 +116,7 @@
   scm_root_state *root;
   SCM handle;
   scm_t_thread thread;
+  SCM cleanup_handlers;
   SCM result;
   int exited;
 
@@ -133,6 +136,7 @@
   t = SCM_THREAD_DATA (z);
   t->handle = z;
   t->result = creation_protects;
+  t->cleanup_handlers = SCM_EOL;
   t->base = NULL;
   scm_i_plugin_cond_init (&t->sleep_cond, 0);
   scm_i_plugin_mutex_init (&t->heap_mutex, &scm_i_plugin_mutex);
@@ -156,6 +160,7 @@
 {
   scm_thread *t = SCM_THREAD_DATA (obj);
   scm_gc_mark (t->result);
+  scm_gc_mark (t->cleanup_handlers);
   return t->root->handle; /* mark root-state of this thread */
 }
 
@@ -285,6 +290,26 @@
   void *handler_data;
 } launch_data;
 
+static void
+handler_cancellation (scm_thread* thread)
+{
+  while (!scm_is_eq(scm_length(thread->cleanup_handlers), SCM_INUM0)) {
+    thread->result = scm_i_eval
+      (SCM_CAR(thread->cleanup_handlers), scm_current_module());
+    thread->cleanup_handlers = SCM_CDR(thread->cleanup_handlers);
+  }
+
+  scm_i_plugin_mutex_lock (&thread_admin_mutex);
+  scm_i_leave_guile();
+
+  all_threads = scm_delq_x (thread->handle, all_threads);
+  thread->exited = 1;
+  thread_count--;
+  scm_thread_detach (thread->thread);
+  scm_i_plugin_mutex_unlock (&thread_admin_mutex);
+  return;
+}
+
 static SCM
 body_bootstrip (launch_data* data)
 {
@@ -315,11 +340,16 @@
   init_thread_creatant (thread, base); /* must own the heap */
   
   data->rootcont = SCM_BOOL_F;
+
+  scm_i_plugin_thread_cleanup_push
+    ((void (*) (void *)) handler_cancellation, (void *) t);
   t->result =
     scm_internal_cwdr ((scm_t_catch_body) body_bootstrip,
 		       data,
 		       (scm_t_catch_handler) handler_bootstrip,
 		       data, base);
+  scm_i_plugin_thread_cleanup_pop(0);
+
   scm_i_leave_guile (); /* release the heap */
   free (data);
 
@@ -370,7 +400,9 @@
     data->body_data = body_data;
     data->handler = handler;
     data->handler_data = handler_data;
+
     t = SCM_THREAD_DATA (thread);
+
     /* must initialize root state pointer before the thread is linked
        into all_threads */
     t->root = SCM_ROOT_STATE (root);
@@ -471,11 +503,77 @@
       scm_i_enter_guile (c);
     }
   res = t->result;
-  t->result = SCM_BOOL_F;
+  /* t->result = SCM_BOOL_F; */
   return res;
 }
 #undef FUNC_NAME
 
+SCM_DEFINE (scm_cancel_thread, "cancel-thread", 1, 0, 0,
+	    (SCM thread),
+"Force the target @var{thread} to terminate, causing all of its "
+"currently registered cleanup handlers to be called.")
+#define FUNC_NAME s_scm_cancel_thread 
+{
+  scm_thread *t = SCM_THREAD_DATA (thread);
+  if (scm_is_eq(scm_member(t->handle, all_threads), SCM_BOOL_F)) {
+    return SCM_BOOL_F;
+  }
+
+  if (!t->exited)
+    {
+      scm_thread *c = scm_i_leave_guile ();
+      while (!THREAD_INITIALIZED_P (t)) {
+	scm_i_plugin_thread_yield ();
+      }
+      scm_i_enter_guile (c);
+      scm_thread_cancel (t->thread);
+    }
+  return SCM_BOOL_T;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_push_thread_cleanup, "push-thread-cleanup", 1, 0, 0,
+	    (SCM expr),
+"Add an expression @var{expr} to the front of the list of cleanup "
+"handlers for the current thread. These handlers will be evaluated "
+"in a LIFO manner if the current thread is cancelled by another "
+"Scheme thread or by C code, via scm_c_thread_cancel().")
+#define FUNC_NAME s_scm_push_thread_cleanup
+{
+  scm_thread *t = SCM_CURRENT_THREAD;
+  if (scm_is_eq(scm_member(t->handle, all_threads), SCM_BOOL_F)) {
+    return SCM_BOOL_F;
+  }
+  t->cleanup_handlers = scm_cons(expr, t->cleanup_handlers);
+  return SCM_BOOL_T;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_pop_thread_cleanup, "pop-thread-cleanup", 0, 1, 0,
+	    (SCM exec),
+"Remove the most recently added cleanup handler expression from the "
+"current thread's queue of cleanup handlers.  If a boolean expression "
+"@var{exec} is provided and is true, the cleanup handler will be "
+"evaluated as it is removed.")
+#define FUNC_NAME s_scm_pop_thread_cleanup
+{
+  scm_thread *t = SCM_CURRENT_THREAD;
+  if (scm_is_eq(scm_member(t->handle, all_threads), SCM_BOOL_F)) {
+    return SCM_BOOL_F;
+  }
+
+  SCM result = SCM_EOL;
+  if (t->cleanup_handlers != SCM_EOL) {
+    SCM expr = SCM_CAR(t->cleanup_handlers);
+    t->cleanup_handlers = SCM_CDR(t->cleanup_handlers);
+    if (scm_is_true(exec)) {
+      result = scm_i_eval(expr, scm_current_module());
+    }
+  }
+  return result;    
+}
+#undef FUNC_NAME
+
 /*** Fair mutexes */
 
 /* We implement our own mutex type since we want them to be 'fair', we
@@ -1098,6 +1196,48 @@
   return tv.tv_sec;
 }
 
+/* Thread cleanup handler pushing and popping functions.  These are
+   the same for all threading libraries, because they operate on
+   Guile's internal representation of the thread, not the threading
+   library's. */
+
+static scm_thread*
+scm_t_thread_to_scm_thread(scm_t_thread* needle) {
+  scm_thread* ret = NULL;
+  SCM all_threads = scm_all_threads();
+  while(!scm_is_eq(all_threads, SCM_EOL)) {
+    SCM single_thread = scm_car(all_threads);
+    if (scm_i_plugin_thread_equal(scm_c_scm2thread(single_thread), *needle)) {
+      ret = SCM_THREAD_DATA(single_thread);
+      break;
+    }
+    all_threads = scm_cdr(all_threads);	
+  }
+  return ret;
+}
+
+SCM 
+scm_internal_thread_cleanup_push(scm_t_thread* thread, SCM expr) 
+{
+  scm_thread* t = scm_t_thread_to_scm_thread(thread);
+  if (t != NULL)
+    t->cleanup_handlers = scm_cons(expr, t->cleanup_handlers);
+  return SCM_EOL;
+}
+
+SCM 
+scm_internal_thread_cleanup_pop(scm_t_thread* thread, int exec)
+{
+  SCM ret = SCM_EOL;
+  scm_thread* t = scm_t_thread_to_scm_thread(thread);
+  if ((t != NULL) && (!scm_is_eq(t->cleanup_handlers, SCM_EOL))) {
+    SCM expr = scm_car(t->cleanup_handlers);
+    t->cleanup_handlers = scm_cdr(t->cleanup_handlers);
+    if (exec) ret = scm_eval(expr, t->root->handle);
+  }
+  return ret;
+}
+
 /*** Misc */
 
 SCM_DEFINE (scm_current_thread, "current-thread", 0, 0, 0,
@@ -1217,9 +1357,9 @@
 scm_t_rec_mutex scm_i_defer_mutex;
 
 #if SCM_USE_PTHREAD_THREADS
-# include "libguile/pthread-threads.c"
+#include "libguile/pthread-threads.h"
 #endif
-#include "libguile/threads-plugin.c"
+#include "libguile/threads-plugin.h"
 
 /*** Initialization */
 
Index: guile-core/libguile/threads.h
===================================================================
RCS file: /cvsroot/guile/guile/guile-core/libguile/threads.h,v
retrieving revision 1.38
diff -a -u -r1.38 threads.h
--- guile-core/libguile/threads.h	23 Jul 2004 23:51:58 -0000	1.38
+++ guile-core/libguile/threads.h	7 Nov 2004 02:43:44 -0000
@@ -64,9 +64,9 @@
 SCM_API void scm_init_thread_procs (void);
 
 #if SCM_USE_PTHREAD_THREADS
-# include "libguile/pthread-threads.h"
+#include "libguile/pthread-threads.h"
 #else
-# include "libguile/null-threads.h"
+#include "libguile/null-threads.h"
 #endif
 
 /*----------------------------------------------------------------------*/
@@ -97,6 +97,14 @@
 #define scm_thread_detach	scm_i_plugin_thread_detach
 #define scm_thread_self		scm_i_plugin_thread_self
 #define scm_thread_yield	scm_i_plugin_thread_yield
+#define scm_thread_cancel       scm_i_plugin_thread_cancel
+#define scm_thread_setcancelstate	scm_i_plugin_thread_setcancelstate
+/* N.B.: scm_i_plugin_thread_cleanup_push and _pop are defined,
+   but we don't use them here because of the way certain thread libraries
+   implement them; the ones here use a mechanism built into thread creation
+   from thread.c... */
+#define scm_thread_cleanup_push scm_internal_thread_cleanup_push
+#define scm_thread_cleanup_pop  scm_internal_thread_cleanup_pop
 
 #define scm_mutex_init		scm_i_plugin_mutex_init 
 #define scm_mutex_destroy	scm_i_plugin_mutex_destroy
@@ -165,6 +173,9 @@
 SCM_API unsigned long scm_thread_sleep (unsigned long);
 SCM_API unsigned long scm_thread_usleep (unsigned long);
 
+SCM_API SCM scm_internal_thread_cleanup_push(scm_t_thread*, SCM);
+SCM_API SCM scm_internal_thread_cleanup_pop(scm_t_thread*, int);
+
 /* End of low-level C API */
 /*----------------------------------------------------------------------*/
 
@@ -210,6 +221,9 @@
 SCM_API SCM scm_call_with_new_thread (SCM thunk, SCM handler);
 SCM_API SCM scm_yield (void);
 SCM_API SCM scm_join_thread (SCM t);
+SCM_API SCM scm_cancel_thread (SCM t);
+SCM_API SCM scm_push_thread_cleanup (SCM expr);
+SCM_API SCM scm_pop_thread_cleanup (SCM exec);
 SCM_API SCM scm_make_mutex (void);
 SCM_API SCM scm_make_fair_mutex (void);
 SCM_API SCM scm_lock_mutex (SCM m);