;;; -*-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
(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."
;;; -*-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
(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)
#f))
(append-message "done")
buffer))))))
+
+(define evaluation-line-marker
+ ";EVALUATION may occur below in the environment of the selected frame.")
\f
(define-command browser-quit
"Exit the current browser, deleting its buffer."
;;;The help messages for the debugger
-
(define where-help-message
" COMMANDS: ? - Help q - Quit Environment browser
\f
;;;; 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)))
bkvalue
(apply proc args))))
\f
-(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"))))
\f
;;;; Continuation Browser Mode
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)
(define-key 'environment-browser #\? 'describe-mode)
(define-key 'environment-browser #\q 'browser-quit)
(define-key 'environment-browser #\space 'browser-select-line)
-
\f
(define (environment/write-summary bline port)
(write-string "E" port)
"---------------------------------------------------------------------"
port))
-
(define (debugger-newline port)
(if (ref-variable debugger-compact-display?)
(fresh-line port)
(show-frames (reverse env-list)
(make-initialized-list (length env-list)
(lambda (i) (make-string (* i 2) #\space))))))))
-
+\f
(define (print-the-local-bindings environment port)
(let ((names (get-all-local-bindings environment)))
(let ((n-bindings (length names))
(write-string " Local Bindings:" port)
(debugger-newline port)
(finish names))))))
-\f
+
(define (show-environment-name environment port)
(write-string "ENVIRONMENT " port)
(let ((package (environment->package environment)))
(string<? (symbol->string x)
(symbol->string y))))))
names4))
-
-
+\f
(define (show-environment-bindings-with-ind environment ind port)
(let ((names (environment-bound-names environment)))
(let ((n-bindings (length names))
(debugger-newline port))
(else
(finish names))))))
-\f
+
(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 " ")
(write value)))))))
port)
(debugger-newline port)))
-
-
+\f
;;;; Interface Port
(define (operation/write-char port char)
;;; -*-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
(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))))
(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)
(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?)
+\f
+(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))))
\f
(define condition-type:abort-current-command
(make-condition-type 'ABORT-CURRENT-COMMAND #f '(INPUT)
#| -*-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
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
;;; -*-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
;;;
evaluation-error-handler
(lambda ()
(hook/repl-eval #f expression environment syntax-table)))))
-\f
+
(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))
\f
;;;; Transcript Buffer
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)
projects / mit-scheme.git / commitdiff