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.
|
|
|
|
|
|
|
|
|
|
|#
|
|
|
|
|
|
|
|
|
|
;;;; Browser-style Debug and Where
|
|
|
|
|
;;; Package: (edwin debugger)
|
|
|
|
|
|
2021-04-26 07:57:47 -04:00
|
|
|
|
|
2021-04-26 07:53:20 -04:00
|
|
|
|
|
|
|
|
|
;;;; Text prop setup stuff
|
|
|
|
|
|
|
|
|
|
(define (with-output-highlighted port thunk)
|
|
|
|
|
(let ((start (mark-temporary-copy (port/mark port))))
|
|
|
|
|
(thunk)
|
|
|
|
|
(highlight-region (make-region start (port/mark port)) (highlight-face))))
|
|
|
|
|
|
|
|
|
|
(define (read-only-between start end)
|
|
|
|
|
(region-read-only (make-region start end)))
|
|
|
|
|
|
|
|
|
|
(define (readable-between start end)
|
|
|
|
|
(region-writeable (make-region start end)))
|
|
|
|
|
|
|
|
|
|
(define (dehigh-between start end)
|
|
|
|
|
(highlight-region (make-region start end) (default-face)))
|
|
|
|
|
|
|
|
|
|
(define (debugger-pp-highlight-subexpression expression subexpression
|
|
|
|
|
indentation port)
|
|
|
|
|
(let ((start-mark #f)
|
|
|
|
|
(end-mark #f))
|
|
|
|
|
(parameterize ((param:pp-no-highlights? #f))
|
|
|
|
|
(debugger-pp
|
|
|
|
|
(unsyntax-with-substitutions
|
|
|
|
|
expression
|
|
|
|
|
(list (cons subexpression
|
|
|
|
|
(make-pretty-printer-highlight
|
|
|
|
|
(unsyntax subexpression)
|
|
|
|
|
(lambda (port)
|
|
|
|
|
(set! start-mark
|
|
|
|
|
(mark-right-inserting-copy
|
|
|
|
|
(output-port->mark port)))
|
|
|
|
|
unspecific)
|
|
|
|
|
(lambda (port)
|
|
|
|
|
(set! end-mark
|
|
|
|
|
(mark-right-inserting-copy
|
|
|
|
|
(output-port->mark port)))
|
|
|
|
|
unspecific)))))
|
|
|
|
|
indentation
|
|
|
|
|
port))
|
|
|
|
|
(if (and start-mark end-mark)
|
|
|
|
|
(highlight-region-excluding-indentation
|
|
|
|
|
(make-region start-mark end-mark)
|
|
|
|
|
(highlight-face)))
|
|
|
|
|
(if start-mark (mark-temporary! start-mark))
|
|
|
|
|
(if end-mark (mark-temporary! end-mark))))
|
|
|
|
|
|
|
|
|
|
;;;; Browsers
|
|
|
|
|
|
|
|
|
|
(define-record-type <browser>
|
|
|
|
|
(%make-browser buffer object name lines selected-line buffers properties)
|
|
|
|
|
browser?
|
|
|
|
|
|
|
|
|
|
;; The browser's buffer.
|
|
|
|
|
(buffer browser/buffer)
|
|
|
|
|
|
|
|
|
|
;; The object being browsed.
|
|
|
|
|
(object browser/object)
|
|
|
|
|
|
|
|
|
|
;; Name of this browser, a string. Not necessarily unique.
|
|
|
|
|
(name browser/name)
|
|
|
|
|
|
|
|
|
|
;; Vector of BLINE objects, sorted in order of increasing INDEX.
|
|
|
|
|
(lines browser/lines set-browser/lines!)
|
|
|
|
|
|
|
|
|
|
;; The current selected BLINE object.
|
|
|
|
|
(selected-line browser/selected-line set-browser/selected-line!)
|
|
|
|
|
|
|
|
|
|
;; List of buffers associated with this browser.
|
|
|
|
|
(buffers browser/buffers set-browser/buffers!)
|
|
|
|
|
|
|
|
|
|
(properties browser/properties))
|
|
|
|
|
|
|
|
|
|
(define (make-browser name mode object)
|
|
|
|
|
(let ((buffer (new-buffer name)))
|
|
|
|
|
(buffer-reset! buffer)
|
|
|
|
|
(set-buffer-read-only! buffer)
|
|
|
|
|
(set-buffer-major-mode! buffer mode)
|
|
|
|
|
(add-kill-buffer-hook buffer kill-browser-buffer)
|
|
|
|
|
(let ((browser
|
|
|
|
|
(%make-browser buffer
|
|
|
|
|
object
|
|
|
|
|
name
|
|
|
|
|
(vector)
|
|
|
|
|
#f
|
|
|
|
|
'()
|
|
|
|
|
(make-1d-table))))
|
|
|
|
|
(buffer-put! buffer 'BROWSER browser)
|
|
|
|
|
browser)))
|
|
|
|
|
|
|
|
|
|
(define (kill-browser-buffer buffer)
|
|
|
|
|
(let ((browser (buffer-get buffer 'BROWSER)))
|
|
|
|
|
(if browser
|
|
|
|
|
(for-each kill-buffer (browser/buffers browser)))))
|
|
|
|
|
|
|
|
|
|
(define (buffer-browser buffer)
|
|
|
|
|
(let ((browser (buffer-get buffer 'BROWSER)))
|
|
|
|
|
(if (not browser)
|
|
|
|
|
(error "This buffer has no associated browser:" buffer))
|
|
|
|
|
browser))
|
|
|
|
|
|
|
|
|
|
(define (browser/new-buffer browser initializer)
|
|
|
|
|
(let ((buffer
|
|
|
|
|
(create-buffer
|
|
|
|
|
(let ((prefix (browser/name browser)))
|
|
|
|
|
(let loop ((index 1))
|
|
|
|
|
(let ((name
|
|
|
|
|
(string-append " "
|
|
|
|
|
prefix
|
|
|
|
|
"-"
|
|
|
|
|
(number->string index))))
|
|
|
|
|
(if (find-buffer name)
|
|
|
|
|
(loop (+ index 1))
|
|
|
|
|
name)))))))
|
|
|
|
|
(if initializer
|
|
|
|
|
(initializer buffer))
|
|
|
|
|
(enable-group-undo! (buffer-group buffer))
|
|
|
|
|
(add-browser-buffer! browser buffer)
|
|
|
|
|
buffer))
|
|
|
|
|
|
|
|
|
|
(define (add-browser-buffer! browser buffer)
|
|
|
|
|
(add-rename-buffer-hook
|
|
|
|
|
buffer
|
|
|
|
|
(letrec
|
|
|
|
|
((hook
|
|
|
|
|
(lambda (buffer name)
|
|
|
|
|
name
|
|
|
|
|
(set-browser/buffers! browser
|
|
|
|
|
(delq! buffer (browser/buffers browser)))
|
|
|
|
|
(remove-rename-buffer-hook buffer hook))))
|
|
|
|
|
hook))
|
|
|
|
|
(add-kill-buffer-hook
|
|
|
|
|
buffer
|
|
|
|
|
(lambda (buffer)
|
|
|
|
|
(set-browser/buffers! browser
|
|
|
|
|
(delq! buffer (browser/buffers browser)))))
|
|
|
|
|
(set-browser/buffers! browser (cons buffer (browser/buffers browser)))
|
|
|
|
|
(buffer-put! buffer 'ASSOCIATED-WITH-BROWSER browser))
|
|
|
|
|
|
|
|
|
|
(define (browser/new-screen browser)
|
|
|
|
|
(let ((pair (1d-table/get (browser/properties browser) 'NEW-SCREEN #f)))
|
|
|
|
|
(and pair
|
|
|
|
|
(let ((screen (weak-car pair)))
|
|
|
|
|
(and (screen? screen)
|
|
|
|
|
screen)))))
|
|
|
|
|
|
|
|
|
|
(define (set-browser/new-screen! browser screen)
|
|
|
|
|
(1d-table/put! (browser/properties browser)
|
|
|
|
|
'NEW-SCREEN
|
|
|
|
|
(weak-cons screen #f)))
|
|
|
|
|
|
|
|
|
|
;;;; Browser Commands
|
|
|
|
|
|
|
|
|
|
(define-command browser-select-line
|
|
|
|
|
"Select the current browser line."
|
|
|
|
|
"d"
|
|
|
|
|
(lambda (point)
|
|
|
|
|
(let ((bline (mark->bline point)))
|
|
|
|
|
(if (not bline)
|
|
|
|
|
(editor-error "Nothing to select on this line."))
|
|
|
|
|
(select-bline bline))))
|
|
|
|
|
|
|
|
|
|
;;; If the mouse clicks on a bline, select it.
|
|
|
|
|
(define-command debugger-mouse-select-bline
|
|
|
|
|
"Select a bline when mouse clicked there."
|
|
|
|
|
()
|
|
|
|
|
(lambda ()
|
|
|
|
|
((ref-command mouse-set-point))
|
|
|
|
|
(let ((bline (mark->bline (current-point))))
|
|
|
|
|
(if bline
|
|
|
|
|
(select-bline bline)))))
|
|
|
|
|
|
|
|
|
|
(define-command browser-next-line
|
|
|
|
|
"Move down to the next line."
|
|
|
|
|
"p"
|
|
|
|
|
(lambda (argument)
|
|
|
|
|
(let* ((browser (buffer-browser (current-buffer)))
|
|
|
|
|
(bline
|
|
|
|
|
(letrec
|
|
|
|
|
((loop
|
|
|
|
|
(lambda (index argument)
|
|
|
|
|
(let ((bline (browser/line browser index)))
|
|
|
|
|
(cond ((bline/continuation? bline)
|
|
|
|
|
(replace-continuation-bline bline)
|
|
|
|
|
(loop index argument))
|
|
|
|
|
((= argument 0)
|
|
|
|
|
bline)
|
|
|
|
|
((> argument 0)
|
|
|
|
|
(let ((index (+ index 1)))
|
|
|
|
|
(if (< index (browser/n-lines browser))
|
|
|
|
|
(loop index (- argument 1))
|
|
|
|
|
(begin
|
|
|
|
|
(select-bline bline)
|
|
|
|
|
#f))))
|
|
|
|
|
(else
|
|
|
|
|
(let ((index (- index 1)))
|
|
|
|
|
(if (<= 0 index)
|
|
|
|
|
(loop index (+ argument 1))
|
|
|
|
|
(begin
|
|
|
|
|
(select-bline bline)
|
|
|
|
|
#f)))))))))
|
|
|
|
|
(let ((point (current-point)))
|
|
|
|
|
(let ((index (mark->bline-index point)))
|
|
|
|
|
(cond (index
|
|
|
|
|
(loop index argument))
|
|
|
|
|
((= argument 0)
|
|
|
|
|
#f)
|
|
|
|
|
(else
|
|
|
|
|
(let ((n (if (< argument 0) -1 1)))
|
|
|
|
|
(let find-next ((mark point))
|
|
|
|
|
(let ((mark (line-start mark n #f)))
|
|
|
|
|
(and mark
|
|
|
|
|
(let ((index (mark->bline-index mark)))
|
|
|
|
|
(if index
|
|
|
|
|
(loop index (- argument n))
|
|
|
|
|
(find-next mark))))))))))))))
|
|
|
|
|
(cond (bline
|
|
|
|
|
(select-bline bline))
|
|
|
|
|
((= argument 0)
|
|
|
|
|
(editor-failure "Nothing to select on this line."))
|
|
|
|
|
(else
|
|
|
|
|
(editor-failure))))))
|
|
|
|
|
|
|
|
|
|
(define-command browser-previous-line
|
|
|
|
|
"Move up to the previous line."
|
|
|
|
|
"p"
|
|
|
|
|
(lambda (argument)
|
|
|
|
|
((ref-command browser-next-line) (- argument))))
|
|
|
|
|
|
|
|
|
|
(define (select-bline bline)
|
|
|
|
|
(let ((bline
|
|
|
|
|
(if (bline/continuation? bline)
|
|
|
|
|
(replace-continuation-bline bline)
|
|
|
|
|
bline)))
|
|
|
|
|
(let ((browser (bline/browser bline)))
|
|
|
|
|
(unselect-bline browser)
|
|
|
|
|
(let ((mark (bline/start-mark bline)))
|
|
|
|
|
(with-buffer-open mark
|
|
|
|
|
(lambda ()
|
|
|
|
|
(insert-char #\> (mark1+ mark))
|
|
|
|
|
(delete-right-char mark)
|
|
|
|
|
(highlight-the-number mark)))
|
|
|
|
|
(set-browser/selected-line! browser bline)
|
|
|
|
|
(set-buffer-point! (mark-buffer mark) mark)))
|
|
|
|
|
(let ((buffer (bline/description-buffer bline)))
|
|
|
|
|
(if buffer
|
|
|
|
|
(pop-up-buffer buffer #f)))))
|
|
|
|
|
|
|
|
|
|
(define (highlight-the-number mark)
|
|
|
|
|
(let ((end (re-search-forward "[RSE][0-9]+ " mark (line-end mark 0))))
|
|
|
|
|
(highlight-region (make-region mark
|
|
|
|
|
(if (mark? end)
|
|
|
|
|
(mark- end 1)
|
|
|
|
|
(line-end mark 0)))
|
|
|
|
|
(highlight-face))))
|
|
|
|
|
|
|
|
|
|
(define (unselect-bline browser)
|
|
|
|
|
(let ((bline (browser/selected-line browser)))
|
|
|
|
|
(if bline
|
|
|
|
|
(let ((mark (bline/start-mark bline)))
|
|
|
|
|
(with-buffer-open mark
|
|
|
|
|
(lambda ()
|
|
|
|
|
(dehigh-between mark (line-end mark 0))
|
|
|
|
|
(insert-char #\space (mark1+ mark))
|
|
|
|
|
(delete-right-char mark)))))))
|
|
|
|
|
|
|
|
|
|
;;; For any frame with an environment (excluding the mark frame) an
|
|
|
|
|
;;; inferior repl is started below the other descriptions.
|
|
|
|
|
|
|
|
|
|
(define (bline/description-buffer bline)
|
|
|
|
|
(let* ((system?
|
|
|
|
|
(and (subproblem? (bline/object bline))
|
|
|
|
|
(system-frame? (subproblem/stack-frame (bline/object bline)))))
|
|
|
|
|
(buffer
|
|
|
|
|
(1d-table/get (bline/properties bline) 'DESCRIPTION-BUFFER #f))
|
|
|
|
|
(get-environment
|
|
|
|
|
(1d-table/get (bline-type/properties (bline/type bline))
|
|
|
|
|
'GET-ENVIRONMENT
|
|
|
|
|
#f))
|
|
|
|
|
(env-exists? (if (and get-environment (not system?))
|
|
|
|
|
(let ((environment* (get-environment bline)))
|
|
|
|
|
(environment? environment*))
|
|
|
|
|
#f))
|
|
|
|
|
(environment (if env-exists? (get-environment bline) #f)))
|
|
|
|
|
(if (and buffer (buffer-alive? buffer))
|
|
|
|
|
buffer
|
|
|
|
|
(let ((write-description
|
|
|
|
|
(bline-type/write-description (bline/type bline))))
|
|
|
|
|
((message-wrapper #t "Computing, please wait")
|
|
|
|
|
(lambda ()
|
|
|
|
|
(and write-description
|
|
|
|
|
(let ((buffer (browser/new-buffer (bline/browser bline) #f)))
|
|
|
|
|
(call-with-output-mark (buffer-start buffer)
|
|
|
|
|
(lambda (port)
|
|
|
|
|
(write-description bline port)
|
|
|
|
|
(if env-exists?
|
|
|
|
|
(begin
|
|
|
|
|
(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)
|
|
|
|
|
'DESCRIPTION-BUFFER
|
|
|
|
|
buffer)
|
|
|
|
|
(read-only-between (buffer-start buffer)
|
|
|
|
|
(buffer-end buffer))
|
|
|
|
|
(buffer-not-modified! buffer)
|
|
|
|
|
(if env-exists?
|
|
|
|
|
(start-inferior-repl! buffer environment #f))
|
|
|
|
|
buffer))))))))
|
|
|
|
|
|
|
|
|
|
(define evaluation-line-marker
|
|
|
|
|
";EVALUATION may occur below in the environment of the selected frame.")
|
|
|
|
|
|
|
|
|
|
(define-command browser-quit
|
|
|
|
|
"Exit the current browser, deleting its buffer."
|
|
|
|
|
()
|
|
|
|
|
(lambda ()
|
|
|
|
|
(let ((buffer (current-buffer)))
|
|
|
|
|
(let ((browser (buffer-browser buffer))
|
|
|
|
|
(screen (selected-screen)))
|
|
|
|
|
;; Delete all windows that are currently showing buffers that
|
|
|
|
|
;; are associated with this browser.
|
|
|
|
|
(let ((window (screen-selected-window screen))
|
|
|
|
|
(buffers (browser/buffers browser)))
|
|
|
|
|
(for-each (lambda (window*)
|
|
|
|
|
(if (and (not (eq? window* window))
|
|
|
|
|
(not (typein-window? window*))
|
|
|
|
|
(memq (window-buffer window*) buffers))
|
|
|
|
|
(window-delete! window*)))
|
|
|
|
|
(screen-window-list screen)))
|
|
|
|
|
;; If the browser was popped up in a new screen, and that
|
|
|
|
|
;; screen is the current screen, delete it too.
|
|
|
|
|
(let ((new-screen (browser/new-screen browser)))
|
|
|
|
|
(if (and (eq? new-screen screen)
|
|
|
|
|
(other-screen screen 1 #t))
|
|
|
|
|
(delete-screen! screen))))
|
|
|
|
|
;; Kill the buffer, then maybe select another browser.
|
|
|
|
|
(let ((browser (get-buffer-browser buffer 'ASSOCIATED-WITH-BROWSER)))
|
|
|
|
|
(kill-buffer-interactive buffer)
|
|
|
|
|
(let ((browser
|
|
|
|
|
(or browser
|
|
|
|
|
(let ((buffer (current-buffer)))
|
|
|
|
|
(or (get-buffer-browser buffer 'BROWSER)
|
|
|
|
|
(get-buffer-browser buffer
|
|
|
|
|
'ASSOCIATED-WITH-BROWSER))))))
|
|
|
|
|
(if browser
|
|
|
|
|
(let ((buffer (browser/buffer browser)))
|
|
|
|
|
(select-buffer buffer)
|
|
|
|
|
((ref-command browser-select-line) (buffer-point buffer))))))
|
|
|
|
|
(clear-current-message!)
|
|
|
|
|
(maybe-restart-buffer-thread buffer))))
|
|
|
|
|
|
|
|
|
|
(define (get-buffer-browser buffer key)
|
|
|
|
|
(let ((browser (buffer-get buffer key)))
|
|
|
|
|
(and (browser? browser)
|
|
|
|
|
(buffer-alive? (browser/buffer browser))
|
|
|
|
|
browser)))
|
|
|
|
|
|
|
|
|
|
(define (maybe-restart-buffer-thread buffer)
|
|
|
|
|
(let ((cont (maybe-get-continuation buffer))
|
|
|
|
|
(thread (buffer-get buffer 'THREAD)))
|
|
|
|
|
(if (and thread cont)
|
|
|
|
|
(if (eq? thread editor-thread)
|
|
|
|
|
(signal-thread-event editor-thread (lambda () (cont unspecific)))
|
|
|
|
|
(restart-thread thread #f #f)))))
|
|
|
|
|
|
|
|
|
|
;;;addition for when debugger is called from a break
|
|
|
|
|
;;;should quit the debugger, and give the continuation
|
|
|
|
|
;;;a value to proceed with (restarting that thread)
|
|
|
|
|
;;;if in a normal error debug it will envoke the standard
|
|
|
|
|
;;;restarts
|
|
|
|
|
(define-command quit-with-restart-value
|
|
|
|
|
"Quit the breakpoint, exiting with a specified value."
|
|
|
|
|
()
|
|
|
|
|
(lambda ()
|
|
|
|
|
(let* ((buffer (current-buffer))
|
|
|
|
|
(thread (buffer-get buffer 'THREAD)))
|
|
|
|
|
(if (thread? thread)
|
|
|
|
|
(let ((value (prompt-for-expression-value
|
|
|
|
|
"Please enter a value to continue with"))
|
|
|
|
|
(cont (maybe-get-continuation buffer)))
|
|
|
|
|
(buffer-remove! buffer 'THREAD)
|
|
|
|
|
((ref-command browser-quit))
|
|
|
|
|
(cond ((eq? thread editor-thread)
|
|
|
|
|
(signal-thread-event editor-thread (lambda ()
|
|
|
|
|
(cont value))))
|
|
|
|
|
(else
|
|
|
|
|
(set! value? #t)
|
|
|
|
|
(restart-thread thread #t (lambda ()
|
|
|
|
|
(cont value))))))
|
|
|
|
|
(invoke-restarts #f)))))
|
|
|
|
|
|
|
|
|
|
(define (maybe-get-continuation buffer)
|
|
|
|
|
(let ((object (browser/object (buffer-get buffer 'BROWSER))))
|
|
|
|
|
(and (continuation? object)
|
|
|
|
|
object)))
|
|
|
|
|
|
|
|
|
|
;;;Method for invoking the standard restarts from within the
|
|
|
|
|
;;;debugger.
|
|
|
|
|
(define (invoke-restarts avoid-deletion?)
|
|
|
|
|
(let* ((mark (current-point))
|
|
|
|
|
(bline (mark->bline mark))
|
|
|
|
|
(browser (bline/browser bline))
|
|
|
|
|
(buffer
|
|
|
|
|
(1d-table/get (bline/properties bline) 'DESCRIPTION-BUFFER #f))
|
|
|
|
|
(condition
|
|
|
|
|
(browser/object browser)))
|
|
|
|
|
(if (condition? condition)
|
|
|
|
|
(fluid-let ((prompt-for-confirmation
|
|
|
|
|
(lambda (prompt #!optional port)
|
|
|
|
|
port
|
|
|
|
|
(call-with-interface-port (buffer-end buffer)
|
|
|
|
|
(lambda (port)
|
|
|
|
|
port
|
|
|
|
|
(prompt-for-yes-or-no? prompt)))))
|
|
|
|
|
(prompt-for-evaluated-expression
|
|
|
|
|
(lambda (prompt #!optional environment port)
|
|
|
|
|
port
|
|
|
|
|
(call-with-interface-port (buffer-end buffer)
|
|
|
|
|
(lambda (port)
|
|
|
|
|
port
|
|
|
|
|
(repl-eval (prompt-for-expression prompt)
|
|
|
|
|
environment)))))
|
|
|
|
|
(hook/invoke-restart
|
|
|
|
|
(lambda (continuation arguments)
|
|
|
|
|
(invoke-continuation continuation
|
|
|
|
|
arguments
|
|
|
|
|
avoid-deletion?))))
|
|
|
|
|
(call-with-interface-port
|
|
|
|
|
(let ((buff (new-buffer " *debug*-RESTARTS")))
|
|
|
|
|
(add-browser-buffer! browser buff)
|
|
|
|
|
(pop-up-buffer buff #f)
|
|
|
|
|
(buffer-start buff))
|
|
|
|
|
(lambda (port)
|
|
|
|
|
(write-string " " port)
|
|
|
|
|
(write-condition-report condition port)
|
|
|
|
|
(debugger-newline port)
|
|
|
|
|
(command/condition-restart
|
|
|
|
|
(make-initial-dstate condition)
|
|
|
|
|
port))))
|
|
|
|
|
(message "No condition to restart from."))))
|
|
|
|
|
|
|
|
|
|
(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 interface-port-type
|
|
|
|
|
(make-port-type
|
|
|
|
|
`((write-char
|
|
|
|
|
,(lambda (port char)
|
|
|
|
|
(guarantee 8-bit-char? char)
|
|
|
|
|
(region-insert-char! (port/state port) char)
|
|
|
|
|
1))
|
|
|
|
|
(prompt-for-confirmation
|
|
|
|
|
,(lambda (port prompt)
|
|
|
|
|
(declare (ignore port))
|
|
|
|
|
(prompt-for-confirmation? prompt)))
|
|
|
|
|
(prompt-for-expression
|
|
|
|
|
,(lambda (port prompt)
|
|
|
|
|
(declare (ignore port))
|
|
|
|
|
(prompt-for-expression prompt))))
|
|
|
|
|
#f))
|
|
|
|
|
|
|
|
|
|
(define (invoke-continuation continuation arguments avoid-deletion?)
|
|
|
|
|
(let ((buffer (current-buffer)))
|
|
|
|
|
(if (and (not avoid-deletion?)
|
|
|
|
|
(ref-variable debugger-quit-on-return?))
|
|
|
|
|
((ref-command browser-quit)))
|
|
|
|
|
((or (buffer-get buffer 'INVOKE-CONTINUATION) apply)
|
|
|
|
|
continuation arguments)))
|
|
|
|
|
|
|
|
|
|
;;;; Where
|
|
|
|
|
|
|
|
|
|
(define-command browser-where
|
|
|
|
|
"Select an environment browser for this line's environment."
|
|
|
|
|
()
|
|
|
|
|
(lambda ()
|
|
|
|
|
(select-buffer
|
|
|
|
|
(bline/environment-browser-buffer (current-selected-line)))))
|
|
|
|
|
|
|
|
|
|
(define (bline/environment-browser-buffer bline)
|
|
|
|
|
(let ((environment (bline/evaluation-environment bline)))
|
|
|
|
|
(bline/attached-buffer bline 'ENVIRONMENT-BROWSER
|
|
|
|
|
(lambda ()
|
|
|
|
|
(or (find (lambda (buffer)
|
|
|
|
|
(let ((browser (buffer-get buffer 'BROWSER)))
|
|
|
|
|
(and browser (eq? environment (browser/object browser)))))
|
|
|
|
|
(buffer-list))
|
|
|
|
|
(environment-browser-buffer environment))))))
|
|
|
|
|
|
|
|
|
|
(define (bline/attached-buffer bline type make-buffer)
|
|
|
|
|
(let ((buffer (1d-table/get (bline/properties bline) type #f)))
|
|
|
|
|
(if (and buffer (buffer-alive? buffer))
|
|
|
|
|
buffer
|
|
|
|
|
(let ((buffer (make-buffer)))
|
|
|
|
|
(1d-table/put! (bline/properties bline) type buffer)
|
|
|
|
|
(add-browser-buffer! (bline/browser bline) buffer)
|
|
|
|
|
buffer))))
|
|
|
|
|
|
|
|
|
|
(define (current-selected-line)
|
|
|
|
|
(let ((bline (browser/selected-line (buffer-browser (current-buffer)))))
|
|
|
|
|
(if (not bline)
|
|
|
|
|
(editor-error "There is no selected line; please select one."))
|
|
|
|
|
bline))
|
|
|
|
|
|
|
|
|
|
(define (bline/evaluation-environment bline)
|
|
|
|
|
(let ((get-environment
|
|
|
|
|
(1d-table/get (bline-type/properties (bline/type bline))
|
|
|
|
|
'GET-ENVIRONMENT
|
|
|
|
|
#f))
|
|
|
|
|
(lose
|
|
|
|
|
(lambda () (editor-error "The selected line has no environment."))))
|
|
|
|
|
(if get-environment
|
|
|
|
|
(let ((environment (get-environment bline)))
|
|
|
|
|
(if (environment? environment)
|
|
|
|
|
environment
|
|
|
|
|
(lose)))
|
|
|
|
|
(lose))))
|
|
|
|
|
|
|
|
|
|
;;;; Browser Lines
|
|
|
|
|
|
|
|
|
|
(define-record-type <browser-line>
|
|
|
|
|
(%make-bline start-mark object type parent depth next prev offset
|
|
|
|
|
properties)
|
|
|
|
|
bline?
|
|
|
|
|
|
|
|
|
|
;; Index of this bline within browser lines vector. #F if line is
|
|
|
|
|
;; invisible.
|
|
|
|
|
(index bline/index set-bline/index!)
|
|
|
|
|
|
|
|
|
|
;; Line start within browser buffer. #F if line is invisible.
|
|
|
|
|
(start-mark bline/start-mark set-bline/start-mark!)
|
|
|
|
|
|
|
|
|
|
;; Object that this line represents.
|
|
|
|
|
(object bline/object)
|
|
|
|
|
|
|
|
|
|
;; Type of OBJECT. This type is specific to the browser; it tells
|
|
|
|
|
;; the browser how to manipulate OBJECT.
|
|
|
|
|
(type bline/type)
|
|
|
|
|
|
|
|
|
|
;; BLINE representing the object that this object is a component of,
|
|
|
|
|
;; or #F if none.
|
|
|
|
|
(parent bline/parent)
|
|
|
|
|
|
|
|
|
|
;; Nonnegative integer indicating the depth of this object in the
|
|
|
|
|
;; component nesting.
|
|
|
|
|
(depth bline/depth)
|
|
|
|
|
|
|
|
|
|
;; BLINEs representing the objects that are adjacent to this one in
|
|
|
|
|
;; the component ordering, or #F if none.
|
|
|
|
|
(next bline/next set-bline/next!)
|
|
|
|
|
(prev bline/prev)
|
|
|
|
|
|
|
|
|
|
;; Nonnegative integer indicating the position of this object in the
|
|
|
|
|
;; component ordering.
|
|
|
|
|
(offset bline/offset)
|
|
|
|
|
|
|
|
|
|
(properties bline/properties))
|
|
|
|
|
|
|
|
|
|
(define (make-bline object type parent prev)
|
|
|
|
|
(let ((bline
|
|
|
|
|
(%make-bline #f
|
|
|
|
|
object
|
|
|
|
|
type
|
|
|
|
|
parent
|
|
|
|
|
(if parent (+ (bline/depth parent) 1) 0)
|
|
|
|
|
#f
|
|
|
|
|
prev
|
|
|
|
|
(if prev (+ (bline/offset prev) 1) 0)
|
|
|
|
|
(make-1d-table))))
|
|
|
|
|
(if prev
|
|
|
|
|
(set-bline/next! prev bline))
|
|
|
|
|
bline))
|
|
|
|
|
|
|
|
|
|
(define (bline/browser bline)
|
|
|
|
|
(buffer-browser (mark-buffer (bline/start-mark bline))))
|
|
|
|
|
|
|
|
|
|
;;;; Browser Line Editing
|
|
|
|
|
|
|
|
|
|
(define (browser/n-lines browser)
|
|
|
|
|
(vector-length (browser/lines browser)))
|
|
|
|
|
|
|
|
|
|
(define (browser/line browser index)
|
|
|
|
|
(vector-ref (browser/lines browser) index))
|
|
|
|
|
|
|
|
|
|
(define (mark->bline mark)
|
|
|
|
|
(let ((blines (browser/lines (buffer-browser (mark-buffer mark))))
|
|
|
|
|
(group (mark-group mark))
|
|
|
|
|
(index (mark-index mark)))
|
|
|
|
|
(let loop ((low 0) (high (vector-length blines)))
|
|
|
|
|
(and (fix:< low high)
|
|
|
|
|
(let ((middle (fix:quotient (fix:+ low high) 2)))
|
|
|
|
|
(let ((bline (vector-ref blines middle)))
|
|
|
|
|
(let ((ls (mark-index (bline/start-mark bline))))
|
|
|
|
|
(cond ((fix:< index ls) (loop low middle))
|
|
|
|
|
((fix:<= index (line-end-index group ls)) bline)
|
|
|
|
|
(else (loop (fix:+ middle 1) high))))))))))
|
|
|
|
|
|
|
|
|
|
(define (mark->bline-index mark)
|
|
|
|
|
(let ((bline (mark->bline mark)))
|
|
|
|
|
(and bline
|
|
|
|
|
(bline/index bline))))
|
|
|
|
|
|
|
|
|
|
(define (delete-blines browser start end)
|
|
|
|
|
(if (< start end)
|
|
|
|
|
(let ((bv (browser/lines browser)))
|
|
|
|
|
(if (subvector-find-next-element bv start end
|
|
|
|
|
(browser/selected-line browser))
|
|
|
|
|
(unselect-bline browser))
|
|
|
|
|
(let ((nbv (vector-length bv)))
|
|
|
|
|
(let ((bv* (make-vector (- nbv (- end start)))))
|
|
|
|
|
(do ((i 0 (+ i 1)))
|
|
|
|
|
((= i start))
|
|
|
|
|
(vector-set! bv* i (vector-ref bv i)))
|
|
|
|
|
(do ((i end (+ i 1))
|
|
|
|
|
(j start (+ j 1)))
|
|
|
|
|
((= i nbv))
|
|
|
|
|
(let ((bline (vector-ref bv i)))
|
|
|
|
|
(set-bline/index! bline j)
|
|
|
|
|
(vector-set! bv* j bline)))
|
|
|
|
|
(let ((start-mark (bline/start-mark (vector-ref bv start))))
|
|
|
|
|
(with-buffer-open start-mark
|
|
|
|
|
(lambda ()
|
|
|
|
|
(delete-string
|
|
|
|
|
start-mark
|
|
|
|
|
(if (< end nbv)
|
|
|
|
|
(bline/start-mark (vector-ref bv end))
|
|
|
|
|
(buffer-end (browser/buffer browser)))))))
|
|
|
|
|
(set-browser/lines! browser bv*))))))
|
|
|
|
|
|
|
|
|
|
(define (insert-blines browser index blines)
|
|
|
|
|
(if (not (null? blines))
|
|
|
|
|
(let ((bv (browser/lines browser))
|
|
|
|
|
(n-blines (length blines)))
|
|
|
|
|
(let ((nbv (vector-length bv)))
|
|
|
|
|
(let ((bv* (make-vector (+ nbv n-blines))))
|
|
|
|
|
(do ((i 0 (+ i 1)))
|
|
|
|
|
((= i index))
|
|
|
|
|
(vector-set! bv* i (vector-ref bv i)))
|
|
|
|
|
(do ((blines blines (cdr blines))
|
|
|
|
|
(i index (+ i 1)))
|
|
|
|
|
((null? blines))
|
|
|
|
|
(let ((bline (car blines)))
|
|
|
|
|
(set-bline/index! bline i)
|
|
|
|
|
(vector-set! bv* i bline)))
|
|
|
|
|
(do ((i index (+ i 1))
|
|
|
|
|
(j (+ index n-blines) (+ j 1)))
|
|
|
|
|
((= i nbv))
|
|
|
|
|
(let ((bline (vector-ref bv i)))
|
|
|
|
|
(set-bline/index! bline j)
|
|
|
|
|
(vector-set! bv* j bline)))
|
|
|
|
|
(let ((start-mark
|
|
|
|
|
(if (< index nbv)
|
|
|
|
|
(bline/start-mark (vector-ref bv index))
|
|
|
|
|
(buffer-end (browser/buffer browser)))))
|
|
|
|
|
(with-buffer-open start-mark
|
|
|
|
|
(lambda ()
|
|
|
|
|
(let ((mark (mark-left-inserting-copy start-mark))
|
|
|
|
|
(columns 79))
|
|
|
|
|
(for-each
|
|
|
|
|
(lambda (bline)
|
|
|
|
|
(let ((index (mark-index mark))
|
|
|
|
|
(indentation
|
|
|
|
|
(+ 1
|
|
|
|
|
(* summary-indentation-increment
|
|
|
|
|
(bline/depth bline)))))
|
|
|
|
|
(insert-horizontal-space indentation mark)
|
|
|
|
|
(let ((summary
|
|
|
|
|
(call-with-truncated-output-string
|
|
|
|
|
(max summary-minimum-columns
|
|
|
|
|
(- columns indentation 4))
|
|
|
|
|
(lambda (port)
|
|
|
|
|
(parameterize ((current-output-port port))
|
|
|
|
|
((bline-type/write-summary
|
|
|
|
|
(bline/type bline))
|
|
|
|
|
bline
|
|
|
|
|
(current-output-port)))))))
|
|
|
|
|
(insert-string (cdr summary) mark)
|
|
|
|
|
(if (car summary)
|
|
|
|
|
(insert-string " ..." mark)))
|
|
|
|
|
(insert-newline mark)
|
|
|
|
|
(set-bline/start-mark!
|
|
|
|
|
bline
|
|
|
|
|
(make-permanent-mark (mark-group mark) index #t))))
|
|
|
|
|
blines)
|
|
|
|
|
(mark-temporary! mark)))))
|
|
|
|
|
(set-browser/lines! browser bv*))))))
|
|
|
|
|
|
|
|
|
|
(define summary-indentation-increment 3)
|
|
|
|
|
(define summary-minimum-columns 10)
|
|
|
|
|
|
|
|
|
|
;;;; Browser Line Types
|
|
|
|
|
|
|
|
|
|
(define-record-type <browser-line-type>
|
|
|
|
|
(%make-bline-type write-summary write-description selection-mark
|
|
|
|
|
properties)
|
|
|
|
|
bline-type?
|
|
|
|
|
|
|
|
|
|
;; Procedure that is called to generate the browser line that
|
|
|
|
|
;; represents this object. Two arguments: BLINE and PORT. The
|
|
|
|
|
;; summary of BLINE is written to PORT. The summary should fit on
|
|
|
|
|
;; one line; PORT will limit the number of characters that can be
|
|
|
|
|
;; printed so that it fits.
|
|
|
|
|
(write-summary bline-type/write-summary)
|
|
|
|
|
|
|
|
|
|
;; Procedure that is called to generate a full description of the
|
|
|
|
|
;; object. Two arguments: BLINE and PORT. This description may use
|
|
|
|
|
;; multiple lines; it will be presented in its own buffer, so the
|
|
|
|
|
;; presentation style is not very constrained. This component may
|
|
|
|
|
;; be #F to indicate that the object is not normally viewed.
|
|
|
|
|
(write-description bline-type/write-description)
|
|
|
|
|
|
|
|
|
|
;; Procedure that generates the standard mark at which the point
|
|
|
|
|
;; should be placed when this object is selected. One argument:
|
|
|
|
|
;; BLINE. This component may be a nonnegative exact integer meaning
|
|
|
|
|
;; an offset from the START-MARK of the bline.
|
|
|
|
|
(selection-mark bline-type/selection-mark)
|
|
|
|
|
|
|
|
|
|
(properties bline-type/properties))
|
|
|
|
|
|
|
|
|
|
(define (make-bline-type write-summary write-description selection-mark)
|
|
|
|
|
(%make-bline-type write-summary
|
|
|
|
|
write-description
|
|
|
|
|
selection-mark
|
|
|
|
|
(make-1d-table)))
|
|
|
|
|
|
|
|
|
|
(define (make-continuation-bline expander parent prev)
|
|
|
|
|
(make-bline expander bline-type:continuation-line parent prev))
|
|
|
|
|
|
|
|
|
|
(define (continuation-line/write-summary bline port)
|
|
|
|
|
bline
|
|
|
|
|
(write-string "--more--" port))
|
|
|
|
|
|
|
|
|
|
(define bline-type:continuation-line
|
|
|
|
|
(make-bline-type continuation-line/write-summary #f 0))
|
|
|
|
|
|
|
|
|
|
(define (bline/continuation? bline)
|
|
|
|
|
(eq? (bline/type bline) bline-type:continuation-line))
|
|
|
|
|
|
|
|
|
|
(define (replace-continuation-bline bline)
|
|
|
|
|
(let ((browser (bline/browser bline))
|
|
|
|
|
(index (bline/index bline))
|
|
|
|
|
(expansion ((bline/object bline))))
|
|
|
|
|
(delete-blines browser index (+ index 1))
|
|
|
|
|
(insert-blines browser index expansion)
|
|
|
|
|
(car expansion)))
|
|
|
|
|
|
|
|
|
|
;;;; Control Variables
|
|
|
|
|
|
|
|
|
|
(define (boolean-or-ask? object)
|
|
|
|
|
(or (boolean? object)
|
|
|
|
|
(eq? 'ASK object)))
|
|
|
|
|
|
|
|
|
|
(define-variable debugger-one-at-a-time?
|
|
|
|
|
"Allow only one debugger buffer to exist at a given time.
|
|
|
|
|
#T means delete an existing debugger buffer before making a new one.
|
|
|
|
|
#F means leave existing buffers alone.
|
|
|
|
|
'ASK means ask user what to do each time."
|
|
|
|
|
'ASK
|
|
|
|
|
boolean-or-ask?)
|
|
|
|
|
|
|
|
|
|
(define-variable debugger-max-subproblems
|
|
|
|
|
"Maximum number of subproblems displayed when debugger starts.
|
|
|
|
|
Set this variable to #F to disable this limit."
|
|
|
|
|
10
|
|
|
|
|
(lambda (object)
|
|
|
|
|
(or (not object)
|
|
|
|
|
(and (exact-integer? object)
|
|
|
|
|
(> object 0)))))
|
|
|
|
|
|
|
|
|
|
(define-variable debugger-confirm-return?
|
|
|
|
|
"True means prompt for confirmation in \"return\" commands.
|
|
|
|
|
The prompting occurs prior to returning the value."
|
|
|
|
|
#t
|
|
|
|
|
boolean?)
|
|
|
|
|
|
|
|
|
|
(define-variable debugger-quit-on-return?
|
|
|
|
|
"True means quit debugger when executing a \"return\" command.
|
|
|
|
|
Quitting the debugger kills the debugger buffer and any associated buffers."
|
|
|
|
|
#t
|
|
|
|
|
boolean?)
|
|
|
|
|
|
|
|
|
|
(define-variable debugger-quit-on-restart?
|
|
|
|
|
"True means quit debugger when executing a \"restart\" command.
|
|
|
|
|
Quitting the debugger kills the debugger buffer and any associated buffers."
|
|
|
|
|
#t
|
|
|
|
|
boolean?)
|
|
|
|
|
|
|
|
|
|
;;; Limited this because the bindings are now pretty-printed.
|
|
|
|
|
|
|
|
|
|
(define-variable environment-package-limit
|
|
|
|
|
"Packages with more than this number of bindings will be abbreviated.
|
|
|
|
|
Set this variable to #F to disable this abbreviation."
|
|
|
|
|
10
|
|
|
|
|
(lambda (object)
|
|
|
|
|
(or (not object)
|
|
|
|
|
(exact-nonnegative-integer? object))))
|
|
|
|
|
|
|
|
|
|
(define-variable debugger-show-help-message?
|
|
|
|
|
"True means show the help message, false means don't."
|
|
|
|
|
#T
|
|
|
|
|
boolean?)
|
|
|
|
|
|
|
|
|
|
(define-variable debugger-start-new-frame?
|
|
|
|
|
"#T means create a new frame whenever the debugger is invoked.
|
|
|
|
|
#F means continue in same frame.
|
|
|
|
|
'ASK means ask user."
|
|
|
|
|
#T
|
|
|
|
|
boolean-or-ask?)
|
|
|
|
|
(define edwin-variable$debugger-start-new-screen?
|
|
|
|
|
edwin-variable$debugger-start-new-frame?)
|
|
|
|
|
|
|
|
|
|
(define-variable debugger-hide-system-code?
|
|
|
|
|
"True means don't show subproblems created by the runtime system."
|
|
|
|
|
#T
|
|
|
|
|
boolean?)
|
|
|
|
|
|
|
|
|
|
(define-variable debugger-show-frames?
|
|
|
|
|
"If true show the environment frames in the description buffer.
|
|
|
|
|
If false show the bindings without frames."
|
|
|
|
|
#T
|
|
|
|
|
boolean?)
|
|
|
|
|
|
|
|
|
|
(define-variable debugger-show-inner-frame-topmost?
|
|
|
|
|
"Affects the debugger display when DEBUGGER-SHOW-FRAMES? is true.
|
|
|
|
|
If false, frames are displayed with the outer (most global) frame topmost,
|
|
|
|
|
like in a 6.001 style environment diagram. This is the default.
|
|
|
|
|
If true, frames are display innermost first."
|
|
|
|
|
#F
|
|
|
|
|
boolean?)
|
|
|
|
|
|
|
|
|
|
(define-variable debugger-compact-display?
|
|
|
|
|
"If true, the debugger omits some blank lines.
|
|
|
|
|
If false, more blank lines are produced between display elements.
|
|
|
|
|
This variable is usually set to #F, but setting it to #T is useful
|
|
|
|
|
to get more information in a short window, for example, when using
|
|
|
|
|
a fixed size terminal."
|
|
|
|
|
#F
|
|
|
|
|
boolean?)
|
|
|
|
|
|
|
|
|
|
;;; These bindings are included only because they are exported by the
|
|
|
|
|
;;; alternate debugger, artdebug, which also lives in this package.
|
|
|
|
|
;;; They appear to CREF to be needed yet not bound.
|
|
|
|
|
|
|
|
|
|
(define edwin-variable$debugger-expand-reductions?)
|
|
|
|
|
(define edwin-variable$debugger-open-markers?)
|
|
|
|
|
(define edwin-variable$debugger-split-window?)
|
|
|
|
|
(define edwin-variable$debugger-verbose-mode?)
|
|
|
|
|
|
|
|
|
|
;;;; Predicates
|
|
|
|
|
|
|
|
|
|
;;; Determines if a frame is marked.
|
|
|
|
|
|
|
|
|
|
(define (system-frame? stack-frame)
|
|
|
|
|
(stack-frame/repl-eval-boundary? stack-frame))
|
|
|
|
|
|
|
|
|
|
;;; Bad implementation to determine for breaks if a value to proceed
|
|
|
|
|
;;; with is desired.
|
|
|
|
|
|
|
|
|
|
(define value? #f)
|
|
|
|
|
|
|
|
|
|
(define (invalid-subexpression? subexpression)
|
|
|
|
|
(or (debugging-info/undefined-expression? subexpression)
|
|
|
|
|
(debugging-info/unknown-expression? subexpression)))
|
|
|
|
|
|
|
|
|
|
(define (invalid-expression? expression)
|
|
|
|
|
(or (debugging-info/undefined-expression? expression)
|
|
|
|
|
(debugging-info/compiled-code? expression)))
|
|
|
|
|
|
|
|
|
|
;;;; Help Messages
|
|
|
|
|
|
|
|
|
|
;;; The help messages for the debugger
|
|
|
|
|
|
|
|
|
|
(define where-help-message
|
|
|
|
|
" COMMANDS: ? - Help q - Quit environment browser
|
|
|
|
|
|
|
|
|
|
This is an environment-browser buffer.
|
|
|
|
|
|
|
|
|
|
Lines identify environment frames.
|
|
|
|
|
The buffer below shows the bindings of the selected environment.
|
|
|
|
|
-----------")
|
|
|
|
|
|
|
|
|
|
(define debugger-help-message
|
|
|
|
|
" COMMANDS: ? - Help q - Quit debugger e - Environment browser
|
|
|
|
|
|
|
|
|
|
This is a debugger buffer.
|
|
|
|
|
|
|
|
|
|
Lines identify stack frames, most recent first.
|
|
|
|
|
|
|
|
|
|
Sx means frame is in subproblem number x.
|
|
|
|
|
Ry means frame is reduction number y.
|
|
|
|
|
|
|
|
|
|
The buffer below shows the current subproblem or reduction.
|
|
|
|
|
-----------")
|
|
|
|
|
|
|
|
|
|
;;;; Debugger entry point
|
|
|
|
|
|
|
|
|
|
(define starting-debugger? #f)
|
|
|
|
|
|
|
|
|
|
(define (debug-scheme-error error-type condition ask?)
|
|
|
|
|
(if starting-debugger?
|
|
|
|
|
(quit-editor-and-signal-error condition)
|
|
|
|
|
(begin
|
|
|
|
|
(let ((start-debugger
|
|
|
|
|
(lambda ()
|
|
|
|
|
(fluid-let ((starting-debugger? #t))
|
|
|
|
|
(select-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 (select-continuation-browser-buffer object #!optional thread)
|
|
|
|
|
(set! value? #f)
|
|
|
|
|
(let ((buffers (find-debugger-buffers)))
|
|
|
|
|
(if (and (pair? buffers)
|
|
|
|
|
(null? (cdr buffers))
|
|
|
|
|
(if (eq? 'ASK (ref-variable debugger-one-at-a-time? #f))
|
|
|
|
|
(prompt-for-confirmation?
|
|
|
|
|
"Another debugger buffer exists. Delete it")
|
|
|
|
|
(ref-variable debugger-one-at-a-time? #f)))
|
|
|
|
|
(kill-buffer (car buffers))))
|
|
|
|
|
(let ((buffer (continuation-browser-buffer object)))
|
|
|
|
|
(let ((thread (and (not (default-object? thread)) thread)))
|
|
|
|
|
(if thread
|
|
|
|
|
(buffer-put! buffer 'THREAD thread)))
|
|
|
|
|
(let ((screen (make-debug-screen buffer)))
|
|
|
|
|
(if screen
|
|
|
|
|
(select-screen screen)
|
|
|
|
|
(select-buffer buffer)))
|
|
|
|
|
((ref-command browser-select-line) (buffer-point buffer))))
|
|
|
|
|
|
|
|
|
|
(define-command browse-continuation
|
|
|
|
|
"Invoke the continuation-browser on CONTINUATION."
|
|
|
|
|
"XBrowse Continuation"
|
|
|
|
|
select-continuation-browser-buffer)
|
|
|
|
|
|
|
|
|
|
(define (make-debug-screen buffer)
|
|
|
|
|
(and (multiple-screens?)
|
|
|
|
|
(let ((new-screen? (ref-variable debugger-start-new-screen? buffer)))
|
|
|
|
|
(if (eq? new-screen? 'ASK)
|
|
|
|
|
(prompt-for-confirmation? "Start debugger in new screen")
|
|
|
|
|
new-screen?))
|
|
|
|
|
(let ((screen (apply make-screen buffer (make-debug-screen-args))))
|
|
|
|
|
(set-browser/new-screen! (buffer-browser buffer) screen)
|
|
|
|
|
screen)))
|
|
|
|
|
|
|
|
|
|
(define (make-debug-screen-args)
|
|
|
|
|
(case (display-type/name (current-display-type))
|
|
|
|
|
((X)
|
|
|
|
|
(cond ((string? default-screen-geometry)
|
|
|
|
|
(list default-screen-geometry))
|
|
|
|
|
((eq? default-screen-geometry 'ASK)
|
|
|
|
|
(let ((geometry
|
|
|
|
|
(let loop ((default default-screen-geometry))
|
|
|
|
|
(let ((geometry
|
|
|
|
|
(prompt-for-string "Please enter a geometry"
|
|
|
|
|
default)))
|
|
|
|
|
(if (geometry? geometry)
|
|
|
|
|
geometry
|
|
|
|
|
(loop geometry))))))
|
|
|
|
|
(set! default-screen-geometry geometry)
|
|
|
|
|
geometry))
|
|
|
|
|
(else '())))
|
|
|
|
|
(else '())))
|
|
|
|
|
|
|
|
|
|
(define (geometry? geometry)
|
|
|
|
|
(let ((geometry-pattern
|
|
|
|
|
"[0-9]+x[0-9]+\\(-[0-9]+\\|+[0-9]+\\|\\)\\(-[0-9]+\\|+[0-9]+\\|\\)"))
|
|
|
|
|
(re-string-match (re-compile-pattern geometry-pattern #f) geometry)))
|
|
|
|
|
|
|
|
|
|
(define default-screen-geometry #f)
|
|
|
|
|
|
|
|
|
|
(define (continuation-browser-buffer object)
|
|
|
|
|
(let ((browser
|
|
|
|
|
(make-browser "*debug*"
|
|
|
|
|
(ref-mode-object continuation-browser)
|
|
|
|
|
object))
|
|
|
|
|
(blines
|
|
|
|
|
(continuation->blines
|
|
|
|
|
(cond ((continuation? object)
|
|
|
|
|
object)
|
|
|
|
|
((condition? object)
|
|
|
|
|
(condition/continuation object))
|
|
|
|
|
(else
|
|
|
|
|
(error:wrong-type-argument object
|
|
|
|
|
"condition or continuation"
|
|
|
|
|
'CONTINUATION-BROWSER-BUFFER)))
|
|
|
|
|
(ref-variable debugger-max-subproblems))))
|
|
|
|
|
(let ((buffer (browser/buffer browser)))
|
|
|
|
|
(let ((mark (buffer-end buffer)))
|
|
|
|
|
(with-buffer-open mark
|
|
|
|
|
(lambda ()
|
|
|
|
|
(call-with-output-mark mark
|
|
|
|
|
(lambda (port)
|
|
|
|
|
(if (ref-variable debugger-show-help-message?)
|
|
|
|
|
(write-string debugger-help-message port))
|
|
|
|
|
(debugger-newline port)
|
|
|
|
|
(if (condition? object)
|
|
|
|
|
(begin
|
|
|
|
|
(write-string "The " port)
|
|
|
|
|
(write-string (if (condition/error? object)
|
|
|
|
|
"error"
|
|
|
|
|
"condition")
|
|
|
|
|
port)
|
|
|
|
|
(write-string " that started the debugger is:" port)
|
|
|
|
|
(debugger-newline port)
|
|
|
|
|
(debugger-newline port)
|
|
|
|
|
(write-string " " port)
|
|
|
|
|
(with-output-highlighted port
|
|
|
|
|
(lambda ()
|
|
|
|
|
(write-condition-report object port)))
|
|
|
|
|
(debugger-newline port)))
|
|
|
|
|
(debugger-newline port))))))
|
|
|
|
|
(insert-blines browser 0 blines)
|
|
|
|
|
(set-buffer-point! buffer
|
|
|
|
|
(if (null? blines)
|
|
|
|
|
(buffer-end buffer)
|
|
|
|
|
(bline/start-mark (car blines))))
|
|
|
|
|
buffer)))
|
|
|
|
|
|
|
|
|
|
(define (find-debugger-buffers)
|
|
|
|
|
(filter (let ((debugger-mode (ref-mode-object continuation-browser)))
|
|
|
|
|
(lambda (buffer)
|
|
|
|
|
(eq? (buffer-major-mode buffer) debugger-mode)))
|
|
|
|
|
(buffer-list)))
|
|
|
|
|
|
|
|
|
|
;;;; Continuation Browser Mode
|
|
|
|
|
|
|
|
|
|
(define-major-mode continuation-browser read-only "Debug"
|
|
|
|
|
" ******* Debugger Help *******
|
|
|
|
|
|
|
|
|
|
Commands:
|
|
|
|
|
|
|
|
|
|
`mouse-button-1'
|
|
|
|
|
Select a subproblem or reduction and display information in the
|
|
|
|
|
description buffer.
|
|
|
|
|
|
|
|
|
|
`C-n'
|
|
|
|
|
`down-arrow'
|
|
|
|
|
Move the cursor down the list of subproblems and reductions and
|
|
|
|
|
display info in the description buffer.
|
|
|
|
|
|
|
|
|
|
`C-p'
|
|
|
|
|
`up-arrow'
|
|
|
|
|
Move the cursor up the list of subproblems and reductions and
|
|
|
|
|
display info in the description buffer.
|
|
|
|
|
|
|
|
|
|
`e' Show the environment structure.
|
|
|
|
|
|
|
|
|
|
`q' Quit the debugger, destroying its window.
|
|
|
|
|
|
|
|
|
|
`p' Invoke the standard restarts.
|
|
|
|
|
|
|
|
|
|
`SPC'
|
|
|
|
|
Display info on current item in the description buffer.
|
|
|
|
|
|
|
|
|
|
`?' Display help information.
|
|
|
|
|
|
|
|
|
|
Each line beginning with `S' represents either a subproblem or stack
|
|
|
|
|
frame. A subproblem line may be followed by one or more indented lines
|
|
|
|
|
\(beginning with the letter `R') which represent reductions associated
|
|
|
|
|
with that subproblem. The subproblems are indexed with the natural
|
|
|
|
|
numbers. To obtain a more complete description of a subproblem or
|
|
|
|
|
reduction, click the mouse on the desired line or move the cursor to the
|
|
|
|
|
line using the arrow keys (or `C-n' and `C-p'). The description buffer
|
|
|
|
|
will display the additional information.
|
|
|
|
|
|
|
|
|
|
The description buffer contains three major regions. The first
|
|
|
|
|
region contains a pretty printed version of the current expression. The
|
|
|
|
|
current subproblem within the expression is highlighted. The second
|
|
|
|
|
region contains a representation of the frames of the environment of the
|
|
|
|
|
current expression. The bindings of each frame are listed below the
|
|
|
|
|
frame header. If there are no bindings in the frame, none will be
|
|
|
|
|
listed. The frame of the current expression is preceeded with ==>.
|
|
|
|
|
|
|
|
|
|
The bottom of the description buffer contains a region for evaluating
|
|
|
|
|
expressions in the environment of the selected subproblem or reduction.
|
|
|
|
|
This is the only portion of the buffer where editing is possible. This
|
|
|
|
|
region can be used to find the values of variables in different
|
|
|
|
|
environments; you cannot, however, use mutators (set!, etc.) on compiled
|
|
|
|
|
code.
|
|
|
|
|
|
|
|
|
|
Typing `e' creates a new buffer in which you may browse through the
|
|
|
|
|
current environment. In this new buffer, you can use the mouse, the
|
|
|
|
|
arrows, or `C-n' and `C-p' to select lines and view different
|
|
|
|
|
environments. The environments listed are the same as those in the
|
|
|
|
|
description buffer. If the selected environment structure is too large
|
|
|
|
|
to display (if there are more than `environment-package-limit' items in
|
|
|
|
|
the environment) an appropriate message is displayed. To display the
|
|
|
|
|
environment in this case, set the `environment-package-limit' variable
|
|
|
|
|
to `#f'. This process is initiated by the command `M-x set-variable'.
|
|
|
|
|
You can not use `set!' to set the variable because it is an editor
|
|
|
|
|
variable and does not exist in the current scheme environment. At the
|
|
|
|
|
bottom of the new buffer is a region for evaluating expressions similar
|
|
|
|
|
to that of the description buffer.
|
|
|
|
|
|
|
|
|
|
The appearance of environment displays is controlled by the editor
|
|
|
|
|
variables `debugger-show-inner-frame-topmost?' and `debugger-compact-display?'
|
|
|
|
|
which affect the ordering of environment frames and the line spacing
|
|
|
|
|
respectively.
|
|
|
|
|
|
|
|
|
|
Type `q' to quit the debugger, killing its primary buffer and any
|
|
|
|
|
others that it has created.
|
|
|
|
|
|
|
|
|
|
NOTE: The debugger creates discription buffers in which debugging
|
|
|
|
|
information is presented. These buffers are given names beginning with
|
|
|
|
|
spaces so that they do not appear in the buffer list; they are
|
|
|
|
|
automatically deleted when you quit the debugger. If you wish to keep
|
|
|
|
|
one of these buffers, simply rename it using `M-x rename-buffer': once
|
|
|
|
|
it has been renamed, it will not be deleted automatically.")
|
|
|
|
|
|
|
|
|
|
(define-key 'continuation-browser #\p 'quit-with-restart-value)
|
|
|
|
|
(define-key 'continuation-browser down 'browser-next-line)
|
|
|
|
|
(define-key 'continuation-browser up 'browser-previous-line)
|
|
|
|
|
(define-key 'continuation-browser button1-down 'debugger-mouse-select-bline)
|
|
|
|
|
(define-key 'continuation-browser #\c-n 'browser-next-line)
|
|
|
|
|
(define-key 'continuation-browser #\c-p 'browser-previous-line)
|
|
|
|
|
(define-key 'continuation-browser #\? 'describe-mode)
|
|
|
|
|
(define-key 'continuation-browser #\q 'browser-quit)
|
|
|
|
|
(define-key 'continuation-browser #\space 'browser-select-line)
|
|
|
|
|
(define-key 'continuation-browser #\e 'browser-where)
|
|
|
|
|
|
|
|
|
|
;;;; Subproblems
|
|
|
|
|
|
|
|
|
|
;; A continuation consists of subproblems. A subproblem has
|
|
|
|
|
;; expression information that identifies what the subproblem means.
|
|
|
|
|
;; It additionally has reductions and an environment. Similarly,
|
|
|
|
|
;; reductions have expression and environment information.
|
|
|
|
|
;; Environments consist of environment frames, and each frame consists
|
|
|
|
|
;; of bindings. Subproblems, reductions, and environment frames are
|
|
|
|
|
;; ordered; bindings are not.
|
|
|
|
|
|
|
|
|
|
;;; Stops displaying subproblems past marked frame by default.
|
|
|
|
|
|
|
|
|
|
(define (continuation->blines continuation limit)
|
|
|
|
|
(let ((beyond-system-code #f))
|
|
|
|
|
(let loop ((frame (continuation/first-subproblem continuation))
|
|
|
|
|
(prev #f)
|
|
|
|
|
(n 0))
|
|
|
|
|
(if (not frame)
|
|
|
|
|
'()
|
|
|
|
|
(let* ((next-subproblem
|
|
|
|
|
(lambda (bline)
|
|
|
|
|
(loop (stack-frame/next-subproblem frame)
|
|
|
|
|
bline
|
|
|
|
|
(+ n 1))))
|
|
|
|
|
(walk-reductions
|
|
|
|
|
(lambda (bline reductions)
|
|
|
|
|
(cons bline
|
|
|
|
|
(let loop ((reductions reductions) (prev #f))
|
|
|
|
|
(if (null? reductions)
|
|
|
|
|
(next-subproblem bline)
|
|
|
|
|
(let ((bline
|
|
|
|
|
(make-bline (car reductions)
|
|
|
|
|
bline-type:reduction
|
|
|
|
|
bline
|
|
|
|
|
prev)))
|
|
|
|
|
(cons bline
|
|
|
|
|
(loop (cdr reductions) bline))))))))
|
|
|
|
|
(continue
|
|
|
|
|
(lambda ()
|
|
|
|
|
(let* ((subproblem (stack-frame->subproblem frame n)))
|
|
|
|
|
(if debugger:student-walk?
|
|
|
|
|
(let ((reductions
|
|
|
|
|
(subproblem/reductions subproblem)))
|
|
|
|
|
(if (null? reductions)
|
|
|
|
|
(let ((bline
|
|
|
|
|
(make-bline subproblem
|
|
|
|
|
bline-type:subproblem
|
|
|
|
|
#f
|
|
|
|
|
prev)))
|
|
|
|
|
(cons bline
|
|
|
|
|
(next-subproblem bline)))
|
|
|
|
|
(let ((bline
|
|
|
|
|
(make-bline (car reductions)
|
|
|
|
|
bline-type:reduction
|
|
|
|
|
#f
|
|
|
|
|
prev)))
|
|
|
|
|
(walk-reductions bline
|
|
|
|
|
(if (> n 0)
|
|
|
|
|
'()
|
|
|
|
|
(cdr reductions))))))
|
|
|
|
|
(walk-reductions
|
|
|
|
|
(make-bline subproblem
|
|
|
|
|
bline-type:subproblem
|
|
|
|
|
#f
|
|
|
|
|
prev)
|
|
|
|
|
(subproblem/reductions subproblem)))))))
|
|
|
|
|
(cond ((and (not (ref-variable debugger-hide-system-code?))
|
|
|
|
|
(system-frame? frame))
|
|
|
|
|
(loop (stack-frame/next-subproblem frame)
|
|
|
|
|
prev
|
|
|
|
|
n))
|
|
|
|
|
((or (and limit (>= n limit))
|
|
|
|
|
(if (system-frame? frame)
|
|
|
|
|
(begin (set! beyond-system-code #t) #t)
|
|
|
|
|
#f)
|
|
|
|
|
beyond-system-code)
|
|
|
|
|
(list (make-continuation-bline continue #f prev)))
|
|
|
|
|
(else (continue))))))))
|
|
|
|
|
|
|
|
|
|
(define-record-type <subproblem>
|
|
|
|
|
(make-subproblem stack-frame expression environment subexpression number)
|
|
|
|
|
subproblem?
|
|
|
|
|
(stack-frame subproblem/stack-frame)
|
|
|
|
|
(expression subproblem/expression)
|
|
|
|
|
(environment subproblem/environment)
|
|
|
|
|
(subexpression subproblem/subexpression)
|
|
|
|
|
(number subproblem/number))
|
|
|
|
|
|
|
|
|
|
(define (stack-frame->subproblem frame number)
|
|
|
|
|
(receive (expression environment subexpression)
|
|
|
|
|
(stack-frame/debugging-info frame)
|
|
|
|
|
(make-subproblem frame expression environment subexpression number)))
|
|
|
|
|
|
|
|
|
|
(define-record-type <reduction>
|
|
|
|
|
(make-reduction subproblem expression environment number)
|
|
|
|
|
reduction?
|
|
|
|
|
(subproblem reduction/subproblem)
|
|
|
|
|
(expression reduction/expression)
|
|
|
|
|
(environment reduction/environment)
|
|
|
|
|
(number reduction/number))
|
|
|
|
|
|
|
|
|
|
(define (subproblem/reductions subproblem)
|
|
|
|
|
(let ((frame (subproblem/stack-frame subproblem)))
|
|
|
|
|
(let loop ((reductions (stack-frame/reductions frame)) (n 0))
|
|
|
|
|
(if (pair? reductions)
|
|
|
|
|
(cons (make-reduction subproblem
|
|
|
|
|
(caar reductions)
|
|
|
|
|
(cadar reductions)
|
|
|
|
|
n)
|
|
|
|
|
(loop (cdr reductions) (+ n 1)))
|
|
|
|
|
'()))))
|
|
|
|
|
|
|
|
|
|
(define (subproblem/write-summary bline port)
|
|
|
|
|
(let* ((subproblem (bline/object bline))
|
|
|
|
|
(frame (subproblem/stack-frame subproblem)))
|
|
|
|
|
(if (system-frame? frame)
|
|
|
|
|
(write-string "***************Internal System Code Follows***********"
|
|
|
|
|
port)
|
|
|
|
|
(begin
|
|
|
|
|
(write-string "S" port)
|
|
|
|
|
(write-string (bline/offset-string (subproblem/number subproblem))
|
|
|
|
|
port)
|
|
|
|
|
(write-string " " port)
|
|
|
|
|
(let ((expression (subproblem/expression subproblem))
|
|
|
|
|
(subexpression (subproblem/subexpression subproblem)))
|
|
|
|
|
(cond ((debugging-info/compiled-code? expression)
|
|
|
|
|
(write-string ";unknown compiled code" port))
|
|
|
|
|
((not (debugging-info/undefined-expression? expression))
|
|
|
|
|
(parameterize ((param:print-primitives-by-name? #t))
|
|
|
|
|
(write
|
|
|
|
|
(unsyntax (if (invalid-subexpression? subexpression)
|
|
|
|
|
expression
|
|
|
|
|
subexpression)))))
|
|
|
|
|
((debugging-info/noise? expression)
|
|
|
|
|
(write-string ";" port)
|
|
|
|
|
(write-string ((debugging-info/noise expression) #f)
|
|
|
|
|
port))
|
|
|
|
|
(else
|
|
|
|
|
(write-string ";undefined expression" port))))))))
|
|
|
|
|
|
|
|
|
|
(define (subproblem/write-description bline port)
|
|
|
|
|
(let* ((subproblem (bline/object bline))
|
|
|
|
|
(frame (subproblem/stack-frame subproblem)))
|
|
|
|
|
(cond ((system-frame? frame)
|
|
|
|
|
(write-string "The subproblems which follow are part of the " port)
|
|
|
|
|
|
|
|
|
|
(write-string "internal system workings." port))
|
|
|
|
|
(else
|
|
|
|
|
(write-string " SUBPROBLEM LEVEL: " port)
|
|
|
|
|
(write (subproblem/number subproblem) port)
|
|
|
|
|
(debugger-newline port)
|
|
|
|
|
(debugger-newline port)
|
|
|
|
|
(let ((expression (subproblem/expression subproblem))
|
|
|
|
|
(frame (subproblem/stack-frame subproblem)))
|
|
|
|
|
(cond ((not (invalid-expression? expression))
|
|
|
|
|
(write-string (if (stack-frame/compiled-code? frame)
|
|
|
|
|
"COMPILED expression"
|
|
|
|
|
"Expression")
|
|
|
|
|
port)
|
|
|
|
|
(write-string " (from stack):" port)
|
|
|
|
|
(debugger-newline port)
|
|
|
|
|
(write-string
|
|
|
|
|
" Subproblem being executed is highlighted.\n"
|
|
|
|
|
port)
|
|
|
|
|
(debugger-newline port)
|
|
|
|
|
(let ((subexpression
|
|
|
|
|
(subproblem/subexpression subproblem)))
|
|
|
|
|
(if (invalid-subexpression? subexpression)
|
|
|
|
|
(debugger-pp expression expression-indentation port)
|
|
|
|
|
(debugger-pp-highlight-subexpression
|
|
|
|
|
expression
|
|
|
|
|
subexpression
|
|
|
|
|
expression-indentation
|
|
|
|
|
port))))
|
|
|
|
|
((debugging-info/noise? expression)
|
|
|
|
|
(write-string ((debugging-info/noise expression) #t)
|
|
|
|
|
port))
|
|
|
|
|
(else
|
|
|
|
|
(write-string (if (stack-frame/compiled-code? frame)
|
|
|
|
|
"Compiled expression unknown"
|
|
|
|
|
"Expression unknown")
|
|
|
|
|
port)
|
|
|
|
|
(debugger-newline port)
|
|
|
|
|
(write (stack-frame/return-address frame) port))))
|
|
|
|
|
(let ((environment (subproblem/environment subproblem)))
|
|
|
|
|
(if (not (debugging-info/undefined-environment? environment))
|
|
|
|
|
(begin
|
|
|
|
|
(debugger-newline port)
|
|
|
|
|
(debugger-newline port)
|
|
|
|
|
(desc-show-environment-name-and-bindings environment
|
|
|
|
|
port))))))))
|
|
|
|
|
|
|
|
|
|
(define bline-type:subproblem
|
|
|
|
|
(make-bline-type subproblem/write-summary
|
|
|
|
|
subproblem/write-description
|
|
|
|
|
1))
|
|
|
|
|
|
|
|
|
|
(1d-table/put! (bline-type/properties bline-type:subproblem)
|
|
|
|
|
'GET-ENVIRONMENT
|
|
|
|
|
(lambda (bline)
|
|
|
|
|
(subproblem/environment (bline/object bline))))
|
|
|
|
|
|
|
|
|
|
;;;; Reductions
|
|
|
|
|
|
|
|
|
|
(define (reduction/write-summary bline port)
|
|
|
|
|
(let ((reduction (bline/object bline)))
|
|
|
|
|
(if (bline/parent bline)
|
|
|
|
|
(begin
|
|
|
|
|
(write-string "R" port)
|
|
|
|
|
(write-string (bline/offset-string (reduction/number reduction))
|
|
|
|
|
port))
|
|
|
|
|
(begin
|
|
|
|
|
(write-string "S" port)
|
|
|
|
|
(write-string
|
|
|
|
|
(bline/offset-string
|
|
|
|
|
(subproblem/number (reduction/subproblem reduction)))
|
|
|
|
|
port)))
|
|
|
|
|
(write-string " " port)
|
|
|
|
|
(parameterize ((param:print-primitives-by-name? #t))
|
|
|
|
|
(write (unsyntax (reduction/expression reduction)) port))))
|
|
|
|
|
|
|
|
|
|
(define (reduction/write-description bline port)
|
|
|
|
|
(let ((reduction (bline/object bline)))
|
|
|
|
|
(write-string " SUBPROBLEM LEVEL: " port)
|
|
|
|
|
(write (subproblem/number (reduction/subproblem reduction)) port)
|
|
|
|
|
(write-string " REDUCTION NUMBER: " port)
|
|
|
|
|
(write (reduction/number reduction) port)
|
|
|
|
|
(debugger-newline port)
|
|
|
|
|
(debugger-newline port)
|
|
|
|
|
(write-string "Expression (from execution history):" port)
|
|
|
|
|
(debugger-newline port)
|
|
|
|
|
(debugger-newline port)
|
|
|
|
|
(debugger-pp (reduction/expression reduction) expression-indentation port)
|
|
|
|
|
(debugger-newline port)
|
|
|
|
|
(debugger-newline port)
|
|
|
|
|
(desc-show-environment-name-and-bindings (reduction/environment reduction)
|
|
|
|
|
port)))
|
|
|
|
|
|
|
|
|
|
(define bline-type:reduction
|
|
|
|
|
(make-bline-type reduction/write-summary
|
|
|
|
|
reduction/write-description
|
|
|
|
|
1))
|
|
|
|
|
|
|
|
|
|
(1d-table/put! (bline-type/properties bline-type:reduction)
|
|
|
|
|
'GET-ENVIRONMENT
|
|
|
|
|
(lambda (bline)
|
|
|
|
|
(reduction/environment (bline/object bline))))
|
|
|
|
|
|
|
|
|
|
;;;; Environments
|
|
|
|
|
|
|
|
|
|
(define-command browse-environment
|
|
|
|
|
"Invoke the environment-browser on ENVIRONMENT."
|
|
|
|
|
"XBrowse Environment"
|
|
|
|
|
(lambda (environment)
|
|
|
|
|
(select-buffer (environment-browser-buffer environment))))
|
|
|
|
|
|
|
|
|
|
;;; Adds a help line.
|
|
|
|
|
|
|
|
|
|
(define (environment-browser-buffer object)
|
|
|
|
|
(let ((environment (->environment object)))
|
|
|
|
|
(let ((browser
|
|
|
|
|
(make-browser "*where*"
|
|
|
|
|
(ref-mode-object environment-browser)
|
|
|
|
|
object))
|
|
|
|
|
(blines (environment->blines environment)))
|
|
|
|
|
|
|
|
|
|
(let ((buffer (browser/buffer browser)))
|
|
|
|
|
(let ((mark (buffer-end buffer)))
|
|
|
|
|
(with-buffer-open mark
|
|
|
|
|
(lambda ()
|
|
|
|
|
(call-with-output-mark
|
|
|
|
|
mark
|
|
|
|
|
(lambda (port)
|
|
|
|
|
(if (ref-variable debugger-show-help-message?)
|
|
|
|
|
(write-string where-help-message port))
|
|
|
|
|
(debugger-newline port))))))
|
|
|
|
|
(insert-blines browser 0 blines)
|
|
|
|
|
(if (null? blines)
|
|
|
|
|
(set-buffer-point! buffer (buffer-end buffer))
|
|
|
|
|
(select-bline (car blines)))
|
|
|
|
|
buffer))))
|
|
|
|
|
|
|
|
|
|
(define (environment->blines environment)
|
|
|
|
|
(let loop ((environment environment) (prev #f))
|
|
|
|
|
(let ((bline (make-bline environment bline-type:environment #f prev)))
|
|
|
|
|
(cons bline
|
|
|
|
|
(if (eq? #t (environment-has-parent? environment))
|
|
|
|
|
(loop (environment-parent environment) bline)
|
|
|
|
|
'())))))
|
|
|
|
|
|
|
|
|
|
(define-major-mode environment-browser read-only "Environment Browser"
|
|
|
|
|
" ********Environment Browser Help********
|
|
|
|
|
|
|
|
|
|
Commands:
|
|
|
|
|
|
|
|
|
|
`mouse-button-1'
|
|
|
|
|
Select a subproblem or reduction and display information in the
|
|
|
|
|
description buffer.
|
|
|
|
|
|
|
|
|
|
`C-n'
|
|
|
|
|
`down-arrow'
|
|
|
|
|
Move the cursor down the list of subproblems and reductions and
|
|
|
|
|
display info in the description buffer.
|
|
|
|
|
|
|
|
|
|
`C-p'
|
|
|
|
|
`up-arrow'
|
|
|
|
|
Move the cursor up the list of subproblems and reductions and
|
|
|
|
|
display info in the description buffer.
|
|
|
|
|
|
|
|
|
|
`q'
|
|
|
|
|
Quit the environment browser, destroying its window.
|
|
|
|
|
|
|
|
|
|
`SPC'
|
|
|
|
|
Display info on current item in the description buffer.
|
|
|
|
|
|
|
|
|
|
`?'
|
|
|
|
|
Display help information.
|
|
|
|
|
|
|
|
|
|
In this buffer, you can use the mouse, the arrows, or `C-n' and
|
|
|
|
|
`C-p' to select lines and view different environments.
|
|
|
|
|
If the selected environment structure is too large to display (if
|
|
|
|
|
there are more than `environment-package-limit' items in the
|
|
|
|
|
environment) an appropriate message is displayed. To display the
|
|
|
|
|
environment in this case, set the `environment-package-limit' variable
|
|
|
|
|
to `#f'. This process is initiated by the command `M-x
|
|
|
|
|
set-variable'. You can not use `set!' to set the variable because it
|
|
|
|
|
is an editor variable and does not exist in the current scheme
|
|
|
|
|
environment.
|
|
|
|
|
|
|
|
|
|
The bottom of the description buffer contains a region for evaluating
|
|
|
|
|
expressions in the environment of the selected subproblem or reduction.
|
|
|
|
|
This is the only portion of the buffer where editing is possible. This
|
|
|
|
|
region can be used to find the values of variables in different
|
|
|
|
|
environments; you cannot, however, use mutators (set!, etc.) on
|
|
|
|
|
compiled code.
|
|
|
|
|
|
|
|
|
|
Type `q' to quit the environment browser, killing its primary buffer
|
|
|
|
|
and any others that it has created.
|
|
|
|
|
|
|
|
|
|
NOTE: The environment browser creates discription buffers in which
|
|
|
|
|
debugging information is presented. These buffers are given names
|
|
|
|
|
beginning with spaces so that they do not appear in the buffer list;
|
|
|
|
|
they are automatically deleted when you quit the debugger. If you wish
|
|
|
|
|
to keep one of these buffers, simply rename it using `M-x rename-buffer':
|
|
|
|
|
once it has been renamed, it will not be deleted automatically.")
|
|
|
|
|
|
|
|
|
|
(define-key 'environment-browser down 'browser-next-line)
|
|
|
|
|
(define-key 'environment-browser up 'browser-previous-line)
|
|
|
|
|
(define-key 'environment-browser button1-down 'debugger-mouse-select-bline)
|
|
|
|
|
(define-key 'environment-browser #\c-n 'browser-next-line)
|
|
|
|
|
(define-key 'environment-browser #\c-p 'browser-previous-line)
|
|
|
|
|
(define-key 'environment-browser #\? 'describe-mode)
|
|
|
|
|
(define-key 'environment-browser #\q 'browser-quit)
|
|
|
|
|
(define-key 'environment-browser #\space 'browser-select-line)
|
|
|
|
|
|
|
|
|
|
(define (environment/write-summary bline port)
|
|
|
|
|
(write-string "E" port)
|
|
|
|
|
(write-string (bline/offset-string (bline/offset bline)) port)
|
|
|
|
|
(write-string " " port)
|
|
|
|
|
(show-environment-name (bline/object bline) port))
|
|
|
|
|
|
|
|
|
|
(define (environment/write-description bline port)
|
|
|
|
|
(let ((environment (bline/object bline)))
|
|
|
|
|
(show-environment-name-and-bindings environment port)))
|
|
|
|
|
|
|
|
|
|
(define (show-environment-name-and-bindings environment port)
|
|
|
|
|
(show-environment-name environment port)
|
|
|
|
|
(debugger-newline port)
|
|
|
|
|
(debugger-newline port)
|
|
|
|
|
(let ((names (environment-bound-names environment))
|
|
|
|
|
(package (environment->package environment))
|
|
|
|
|
(finish
|
|
|
|
|
(lambda (names)
|
|
|
|
|
(debugger-newline port)
|
|
|
|
|
(for-each (lambda (name)
|
|
|
|
|
(myprint-binding name
|
|
|
|
|
(environment-safe-lookup environment
|
|
|
|
|
name)
|
|
|
|
|
port))
|
|
|
|
|
names))))
|
|
|
|
|
(cond ((null? names)
|
|
|
|
|
(write-string " has no bindings" port))
|
|
|
|
|
((and package
|
|
|
|
|
(let ((limit (ref-variable environment-package-limit)))
|
|
|
|
|
(and limit
|
|
|
|
|
(let ((n (length names)))
|
|
|
|
|
(and (>= n limit)
|
|
|
|
|
(begin
|
|
|
|
|
(write-string " has " port)
|
|
|
|
|
(write n port)
|
|
|
|
|
(write-string " bindings (first " port)
|
|
|
|
|
(write limit port)
|
|
|
|
|
(write-string " shown):" port)
|
|
|
|
|
(finish (take names limit))
|
|
|
|
|
#t)))))))
|
|
|
|
|
(else
|
|
|
|
|
(write-string " BINDINGS:" port)
|
|
|
|
|
(finish (if package (sort names symbol<?) names)))))
|
|
|
|
|
(debugger-newline port)
|
|
|
|
|
(debugger-newline port)
|
|
|
|
|
(write-string
|
|
|
|
|
"---------------------------------------------------------------------"
|
|
|
|
|
port))
|
|
|
|
|
|
|
|
|
|
;;;This does some stuff who's end product is to pp the bindings
|
|
|
|
|
(define (myprint-binding name value port)
|
|
|
|
|
(let ((x-size (output-port/x-size port)))
|
|
|
|
|
(debugger-newline port)
|
|
|
|
|
(let ((name1
|
|
|
|
|
(output-to-string (quotient x-size 2)
|
|
|
|
|
(lambda ()
|
|
|
|
|
(write-dbg-name name (current-output-port))))))
|
|
|
|
|
(write-string name1 port)
|
|
|
|
|
(cond ((unassigned-reference-trap? value)
|
|
|
|
|
(write-string " is unassigned" port))
|
|
|
|
|
((macro-reference-trap? value)
|
|
|
|
|
(write-string " is a syntactic keyword" port))
|
|
|
|
|
(else
|
|
|
|
|
(let ((separator " = "))
|
|
|
|
|
(write-string separator port)
|
|
|
|
|
(let ((indentation
|
|
|
|
|
(+ (string-length name1)
|
|
|
|
|
(string-length separator))))
|
|
|
|
|
(write-string (string-tail
|
|
|
|
|
(call-with-output-string
|
|
|
|
|
(lambda (port)
|
|
|
|
|
(pretty-print value port #t indentation)))
|
|
|
|
|
indentation)
|
|
|
|
|
port))))))
|
|
|
|
|
(debugger-newline port)))
|
|
|
|
|
|
|
|
|
|
(define bline-type:environment
|
|
|
|
|
(make-bline-type environment/write-summary
|
|
|
|
|
environment/write-description
|
|
|
|
|
1))
|
|
|
|
|
|
|
|
|
|
(1d-table/put! (bline-type/properties bline-type:environment)
|
|
|
|
|
'GET-ENVIRONMENT
|
|
|
|
|
bline/object)
|
|
|
|
|
|
|
|
|
|
(define (bline/offset-string number)
|
|
|
|
|
(let ((string (number->string number)))
|
|
|
|
|
(if (< (string-length string) offset-string-min)
|
|
|
|
|
(string-pad-right string offset-string-min)
|
|
|
|
|
string)))
|
|
|
|
|
|
|
|
|
|
(define offset-string-min
|
|
|
|
|
2)
|
|
|
|
|
|
|
|
|
|
(define (with-buffer-open mark thunk)
|
|
|
|
|
(with-read-only-defeated mark thunk)
|
|
|
|
|
(buffer-not-modified! (mark-buffer mark)))
|
|
|
|
|
|
|
|
|
|
(define (desc-show-environment-name-and-bindings environment port)
|
|
|
|
|
(write-string
|
|
|
|
|
"---------------------------------------------------------------------"
|
|
|
|
|
port)
|
|
|
|
|
(if (ref-variable debugger-show-frames?)
|
|
|
|
|
(show-frames-and-bindings environment port)
|
|
|
|
|
(print-the-local-bindings environment port))
|
|
|
|
|
(debugger-newline port)
|
|
|
|
|
(write-string
|
|
|
|
|
"---------------------------------------------------------------------"
|
|
|
|
|
port))
|
|
|
|
|
|
|
|
|
|
(define (debugger-newline port)
|
|
|
|
|
(if (ref-variable debugger-compact-display?)
|
|
|
|
|
(fresh-line port)
|
|
|
|
|
(newline port)))
|
|
|
|
|
|
|
|
|
|
(define (show-frames-and-bindings environment port)
|
|
|
|
|
|
|
|
|
|
(define (envs environment)
|
|
|
|
|
(cons environment
|
|
|
|
|
(if (environment-has-parent? environment)
|
|
|
|
|
(envs (environment-parent environment))
|
|
|
|
|
'())))
|
|
|
|
|
|
|
|
|
|
(define (show-frames envs indents)
|
|
|
|
|
(for-each (lambda (env indent)
|
|
|
|
|
(debugger-newline port)
|
|
|
|
|
(if (eq? env environment)
|
|
|
|
|
(let* ((pointer "==> ")
|
|
|
|
|
(pl (string-length pointer)))
|
|
|
|
|
(if (> (string-length indent) pl)
|
|
|
|
|
(write-string (string-tail indent pl) port))
|
|
|
|
|
(write-string pointer port))
|
|
|
|
|
(write-string indent port))
|
|
|
|
|
(show-environment-name env port)
|
|
|
|
|
(debugger-newline port)
|
|
|
|
|
(show-environment-bindings-with-ind env indent port))
|
|
|
|
|
envs indents))
|
|
|
|
|
|
|
|
|
|
(let ((env-list (envs environment)))
|
|
|
|
|
(cond ((ref-variable debugger-show-inner-frame-topmost?)
|
|
|
|
|
(show-frames env-list (make-list (length env-list) "")))
|
|
|
|
|
(else
|
|
|
|
|
(show-frames (reverse env-list)
|
|
|
|
|
(make-initialized-list (length env-list)
|
|
|
|
|
(lambda (i) (make-string (* i 2) #\space))))))))
|
|
|
|
|
|
|
|
|
|
(define (print-the-local-bindings environment port)
|
|
|
|
|
(let ((names (get-all-local-bindings environment)))
|
|
|
|
|
(let ((n-bindings (length names))
|
|
|
|
|
(finish
|
|
|
|
|
(lambda (names)
|
|
|
|
|
(for-each (lambda (name)
|
|
|
|
|
(let loop ((env environment))
|
|
|
|
|
(if (environment-bound? env name)
|
|
|
|
|
(print-binding-with-ind
|
|
|
|
|
name
|
|
|
|
|
(environment-safe-lookup env name)
|
|
|
|
|
" "
|
|
|
|
|
port)
|
|
|
|
|
(loop (environment-parent env)))))
|
|
|
|
|
names))))
|
|
|
|
|
(debugger-newline port)
|
|
|
|
|
(show-environment-name environment port)
|
|
|
|
|
(cond ((zero? n-bindings)
|
|
|
|
|
(debugger-newline port)
|
|
|
|
|
(write-string " has no bindings" port)
|
|
|
|
|
(debugger-newline port))
|
|
|
|
|
((> n-bindings (ref-variable environment-package-limit)))
|
|
|
|
|
(else
|
|
|
|
|
(debugger-newline port)
|
|
|
|
|
(debugger-newline port)
|
|
|
|
|
(write-string " Local Bindings:" port)
|
|
|
|
|
(debugger-newline port)
|
|
|
|
|
(finish names))))))
|
|
|
|
|
|
|
|
|
|
(define (show-environment-name environment port)
|
|
|
|
|
(write-string "ENVIRONMENT " port)
|
|
|
|
|
(let ((package (environment->package environment)))
|
|
|
|
|
(if package
|
|
|
|
|
(begin
|
|
|
|
|
(write-string "named: " port)
|
|
|
|
|
(write (package/name package) port))
|
|
|
|
|
(begin
|
|
|
|
|
(write-string "created by " port)
|
|
|
|
|
(print-user-friendly-name environment port)))))
|
|
|
|
|
|
|
|
|
|
(define (get-all-local-bindings environment)
|
|
|
|
|
(define (envs environment)
|
|
|
|
|
(if (environment-has-parent? environment)
|
|
|
|
|
(cons environment (envs (environment-parent environment))) ;
|
|
|
|
|
'()))
|
|
|
|
|
(let* ((env-list (envs environment))
|
|
|
|
|
(names1 (map (lambda (envir)
|
|
|
|
|
(let ((names (environment-bound-names envir)))
|
|
|
|
|
(if (< (length names)
|
|
|
|
|
(ref-variable environment-package-limit))
|
|
|
|
|
names
|
|
|
|
|
'())))
|
|
|
|
|
env-list))
|
|
|
|
|
(names2 (reduce-right append '() names1))
|
|
|
|
|
(names3 (let loop ((l names2))
|
|
|
|
|
(if (null? l)
|
|
|
|
|
l
|
|
|
|
|
(cons (car l) (loop (delete (car l) l))))))
|
|
|
|
|
(names4 (sort names3 symbol<?)))
|
|
|
|
|
names4))
|
|
|
|
|
|
|
|
|
|
(define (show-environment-bindings-with-ind environment ind port)
|
|
|
|
|
(let ((names (environment-bound-names environment)))
|
|
|
|
|
(let ((n-bindings (length names))
|
|
|
|
|
(finish
|
|
|
|
|
(lambda (names)
|
|
|
|
|
(debugger-newline port)
|
|
|
|
|
(for-each (lambda (name)
|
|
|
|
|
(print-binding-with-ind
|
|
|
|
|
name
|
|
|
|
|
(environment-safe-lookup environment name)
|
|
|
|
|
ind
|
|
|
|
|
port))
|
|
|
|
|
names))))
|
|
|
|
|
(cond ((environment->package environment)
|
|
|
|
|
(write-string (string-append ind " has ") port)
|
|
|
|
|
(write n-bindings port)
|
|
|
|
|
(write-string
|
|
|
|
|
" bindings"
|
|
|
|
|
port)
|
|
|
|
|
(debugger-newline port))
|
|
|
|
|
((zero? n-bindings)
|
|
|
|
|
#|(write-string (string-append ind " has no bindings") port)
|
|
|
|
|
(debugger-newline port)|#)
|
|
|
|
|
((> n-bindings (ref-variable environment-package-limit))
|
|
|
|
|
(write-string (string-append ind " has ") port)
|
|
|
|
|
(write n-bindings port)
|
|
|
|
|
(write-string
|
|
|
|
|
" bindings (see editor variable environment-package-limit)"
|
|
|
|
|
port)
|
|
|
|
|
(debugger-newline port))
|
|
|
|
|
(else
|
|
|
|
|
(finish names))))))
|
|
|
|
|
|
|
|
|
|
(define (print-binding-with-ind name value ind port)
|
|
|
|
|
(let* ((extra " ")
|
|
|
|
|
(x-size
|
|
|
|
|
(- (output-port/x-size port)
|
|
|
|
|
(+ (string-length ind)
|
|
|
|
|
(string-length extra)))))
|
|
|
|
|
(write-string ind port)
|
|
|
|
|
(write-string extra port)
|
|
|
|
|
(let ((name
|
|
|
|
|
(output-to-string (quotient x-size 2)
|
|
|
|
|
(lambda ()
|
|
|
|
|
(write-dbg-name name (current-output-port))))))
|
|
|
|
|
(write-string name port)
|
|
|
|
|
(cond ((unassigned-reference-trap? value)
|
|
|
|
|
(write-string " is unassigned" port))
|
|
|
|
|
((macro-reference-trap? value)
|
|
|
|
|
(write-string " is a syntactic keyword" port))
|
|
|
|
|
(else
|
|
|
|
|
(let ((separator " = "))
|
|
|
|
|
(write-string separator port)
|
|
|
|
|
(write-string
|
|
|
|
|
(output-to-string (max 0
|
|
|
|
|
(- (- x-size 1)
|
|
|
|
|
(+ (string-length name)
|
|
|
|
|
(string-length separator))))
|
|
|
|
|
(lambda () (write value)))
|
|
|
|
|
port)))))
|
2021-04-26 07:57:47 -04:00
|
|
|
|
(debugger-newline port)))
|