;;; -*-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
;;;
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."
(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."
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?)
\f
-(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."
(define-integrable (buffer-dstate buffer)
(buffer-get buffer 'DEBUG-STATE))
\f
-(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)
(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))
'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))))
+\f
+(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)))))
\f
(define (count-subproblems dstate)
(do ((i 0 (1+ i))
;;; -*-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
;;;
evaluation-error-handler
(lambda ()
(hook/repl-eval (nearest-repl) 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)
+ (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
(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))))
\f
;;;; Transcript Buffer
projects / mit-scheme.git / commitdiff