;;; -*-Scheme-*-
;;;
-;;; $Id: debug.scm,v 1.16 1993/09/02 22:33:29 jbank Exp $
+;;; $Id: debug.scm,v 1.17 1993/09/09 21:13:59 cph Exp $
;;;
;;; Copyright (c) 1992-93 Massachusetts Institute of Technology
;;;
;;;
;;;; Browser-style Debug and Where
-;;; Package: (edwin new-debugger)
+;;; Package: (edwin debugger)
(declare (usual-integrations))
\f
+;;;; Text prop setup stuff
-;;;;;;;;Text prop setup stuff
-
-(define (port/buffer port)
- (mark-buffer (port/mark port)))
-
-(define (with-output-props props thunk port)
+(define (with-output-property port key datum thunk)
(let ((start (mark-index (port/mark port))))
(thunk)
(let ((end (mark-index (port/mark port))))
- (add-text-properties (buffer-group (port/buffer port))
- (min start end)
- (max start end)
- props))))
+ (add-text-property (mark-group (port/mark port))
+ start
+ end
+ key
+ datum))))
(define (readable-between start end)
- (remove-text-properties (buffer-group (mark-buffer start))
- (mark-index start)
- (mark-index end)
- (list (list 'READ-ONLY))))
+ (remove-text-property (mark-group start)
+ (mark-index start)
+ (mark-index end)
+ 'READ-ONLY))
(define (dehigh-between start end)
- (remove-text-properties (buffer-group (mark-buffer start))
- (mark-index start)
- (mark-index end)
- '((highlighted . #t))))
+ (remove-text-property (mark-group start)
+ (mark-index start)
+ (mark-index end)
+ 'HIGHLIGHTED))
(define (read-only-between start end)
- (add-text-properties (buffer-group (mark-buffer start))
- (mark-index start)
- (mark-index end)
- (list (list 'READ-ONLY (generate-uninterned-symbol)))))
+ (add-text-property (mark-group start)
+ (mark-index start)
+ (mark-index end)
+ 'READ-ONLY
+ (generate-uninterned-symbol)))
+
+(define (highlight-region start end)
+ (if (not (mark<= start end))
+ (error "Marks incorrectly related:" start end))
+ (group-highlight (mark-group start) (mark-index start) (mark-index end)))
+
+(define (group-highlight group start end)
+ (add-text-property group start end 'HIGHLIGHTED #t))
(define (debugger-pp-highlight-subexpression expression subexpression
indentation port)
(highlight-region-excluding-indentation start-mark end-mark))
(if start-mark (mark-temporary! start-mark))
(if end-mark (mark-temporary! end-mark))))
-
+
(define (highlight-region-excluding-indentation start end)
(let loop ((start start))
(let ((lend (line-end start 0)))
(end (horizontal-space-start end)))
(if (mark< start end)
(highlight-region start end)))))))
-
-(define (highlight-region start end)
- (if (not (mark<= start end))
- (error "Marks incorrectly related:" start end))
- (group-highlight (mark-group start) (mark-index start) (mark-index end)))
-
-(define (group-highlight group start end)
- (add-text-properties group start end '((HIGHLIGHTED . #T))))
-
-;;;;;;End of text setup stuff.
-
-
+\f
;;;; Browsers
(define browser-rtd
(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 false)))))
(define (highlight-the-number mark)
(let ((end (re-search-forward "[RSE][0-9]+ " mark (line-end mark 0))))
- (highlight-region mark (if (mark? end)
- (mark- end 1)
- (line-end mark 0)))))
+ (highlight-region mark (if (mark? end) (mark- end 1) (line-end mark 0)))))
(define (unselect-bline browser)
(let ((bline (browser/selected-line browser)))
(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.
+;;; 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?
+ (let* ((system?
(and (subproblem? (bline/object bline))
(system-frame? (subproblem/stack-frame (bline/object bline)))))
(buffer
(1d-table/get (bline/properties bline) 'DESCRIPTION-BUFFER false))
- (get-environment
+ (get-environment
(1d-table/get (bline-type/properties (bline/type bline))
'GET-ENVIRONMENT
false))
(let ((environment* (get-environment bline)))
(environment? environment*))
#f))
- (environment (if env-exists?
- (get-environment bline)
- #f)))
+ (environment (if env-exists? (get-environment bline) #f)))
(if (and buffer (buffer-alive? buffer))
buffer
(let ((write-description
(and write-description
(let ((buffer (browser/new-buffer (bline/browser bline) false)))
(call-with-output-mark (buffer-start buffer)
- (lambda (port)
- (write-description bline port)
- (if env-exists?
- (write-string "\n;EVALUATION may occur below in the environment of the selected frame.\n" port))))
+ (lambda (port)
+ (write-description bline port)
+ (if env-exists?
+ (write-string
+ "\n;EVALUATION may occur below in the environment of the selected frame.\n"
+ 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))
+ (read-only-between (buffer-start buffer) (buffer-end buffer))
(buffer-not-modified! buffer)
(if env-exists?
(start-inferior-repl!
#f))
(append-message "done")
buffer))))))
-
-
+\f
;;;Main addition deals with possibility that the debugger was
;;;called by a break procure, makes sure to restart the thread
(let* ((buffer (current-buffer))
(thread (buffer-get buffer 'THREAD)))
(if (thread? thread)
- (let ((value (prompt-for-expression-value
+ (let ((value (prompt-for-expression-value
"Please enter a value to continue with: "))
(cont (maybe-get-continuation buffer)))
(buffer-put! buffer 'THREAD #f)
(restart-thread thread #t (lambda ()
(cont value))))))
(invoke-restarts #f)))))
-
+\f
;;;Method for invoking the standard restarts from within the
;;;debugger.
(define (invoke-restarts avoid-deletion?)
(prompt-for-yes-or-no? prompt)))))
(prompt-for-evaluated-expression
(lambda (prompt #!optional environment port)
- (call-with-interface-port
- (buffer-end buffer)
+ (call-with-interface-port
+ (buffer-end buffer)
(lambda (port)
(hook/repl-eval #f
(prompt-for-expression prompt)
(invoke-continuation continuation
arguments
avoid-deletion?))))
- (call-with-interface-port
+ (call-with-interface-port
(let ((buff (new-buffer " *debug*-RESTARTS")))
(add-browser-buffer! browser buff)
(pop-up-buffer buff)
(write-string " " port)
(write-condition-report condition port)
(newline port)
- (command/condition-restart
+ (command/condition-restart
(make-initial-dstate condition)
port))))
(message "No condition to restart from."))))
;;;
-;;;Sort of a kludge, borrowed from arthur's debugger,
+;;;Sort of a kludge, borrowed from arthur's debugger,
;;;this makes sure that the interface port that the restart
;;;stuff gets called with uses the minibuffer for prompts
(define (call-with-interface-port mark receiver)
;; Index of this bline within browser lines vector. #F if line
;; is invisible.
INDEX
-
+
;; Line start within browser buffer. #F if line is invisible.
START-MARK
Quitting the debugger kills the debugger buffer and any associated buffers."
true
boolean?)
-
+
;;;Limited this bc the bindings are now pretty-printed
(define-variable environment-package-limit
"Packages with more than this number of bindings will be abbreviated.
boolean?)
(define-variable debugger-start-new-screen?
- "#T means start a new-screen whenever the debugger is invoked.
-#F means continue in same screen.
+ "#T means start a new-screen whenever the debugger is invoked.
+#F means continue in same screen.
'ASK means ask user whether to start new-screen."
(if (equal? microcode-id/operating-system-name "unix")
#T
#F means use default screen geometry"
#F
boolean?)
-
+\f
(define-variable debugger-sticky-prompt
"#T means don't change variable debugger-prompt-geometry?.
#F means change debugger-prompt-geometry? if true after the first time."
string?)
(define-variable debugger-show-frames?
- "If true show the environment frames in the description buffer.
+ "If true show the environment frames in the description buffer.
If false show the bindings without frames."
#T
boolean?)
" \\*debug\\*-[0-9]+")
(where-pattern
" \\*where\\*-[0-9]+"))
- (or (re-match-string-forward
+ (or (re-match-string-forward
(re-compile-pattern debug-pattern false) false false buffer-name)
- (re-match-string-forward
+ (re-match-string-forward
(re-compile-pattern where-pattern false) false false buffer-name))))
;;;Makes sure that the prompted geometry is legal
(define (geometry? geometry)
(let ((geometry-pattern
"[0-9]+x[0-9]+\\(-[0-9]+\\|+[0-9]+\\|\\)\\(-[0-9]+\\|+[0-9]+\\|\\)"))
- (re-match-string-forward (re-compile-pattern geometry-pattern false)
- false
+ (re-match-string-forward (re-compile-pattern geometry-pattern false)
+ false
false
geometry)))
;;;Bad implementation to determine for breaks
;;;if a value to proceed with is desired
-(define value? #f)
+(define value? #f)
(define (invalid-subexpression? subexpression)
(or (debugging-info/undefined-expression? subexpression)
The buffer below describes the current subproblem or reduction.
-----------")
-
+\f
;;;; Debugger Entry
;;;many changes
;;;see comments after each change
(define (continuation-browser-buffer object #!optional thread)
;;**NOTE: if a thread is passed that means it is being called by a breakpoint
- (let ((in-debugger?
+ (let ((in-debugger?
(debugger-evaluation-buffer? (buffer-name (current-buffer))))
- (break-thread
+ (break-thread
(if (default-object? thread)
#f
thread)))
(write-string debugger-help-message port))
(newline port)
(if (condition? object)
- (begin
- (write-string
+ (begin
+ (write-string
"The *ERROR* that started the debugger is:"
port)
(newline port)
(newline port)
(write-string " " port)
- (with-output-props '((highlighted . #t))
- (lambda () (write-condition-report object port))
- port)
+ (with-output-property port 'HIGHLIGHTED #t
+ (lambda ()
+ (write-condition-report object port)))
(newline port)))
(newline port))))))
(insert-blines browser 0 blines)
(set-buffer-point! buffer (buffer-end buffer))
(select-bline (car blines)))
buffer)))))
-
+\f
(define (find-debugger-buffers)
(list-transform-positive (buffer-list)
(let ((debugger-mode (ref-mode-object continuation-browser)))
;;;Determines if necessary to make a new screen and if so makes it
(define (make-debug-screen)
- (cond ((> (length (screen-list)) 1)
+ (cond ((> (length (screen-list)) 1)
(screen1+ (selected-screen)))
((and (multiple-screens?)
(if (eq? (ref-variable debugger-start-new-screen?) 'ASK)
(prompt-for-confirmation? "Start new Xwindow?")
(ref-variable debugger-start-new-screen?)))
(let* ((def-geometry (ref-variable new-screen-geometry))
- (geometry
+ (geometry
(if (ref-variable debugger-prompt-geometry?)
- (let ((prompted-geometry
- (prompt-for-string
+ (let ((prompted-geometry
+ (prompt-for-string
"Please enter a geometry" def-geometry)))
(if (geometry? prompted-geometry)
(begin
(if (not (ref-variable debugger-sticky-prompt))
(set-variable! debugger-prompt-geometry? #f))
- (set-variable! new-screen-geometry
+ (set-variable! new-screen-geometry
prompted-geometry)
prompted-geometry)
(begin
;;;Procedure that actually calls the cont-browser with the continuation
;;;and stops the thread when a break-pt is called
(define (break-to-debugger #!optional pred-thunk)
- (let ((pred
+ (let ((pred
(if (default-object? pred-thunk)
(prompt-for-yes-or-no?
"Enter the continuation browser at breakpoint")
(with-simple-restart 'CONTINUE "Return from BKPT."
(lambda ()
(let ((thread (current-thread)))
- (call-with-current-continuation
+ (call-with-current-continuation
(lambda (cont)
- (select-buffer
+ (select-buffer
(continuation-browser-buffer cont thread))
(if (eq? thread editor-thread)
(abort-current-command)
(bkvalue (break-to-debugger pred-thunk)))
(set! value? #f)
(if val
- bkvalue
+ bkvalue
(val-thunk))))
;;;Calls the break pt thing with a pred-thunk a proc and args
(bkvalue (break-to-debugger pred-thunk)))
(set! value? #f)
(if val
- bkvalue
+ bkvalue
(apply proc args))))
(define (select-continuation-browser-buffer object)
(select-buffer (continuation-browser-buffer object)))
-
+\f
(define-command browse-continuation
"Invoke the continuation-browser on CONTINUATION."
"XBrowse Continuation"
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
+\(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
one of these buffers, simply rename it using `M-x rename-buffer': once
it has been renamed, it will not be deleted automatically."
)
-
-
+\f
(define-key 'continuation-browser #\p 'quit-with-restart-value)
(if (equal? microcode-id/operating-system-name "unix")
- (begin (define-key 'continuation-browser down 'browser-next-line)
- (define-key 'continuation-browser up 'browser-previous-line)
- (define-key 'continuation-browser x-button1-down 'debugger-mouse-select-bline)))
+ (begin
+ (define-key 'continuation-browser down 'browser-next-line)
+ (define-key 'continuation-browser up 'browser-previous-line)
+ (define-key 'continuation-browser x-button1-down
+ 'debugger-mouse-select-bline)))
(define-key 'continuation-browser #\c-n 'browser-next-line)
(define-key 'continuation-browser #\c-p 'browser-previous-line)
(n 0))
(if (not frame)
'()
- (let* ((next-subproblem
+ (let* ((next-subproblem
(lambda (bline)
(loop (stack-frame/next-subproblem frame)
bline
(+ n 1))))
- (walk-reductions
+ (walk-reductions
(lambda (bline reductions)
(cons bline
(let loop ((reductions reductions) (prev false))
(lambda ()
(let* ((subproblem (stack-frame->subproblem frame n)))
(if debugger:student-walk?
- (let ((reductions
+ (let ((reductions
(subproblem/reductions subproblem)))
(if (null? reductions)
(let ((bline
(let* ((subproblem (bline/object bline))
(frame (subproblem/stack-frame subproblem)))
(if (system-frame? frame)
- (write-string "***************Internal System Code Follows***********"
+ (write-string "***************Internal System Code Follows***********"
port)
(begin
(write-string "S" port)
(print-with-subexpression expression subexpression))
((debugging-info/noise? expression)
(write-string ";" port)
- (write-string ((debugging-info/noise expression) false)
+ (write-string ((debugging-info/noise expression) false)
port))
(else
(write-string ";undefined expression" port))))))))
(unparser-literal/string instance))))
(constructor unparser-literal/make))
string)
-
+\f
(define (subproblem/write-description bline port)
(let* ((subproblem (bline/object bline))
(frame (subproblem/stack-frame subproblem)))
port)
(write-string " (from stack):" port)
(newline port)
- (write-string
+ (write-string
" Subproblem being executed highlighted.\n"
port)
(newline port)
- (let ((subexpression
+ (let ((subexpression
(subproblem/subexpression subproblem)))
(if (invalid-subexpression? subexpression)
(debugger-pp expression expression-indentation port)
- (debugger-pp-highlight-subexpression expression
- subexpression
- expression-indentation
- port))))
+ (debugger-pp-highlight-subexpression
+ expression
+ subexpression
+ expression-indentation
+ port))))
((debugging-info/noise? expression)
(write-string ((debugging-info/noise expression) true)
port))
(begin
(newline port)
(newline port)
- (desc-show-environment-name-and-bindings environment port))))))))
+ (desc-show-environment-name-and-bindings environment
+ port))))))))
(define bline-type:subproblem
(make-bline-type subproblem/write-summary
(debugger-pp (reduction/expression reduction) expression-indentation port)
(newline port)
(newline port)
- (desc-show-environment-name-and-bindings (reduction/environment reduction)
+ (desc-show-environment-name-and-bindings (reduction/environment reduction)
port)))
(define bline-type:reduction
(ref-mode-object environment-browser)
object))
(blines (environment->blines environment)))
-
+
(let ((buffer (browser/buffer browser)))
(let ((mark (buffer-end buffer)))
(with-buffer-open mark
(if (eq? true (environment-has-parent? environment))
(loop (environment-parent environment) bline)
'())))))
-
+\f
(define-major-mode environment-browser read-only "Environment Browser"
" ********Environment Browser Help********
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.
+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.
+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;
+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':
+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.")
(if (equal? microcode-id/operating-system-name "unix")
- (begin (define-key 'environment-browser down 'browser-next-line)
- (define-key 'environment-browser up 'browser-previous-line)
- (define-key 'environment-browser x-button1-down 'debugger-mouse-select-bline)))
+ (begin
+ (define-key 'environment-browser down 'browser-next-line)
+ (define-key 'environment-browser up 'browser-previous-line)
+ (define-key 'environment-browser x-button1-down
+ 'debugger-mouse-select-bline)))
(define-key 'environment-browser #\c-n 'browser-next-line)
(define-key 'environment-browser #\c-p 'browser-previous-line)
(newline port)
(let ((names (environment-bound-names environment))
(package (environment->package environment))
- (finish (lambda (names)
+ (finish (lambda (names)
(newline port)
(for-each (lambda (name)
(myprint-binding name
- (environment-lookup environment name)
+ (environment-lookup environment
+ name)
environment
port))
names))))
(cond ((null? names)
(write-string " has no bindings" port))
((and package
- (let ((limit
+ (let ((limit
(ref-variable
environment-package-limit)))
(and limit
names)))))
(newline port)
(newline port)
- (write-string
+ (write-string
"---------------------------------------------------------------------"
port))
-
+\f
;;;This does some stuff who's end product is to pp the bindings
(define (myprint-binding name value environment port)
(let ((x-size (output-port/x-size port)))
(newline port)
(write-string
(let ((name1
- (output-to-string
+ (output-to-string
(quotient x-size 2)
(lambda ()
(write-dbg-name name (current-output-port))))))
(string-append name1 " is unassigned")
(let* ((s (string-append name1 " = "))
(length (string-length s))
- (pret
- (with-output-to-string
+ (pret
+ (with-output-to-string
(lambda ()
- (eval `(pp ,name (current-output-port) #t ,length)
+ (eval `(pp ,name (current-output-port) #t ,length)
environment)))))
- (string-append
+ (string-append
s
(string-tail pret (+ length 1))))))
port)
(buffer-not-modified! (mark-buffer mark)))
(define (desc-show-environment-name-and-bindings environment port)
- (write-string "---------------------------------------------------------------------"
- port)
+ (write-string
+ "---------------------------------------------------------------------"
+ port)
(if (ref-variable debugger-show-frames?)
(show-frames-and-bindings environment port)
(print-the-local-bindings environment port))
(newline port)
- (write-string "---------------------------------------------------------------------"
- port))
+ (write-string
+ "---------------------------------------------------------------------"
+ port))
+
-
(define (show-frames-and-bindings environment port)
(define (envs environment)
(if (eq? true (environment-has-parent? environment))
'()))
(let ((env-list (envs environment))
(depth 0))
- (map (lambda (env)
+ (map (lambda (env)
(let ((ind (make-string (* 2 depth) #\space)))
(newline port)
(if (eq? env environment)
(write-string (if (< 2 (string-length ind))
- (string-append
+ (string-append
(string-tail ind 2) "==> ")
"==> ")
port)
(for-each (lambda (name)
(let loop ((env environment))
(if (environment-bound? env name)
- (print-binding-with-ind name
- (environment-lookup env name)
- " "
- port)
+ (print-binding-with-ind
+ name
+ (environment-lookup env name)
+ " "
+ port)
(loop (environment-parent env)))))
names))))
(newline port)
(else
(write-string "\n\n Local Bindings:\n" port)
(finish names))))))
-
+\f
(define (show-environment-name environment port)
(write-string "ENVIRONMENT " port)
(let ((package (environment->package environment)))
(let* ((env-list (envs environment))
(names1 (map (lambda (envir)
(let ((names (environment-bound-names envir)))
- (if (< (length names)
+ (if (< (length names)
(ref-variable environment-package-limit))
names
'())))
(lambda (names)
(newline port)
(for-each (lambda (name)
- (print-binding-with-ind name
- (environment-lookup environment name)
- ind
- port))
+ (print-binding-with-ind
+ name
+ (environment-lookup environment name)
+ ind
+ port))
names))))
(cond ((zero? n-bindings)
#|(write-string (string-append ind " has no bindings") 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)
+ (write-string
+ " bindings (see editor variable environment-package-limit) "
+ port)
(newline port))
(else
(finish names))))))
-
+\f
(define (print-binding-with-ind name value ind port)
(let ((x-size (- (output-port/x-size port) (string-length ind) 4)))
(write-string (string-append ind " ")
`((WRITE-CHAR ,operation/write-char)
(PROMPT-FOR-CONFIRMATION ,operation/prompt-for-confirmation)
(PROMPT-FOR-EXPRESSION ,operation/prompt-for-expression))
- false))
-
-
-;; Edwin Variables:
-;; scheme-environment: '(edwin debugger)
-;; scheme-syntax-table: (access edwin-syntax-table (->environment '(edwin)))
-;; End:
+ false))
\ No newline at end of file
projects / mit-scheme.git / commitdiff