From ef151891b9d8455b04acfcd451831bb00480882b Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Tue, 8 Aug 1989 22:00:00 +0000 Subject: [PATCH] Initial revision --- v7/src/edwin/artdebug.scm | 285 ++++++++++++++++++++++++++++++++++++++ 1 file changed, 285 insertions(+) create mode 100644 v7/src/edwin/artdebug.scm diff --git a/v7/src/edwin/artdebug.scm b/v7/src/edwin/artdebug.scm new file mode 100644 index 000000000..7c27f1b9d --- /dev/null +++ b/v7/src/edwin/artdebug.scm @@ -0,0 +1,285 @@ +;;; -*-Scheme-*- +;;; +;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/artdebug.scm,v 1.1 1989/08/08 22:00:00 cph Exp $ +;;; +;;; Copyright (c) 1989 Massachusetts Institute of Technology +;;; +;;; This material was developed by the Scheme project at the +;;; Massachusetts Institute of Technology, Department of +;;; Electrical Engineering and Computer Science. Permission to +;;; copy this software, to redistribute it, and to use it for any +;;; purpose is granted, subject to the following restrictions and +;;; understandings. +;;; +;;; 1. Any copy made of this software must include this copyright +;;; notice in full. +;;; +;;; 2. Users of this software agree to make their best efforts (a) +;;; to return to the MIT Scheme project any improvements or +;;; extensions that they make, so that these may be included in +;;; future releases; and (b) to inform MIT of noteworthy uses of +;;; this software. +;;; +;;; 3. All materials developed as a consequence of the use of this +;;; software shall duly acknowledge such use, in accordance with +;;; the usual standards of acknowledging credit in academic +;;; research. +;;; +;;; 4. MIT has made no warrantee or representation that the +;;; operation of this software will be error-free, and MIT is +;;; under no obligation to provide any services, by way of +;;; maintenance, update, or otherwise. +;;; +;;; 5. In conjunction with products arising from the use of this +;;; material, there shall be no use of the name of the +;;; Massachusetts Institute of Technology nor of any adaptation +;;; thereof in any advertising, promotional, or sales literature +;;; without prior written consent from MIT in each case. +;;; +;;; NOTE: Parts of this program (Edwin) were created by translation +;;; from corresponding parts of GNU Emacs. Users should be aware that +;;; the GNU GENERAL PUBLIC LICENSE may apply to these parts. A copy +;;; of that license should have been included along with this file. +;;; + +;;;; Continuation Browser + +(declare (usual-integrations)) + +(define in-debugger? false) + +(define (debug-scheme-error condition) + (if in-debugger? + (exit-editor-and-signal-error condition) + (fluid-let ((in-debugger? true)) + (let* ((continuation (condition/continuation condition)) + (buffer (continuation-browser continuation))) + (buffer-put! buffer 'DEBUG-CONDITION condition) + (select-buffer buffer) + (standard-output buffer + (lambda () + (write-string + (substitute-command-keys + "This is a debugger buffer: +Type \\[continuation-browser-quit] to exit. +Type \\[continuation-browser-print-reduction] to see where you are. +Type \\[describe-mode] for more information. + +The error that started the debugger is: +")) + ((condition/reporter condition) condition + (current-output-port)))))))) + +(define-command browse-continuation + "Invoke the continuation-browser on CONTINUATION." + "XBrowse Continuation" + (lambda (continuation) + (if (not (continuation? continuation)) (editor-error "Not a continuation")) + (let ((buffer (continuation-browser continuation))) + (invoke-debugger-command command/print-reduction buffer) + (select-buffer buffer)))) + +(define (continuation-browser continuation) + (let ((buffer (new-buffer "*debug*"))) + (set-buffer-major-mode! buffer (ref-mode-object continuation-browser)) + (buffer-put! buffer 'DEBUG-CONTINUATION continuation) + (buffer-put! buffer 'DEBUG-STATE (make-initial-dstate continuation)) + (with-selected-buffer buffer + (lambda () + (setup-buffer-environment! buffer))) + buffer)) + +(define-integrable (buffer-dstate buffer) + (buffer-get buffer 'DEBUG-STATE)) + +(define (debugger-command-invocation command) + (lambda () + (invoke-debugger-command command (current-buffer)))) + +(define (invoke-debugger-command command buffer) + (with-debugger-hooks buffer + (lambda () + (command (buffer-dstate buffer)))) + (setup-buffer-environment! buffer)) + +(define (with-debugger-hooks buffer thunk) + (fluid-let ((hook/prompt-for-confirmation + (lambda (cmdl prompt) + cmdl ;ignore + (prompt-for-confirmation prompt))) + (hook/prompt-for-expression + (lambda (cmdl prompt) + cmdl ;ignore + (prompt-for-expression prompt false))) (hook/debugger-failure + (lambda (string) + (message string) + (editor-beep))) + (hook/debugger-message message) + (hook/presentation + (lambda (thunk) + (standard-output buffer (lambda () (thunk) (newline)))))) + (thunk))) + +(define (standard-output buffer thunk) + (set-buffer-writeable! buffer) + (region-delete! (buffer-region buffer)) + (with-output-to-mark (buffer-point buffer) thunk) + (buffer-not-modified! buffer) + (set-buffer-read-only! buffer) + (set-buffer-point! buffer (buffer-start buffer))) + +(define (setup-buffer-environment! buffer) + (set-variable! + scheme-environment + (let ((environment-list (dstate/environment-list (buffer-dstate buffer)))) + (if (and (pair? environment-list) + (environment? (car environment-list))) + (car environment-list) + 'DEFAULT)))) + +(define-command continuation-browser-print-reduction + "Print the current reduction in the standard format." + () + (debugger-command-invocation command/print-reduction)) + +(define-command continuation-browser-print-expression + "Pretty-print the current expression." + () + (debugger-command-invocation command/print-expression)) + +(define-command continuation-browser-print-environment-procedure + "Pretty-print the procedure that created the current environment." + () + (debugger-command-invocation command/print-environment-procedure)) + +(define-command continuation-browser-print-reductions + "Print all the reductions of the current subproblem." + () + (debugger-command-invocation command/print-reductions)) + +(define-command continuation-browser-summarize-history + "Print a summary of all subproblems." + () + (debugger-command-invocation command/summarize-history)) + +(define-command continuation-browser-goto + "Move to an arbitrary subproblem/reduction. +Prompts for the subproblem and reduction numbers." + () + (debugger-command-invocation command/goto)) + +(define-command continuation-browser-earlier-subproblem + "Move to the next earlier subproblem." + () + (debugger-command-invocation command/earlier-subproblem)) + +(define-command continuation-browser-earlier-reduction + "Move to the next earlier reduction. +If there are no earlier reductions for this subproblem, +move to the next earlier subproblem." + () + (debugger-command-invocation command/earlier-reduction)) + +(define-command continuation-browser-later-subproblem + "Move to the next later subproblem." + () + (debugger-command-invocation command/later-subproblem)) + +(define-command continuation-browser-later-reduction + "Move to the next later reduction. +If there are no later reductions for this subproblem, +move to the next later subproblem." + () + (debugger-command-invocation command/later-reduction)) + +(define-command continuation-browser-show-current-frame + "Print the bindings of the current frame of the current environment." + () + (debugger-command-invocation command/show-current-frame)) + +(define-command continuation-browser-show-all-frames + "Print the bindings of all frames of the current environment." + () + (debugger-command-invocation command/show-all-frames)) + +(define-command continuation-browser-move-to-parent-environment + "Move to the environment frame which is the parent of the current one." + () + (debugger-command-invocation command/move-to-parent-environment)) + +(define-command continuation-browser-move-to-child-environment + "Move to the environment frame which is the child of the current one." + () + (debugger-command-invocation command/move-to-child-environment)) + +(define-command continuation-browser-return + "Invoke the continuation which is the current subproblem, +supplying it with a value which is prompted for." + () + (debugger-command-invocation command/return)) + +(define-command continuation-browser-frame + "Show the current subproblem's stack-frame in internal format." + () + (debugger-command-invocation command/frame)) + +(define-command continuation-browser-quit + "Kill the current continuation-browser." + () + (lambda () + (kill-buffer-interactive (current-buffer)))) + +(define-command continuation-browser-error-info + "Show the error-message associated with this continuation." + () + (lambda () + (let ((buffer (current-buffer))) + (with-debugger-hooks buffer + (lambda () + (show-error-info (buffer-get buffer 'DEBUG-CONDITION))))))) + +(define-major-mode continuation-browser fundamental "Debug" + "You are in the Scheme debugger, where you can do the following: + +\\[continuation-browser-show-all-frames] shows bindings of the current environment and its ancestors. +\\[continuation-browser-earlier-reduction] moves Back to the previous reduction. +\\[continuation-browser-show-current-frame] shows bindings of identifiers in the Current environment. +\\[continuation-browser-later-subproblem] moves Down to the next subproblem. +\\[continuation-browser-error-info] prints the Error message. +\\[continuation-browser-later-reduction] moves Forward to the next reduction. +\\[continuation-browser-goto] Goes to an arbitrary subproblem and reduction. +\\[continuation-browser-summarize-history] prints a summary of all subproblems (History). +\\[continuation-browser-print-expression] pretty-prints the current expression. +\\[continuation-browser-print-environment-procedure] pretty-prints the procedure that created the current environment. +\\[continuation-browser-move-to-parent-environment] moves to the environment which is the Parent of the current environment. +\\[continuation-browser-print-reductions] shows all the Reductions in the current subproblem. +\\[continuation-browser-move-to-child-environment] moves to the child of the current environment (in current chain). +\\[continuation-browser-print-reduction] shows the current reduction. +\\[continuation-browser-earlier-subproblem] moves Up to the previous subproblem. +\\[continuation-browser-frame] displays the current stack-frame in internal format. +\\[continuation-browser-return] returns (continues with) an expression after evaluating it." + (local-set-variable! scheme-environment (ref-variable scheme-environment))) + +(define-key 'continuation-browser #\? 'describe-mode) +(define-key 'continuation-browser #\a 'continuation-browser-show-all-frames) +(define-key 'continuation-browser #\b 'continuation-browser-earlier-reduction) +(define-key 'continuation-browser #\c 'continuation-browser-show-current-frame) +(define-key 'continuation-browser #\d 'continuation-browser-later-subproblem) +(define-key 'continuation-browser #\e 'continuation-browser-error-info) +(define-key 'continuation-browser #\f 'continuation-browser-later-reduction) +(define-key 'continuation-browser #\g 'continuation-browser-goto) +(define-key 'continuation-browser #\h 'continuation-browser-summarize-history) +(define-key 'continuation-browser #\l 'continuation-browser-print-expression) +(define-key 'continuation-browser #\o + 'continuation-browser-print-environment-procedure) +(define-key 'continuation-browser #\p + 'continuation-browser-move-to-parent-environment) +(define-key 'continuation-browser #\q 'continuation-browser-quit) +(define-key 'continuation-browser #\r 'continuation-browser-print-reductions) +(define-key 'continuation-browser #\s + 'continuation-browser-move-to-child-environment) +(define-key 'continuation-browser #\t 'continuation-browser-print-reduction) +(define-key 'continuation-browser #\u 'continuation-browser-earlier-subproblem) +(define-key 'continuation-browser #\v 'eval-expression) +(define-key 'continuation-browser #\y 'continuation-browser-frame) +(define-key 'continuation-browser #\z 'continuation-browser-return) \ No newline at end of file -- 2.25.1