Fluidize *bound-restarts* and dynamic-handler-frames.

diff --git a/src/runtime/error.scm b/src/runtime/error.scm
index ee20244a0a958d087b295b374a446b772ce67e86..433d37ca6019155c7921d909bceffa415e1ce5c6 100644 (file)
--- a/src/runtime/error.scm
+++ b/src/runtime/error.scm
@@ -225,7 +225,7 @@ USA.
 \f
 (define-integrable (%restarts-argument restarts operator)
   (cond ((eq? 'BOUND-RESTARTS restarts)
-        *bound-restarts*)
+        (fluid *bound-restarts*))
        ((condition? restarts)
         (%condition/restarts restarts))
        (else
@@ -301,7 +301,7 @@ USA.
 \f
 ;;;; Restarts
 
-(define *bound-restarts* '())
+(define *bound-restarts*)
 
 (define-structure (restart
                   (conc-name %restart/)
@@ -334,10 +334,10 @@ USA.
       (error:wrong-type-argument effector "effector" 'WITH-RESTART))
   (if (not (or (not interactor) (procedure? interactor)))
       (error:wrong-type-argument interactor "interactor" 'WITH-RESTART))
-  (fluid-let ((*bound-restarts*
-              (cons (%make-restart name reporter effector interactor)
-                    *bound-restarts*)))
-    (thunk)))
+  (let-fluid *bound-restarts*
+            (cons (%make-restart name reporter effector interactor)
+                  (fluid *bound-restarts*))
+            thunk))
 
 (define (with-simple-restart name reporter thunk)
   (call-with-current-continuation
@@ -382,7 +382,7 @@ USA.
 (define (bind-restart name reporter effector receiver)
   (with-restart name reporter effector #f
     (lambda ()
-      (receiver (car *bound-restarts*)))))
+      (receiver (car (fluid *bound-restarts*))))))
 
 (define (invoke-restart restart . arguments)
   (guarantee-restart restart 'INVOKE-RESTART)
@@ -424,13 +424,13 @@ USA.
 (define hook/invoke-restart)
 
 (define (bound-restarts)
-  (let loop ((restarts *bound-restarts*))
+  (let loop ((restarts (fluid *bound-restarts*)))
     (if (pair? restarts)
        (cons (car restarts) (loop (cdr restarts)))
        '())))
 
 (define (first-bound-restart)
-  (let ((restarts *bound-restarts*))
+  (let ((restarts (fluid *bound-restarts*)))
     (if (not (pair? restarts))
        (error:no-such-restart #f))
     (car restarts)))
@@ -489,7 +489,7 @@ USA.
 (define (restarts-default restarts name)
   (cond ((or (default-object? restarts)
             (eq? 'BOUND-RESTARTS restarts))
-        *bound-restarts*)
+        (fluid *bound-restarts*))
        ((condition? restarts)
         (%condition/restarts restarts))
        (else
@@ -499,7 +499,7 @@ USA.
 ;;;; Condition Signalling and Handling
 
 (define static-handler-frames)
-(define dynamic-handler-frames '())
+(define dynamic-handler-frames)
 (define break-on-signals-types)
 
 (define (bind-default-condition-handler types handler)
@@ -513,9 +513,9 @@ USA.
 (define (bind-condition-handler types handler thunk)
   (guarantee-condition-types types 'BIND-CONDITION-HANDLER)
   (guarantee-condition-handler handler 'BIND-CONDITION-HANDLER)
-  (fluid-let ((dynamic-handler-frames
-              (cons (cons types handler) dynamic-handler-frames)))
-    (thunk)))
+  (let-fluid dynamic-handler-frames
+            (cons (cons types handler) (fluid dynamic-handler-frames))
+            thunk))
 
 (define-integrable (guarantee-condition-handler object caller)
   (guarantee-procedure-of-arity object 1 caller))
@@ -551,22 +551,23 @@ USA.
              (breakpoint-procedure 'INHERIT
                                    "BKPT entered because of BREAK-ON-SIGNALS:"
                                    condition))))
-      (do ((frames dynamic-handler-frames (cdr frames)))
+      (do ((frames (fluid dynamic-handler-frames) (cdr frames)))
          ((not (pair? frames)))
        (if (let ((types (caar frames)))
              (or (not (pair? types))
                  (intersect-generalizations? types)))
-           (fluid-let ((dynamic-handler-frames (cdr frames)))
-             (hook/invoke-condition-handler (cdar frames) condition))))
+           (let-fluid dynamic-handler-frames (cdr frames)
+             (lambda ()
+               (hook/invoke-condition-handler (cdar frames) condition)))))
       (do ((frames (fluid static-handler-frames) (cdr frames)))
          ((not (pair? frames)))
        (if (let ((types (caar frames)))
              (or (not (pair? types))
                  (intersect-generalizations? types)))
-           (fluid-let ((dynamic-handler-frames '()))
-             (let-fluid static-handler-frames (cdr frames)
-               (lambda ()
-                 (hook/invoke-condition-handler (cdar frames) condition))))))
+           (let-fluids dynamic-handler-frames '()
+                       static-handler-frames (cdr frames)
+             (lambda ()
+               (hook/invoke-condition-handler (cdar frames) condition)))))
       unspecific)))
 \f
 ;;;; Standard Condition Signallers
@@ -765,7 +766,9 @@ USA.
   (memq condition-type:error (%condition-type/generalizations type)))
 \f
 (define (initialize-package!)
+  (set! *bound-restarts* (make-fluid '()))
   (set! static-handler-frames (make-fluid '()))
+  (set! dynamic-handler-frames (make-fluid '()))
   (set! break-on-signals-types (make-fluid '()))
   (set! standard-error-hook (make-fluid #f))
   (set! standard-warning-hook (make-fluid #f))

diff --git a/src/runtime/rep.scm b/src/runtime/rep.scm
index 5c69c269085f23d7b8509329b1d72b3b84b70cba..9ea3cf0ed0684ef3684cbbde11543644406125c0 100644 (file)
--- a/src/runtime/rep.scm
+++ b/src/runtime/rep.scm
@@ -128,27 +128,28 @@ USA.
              standard-warning-hook #f
              standard-breakpoint-hook #f
              *default-pathname-defaults* (fluid *default-pathname-defaults*)
+             dynamic-handler-frames '()
+             *bound-restarts* (if (cmdl/parent cmdl)
+                                  (fluid *bound-restarts*)
+                                  '())
              (lambda ()
-               (fluid-let ((dynamic-handler-frames '())
-                           (*bound-restarts*
-                            (if (cmdl/parent cmdl) *bound-restarts* '())))
-                 (let loop ((message message))
-                   (loop
-                    (bind-abort-restart cmdl
-                      (lambda ()
-                        (deregister-all-events)
-                        (with-interrupt-mask interrupt-mask/all
-                          (lambda (interrupt-mask)
-                            interrupt-mask
-                            (unblock-thread-events)
-                            (ignore-errors
-                             (lambda ()
-                               ((->cmdl-message message) cmdl)))
-                            (call-with-current-continuation
-                             (lambda (continuation)
-                               (with-create-thread-continuation continuation
-                                 (lambda ()
-                                   ((cmdl/driver cmdl) cmdl))))))))))))))))
+               (let loop ((message message))
+                 (loop
+                  (bind-abort-restart cmdl
+                    (lambda ()
+                      (deregister-all-events)
+                      (with-interrupt-mask interrupt-mask/all
+                        (lambda (interrupt-mask)
+                          interrupt-mask
+                          (unblock-thread-events)
+                          (ignore-errors
+                           (lambda ()
+                             ((->cmdl-message message) cmdl)))
+                          (call-with-current-continuation
+                           (lambda (continuation)
+                             (with-create-thread-continuation continuation
+                               (lambda ()
+                                 ((cmdl/driver cmdl) cmdl)))))))))))))))
          (mutex (port/thread-mutex port)))
       (let ((thread (current-thread))
            (owner (thread-mutex-owner mutex)))