From 2ff46749f3a4560490e566502a38ebc8a8df4cb7 Mon Sep 17 00:00:00 2001 From: Matt Birkholz Date: Tue, 12 Aug 2014 11:51:23 -0700 Subject: [PATCH] Fluidize *bound-restarts* and dynamic-handler-frames. --- src/runtime/error.scm | 45 +++++++++++++++++++++++-------------------- src/runtime/rep.scm | 41 ++++++++++++++++++++------------------- 2 files changed, 45 insertions(+), 41 deletions(-) diff --git a/src/runtime/error.scm b/src/runtime/error.scm index ee20244a0..433d37ca6 100644 --- a/src/runtime/error.scm +++ b/src/runtime/error.scm @@ -225,7 +225,7 @@ USA. (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. ;;;; 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))) ;;;; Standard Condition Signallers @@ -765,7 +766,9 @@ USA. (memq condition-type:error (%condition-type/generalizations type))) (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 5c69c2690..9ea3cf0ed 100644 --- 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))) -- 2.25.1