Changeset 12587

Timestamp:

04/09/10 23:10:42 (13 years ago)

Author:

ehuelsmann

Message:

Fix #88: Add the thread name to the debugger-printed message and

bind a restart which allows gracefully exiting a thread.

Location:

trunk/abcl/src/org/armedbear/lisp

Files:

• LispThread.java (modified) (2 diffs)
• autoloads.lisp (modified) (1 diff)
• debug.lisp (modified) (1 diff)
• threads.lisp (modified) (1 diff)

trunk/abcl/src/org/armedbear/lisp/LispThread.java

@@ -73 +73 @@
     private boolean threadInterrupted;
     private LispObject pending = NIL;
+    private Symbol wrapper =
+        PACKAGE_THREADS.intern("THREAD-FUNCTION-WRAPPER");
 
     LispThread(Thread javaThread)
@@ -86 +88 @@
             {
                 try {
-                    funcall(fun, new LispObject[0], LispThread.this);
+                    funcall(wrapper,
+                            new LispObject[] { fun },
+                            LispThread.this);
                 }
                 catch (ThreadDestroyed ignored) {

trunk/abcl/src/org/armedbear/lisp/autoloads.lisp

@@ -319 +319 @@
 (in-package "THREADS")
 
-
-(autoload '(;; Mailbox
+(autoload '(;; MAKE-THREAD helper
+            thread-function-wrapper
+
+            ;; Mailbox
             make-mailbox mailbox-send mailbox-empty-p
             mailbox-read mailbox-peek

trunk/abcl/src/org/armedbear/lisp/debug.lisp

@@ -95 +95 @@
         (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)))))

trunk/abcl/src/org/armedbear/lisp/threads.lisp

@@ -33 +33 @@
 (in-package #:threads)
 
+
+;;
+;; MAKE-THREAD helper to establish restarts
+;;
+
+(defun thread-function-wrapper (fun)
+  (restart-case
+      (funcall fun)
+    (abort () :report "Abort thread.")))
 
 ;;