2021-04-26 07:53:20 -04:00
|
|
|
|
#| -*-Scheme-*-
|
|
|
|
|
|
|
|
|
|
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
|
|
|
|
|
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
|
|
|
|
|
2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
|
|
|
|
|
2017, 2018, 2019, 2020 Massachusetts Institute of Technology
|
|
|
|
|
|
|
|
|
|
This file is part of MIT/GNU Scheme.
|
|
|
|
|
|
|
|
|
|
MIT/GNU Scheme is free software; you can redistribute it and/or modify
|
|
|
|
|
it under the terms of the GNU General Public License as published by
|
|
|
|
|
the Free Software Foundation; either version 2 of the License, or (at
|
|
|
|
|
your option) any later version.
|
|
|
|
|
|
|
|
|
|
MIT/GNU Scheme is distributed in the hope that it will be useful, but
|
|
|
|
|
WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
|
|
|
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
|
|
|
|
General Public License for more details.
|
|
|
|
|
|
|
|
|
|
You should have received a copy of the GNU General Public License
|
|
|
|
|
along with MIT/GNU Scheme; if not, write to the Free Software
|
|
|
|
|
Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
|
|
|
|
|
USA.
|
|
|
|
|
|
|
|
|
|
|#
|
|
|
|
|
|
|
|
|
|
;;;; Continuation Browser
|
|
|
|
|
|
2021-04-26 07:57:47 -04:00
|
|
|
|
|
2021-04-26 07:53:20 -04:00
|
|
|
|
|
|
|
|
|
#| TO DO
|
|
|
|
|
|
|
|
|
|
Make environment browsing mode; the debugger mode can be a superset
|
|
|
|
|
of that mode: Add optional marker lines for environments. If you do
|
|
|
|
|
the C-c C-a command to describe the environment frames in the current
|
|
|
|
|
subproblem or reduction, the debugger should use the correct
|
|
|
|
|
environment when you do evaluations in those environment frames.
|
|
|
|
|
Make commands for moving by environment level. Later, change this to
|
|
|
|
|
execute Where in another buffer depending on the state of a flag.
|
|
|
|
|
|
|
|
|
|
Make a variable that specifies whether to prompt the user if more
|
|
|
|
|
than a certain number of variables are about to be printed during an
|
|
|
|
|
environment-browsing command.
|
|
|
|
|
|
|
|
|
|
By default, when the debugger starts, don't show history levels
|
|
|
|
|
inside the system. To detect system code, see
|
|
|
|
|
~arthur/new6001/detect.scm. Predicate SYSTEM-FRAME? is already
|
|
|
|
|
in place.
|
|
|
|
|
|
|
|
|
|
MarkF has code to use the correct syntax tables for evaluation.
|
|
|
|
|
|
|
|
|
|
Add limits to the depth and breadth of objects printed by the
|
|
|
|
|
debugger, to avoid problems caused by displaying circular objects.
|
|
|
|
|
Note $se/evlcom.scm: TRANSCRIPT-LIST-DEPTH-LIMIT and
|
|
|
|
|
TRANSCRIPT-LIST-BREADTH-LIMIT.
|
|
|
|
|
|
|
|
|
|
Make C-c C-k evaluate in the environment in which the error occurred.
|
|
|
|
|
Otherwise, the "Define x to a given value" restart for unbound
|
|
|
|
|
variable errors won't work. This seems to be a bug in the regular
|
|
|
|
|
debugger, too.
|
|
|
|
|
|
|
|
|
|
Make C-c C-z work in the case where an error happens during
|
|
|
|
|
evaluation of the return expression, the debugger starts on the new
|
|
|
|
|
error, and return is done from the second debugger straight through
|
|
|
|
|
the first back into the original computation. The restart itself
|
|
|
|
|
works, but the message "Scheme error" is printed upon starting the
|
|
|
|
|
second debugger.
|
|
|
|
|
|
|
|
|
|
Jinx: Depending on the state of a flag, never invoke debugger on
|
|
|
|
|
unbound variable errors from the expression you eval in the
|
|
|
|
|
interaction buffer (or debugger buffer). Actually, how about a
|
|
|
|
|
general filter on conditions that will start the debugger? Provide a
|
|
|
|
|
default filter for ignoring unbound variables.
|
|
|
|
|
|
|
|
|
|
Jinx: Display the offending expression evaluated by the user. Display
|
|
|
|
|
it just above the error message line.
|
|
|
|
|
|
|
|
|
|
Make a way to restrict the possible restarts to not include restarts
|
|
|
|
|
that could stop Edwin.
|
|
|
|
|
|
|
|
|
|
Make a narrow interface between Edwin and the debugger so it will be
|
|
|
|
|
easy to write this debugger for Emacs.
|
|
|
|
|
|
|
|
|
|
Number input lines so that it is possible to tell the order in which
|
|
|
|
|
you evaluated your expressions. This could be particularly useful
|
|
|
|
|
for TAs looking over students' shoulders.
|
|
|
|
|
|
|
|
|
|
Once outline mode has been written for Edwin, add commands to expand
|
|
|
|
|
and contract subproblems and reductions.
|
|
|
|
|
|
|
|
|
|
|#
|
|
|
|
|
|
|
|
|
|
(define-variable debugger-confirm-return?
|
|
|
|
|
"True means to prompt for confirmation in RETURN-FROM and RETURN-TO
|
|
|
|
|
commands before returning the value."
|
|
|
|
|
#t
|
|
|
|
|
boolean?)
|
|
|
|
|
|
|
|
|
|
(define-variable debugger-split-window?
|
|
|
|
|
"True means use another window for the debugger buffer; false means
|
|
|
|
|
use the current window."
|
|
|
|
|
#t
|
|
|
|
|
boolean?)
|
|
|
|
|
|
|
|
|
|
(define-variable debugger-one-at-a-time?
|
|
|
|
|
"True means delete an existing debugger buffer before before
|
|
|
|
|
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))))
|
|
|
|
|
|
|
|
|
|
(define-variable debugger-quit-on-return?
|
|
|
|
|
"True means quit debugger when executing a \"return\" command."
|
|
|
|
|
#t
|
|
|
|
|
boolean?)
|
|
|
|
|
|
|
|
|
|
(define-variable debugger-quit-on-restart?
|
|
|
|
|
"True means quit debugger when executing a \"restart\" command."
|
|
|
|
|
#t
|
|
|
|
|
boolean?)
|
|
|
|
|
|
|
|
|
|
(define-variable debugger-open-markers?
|
|
|
|
|
"True means newlines are inserted between marker lines."
|
|
|
|
|
#t
|
|
|
|
|
boolean?)
|
|
|
|
|
|
|
|
|
|
(define-variable debugger-verbose-mode?
|
|
|
|
|
"True means display extra information without the user requesting it."
|
|
|
|
|
#f
|
|
|
|
|
boolean?)
|
|
|
|
|
|
|
|
|
|
(define-variable debugger-expand-reductions?
|
|
|
|
|
"True says to insert reductions when reduction motion commands are used
|
|
|
|
|
in a subproblem whose reductions aren't already inserted."
|
|
|
|
|
#t
|
|
|
|
|
boolean?)
|
|
|
|
|
|
|
|
|
|
(define-variable debugger-max-subproblems
|
|
|
|
|
"Maximum number of subproblems displayed when debugger starts,
|
|
|
|
|
or #F meaning no limit."
|
|
|
|
|
3
|
|
|
|
|
(lambda (number)
|
|
|
|
|
(or (not number)
|
|
|
|
|
(and (exact-integer? number)
|
|
|
|
|
(> number 0)))))
|
|
|
|
|
|
|
|
|
|
(define-variable debugger-hide-system-code?
|
|
|
|
|
"True means don't show subproblems created by the runtime system."
|
|
|
|
|
#t
|
|
|
|
|
boolean?)
|
|
|
|
|
|
|
|
|
|
(define-variable debugger-show-help-message?
|
|
|
|
|
"True means show a help message in the debugger buffer."
|
|
|
|
|
#t
|
|
|
|
|
boolean?)
|
|
|
|
|
|
|
|
|
|
(define-variable debugger-debug-evaluations?
|
|
|
|
|
"True means evaluation errors in a debugger buffer start new debuggers."
|
|
|
|
|
#f
|
|
|
|
|
boolean?)
|
|
|
|
|
|
|
|
|
|
(define starting-debugger? #f)
|
|
|
|
|
(define in-debugger-evaluation? #f)
|
|
|
|
|
|
|
|
|
|
(define (debug-scheme-error error-type condition ask?)
|
|
|
|
|
(cond (starting-debugger?
|
|
|
|
|
(quit-editor-and-signal-error condition))
|
|
|
|
|
((and in-debugger-evaluation?
|
|
|
|
|
(not (ref-variable debugger-debug-evaluations? #f)))
|
|
|
|
|
unspecific)
|
|
|
|
|
(else
|
|
|
|
|
(let ((start-debugger
|
|
|
|
|
(lambda ()
|
|
|
|
|
(fluid-let ((starting-debugger? #t))
|
|
|
|
|
((if (ref-variable debugger-split-window? #f)
|
|
|
|
|
select-buffer-other-window
|
|
|
|
|
select-buffer)
|
|
|
|
|
(continuation-browser-buffer condition))))))
|
|
|
|
|
(if ask?
|
|
|
|
|
(if (cleanup-pop-up-buffers
|
|
|
|
|
(lambda ()
|
|
|
|
|
(standard-error-report error-type condition #t)
|
|
|
|
|
(editor-beep)
|
|
|
|
|
(prompt-for-confirmation? "Start debugger")))
|
|
|
|
|
(start-debugger))
|
|
|
|
|
(begin
|
|
|
|
|
(start-debugger)
|
|
|
|
|
(message (string-capitalize (symbol->string error-type))
|
|
|
|
|
" error")
|
|
|
|
|
(editor-beep))))
|
|
|
|
|
(return-to-command-loop condition))))
|
|
|
|
|
|
|
|
|
|
(define-command browse-continuation
|
|
|
|
|
"Invoke the continuation-browser on CONTINUATION."
|
|
|
|
|
"XBrowse Continuation"
|
|
|
|
|
(lambda (continuation)
|
|
|
|
|
(let ((buffer (continuation-browser-buffer continuation)))
|
|
|
|
|
((if (ref-variable debugger-split-window?)
|
|
|
|
|
select-buffer-other-window
|
|
|
|
|
select-buffer)
|
|
|
|
|
buffer))))
|
|
|
|
|
|
|
|
|
|
(define-integrable (buffer-dstate buffer)
|
|
|
|
|
(buffer-get buffer 'DEBUG-STATE))
|
|
|
|
|
|
|
|
|
|
;;;; Main Entry
|
|
|
|
|
|
|
|
|
|
(define (continuation-browser-buffer object)
|
|
|
|
|
(let ((buffers (find-debugger-buffers)))
|
|
|
|
|
(if (and (not (null? buffers))
|
|
|
|
|
(null? (cdr buffers))
|
|
|
|
|
(ref-variable debugger-one-at-a-time?)
|
|
|
|
|
(or (eq? #t (ref-variable debugger-one-at-a-time?))
|
|
|
|
|
(prompt-for-confirmation?
|
|
|
|
|
"Another debugger buffer exists. Delete it")))
|
|
|
|
|
(kill-buffer (car buffers))))
|
|
|
|
|
(let ((buffer (new-buffer "*debug*"))
|
|
|
|
|
(dstate (make-initial-dstate object)))
|
|
|
|
|
(set-buffer-major-mode! buffer (ref-mode-object continuation-browser))
|
|
|
|
|
(buffer-put! buffer 'DEBUG-STATE dstate)
|
|
|
|
|
(let ((top-subproblem
|
|
|
|
|
(let ((previous-subproblems (dstate/previous-subproblems dstate)))
|
|
|
|
|
(if (null? previous-subproblems)
|
|
|
|
|
(dstate/subproblem dstate)
|
|
|
|
|
(car (last-pair previous-subproblems)))))
|
|
|
|
|
(max-subproblems (ref-variable debugger-max-subproblems buffer))
|
|
|
|
|
(hide-system-code? (ref-variable debugger-hide-system-code? buffer)))
|
|
|
|
|
(with-group-undo-disabled (buffer-group buffer)
|
|
|
|
|
(lambda ()
|
|
|
|
|
(let ((port (mark->output-port (buffer-start buffer))))
|
|
|
|
|
(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)))
|
|
|
|
|
(if (let loop ((frame top-subproblem) (level 0))
|
|
|
|
|
(and frame
|
|
|
|
|
(or (and max-subproblems (= level max-subproblems))
|
|
|
|
|
(and hide-system-code? (system-frame? frame))
|
|
|
|
|
(begin
|
|
|
|
|
(newline port)
|
|
|
|
|
(print-subproblem level frame port)
|
|
|
|
|
(loop (stack-frame/next-subproblem frame)
|
|
|
|
|
(+ level 1))))))
|
|
|
|
|
(display-more-subproblems-message buffer)))))
|
|
|
|
|
(let ((point (forward-subproblem (buffer-start buffer) 1)))
|
|
|
|
|
(set-buffer-point! buffer point)
|
|
|
|
|
(if (ref-variable debugger-verbose-mode? buffer)
|
|
|
|
|
(invoke-debugger-command mark
|
|
|
|
|
command/print-subproblem-or-reduction))
|
|
|
|
|
(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 (substitute-command-keys debugger-help-message buffer) port)
|
|
|
|
|
(newline port)
|
|
|
|
|
(newline port))
|
|
|
|
|
|
|
|
|
|
(define debugger-help-message
|
|
|
|
|
"This is a debugger buffer:
|
|
|
|
|
|
|
|
|
|
Marker lines identify stack frames, 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))
|
|
|
|
|
(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
|
|
|
|
|
(substitute-command-keys
|
|
|
|
|
"Use \\[continuation-browser-condition-restart] to invoke any of these restarts."
|
|
|
|
|
buffer)
|
|
|
|
|
port)
|
|
|
|
|
(newline port)))))
|
|
|
|
|
|
|
|
|
|
(define (system-frame? frame)
|
|
|
|
|
frame ;ignore
|
|
|
|
|
#f)
|
|
|
|
|
|
|
|
|
|
(define-major-mode continuation-browser scheme "Debug"
|
|
|
|
|
"Major mode for debugging Scheme programs and browsing Scheme continuations.
|
|
|
|
|
Evaluation commands are similar to those of Scheme Interaction mode.
|
|
|
|
|
|
|
|
|
|
Marker lines identify stack frames, 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
|
|
|
|
|
|
|
|
|
|
Evaluate expressions
|
|
|
|
|
|
|
|
|
|
\\[continuation-browser-eval-last-sexp] evaluates the expression preceding point in the
|
|
|
|
|
environment of the current frame.
|
|
|
|
|
\\[continuation-browser-eval-last-sexp/dynamic] evaluates the expression preceding point in the
|
|
|
|
|
environment AND DYNAMIC STATE of the current frame.
|
|
|
|
|
|
|
|
|
|
Move between subproblems and reductions
|
|
|
|
|
|
|
|
|
|
\\[continuation-browser-forward-reduction] moves forward one reduction (earlier in time).
|
|
|
|
|
\\[continuation-browser-backward-reduction] moves backward one reduction (later in time).
|
|
|
|
|
|
|
|
|
|
\\[continuation-browser-forward-subproblem] moves forward one subproblem (earlier in time).
|
|
|
|
|
\\[continuation-browser-backward-subproblem] moves backward one subproblem (later in time).
|
|
|
|
|
|
|
|
|
|
\\[continuation-browser-go-to] moves directly to a subproblem (given its number).
|
|
|
|
|
|
|
|
|
|
Display debugging information
|
|
|
|
|
|
|
|
|
|
\\[continuation-browser-show-all-frames] shows All bindings of the current environment and its ancestors.
|
|
|
|
|
\\[continuation-browser-show-current-frame] shows bindings of identifiers in the Current environment.
|
|
|
|
|
\\[continuation-browser-print-environment] describes the current Environment.
|
|
|
|
|
\\[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-expand-reductions] shows the Reductions of the current subproblem level.
|
|
|
|
|
\\[continuation-browser-print-subproblem-or-reduction] describes the current subproblem or reduction.
|
|
|
|
|
\\[continuation-browser-expand-subproblems] shows subproblems not already displayed.
|
|
|
|
|
\\[continuation-browser-frame] displays the current stack frame in internal format.
|
|
|
|
|
|
|
|
|
|
Miscellany
|
|
|
|
|
|
|
|
|
|
\\[continuation-browser-condition-restart] continues the program using a standard restart option.
|
|
|
|
|
\\[continuation-browser-return-from] returns from the current subproblem with the value of the expression
|
|
|
|
|
preceding the point.
|
|
|
|
|
\\[continuation-browser-return-to] returns to the current subproblem with the value of the expression
|
|
|
|
|
preceding the point.
|
|
|
|
|
\\[continuation-browser-retry] retries the offending expression, returning from the current
|
|
|
|
|
subproblem with its value.
|
|
|
|
|
|
|
|
|
|
Use \\[kill-buffer] to quit the debugger."
|
|
|
|
|
(lambda (buffer)
|
|
|
|
|
(define-variable-local-value! buffer
|
|
|
|
|
(ref-variable-object comint-input-ring)
|
|
|
|
|
(make-ring (ref-variable comint-input-ring-size)))
|
|
|
|
|
(define-variable-local-value! buffer
|
|
|
|
|
(ref-variable-object evaluation-input-recorder)
|
|
|
|
|
continuation-browser-input-recorder)
|
|
|
|
|
(define-variable-local-value! buffer
|
|
|
|
|
(ref-variable-object evaluation-output-receiver)
|
|
|
|
|
continuation-browser-output-receiver)))
|
|
|
|
|
|
|
|
|
|
(define (continuation-browser-input-recorder region)
|
|
|
|
|
(ring-push! (ref-variable comint-input-ring) (region->string region)))
|
|
|
|
|
|
|
|
|
|
(define (continuation-browser-output-receiver value output)
|
|
|
|
|
(let ((point (mark-left-inserting-copy (current-point))))
|
|
|
|
|
(insert-string output point)
|
|
|
|
|
(guarantee-newlines 1 point)
|
|
|
|
|
(insert-string (transcript-value-prefix-string value #t) point)
|
|
|
|
|
(insert-string (transcript-value-string value) point)
|
|
|
|
|
(insert-newlines 2 point)
|
|
|
|
|
(mark-temporary! point)))
|
|
|
|
|
|
|
|
|
|
;;; Disable EVAL-CURRENT-BUFFER in Debugger Mode. It is inherited
|
|
|
|
|
;;; from Scheme mode but does not make sense here:
|
|
|
|
|
|
|
|
|
|
(define-key 'continuation-browser #\M-o
|
|
|
|
|
'undefined)
|
|
|
|
|
|
|
|
|
|
;;; Comint History
|
|
|
|
|
(define-key 'continuation-browser #\M-p
|
|
|
|
|
'comint-previous-input)
|
|
|
|
|
(define-key 'continuation-browser #\M-n
|
|
|
|
|
'comint-next-input)
|
|
|
|
|
(define-key 'continuation-browser '(#\C-c #\C-r)
|
|
|
|
|
'comint-history-search-backward)
|
|
|
|
|
(define-key 'continuation-browser '(#\C-c #\C-s)
|
|
|
|
|
'comint-history-search-forward)
|
|
|
|
|
|
|
|
|
|
;;; Evaluation Commands
|
|
|
|
|
(define-key 'continuation-browser '(#\C-x #\C-e)
|
|
|
|
|
'continuation-browser-eval-last-sexp)
|
|
|
|
|
(define-key 'continuation-browser '(#\C-x #\C-r)
|
|
|
|
|
'continuation-browser-eval-last-sexp/dynamic)
|
|
|
|
|
(define-key 'continuation-browser #\M-z
|
|
|
|
|
'continuation-browser-eval-defun)
|
|
|
|
|
(define-key 'continuation-browser '(#\M-C-z)
|
|
|
|
|
'continuation-browser-eval-region)
|
|
|
|
|
|
|
|
|
|
;;; Motion Commands
|
|
|
|
|
(define-key 'continuation-browser '(#\C-c #\C-f)
|
|
|
|
|
'continuation-browser-forward-reduction)
|
|
|
|
|
(define-key 'continuation-browser '(#\C-c #\C-n)
|
|
|
|
|
'continuation-browser-forward-subproblem)
|
|
|
|
|
(define-key 'continuation-browser '(#\C-c #\C-b)
|
|
|
|
|
'continuation-browser-backward-reduction)
|
|
|
|
|
(define-key 'continuation-browser '(#\C-c #\C-p)
|
|
|
|
|
'continuation-browser-backward-subproblem)
|
|
|
|
|
(define-key 'continuation-browser '(#\C-c #\C-w)
|
|
|
|
|
'continuation-browser-go-to)
|
|
|
|
|
|
|
|
|
|
;;; Information-display Commands
|
|
|
|
|
(define-key 'continuation-browser '(#\C-c #\C-a)
|
|
|
|
|
'continuation-browser-show-all-frames)
|
|
|
|
|
(define-key 'continuation-browser '(#\C-c #\C-c)
|
|
|
|
|
'continuation-browser-show-current-frame)
|
|
|
|
|
(define-key 'continuation-browser '(#\C-c #\C-e)
|
|
|
|
|
'continuation-browser-print-environment)
|
|
|
|
|
(define-key 'continuation-browser '(#\C-c #\C-l)
|
|
|
|
|
'continuation-browser-print-expression)
|
|
|
|
|
(define-key 'continuation-browser '(#\C-c #\C-o)
|
|
|
|
|
'continuation-browser-print-environment-procedure)
|
|
|
|
|
(define-key 'continuation-browser '(#\C-c #\C-m)
|
|
|
|
|
'continuation-browser-expand-reductions)
|
|
|
|
|
(define-key 'continuation-browser '(#\C-c #\C-t)
|
|
|
|
|
'continuation-browser-print-subproblem-or-reduction)
|
|
|
|
|
(define-key 'continuation-browser '(#\C-c #\C-x)
|
|
|
|
|
'continuation-browser-expand-subproblems)
|
|
|
|
|
(define-key 'continuation-browser '(#\C-c #\C-y)
|
|
|
|
|
'continuation-browser-frame)
|
|
|
|
|
|
|
|
|
|
;;; Miscellaneous Commands
|
|
|
|
|
(define-key 'continuation-browser '(#\C-c #\C-k)
|
|
|
|
|
'continuation-browser-condition-restart)
|
|
|
|
|
(define-key 'continuation-browser '(#\C-c #\C-j)
|
|
|
|
|
'continuation-browser-return-to)
|
|
|
|
|
(define-key 'continuation-browser '(#\C-c #\C-z)
|
|
|
|
|
'continuation-browser-return-from)
|
|
|
|
|
(define-key 'continuation-browser '(#\C-c #\C-d)
|
|
|
|
|
'continuation-browser-retry)
|
|
|
|
|
(define-key 'continuation-browser '(#\C-c #\C-g)
|
|
|
|
|
'continuation-browser-abort-all)
|
|
|
|
|
(define-key 'continuation-browser '(#\C-c #\C-u)
|
|
|
|
|
'continuation-browser-abort-previous)
|
|
|
|
|
(define-key 'continuation-browser '(#\C-c #\C-M-y)
|
|
|
|
|
'continuation-browser-display-stack-elements)
|
|
|
|
|
|
|
|
|
|
(define (debugger-command-invocation command)
|
|
|
|
|
(lambda ()
|
|
|
|
|
(invoke-debugger-command (current-point) command)))
|
|
|
|
|
|
|
|
|
|
;;;; Evaluation Commands
|
|
|
|
|
|
|
|
|
|
(define-command continuation-browser-eval-region
|
|
|
|
|
"Evaluate the region."
|
|
|
|
|
"r"
|
|
|
|
|
(lambda (region)
|
|
|
|
|
(let ((environment
|
|
|
|
|
(dstate-evaluation-environment (start-evaluation region))))
|
|
|
|
|
(fluid-let ((in-debugger-evaluation? #t))
|
|
|
|
|
(evaluate-region region environment)))))
|
|
|
|
|
|
|
|
|
|
(define (start-evaluation region)
|
|
|
|
|
(if (region-contains-marker? region)
|
|
|
|
|
(editor-error "Can't evaluate region containing markers."))
|
|
|
|
|
(set-current-point! (region-end region))
|
|
|
|
|
(debug-dstate (region-start region)))
|
|
|
|
|
|
|
|
|
|
(define-command continuation-browser-eval-defun
|
|
|
|
|
"Evaluate definition that point is in or before."
|
|
|
|
|
()
|
|
|
|
|
(lambda ()
|
|
|
|
|
((ref-command continuation-browser-eval-region)
|
|
|
|
|
(let ((input-mark (current-definition-start)))
|
|
|
|
|
(make-region input-mark (forward-sexp input-mark 1 'ERROR))))))
|
|
|
|
|
|
|
|
|
|
(define-command continuation-browser-eval-last-sexp
|
|
|
|
|
"Evaluate the expression preceding point."
|
|
|
|
|
()
|
|
|
|
|
(lambda ()
|
|
|
|
|
((ref-command continuation-browser-eval-region)
|
|
|
|
|
(let ((input-mark (backward-sexp (current-point) 1 'ERROR)))
|
|
|
|
|
(make-region input-mark (forward-sexp input-mark 1 'ERROR))))))
|
|
|
|
|
|
|
|
|
|
(define-command continuation-browser-eval-region/dynamic
|
|
|
|
|
"Evaluate the region.
|
|
|
|
|
The evaluation occurs in the dynamic state of the current frame."
|
|
|
|
|
"r"
|
|
|
|
|
(lambda (region)
|
|
|
|
|
(let ((dstate (start-evaluation region)))
|
|
|
|
|
(let ((environment (dstate-evaluation-environment dstate))
|
|
|
|
|
(continuation
|
|
|
|
|
(stack-frame->continuation (dstate/subproblem dstate)))
|
|
|
|
|
(old-hook hook/repl-eval))
|
|
|
|
|
(fluid-let
|
|
|
|
|
((in-debugger-evaluation? #t)
|
|
|
|
|
(hook/repl-eval
|
|
|
|
|
(lambda (expression environment repl)
|
|
|
|
|
(let ((unique (cons 'unique 'id)))
|
|
|
|
|
(let ((result
|
|
|
|
|
(call-with-current-continuation
|
|
|
|
|
(lambda (continuation*)
|
|
|
|
|
(within-continuation continuation
|
|
|
|
|
(lambda ()
|
|
|
|
|
(bind-condition-handler
|
|
|
|
|
'()
|
|
|
|
|
(lambda (condition)
|
|
|
|
|
(continuation* (cons unique condition)))
|
|
|
|
|
(lambda ()
|
|
|
|
|
(continuation*
|
|
|
|
|
(old-hook expression
|
|
|
|
|
environment
|
|
|
|
|
repl))))))))))
|
|
|
|
|
(if (and (pair? result)
|
|
|
|
|
(eq? unique (car result)))
|
|
|
|
|
(error (cdr result))
|
|
|
|
|
result))))))
|
|
|
|
|
(evaluate-region region environment))))))
|
|
|
|
|
|
|
|
|
|
(define-command continuation-browser-eval-last-sexp/dynamic
|
|
|
|
|
"Evaluate the expression preceding point.
|
|
|
|
|
The evaluation occurs in the dynamic state of the current frame."
|
|
|
|
|
()
|
|
|
|
|
(lambda ()
|
|
|
|
|
((ref-command continuation-browser-eval-region/dynamic)
|
|
|
|
|
(let ((input-mark (backward-sexp (current-point) 1 'ERROR)))
|
|
|
|
|
(make-region input-mark (forward-sexp input-mark 1 'ERROR))))))
|
|
|
|
|
|
|
|
|
|
;;;; Motion Commands
|
|
|
|
|
|
|
|
|
|
;;; The subproblem and reduction motion commands rely, in many
|
|
|
|
|
;;; places, on the assumption that subproblem and reduction numbers
|
|
|
|
|
;;; increase downward in the buffer, and that no subproblem/reduction
|
|
|
|
|
;;; marker line is repeated. Of course, the user can violate this
|
|
|
|
|
;;; assumption by constructing or copying a marker, but the program
|
|
|
|
|
;;; is robust with respect to such conniving, as long as the
|
|
|
|
|
;;; reduction and subproblem specified by the numbers in the marker
|
|
|
|
|
;;; exist. The only time it should be possible to notice an effect
|
|
|
|
|
;;; of this assumption is when a reduction or subproblem that is
|
|
|
|
|
;;; already displayed is automatically redisplayed because the
|
|
|
|
|
;;; existing one appeared out of order.
|
|
|
|
|
|
|
|
|
|
(define-command continuation-browser-forward-subproblem
|
|
|
|
|
"Move one or more subproblems forward."
|
|
|
|
|
"p"
|
|
|
|
|
(lambda (argument) (move-thing forward-subproblem argument 'ERROR)))
|
|
|
|
|
|
|
|
|
|
(define-command continuation-browser-backward-subproblem
|
|
|
|
|
"Move one or more subproblems backward."
|
|
|
|
|
"p"
|
|
|
|
|
(lambda (argument) (move-thing backward-subproblem argument 'ERROR)))
|
|
|
|
|
|
|
|
|
|
(define-command continuation-browser-forward-reduction
|
|
|
|
|
"Move one or more reductions forward.
|
|
|
|
|
Display reductions that exist but are not yet displayed.
|
|
|
|
|
If there are no more reductions for the current subproblem,
|
|
|
|
|
move to the first reduction shown in the next subproblem."
|
|
|
|
|
"p"
|
|
|
|
|
(lambda (argument) (move-thing forward-reduction argument 'ERROR)))
|
|
|
|
|
|
|
|
|
|
(define-command continuation-browser-backward-reduction
|
|
|
|
|
"Move one or more reductions backward.
|
|
|
|
|
Display reductions that exist but are not yet displayed.
|
|
|
|
|
If there are no more reductions for the current subproblem,
|
|
|
|
|
move to the last reduction shown in the previous subproblem."
|
|
|
|
|
"p"
|
|
|
|
|
(lambda (argument) (move-thing backward-reduction argument 'ERROR)))
|
|
|
|
|
|
|
|
|
|
(define-command continuation-browser-go-to
|
|
|
|
|
"Move to an arbitrary subproblem.
|
|
|
|
|
Prompt for the subproblem number if not given as an argument.
|
|
|
|
|
Move to the last subproblem if the subproblem number is too high."
|
|
|
|
|
"NSubproblem number"
|
|
|
|
|
(lambda (destination-subproblem-number)
|
|
|
|
|
(set-current-point!
|
|
|
|
|
(let ((end (group-end (current-point)))
|
|
|
|
|
(not-found
|
|
|
|
|
(lambda ()
|
|
|
|
|
(editor-error "Cannot find subproblem"
|
|
|
|
|
destination-subproblem-number))))
|
|
|
|
|
(let ((last-subproblem-number (current-subproblem-number end)))
|
|
|
|
|
(if (not last-subproblem-number)
|
|
|
|
|
(not-found))
|
|
|
|
|
(cond ((< destination-subproblem-number last-subproblem-number)
|
|
|
|
|
(let loop ((point (backward-subproblem end 1)))
|
|
|
|
|
(if (not point)
|
|
|
|
|
(not-found))
|
|
|
|
|
(let ((subproblem (current-subproblem-number point)))
|
|
|
|
|
(if (not subproblem)
|
|
|
|
|
(not-found))
|
|
|
|
|
(if (= subproblem destination-subproblem-number)
|
|
|
|
|
point
|
|
|
|
|
(loop (backward-subproblem point 1))))))
|
|
|
|
|
((> destination-subproblem-number last-subproblem-number)
|
|
|
|
|
(forward-subproblem
|
|
|
|
|
end
|
|
|
|
|
(- destination-subproblem-number last-subproblem-number)
|
|
|
|
|
'LIMIT))
|
|
|
|
|
(else end)))))))
|
|
|
|
|
|
|
|
|
|
;;;; Information-display Commands
|
|
|
|
|
|
|
|
|
|
(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-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-print-environment
|
|
|
|
|
"Identify the environment of the current frame."
|
|
|
|
|
()
|
|
|
|
|
(debugger-command-invocation
|
|
|
|
|
(lambda (dstate port)
|
|
|
|
|
(debugger-presentation port
|
|
|
|
|
(lambda ()
|
|
|
|
|
(print-subproblem-environment dstate port))))))
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
(define-command continuation-browser-print-expression
|
|
|
|
|
"Pretty print the current expression."
|
|
|
|
|
"P"
|
|
|
|
|
(lambda (argument)
|
|
|
|
|
(let ((point (current-point)))
|
|
|
|
|
(call-with-interface-port
|
|
|
|
|
point
|
|
|
|
|
(lambda (port)
|
|
|
|
|
(push-current-mark! point)
|
|
|
|
|
(let ((dstate (debug-dstate point))
|
|
|
|
|
(message
|
|
|
|
|
(lambda (string)
|
|
|
|
|
(fresh-line port)
|
|
|
|
|
(write-string "; " port)
|
|
|
|
|
(write-string string port)))
|
|
|
|
|
(pp (lambda (obj)
|
|
|
|
|
(fresh-line port)
|
|
|
|
|
(pp obj port #t))))
|
|
|
|
|
|
|
|
|
|
(if (dstate/reduction-number dstate)
|
|
|
|
|
(pp (reduction-expression (dstate/reduction dstate)))
|
|
|
|
|
(let ((exp (dstate/expression dstate))
|
|
|
|
|
(sub (dstate/subexpression dstate)))
|
|
|
|
|
(define (do-hairy)
|
|
|
|
|
(pp (unsyntax-with-substitutions
|
|
|
|
|
exp
|
|
|
|
|
(list
|
|
|
|
|
(cons sub
|
|
|
|
|
(make-pretty-printer-highlight
|
|
|
|
|
(unsyntax sub)
|
|
|
|
|
(ref-variable subexpression-start-marker)
|
|
|
|
|
(ref-variable subexpression-end-marker)))))))
|
|
|
|
|
|
|
|
|
|
(cond ((not (invalid-expression? exp))
|
|
|
|
|
(if (or argument
|
|
|
|
|
(invalid-subexpression? sub))
|
|
|
|
|
(pp exp)
|
|
|
|
|
(parameterize ((param:pp-no-highlights? #f))
|
|
|
|
|
(do-hairy))))
|
|
|
|
|
((debugging-info/noise? exp)
|
|
|
|
|
(message ((debugging-info/noise exp) #t)))
|
|
|
|
|
(else
|
|
|
|
|
(message "Unknown 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-expand-reductions
|
|
|
|
|
"Expand all the reductions of the current subproblem.
|
|
|
|
|
If already expanded, move the point to one of the reductions."
|
|
|
|
|
()
|
|
|
|
|
(lambda ()
|
|
|
|
|
(let ((point (current-point)))
|
|
|
|
|
(if (reductions-expanded? point)
|
|
|
|
|
(temporary-message
|
|
|
|
|
"Reductions for this subproblem already expanded.")
|
|
|
|
|
(expand-reductions point)))))
|
|
|
|
|
|
|
|
|
|
(define (command/print-subproblem-or-reduction dstate port)
|
|
|
|
|
(debugger-presentation port
|
|
|
|
|
(lambda ()
|
|
|
|
|
(if (dstate/reduction-number dstate)
|
|
|
|
|
(print-reduction-expression (dstate/reduction dstate) port)
|
|
|
|
|
(print-subproblem-expression dstate port)))))
|
|
|
|
|
|
|
|
|
|
(define-command continuation-browser-print-subproblem-or-reduction
|
|
|
|
|
"Print the current subproblem or reduction in the standard format."
|
|
|
|
|
()
|
|
|
|
|
(debugger-command-invocation command/print-subproblem-or-reduction))
|
|
|
|
|
|
|
|
|
|
(define-command continuation-browser-expand-subproblems
|
|
|
|
|
"Expand all subproblems, or ARG more subproblems if argument is given."
|
|
|
|
|
"P"
|
|
|
|
|
(lambda (argument)
|
|
|
|
|
(let ((subproblem-number
|
|
|
|
|
(if argument
|
|
|
|
|
(+ (or (current-subproblem-number (group-end (current-point)))
|
|
|
|
|
(editor-error "Can't find subproblem marker"))
|
|
|
|
|
(command-argument-numeric-value argument))
|
|
|
|
|
(- (count-subproblems (current-buffer)) 1))))
|
|
|
|
|
(let ((point (mark-right-inserting-copy (current-point))))
|
|
|
|
|
((ref-command continuation-browser-go-to) subproblem-number)
|
|
|
|
|
(mark-temporary! point)
|
|
|
|
|
(set-current-point! point)))))
|
|
|
|
|
|
|
|
|
|
(define-command continuation-browser-frame
|
|
|
|
|
"Show the current subproblem's stack frame in internal format."
|
|
|
|
|
()
|
|
|
|
|
(debugger-command-invocation command/frame))
|
|
|
|
|
|
|
|
|
|
;;;; Miscellaneous Commands
|
|
|
|
|
|
|
|
|
|
(define-command continuation-browser-condition-restart
|
|
|
|
|
"Continue the program using a standard restart option.
|
|
|
|
|
Prefix argument means do not kill the debugger buffer."
|
|
|
|
|
"P"
|
|
|
|
|
(lambda (avoid-deletion?)
|
|
|
|
|
(fluid-let ((hook/invoke-restart
|
|
|
|
|
(lambda (continuation arguments)
|
|
|
|
|
(invoke-continuation continuation
|
|
|
|
|
arguments
|
|
|
|
|
avoid-deletion?))))
|
|
|
|
|
(invoke-debugger-command (current-point) command/condition-restart))))
|
|
|
|
|
|
|
|
|
|
(define-command continuation-browser-return-to
|
|
|
|
|
"Return TO the current subproblem with a value.
|
|
|
|
|
Invoke the continuation corresponding to this subproblem on the value
|
|
|
|
|
of the expression before the point.
|
|
|
|
|
Prefix argument means do not kill the debugger buffer."
|
|
|
|
|
"P"
|
|
|
|
|
(lambda (avoid-deletion?)
|
|
|
|
|
(let ((subproblem (dstate/subproblem (debug-dstate (current-point)))))
|
|
|
|
|
(subproblem-enter subproblem
|
|
|
|
|
((ref-command continuation-browser-eval-last-sexp))
|
|
|
|
|
avoid-deletion?))))
|
|
|
|
|
|
|
|
|
|
(define-command continuation-browser-return-from
|
|
|
|
|
"Return FROM the current subproblem with a value.
|
|
|
|
|
Invoke the continuation that is waiting for the value of the current
|
|
|
|
|
subproblem on the value of the expression before the point.
|
|
|
|
|
Prefix argument means do not kill the debugger buffer."
|
|
|
|
|
"P"
|
|
|
|
|
(lambda (avoid-deletion?)
|
|
|
|
|
(let ((next (guarantee-next-subproblem (debug-dstate (current-point)))))
|
|
|
|
|
(subproblem-enter next
|
|
|
|
|
((ref-command continuation-browser-eval-last-sexp))
|
|
|
|
|
avoid-deletion?))))
|
|
|
|
|
|
|
|
|
|
(define-command continuation-browser-retry
|
|
|
|
|
"Retry the expression of the current subproblem.
|
|
|
|
|
Prefix argument means do not kill the debugger buffer."
|
|
|
|
|
"P"
|
|
|
|
|
(lambda (avoid-deletion?)
|
|
|
|
|
(let* ((dstate (debug-dstate (current-point)))
|
|
|
|
|
(next (guarantee-next-subproblem dstate)))
|
|
|
|
|
(subproblem-enter
|
|
|
|
|
next
|
|
|
|
|
(let ((expression (dstate/expression dstate)))
|
|
|
|
|
(if (invalid-expression? expression)
|
|
|
|
|
(editor-error "Can't retry; invalid expression" expression))
|
|
|
|
|
(extended-scode-eval expression
|
|
|
|
|
(dstate-evaluation-environment dstate)))
|
|
|
|
|
avoid-deletion?))))
|
|
|
|
|
|
|
|
|
|
(define-command continuation-browser-abort-all
|
|
|
|
|
"Insert restarts"
|
|
|
|
|
()
|
|
|
|
|
(lambda ()
|
|
|
|
|
(continuation-browser-abort (reverse (current-restarts)))))
|
|
|
|
|
|
|
|
|
|
(define-command continuation-browser-abort-previous
|
|
|
|
|
"Insert restarts"
|
|
|
|
|
()
|
|
|
|
|
(lambda ()
|
|
|
|
|
(continuation-browser-abort (current-restarts))))
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
(define-command continuation-browser-display-stack-elements
|
|
|
|
|
"Show the elements on the current stack frame"
|
|
|
|
|
"P"
|
|
|
|
|
(lambda (argument)
|
|
|
|
|
(let* ((point (current-point))
|
|
|
|
|
(dstate (debug-dstate point))
|
|
|
|
|
(sub (dstate/subproblem dstate)))
|
|
|
|
|
(if (and (dstate/reduction-number dstate)
|
|
|
|
|
(not argument))
|
|
|
|
|
(editor-error "Reductions have no stack frames")
|
|
|
|
|
(call-with-interface-port
|
|
|
|
|
point
|
|
|
|
|
(lambda (port)
|
|
|
|
|
(push-current-mark! point)
|
|
|
|
|
(fresh-line port)
|
|
|
|
|
(let* ((vec (stack-frame/elements sub))
|
|
|
|
|
(depth (-1+ (vector-length vec)))
|
|
|
|
|
(mlen (string-length (number->string depth)))
|
|
|
|
|
(pad-len (max 5 mlen))
|
|
|
|
|
(padded
|
|
|
|
|
(lambda (s)
|
|
|
|
|
(string-pad-left s pad-len #\Space)))
|
|
|
|
|
(blanks (make-string pad-len #\Space)))
|
|
|
|
|
|
|
|
|
|
(write-string ";; " port)
|
|
|
|
|
(write-string (padded "Depth") port)
|
|
|
|
|
(write-string " Bottom of stack frame" port)
|
|
|
|
|
(newline port)
|
|
|
|
|
(write-string ";;" port)
|
|
|
|
|
(let ((pad (if (= pad-len mlen)
|
|
|
|
|
padded
|
|
|
|
|
(let* ((right (quotient (- pad-len mlen) 2))
|
|
|
|
|
(rest (- pad-len right))
|
|
|
|
|
(blanks (make-string right #\Space)))
|
|
|
|
|
(lambda (s)
|
|
|
|
|
(string-append
|
|
|
|
|
(string-pad-left s rest #\Space)
|
|
|
|
|
blanks))))))
|
|
|
|
|
|
|
|
|
|
(do ((elements (reverse! (vector->list vec))
|
|
|
|
|
(cdr elements))
|
|
|
|
|
(depth depth (-1+ depth)))
|
|
|
|
|
((null? elements))
|
|
|
|
|
(newline port)
|
|
|
|
|
(write-string ";; " port)
|
|
|
|
|
(write-string (pad (number->string depth)) port)
|
|
|
|
|
(write-string " " port)
|
|
|
|
|
(write (car elements) port)))
|
|
|
|
|
(newline port)
|
|
|
|
|
(write-string ";;" port)
|
|
|
|
|
(newline port)
|
|
|
|
|
(write-string ";; " port)
|
|
|
|
|
(write-string blanks port)
|
|
|
|
|
(write-string " Top of stack frame" port))
|
|
|
|
|
(newline port)
|
|
|
|
|
(newline port)))))))
|
|
|
|
|
|
|
|
|
|
(define (subproblem-enter subproblem value avoid-deletion?)
|
|
|
|
|
(if (or (not (ref-variable debugger-confirm-return?))
|
|
|
|
|
(prompt-for-confirmation? "Continue with this value"))
|
|
|
|
|
(invoke-continuation (stack-frame->continuation subproblem)
|
|
|
|
|
(list value)
|
|
|
|
|
avoid-deletion?)))
|
|
|
|
|
|
|
|
|
|
(define (invoke-continuation continuation arguments avoid-deletion?)
|
|
|
|
|
(let ((buffer (current-buffer)))
|
|
|
|
|
(if (and (not avoid-deletion?)
|
|
|
|
|
(ref-variable debugger-quit-on-return?))
|
|
|
|
|
(kill-buffer-interactive buffer))
|
|
|
|
|
((or (buffer-get buffer 'INVOKE-CONTINUATION) apply)
|
|
|
|
|
continuation arguments)))
|
|
|
|
|
|
|
|
|
|
(define (guarantee-next-subproblem dstate)
|
|
|
|
|
(or (stack-frame/next-subproblem (dstate/subproblem dstate))
|
|
|
|
|
(editor-error "Can't continue; no earlier subproblem")))
|
|
|
|
|
|
|
|
|
|
(define (current-restarts)
|
|
|
|
|
(let* ((dstate (debug-dstate (current-point)))
|
|
|
|
|
(condition (dstate/condition dstate)))
|
|
|
|
|
(if condition
|
|
|
|
|
(condition/restarts condition)
|
|
|
|
|
(bound-restarts))))
|
|
|
|
|
|
|
|
|
|
(define (continuation-browser-abort restarts)
|
|
|
|
|
(let ((restart
|
|
|
|
|
(find (lambda (restart)
|
|
|
|
|
(eq? (restart/name restart) 'abort))
|
|
|
|
|
restarts)))
|
|
|
|
|
(if (not restart)
|
|
|
|
|
(editor-error "Can't find an abort restart")
|
|
|
|
|
(fluid-let ((hook/invoke-restart
|
|
|
|
|
(lambda (continuation arguments)
|
|
|
|
|
(invoke-continuation continuation
|
|
|
|
|
arguments
|
|
|
|
|
#f))))
|
|
|
|
|
(invoke-restart restart)))))
|
|
|
|
|
|
|
|
|
|
;;;; Marker Generation
|
|
|
|
|
|
|
|
|
|
(define (expand-subproblem mark)
|
|
|
|
|
(let ((buffer (mark-buffer mark))
|
|
|
|
|
(number (current-subproblem-number mark)))
|
|
|
|
|
(if (not number)
|
|
|
|
|
(editor-error "No subproblem or reduction marks"))
|
|
|
|
|
(let ((number (+ number 1))
|
|
|
|
|
(count (count-subproblems buffer)))
|
|
|
|
|
(if (>= number count)
|
|
|
|
|
(editor-error "No more subproblems or reductions"))
|
|
|
|
|
(remove-more-subproblems-message buffer)
|
|
|
|
|
(let ((port (mark->output-port mark)))
|
|
|
|
|
(newline port)
|
|
|
|
|
(print-subproblem number (nth-subproblem buffer number) port))
|
|
|
|
|
(if (< number (- count 1))
|
|
|
|
|
(display-more-subproblems-message buffer)))))
|
|
|
|
|
|
|
|
|
|
(define (display-more-subproblems-message buffer)
|
|
|
|
|
(define-variable-local-value! buffer (ref-variable-object mode-line-process)
|
|
|
|
|
'(RUN-LIGHT (": more-subproblems " RUN-LIGHT) ": more-subproblems"))
|
|
|
|
|
(buffer-modeline-event! buffer 'PROCESS-STATUS))
|
|
|
|
|
|
|
|
|
|
(define (remove-more-subproblems-message buffer)
|
|
|
|
|
(let ((variable (ref-variable-object mode-line-process)))
|
|
|
|
|
(define-variable-local-value! buffer variable
|
|
|
|
|
(variable-default-value variable)))
|
|
|
|
|
(buffer-modeline-event! buffer 'PROCESS-STATUS))
|
|
|
|
|
|
|
|
|
|
(define (perhaps-expand-reductions mark)
|
|
|
|
|
(if (and (ref-variable debugger-expand-reductions?)
|
|
|
|
|
(not (reductions-expanded? mark)))
|
|
|
|
|
(begin
|
|
|
|
|
(message "Expanding reductions...")
|
|
|
|
|
(expand-reductions (end-of-subproblem mark))
|
|
|
|
|
(temporary-message "Expanding reductions...done"))))
|
|
|
|
|
|
|
|
|
|
(define (expand-reductions mark)
|
|
|
|
|
(let ((port (mark->output-port mark))
|
|
|
|
|
(subproblem-number (current-subproblem-number mark)))
|
|
|
|
|
(do ((reductions (stack-frame/reductions
|
|
|
|
|
(dstate/subproblem (debug-dstate mark)))
|
|
|
|
|
(cdr reductions))
|
|
|
|
|
(reduction-number 0 (+ reduction-number 1)))
|
|
|
|
|
((not (pair? reductions)))
|
|
|
|
|
(newline port)
|
|
|
|
|
(print-reduction subproblem-number
|
|
|
|
|
reduction-number
|
|
|
|
|
(car reductions)
|
|
|
|
|
port))))
|
|
|
|
|
|
|
|
|
|
(define (reductions-expanded? mark)
|
|
|
|
|
;; Return true whenever expansion is impossible at MARK, even if
|
|
|
|
|
;; because MARK is outside any subproblem or because there are no
|
|
|
|
|
;; reductions for the subproblem. If only some of the reductions
|
|
|
|
|
;; appear already (e.g. if the others have been deleted by the
|
|
|
|
|
;; user), still return true.
|
|
|
|
|
(let ((subproblem-above (find-previous-subproblem-marker mark)))
|
|
|
|
|
(or (not subproblem-above)
|
|
|
|
|
(let ((subproblem-number-above (re-match-extract-subproblem))
|
|
|
|
|
(reduction-count (re-match-extract-reduction-count)))
|
|
|
|
|
(and reduction-count
|
|
|
|
|
(let ((reduction-below
|
|
|
|
|
(find-next-marker
|
|
|
|
|
(line-end subproblem-above 0))))
|
|
|
|
|
(and reduction-below
|
|
|
|
|
(= (re-match-extract-subproblem)
|
|
|
|
|
subproblem-number-above))))))))
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
(define-structure (unparser-literal
|
|
|
|
|
(conc-name unparser-literal/)
|
|
|
|
|
(print-procedure
|
|
|
|
|
(lambda (instance port)
|
|
|
|
|
(write-string (unparser-literal/string instance)
|
|
|
|
|
port)))
|
|
|
|
|
(constructor unparser-literal/make))
|
|
|
|
|
string)
|
|
|
|
|
|
|
|
|
|
(define-variable subexpression-start-marker
|
|
|
|
|
"Subexpressions are preceeded by this value."
|
|
|
|
|
"#"
|
|
|
|
|
string?)
|
|
|
|
|
|
|
|
|
|
(define-variable subexpression-end-marker
|
|
|
|
|
"Subexpressions are followed by this value."
|
|
|
|
|
"#"
|
|
|
|
|
string?)
|
|
|
|
|
|
|
|
|
|
(define (print-subproblem number frame port)
|
|
|
|
|
(call-with-values (lambda () (stack-frame/debugging-info frame))
|
|
|
|
|
(lambda (expression environment subexpression)
|
|
|
|
|
(print-history-level
|
|
|
|
|
(stack-frame/compiled-code? frame)
|
|
|
|
|
number
|
|
|
|
|
(let ((reductions
|
|
|
|
|
(improper-list-length (stack-frame/reductions frame))))
|
|
|
|
|
(if (zero? reductions)
|
|
|
|
|
" -------- "
|
|
|
|
|
(string-append " #R=" (number->string reductions) " --- ")))
|
|
|
|
|
(lambda ()
|
|
|
|
|
(cond ((debugging-info/compiled-code? expression)
|
|
|
|
|
(write-string ";compiled code"))
|
|
|
|
|
((not (debugging-info/undefined-expression? expression))
|
|
|
|
|
(print-with-subexpression expression subexpression))
|
|
|
|
|
((debugging-info/noise? expression)
|
|
|
|
|
(write-string ((debugging-info/noise expression) #f)))
|
|
|
|
|
(else
|
|
|
|
|
(write-string ";undefined expression"))))
|
|
|
|
|
environment
|
|
|
|
|
port))))
|
|
|
|
|
|
|
|
|
|
(define (print-with-subexpression expression subexpression)
|
|
|
|
|
(parameterize ((param:print-primitives-by-name? #t))
|
|
|
|
|
(if (invalid-subexpression? subexpression)
|
|
|
|
|
(write (unsyntax expression))
|
|
|
|
|
(let ((sub (write-to-string (unsyntax subexpression))))
|
|
|
|
|
(write (unsyntax-with-substitutions
|
|
|
|
|
expression
|
|
|
|
|
(list
|
|
|
|
|
(cons subexpression
|
|
|
|
|
(unparser-literal/make
|
|
|
|
|
(string-append
|
|
|
|
|
(ref-variable subexpression-start-marker)
|
|
|
|
|
sub
|
|
|
|
|
(ref-variable subexpression-end-marker)))))))))))
|
|
|
|
|
|
|
|
|
|
(define (invalid-subexpression? subexpression)
|
|
|
|
|
(or (debugging-info/undefined-expression? subexpression)
|
|
|
|
|
(debugging-info/unknown-expression? subexpression)))
|
|
|
|
|
|
|
|
|
|
(define (print-reduction subproblem-number reduction-number reduction port)
|
|
|
|
|
(print-history-level
|
|
|
|
|
#f
|
|
|
|
|
subproblem-number
|
|
|
|
|
(string-append ", R=" (number->string reduction-number) " --- ")
|
|
|
|
|
(lambda ()
|
|
|
|
|
(print-reduction-as-subexpression (reduction-expression reduction)))
|
|
|
|
|
(reduction-environment reduction)
|
|
|
|
|
port))
|
|
|
|
|
|
|
|
|
|
(define (print-reduction-as-subexpression expression)
|
|
|
|
|
(parameterize ((param:print-primitives-by-name? #t))
|
|
|
|
|
(write-string (ref-variable subexpression-start-marker))
|
|
|
|
|
(write (unsyntax expression))
|
|
|
|
|
(write-string (ref-variable subexpression-end-marker))))
|
|
|
|
|
|
|
|
|
|
(define (print-history-level compiled? subproblem-number reduction-id
|
|
|
|
|
expression-thunk environment port)
|
|
|
|
|
(fresh-line port)
|
|
|
|
|
(let ((level-identification
|
|
|
|
|
(string-append (if compiled? "-C- S=" "-I- S=")
|
|
|
|
|
(number->string subproblem-number)
|
|
|
|
|
reduction-id)))
|
|
|
|
|
(write-string level-identification port)
|
|
|
|
|
(let ((pad-width (max 0 (- 78 (string-length level-identification)))))
|
|
|
|
|
(write-string
|
|
|
|
|
(string-pad-right
|
|
|
|
|
(string-append
|
|
|
|
|
(cdr
|
|
|
|
|
(call-with-truncated-output-string pad-width
|
|
|
|
|
(lambda (port)
|
|
|
|
|
(parameterize ((current-output-port port))
|
|
|
|
|
(expression-thunk)))))
|
|
|
|
|
" ")
|
|
|
|
|
pad-width
|
|
|
|
|
#\-)
|
|
|
|
|
port)))
|
|
|
|
|
(if (ref-variable debugger-verbose-mode?)
|
|
|
|
|
(begin
|
|
|
|
|
(newline port)
|
|
|
|
|
(if (environment? environment)
|
|
|
|
|
(show-environment-name environment port)
|
|
|
|
|
(write-string "There is no environment stored for this frame."
|
|
|
|
|
port))))
|
|
|
|
|
(if (ref-variable debugger-open-markers?)
|
|
|
|
|
(newline port)))
|
|
|
|
|
|
|
|
|
|
;;;; Marker Location
|
|
|
|
|
|
|
|
|
|
(define forward-subproblem)
|
|
|
|
|
(define backward-subproblem)
|
|
|
|
|
(make-motion-pair (lambda (start)
|
|
|
|
|
(forward-one-level start find-next-subproblem-marker))
|
|
|
|
|
(lambda (start)
|
|
|
|
|
(backward-one-level start find-previous-subproblem-marker))
|
|
|
|
|
(lambda (f b)
|
|
|
|
|
(set! forward-subproblem f)
|
|
|
|
|
(set! backward-subproblem b)
|
|
|
|
|
unspecific))
|
|
|
|
|
|
|
|
|
|
(define forward-reduction)
|
|
|
|
|
(define backward-reduction)
|
|
|
|
|
(make-motion-pair (lambda (start)
|
|
|
|
|
(let ((mark (mark-right-inserting-copy start)))
|
|
|
|
|
(perhaps-expand-reductions mark)
|
|
|
|
|
(let ((result (forward-one-level mark find-next-marker)))
|
|
|
|
|
(mark-temporary! mark)
|
|
|
|
|
result)))
|
|
|
|
|
(lambda (start)
|
|
|
|
|
(let ((mark (mark-left-inserting-copy start)))
|
|
|
|
|
(if (below-subproblem-marker? mark)
|
|
|
|
|
(perhaps-expand-reductions
|
|
|
|
|
(backward-subproblem mark 1)))
|
|
|
|
|
(let ((result
|
|
|
|
|
(backward-one-level mark find-previous-marker)))
|
|
|
|
|
(mark-temporary! mark)
|
|
|
|
|
result)))
|
|
|
|
|
(lambda (f b)
|
|
|
|
|
(set! forward-reduction f)
|
|
|
|
|
(set! backward-reduction b)
|
|
|
|
|
unspecific))
|
|
|
|
|
|
|
|
|
|
(define (forward-one-level start finder)
|
|
|
|
|
(let ((next-level (finder start)))
|
|
|
|
|
(if next-level
|
|
|
|
|
(let ((second-next-level
|
|
|
|
|
(find-next-marker
|
|
|
|
|
(line-end next-level 0))))
|
|
|
|
|
(if second-next-level
|
|
|
|
|
(line-end second-next-level -1)
|
|
|
|
|
(group-end next-level)))
|
|
|
|
|
(begin
|
|
|
|
|
(message "Expanding subproblem...")
|
|
|
|
|
(expand-subproblem (group-end start))
|
|
|
|
|
(temporary-message "Expanding subproblem...done")
|
|
|
|
|
(group-end start)))))
|
|
|
|
|
|
|
|
|
|
(define (backward-one-level start finder)
|
|
|
|
|
(let ((level-top (finder start)))
|
|
|
|
|
(if (or (not level-top) (not (finder level-top)))
|
|
|
|
|
(editor-error "Can't move beyond top level"))
|
|
|
|
|
(line-end level-top -1)))
|
|
|
|
|
|
|
|
|
|
(define (end-of-subproblem mark)
|
|
|
|
|
(let ((subproblem-below (find-next-subproblem-marker mark)))
|
|
|
|
|
(if subproblem-below
|
|
|
|
|
(line-end subproblem-below -1)
|
|
|
|
|
(group-end mark))))
|
|
|
|
|
|
|
|
|
|
(define (below-subproblem-marker? mark)
|
|
|
|
|
(let ((mark (find-previous-marker mark)))
|
|
|
|
|
(and mark
|
|
|
|
|
(re-match-forward subproblem-regexp mark))))
|
|
|
|
|
|
|
|
|
|
(define (region-contains-marker? region)
|
|
|
|
|
(re-search-forward marker-regexp
|
|
|
|
|
(line-start (region-start region) 0)
|
|
|
|
|
(line-end (region-end region) 0)))
|
|
|
|
|
|
|
|
|
|
(define (current-subproblem-number mark)
|
|
|
|
|
(and (find-previous-marker mark)
|
|
|
|
|
(re-match-extract-subproblem)))
|
|
|
|
|
|
|
|
|
|
(define (current-reduction-number mark)
|
|
|
|
|
(and (not (below-subproblem-marker? mark))
|
|
|
|
|
(find-previous-reduction-marker mark)
|
|
|
|
|
(re-match-extract-reduction)))
|
|
|
|
|
|
|
|
|
|
(define (find-next-subproblem-marker mark)
|
|
|
|
|
(and (re-search-forward subproblem-regexp mark (group-end mark))
|
|
|
|
|
(re-match-start 0)))
|
|
|
|
|
|
|
|
|
|
(define (find-next-reduction-marker mark)
|
|
|
|
|
(and (re-search-forward reduction-regexp mark (group-end mark))
|
|
|
|
|
(re-match-start 0)))
|
|
|
|
|
|
|
|
|
|
(define (find-next-marker mark)
|
|
|
|
|
(and (re-search-forward marker-regexp mark (group-end mark))
|
|
|
|
|
(re-match-start 0)))
|
|
|
|
|
|
|
|
|
|
(define (find-previous-subproblem-marker mark)
|
|
|
|
|
(re-search-backward subproblem-regexp mark (group-start mark)))
|
|
|
|
|
|
|
|
|
|
(define (find-previous-reduction-marker mark)
|
|
|
|
|
(re-search-backward reduction-regexp mark (group-start mark)))
|
|
|
|
|
|
|
|
|
|
(define (find-previous-marker mark)
|
|
|
|
|
(re-search-backward marker-regexp mark (group-start mark)))
|
|
|
|
|
|
|
|
|
|
(define (re-match-extract-subproblem)
|
|
|
|
|
(or (re-match-extract-number 1)
|
|
|
|
|
(editor-error "Ill-formed subproblem marker")))
|
|
|
|
|
|
|
|
|
|
(define (re-match-extract-reduction)
|
|
|
|
|
(or (re-match-extract-number 2)
|
|
|
|
|
(editor-error "Ill-formed reduction marker")))
|
|
|
|
|
|
|
|
|
|
(define (re-match-extract-reduction-count)
|
|
|
|
|
(re-match-extract-number 3))
|
|
|
|
|
|
|
|
|
|
(define (re-match-extract-number register-number)
|
|
|
|
|
(let ((start (re-match-start register-number))
|
|
|
|
|
(end (re-match-end register-number)))
|
|
|
|
|
(and start
|
|
|
|
|
end
|
|
|
|
|
(string->number (extract-string end start)))))
|
|
|
|
|
|
|
|
|
|
;;; Regular expressions for finding subproblem and reduction marker
|
|
|
|
|
;;; lines. After a match on REDUCTION-REGEXP, register 1 must match
|
|
|
|
|
;;; the subproblem number and register 2 must match the reduction
|
|
|
|
|
;;; number. After a match on SUBPROBLEM-REGEXP, register 1 must
|
|
|
|
|
;;; match the subproblem number and register 3 must match the maximum
|
|
|
|
|
;;; reduction number in that subproblem.
|
|
|
|
|
|
|
|
|
|
(define subproblem-regexp
|
|
|
|
|
"^-[CI]- S=\\([0-9]+\\) \\(#R=\\([0-9]+\\)\\|\\)")
|
|
|
|
|
|
|
|
|
|
(define reduction-regexp
|
|
|
|
|
"^-I- S=\\([0-9]+\\), R=\\([0-9]+\\)")
|
|
|
|
|
|
|
|
|
|
(define marker-regexp
|
|
|
|
|
"^-[CI]- S=\\([0-9]+\\)\\(, R=[0-9]+\\| #R=[0-9]+\\|\\)")
|
|
|
|
|
|
|
|
|
|
;;;; Debugger State
|
|
|
|
|
|
|
|
|
|
;;; UGLY BECAUSE IT MUTATES THE DSTATE.
|
|
|
|
|
|
|
|
|
|
(define (debug-dstate mark)
|
|
|
|
|
(let ((dstate (buffer-dstate (mark-buffer mark))))
|
|
|
|
|
(let ((subproblem-number (current-subproblem-number mark))
|
|
|
|
|
(reduction-number (current-reduction-number mark)))
|
|
|
|
|
(if subproblem-number
|
|
|
|
|
(begin (change-subproblem! dstate subproblem-number)
|
|
|
|
|
(if (and reduction-number
|
|
|
|
|
(positive? (dstate/number-of-reductions dstate)))
|
|
|
|
|
(change-reduction! dstate reduction-number)
|
|
|
|
|
(set-dstate/reduction-number! dstate #f))
|
|
|
|
|
dstate)
|
|
|
|
|
(editor-error "Cannot find environment for evaluation.")))))
|
|
|
|
|
|
|
|
|
|
(define (change-subproblem! dstate subproblem-number)
|
|
|
|
|
(let ((finish-move-to-subproblem!
|
|
|
|
|
(lambda (dstate)
|
|
|
|
|
(if (and (dstate/using-history? dstate)
|
|
|
|
|
(positive? (dstate/number-of-reductions dstate)))
|
|
|
|
|
(change-reduction! dstate 0)
|
|
|
|
|
(set-dstate/reduction-number! dstate #f))))
|
|
|
|
|
(delta (- subproblem-number (dstate/subproblem-number dstate))))
|
|
|
|
|
(if (negative? delta)
|
|
|
|
|
(let ((subproblems
|
|
|
|
|
(drop (dstate/previous-subproblems dstate)
|
|
|
|
|
(-1+ (- delta)))))
|
|
|
|
|
(set-current-subproblem! dstate (car subproblems) (cdr subproblems))
|
|
|
|
|
(finish-move-to-subproblem! dstate))
|
|
|
|
|
(let loop
|
|
|
|
|
((subproblem (dstate/subproblem dstate))
|
|
|
|
|
(subproblems (dstate/previous-subproblems dstate))
|
|
|
|
|
(delta delta))
|
|
|
|
|
(if (zero? delta)
|
|
|
|
|
(begin
|
|
|
|
|
(set-current-subproblem! dstate subproblem subproblems)
|
|
|
|
|
(finish-move-to-subproblem! dstate))
|
|
|
|
|
(loop (stack-frame/next-subproblem subproblem)
|
|
|
|
|
(cons subproblem subproblems)
|
|
|
|
|
(-1+ delta)))))))
|
|
|
|
|
|
|
|
|
|
(define (change-reduction! dstate reduction-number)
|
|
|
|
|
(set-dstate/reduction-number! dstate reduction-number)
|
|
|
|
|
(set-dstate/environment-list!
|
|
|
|
|
dstate
|
|
|
|
|
(list (reduction-environment (dstate/reduction dstate)))))
|
|
|
|
|
|
|
|
|
|
(define (count-subproblems buffer)
|
|
|
|
|
(do ((i 0 (1+ i))
|
|
|
|
|
(subproblem (dstate/subproblem (buffer-dstate buffer))
|
|
|
|
|
(stack-frame/next-subproblem subproblem)))
|
|
|
|
|
((not subproblem) i)))
|
|
|
|
|
|
|
|
|
|
(define (nth-subproblem buffer n)
|
|
|
|
|
(let ((dstate (buffer-dstate buffer)))
|
|
|
|
|
(do ((frame
|
|
|
|
|
(let ((previous-subproblems (dstate/previous-subproblems dstate)))
|
|
|
|
|
(if (null? previous-subproblems)
|
|
|
|
|
(dstate/subproblem dstate)
|
|
|
|
|
(car (last-pair previous-subproblems))))
|
|
|
|
|
(or (stack-frame/next-subproblem frame)
|
|
|
|
|
(editor-error "No such subproblem" n)))
|
|
|
|
|
(level 0 (+ level 1)))
|
|
|
|
|
((= level n) frame))))
|
|
|
|
|
|
|
|
|
|
(define (dstate-evaluation-environment dstate)
|
|
|
|
|
(let ((environment-list (dstate/environment-list dstate)))
|
|
|
|
|
(if (and (pair? environment-list)
|
|
|
|
|
(environment? (car environment-list)))
|
|
|
|
|
(car environment-list)
|
|
|
|
|
(evaluation-environment-no-repl))))
|
|
|
|
|
|
|
|
|
|
;;;; Interface Port
|
|
|
|
|
|
|
|
|
|
(define (invoke-debugger-command mark command)
|
|
|
|
|
(call-with-interface-port mark
|
|
|
|
|
(lambda (port)
|
|
|
|
|
(command (debug-dstate mark) port))))
|
|
|
|
|
|
|
|
|
|
(define (call-with-interface-port mark receiver)
|
|
|
|
|
(let ((mark (mark-left-inserting-copy mark)))
|
|
|
|
|
(let ((value (receiver (make-port interface-port-type mark))))
|
|
|
|
|
(mark-temporary! mark)
|
|
|
|
|
value)))
|
|
|
|
|
|
|
|
|
|
(define (operation/write-char port char)
|
|
|
|
|
(guarantee 8-bit-char? char)
|
|
|
|
|
(region-insert-char! (port/state port) char))
|
|
|
|
|
|
|
|
|
|
(define (operation/write-substring port string start end)
|
|
|
|
|
(if (string? string)
|
|
|
|
|
(region-insert-substring! (port/state port) string start end)
|
|
|
|
|
(generic-port-operation:write-substring port string start end)))
|
|
|
|
|
|
|
|
|
|
(define (operation/x-size port)
|
|
|
|
|
(let ((buffer (mark-buffer (port/state port))))
|
|
|
|
|
(and buffer
|
|
|
|
|
(let ((windows (buffer-windows buffer)))
|
|
|
|
|
(and (not (null? windows))
|
|
|
|
|
(apply min (map window-x-size windows)))))))
|
|
|
|
|
|
|
|
|
|
(define (operation/debugger-failure port string)
|
|
|
|
|
port
|
|
|
|
|
(message string)
|
|
|
|
|
(editor-beep))
|
|
|
|
|
|
|
|
|
|
(define (operation/debugger-message port string)
|
|
|
|
|
port
|
|
|
|
|
(message string))
|
|
|
|
|
|
|
|
|
|
(define (debugger-presentation port thunk)
|
|
|
|
|
(fresh-line port)
|
|
|
|
|
(fluid-let ((debugger-pp
|
|
|
|
|
(lambda (expression indentation port)
|
|
|
|
|
(pretty-print expression port #t indentation))))
|
|
|
|
|
(thunk))
|
|
|
|
|
(newline port)
|
|
|
|
|
(newline port))
|
|
|
|
|
|
|
|
|
|
(define (operation/prompt-for-expression port prompt)
|
|
|
|
|
port
|
|
|
|
|
(prompt-for-expression prompt))
|
|
|
|
|
|
|
|
|
|
(define (operation/prompt-for-confirmation port prompt)
|
|
|
|
|
port
|
|
|
|
|
(prompt-for-confirmation? prompt))
|
|
|
|
|
|
|
|
|
|
(define interface-port-type
|
|
|
|
|
(make-port-type
|
|
|
|
|
`((WRITE-CHAR ,operation/write-char)
|
|
|
|
|
(WRITE-SUBSTRING ,operation/write-substring)
|
|
|
|
|
(X-SIZE ,operation/x-size)
|
|
|
|
|
(DEBUGGER-FAILURE ,operation/debugger-failure)
|
|
|
|
|
(DEBUGGER-MESSAGE ,operation/debugger-message)
|
|
|
|
|
(DEBUGGER-PRESENTATION ,debugger-presentation)
|
|
|
|
|
(PROMPT-FOR-EXPRESSION ,operation/prompt-for-expression)
|
|
|
|
|
(PROMPT-FOR-CONFIRMATION ,operation/prompt-for-confirmation))
|
2021-04-26 07:57:47 -04:00
|
|
|
|
#f))
|