[armedbear-cvs] r12587 - trunk/abcl/src/org/armedbear/lisp

[Erik Huelsmann]

Author: ehuelsmann
Date: Fri Apr  9 19:10:42 2010
New Revision: 12587

Log:
Fix #88: Add the thread name to the debugger-printed message and
   bind a restart which allows gracefully exiting a thread.

Modified:
   trunk/abcl/src/org/armedbear/lisp/LispThread.java
   trunk/abcl/src/org/armedbear/lisp/autoloads.lisp
   trunk/abcl/src/org/armedbear/lisp/debug.lisp
   trunk/abcl/src/org/armedbear/lisp/threads.lisp

Modified: trunk/abcl/src/org/armedbear/lisp/LispThread.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/LispThread.java	(original)
+++ trunk/abcl/src/org/armedbear/lisp/LispThread.java	Fri Apr  9 19:10:42 2010
@@ -72,6 +72,8 @@
     public LispObject[] _values;
     private boolean threadInterrupted;
     private LispObject pending = NIL;
+    private Symbol wrapper =
+        PACKAGE_THREADS.intern("THREAD-FUNCTION-WRAPPER");
 
     LispThread(Thread javaThread)
     {
@@ -85,7 +87,9 @@
             public void run()
             {
                 try {
-                    funcall(fun, new LispObject[0], LispThread.this);
+                    funcall(wrapper,
+                            new LispObject[] { fun },
+                            LispThread.this);
                 }
                 catch (ThreadDestroyed ignored) {
                       // Might happen.

Modified: trunk/abcl/src/org/armedbear/lisp/autoloads.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/autoloads.lisp	(original)
+++ trunk/abcl/src/org/armedbear/lisp/autoloads.lisp	Fri Apr  9 19:10:42 2010
@@ -318,8 +318,10 @@
 
 (in-package "THREADS")
 
+(autoload '(;; MAKE-THREAD helper
+            thread-function-wrapper
 
-(autoload '(;; Mailbox
+            ;; Mailbox
             make-mailbox mailbox-send mailbox-empty-p
             mailbox-read mailbox-peek
 

Modified: trunk/abcl/src/org/armedbear/lisp/debug.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/debug.lisp	(original)
+++ trunk/abcl/src/org/armedbear/lisp/debug.lisp	Fri Apr  9 19:10:42 2010
@@ -94,8 +94,9 @@
                          (stream-offset *load-stream*)))
         (simple-format *debug-io*
                        (if (fboundp 'tpl::repl)
-                           "Debugger invoked on condition of type ~A:~%"
-                           "Unhandled condition of type ~A:~%")
+                           "~S: Debugger invoked on condition of type ~A~%"
+                           "~S: Unhandled condition of type ~A:~%")
+                       (threads:current-thread)
                        (type-of condition))
         (simple-format *debug-io* "  ~A~%" condition)))))
 

Modified: trunk/abcl/src/org/armedbear/lisp/threads.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/threads.lisp	(original)
+++ trunk/abcl/src/org/armedbear/lisp/threads.lisp	Fri Apr  9 19:10:42 2010
@@ -34,6 +34,15 @@
 
 
 ;;
+;; MAKE-THREAD helper to establish restarts
+;;
+
+(defun thread-function-wrapper (fun)
+  (restart-case
+      (funcall fun)
+    (abort () :report "Abort thread.")))
+
+;;
 ;; Mailbox implementation
 ;;