Rationalize exception handling in srfi-18

* module/srfi/srfi-18.scm (make-thread): Inline some helpers, and use
  just one catch block.
  (thread->exception): Move up definition.
  (exception-handler-for-foreign-threads): Use this as the default
  handler, not the one that squirrels away exceptions in
  thread->exception.
  (thread-terminate!): Don't instate an exception handler for the thread
  cleanup proc.

module/srfi/srfi-18.scm

@@ -113,26 +113,20 @@
 (define object-names (make-weak-key-hash-table))
 (define object-specifics (make-weak-key-hash-table))
 (define thread-start-conds (make-weak-key-hash-table))
+(define thread->exception (make-object-property))
 
 ;; EXCEPTIONS
 
-(define (initial-handler obj) 
+;; All threads created by SRFI-18 have an initial handler installed that
-  (set! (thread->exception (threads:current-thread))
+;; will squirrel away an uncaught exception to allow it to bubble out to
-    (condition (&uncaught-exception (reason obj)))))
+;; joining threads.  However for the main thread and other threads not
+;; created by SRFI-18, just let the exception bubble up by passing on
+;; doing anything with the exception.
+(define (exception-handler-for-foreign-threads obj)
+  (values))
 
-(define thread->exception (make-object-property))
+(define current-exception-handler
-
+  (make-parameter exception-handler-for-foreign-threads))
-(define (srfi-18-exception-handler key . args)
-
-  ;; SRFI 34 exceptions continue to bubble up no matter who handles them, so
-  ;; if one is caught at this level, it has already been taken care of by
-  ;; `initial-handler'.
-
-  (unless (eq? key 'srfi-34)
-    (set! (thread->exception (threads:current-thread))
-      (condition (&uncaught-exception (reason (cons key args)))))))
-
-(define current-exception-handler (make-parameter initial-handler))
 
 (define (with-exception-handler handler thunk)
   (check-arg-type procedure? handler "with-exception-handler")
@@ -152,32 +146,33 @@
 ;; Once started, install a top-level exception handler that rethrows any 
 ;; exceptions wrapped in an uncaught-exception wrapper. 
 
-(define make-thread 
+(define* (make-thread thunk #:optional name)
-  (let ((make-cond-wrapper (lambda (thunk lcond lmutex scond smutex)
+  (let ((lm (make-mutex 'launch-mutex))
-			     (lambda () 
+        (lc (make-condition-variable 'launch-condition-variable))
-			       (threads:lock-mutex lmutex)
+        (sm (make-mutex 'start-mutex))
-			       (threads:signal-condition-variable lcond)
+        (sc (make-condition-variable 'start-condition-variable)))
-			       (threads:lock-mutex smutex)
+    (threads:lock-mutex lm)
-			       (threads:unlock-mutex lmutex)
+    (let ((t (threads:call-with-new-thread
-			       (threads:wait-condition-variable scond smutex)
+              (lambda ()
-			       (threads:unlock-mutex smutex)
+                (threads:lock-mutex lm)
-			       (with-exception-handler initial-handler 
+                (threads:signal-condition-variable lc)
-                                 thunk)))))
+                (threads:lock-mutex sm)
-    (lambda* (thunk #:optional name)
+                (threads:unlock-mutex lm)
-      (let ((lm (make-mutex 'launch-mutex))
+                (threads:wait-condition-variable sc sm)
-	    (lc (make-condition-variable 'launch-condition-variable))
+                (threads:unlock-mutex sm)
-	    (sm (make-mutex 'start-mutex))
+                (thunk))
-	    (sc (make-condition-variable 'start-condition-variable)))
+              (lambda (key . args)
-	
+                (set! (thread->exception (threads:current-thread))
-	(threads:lock-mutex lm)
+                  (condition (&uncaught-exception
-	(let ((t (threads:call-with-new-thread
+                              (reason
-                  (make-cond-wrapper thunk lc lm sc sm)
+                               (match (cons key args)
-                  srfi-18-exception-handler)))
+                                 (('srfi-34 obj) obj)
-	  (hashq-set! thread-start-conds t (cons sm sc))
+                                 (obj obj))))))))))
-	  (when name (hashq-set! object-names t name))
+      (hashq-set! thread-start-conds t (cons sm sc))
-	  (threads:wait-condition-variable lc lm)
+      (when name (hashq-set! object-names t name))
-	  (threads:unlock-mutex lm)
+      (threads:wait-condition-variable lc lm)
-	  t)))))
+      (threads:unlock-mutex lm)
+      t)))
 
 (define (thread-name thread)
   (hashq-ref object-names
@@ -253,8 +248,7 @@
                         (condition (&terminated-thread-exception))))))
        (if (thunk? current-handler)
            (lambda ()
-             (with-exception-handler initial-handler
+             (current-handler)
-               current-handler)
              (handler))
            handler)))
     (threads:cancel-thread thread)