From: Chris Hanson Date: Sun, 28 Feb 2016 05:54:27 +0000 (-0800) Subject: Fix parameterization in error.scm. X-Git-Tag: mit-scheme-pucked-9.2.12~261^2~108 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=5b2b0e052804b513cd80fc832ee8164041599771;p=mit-scheme.git Fix parameterization in error.scm. --- diff --git a/src/runtime/error.scm b/src/runtime/error.scm index e1cd90815..43f1d1a96 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*)) + (param:bound-restarts)) ((condition? restarts) (%condition/restarts restarts)) (else @@ -301,7 +301,7 @@ USA. ;;;; Restarts -(define *bound-restarts*) +(define param:bound-restarts) (define-structure (restart (conc-name %restart/) @@ -335,9 +335,9 @@ USA. (if (not (or (not interactor) (procedure? interactor))) (error:wrong-type-argument interactor "interactor" 'WITH-RESTART)) (parameterize* - (list (cons *bound-restarts* + (list (cons param:bound-restarts (cons (%make-restart name reporter effector interactor) - (*bound-restarts*)))) + (param:bound-restarts)))) thunk)) (define (with-simple-restart name reporter thunk) @@ -383,7 +383,7 @@ USA. (define (bind-restart name reporter effector receiver) (with-restart name reporter effector #f (lambda () - (receiver (car (*bound-restarts*)))))) + (receiver (car (param:bound-restarts)))))) (define (invoke-restart restart . arguments) (guarantee-restart restart 'INVOKE-RESTART) @@ -425,13 +425,13 @@ USA. (define hook/invoke-restart) (define (bound-restarts) - (let loop ((restarts (*bound-restarts*))) + (let loop ((restarts (param:bound-restarts))) (if (pair? restarts) (cons (car restarts) (loop (cdr restarts))) '()))) (define (first-bound-restart) - (let ((restarts (*bound-restarts*))) + (let ((restarts (param:bound-restarts))) (if (not (pair? restarts)) (error:no-such-restart #f)) (car restarts))) @@ -490,7 +490,7 @@ USA. (define (restarts-default restarts name) (cond ((or (default-object? restarts) (eq? 'BOUND-RESTARTS restarts)) - (*bound-restarts*)) + (param:bound-restarts)) ((condition? restarts) (%condition/restarts restarts)) (else @@ -605,27 +605,37 @@ USA. (default-handler condition))))))) (define (standard-error-handler condition) - (let ((hook (standard-error-hook))) + (let ((hook + (if (default-object? standard-error-hook) + (param:standard-error-hook) + standard-error-hook))) (if hook - (parameterize* (list (cons standard-error-hook #f)) - (lambda () - (hook condition))))) + (fluid-let ((standard-error-hook #!default)) + (parameterize* (list (cons param:standard-error-hook #f)) + (lambda () + (hook condition)))))) (repl/start (push-repl 'INHERIT condition '() "error>"))) (define (standard-warning-handler condition) - (let ((hook (standard-warning-hook))) + (let ((hook + (if (default-object? standard-warning-hook) + (param:standard-warning-hook) + standard-warning-hook))) (if hook - (parameterize* (list (cons standard-warning-hook #f)) - (lambda () - (hook condition))) + (fluid-let ((standard-warning-hook #!default)) + (parameterize* (list (cons param:standard-warning-hook #f)) + (lambda () + (hook condition)))) (let ((port (notification-output-port))) (fresh-line port) (write-string ";Warning: " port) (write-condition-report condition port) (newline port))))) -(define standard-error-hook) -(define standard-warning-hook) +(define standard-error-hook #!default) +(define standard-warning-hook #!default) +(define param:standard-error-hook) +(define param:standard-warning-hook) (define (condition-signaller type field-names default-handler) (guarantee-condition-handler default-handler 'CONDITION-SIGNALLER) @@ -768,12 +778,12 @@ USA. (memq condition-type:error (%condition-type/generalizations type))) (define (initialize-package!) - (set! *bound-restarts* (make-parameter '())) + (set! param:bound-restarts (make-parameter '())) (set! static-handler-frames (make-parameter '())) (set! dynamic-handler-frames (make-parameter '())) (set! break-on-signals-types (make-parameter '())) - (set! standard-error-hook (make-parameter #f)) - (set! standard-warning-hook (make-parameter #f)) + (set! param:standard-error-hook (make-settable-parameter #f)) + (set! param:standard-warning-hook (make-settable-parameter #f)) (set! hook/invoke-condition-handler default/invoke-condition-handler) ;; No eta conversion for bootstrapping and efficiency reasons. (set! hook/invoke-restart diff --git a/src/runtime/rep.scm b/src/runtime/rep.scm index e7a1d47b2..be9a541fe 100644 --- a/src/runtime/rep.scm +++ b/src/runtime/rep.scm @@ -123,14 +123,14 @@ USA. (cons working-directory-pathname (working-directory-pathname)) (cons param:nearest-cmdl cmdl) - (cons standard-error-hook #f) - (cons standard-warning-hook #f) + (cons param:standard-error-hook #f) + (cons param:standard-warning-hook #f) (cons param:standard-breakpoint-hook #f) (cons param:default-pathname-defaults (param:default-pathname-defaults)) (cons dynamic-handler-frames '()) - (cons *bound-restarts* - (if (cmdl/parent cmdl) (*bound-restarts*) '()))) + (cons param:bound-restarts + (if (cmdl/parent cmdl) (param:bound-restarts) '()))) (lambda () (let loop ((message message)) (loop diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg index b049f6aea..5440a2e98 100644 --- a/src/runtime/runtime.pkg +++ b/src/runtime/runtime.pkg @@ -1877,6 +1877,8 @@ USA. make-condition make-condition-type muffle-warning + param:standard-error-hook + param:standard-warning-hook restart/effector restart/get restart/interactor @@ -1900,7 +1902,7 @@ USA. (export (runtime microcode-errors) write-operator) (export (runtime rep) - *bound-restarts* + param:bound-restarts dynamic-handler-frames) (export (runtime debugger) continue-from-derived-thread-error)