Run the handler of SRFI-34's `with-exception-handler' in the right dyn. env.

* srfi/srfi-34.scm (with-exception-handler): Use `with-throw-handler'
  instead of `lazy-catch'.

* test-suite/tests/srfi-34.test ("SRFI 34")["`with-exception-handler'
  invokes HANDLER in THUNK's dynamic env."]: New test.

* test-suite/tests/srfi-39.test: Use `(srfi srfi-34)'.
  ("SRFI-39")["SRFI-34"]: New test.

* NEWS: Update.

NEWS

@@ -82,6 +82,8 @@ available: Guile is now always configured in "maintainer mode".
 ** Fix `Stack overflow' errors seen when building on some platforms
 ** Fix bug when `scm_with_guile ()' was called several times from the
    same thread
+** The handler of SRFI-34 `with-exception-handler' is now invoked in the
+   dynamic environment of the call to `raise'
 
 
 Changes in 1.8.5 (since 1.8.4)

srfi/srfi-34.scm

@@ -1,6 +1,6 @@
 ;;; srfi-34.scm --- Exception handling for programs
 
-;; Copyright (C) 2003, 2006 Free Software Foundation, Inc.
+;; Copyright (C) 2003, 2006, 2008 Free Software Foundation, Inc.
 ;;
 ;; This library is free software; you can redistribute it and/or
 ;; modify it under the terms of the GNU Lesser General Public
@@ -40,7 +40,7 @@
 procedure that accepts one argument.  It is installed as the current
 exception handler for the dynamic extent (as determined by
 dynamic-wind) of the invocation of THUNK."
-  (lazy-catch throw-key
+  (with-throw-handler throw-key
 	      thunk
 	      (lambda (key obj)
 		(handler obj))))

test-suite/tests/srfi-34.test

@@ -1,6 +1,6 @@
 ;;;; srfi-34.test --- test suite for SRFI-34 -*- scheme -*-
 ;;;;
-;;;; 	Copyright (C) 2003, 2004, 2006 Free Software Foundation, Inc.
+;;;; 	Copyright (C) 2003, 2004, 2006, 2008 Free Software Foundation, Inc.
 ;;;;
 ;;;; This program is free software; you can redistribute it and/or modify
 ;;;; it under the terms of the GNU General Public License as published by
@@ -161,4 +161,24 @@
 	    ""
 	    '(b . 23)))
 
-)
+  (pass-if "`with-exception-handler' invokes HANDLER in THUNK's dynamic env."
+           ;; In Guile 1.8.5 and earlier, unwinders would be called before
+           ;; the exception handler, which reads "The handler is called in
+           ;; the dynamic environment of the call to `raise'".
+           (call/cc
+            (lambda (return)
+              (let ((inside? #f))
+                (with-exception-handler
+                 (lambda (c)
+                   ;; This handler must be called before the unwinder below.
+                   (return inside?))
+                 (lambda ()
+                   (dynamic-wind
+                     (lambda ()
+                       (set! inside? #t))
+                     (lambda ()
+                       (raise 'some-exception))
+                     (lambda ()
+                       ;; This unwinder should not be executed before the
+                       ;; handler is called.
+                       (set! inside? #f))))))))))

test-suite/tests/srfi-39.test

@@ -1,6 +1,6 @@
 ;;;; srfi-39.test --- -*- scheme -*-
 ;;;;
-;;;; Copyright (C) 2004, 2005, 2006 Free Software Foundation, Inc.
+;;;; Copyright (C) 2004, 2005, 2006, 2008 Free Software Foundation, Inc.
 ;;;; 
 ;;;; This program is free software; you can redistribute it and/or modify
 ;;;; it under the terms of the GNU General Public License as published by
@@ -19,7 +19,10 @@
 
 (define-module (test-srfi-39)
   #:use-module (test-suite lib)
-  #:use-module (srfi srfi-39))
+  #:use-module (srfi srfi-34)
+  #:use-module (srfi srfi-39)
+  #:duplicates (last) ;; avoid warning about srfi-34 replacing `raise'
+  )
 
 (define a (make-parameter 3))
 (define b (make-parameter 4))
@@ -53,7 +56,19 @@
            (check c d 10 9)
            (parameterize ((c (a)) (d (b)))
 	     (and (check a b 0 1)
-		  (check c d 0 1)))))))
+		  (check c d 0 1))))))
+
+  (pass-if "SRFI-34"
+    (let ((inside? (make-parameter #f)))
+      (call/cc (lambda (return)
+                 (with-exception-handler
+                  (lambda (c)
+                    ;; This handler should be called in the dynamic
+                    ;; environment installed by `parameterize'.
+                    (return (inside?)))
+                  (lambda ()
+                    (parameterize ((inside? #t))
+                      (raise 'some-exception)))))))))
 
 (let ()
   (define (test-ports param new-port new-port-2)