From 5d512c377015e2f4f8618816701c6ab1388cc3a3 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Thu, 23 Dec 1993 08:03:45 +0000 Subject: [PATCH] When invoking restart in another thread, must call RESTART-THREAD. Also, look for a special CONTINUE restart in the current thread and invoke that. --- v7/src/runtime/debug.scm | 95 ++++++++++++----------------- v7/src/runtime/error.scm | 51 +++++++++++++--- v7/src/runtime/rep.scm | 121 ++++++++++++++++++------------------- v7/src/runtime/runtime.pkg | 5 +- v8/src/runtime/runtime.pkg | 5 +- 5 files changed, 149 insertions(+), 128 deletions(-) diff --git a/v7/src/runtime/debug.scm b/v7/src/runtime/debug.scm index 69b50b469..3b672b176 100644 --- a/v7/src/runtime/debug.scm +++ b/v7/src/runtime/debug.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: debug.scm,v 14.37 1993/12/22 01:26:13 jmiller Exp $ +$Id: debug.scm,v 14.38 1993/12/23 08:03:35 cph Exp $ Copyright (c) 1988-1993 Massachusetts Institute of Technology @@ -694,38 +694,40 @@ MIT in each case. |# (debugger-failure port "No condition to report.")))) (define-command (command/condition-restart dstate port) - (let ((restarts - (let ((condition (dstate/condition dstate))) + (let ((condition (dstate/condition dstate))) + (let ((restarts (if condition (condition/restarts condition) - (bound-restarts))))) - (if (null? restarts) - (debugger-failure port "No options to choose from.") - (let ((n-restarts (length restarts)) - (write-index - (lambda (index port) - (write-string (string-pad-left (number->string index) 3) port) - (write-string ":" port)))) - (let ((invoke-option - (lambda (n) - (invoke-restart-interactively - (list-ref restarts (- n-restarts n)))))) - (debugger-presentation port - (lambda () - (if (= n-restarts 1) - (begin - (write-string "There is only one option:" port) - (write-restarts restarts port write-index) - (if (prompt-for-confirmation "Use this option" port) - (invoke-option 1))) - (begin - (write-string "Choose an option by number:" port) - (write-restarts restarts port write-index) - (invoke-option - (prompt-for-integer "Option number" - 1 - (+ n-restarts 1) - port))))))))))) + (bound-restarts)))) + (if (null? restarts) + (debugger-failure port "No options to choose from.") + (let ((n-restarts (length restarts)) + (write-index + (lambda (index port) + (write-string (string-pad-left (number->string index) 3) + port) + (write-string ":" port)))) + (let ((invoke-option + (lambda (n) + (invoke-restart-interactively + (list-ref restarts (- n-restarts n)) + condition)))) + (debugger-presentation port + (lambda () + (if (= n-restarts 1) + (begin + (write-string "There is only one option:" port) + (write-restarts restarts port write-index) + (if (prompt-for-confirmation "Use this option" port) + (invoke-option 1))) + (begin + (write-string "Choose an option by number:" port) + (write-restarts restarts port write-index) + (invoke-option + (prompt-for-integer "Option number" + 1 + (+ n-restarts 1) + port)))))))))))) ;;;; Advanced hacking commands @@ -769,33 +771,16 @@ MIT in each case. |# (if (not thread) ((stack-frame->continuation subproblem) value) (begin - (restart-thread - thread - (prompt-for-confirmation - "Restarting other thread; discard events in its queue" - port) - (lambda () - ((stack-frame->continuation subproblem) value))) - (if (prompt-for-confirmation - "Thread restarted; exit debugger" - port) - (standard-exit-command dstate port)))))))))) + (restart-thread thread 'ASK + (lambda () + ((stack-frame->continuation subproblem) value))) + (continue-from-derived-thread-error + (dstate/condition dstate)))))))))) -(define (dstate/thread dstate) +(define (dstate/other-thread dstate) (let ((condition (dstate/condition dstate))) (and condition - (condition/derived-thread? condition) - (access-condition condition 'THREAD)))) - -(define (dstate/other-thread dstate) - (let ((thread - (let ((condition (dstate/condition dstate))) - (and condition - (condition/derived-thread? condition) - (access-condition condition 'THREAD))))) - (and thread - (not (eq? thread (current-thread))) - thread))) + (condition/other-thread condition)))) (define hook/debugger-before-return) (define (default/debugger-before-return) diff --git a/v7/src/runtime/error.scm b/v7/src/runtime/error.scm index b78d37506..deb2200ba 100644 --- a/v7/src/runtime/error.scm +++ b/v7/src/runtime/error.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: error.scm,v 14.44 1993/12/17 02:47:39 cph Exp $ +$Id: error.scm,v 14.45 1993/12/23 08:03:22 cph Exp $ Copyright (c) 1988-93 Massachusetts Institute of Technology @@ -368,14 +368,38 @@ MIT in each case. |# (guarantee-restart restart 'INVOKE-RESTART) (hook/invoke-restart (%restart/effector restart) arguments)) -(define (invoke-restart-interactively restart) +(define (invoke-restart-interactively restart #!optional condition) (guarantee-restart restart 'INVOKE-RESTART-INTERACTIVELY) - (hook/invoke-restart - (%restart/effector restart) - (let ((interactor (%restart/interactor restart))) - (if interactor - (call-with-values interactor list) - '())))) + (let ((effector (%restart/effector restart)) + (arguments + (let ((interactor (%restart/interactor restart))) + (if interactor + (call-with-values interactor list) + '()))) + (condition (if (default-object? condition) #f condition))) + (let ((thread (and condition (condition/other-thread condition)))) + (if thread + (begin + (restart-thread thread 'ASK + (lambda () + (hook/invoke-restart effector arguments))) + (continue-from-derived-thread-error condition)) + (hook/invoke-restart effector arguments))))) + +(define (condition/other-thread condition) + (and (condition/derived-thread? condition) + (let ((thread (access-condition condition 'THREAD))) + (and (not (eq? thread (current-thread))) + thread)))) + +(define (continue-from-derived-thread-error condition) + (let loop ((restarts (bound-restarts))) + (if (not (null? restarts)) + (if (and (eq? 'CONTINUE (restart/name (car restarts))) + (eq? condition + (restart/get (car restarts) 'ASSOCIATED-CONDITION))) + (invoke-restart (car restarts)) + (loop (cdr restarts)))))) (define hook/invoke-restart) @@ -949,10 +973,17 @@ MIT in each case. |# '(THREAD CONDITION)))) (lambda (thread condition) (guarantee-condition condition 'ERROR:DERIVED-THREAD) - (error (make-condition (%condition/continuation condition) + (let ((condition + (make-condition (%condition/continuation condition) (%condition/restarts condition) thread - condition))))) + condition))) + (with-simple-restart 'CONTINUE "Continue from error." + (lambda () + (restart/put! (first-bound-restart) + 'ASSOCIATED-CONDITION + condition) + (error condition))))))) (set! condition/derived-thread? (condition-predicate condition-type:derived-thread-error)) diff --git a/v7/src/runtime/rep.scm b/v7/src/runtime/rep.scm index fb229a18d..cea263b83 100644 --- a/v7/src/runtime/rep.scm +++ b/v7/src/runtime/rep.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: rep.scm,v 14.46 1993/12/17 00:09:03 cph Exp $ +$Id: rep.scm,v 14.47 1993/12/23 08:03:10 cph Exp $ Copyright (c) 1988-93 Massachusetts Institute of Technology @@ -174,10 +174,8 @@ MIT in each case. |# (error "Non-owner thread can't start CMDL:" thread))))) (lambda () - (with-simple-restart 'CONTINUE "Continue from error." - (lambda () - (unblock-thread-events) - (signaller cmdl thread)))))) + (unblock-thread-events) + (signaller cmdl thread)))) (stop-current-thread)) ((let ((parent (cmdl/parent cmdl))) (and parent @@ -530,65 +528,55 @@ MIT in each case. |# (write-string ";Package: " port) (write (package/name package) port)))))))) -(define (condition-restarts-message condition) - (cmdl-message/active - (lambda (port) - (fresh-line port) - (write-string ";To continue, call RESTART with an option number:" port) - (write-restarts (filter-restarts (condition/restarts condition)) port - (lambda (index port) - (write-string "; (RESTART " port) - (write index port) - (write-string ") =>" port)))))) - (define (restart #!optional n) - (let ((restarts - (filter-restarts - (let ((condition (nearest-repl/condition))) + (let ((condition (nearest-repl/condition))) + (let ((restarts + (filter-restarts (if condition (condition/restarts condition) - (bound-restarts)))))) - (let ((n-restarts (length restarts))) - (if (zero? n-restarts) - (error "Can't RESTART: no options available.")) - (invoke-restart-interactively - (list-ref - restarts - (- n-restarts - (if (default-object? n) - (let ((port (interaction-i/o-port))) - (fresh-line port) - (write-string ";Choose an option by number:" port) - (write-restarts restarts port - (lambda (index port) - (write-string ";" port) - (write-string (string-pad-left (number->string index) 3) - port) - (write-string ":" port))) - (let loop () - (let ((n - (prompt-for-evaluated-expression - "Option number" - (nearest-repl/environment) - port))) - (if (and (exact-integer? n) (<= 1 n n-restarts)) - n - (begin - (beep port) - (fresh-line port) - (write-string - ";Option must be an integer between 1 and " - port) - (write n-restarts port) - (write-string ", inclusive.") - (loop)))))) - (begin - (if (not (exact-integer? n)) - (error:wrong-type-argument n "exact integer" 'RESTART)) - (if (not (<= 1 n n-restarts)) - (error:bad-range-argument n 'RESTART)) - n)))))))) - + (bound-restarts))))) + (let ((n-restarts (length restarts))) + (if (zero? n-restarts) + (error "Can't RESTART: no options available.")) + (invoke-restart-interactively + (list-ref + restarts + (- n-restarts + (if (default-object? n) + (let ((port (interaction-i/o-port))) + (fresh-line port) + (write-string ";Choose an option by number:" port) + (write-restarts restarts port + (lambda (index port) + (write-string ";" port) + (write-string (string-pad-left (number->string index) 3) + port) + (write-string ":" port))) + (let loop () + (let ((n + (prompt-for-evaluated-expression + "Option number" + (nearest-repl/environment) + port))) + (if (and (exact-integer? n) (<= 1 n n-restarts)) + n + (begin + (beep port) + (fresh-line port) + (write-string + ";Option must be an integer between 1 and " + port) + (write n-restarts port) + (write-string ", inclusive.") + (loop)))))) + (begin + (if (not (exact-integer? n)) + (error:wrong-type-argument n "exact integer" 'RESTART)) + (if (not (<= 1 n n-restarts)) + (error:bad-range-argument n 'RESTART)) + n)))) + condition))))) + (define (write-restarts restarts port write-index) (newline port) (do ((restarts restarts (cdr restarts)) @@ -610,6 +598,17 @@ MIT in each case. |# (if (restart/interactor (car restarts)) (cons (car restarts) rest) rest))))) + +(define (condition-restarts-message condition) + (cmdl-message/active + (lambda (port) + (fresh-line port) + (write-string ";To continue, call RESTART with an option number:" port) + (write-restarts (filter-restarts (condition/restarts condition)) port + (lambda (index port) + (write-string "; (RESTART " port) + (write index port) + (write-string ") =>" port)))))) (define-structure (repl-state (conc-name repl-state/) diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg index 08d0eb37b..16b7666ab 100644 --- a/v7/src/runtime/runtime.pkg +++ b/v7/src/runtime/runtime.pkg @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: runtime.pkg,v 14.221 1993/12/17 00:05:06 cph Exp $ +$Id: runtime.pkg,v 14.222 1993/12/23 08:03:45 cph Exp $ Copyright (c) 1988-1993 Massachusetts Institute of Technology @@ -587,6 +587,7 @@ MIT in each case. |# condition/derived-thread? condition/error? condition/get + condition/other-thread condition/properties condition/put! condition/report-string @@ -643,6 +644,8 @@ MIT in each case. |# (export (runtime rep) *bound-restarts* dynamic-handler-frames) + (export (runtime debugger) + continue-from-derived-thread-error) (initialization (initialize-package!))) (define-package (runtime event-distributor) diff --git a/v8/src/runtime/runtime.pkg b/v8/src/runtime/runtime.pkg index 08d0eb37b..16b7666ab 100644 --- a/v8/src/runtime/runtime.pkg +++ b/v8/src/runtime/runtime.pkg @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: runtime.pkg,v 14.221 1993/12/17 00:05:06 cph Exp $ +$Id: runtime.pkg,v 14.222 1993/12/23 08:03:45 cph Exp $ Copyright (c) 1988-1993 Massachusetts Institute of Technology @@ -587,6 +587,7 @@ MIT in each case. |# condition/derived-thread? condition/error? condition/get + condition/other-thread condition/properties condition/put! condition/report-string @@ -643,6 +644,8 @@ MIT in each case. |# (export (runtime rep) *bound-restarts* dynamic-handler-frames) + (export (runtime debugger) + continue-from-derived-thread-error) (initialization (initialize-package!))) (define-package (runtime event-distributor) -- 2.25.1