Ticket #86: thread-restarts.patch

src/org/armedbear/lisp/autoloads.lisp

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

src/org/armedbear/lisp/debug.lisp

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

src/org/armedbear/lisp/LispThread.java

@@ -72 +72 @@
     public LispObject[] _values;
     private boolean threadInterrupted;
     private LispObject pending = NIL;
+    private Symbol wrapper =
+        PACKAGE_THREADS.intern("THREAD-FUNCTION-WRAPPER");
 
     LispThread(Thread javaThread)
     {
@@ -85 +87 @@
             public void run()
             {
                 try {
-                    funcall(fun, new LispObject[0], LispThread.this);
+                    funcall(wrapper,
+                            new LispObject[] { fun },
+                            LispThread.this);
                 }
                 catch (ThreadDestroyed ignored) {
                       // Might happen.

src/org/armedbear/lisp/threads.lisp

@@ -34 +34 @@
 
 
 ;;
+;; MAKE-THREAD helper to establish restarts
+;;
+
+(defun thread-function-wrapper (fun)
+  (restart-case
+      (funcall fun)
+    (abort () :report "Abort thread.")))
+
+;;
 ;; Mailbox implementation
 ;;