From: Chris Hanson Date: Fri, 17 Dec 1993 00:05:06 +0000 (+0000) Subject: Implement WITH-RESTART to replace BIND-RESTART. WITH-RESTART takes an X-Git-Tag: 20090517-FFI~7367 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=8ffd6a04b00c6335f653cf9f9c8f259ab7292fb8;p=mit-scheme.git Implement WITH-RESTART to replace BIND-RESTART. WITH-RESTART takes an additional argument that specifies the interactor -- this is no longer done by means of a restart property. --- diff --git a/v7/src/runtime/error.scm b/v7/src/runtime/error.scm index 60752cfc1..88c471066 100644 --- a/v7/src/runtime/error.scm +++ b/v7/src/runtime/error.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: error.scm,v 14.39 1993/12/16 23:28:51 cph Exp $ +$Id: error.scm,v 14.40 1993/12/17 00:03:57 cph Exp $ Copyright (c) 1988-93 Massachusetts Institute of Technology @@ -302,51 +302,66 @@ MIT in each case. |# (name false read-only true) (reporter false read-only true) (effector false read-only true) + (interactor false) (properties (make-1d-table) read-only true)) -(define (bind-restart name reporter effector receiver) - (if name (guarantee-symbol name 'BIND-RESTART)) +(define (with-restart name reporter effector interactor thunk) + (if name (guarantee-symbol name 'WITH-RESTART)) (if (not (or (string? reporter) (procedure-of-arity? reporter 1))) - (error:wrong-type-argument reporter "restart reporter" 'BIND-RESTART)) + (error:wrong-type-argument reporter "restart reporter" 'WITH-RESTART)) (if (not (procedure? effector)) - (error:wrong-type-argument effector "restart effector" 'BIND-RESTART)) - (let ((restart (%make-restart name reporter effector))) + (error:wrong-type-argument effector "restart effector" 'WITH-RESTART)) + (if (not (procedure? interactor)) + (error:wrong-type-argument interactor "restart interactor" + 'WITH-RESTART)) + (let ((restart (%make-restart name reporter effector interactor))) (fluid-let ((*bound-restarts* (cons restart *bound-restarts*))) (receiver restart)))) (define (with-simple-restart name reporter thunk) (call-with-current-continuation (lambda (continuation) - (bind-restart name reporter (lambda () (continuation unspecific)) - (lambda (restart) - restart - (thunk)))))) + (with-restart name reporter (lambda () (continuation unspecific)) values + thunk)))) (define (restart/name restart) (guarantee-restart restart 'RESTART/NAME) (%restart/name restart)) +(define (write-restart-report restart port) + (guarantee-restart restart 'WRITE-RESTART-REPORT) + (guarantee-output-port port 'WRITE-RESTART-REPORT) + (let ((reporter (%restart/reporter restart))) + (if (string? reporter) + (write-string reporter port) + (reporter port)))) + (define (restart/effector restart) (guarantee-restart restart 'RESTART/EFFECTOR) (%restart/effector restart)) +(define (restart/interactor restart) + (guarantee-restart restart 'RESTART/INTERACTOR) + (%restart/interactor restart)) + (define (restart/properties restart) (guarantee-restart restart 'RESTART/PROPERTIES) (%restart/properties restart)) -(define (restart/put! restart key datum) - (1d-table/put! (restart/properties restart) key datum)) - (define (restart/get restart key) - (1d-table/get (restart/properties restart) key false)) + (if (eq? key 'INTERACTIVE) + (restart/interactor restart) + (1d-table/get (restart/properties restart) key false))) -(define (write-restart-report restart port) - (guarantee-restart restart 'WRITE-RESTART-REPORT) - (guarantee-output-port port 'WRITE-RESTART-REPORT) - (let ((reporter (%restart/reporter restart))) - (if (string? reporter) - (write-string reporter port) - (reporter port)))) +(define (restart/put! restart key datum) + (if (eq? key 'INTERACTIVE) + (set-restart/interactor! restart datum) + (1d-table/put! (restart/properties restart) key datum))) + +(define (bind-restart name reporter effector receiver) + (with-restart name reporter effector #f + (lambda () + (receiver (car *bound-restarts*))))) (define (invoke-restart restart . arguments) (guarantee-restart restart 'INVOKE-RESTART) @@ -356,11 +371,12 @@ MIT in each case. |# (guarantee-restart restart 'INVOKE-RESTART-INTERACTIVELY) (hook/invoke-restart (%restart/effector restart) - (let ((interactive - (1d-table/get (%restart/properties restart) 'INTERACTIVE false))) - (if (not interactive) - '() - (with-values interactive list))))) + (call-with-values + (let ((interactor (%restart/interactor restart))) + (if (not interactor) + (error:bad-range-argument restart 'INVOKE-RESTART-INTERACTIVELY)) + interactor) + list))) (define hook/invoke-restart) @@ -370,6 +386,12 @@ MIT in each case. |# '() (cons (car restarts) (loop (cdr restarts)))))) +(define (first-bound-restart) + (let ((restarts *bound-restarts*)) + (if (null? restarts) + (error:no-such-restart #f)) + (car restarts))) + (define (%find-restart name restarts) (let loop ((restarts restarts)) (and (not (null? restarts)) @@ -598,27 +620,26 @@ MIT in each case. |# (cons* continuation 'BOUND-RESTARTS field-values)))) - (bind-restart 'USE-VALUE + (with-restart 'USE-VALUE (if (string? use-value-message) use-value-message (use-value-message condition)) continuation - (lambda (restart) - (restart/put! restart 'INTERACTIVE - (let ((prompt - (if (string? use-value-prompt) - use-value-prompt - (use-value-prompt condition)))) - (lambda () - (values (prompt-for-evaluated-expression prompt))))) - (bind-restart 'RETRY + (let ((prompt + (if (string? use-value-prompt) + use-value-prompt + (use-value-prompt condition)))) + (lambda () + (values (prompt-for-evaluated-expression prompt)))) + (lambda () + (with-restart 'RETRY (if (string? retry-message) retry-message (retry-message condition)) (lambda () (continuation (list-ref field-values index))) - (lambda (restart) - (restart/put! restart 'INTERACTIVE values) + values + (lambda () (signal-condition condition) (default-handler condition))))))))))) constructor))) diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg index c04c16c84..08d0eb37b 100644 --- a/v7/src/runtime/runtime.pkg +++ b/v7/src/runtime/runtime.pkg @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: runtime.pkg,v 14.220 1993/12/05 06:15:14 cph Exp $ +$Id: runtime.pkg,v 14.221 1993/12/17 00:05:06 cph Exp $ Copyright (c) 1988-1993 Massachusetts Institute of Technology @@ -609,6 +609,7 @@ MIT in each case. |# error:wrong-type-argument error:wrong-type-datum find-restart + first-bound-restart format-error-message hook/invoke-condition-handler ignore-errors @@ -619,6 +620,7 @@ MIT in each case. |# muffle-warning restart/effector restart/get + restart/interactor restart/name restart/properties restart/put! @@ -632,6 +634,7 @@ MIT in each case. |# store-value use-value warn + with-restart with-simple-restart write-condition-report write-restart-report)