From: Chris Hanson Date: Fri, 17 Dec 1993 00:11:59 +0000 (+0000) Subject: Implement WITH-RESTART to replace BIND-RESTART. WITH-RESTART takes an X-Git-Tag: 20090517-FFI~7366 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=05cc94a488f61e9374b2410536e7f1b557ff2288;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/edwin/comred.scm b/v7/src/edwin/comred.scm index a19b2f4a0..6fe6c500d 100644 --- a/v7/src/edwin/comred.scm +++ b/v7/src/edwin/comred.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: comred.scm,v 1.109 1993/10/26 18:42:29 cph Exp $ +;;; $Id: comred.scm,v 1.110 1993/12/17 00:09:21 cph Exp $ ;;; ;;; Copyright (c) 1986, 1989-93 Massachusetts Institute of Technology ;;; @@ -129,7 +129,7 @@ (define (bind-abort-editor-command thunk) (call-with-current-continuation (lambda (continuation) - (bind-restart 'ABORT-EDITOR-COMMAND "Return to the editor command loop." + (with-restart 'ABORT-EDITOR-COMMAND "Return to the editor command loop." (lambda (#!optional input) (within-continuation continuation (lambda () @@ -137,7 +137,8 @@ (begin (reset-command-state!) (apply-input-event input)))))) - (lambda (restart) restart (thunk)))))) + values + thunk)))) (define (return-to-command-loop condition) (let ((restart (find-restart 'ABORT-EDITOR-COMMAND))) diff --git a/v7/src/edwin/schmod.scm b/v7/src/edwin/schmod.scm index 4fc0816fd..cb54151d9 100644 --- a/v7/src/edwin/schmod.scm +++ b/v7/src/edwin/schmod.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: schmod.scm,v 1.35 1993/12/10 19:25:09 cph Exp $ +;;; $Id: schmod.scm,v 1.36 1993/12/17 00:09:14 cph Exp $ ;;; ;;; Copyright (c) 1986, 1989-93 Massachusetts Institute of Technology ;;; @@ -210,7 +210,7 @@ The following commands evaluate Scheme expressions: (WITHIN-CONTINUATION . 1) (MAKE-CONDITION-TYPE . 3) - (BIND-RESTART . 3) + (WITH-RESTART . 4) (WITH-SIMPLE-RESTART . 2) (BIND-CONDITION-HANDLER . 2) (LIST-TRANSFORM-POSITIVE . 1) diff --git a/v7/src/runtime/advice.scm b/v7/src/runtime/advice.scm index 1269e46a5..f8671eff6 100644 --- a/v7/src/runtime/advice.scm +++ b/v7/src/runtime/advice.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: advice.scm,v 14.13 1993/10/21 11:49:41 cph Exp $ +$Id: advice.scm,v 14.14 1993/12/17 00:05:20 cph Exp $ Copyright (c) 1988-93 Massachusetts Institute of Technology @@ -228,13 +228,12 @@ MIT in each case. |# (call-with-current-continuation (lambda (continuation) (fluid-let ((advice-continuation continuation)) - (bind-restart 'USE-VALUE + (with-restart 'USE-VALUE "Return a value from the advised procedure." continuation - (lambda (restart) - (restart/put! restart 'INTERACTIVE - (lambda () - (prompt-for-evaluated-expression "Procedure value"))) + (lambda () + (prompt-for-evaluated-expression "Procedure value")) + (lambda () (for-each (lambda (advice) (with-simple-restart 'CONTINUE "Continue with advised procedure." diff --git a/v7/src/runtime/error.scm b/v7/src/runtime/error.scm index 88c471066..45b7a4d33 100644 --- a/v7/src/runtime/error.scm +++ b/v7/src/runtime/error.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: error.scm,v 14.40 1993/12/17 00:03:57 cph Exp $ +$Id: error.scm,v 14.41 1993/12/17 00:11:59 cph Exp $ Copyright (c) 1988-93 Massachusetts Institute of Technology @@ -316,7 +316,7 @@ MIT in each case. |# 'WITH-RESTART)) (let ((restart (%make-restart name reporter effector interactor))) (fluid-let ((*bound-restarts* (cons restart *bound-restarts*))) - (receiver restart)))) + (thunk)))) (define (with-simple-restart name reporter thunk) (call-with-current-continuation @@ -355,7 +355,7 @@ MIT in each case. |# (define (restart/put! restart key datum) (if (eq? key 'INTERACTIVE) - (set-restart/interactor! restart datum) + (set-%restart/interactor! restart datum) (1d-table/put! (restart/properties restart) key datum))) (define (bind-restart name reporter effector receiver) diff --git a/v7/src/runtime/rep.scm b/v7/src/runtime/rep.scm index 7b04464d6..fb229a18d 100644 --- a/v7/src/runtime/rep.scm +++ b/v7/src/runtime/rep.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: rep.scm,v 14.45 1993/12/06 19:34:06 cph Exp $ +$Id: rep.scm,v 14.46 1993/12/17 00:09:03 cph Exp $ Copyright (c) 1988-93 Massachusetts Institute of Technology @@ -189,7 +189,7 @@ MIT in each case. |# (define (bind-abort-restart cmdl thunk) (call-with-current-continuation (lambda (continuation) - (bind-restart 'ABORT + (with-restart 'ABORT (string-append "Return to " (if (repl? cmdl) "read-eval-print" @@ -206,10 +206,14 @@ MIT in each case. |# (port/set-default-directory port (working-directory-pathname)))) (if (default-object? message) "Abort!" message)))) - (lambda (restart) - (restart/put! restart cmdl-abort-restart-tag cmdl) + values + (lambda () + (restart/put! (first-bound-restart) cmdl-abort-restart-tag cmdl) (thunk)))))) +(define (cmdl-abort-restart? restart) + (restart/get restart cmdl-abort-restart-tag)) + (define *nearest-cmdl*) (define (nearest-cmdl) @@ -363,7 +367,7 @@ MIT in each case. |# (define (invoke-abort restart message) (let ((effector (restart/effector restart))) - (if (restart/get restart cmdl-abort-restart-tag) + (if (cmdl-abort-restart? restart) (effector message) (effector)))) @@ -599,12 +603,13 @@ MIT in each case. |# (let loop ((restarts restarts)) (if (null? restarts) '() - (cons (car restarts) - (if (restart/get (car restarts) cmdl-abort-restart-tag) - (list-transform-positive (cdr restarts) - (lambda (restart) - (restart/get restart cmdl-abort-restart-tag))) - (loop (cdr restarts))))))) + (let ((rest + (if (cmdl-abort-restart? (car restarts)) + (list-transform-positive (cdr restarts) cmdl-abort-restart?) + (loop (cdr restarts))))) + (if (restart/interactor (car restarts)) + (cons (car restarts) rest) + rest))))) (define-structure (repl-state (conc-name repl-state/) @@ -820,13 +825,13 @@ MIT in each case. |# (call-with-current-continuation (lambda (restart-continuation) (let ((continuation (or continuation restart-continuation))) - (bind-restart 'CONTINUE + (with-restart 'CONTINUE (if (string=? "bkpt>" prompt) "Return from BKPT." "Continue from breakpoint.") (lambda () (restart-continuation unspecific)) - (lambda (restart) - restart + values + (lambda () (call-with-values (lambda () (get-breakpoint-environment continuation environment message)) diff --git a/v7/src/runtime/uerror.scm b/v7/src/runtime/uerror.scm index e1b78cac5..3fedc5410 100644 --- a/v7/src/runtime/uerror.scm +++ b/v7/src/runtime/uerror.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: uerror.scm,v 14.36 1993/12/14 22:22:49 cph Exp $ +$Id: uerror.scm,v 14.37 1993/12/17 00:05:57 cph Exp $ Copyright (c) 1988-93 Massachusetts Institute of Technology @@ -93,7 +93,7 @@ MIT in each case. |# ;;;; Restart Bindings (define (unbound-variable/store-value continuation environment name thunk) - (bind-restart 'STORE-VALUE + (with-restart 'STORE-VALUE (lambda (port) (write-string "Define " port) (write name port) @@ -101,15 +101,13 @@ MIT in each case. |# (lambda (value) (local-assignment environment name value) (continuation unspecific)) - (lambda (restart) - (restart/put! restart 'INTERACTIVE - (let ((prompt (string-append "Define " (write-to-string name) " as"))) - (lambda () - (values (prompt-for-evaluated-expression prompt environment))))) - (thunk)))) + (let ((prompt (string-append "Define " (write-to-string name) " as"))) + (lambda () + (values (prompt-for-evaluated-expression prompt environment)))) + thunk)) (define (unassigned-variable/store-value continuation environment name thunk) - (bind-restart 'STORE-VALUE + (with-restart 'STORE-VALUE (lambda (port) (write-string "Set " port) (write name port) @@ -117,46 +115,40 @@ MIT in each case. |# (lambda (value) (environment-assign! environment name value) (continuation unspecific)) - (lambda (restart) - (restart/put! restart 'INTERACTIVE - (let ((prompt (string-append "Set " (write-to-string name) " to"))) - (lambda () - (values (prompt-for-evaluated-expression prompt environment))))) - (thunk)))) + (let ((prompt (string-append "Set " (write-to-string name) " to"))) + (lambda () + (values (prompt-for-evaluated-expression prompt environment)))) + thunk)) (define (variable/use-value continuation environment name thunk) (let ((continuation (continuation/next-continuation continuation))) (if continuation - (bind-restart 'USE-VALUE + (with-restart 'USE-VALUE (lambda (port) (write-string "Specify a value to use instead of " port) (write name port) (write-string "." port)) continuation - (lambda (restart) - (restart/put! restart 'INTERACTIVE - (let ((prompt - (string-append "Value to use instead of " - (write-to-string name)))) - (lambda () - (values - (prompt-for-evaluated-expression prompt environment))))) - (thunk))) + (let ((prompt + (string-append "Value to use instead of " + (write-to-string name)))) + (lambda () + (values + (prompt-for-evaluated-expression prompt environment)))) + thunk) (thunk)))) (define (inapplicable-object/use-value continuation operands thunk) (let ((continuation (continuation/next-continuation continuation))) (if continuation - (bind-restart 'USE-VALUE "Specify a procedure to use in its place." + (with-restart 'USE-VALUE "Specify a procedure to use in its place." (lambda (operator) (within-continuation continuation (lambda () (apply operator operands)))) - (lambda (restart) - (restart/put! restart 'INTERACTIVE - (lambda () - (values (prompt-for-evaluated-expression "New procedure")))) - (thunk))) + (lambda () + (values (prompt-for-evaluated-expression "New procedure"))) + thunk) (thunk)))) (define (illegal-arg-signaller type) @@ -169,17 +161,15 @@ MIT in each case. |# (define (illegal-argument/use-value continuation operator operands index thunk) (let ((continuation (continuation/next-continuation continuation))) (if continuation - (bind-restart 'USE-VALUE "Specify an argument to use in its place." + (with-restart 'USE-VALUE "Specify an argument to use in its place." (lambda (operand) (within-continuation continuation (lambda () (apply operator (substitute-element operands index operand))))) - (lambda (restart) - (restart/put! restart 'INTERACTIVE - (lambda () - (values (prompt-for-evaluated-expression "New argument")))) - (thunk))) + (lambda () + (values (prompt-for-evaluated-expression "New argument"))) + thunk) (thunk)))) (define (file-operation-signaller) @@ -198,36 +188,33 @@ MIT in each case. |# verb noun thunk) (let ((continuation (continuation/next-continuation continuation))) (if continuation - (bind-restart 'USE-VALUE + (with-restart 'USE-VALUE (string-append "Try to " verb " a different " noun ".") (lambda (operand) (within-continuation continuation (lambda () (apply operator (substitute-element operands index operand))))) - (let ((prompt - (string-append "New " - noun - " name (an expression to be evaluated)"))) - (lambda (restart) - (restart/put! restart 'INTERACTIVE - (lambda () - (values (prompt-for-evaluated-expression prompt)))) - (thunk)))) + (let ((prompt + (string-append "New " + noun + " name (an expression to be evaluated)"))) + (lambda () + (values (prompt-for-evaluated-expression prompt)))) + thunk) (thunk)))) (define (file-operation/retry continuation operator operands verb noun thunk) (let ((continuation (continuation/next-continuation continuation))) (if continuation - (bind-restart 'RETRY + (with-restart 'RETRY (string-append "Try to " verb " the same " noun " again.") (lambda () (within-continuation continuation (lambda () (apply operator operands)))) - (lambda (restart) - (restart/put! restart 'INTERACTIVE values) - (thunk))) + values + thunk) (thunk)))) (define (substitute-element list index element) diff --git a/v8/src/runtime/runtime.pkg b/v8/src/runtime/runtime.pkg index c04c16c84..08d0eb37b 100644 --- a/v8/src/runtime/runtime.pkg +++ b/v8/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)