From ba5c3576db938d7f01638d3c007e18549f76c9bb Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Mon, 4 Nov 1991 20:47:47 +0000 Subject: [PATCH] Change signalling of errors so that bell is run before the debugger confirmation prompt is given. Reorganize code slightly. --- v7/src/edwin/artdebug.scm | 245 +++++++++++++++++++------------------- v7/src/edwin/editor.scm | 21 ++-- v7/src/edwin/evlcom.scm | 60 +++++----- 3 files changed, 160 insertions(+), 166 deletions(-) diff --git a/v7/src/edwin/artdebug.scm b/v7/src/edwin/artdebug.scm index 1666c3350..a2ea99dd0 100644 --- a/v7/src/edwin/artdebug.scm +++ b/v7/src/edwin/artdebug.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/artdebug.scm,v 1.12 1991/09/17 14:53:45 arthur Exp $ +;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/artdebug.scm,v 1.13 1991/11/04 20:46:39 cph Exp $ ;;; ;;; Copyright (c) 1989-91 Massachusetts Institute of Technology ;;; @@ -126,19 +126,15 @@ starting a new debugger, ASK means ask the user, and false means always create a new debugger buffer. If there is more than one debugger buffer at the time a new debugger is started, the debugger will always create a new buffer." - 'ask - (lambda (value) - (or (boolean? value) - (eq? value 'ask)))) + 'ASK + (lambda (value) (or (boolean? value) (eq? value 'ASK)))) (define-variable debugger-start-on-error? "True means always start the debugger on evaluation errors, false means never start the debugger on errors, and ASK means ask the user each time." - 'ask - (lambda (value) - (or (boolean? value) - (eq? value 'ask)))) + 'ASK + (lambda (value) (or (boolean? value) (eq? value 'ASK)))) (define-variable debugger-quit-on-return? "True means quit debugger when executing a \"return\" command." @@ -173,7 +169,7 @@ or #F meaning no limit." (lambda (number) (or (not number) (and (exact-integer? number) - (positive? number))))) + (> number 0))))) (define-variable debugger-hide-system-code? "True means don't show subproblems created by the runtime system." @@ -185,29 +181,32 @@ or #F meaning no limit." true boolean?) -(define in-debugger? false) -(define in-debugger-evaluation? false) - (define-variable debugger-debug-evaluations? "True means evaluation errors in a debugger buffer start new debuggers." false boolean?) -(define (debug-scheme-error condition) - (cond (in-debugger? - (exit-editor-and-signal-error condition)) - ((not (and (if in-debugger-evaluation? - (ref-variable debugger-debug-evaluations?) - (ref-variable debugger-start-on-error?)) - (or (not (eq? (ref-variable debugger-start-on-error?) 'ask)) - (prompt-for-confirmation? "Start debugger")))) - (%editor-error)) - (else - (fluid-let ((in-debugger? true)) - ((if (ref-variable debugger-split-window?) - select-buffer-other-window - select-buffer) - (continuation-browser condition)))))) +(define in-debugger? false) +(define in-debugger-evaluation? false) + +(define (debug-scheme-error condition error-type-name) + (if in-debugger? + (exit-editor-and-signal-error condition) + (begin + (editor-beep) + (if (and (if in-debugger-evaluation? + (ref-variable debugger-debug-evaluations?) + (ref-variable debugger-start-on-error?)) + (or (not (eq? (ref-variable debugger-start-on-error?) 'ASK)) + (prompt-for-confirmation? "Start debugger"))) + (begin + (fluid-let ((in-debugger? true)) + ((if (ref-variable debugger-split-window?) + select-buffer-other-window + select-buffer) + (continuation-browser condition))) + (message error-type-name " error"))) + (abort-current-command)))) (define-command browse-continuation "Invoke the continuation-browser on CONTINUATION." @@ -223,87 +222,46 @@ or #F meaning no limit." (define-integrable (buffer-dstate buffer) (buffer-get buffer 'DEBUG-STATE)) -(define debugger-help-message - "This is a debugger buffer: - - Expressions appear one to a line, most recent first. Expressions - are evaluated in the environment of the line above the point. - - In the marker lines, - - -C- means frame was generated by Compiled code - -I- means frame was generated by Interpreted code - - S=x means frame is in subproblem number x - R=y means frame is reduction number y - #R=z means there are z reductions in the subproblem - Use \\[continuation-browser-forward-reduction] to see them - - \\[continuation-browser-print-subproblem-or-reduction] describes the current subproblem or reduction. - \\[describe-mode] shows information about debugger commands. - Use \\[kill-buffer] to quit the debugger. -") - -(define (print-help-message buffer) - (with-selected-buffer - buffer - (lambda () - (write-string - (substitute-command-keys debugger-help-message)))) - (newline)) - -(define (find-debugger-buffers) - (let ((debugger-mode (ref-mode-object continuation-browser))) - (let loop ((buffers (buffer-list))) - (cond ((null? buffers) buffers) - ((eq? (buffer-major-mode (car buffers)) - debugger-mode) - (cons (car buffers) - (loop (cdr buffers)))) - (else (loop (cdr buffers))))))) - (define (continuation-browser object) - (let ((buffer (let ((existing-buffers (find-debugger-buffers))) - (and existing-buffers - (null? (cdr existing-buffers)) - (case (ref-variable debugger-one-at-a-time?) - ((ask) + (let ((buffer + (let ((buffers (find-debugger-buffers))) + (if (and (not (null? buffers)) + (null? (cdr buffers)) + (let ((one-at-a-time? + (ref-variable debugger-one-at-a-time?))) + (if (boolean? one-at-a-time?) + one-at-a-time? (prompt-for-confirmation? - "Another debugger buffer exists. Delete it")) - ((#t) #t) - (else #f)) - (kill-buffer (car existing-buffers))) - (new-buffer "*debug*"))) + "Another debugger buffer exists. Delete it")))) + (kill-buffer (car buffers))) + (new-buffer "*debug*"))) (dstate (make-initial-dstate object))) - (let ((start-message (string-append "Starting debugger in buffer " - (buffer-name buffer) - " ..."))) - (set-buffer-major-mode! buffer (ref-mode-object continuation-browser)) - (buffer-put! buffer 'DEBUG-STATE dstate) - (let ((hide-system-code? - (ref-variable debugger-hide-system-code? buffer)) - (max-subproblems (ref-variable debugger-max-subproblems buffer)) - (top-subproblem - (let ((previous-subproblems (dstate/previous-subproblems dstate))) - (if (null? previous-subproblems) - (dstate/subproblem dstate) - (car (last-pair previous-subproblems)))))) - (with-group-undo-disabled - (buffer-group buffer) - (lambda () - (with-output-to-mark - (buffer-start buffer) + (set-buffer-major-mode! buffer (ref-mode-object continuation-browser)) + (buffer-put! buffer 'DEBUG-STATE dstate) + (let ((hide-system-code? (ref-variable debugger-hide-system-code? buffer)) + (max-subproblems (ref-variable debugger-max-subproblems buffer)) + (top-subproblem + (let ((previous-subproblems (dstate/previous-subproblems dstate))) + (if (null? previous-subproblems) + (dstate/subproblem dstate) + (car (last-pair previous-subproblems)))))) + (with-group-undo-disabled (buffer-group buffer) + (lambda () + (with-output-to-mark (buffer-start buffer) (lambda () - (if (ref-variable debugger-show-help-message?) - (print-help-message buffer)) - (if (condition? object) - (let ((port (current-output-port))) - (write-string - "The error that started the debugger is:\n ") - (write-condition-report object port) - (newline) - (newline) - (print-restarts object buffer))) + (let ((port (current-output-port))) + (if (ref-variable debugger-show-help-message? buffer) + (print-help-message buffer port)) + (if (condition? object) + (begin + (write-string "The error that started the debugger is:" + port) + (newline port) + (write-string " " port) + (write-condition-report object port) + (newline port) + (newline port) + (print-restarts object buffer port)))) (case (non-reentrant-call-with-current-continuation (lambda (finish) @@ -315,7 +273,6 @@ or #F meaning no limit." (with-values (lambda () (stack-frame/debugging-info frame)) (lambda (expression environment subexpression) - subexpression (if (and hide-system-code? (system-expression? subexpression)) (finish 'NOT-ALL-SHOWN)) @@ -329,31 +286,69 @@ or #F meaning no limit." 'ALL-SHOWN)))) ((NOT-ALL-SHOWN) (display-more-subproblems-message buffer))))))) - (let ((point (forward-one-subproblem (buffer-start buffer)))) - (set-buffer-point! buffer point) - (if (ref-variable debugger-verbose-mode? buffer) - (print-subproblem-or-reduction point (debug-dstate point))) - (push-buffer-mark! buffer point) - (buffer-not-modified! buffer) - (temporary-message (string-append start-message "done")) - buffer))))) - -(define (print-restarts condition buffer) + (let ((point (forward-one-subproblem (buffer-start buffer)))) + (set-buffer-point! buffer point) + (if (ref-variable debugger-verbose-mode? buffer) + (print-subproblem-or-reduction point (debug-dstate point))) + (push-buffer-mark! buffer point) + (buffer-not-modified! buffer) + buffer)))) + +(define (find-debugger-buffers) + (let ((debugger-mode (ref-mode-object continuation-browser))) + (let loop ((buffers (buffer-list))) + (cond ((null? buffers) + buffers) + ((eq? (buffer-major-mode (car buffers)) debugger-mode) + (cons (car buffers) (loop (cdr buffers)))) + (else + (loop (cdr buffers))))))) + +(define (print-help-message buffer port) + (write-string + (with-selected-buffer buffer + (lambda () + (substitute-command-keys debugger-help-message))) + port) + (newline port) + (newline port)) + +(define debugger-help-message + "This is a debugger buffer: + + Expressions appear one to a line, most recent first. + Expressions are evaluated in the environment of the line above the point. + + In the marker lines, + + -C- means frame was generated by Compiled code. + -I- means frame was generated by Interpreted code. + + S=x means frame is in subproblem number x . + R=y means frame is reduction number y . + #R=z means there are z reductions in the subproblem; + use \\[continuation-browser-forward-reduction] to see them. + + \\[continuation-browser-print-subproblem-or-reduction] describes the current subproblem or reduction. + \\[describe-mode] shows information about debugger commands. + Use \\[kill-buffer] to quit the debugger.") + +(define (print-restarts condition buffer port) (let ((restarts (condition/restarts condition))) (if (not (null? restarts)) - (let ((write-index (lambda (index port) - (write-string - (string-pad-left (number->string index) 3) - port) - (write-string ":" port)))) - (write-string "Restart options:") - (write-restarts restarts (current-output-port) write-index) + (begin + (write-string "Restart options:" port) + (write-restarts restarts port + (lambda (index port) + (write-string (string-pad-left (number->string index) 3) port) + (write-string ":" port))) (write-string (with-selected-buffer buffer (lambda () (substitute-command-keys - "Use \\[continuation-browser-condition-restart] to invoke any of these restarts.")))) - (newline))))) + "Use \\[continuation-browser-condition-restart] to invoke any of these restarts."))) + port) + (newline port))))) (define (count-subproblems dstate) (do ((i 0 (1+ i)) diff --git a/v7/src/edwin/editor.scm b/v7/src/edwin/editor.scm index 63464494f..fe8f4ae33 100644 --- a/v7/src/edwin/editor.scm +++ b/v7/src/edwin/editor.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/editor.scm,v 1.207 1991/10/04 06:06:27 cph Exp $ +;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/editor.scm,v 1.208 1991/11/04 20:47:33 cph Exp $ ;;; ;;; Copyright (c) 1986, 1989-91 Massachusetts Institute of Technology ;;; @@ -266,12 +266,11 @@ with the contents of the startup message." (cond (debug-internal-errors? (exit-editor-and-signal-error condition)) ((ref-variable debug-on-internal-error) - (debug-scheme-error condition) - (message "Scheme error") - (%editor-error)) + (debug-scheme-error condition "internal")) (else + (editor-beep) (message (condition/report-string condition)) - (%editor-error)))) + (abort-current-command)))) (define-variable debug-on-internal-error "True means enter debugger if error is signalled while the editor is running. @@ -305,11 +304,13 @@ This does not affect editor errors or evaluation errors." (define (editor-error-handler condition) (if (ref-variable debug-on-editor-error) - (debug-scheme-error condition) - (let ((strings (editor-error-strings condition))) - (if (not (null? strings)) - (apply message strings)))) - (%editor-error)) + (debug-scheme-error condition "editor") + (begin + (editor-beep) + (let ((strings (editor-error-strings condition))) + (if (not (null? strings)) + (apply message strings))) + (abort-current-command)))) (define-variable debug-on-editor-error "True means signal Scheme error when an editor error occurs." diff --git a/v7/src/edwin/evlcom.scm b/v7/src/edwin/evlcom.scm index 7cac50cef..00290d0bb 100644 --- a/v7/src/edwin/evlcom.scm +++ b/v7/src/edwin/evlcom.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/evlcom.scm,v 1.29 1991/09/12 23:31:52 arthur Exp $ +;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/evlcom.scm,v 1.30 1991/11/04 20:47:47 cph Exp $ ;;; ;;; Copyright (c) 1986, 1989-91 Massachusetts Institute of Technology ;;; @@ -349,30 +349,26 @@ kludge the mode line." evaluation-error-handler (lambda () (hook/repl-eval (nearest-repl) expression environment syntax-table))))) + +(define (evaluation-error-handler condition) + (default-report-error condition "evaluation") + (if (ref-variable debug-on-evaluation-error) + (debug-scheme-error condition "evaluation") + (begin + (editor-beep) + (abort-current-command)))) -(define-variable error-display-mode - "ERROR-BUFFER => Error messages always appear in *Error* buffer. -FIT => Error messages appear in Typein window if they fit and in *Error* -buffer if they don't. -TRANSCRIPT => Error messages appear in transcript buffer. -TYPEIN or False => Error messages always appear in Typein window." - 'transcript - (lambda (value) - (or (not value) - (memq value '(error-buffer fit transcript typein))))) - -(define (default-report-error condition) - (let ((report-string - (with-output-to-string - (lambda () - (write-condition-report condition (current-output-port)))))) +(define (default-report-error condition error-type-name) + (let ((report-string (condition/report-string condition))) (let ((typein-report (lambda () - (message "Evaluation error: " report-string))) + (message (string-capitalize error-type-name) + " error: " + report-string))) (error-buffer-report (lambda () (string->temporary-buffer report-string "*Error*") - (message "Evaluation error")))) + (message (string-capitalize error-type-name) " error")))) (case (ref-variable error-display-mode) ((TRANSCRIPT) (with-output-to-transcript-buffer @@ -382,24 +378,26 @@ TYPEIN or False => Error messages always appear in Typein window." (display report-string) (newline) (newline)))) + ((ERROR-BUFFER) + (error-buffer-report)) + ((TYPEIN) + (typein-report)) ((FIT) (if (and (not (string-find-next-char report-string #\newline)) (< (string-columns report-string 18 false) (window-x-size (typein-window)))) (typein-report) - (error-buffer-report))) - ((ERROR-BUFFER) - (error-buffer-report)) - ((TYPEIN) - (typein-report)) - (else - (typein-report)))))) + (error-buffer-report))))))) -(define (evaluation-error-handler condition) - (default-report-error condition) - (if (ref-variable debug-on-evaluation-error) - (debug-scheme-error condition)) - (%editor-error)) +(define-variable error-display-mode + "Value of this variable controls the way evaluation errors are displayed: +TRANSCRIPT Error messages appear in transcript buffer. +ERROR-BUFFER Error messages appear in *Error* buffer. +TYPEIN Error messages appear in typein window. +FIT Error messages appear in typein window if they fit; + in *Error* buffer if they don't." + 'TRANSCRIPT + (lambda (value) (memq value '(TRANSCRIPT ERROR-BUFFER TYPEIN FIT)))) ;;;; Transcript Buffer -- 2.25.1