From: Chris Hanson Date: Sun, 8 Mar 1998 07:26:25 +0000 (+0000) Subject: Change interface procedure DEBUG-SCHEME-ERROR so that it returns if X-Git-Tag: 20090517-FFI~4832 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=af24563f42edba5a9f58125227ba2e752ca5fce2;p=mit-scheme.git Change interface procedure DEBUG-SCHEME-ERROR so that it returns if the user opts not to enter the debugger. Also, do a better job of presenting the error message to the user when asking whether to start the debugger. --- diff --git a/v7/src/edwin/artdebug.scm b/v7/src/edwin/artdebug.scm index a5362b059..da8eed48d 100644 --- a/v7/src/edwin/artdebug.scm +++ b/v7/src/edwin/artdebug.scm @@ -1,8 +1,8 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: artdebug.scm,v 1.24 1993/10/26 00:37:55 cph Exp $ +;;; $Id: artdebug.scm,v 1.25 1998/03/08 07:26:00 cph Exp $ ;;; -;;; Copyright (c) 1989-93 Massachusetts Institute of Technology +;;; Copyright (c) 1989-98 Massachusetts Institute of Technology ;;; ;;; This material was developed by the Scheme project at the ;;; Massachusetts Institute of Technology, Department of @@ -189,24 +189,33 @@ or #F meaning no limit." (define in-debugger? false) (define in-debugger-evaluation? false) +(define (maybe-debug-scheme-error switch-variable condition error-type-name) + (if (variable-value switch-variable) + (debug-scheme-error condition error-type-name))) + (define (debug-scheme-error condition error-type-name) - (if in-debugger? - (quit-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-buffer condition))) - (message error-type-name " error"))) - (return-to-command-loop condition)))) + (cond (in-debugger? + (quit-editor-and-signal-error condition)) + ((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)) + (debug-scheme-error? condition error-type-name))) + (fluid-let ((in-debugger? true)) + ((if (ref-variable debugger-split-window?) + select-buffer-other-window + select-buffer) + (continuation-browser-buffer condition))) + (message error-type-name " error") + (editor-beep) + (return-to-command-loop condition)))) + +(define (debug-scheme-error? condition error-type-name) + (cleanup-pop-up-buffers + (lambda () + (standard-error-report condition error-type-name #t) + (editor-beep) + (prompt-for-confirmation? "Start debugger")))) (define-command browse-continuation "Invoke the continuation-browser on CONTINUATION." diff --git a/v7/src/edwin/debug.scm b/v7/src/edwin/debug.scm index 7308533b5..46c34cac7 100644 --- a/v7/src/edwin/debug.scm +++ b/v7/src/edwin/debug.scm @@ -1,8 +1,8 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: debug.scm,v 1.41 1997/03/04 06:42:58 cph Exp $ +;;; $Id: debug.scm,v 1.42 1998/03/08 07:25:49 cph Exp $ ;;; -;;; Copyright (c) 1992-97 Massachusetts Institute of Technology +;;; Copyright (c) 1992-98 Massachusetts Institute of Technology ;;; ;;; This material was developed by the Scheme project at the ;;; Massachusetts Institute of Technology, Department of @@ -359,9 +359,8 @@ (write-description bline port) (if env-exists? (begin - (debugger-newline port) - (write-string - ";EVALUATION may occur below in the environment of the selected frame." port) + (debugger-newline port) + (write-string evaluation-line-marker port) (debugger-newline port))))) (set-buffer-point! buffer (buffer-start buffer)) (1d-table/put! (bline/properties bline) @@ -377,6 +376,9 @@ #f)) (append-message "done") buffer)))))) + +(define evaluation-line-marker + ";EVALUATION may occur below in the environment of the selected frame.") (define-command browser-quit "Exit the current browser, deleting its buffer." @@ -960,7 +962,6 @@ a fixed size terminal." ;;;The help messages for the debugger - (define where-help-message " COMMANDS: ? - Help q - Quit Environment browser @@ -986,6 +987,11 @@ The buffer below describes the current subproblem or reduction. ;;;; Debugger Entry +(define-command browse-continuation + "Invoke the continuation-browser on CONTINUATION." + "XBrowse Continuation" + select-continuation-browser-buffer) + (define (select-continuation-browser-buffer object #!optional thread) (set! value? #f) (let ((buffers (find-debugger-buffers))) @@ -1141,26 +1147,32 @@ The buffer below describes the current subproblem or reduction. bkvalue (apply proc args)))) -(define-command browse-continuation - "Invoke the continuation-browser on CONTINUATION." - "XBrowse Continuation" - select-continuation-browser-buffer) +;;;; External Entry Point + +(define (maybe-debug-scheme-error switch-variable condition error-type-name) + (if (variable-value switch-variable) + (debug-scheme-error condition error-type-name))) (define (debug-scheme-error condition error-type-name) - (if starting-debugger? - (quit-editor-and-signal-error condition) - (begin - (editor-beep) - (if (if (eq? 'ASK (ref-variable debugger-start-on-error?)) - (prompt-for-confirmation? "Start debugger") - (ref-variable debugger-start-on-error?)) - (begin - (fluid-let ((starting-debugger? true)) - (select-continuation-browser-buffer condition)) - (message error-type-name " error"))) - (return-to-command-loop condition)))) - -(define starting-debugger? false) + (cond (starting-debugger? + (quit-editor-and-signal-error condition)) + ((let ((start? (ref-variable debugger-start-on-error?))) + (if (eq? 'ASK start?) + (debug-scheme-error? condition error-type-name) + start?)) + (fluid-let ((starting-debugger? #t)) + (select-continuation-browser-buffer condition)) + (message (string-capitalize error-type-name) " error") + (return-to-command-loop condition)))) + +(define starting-debugger? #f) + +(define (debug-scheme-error? condition error-type-name) + (cleanup-pop-up-buffers + (lambda () + (standard-error-report condition error-type-name #t) + (editor-beep) + (prompt-for-confirmation? "Start debugger")))) ;;;; Continuation Browser Mode @@ -1616,7 +1628,6 @@ they are automatically deleted when you quit the debugger. If you wish to keep one of these buffers, simply rename it using `M-x rename-buffer': once it has been renamed, it will not be deleted automatically.") - (define-key 'environment-browser down 'browser-next-line) (define-key 'environment-browser up 'browser-previous-line) (define-key 'environment-browser button1-down 'debugger-mouse-select-bline) @@ -1625,7 +1636,6 @@ once it has been renamed, it will not be deleted automatically.") (define-key 'environment-browser #\? 'describe-mode) (define-key 'environment-browser #\q 'browser-quit) (define-key 'environment-browser #\space 'browser-select-line) - (define (environment/write-summary bline port) (write-string "E" port) @@ -1743,7 +1753,6 @@ once it has been renamed, it will not be deleted automatically.") "---------------------------------------------------------------------" port)) - (define (debugger-newline port) (if (ref-variable debugger-compact-display?) (fresh-line port) @@ -1777,7 +1786,7 @@ once it has been renamed, it will not be deleted automatically.") (show-frames (reverse env-list) (make-initialized-list (length env-list) (lambda (i) (make-string (* i 2) #\space)))))))) - + (define (print-the-local-bindings environment port) (let ((names (get-all-local-bindings environment))) (let ((n-bindings (length names)) @@ -1806,7 +1815,7 @@ once it has been renamed, it will not be deleted automatically.") (write-string " Local Bindings:" port) (debugger-newline port) (finish names)))))) - + (define (show-environment-name environment port) (write-string "ENVIRONMENT " port) (let ((package (environment->package environment))) @@ -1841,8 +1850,7 @@ once it has been renamed, it will not be deleted automatically.") (stringstring x) (symbol->string y)))))) names4)) - - + (define (show-environment-bindings-with-ind environment ind port) (let ((names (environment-bound-names environment))) (let ((n-bindings (length names)) @@ -1868,7 +1876,7 @@ once it has been renamed, it will not be deleted automatically.") (debugger-newline port)) (else (finish names)))))) - + (define (print-binding-with-ind name value ind port) (let ((x-size (- (output-port/x-size port) (string-length ind) 4))) (write-string (string-append ind " ") @@ -1888,8 +1896,7 @@ once it has been renamed, it will not be deleted automatically.") (write value))))))) port) (debugger-newline port))) - - + ;;;; Interface Port (define (operation/write-char port char) diff --git a/v7/src/edwin/editor.scm b/v7/src/edwin/editor.scm index 81cba0a40..b983cda2a 100644 --- a/v7/src/edwin/editor.scm +++ b/v7/src/edwin/editor.scm @@ -1,8 +1,8 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: editor.scm,v 1.242 1997/12/23 04:36:56 cph Exp $ +;;; $Id: editor.scm,v 1.243 1998/03/08 07:26:16 cph Exp $ ;;; -;;; Copyright (c) 1986, 1989-97 Massachusetts Institute of Technology +;;; Copyright (c) 1986, 1989-98 Massachusetts Institute of Technology ;;; ;;; This material was developed by the Scheme project at the ;;; Massachusetts Institute of Technology, Department of @@ -296,9 +296,10 @@ with the contents of the startup message." (exit-editor)) (debug-internal-errors? (error condition)) - ((ref-variable debug-on-internal-error) - (debug-scheme-error condition "internal")) (else + (maybe-debug-scheme-error + (ref-variable-object debug-on-internal-error) + condition "internal") (editor-beep) (message (condition/report-string condition)) (return-to-command-loop condition)))) @@ -306,9 +307,10 @@ with the contents of the startup message." (define-variable debug-on-internal-error "True means enter debugger if error is signalled while the editor is running. This does not affect editor errors or evaluation errors." - false) + #f + boolean?) -(define debug-internal-errors? false) +(define debug-internal-errors? #f) (define condition-type:editor-error (make-condition-type 'EDITOR-ERROR condition-type:error '(STRINGS) @@ -329,18 +331,73 @@ This does not affect editor errors or evaluation errors." (condition-accessor condition-type:editor-error 'STRINGS)) (define (editor-error-handler condition) - (if (ref-variable debug-on-editor-error) - (debug-scheme-error condition "editor") - (begin - (editor-beep) - (let ((strings (editor-error-strings condition))) - (if (not (null? strings)) - (apply message strings))) - (return-to-command-loop condition)))) + (maybe-debug-scheme-error (ref-variable-object debug-on-editor-error) + condition "editor") + (editor-beep) + (let ((strings (editor-error-strings condition))) + (if (not (null? strings)) + (apply message strings))) + (return-to-command-loop condition)) (define-variable debug-on-editor-error "True means signal Scheme error when an editor error occurs." - false) + #f + boolean?) + +(define (standard-error-report condition error-type-name in-prompt?) + (let ((report-string (condition/report-string condition))) + (let ((typein-report + (lambda () + (message (string-capitalize error-type-name) + " error: " + report-string))) + (error-buffer-report + (lambda () + (string->temporary-buffer report-string "*error*" + '(SHRINK-WINDOW)) + (message (string-capitalize error-type-name) " error") + (update-screens! #f))) + (transcript-report + (lambda () + (and (ref-variable enable-transcript-buffer) + (begin + (with-output-to-transcript-buffer + (lambda () + (fresh-line) + (write-string ";Error: ") + (write-string report-string) + (newline) + (newline))) + #t))))) + (let ((fit-report + (lambda () + (if (and (not in-prompt?) + (not (string-find-next-char report-string #\newline)) + (< (string-columns report-string 0 8 + default-char-image-strings) + (window-x-size (typein-window)))) + (typein-report) + (error-buffer-report))))) + (case (ref-variable error-display-mode) + ((STANDARD) (transcript-report) (fit-report)) + ((TRANSCRIPT) (or (transcript-report) (fit-report))) + ((ERROR-BUFFER) (error-buffer-report)) + ((TYPEIN) (if in-prompt? (error-buffer-report) (typein-report))) + ((FIT) (fit-report))))))) + +(define-variable error-display-mode + "Value of this variable controls the way evaluation error messages +are displayed: +STANDARD like FIT, except messages also appear in transcript buffer, + if it is enabled. +FIT messages appear in typein window if they fit; + in *error* buffer if they don't. +TYPEIN messages appear in typein window. +ERROR-BUFFER messages appear in *error* buffer. +TRANSCRIPT messages appear in transcript buffer, if it is enabled; + otherwise this is the same as FIT." + 'STANDARD + (lambda (value) (memq value '(STANDARD TRANSCRIPT ERROR-BUFFER TYPEIN FIT)))) (define condition-type:abort-current-command (make-condition-type 'ABORT-CURRENT-COMMAND #f '(INPUT) diff --git a/v7/src/edwin/edwin.pkg b/v7/src/edwin/edwin.pkg index 62bc19c5a..7b800477c 100644 --- a/v7/src/edwin/edwin.pkg +++ b/v7/src/edwin/edwin.pkg @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: edwin.pkg,v 1.221 1998/02/12 05:57:40 cph Exp $ +$Id: edwin.pkg,v 1.222 1998/03/08 07:26:25 cph Exp $ Copyright (c) 1989-98 Massachusetts Institute of Technology @@ -829,7 +829,8 @@ MIT in each case. |# edwin-variable$debugger-start-new-screen? edwin-variable$debugger-start-on-error? edwin-variable$debugger-verbose-mode? - edwin-variable$environment-package-limit) + edwin-variable$environment-package-limit + maybe-debug-scheme-error) (import (runtime debugger) command/condition-restart command/frame diff --git a/v7/src/edwin/evlcom.scm b/v7/src/edwin/evlcom.scm index aca29aadd..206d1c7fc 100644 --- a/v7/src/edwin/evlcom.scm +++ b/v7/src/edwin/evlcom.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: evlcom.scm,v 1.54 1998/03/07 08:54:02 cph Exp $ +;;; $Id: evlcom.scm,v 1.55 1998/03/08 07:26:07 cph Exp $ ;;; ;;; Copyright (c) 1986, 1989-98 Massachusetts Institute of Technology ;;; @@ -489,67 +489,14 @@ Set by Scheme evaluation code to update the mode line." evaluation-error-handler (lambda () (hook/repl-eval #f 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) - (return-to-command-loop condition)))) - -(define (default-report-error condition error-type-name) - (let ((report-string (condition/report-string condition))) - (let ((typein-report - (lambda () - (message (string-capitalize error-type-name) - " error: " - report-string))) - (error-buffer-report - (lambda () - (string->temporary-buffer report-string "*error*") - (update-screens! #f) - (message (string-capitalize error-type-name) " error"))) - (transcript-report - (lambda () - (and (ref-variable enable-transcript-buffer) - (begin - (with-output-to-transcript-buffer - (lambda () - (fresh-line) - (write-string ";Error: ") - (write-string report-string) - (newline) - (newline))) - #t))))) - (let ((fit-report - (lambda () - (if (and (not (string-find-next-char report-string #\newline)) - (< (string-columns report-string 0 8 - default-char-image-strings) - (window-x-size (typein-window)))) - (typein-report) - (error-buffer-report))))) - (case (ref-variable error-display-mode) - ((STANDARD) (transcript-report) (fit-report)) - ((TRANSCRIPT) (or (transcript-report) (fit-report))) - ((ERROR-BUFFER) (error-buffer-report)) - ((TYPEIN) (typein-report)) - ((FIT) (fit-report))))))) - -(define-variable error-display-mode - "Value of this variable controls the way evaluation error messages -are displayed: -STANDARD like FIT, except messages also appear in transcript buffer, - if it is enabled. -FIT messages appear in typein window if they fit; - in *error* buffer if they don't. -TYPEIN messages appear in typein window. -ERROR-BUFFER messages appear in *error* buffer. -TRANSCRIPT messages appear in transcript buffer, if it is enabled; - otherwise this is the same as FIT." - 'STANDARD - (lambda (value) (memq value '(STANDARD TRANSCRIPT ERROR-BUFFER TYPEIN FIT)))) + (maybe-debug-scheme-error (ref-variable-object debug-on-evaluation-error) + condition + "evaluation") + (standard-error-report condition "evaluation" #f) + (editor-beep) + (return-to-command-loop condition)) ;;;; Transcript Buffer @@ -572,7 +519,7 @@ TRANSCRIPT messages appear in transcript buffer, if it is enabled; unspecific)))) (if (and (not (string-null? output)) (not (ref-variable evaluation-output-receiver))) - (string->temporary-buffer output "*Unsolicited-Output*"))) + (string->temporary-buffer output "*Unsolicited-Output*" '()))) value))) (define (transcript-write value buffer)