;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/artdebug.scm,v 1.13 1991/11/04 20:46:39 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/artdebug.scm,v 1.14 1991/11/26 08:02:40 cph Exp $
;;;
;;; Copyright (c) 1989-91 Massachusetts Institute of Technology
;;;
By default, when the debugger starts, don't show history levels
inside the system. To detect system code, see
-~arthur/new6001/detect.scm. Predicate SYSTEM-EXPRESSION? is already
+~arthur/new6001/detect.scm. Predicate SYSTEM-FRAME? is already
in place.
MarkF has code to use the correct syntax tables for evaluation.
"Invoke the continuation-browser on CONTINUATION."
"XBrowse Continuation"
(lambda (continuation)
- (if (not (continuation? continuation)) (editor-error "Not a continuation"))
(let ((buffer (continuation-browser continuation)))
((if (ref-variable debugger-split-window?)
select-buffer-other-window
(define-integrable (buffer-dstate buffer)
(buffer-get buffer 'DEBUG-STATE))
\f
+;;;; Main Entry
+
(define (continuation-browser object)
- (let ((buffer
- (let ((buffers (find-debugger-buffers)))
- (if (and (not (null? buffers))
- (null? (cdr buffers))
- (let ((one-at-a-time?
- (ref-variable debugger-one-at-a-time?)))
- (if (boolean? one-at-a-time?)
- one-at-a-time?
- (prompt-for-confirmation?
- "Another debugger buffer exists. Delete it"))))
- (kill-buffer (car buffers)))
- (new-buffer "*debug*")))
+ (let ((buffers (find-debugger-buffers)))
+ (if (and (not (null? buffers))
+ (null? (cdr buffers))
+ (ref-variable debugger-one-at-a-time?)
+ (or (eq? true (ref-variable debugger-one-at-a-time?))
+ (prompt-for-confirmation?
+ "Another debugger buffer exists. Delete it")))
+ (kill-buffer (car buffers))))
+ (let ((buffer (new-buffer "*debug*"))
(dstate (make-initial-dstate object)))
(set-buffer-major-mode! buffer (ref-mode-object continuation-browser))
(buffer-put! buffer 'DEBUG-STATE dstate)
- (let ((hide-system-code? (ref-variable debugger-hide-system-code? buffer))
- (max-subproblems (ref-variable debugger-max-subproblems buffer))
- (top-subproblem
+ (let ((top-subproblem
(let ((previous-subproblems (dstate/previous-subproblems dstate)))
(if (null? previous-subproblems)
(dstate/subproblem dstate)
- (car (last-pair previous-subproblems))))))
+ (car (last-pair previous-subproblems)))))
+ (max-subproblems (ref-variable debugger-max-subproblems buffer))
+ (hide-system-code? (ref-variable debugger-hide-system-code? buffer)))
(with-group-undo-disabled (buffer-group buffer)
(lambda ()
- (with-output-to-mark (buffer-start buffer)
- (lambda ()
- (let ((port (current-output-port)))
- (if (ref-variable debugger-show-help-message? buffer)
- (print-help-message buffer port))
- (if (condition? object)
- (begin
- (write-string "The error that started the debugger is:"
- port)
- (newline port)
- (write-string " " port)
- (write-condition-report object port)
- (newline port)
- (newline port)
- (print-restarts object buffer port))))
- (case
- (non-reentrant-call-with-current-continuation
- (lambda (finish)
- (let loop ((frame top-subproblem) (level 0))
- (if (and frame
- (or (not max-subproblems)
- (< level max-subproblems)
- (finish 'NOT-ALL-SHOWN)))
- (with-values
- (lambda () (stack-frame/debugging-info frame))
- (lambda (expression environment subexpression)
- (if (and hide-system-code?
- (system-expression? subexpression))
- (finish 'NOT-ALL-SHOWN))
- (newline)
- (print-subproblem-level level
- frame
- expression
- environment)
- (loop (stack-frame/next-subproblem frame)
- (1+ level))))
- 'ALL-SHOWN))))
- ((NOT-ALL-SHOWN)
- (display-more-subproblems-message buffer)))))))
- (let ((point (forward-one-subproblem (buffer-start buffer))))
+ (let ((port (mark->output-port (buffer-start buffer))))
+ (if (ref-variable debugger-show-help-message? buffer)
+ (print-help-message buffer port))
+ (if (condition? object)
+ (begin
+ (write-string "The error that started the debugger is:" port)
+ (newline port)
+ (write-string " " port)
+ (write-condition-report object port)
+ (newline port)
+ (newline port)
+ (print-restarts object buffer port)))
+ (if (let loop ((frame top-subproblem) (level 0))
+ (and frame
+ (or (and max-subproblems (= level max-subproblems))
+ (and hide-system-code? (system-frame? frame))
+ (begin
+ (newline port)
+ (print-subproblem level frame port)
+ (loop (stack-frame/next-subproblem frame)
+ (+ level 1))))))
+ (display-more-subproblems-message buffer)))))
+ (let ((point (forward-subproblem (buffer-start buffer) 1)))
(set-buffer-point! buffer point)
(if (ref-variable debugger-verbose-mode? buffer)
- (print-subproblem-or-reduction point (debug-dstate point)))
+ (invoke-debugger-command mark
+ command/print-subproblem-or-reduction))
(push-buffer-mark! buffer point)
(buffer-not-modified! buffer)
buffer))))
(loop (cdr buffers)))))))
(define (print-help-message buffer port)
- (write-string
- (with-selected-buffer buffer
- (lambda ()
- (substitute-command-keys debugger-help-message)))
- port)
+ (write-string (substitute-command-keys debugger-help-message buffer) port)
(newline port)
(newline port))
(define debugger-help-message
"This is a debugger buffer:
- Expressions appear one to a line, most recent first.
+ Marker lines identify stack frames, most recent first.
Expressions are evaluated in the environment of the line above the point.
In the marker lines,
- -C- means frame was generated by Compiled code.
- -I- means frame was generated by Interpreted code.
+ -C- means frame was generated by Compiled code
+ -I- means frame was generated by Interpreted code
- S=x means frame is in subproblem number x .
- R=y means frame is reduction number y .
+ S=x means frame is in subproblem number x
+ R=y means frame is reduction number y
#R=z means there are z reductions in the subproblem;
- use \\[continuation-browser-forward-reduction] to see them.
+ use \\[continuation-browser-forward-reduction] to see them
\\[continuation-browser-print-subproblem-or-reduction] describes the current subproblem or reduction.
\\[describe-mode] shows information about debugger commands.
(write-string (string-pad-left (number->string index) 3) port)
(write-string ":" port)))
(write-string
- (with-selected-buffer buffer
- (lambda ()
- (substitute-command-keys
- "Use \\[continuation-browser-condition-restart] to invoke any of these restarts.")))
+ (substitute-command-keys
+ "Use \\[continuation-browser-condition-restart] to invoke any of these restarts."
+ buffer)
port)
(newline port)))))
-\f
-(define (count-subproblems dstate)
- (do ((i 0 (1+ i))
- (subproblem (dstate/subproblem dstate)
- (stack-frame/next-subproblem subproblem)))
- ((not subproblem) i)))
-(define (nth-subproblem buffer n)
- (let ((dstate (buffer-dstate buffer)))
- (let ((top-subproblem
- (let ((previous-subproblems (dstate/previous-subproblems dstate)))
- (if (null? previous-subproblems)
- (dstate/subproblem dstate)
- (car (last-pair previous-subproblems))))))
- (let next-subproblem ((frame top-subproblem)
- (level 0))
- (cond ((not frame)
- (editor-error "No such subproblem" n))
- ((= level n) frame)
- (else (next-subproblem (stack-frame/next-subproblem frame)
- (1+ level))))))))
-
-(define (system-expression? expression)
- expression ;ignore
+(define (system-frame? frame)
+ frame ;ignore
#f)
-
-(define (print-reductions mark)
- (let ((frame (dstate/subproblem (debug-dstate mark)))
- (subproblem-number (current-subproblem-number mark)))
- (let ((reductions (stack-frame/reductions frame)))
- (if (pair? reductions)
- (let next-reduction ((reductions reductions)
- (reduction-level 0))
- (if (pair? reductions)
- (begin
- (newline)
- (print-reduction-level
- (car reductions) subproblem-number reduction-level)
- (next-reduction (cdr reductions) (1+ reduction-level)))))))))
-
-(define (print-history-level compiled? subproblem-number reduction-id thunk)
- (fresh-line)
- (let ((level-identification
- (string-append (if compiled? "-C- S=" "-I- S=")
- (number->string subproblem-number)
- reduction-id)))
- (let ((pad-width (max 0 (- 78 (string-length level-identification)))))
- (write-string level-identification)
- (write-string
- (string-pad-right
- (string-append
- (cdr (with-output-to-truncated-string pad-width thunk)) " ")
- pad-width
- #\-)))))
-\f
-(define (print-subproblem-level subproblem-number frame expression environment)
- (print-history-level
- (stack-frame/compiled-code? frame)
- subproblem-number
- (let ((reductions
- (improper-list-length (stack-frame/reductions frame))))
- (if (zero? reductions)
- " -------- "
- (string-append " #R=" (number->string reductions) " --- ")))
- (cond ((debugging-info/compiled-code? expression)
- (lambda () (write-string ";compiled code")))
- ((not (debugging-info/undefined-expression? expression))
- (lambda ()
- (fluid-let ((*unparse-primitives-by-name?* true))
- (write (unsyntax expression)))))
- ((debugging-info/noise? expression)
- (lambda ()
- (write-string ((debugging-info/noise expression) false))))
- (else
- (lambda () (write-string ";undefined expression")))))
- (if (ref-variable debugger-verbose-mode?)
- (begin
- (newline)
- (if (environment? environment)
- (show-environment-name environment)
- (write-string "There is no environment stored for this frame."))))
- (if (ref-variable debugger-open-markers?)
- (newline)))
-
-(define (print-reduction-level reduction subproblem-number reduction-level)
- (print-history-level
- #f
- subproblem-number
- (string-append ", R=" (number->string reduction-level) " --- ")
- (lambda ()
- (fluid-let ((*unparse-primitives-by-name?* true))
- (write (unsyntax (reduction-expression reduction))))))
- (if (ref-variable debugger-verbose-mode?)
- (let ((environment (reduction-environment reduction)))
- (begin
- (newline)
- (if (environment? environment)
- (show-environment-name environment)
- (write-string
- "There is no environment stored for this frame.")))))
- (if (ref-variable debugger-open-markers?)
- (newline)))
\f
-;; Regular expressions for finding subproblem and reduction marker
-;; lines. After a match on REDUCTION-REGEXP, register 1 must match
-;; the subproblem number and register 2 must match the reduction
-;; number. After a match on SUBPROBLEM-REGEXP, register 1 must match
-;; the subproblem number and register 3 must match the maximum
-;; reduction number in that subproblem. The FIND- procedures below
-;; use these regexps.
+(define-major-mode continuation-browser scheme "Debug"
+ "Major mode for debugging Scheme programs and browsing Scheme continuations.
+Evaluation commands are similar to those of Scheme Interaction mode.
-(define reduction-regexp
- "^-I- S=\\([0-9]+\\), R=\\([0-9]+\\)")
-(define subproblem-regexp
- "^-[CI]- S=\\([0-9]+\\) \\(#R=\\([0-9]+\\)\\|\\)")
-(define subproblem-or-reduction-regexp
- "^-[CI]- S=\\([0-9]+\\)\\(, R=[0-9]+\\| #R=[0-9]+\\|\\)")
+ Marker lines identify stack frames, most recent first.
+ Expressions are evaluated in the environment of the line above the point.
-(define (region-contains-marker? region)
- (let ((start (line-start (region-start region) 0))
- (end (line-end (region-end region) 0)))
- (or (re-search-forward subproblem-regexp start end)
- (re-search-forward reduction-regexp start end))))
+ In the marker lines,
-(define (find-next-subproblem-marker mark)
- (let ((found
- (re-search-forward subproblem-regexp
- mark
- (group-end mark))))
- (and found (line-start found 0))))
+ -C- means frame was generated by Compiled code
+ -I- means frame was generated by Interpreted code
-(define (find-next-reduction-marker mark)
- (let ((found
- (re-search-forward reduction-regexp
- mark
- (group-end mark))))
- (and found (line-start found 0))))
-
-(define (find-next-subproblem-or-reduction-marker mark)
- (let ((found (re-search-forward subproblem-or-reduction-regexp
- mark
- (group-end mark))))
- (and found (line-start found 0))))
+ S=x means frame is in subproblem number x
+ R=y means frame is reduction number y
+ #R=z means there are z reductions in the subproblem;
+ use \\[continuation-browser-forward-reduction] to see them
-(define (find-previous-subproblem-marker mark)
- (re-search-backward subproblem-regexp
- mark
- (group-start mark)))
+Evaluate expressions
-(define (find-previous-reduction-marker mark)
- (re-search-backward reduction-regexp
- mark
- (group-start mark)))
+ \\[continuation-browser-eval-last-sexp] evaluates the expression preceding point in the
+ environment of the current frame.
+ \\[continuation-browser-eval-last-sexp/dynamic] evaluates the expression preceding point in the
+ environment AND DYNAMIC STATE of the current frame.
-(define (find-previous-subproblem-or-reduction-marker mark)
- (re-search-backward subproblem-or-reduction-regexp
- mark
- (group-start mark)))
+Move between subproblems and reductions
-(define (end-of-subproblem mark)
- (let ((subproblem-below (find-next-subproblem-marker mark)))
- (if subproblem-below
- (line-end subproblem-below -1)
- (group-end mark))))
+ \\[continuation-browser-forward-reduction] moves forward one reduction (earlier in time).
+ \\[continuation-browser-backward-reduction] moves backward one reduction (later in time).
-(define (re-match-extract-number register-number)
- (let ((start (re-match-start register-number))
- (end (re-match-end register-number)))
- (and start
- end
- (string->number (extract-string end start)))))
+ \\[continuation-browser-forward-subproblem] moves forward one subproblem (earlier in time).
+ \\[continuation-browser-backward-subproblem] moves backward one subproblem (later in time).
-(define (re-match-extract-subproblem)
- (or (re-match-extract-number 1)
- (editor-error "Bad subproblem marker.")))
+ \\[continuation-browser-go-to] moves directly to a subproblem (given its number).
-(define (re-match-extract-reduction)
- (or (re-match-extract-number 2)
- (editor-error "Bad reduction marker.")))
+Display debugging information
-(define (re-match-extract-reduction-count)
- (re-match-extract-number 3))
+ \\[continuation-browser-show-all-frames] shows All bindings of the current environment and its ancestors.
+ \\[continuation-browser-show-current-frame] shows bindings of identifiers in the Current environment.
+ \\[continuation-browser-print-environment] describes the current Environment.
+ \\[continuation-browser-print-expression] pretty prints the current expression.
+ \\[continuation-browser-print-environment-procedure] pretty prints the procedure that created the current environment.
+ \\[continuation-browser-expand-reductions] shows the Reductions of the current subproblem level.
+ \\[continuation-browser-print-subproblem-or-reduction] describes the current subproblem or reduction.
+ \\[continuation-browser-expand-subproblems] shows subproblems not already displayed.
+ \\[continuation-browser-frame] displays the current stack frame in internal format.
-(define (current-subproblem-number mark)
- (and (find-previous-subproblem-or-reduction-marker mark)
- (re-match-extract-subproblem)))
+Miscellany
-(define (current-reduction-number mark)
- (and (not (below-subproblem-marker? mark))
- (begin
- (find-previous-reduction-marker mark)
- (re-match-extract-reduction))))
+ \\[continuation-browser-condition-restart] continues the program using a standard restart option.
+ \\[continuation-browser-return-from] returns from the current subproblem with the value of the expression
+ preceding the point.
+ \\[continuation-browser-return-to] returns to the current subproblem with the value of the expression
+ preceding the point.
+ \\[continuation-browser-retry] retries the offending expression, returning from the current
+ subproblem with its value.
-;; Return true whenever expansion is impossible at MARK, even if
-;; because MARK is outside any subproblem or because there are no
-;; reductions for the subproblem. If only some of the reductions
-;; appear already (e.g. if the others have been deleted by the user),
-;; still return true.
+Use \\[kill-buffer] to quit the debugger."
+ (local-set-variable! enable-transcript-buffer true)
+ (local-set-variable! transcript-buffer-name (current-buffer))
+ (local-set-variable! comint-input-ring
+ (make-ring (ref-variable comint-input-ring-size)))
+ (local-set-variable! transcript-input-recorder
+ continuation-browser-input-recorder)
+ (local-set-variable! transcript-output-wrapper
+ continuation-browser-output-wrapper))
-(define (reductions-expanded? mark)
- (let ((subproblem-above (find-previous-subproblem-marker mark)))
- (or (not subproblem-above)
- (let ((subproblem-number-above (re-match-extract-subproblem))
- (reduction-count (re-match-extract-reduction-count)))
- (and reduction-count
- (let ((reduction-below
- (find-next-subproblem-or-reduction-marker
- (line-end subproblem-above 0))))
- (and reduction-below
- (= (re-match-extract-subproblem)
- subproblem-number-above))))))))
+(define (continuation-browser-input-recorder region)
+ (ring-push! (ref-variable comint-input-ring) (region->string region)))
-(define (perhaps-expand-reductions mark)
- (if (and (ref-variable debugger-expand-reductions?)
- (not (reductions-expanded? mark)))
- (with-output-to-mark (end-of-subproblem mark)
- (lambda ()
- (message "Expanding reductions...")
- (print-reductions mark)
- (temporary-message "Expanding reductions...done")))))
+(define (continuation-browser-output-wrapper thunk)
+ (with-output-to-mark (current-point)
+ (lambda ()
+ (intercept-^G-interrupts (lambda ()
+ (fresh-line)
+ (write-string ";Abort!\n\n")
+ (^G-signal))
+ thunk))))
\f
-(define (above-subproblem-marker? mark)
- (let ((next-marker
- (find-next-subproblem-or-reduction-marker mark))
- (next-subproblem (find-next-subproblem-marker mark)))
- (and next-marker
- (mark= next-marker next-subproblem))))
+;;; Disable EVAL-CURRENT-BUFFER in Debugger Mode. It is inherited
+;;; from Scheme mode but does not make sense here:
-(define (below-subproblem-marker? mark)
- (let ((previous-marker
- (find-previous-subproblem-or-reduction-marker mark))
- (previous-subproblem (find-previous-subproblem-marker mark)))
- (and previous-marker
- (mark= previous-marker previous-subproblem))))
+(define-key 'continuation-browser #\M-o
+ 'undefined)
-(define (display-more-subproblems-message buffer)
- (with-selected-buffer buffer
- (lambda ()
- (local-set-variable! mode-line-process
- '(run-light
- (": more-subproblems " run-light)
- ": more-subproblems"))))
- (buffer-modeline-event! buffer 'PROCESS-STATUS))
+;;; Comint History
+(define-key 'continuation-browser #\M-p
+ 'comint-previous-input)
+(define-key 'continuation-browser #\M-n
+ 'comint-next-input)
+(define-key 'continuation-browser '(#\C-c #\C-r)
+ 'comint-history-search-backward)
+(define-key 'continuation-browser '(#\C-c #\C-s)
+ 'comint-history-search-forward)
-(define (remove-more-subproblems-message buffer)
- (with-selected-buffer buffer
- (lambda ()
- (local-set-variable! mode-line-process
- (variable-default-value
- (ref-variable-object mode-line-process)))))
- (buffer-modeline-event! buffer 'PROCESS-STATUS))
+;;; Evaluation Commands
+(define-key 'continuation-browser '(#\C-x #\C-e)
+ 'continuation-browser-eval-last-sexp)
+(define-key 'continuation-browser '(#\C-x #\C-r)
+ 'continuation-browser-eval-last-sexp/dynamic)
+(define-key 'continuation-browser #\M-z
+ 'continuation-browser-eval-defun)
+(define-key 'continuation-browser '(#\M-C-z)
+ 'continuation-browser-eval-region)
-(define (forward-one-level start finder)
- (let ((next-level (finder start)))
- (if next-level
- (let ((second-next-level
- (find-next-subproblem-or-reduction-marker
- (line-end next-level 0))))
- (if second-next-level
- (line-end second-next-level -1)
- (group-end next-level)))
- (let ((buffer (mark-buffer start))
- (number (current-subproblem-number (group-end start))))
- (if number
- (let ((count (count-subproblems (buffer-dstate buffer))))
- (if (< number (-1+ count))
- (with-output-to-mark
- (group-end start)
- (lambda ()
- (remove-more-subproblems-message buffer)
- (let ((subproblem (nth-subproblem buffer (1+ number))))
- (with-values
- (lambda ()
- (stack-frame/debugging-info subproblem))
- (lambda (expression environment subexpression)
- subexpression
- (message
- "Expanding subproblems...")
- (newline)
- (print-subproblem-level
- (1+ number)
- subproblem
- expression
- environment)
- (temporary-message
- "Expanding subproblems...done"))))
- (if (< number (- count 2))
- (display-more-subproblems-message buffer))
- (group-end start)))
- (editor-error "No more subproblems or reductions")))
- (editor-error "No subproblem or reduction marks"))))))
-
-(define (forward-one-subproblem start)
- (forward-one-level start find-next-subproblem-marker))
-(define (forward-one-reduction start)
- (let ((mark (mark-right-inserting-copy start)))
- (perhaps-expand-reductions mark)
- (forward-one-level mark find-next-subproblem-or-reduction-marker)))
+;;; Motion Commands
+(define-key 'continuation-browser '(#\C-c #\C-f)
+ 'continuation-browser-forward-reduction)
+(define-key 'continuation-browser '(#\C-c #\C-n)
+ 'continuation-browser-forward-subproblem)
+(define-key 'continuation-browser '(#\C-c #\C-b)
+ 'continuation-browser-backward-reduction)
+(define-key 'continuation-browser '(#\C-c #\C-p)
+ 'continuation-browser-backward-subproblem)
+(define-key 'continuation-browser '(#\C-c #\C-w)
+ 'continuation-browser-go-to)
-(define (backward-one-level start finder)
- (let ((level-top (finder start)))
- (if level-top
- (let ((previous-level (finder level-top)))
- (if previous-level
- (line-end level-top -1)
- (editor-error "Cannot move beyond top level")))
- (editor-error "Cannot move beyond top level"))))
-\f
-(define (backward-one-subproblem start)
- (backward-one-level start find-previous-subproblem-marker))
-(define (backward-one-reduction start)
- (let ((mark (mark-left-inserting-copy start)))
- (if (below-subproblem-marker? mark)
- (let ((previous-subproblem (backward-one-subproblem mark)))
- (perhaps-expand-reductions previous-subproblem)))
- (backward-one-level mark find-previous-subproblem-or-reduction-marker)))
+;;; Information-display Commands
+(define-key 'continuation-browser '(#\C-c #\C-a)
+ 'continuation-browser-show-all-frames)
+(define-key 'continuation-browser '(#\C-c #\C-c)
+ 'continuation-browser-show-current-frame)
+(define-key 'continuation-browser '(#\C-c #\C-e)
+ 'continuation-browser-print-environment)
+(define-key 'continuation-browser '(#\C-c #\C-l)
+ 'continuation-browser-print-expression)
+(define-key 'continuation-browser '(#\C-c #\C-o)
+ 'continuation-browser-print-environment-procedure)
+(define-key 'continuation-browser '(#\C-c #\C-m)
+ 'continuation-browser-expand-reductions)
+(define-key 'continuation-browser '(#\C-c #\C-t)
+ 'continuation-browser-print-subproblem-or-reduction)
+(define-key 'continuation-browser '(#\C-c #\C-x)
+ 'continuation-browser-expand-subproblems)
+(define-key 'continuation-browser '(#\C-c #\C-y)
+ 'continuation-browser-frame)
-(define forward-reduction)
-(define backward-reduction)
-(make-motion-pair forward-one-reduction backward-one-reduction
- (lambda (f b)
- (set! forward-reduction f)
- (set! backward-reduction b)))
+;;; Miscellaneous Commands
+(define-key 'continuation-browser '(#\C-c #\C-k)
+ 'continuation-browser-condition-restart)
+(define-key 'continuation-browser '(#\C-c #\C-j)
+ 'continuation-browser-return-to)
+(define-key 'continuation-browser '(#\C-c #\C-z)
+ 'continuation-browser-return-from)
+(define-key 'continuation-browser '(#\C-c #\C-d)
+ 'continuation-browser-retry)
-(define forward-subproblem)
-(define backward-subproblem)
-(make-motion-pair forward-one-subproblem backward-one-subproblem
- (lambda (f b)
- (set! forward-subproblem f)
- (set! backward-subproblem b)))
+(define (debugger-command-invocation command)
+ (lambda ()
+ (invoke-debugger-command (current-point) command)))
+\f
+;;;; Evaluation Commands
-(define (change-subproblem! dstate subproblem-number)
- (let ((finish-move-to-subproblem!
- (lambda (dstate)
- (if (and (dstate/using-history? dstate)
- (positive? (dstate/number-of-reductions dstate)))
- (change-reduction! dstate 0)
- (set-dstate/reduction-number! dstate false))))
- (delta (- subproblem-number (dstate/subproblem-number dstate))))
- (if (negative? delta)
- (let ((subproblems
- (list-tail (dstate/previous-subproblems dstate)
- (-1+ (- delta)))))
- (set-current-subproblem! dstate (car subproblems) (cdr subproblems))
- (finish-move-to-subproblem! dstate))
- (let loop
- ((subproblem (dstate/subproblem dstate))
- (subproblems (dstate/previous-subproblems dstate))
- (delta delta))
- (if (zero? delta)
- (begin
- (set-current-subproblem! dstate subproblem subproblems)
- (finish-move-to-subproblem! dstate))
- (loop (stack-frame/next-subproblem subproblem)
- (cons subproblem subproblems)
- (-1+ delta)))))))
+(define-command continuation-browser-eval-region
+ "Evaluate the region."
+ "r"
+ (lambda (region)
+ (let ((environment
+ (dstate-evaluation-environment (start-evaluation region))))
+ (fluid-let ((in-debugger-evaluation? true))
+ (evaluate-region region environment)))))
+
+(define (start-evaluation region)
+ (if (region-contains-marker? region)
+ (editor-error "Can't evaluate region containing markers."))
+ (set-current-point! (region-end region))
+ (debug-dstate (region-start region)))
+
+(define-command continuation-browser-eval-defun
+ "Evaluate definition that point is in or before."
+ ()
+ (lambda ()
+ ((ref-command continuation-browser-eval-region)
+ (let ((input-mark (current-definition-start)))
+ (make-region input-mark (forward-sexp input-mark 1 'ERROR))))))
-(define (change-reduction! dstate reduction-number)
- (set-dstate/reduction-number! dstate reduction-number)
- (set-dstate/environment-list!
- dstate
- (list (reduction-environment (dstate/reduction dstate)))))
-\f
-;; UGLY BECAUSE IT MUTATES THE DSTATE.
+(define-command continuation-browser-eval-last-sexp
+ "Evaluate the expression preceding point."
+ ()
+ (lambda ()
+ ((ref-command continuation-browser-eval-region)
+ (let ((input-mark (backward-sexp (current-point) 1 'ERROR)))
+ (make-region input-mark (forward-sexp input-mark 1 'ERROR))))))
-(define (debug-dstate mark)
- (let ((dstate (buffer-dstate (mark-buffer mark))))
- (let ((subproblem-number (current-subproblem-number mark))
- (reduction-number (current-reduction-number mark)))
- (if subproblem-number
- (begin (change-subproblem! dstate subproblem-number)
- (if (and reduction-number
- (positive? (dstate/number-of-reductions dstate)))
- (change-reduction! dstate reduction-number)
- (set-dstate/reduction-number! dstate false))
- dstate)
- (editor-error "Cannot find environment for evaluation.")))))
-
-(define (dstate-evaluation-environment dstate)
- (let ((environment-list (dstate/environment-list dstate)))
- (if (and (pair? environment-list)
- (environment? (car environment-list)))
- (car environment-list)
- (let ((environment (ref-variable scheme-environment)))
- (if (eq? 'DEFAULT environment)
- (nearest-repl/environment)
- (->environment environment))))))
-
-(define (dstate-evaluation-information dstate)
- (values (dstate-evaluation-environment dstate)
- (stack-frame->continuation (dstate/subproblem dstate))))
-
-(define (debug-evaluation-information mark)
- (let ((dstate (debug-dstate mark)))
- (if dstate
- (dstate-evaluation-information dstate)
- (editor-error "Point must be between frame marker lines"))))
-\f
-(define (debugger-command-invocation command)
- (lambda ()
- (invoke-debugger-command command (current-point))))
-
-(define (invoke-debugger-command command mark)
- (with-debugger-hooks mark
- (lambda ()
- (command (debug-dstate mark)))))
-
-(define (with-debugger-hooks mark thunk)
- (fluid-let ((hook/prompt-for-confirmation
- (lambda (cmdl prompt)
- cmdl ;ignore
- (prompt-for-confirmation prompt)))
- (hook/prompt-for-expression
- (lambda (cmdl prompt)
- cmdl ;ignore
- (prompt-for-expression prompt)))
- (hook/debugger-failure
- (lambda (string)
- (message string)
- (editor-beep)))
- (hook/debugger-message message)
- (hook/presentation
- (lambda (thunk)
- (edwin-debugger-presentation mark thunk))))
- (thunk)))
-
-(define (edwin-debugger-presentation mark thunk)
- (with-output-to-mark mark
- (lambda ()
- (fresh-line)
- (fluid-let ((debugger-pp
- (lambda (expression indentation)
- (pretty-print expression
- (current-output-port)
- true
- indentation))))
- (thunk))
- (newline)
- (newline))))
-\f
-(define (continuation-browser-start-eval region)
- (fluid-let ((in-debugger-evaluation? true))
- (if (region-contains-marker? region)
- (editor-error "Cannot evaluate a region that contains markers.")
- (let ((end (region-end region)))
- (set-buffer-point! (mark-buffer end) end)
- (debug-evaluation-information (region-start region))))))
-
-(define (continuation-browser-evaluate-region/static region)
- (with-values (lambda () (continuation-browser-start-eval region))
- (lambda (environment continuation)
- continuation ;ignored
- (evaluate-region region environment))))
-
-(define (continuation-browser-evaluate-region/dynamic region)
- (with-values (lambda () (continuation-browser-start-eval region))
- (lambda (environment continuation)
- (let ((repl-eval hook/repl-eval))
+(define-command continuation-browser-eval-region/dynamic
+ "Evaluate the region.
+The evaluation occurs in the dynamic state of the current frame."
+ "r"
+ (lambda (region)
+ (let ((dstate (start-evaluation region)))
+ (let ((environment (dstate-evaluation-environment dstate))
+ (continuation
+ (stack-frame->continuation (dstate/subproblem dstate)))
+ (repl-eval hook/repl-eval))
(fluid-let
- ((hook/repl-eval
- (lambda (repl sexp env syntax-table)
+ ((in-debugger-evaluation? true)
+ (hook/repl-eval
+ (lambda (expression environment syntax-table)
(let ((unique (cons 'unique 'id)))
(let ((result
(call-with-current-continuation
- (lambda (new-continuation)
- (within-continuation
- continuation
+ (lambda (continuation*)
+ (within-continuation continuation
(lambda ()
(bind-condition-handler
'()
(lambda (condition)
- (new-continuation
- (cons unique condition)))
+ (continuation* (cons unique condition)))
(lambda ()
- (new-continuation
- (repl-eval repl
- sexp
- env
+ (continuation*
+ (repl-eval expression
+ environment
syntax-table))))))))))
(if (and (pair? result)
(eq? unique (car result)))
result))))))
(evaluate-region region environment))))))
-(define (continuation-browser-evaluate-from-mark input-mark)
- (continuation-browser-evaluate-region/static
- (make-region input-mark (forward-sexp input-mark 1 'ERROR))))
-
-(define-command continuation-browser-eval-last-expression/static
- "Evaluate the expression before the point."
+(define-command continuation-browser-eval-last-sexp/dynamic
+ "Evaluate the expression preceding point.
+The evaluation occurs in the dynamic state of the current frame."
()
(lambda ()
- (continuation-browser-evaluate-from-mark
- (backward-sexp (current-point) 1))))
+ ((ref-command continuation-browser-eval-region/dynamic)
+ (let ((input-mark (backward-sexp (current-point) 1 'ERROR)))
+ (make-region input-mark (forward-sexp input-mark 1 'ERROR))))))
+\f
+;;;; Motion Commands
+
+;;; The subproblem and reduction motion commands rely, in many
+;;; places, on the assumption that subproblem and reduction numbers
+;;; increase downward in the buffer, and that no subproblem/reduction
+;;; marker line is repeated. Of course, the user can violate this
+;;; assumption by constructing or copying a marker, but the program
+;;; is robust with respect to such conniving, as long as the
+;;; reduction and subproblem specified by the numbers in the marker
+;;; exist. The only time it should be possible to notice an effect
+;;; of this assumption is when a reduction or subproblem that is
+;;; already displayed is automatically redisplayed because the
+;;; existing one appeared out of order.
-(define-command continuation-browser-eval-last-expression/dynamic
- "Evaluate the expression before the point in the dynamic state of the
-continuation of the current frame."
- ()
- (lambda ()
- (let ((input-mark (backward-sexp (current-point) 1)))
- (continuation-browser-evaluate-region/dynamic
- (make-region input-mark
- (forward-sexp input-mark 1 'ERROR))))))
+(define-command continuation-browser-forward-subproblem
+ "Move one or more subproblems forward."
+ "p"
+ (lambda (argument) (move-thing forward-subproblem argument 'ERROR)))
-(define-command continuation-browser-eval-region
- "Evaluate the expressions in the region. Give an error if the
-region includes part of any subproblem or reduction marker."
- "r"
- (lambda (region)
- (continuation-browser-evaluate-region/static region)))
+(define-command continuation-browser-backward-subproblem
+ "Move one or more subproblems backward."
+ "p"
+ (lambda (argument) (move-thing backward-subproblem argument 'ERROR)))
-(define-command continuation-browser-eval-definition
- "Evaluate the definition the point is in or before."
- ()
- (lambda ()
- (continuation-browser-evaluate-from-mark (current-definition-start))))
+(define-command continuation-browser-forward-reduction
+ "Move one or more reductions forward.
+Display reductions that exist but are not yet displayed.
+If there are no more reductions for the current subproblem,
+move to the first reduction shown in the next subproblem."
+ "p"
+ (lambda (argument) (move-thing forward-reduction argument 'ERROR)))
-(define (print-subproblem-or-reduction mark dstate)
- (edwin-debugger-presentation mark
- (lambda ()
- (if (dstate/reduction-number dstate)
- (print-reduction-expression (dstate/reduction dstate))
- (print-subproblem-expression dstate)))))
+(define-command continuation-browser-backward-reduction
+ "Move one or more reductions backward.
+Display reductions that exist but are not yet displayed.
+If there are no more reductions for the current subproblem,
+move to the last reduction shown in the previous subproblem."
+ "p"
+ (lambda (argument) (move-thing backward-reduction argument 'ERROR)))
-(define (identify-environment dstate)
- (let ((environment-list (dstate/environment-list dstate)))
- (if (pair? environment-list)
- (print-environment (car environment-list))
- (begin (newline)
- (write-string "There is no current environment.")))))
+(define-command continuation-browser-go-to
+ "Move to an arbitrary subproblem.
+Prompt for the subproblem number if not given as an argument.
+Move to the last subproblem if the subproblem number is too high."
+ "NSubproblem number"
+ (lambda (destination-subproblem-number)
+ (set-current-point!
+ (let ((end (group-end (current-point)))
+ (not-found
+ (lambda ()
+ (editor-error "Cannot find subproblem"
+ destination-subproblem-number))))
+ (let ((last-subproblem-number (current-subproblem-number end)))
+ (if (not last-subproblem-number)
+ (not-found))
+ (cond ((< destination-subproblem-number last-subproblem-number)
+ (let loop ((point (backward-subproblem end 1)))
+ (if (not point)
+ (not-found))
+ (let ((subproblem (current-subproblem-number point)))
+ (if (not subproblem)
+ (not-found))
+ (if (= subproblem destination-subproblem-number)
+ point
+ (loop (backward-subproblem point 1))))))
+ ((> destination-subproblem-number last-subproblem-number)
+ (forward-subproblem
+ end
+ (- destination-subproblem-number last-subproblem-number)
+ 'LIMIT))
+ (else end)))))))
+\f
+;;;; Information-display Commands
+
+(define-command continuation-browser-show-all-frames
+ "Print the bindings of all frames of the current environment."
+ ()
+ (debugger-command-invocation command/show-all-frames))
+
+(define-command continuation-browser-show-current-frame
+ "Print the bindings of the current frame of the current environment."
+ ()
+ (debugger-command-invocation command/show-current-frame))
(define-command continuation-browser-print-environment
"Identify the environment of the current frame."
()
- (lambda ()
- (let ((cp (current-point)))
- (edwin-debugger-presentation
- cp
+ (debugger-command-invocation
+ (lambda (dstate port)
+ (debugger-presentation port
(lambda ()
- (identify-environment (debug-dstate cp)))))))
-
-(define-command continuation-browser-print-subproblem-or-reduction
- "Print the current subproblem or reduction in the standard format."
- ()
- (lambda ()
- (let ((cp (current-point)))
- (print-subproblem-or-reduction cp (debug-dstate cp)))))
+ (print-subproblem-environment dstate port))))))
(define-command continuation-browser-print-expression
"Pretty print the current expression."
(debugger-command-invocation command/print-environment-procedure))
(define-command continuation-browser-expand-reductions
- "Expand all the reductions of the current subproblem. If already
-expanded, move the point to one of the reductions."
+ "Expand all the reductions of the current subproblem.
+If already expanded, move the point to one of the reductions."
()
(lambda ()
- (let ((cp (current-point)))
- (if (reductions-expanded? cp)
+ (let ((point (current-point)))
+ (if (reductions-expanded? point)
(temporary-message
"Reductions for this subproblem already expanded.")
- (with-output-to-mark
- cp
- (lambda ()
- (print-reductions (current-point))))))))
-\f
-(define-command continuation-browser-go-to
- "Move to an arbitrary subproblem. Prompt for the subproblem number
-if not given as an argument. Move to the last subproblem if the
-subproblem number is too high."
- "NSubproblem number"
- (lambda (destination-subproblem-number)
- (let ((end (group-end (current-point)))
- (not-found
- (lambda ()
- (editor-error "Cannot find subproblem"
- destination-subproblem-number))))
- (let ((last-subproblem-number (current-subproblem-number end)))
- (if last-subproblem-number
- (set-buffer-point!
- (current-buffer)
- (cond ((< destination-subproblem-number last-subproblem-number)
- (let loop ((point (backward-subproblem end 1)))
- (if point
- (let ((subproblem (current-subproblem-number point)))
- (if subproblem
- (if (= subproblem
- destination-subproblem-number)
- point
- (loop (backward-subproblem point 1)))
- (not-found)))
- (not-found))))
- ((> destination-subproblem-number last-subproblem-number)
- (forward-subproblem
- end
- (- destination-subproblem-number last-subproblem-number)
- 'limit))
- (else end)))
- (not-found))))))
+ (expand-reductions point)))))
+
+(define (command/print-subproblem-or-reduction dstate port)
+ (debugger-presentation port
+ (lambda ()
+ (if (dstate/reduction-number dstate)
+ (print-reduction-expression (dstate/reduction dstate) port)
+ (print-subproblem-expression dstate port)))))
+
+(define-command continuation-browser-print-subproblem-or-reduction
+ "Print the current subproblem or reduction in the standard format."
+ ()
+ (debugger-command-invocation command/print-subproblem-or-reduction))
(define-command continuation-browser-expand-subproblems
"Expand all subproblems, or ARG more subproblems if argument is given."
(lambda (argument)
(let ((subproblem-number
(if argument
- (let ((number
- (current-subproblem-number
- (group-end (current-point)))))
- (if number
- (+ number (command-argument-numeric-value argument))
- (editor-error "Cannot find subproblem marker.")))
- (-1+ (count-subproblems
- (buffer-dstate (current-buffer)))))))
+ (+ (or (current-subproblem-number (group-end (current-point)))
+ (editor-error "Can't find subproblem marker"))
+ (command-argument-numeric-value argument))
+ (- (count-subproblems (current-buffer)) 1))))
(let ((point (mark-right-inserting-copy (current-point))))
((ref-command continuation-browser-go-to) subproblem-number)
+ (mark-temporary! point)
(set-current-point! point)))))
-;; The subproblem and reduction motion commands rely, in many places,
-;; on the assumption that subproblem and reduction numbers increase
-;; downward in the buffer, and that no subproblem/reduction marker
-;; line is repeated. Of course, the user can violate this assumption
-;; by constructing or copying a marker, but the program is robust with
-;; respect to such conniving, as long as the reduction and subproblem
-;; specified by the numbers in the marker exist. The only time it
-;; should be possible to notice an effect of this assumption is when a
-;; reduction or subproblem that is already displayed is automatically
-;; redisplayed because the existing one appeared out of order.
-
-(define-command continuation-browser-forward-reduction
- "Move one or more reductions forward.
-Display reductions that exist but are not yet displayed. If there are
-no more reductions for the current subproblem, move to the first
-reduction shown in the next subproblem."
- "p"
- (lambda (argument)
- (move-thing forward-reduction argument)))
-
-(define-command continuation-browser-forward-subproblem
- "Move one or more subproblems forward."
- "p"
- (lambda (argument)
- (move-thing forward-subproblem argument)))
-
-(define-command continuation-browser-backward-reduction
- "Move one or more reductions backward.
-Display reductions that exist but are not yet displayed. If there are
-no more reductions for the current subproblem, move to the last
-reduction shown in the previous subproblem."
- "p"
- (lambda (argument)
- (move-thing backward-reduction argument)))
-
-(define-command continuation-browser-backward-subproblem
- "Move one or more subproblems backward."
- "p"
- (lambda (argument)
- (move-thing backward-subproblem argument)))
-
-(define (show-frame environment depth brief?)
- (show-environment-name environment)
- (if (not (negative? depth))
- (begin (newline)
- (write-string "Depth (relative to initial environment): ")
- (write depth)))
- (if (not (and (environment->package environment) brief?))
- (begin
- (newline)
- (show-environment-bindings environment brief?))))
-
-(define (show-current-frame dstate brief?)
- (edwin-debugger-presentation
- (current-point)
- (lambda ()
- (let ((environment-list (dstate/environment-list dstate)))
- (show-frame (car environment-list)
- (length (cdr environment-list))
- brief?)))))
-
-(define (show-frames environment depth)
- (edwin-debugger-presentation
- (current-point)
- (lambda ()
- (let loop ((environment environment) (depth depth))
- (write-string "----------------------------------------")
- (newline)
- (show-frame environment depth true)
- (if (eq? true (environment-has-parent? environment))
- (begin
- (newline)
- (newline)
- (loop (environment-parent environment) (1+ depth))))))))
-
-(define-command continuation-browser-show-current-frame
- "Print the bindings of the current frame of the current environment."
- ()
- (lambda ()
- (show-current-frame (debug-dstate (current-point)) false)))
-
-(define-command continuation-browser-show-all-frames
- "Print the bindings of all frames of the current environment."
+(define-command continuation-browser-frame
+ "Show the current subproblem's stack frame in internal format."
()
- (debugger-command-invocation command/show-all-frames))
+ (debugger-command-invocation command/frame))
\f
-(define (subproblem-enter subproblem value avoid-deletion?)
- (if (or (not (ref-variable debugger-confirm-return?))
- (prompt-for-confirmation? "Continue with this value"))
- (begin
- (if (and (not avoid-deletion?)
- (ref-variable debugger-quit-on-return?))
- (kill-buffer-interactive (current-buffer)))
- ((stack-frame->continuation subproblem)
- value))))
+;;;; Miscellaneous Commands
-(define (guarantee-next-subproblem dstate)
- (or (stack-frame/next-subproblem (dstate/subproblem dstate))
- (editor-error "Can't continue.")))
-
-(define-command continuation-browser-retry
- "Retry the offending expression, returning from the current
-subproblem with its value.
-Prefix argument means do not kill the debugger buffer."
- "P"
- (lambda (avoid-deletion?)
- (let* ((dstate (debug-dstate (current-point)))
- (next (guarantee-next-subproblem dstate)))
- (subproblem-enter
- next
- (let ((expression (dstate/expression dstate)))
- (if (invalid-expression? expression)
- (editor-error "Cannot retry; invalid expression."
- expression)
- (extended-scode-eval
- expression
- (dstate-evaluation-environment dstate))))
- avoid-deletion?))))
-
-(define-command continuation-browser-return-from
- "Return FROM the current subproblem with a value.
-Invoke the continuation that is waiting for the value of the current
-subproblem on the value of the expression before the point.
+(define-command continuation-browser-condition-restart
+ "Continue the program using a standard restart option.
Prefix argument means do not kill the debugger buffer."
"P"
(lambda (avoid-deletion?)
- (let ((next
- (guarantee-next-subproblem
- (debug-dstate (current-point)))))
- (subproblem-enter
- next
- (continuation-browser-evaluate-from-mark
- (backward-sexp (current-point) 1))
- avoid-deletion?))))
+ (fluid-let ((hook/invoke-restart
+ (lambda (continuation arguments)
+ (invoke-continuation continuation
+ arguments
+ avoid-deletion?))))
+ (invoke-debugger-command (current-point) command/condition-restart))))
(define-command continuation-browser-return-to
"Return TO the current subproblem with a value.
(lambda (avoid-deletion?)
(let ((subproblem (dstate/subproblem (debug-dstate (current-point)))))
(subproblem-enter subproblem
- (continuation-browser-evaluate-from-mark
- (backward-sexp (current-point) 1))
+ ((ref-command continuation-browser-eval-last-sexp))
avoid-deletion?))))
-(define-command continuation-browser-frame
- "Show the current subproblem's stack frame in internal format."
- ()
- (debugger-command-invocation command/frame))
+(define-command continuation-browser-return-from
+ "Return FROM the current subproblem with a value.
+Invoke the continuation that is waiting for the value of the current
+subproblem on the value of the expression before the point.
+Prefix argument means do not kill the debugger buffer."
+ "P"
+ (lambda (avoid-deletion?)
+ (let ((next (guarantee-next-subproblem (debug-dstate (current-point)))))
+ (subproblem-enter next
+ ((ref-command continuation-browser-eval-last-sexp))
+ avoid-deletion?))))
-(define-command continuation-browser-condition-restart
- "Continue the program using a standard restart option.
+(define-command continuation-browser-retry
+ "Retry the expression of the current subproblem.
Prefix argument means do not kill the debugger buffer."
"P"
(lambda (avoid-deletion?)
- (fluid-let ((hook/before-restart
- (lambda ()
- (if (and (not avoid-deletion?)
- (ref-variable debugger-quit-on-restart?))
- (kill-buffer-interactive (current-buffer))))))
- (invoke-debugger-command command/condition-restart (current-point)))))
+ (let* ((dstate (debug-dstate (current-point)))
+ (next (guarantee-next-subproblem dstate)))
+ (subproblem-enter
+ next
+ (let ((expression (dstate/expression dstate)))
+ (if (invalid-expression? expression)
+ (editor-error "Can't retry; invalid expression" expression))
+ (extended-scode-eval expression
+ (dstate-evaluation-environment dstate)))
+ avoid-deletion?))))
-(define-major-mode continuation-browser scheme "Debug"
- "Major mode for debugging Scheme programs and browsing Scheme continuations.
-Editing and evaluation commands are similar to those of Scheme Interaction mode.
+(define (subproblem-enter subproblem value avoid-deletion?)
+ (if (or (not (ref-variable debugger-confirm-return?))
+ (prompt-for-confirmation? "Continue with this value"))
+ (invoke-continuation (stack-frame->continuation subproblem)
+ (list value)
+ avoid-deletion?)))
+
+(define (invoke-continuation continuation arguments avoid-deletion?)
+ (let ((buffer (current-buffer)))
+ (if (and (not avoid-deletion?)
+ (ref-variable debugger-quit-on-return?))
+ (kill-buffer-interactive buffer))
+ ((or (buffer-get buffer 'INVOKE-CONTINUATION) apply)
+ continuation arguments)))
- Expressions appear one to a line, most recent first. Expressions
- are evaluated in the environment of the line above the point.
+(define (guarantee-next-subproblem dstate)
+ (or (stack-frame/next-subproblem (dstate/subproblem dstate))
+ (editor-error "Can't continue; no earlier subproblem")))
+\f
+;;;; Marker Generation
+
+(define (expand-subproblem mark)
+ (let ((buffer (mark-buffer mark))
+ (number (current-subproblem-number mark)))
+ (if (not number)
+ (editor-error "No subproblem or reduction marks"))
+ (let ((number (+ number 1))
+ (count (count-subproblems buffer)))
+ (if (>= number count)
+ (editor-error "No more subproblems or reductions"))
+ (remove-more-subproblems-message buffer)
+ (let ((port (mark->output-port mark)))
+ (newline port)
+ (print-subproblem number (nth-subproblem buffer number) port))
+ (if (< number (- count 1))
+ (display-more-subproblems-message buffer)))))
- In the marker lines,
+(define (display-more-subproblems-message buffer)
+ (define-variable-local-value! buffer (ref-variable-object mode-line-process)
+ '(RUN-LIGHT (": more-subproblems " RUN-LIGHT) ": more-subproblems"))
+ (buffer-modeline-event! buffer 'PROCESS-STATUS))
- -C- means frame was generated by Compiled code
- -I- means frame was generated by Interpreted code
+(define (remove-more-subproblems-message buffer)
+ (let ((variable (ref-variable-object mode-line-process)))
+ (define-variable-local-value! buffer variable
+ (variable-default-value variable)))
+ (buffer-modeline-event! buffer 'PROCESS-STATUS))
- S=x means frame is in subproblem number x
- R=y means frame is reduction number y
- #R=z means there are z reductions in the subproblem
- Use \\[continuation-browser-forward-reduction] to see them
+(define (perhaps-expand-reductions mark)
+ (if (and (ref-variable debugger-expand-reductions?)
+ (not (reductions-expanded? mark)))
+ (begin
+ (message "Expanding reductions...")
+ (expand-reductions (end-of-subproblem mark))
+ (temporary-message "Expanding reductions...done"))))
-Evaluate expressions
+(define (expand-reductions mark)
+ (let ((port (mark->output-port mark))
+ (subproblem-number (current-subproblem-number mark)))
+ (do ((reductions (stack-frame/reductions
+ (dstate/subproblem (debug-dstate mark)))
+ (cdr reductions))
+ (reduction-number 0 (+ reduction-number 1)))
+ ((not (pair? reductions)))
+ (newline port)
+ (print-reduction subproblem-number
+ reduction-number
+ (car reductions)
+ port))))
- \\[continuation-browser-eval-last-expression/static] evaluates the expression preceding the point in the
- environment of the current frame.
- \\[continuation-browser-eval-last-expression/dynamic] evaluates the expression preceding the point in the
- environment AND DYNAMIC STATE of the current frame.
+(define (reductions-expanded? mark)
+ ;; Return true whenever expansion is impossible at MARK, even if
+ ;; because MARK is outside any subproblem or because there are no
+ ;; reductions for the subproblem. If only some of the reductions
+ ;; appear already (e.g. if the others have been deleted by the
+ ;; user), still return true.
+ (let ((subproblem-above (find-previous-subproblem-marker mark)))
+ (or (not subproblem-above)
+ (let ((subproblem-number-above (re-match-extract-subproblem))
+ (reduction-count (re-match-extract-reduction-count)))
+ (and reduction-count
+ (let ((reduction-below
+ (find-next-marker
+ (line-end subproblem-above 0))))
+ (and reduction-below
+ (= (re-match-extract-subproblem)
+ subproblem-number-above))))))))
+\f
+(define (print-subproblem number frame port)
+ (with-values (lambda () (stack-frame/debugging-info frame))
+ (lambda (expression environment subexpression)
+ subexpression
+ (print-history-level
+ (stack-frame/compiled-code? frame)
+ number
+ (let ((reductions
+ (improper-list-length (stack-frame/reductions frame))))
+ (if (zero? reductions)
+ " -------- "
+ (string-append " #R=" (number->string reductions) " --- ")))
+ (lambda ()
+ (cond ((debugging-info/compiled-code? expression)
+ (write-string ";compiled code"))
+ ((not (debugging-info/undefined-expression? expression))
+ (fluid-let ((*unparse-primitives-by-name?* true))
+ (write (unsyntax expression))))
+ ((debugging-info/noise? expression)
+ (write-string ((debugging-info/noise expression) false)))
+ (else
+ (write-string ";undefined expression"))))
+ environment
+ port))))
+
+(define (print-reduction subproblem-number reduction-number reduction port)
+ (print-history-level
+ false
+ subproblem-number
+ (string-append ", R=" (number->string reduction-number) " --- ")
+ (lambda ()
+ (fluid-let ((*unparse-primitives-by-name?* true))
+ (write (unsyntax (reduction-expression reduction)))))
+ (reduction-environment reduction)
+ port))
-Move between subproblems and reductions
+(define (print-history-level compiled? subproblem-number reduction-id
+ expression-thunk environment port)
+ (fresh-line port)
+ (let ((level-identification
+ (string-append (if compiled? "-C- S=" "-I- S=")
+ (number->string subproblem-number)
+ reduction-id)))
+ (write-string level-identification port)
+ (let ((pad-width (max 0 (- 78 (string-length level-identification)))))
+ (write-string
+ (string-pad-right
+ (string-append
+ (cdr (with-output-to-truncated-string pad-width expression-thunk))
+ " ")
+ pad-width
+ #\-)
+ port)))
+ (if (ref-variable debugger-verbose-mode?)
+ (begin
+ (newline port)
+ (if (environment? environment)
+ (show-environment-name environment port)
+ (write-string "There is no environment stored for this frame."
+ port))))
+ (if (ref-variable debugger-open-markers?)
+ (newline port)))
+\f
+;;;; Marker Location
- \\[continuation-browser-forward-reduction] moves forward one reduction (earlier in time).
- \\[continuation-browser-backward-reduction] moves backward one reduction (later in time).
+(define forward-subproblem)
+(define backward-subproblem)
+(make-motion-pair (lambda (start)
+ (forward-one-level start find-next-subproblem-marker))
+ (lambda (start)
+ (backward-one-level start find-previous-subproblem-marker))
+ (lambda (f b)
+ (set! forward-subproblem f)
+ (set! backward-subproblem b)
+ unspecific))
- \\[continuation-browser-forward-subproblem] moves forward one subproblem (earlier in time).
- \\[continuation-browser-backward-subproblem] moves backward one subproblem (later in time).
+(define forward-reduction)
+(define backward-reduction)
+(make-motion-pair (lambda (start)
+ (let ((mark (mark-right-inserting-copy start)))
+ (perhaps-expand-reductions mark)
+ (let ((result (forward-one-level mark find-next-marker)))
+ (mark-temporary! mark)
+ result)))
+ (lambda (start)
+ (let ((mark (mark-left-inserting-copy start)))
+ (if (below-subproblem-marker? mark)
+ (perhaps-expand-reductions
+ (backward-subproblem mark 1)))
+ (let ((result
+ (backward-one-level mark find-previous-marker)))
+ (mark-temporary! mark)
+ result)))
+ (lambda (f b)
+ (set! forward-reduction f)
+ (set! backward-reduction b)
+ unspecific))
- \\[continuation-browser-go-to] moves directly to a subproblem (given its number).
+(define (forward-one-level start finder)
+ (let ((next-level (finder start)))
+ (if next-level
+ (let ((second-next-level
+ (find-next-marker
+ (line-end next-level 0))))
+ (if second-next-level
+ (line-end second-next-level -1)
+ (group-end next-level)))
+ (begin
+ (message "Expanding subproblem...")
+ (expand-subproblem (group-end start))
+ (temporary-message "Expanding subproblem...done")
+ (group-end start)))))
-Display debugging information
+(define (backward-one-level start finder)
+ (let ((level-top (finder start)))
+ (if (or (not level-top) (not (finder level-top)))
+ (editor-error "Can't move beyond top level"))
+ (line-end level-top -1)))
- \\[continuation-browser-show-all-frames] shows All bindings of the current environment and its ancestors.
- \\[continuation-browser-show-current-frame] shows bindings of identifiers in the Current environment.
- \\[continuation-browser-print-environment] describes the current Environment.
- \\[continuation-browser-print-expression] pretty prints the current expression.
- \\[continuation-browser-print-environment-procedure] pretty prints the procedure that created the current environment.
- \\[continuation-browser-expand-reductions] shows the Reductions of the current subproblem level.
- \\[continuation-browser-print-subproblem-or-reduction] describes the current subproblem or reduction.
- \\[continuation-browser-expand-subproblems] shows subproblems not already displayed.
- \\[continuation-browser-frame] displays the current stack frame in internal format.
+(define (end-of-subproblem mark)
+ (let ((subproblem-below (find-next-subproblem-marker mark)))
+ (if subproblem-below
+ (line-end subproblem-below -1)
+ (group-end mark))))
+\f
+(define (below-subproblem-marker? mark)
+ (let ((mark (find-previous-marker mark)))
+ (and mark
+ (re-match-forward subproblem-regexp mark))))
-Miscellany
+(define (region-contains-marker? region)
+ (re-search-forward marker-regexp
+ (line-start (region-start region) 0)
+ (line-end (region-end region) 0)))
- \\[continuation-browser-condition-restart] continues the program using a standard restart option.
- \\[continuation-browser-return-from] returns from the current subproblem with the value of the expression
- preceding the point.
- \\[continuation-browser-return-to] returns to the current subproblem with the value of the expression
- preceding the point.
- \\[continuation-browser-retry] retries the offending expression, returning from the current
- subproblem with its value.
+(define (current-subproblem-number mark)
+ (and (find-previous-marker mark)
+ (re-match-extract-subproblem)))
-Use \\[kill-buffer] to quit the debugger."
- (local-set-variable! enable-transcript-buffer true)
- (local-set-variable! transcript-buffer-name (current-buffer))
- (local-set-variable! transcript-buffer-mode
- (ref-mode-object continuation-browser))
- (local-set-variable! transcript-input-recorder
- scheme-interaction-input-recorder)
- (local-set-variable! transcript-output-wrapper
- scheme-interaction-output-wrapper)
- (local-set-variable! comint-input-ring
- (make-ring (ref-variable comint-input-ring-size)))
- (local-set-variable! transcript-output-wrapper
- debug-interaction-output-wrapper))
-\f
-(define (debug-interaction-output-wrapper thunk)
- (with-output-to-current-point
- (lambda ()
- (intercept-^G-interrupts
- (lambda ()
- (fresh-line)
- (write-string ";Abort!")
- (fresh-lines 2)
- (^G-signal))
- thunk))))
+(define (current-reduction-number mark)
+ (and (not (below-subproblem-marker? mark))
+ (find-previous-reduction-marker mark)
+ (re-match-extract-reduction)))
-;; Disable EVAL-CURRENT-BUFFER in Debugger Mode; it is inherited from
-;; Scheme mode but does not make sense here:
+(define (find-next-subproblem-marker mark)
+ (and (re-search-forward subproblem-regexp mark (group-end mark))
+ (re-match-start 0)))
-(define-key 'continuation-browser #\M-o
- (ref-command-object undefined))
+(define (find-next-reduction-marker mark)
+ (and (re-search-forward reduction-regexp mark (group-end mark))
+ (re-match-start 0)))
-;; Evaluation
+(define (find-next-marker mark)
+ (and (re-search-forward marker-regexp mark (group-end mark))
+ (re-match-start 0)))
-(define-key 'continuation-browser '(#\C-x #\C-e)
- 'continuation-browser-eval-last-expression/static)
-(define-key 'continuation-browser '(#\C-x #\C-r)
- 'continuation-browser-eval-last-expression/dynamic)
-(define-key 'continuation-browser #\M-z
- 'continuation-browser-eval-definition)
-(define-key 'continuation-browser '(#\M-C-z)
- 'continuation-browser-eval-region)
+(define (find-previous-subproblem-marker mark)
+ (re-search-backward subproblem-regexp mark (group-start mark)))
-;; Comint history
+(define (find-previous-reduction-marker mark)
+ (re-search-backward reduction-regexp mark (group-start mark)))
-(define-key 'continuation-browser #\M-p
- 'comint-previous-input)
-(define-key 'continuation-browser #\M-n
- 'comint-next-input)
+(define (find-previous-marker mark)
+ (re-search-backward marker-regexp mark (group-start mark)))
-(define-key 'continuation-browser '(#\C-c #\C-r)
- 'comint-history-search-backward)
-(define-key 'continuation-browser '(#\C-c #\C-s)
- 'comint-history-search-forward)
+(define (re-match-extract-subproblem)
+ (or (re-match-extract-number 1)
+ (editor-error "Ill-formed subproblem marker")))
-;; Subproblem/reduction motion
+(define (re-match-extract-reduction)
+ (or (re-match-extract-number 2)
+ (editor-error "Ill-formed reduction marker")))
-(define-key 'continuation-browser '(#\C-c #\C-f)
- 'continuation-browser-forward-reduction)
-(define-key 'continuation-browser '(#\C-c #\C-n)
- 'continuation-browser-forward-subproblem)
-(define-key 'continuation-browser '(#\C-c #\C-b)
- 'continuation-browser-backward-reduction)
-(define-key 'continuation-browser '(#\C-c #\C-p)
- 'continuation-browser-backward-subproblem)
-(define-key 'continuation-browser '(#\C-c #\C-w)
- 'continuation-browser-go-to)
+(define (re-match-extract-reduction-count)
+ (re-match-extract-number 3))
-;; Information display
+(define (re-match-extract-number register-number)
+ (let ((start (re-match-start register-number))
+ (end (re-match-end register-number)))
+ (and start
+ end
+ (string->number (extract-string end start)))))
-(define-key 'continuation-browser '(#\C-c #\C-a)
- 'continuation-browser-show-all-frames)
-(define-key 'continuation-browser '(#\C-c #\C-c)
- 'continuation-browser-show-current-frame)
-(define-key 'continuation-browser '(#\C-c #\C-e)
- 'continuation-browser-print-environment)
-(define-key 'continuation-browser '(#\C-c #\C-l)
- 'continuation-browser-print-expression)
-(define-key 'continuation-browser '(#\C-c #\C-o)
- 'continuation-browser-print-environment-procedure)
-(define-key 'continuation-browser '(#\C-c #\C-m)
- 'continuation-browser-expand-reductions)
-(define-key 'continuation-browser '(#\C-c #\C-t)
- 'continuation-browser-print-subproblem-or-reduction)
-(define-key 'continuation-browser '(#\C-c #\C-x)
- 'continuation-browser-expand-subproblems)
-(define-key 'continuation-browser '(#\C-c #\C-y)
- 'continuation-browser-frame)
+;;; Regular expressions for finding subproblem and reduction marker
+;;; lines. After a match on REDUCTION-REGEXP, register 1 must match
+;;; the subproblem number and register 2 must match the reduction
+;;; number. After a match on SUBPROBLEM-REGEXP, register 1 must
+;;; match the subproblem number and register 3 must match the maximum
+;;; reduction number in that subproblem.
-;; Miscellany
+(define subproblem-regexp
+ "^-[CI]- S=\\([0-9]+\\) \\(#R=\\([0-9]+\\)\\|\\)")
-(define-key 'continuation-browser '(#\C-c #\C-k)
- 'continuation-browser-condition-restart)
-(define-key 'continuation-browser '(#\C-c #\C-j)
- 'continuation-browser-return-to)
-(define-key 'continuation-browser '(#\C-c #\C-z)
- 'continuation-browser-return-from)
-(define-key 'continuation-browser '(#\C-c #\C-d)
- 'continuation-browser-retry)
\ No newline at end of file
+(define reduction-regexp
+ "^-I- S=\\([0-9]+\\), R=\\([0-9]+\\)")
+
+(define marker-regexp
+ "^-[CI]- S=\\([0-9]+\\)\\(, R=[0-9]+\\| #R=[0-9]+\\|\\)")
+\f
+;;;; Debugger State
+
+;;; UGLY BECAUSE IT MUTATES THE DSTATE.
+
+(define (debug-dstate mark)
+ (let ((dstate (buffer-dstate (mark-buffer mark))))
+ (let ((subproblem-number (current-subproblem-number mark))
+ (reduction-number (current-reduction-number mark)))
+ (if subproblem-number
+ (begin (change-subproblem! dstate subproblem-number)
+ (if (and reduction-number
+ (positive? (dstate/number-of-reductions dstate)))
+ (change-reduction! dstate reduction-number)
+ (set-dstate/reduction-number! dstate false))
+ dstate)
+ (editor-error "Cannot find environment for evaluation.")))))
+
+(define (change-subproblem! dstate subproblem-number)
+ (let ((finish-move-to-subproblem!
+ (lambda (dstate)
+ (if (and (dstate/using-history? dstate)
+ (positive? (dstate/number-of-reductions dstate)))
+ (change-reduction! dstate 0)
+ (set-dstate/reduction-number! dstate false))))
+ (delta (- subproblem-number (dstate/subproblem-number dstate))))
+ (if (negative? delta)
+ (let ((subproblems
+ (list-tail (dstate/previous-subproblems dstate)
+ (-1+ (- delta)))))
+ (set-current-subproblem! dstate (car subproblems) (cdr subproblems))
+ (finish-move-to-subproblem! dstate))
+ (let loop
+ ((subproblem (dstate/subproblem dstate))
+ (subproblems (dstate/previous-subproblems dstate))
+ (delta delta))
+ (if (zero? delta)
+ (begin
+ (set-current-subproblem! dstate subproblem subproblems)
+ (finish-move-to-subproblem! dstate))
+ (loop (stack-frame/next-subproblem subproblem)
+ (cons subproblem subproblems)
+ (-1+ delta)))))))
+
+(define (change-reduction! dstate reduction-number)
+ (set-dstate/reduction-number! dstate reduction-number)
+ (set-dstate/environment-list!
+ dstate
+ (list (reduction-environment (dstate/reduction dstate)))))
+
+(define (count-subproblems buffer)
+ (do ((i 0 (1+ i))
+ (subproblem (dstate/subproblem (buffer-dstate buffer))
+ (stack-frame/next-subproblem subproblem)))
+ ((not subproblem) i)))
+
+(define (nth-subproblem buffer n)
+ (let ((dstate (buffer-dstate buffer)))
+ (do ((frame
+ (let ((previous-subproblems (dstate/previous-subproblems dstate)))
+ (if (null? previous-subproblems)
+ (dstate/subproblem dstate)
+ (car (last-pair previous-subproblems))))
+ (or (stack-frame/next-subproblem frame)
+ (editor-error "No such subproblem" n)))
+ (level 0 (+ level 1)))
+ ((= level n) frame))))
+
+(define (dstate-evaluation-environment dstate)
+ (let ((environment-list (dstate/environment-list dstate)))
+ (if (and (pair? environment-list)
+ (environment? (car environment-list)))
+ (car environment-list)
+ (let ((environment (ref-variable scheme-environment)))
+ (if (eq? 'DEFAULT environment)
+ (nearest-repl/environment)
+ (->environment environment))))))
+\f
+;;;; Interface Port
+
+(define (invoke-debugger-command mark command)
+ (call-with-interface-port mark
+ (lambda (port)
+ (command (debug-dstate mark) port))))
+
+(define (call-with-interface-port mark receiver)
+ (let ((mark (mark-left-inserting-copy mark)))
+ (let ((value (receiver (port/copy interface-port-template mark))))
+ (mark-temporary! mark)
+ value)))
+
+(define (operation/write-char port char)
+ (region-insert-char! (port/state port) char))
+
+(define (operation/write-substring port string start end)
+ (region-insert-substring! (port/state port) string start end))
+
+(define (operation/fresh-line port)
+ (guarantee-newline (port/state port)))
+
+(define (operation/x-size port)
+ (let ((buffer (mark-buffer (port/state port))))
+ (and buffer
+ (let ((windows (buffer-windows buffer)))
+ (and (not (null? windows))
+ (apply min (map window-x-size windows)))))))
+
+(define (operation/debugger-failure string)
+ (message string)
+ (editor-beep))
+
+(define (operation/debugger-message string)
+ (message string))
+
+(define (debugger-presentation port thunk)
+ (fresh-line port)
+ (fluid-let ((debugger-pp
+ (lambda (expression indentation port)
+ (pretty-print expression port true indentation))))
+ (thunk))
+ (newline port)
+ (newline port))
+
+(define (operation/prompt-for-expression port prompt)
+ port
+ (prompt-for-expression prompt))
+
+(define (operation/prompt-for-confirmation port prompt)
+ port
+ (prompt-for-confirmation prompt))
+
+(define interface-port-template
+ (make-output-port
+ `((WRITE-CHAR ,operation/write-char)
+ (WRITE-SUBSTRING ,operation/write-substring)
+ (FRESH-LINE ,operation/fresh-line)
+ (X-SIZE ,operation/x-size)
+ (DEBUGGER-FAILURE ,operation/debugger-failure)
+ (DEBUGGER-MESSAGE ,operation/debugger-message)
+ (DEBUGGER-PRESENTATION ,debugger-presentation)
+ (PROMPT-FOR-EXPRESSION ,operation/prompt-for-expression)
+ (PROMPT-FOR-CONFIRMATION ,operation/prompt-for-confirmation))
+ false))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/intmod.scm,v 1.39 1991/08/28 21:06:47 arthur Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/intmod.scm,v 1.40 1991/11/26 08:03:18 cph Exp $
;;;
;;; Copyright (c) 1986, 1989-91 Massachusetts Institute of Technology
;;;
;;; of that license should have been included along with this file.
;;;
-;;;; Interaction Mode
-;;; Package: (edwin)
+;;;; Inferior REPL Mode
+;;; Package: (edwin inferior-repl)
(declare (usual-integrations))
\f
-(define-command scheme-interaction-mode
- "Make the current mode be Scheme Interaction mode."
- ()
- (lambda ()
- (set-current-major-mode! (ref-mode-object scheme-interaction))))
+(define-command repl
+ "Run an inferior read-eval-print loop (REPL), with I/O through buffer *repl*.
+If buffer exists, just select it; otherwise create it and start REPL.
+REPL uses current evaluation environment,
+but prefix argument means prompt for different environment."
+ "P"
+ (lambda (argument)
+ (select-buffer
+ (or (find-buffer initial-buffer-name)
+ (let ((environment (evaluation-environment argument)))
+ (start-inferior-repl! (create-buffer initial-buffer-name)
+ environment
+ (evaluation-syntax-table environment)
+ false))))))
+
+(define (start-inferior-repl! buffer environment syntax-table message)
+ (set-buffer-major-mode! buffer (ref-mode-object inferior-repl))
+ (let ((port (make-interface-port buffer)))
+ (attach-buffer-interface-port! buffer port)
+ (set-port/inferior-continuation! port command-reader-reset-continuation)
+ (add-buffer-initialization!
+ buffer
+ (lambda ()
+ (set-buffer-default-directory! buffer (working-directory-pathname))
+ (within-inferior port
+ (lambda ()
+ (fluid-let ((*^G-interrupt-handler* cmdl-interrupt/abort-nearest))
+ (with-input-from-port port
+ (lambda ()
+ (with-output-to-port port
+ (lambda ()
+ (repl/start (make-repl false
+ port
+ environment
+ syntax-table
+ false
+ '()
+ user-initial-prompt)
+ message))))))))))
+ buffer))
+
+(define (within-inferior port thunk)
+ (without-interrupts
+ (lambda ()
+ (set-run-light! port true)
+ (update-screens! false)
+ (call-with-current-continuation
+ (lambda (continuation)
+ (set-port/editor-continuation! port continuation)
+ (let ((continuation (port/inferior-continuation port)))
+ (set-port/inferior-continuation! port false)
+ (within-continuation continuation thunk)))))))
+
+(define (within-editor port thunk)
+ (call-with-current-continuation
+ (lambda (continuation)
+ (without-interrupts
+ (lambda ()
+ (set-port/inferior-continuation! port continuation)
+ (let ((continuation (port/editor-continuation port)))
+ (set-port/editor-continuation! port false)
+ (within-continuation continuation
+ (lambda ()
+ (set-run-light! port false)
+ (thunk)))))))))
+\f
+(define (invoke-inferior port result)
+ (within-inferior port (lambda () result)))
+
+(define (within-editor-temporarily port thunk)
+ (within-editor port
+ (lambda ()
+ (invoke-inferior port (thunk)))))
+
+(define (return-to-editor port level mode)
+ (within-editor port
+ (lambda ()
+ (process-output-queue port)
+ (maybe-switch-modes! port mode)
+ (add-buffer-initialization! (port/buffer port)
+ (lambda ()
+ (local-set-variable! mode-line-process
+ (list (string-append ": " (or level "???") " ")
+ 'RUN-LIGHT))))
+ (let ((mark (port/mark port)))
+ (if (not (group-start? mark))
+ (guarantee-newlines 2 mark))))))
+
+(define (maybe-switch-modes! port mode)
+ (let ((buffer (port/buffer port)))
+ (let ((mode* (buffer-major-mode buffer)))
+ (if (not (eq? mode* mode))
+ (if (or (eq? mode* (ref-mode-object inferior-repl))
+ (eq? mode* (ref-mode-object inferior-debugger)))
+ ;; Modes are compatible, so no need to reset the buffer's
+ ;; variables and properties.
+ (begin
+ (without-interrupts
+ (lambda ()
+ (set-car! (buffer-modes buffer) mode)
+ (set-buffer-comtabs! buffer (mode-comtabs mode))))
+ (buffer-modeline-event! buffer 'BUFFER-MODES))
+ (begin
+ (set-buffer-major-mode! buffer mode)
+ (attach-buffer-interface-port! buffer port)))))))
+
+(define (attach-buffer-interface-port! buffer port)
+ (buffer-put! buffer 'INTERFACE-PORT port)
+ (add-buffer-initialization! buffer
+ (lambda ()
+ (local-set-variable! comint-input-ring (port/input-ring port))
+ (set-run-light! port false))))
+
+(define-integrable (buffer-interface-port buffer)
+ (buffer-get buffer 'INTERFACE-PORT))
-(define-major-mode scheme-interaction scheme "Scheme Interaction"
- "Major mode for evaluating Scheme expressions interactively.
-Like Scheme mode, except that a history of evaluated expressions is saved.
+(define (set-run-light! port run?)
+ (let ((buffer (port/buffer port)))
+ (define-variable-local-value! buffer (ref-variable-object run-light)
+ (if run? "run" "listen"))
+ (buffer-modeline-event! buffer 'RUN-LIGHT)))
+\f
+;;;; Modes
+
+(define-major-mode inferior-repl scheme "Inferior REPL"
+ "Major mode for communicating with an inferior read-eval-print loop (REPL).
+Editing and evaluation commands are like Scheme mode:
+
+\\[inferior-repl-eval-last-sexp] evaluates the expression preceding point.
+\\[inferior-repl-eval-defun] evaluates the current definition.
+\\[inferior-repl-eval-region] evaluates the current region.
+C-g aborts any evaluation.
+
+Expressions submitted for evaluation are saved in an expression history.
The history may be accessed with the following commands:
-\\[comint-previous-input] cycles backwards through the input history;
-\\[comint-next-input] cycles forwards;
+\\[comint-previous-input] cycles backwards through the history;
+\\[comint-next-input] cycles forwards.
\\[comint-history-search-backward] searches backwards for a matching string;
-\\[comint-history-search-forward] searchs forwards."
- (local-set-variable! enable-transcript-buffer true)
- (local-set-variable! transcript-buffer-name (current-buffer))
- (local-set-variable! transcript-input-recorder
- scheme-interaction-input-recorder)
- (local-set-variable! transcript-output-wrapper
- scheme-interaction-output-wrapper)
- (local-set-variable! comint-input-ring
- (make-ring (ref-variable comint-input-ring-size))))
-
-(define (scheme-interaction-input-recorder region)
- (ring-push! (ref-variable comint-input-ring)
- (region->string region)))
-
-(define (scheme-interaction-output-wrapper thunk)
- (let ((point (buffer-end (current-buffer))))
- (set-current-point! point)
- (with-output-to-mark
- point
- (lambda ()
- (intercept-^G-interrupts
- (lambda ()
- (fresh-line)
- (write-string ";Abort!")
- (fresh-lines 2)
- (^G-signal))
- thunk)))))
+\\[comint-history-search-forward] searches forwards.
+
+The REPL may be controlled by the following commands:
+
+\\[inferior-repl-abort-top-level] returns to top level.
+\\[inferior-repl-abort-previous] goes up one level.")
+
+(define-key 'inferior-repl '(#\C-c #\C-b) 'inferior-repl-breakpoint)
+(define-key 'inferior-repl '(#\C-c #\C-c) 'inferior-repl-abort-top-level)
+(define-key 'inferior-repl '(#\C-c #\C-u) 'inferior-repl-abort-previous)
+(define-key 'inferior-repl '(#\C-c #\C-x) 'inferior-repl-abort-nearest)
+
+(define-key 'inferior-repl #\M-o 'undefined)
+(define-key 'inferior-repl #\M-z 'inferior-repl-eval-defun)
+(define-key 'inferior-repl #\C-M-z 'inferior-repl-eval-region)
+(define-key 'inferior-repl '(#\C-x #\C-e) 'inferior-repl-eval-last-sexp)
+
+(define-key 'inferior-repl #\M-p 'comint-previous-input)
+(define-key 'inferior-repl #\M-n 'comint-next-input)
+(define-key 'inferior-repl '(#\C-c #\C-r) 'comint-history-search-backward)
+(define-key 'inferior-repl '(#\C-c #\C-s) 'comint-history-search-forward)
+
+(define-key 'inferior-repl '(#\C-c #\C-d) 'inferior-repl-debug)
+
+(define-major-mode inferior-debugger scheme "Inferior Debugger"
+ "Major mode for communicating with an inferior debugger.
+Like Scheme mode except that the evaluation commands are disabled,
+and characters that would normally be self inserting are debugger commands.
+Typing ? will show you which characters perform useful functions.
+
+Additionally, these commands abort the debugger:
+
+\\[inferior-repl-abort-top-level] returns to the top-level REPL.
+\\[inferior-repl-abort-previous] returns to the previous level REPL.")
+
+(define-key 'inferior-debugger '(#\C-c #\C-b) 'inferior-repl-breakpoint)
+(define-key 'inferior-debugger '(#\C-c #\C-c) 'inferior-repl-abort-top-level)
+(define-key 'inferior-debugger '(#\C-c #\C-u) 'inferior-repl-abort-previous)
+(define-key 'inferior-debugger '(#\C-c #\C-x) 'inferior-repl-abort-nearest)
+
+(define-key 'inferior-debugger #\M-o 'undefined)
+(define-key 'inferior-debugger #\M-z 'undefined)
+(define-key 'inferior-debugger #\C-M-z 'undefined)
+(define-key 'inferior-debugger '(#\C-x #\C-e) 'undefined)
+
+(define-key 'inferior-debugger #\M-p 'undefined)
+(define-key 'inferior-debugger #\M-n 'undefined)
+(define-key 'inferior-debugger '(#\C-c #\C-r) 'undefined)
+(define-key 'inferior-debugger '(#\C-c #\C-s) 'undefined)
+
+(define-key 'inferior-debugger char-set:graphic 'inferior-debugger-self-insert)
+\f
+;;;; Commands
+
+(define (interrupt-command interrupt)
+ (lambda ()
+ (within-inferior (buffer-interface-port (current-buffer)) interrupt)))
+
+(define-command inferior-repl-breakpoint
+ "Force the inferior REPL into a breakpoint."
+ ()
+ (interrupt-command cmdl-interrupt/breakpoint))
+
+(define-command inferior-repl-abort-nearest
+ "Force the inferior REPL back to the current level."
+ ()
+ (interrupt-command cmdl-interrupt/abort-nearest))
+
+(define-command inferior-repl-abort-previous
+ "Force the inferior REPL up to the previous level."
+ ()
+ (interrupt-command cmdl-interrupt/abort-previous))
+
+(define-command inferior-repl-abort-top-level
+ "Force the inferior REPL up to top level."
+ ()
+ (interrupt-command cmdl-interrupt/abort-top-level))
+
+(define-command inferior-repl-eval-defun
+ "Evaluate defun that point is in or before."
+ ()
+ (lambda ()
+ (inferior-repl-eval-from-mark (current-definition-start))))
+
+(define-command inferior-repl-eval-last-sexp
+ "Evaluate the expression preceding point."
+ ()
+ (lambda ()
+ (inferior-repl-eval-from-mark (backward-sexp (current-point) 1 'ERROR))))
+
+(define-command inferior-repl-eval-region
+ "Evaluate the region."
+ "r"
+ (lambda (region)
+ (inferior-repl-eval-region (region-start region) (region-end region))))
+\f
+(define-command inferior-repl-debug
+ "Select a debugger buffer to examine the current REPL state.
+If this is an error, the debugger examines the error condition."
+ ()
+ (lambda ()
+ (let ((buffer (current-buffer)))
+ (let ((port (buffer-interface-port buffer)))
+ (let ((browser
+ (continuation-browser
+ (or (let ((cmdl (port/inferior-cmdl port)))
+ (and (repl? cmdl)
+ (repl/condition cmdl)))
+ (port/inferior-continuation port)))))
+ (buffer-put! browser 'INVOKE-CONTINUATION
+ (lambda (continuation arguments)
+ (if (not (buffer-alive? buffer))
+ (editor-error
+ "Can't continue; REPL buffer no longer exists!"))
+ (select-buffer buffer)
+ (within-continuation *command-continuation*
+ (lambda ()
+ (within-inferior port
+ (lambda ()
+ (apply continuation arguments)))
+ 'ABORT))))
+ (select-buffer browser))))))
+
+(define (port/inferior-cmdl port)
+ (call-with-current-continuation
+ (lambda (continuation)
+ (within-continuation (port/inferior-continuation port)
+ (lambda ()
+ (continuation (nearest-cmdl)))))))
+
+(define-command inferior-debugger-self-insert
+ "Send this character to the inferior debugger process."
+ ()
+ (lambda ()
+ (invoke-inferior (buffer-interface-port (current-buffer))
+ (last-command-key))))
+\f
+;;;; Evaluation
+
+(define (inferior-repl-eval-from-mark mark)
+ (inferior-repl-eval-region mark (forward-sexp mark 1 'ERROR)))
+
+(define (inferior-repl-eval-region start end)
+ (let ((buffer (mark-buffer start)))
+ (let ((port (buffer-interface-port buffer)))
+ (set-buffer-point! buffer end)
+ (move-mark-to! (port/mark port) end)
+ (ring-push! (port/input-ring port) (extract-string start end))
+ (let ((queue (port/expression-queue port)))
+ (let ((input-port (make-buffer-input-port start end)))
+ (bind-condition-handler (list condition-type:error)
+ evaluation-error-handler
+ (lambda ()
+ (let loop ()
+ (let ((sexp (read input-port)))
+ (if (not (eof-object? sexp))
+ (begin
+ (enqueue! queue sexp)
+ (loop))))))))
+ (let ((empty (cons '() '())))
+ (let ((expression (dequeue! queue empty)))
+ (if (not (eq? expression empty))
+ (invoke-inferior port expression))))))))
+
+(define (dequeue! queue empty)
+ (without-interrupts
+ (lambda ()
+ (if (queue-empty? queue)
+ empty
+ (dequeue!/unsafe queue)))))
+\f
+;;;; Interface Port
+
+(define (make-interface-port buffer)
+ (port/copy interface-port-template
+ (make-interface-port-state
+ (mark-left-inserting-copy (buffer-end buffer))
+ (make-ring (ref-variable comint-input-ring-size))
+ (make-queue)
+ (make-queue)
+ '()
+ false
+ false)))
+
+(define-structure (interface-port-state (conc-name interface-port-state/))
+ (mark false read-only true)
+ (input-ring false read-only true)
+ (expression-queue false read-only true)
+ (output-queue false read-only true)
+ output-strings
+ editor-continuation
+ inferior-continuation)
+
+(define-integrable (port/mark port)
+ (interface-port-state/mark (port/state port)))
+
+(define-integrable (port/buffer port)
+ (mark-buffer (port/mark port)))
+
+(define-integrable (port/input-ring port)
+ (interface-port-state/input-ring (port/state port)))
+
+(define-integrable (port/expression-queue port)
+ (interface-port-state/expression-queue (port/state port)))
+
+(define-integrable (port/output-queue port)
+ (interface-port-state/output-queue (port/state port)))
+
+(define-integrable (port/output-strings port)
+ (interface-port-state/output-strings (port/state port)))
+
+(define-integrable (set-port/output-strings! port strings)
+ (set-interface-port-state/output-strings! (port/state port) strings))
+
+(define-integrable (port/editor-continuation port)
+ (interface-port-state/editor-continuation (port/state port)))
+
+(define-integrable (set-port/editor-continuation! port continuation)
+ (set-interface-port-state/editor-continuation! (port/state port)
+ continuation))
+
+(define-integrable (port/inferior-continuation port)
+ (interface-port-state/inferior-continuation (port/state port)))
+
+(define-integrable (set-port/inferior-continuation! port continuation)
+ (set-interface-port-state/inferior-continuation! (port/state port)
+ continuation))
+\f
+;;; Output operations
+
+(define (operation/write-char port char)
+ (set-port/output-strings! port
+ (cons (string char)
+ (port/output-strings port))))
+
+(define (operation/write-substring port string start end)
+ (set-port/output-strings! port
+ (cons (substring string start end)
+ (port/output-strings port))))
+
+(define (process-output-queue port)
+ (synchronize-output port)
+ (let ((queue (port/output-queue port))
+ (mark (port/mark port)))
+ (let loop ()
+ (let ((operation (dequeue! queue false)))
+ (if operation
+ (begin
+ (operation mark)
+ (loop)))))))
+
+(define (operation/fresh-line port)
+ (enqueue-output-operation! port guarantee-newline))
+
+(define (enqueue-output-operation! port operator)
+ (synchronize-output port)
+ (enqueue! (port/output-queue port) operator))
+
+(define (synchronize-output port)
+ (without-interrupts
+ (lambda ()
+ (let ((strings (port/output-strings port)))
+ (set-port/output-strings! port '())
+ (if (not (null? strings))
+ (enqueue! (port/output-queue port)
+ (let ((string (apply string-append (reverse! strings))))
+ (lambda (mark)
+ (region-insert-string! mark string)))))))))
+
+(define (operation/x-size port)
+ (let ((buffer (port/buffer port)))
+ (and buffer
+ (let ((windows (buffer-windows buffer)))
+ (and (not (null? windows))
+ (apply min (map window-x-size windows)))))))
+
+;;; Input operations
+
+(define (operation/peek-char port)
+ (error "PEEK-CHAR not supported on this port:" port))
+
+(define (operation/read-char port)
+ (error "READ-CHAR not supported on this port:" port))
+
+(define (operation/read port parser-table)
+ parser-table
+ (read-expression port (number->string (nearest-cmdl/level))))
+
+(define (read-expression port level)
+ (let ((empty (cons '() '())))
+ (let ((expression (dequeue! (port/expression-queue port) empty)))
+ (if (eq? expression empty)
+ (return-to-editor port level (ref-mode-object inferior-repl))
+ expression))))
+\f
+;;; Debugger
+
+(define (operation/debugger-failure port string)
+ (enqueue-output-operation! port
+ (lambda (mark)
+ mark
+ (message string)
+ (editor-beep))))
+
+(define (operation/debugger-message port string)
+ (enqueue-output-operation! port (lambda (mark) mark (message string))))
+
+(define (operation/debugger-presentation port thunk)
+ (fresh-line port)
+ (thunk))
+
+;;; Prompting
+
+(define (operation/prompt-for-expression port prompt)
+ (within-editor-temporarily port
+ (lambda ()
+ (process-output-queue port)
+ (prompt-for-expression prompt))))
+
+(define (operation/prompt-for-confirmation port prompt)
+ (within-editor-temporarily port
+ (lambda ()
+ (process-output-queue port)
+ (prompt-for-confirmation prompt))))
+
+(define (operation/prompt-for-command-expression port prompt)
+ (read-expression port (parse-command-prompt prompt)))
+
+(define (operation/prompt-for-command-char port prompt)
+ (return-to-editor port
+ (parse-command-prompt prompt)
+ (ref-mode-object inferior-debugger)))
+
+(define (parse-command-prompt prompt)
+ (and (re-match-string-forward (re-compile-pattern "\\([0-9]+\\) " false)
+ false false prompt)
+ (substring prompt
+ (re-match-start-index 1)
+ (re-match-end-index 1))))
+\f
+;;; Miscellaneous
+
+(define (operation/set-default-directory port directory)
+ (enqueue-output-operation! port
+ (lambda (mark)
+ (set-buffer-default-directory! (mark-buffer mark) directory)
+ (message (->namestring directory)))))
+
+(define (operation/set-default-environment port environment)
+ (enqueue-output-operation! port
+ (lambda (mark)
+ (define-variable-local-value! (mark-buffer mark)
+ (ref-variable-object scheme-environment)
+ environment))))
-(define-key 'scheme-interaction #\M-p 'comint-previous-input)
-(define-key 'scheme-interaction #\M-n 'comint-next-input)
+(define (operation/set-default-syntax-table port syntax-table)
+ (enqueue-output-operation! port
+ (lambda (mark)
+ (define-variable-local-value! (mark-buffer mark)
+ (ref-variable-object scheme-syntax-table)
+ syntax-table))))
-(define-key 'scheme-interaction '(#\C-c #\C-r) 'comint-history-search-backward)
-(define-key 'scheme-interaction '(#\C-c #\C-s) 'comint-history-search-forward)
\ No newline at end of file
+(define interface-port-template
+ (make-i/o-port
+ `((WRITE-CHAR ,operation/write-char)
+ (WRITE-SUBSTRING ,operation/write-substring)
+ (FRESH-LINE ,operation/fresh-line)
+ (X-SIZE ,operation/x-size)
+ (DEBUGGER-FAILURE ,operation/debugger-failure)
+ (DEBUGGER-MESSAGE ,operation/debugger-message)
+ (DEBUGGER-PRESENTATION ,operation/debugger-presentation)
+ (PROMPT-FOR-EXPRESSION ,operation/prompt-for-expression)
+ (PROMPT-FOR-CONFIRMATION ,operation/prompt-for-confirmation)
+ (PROMPT-FOR-COMMAND-EXPRESSION ,operation/prompt-for-command-expression)
+ (PROMPT-FOR-COMMAND-CHAR ,operation/prompt-for-command-char)
+ (SET-DEFAULT-DIRECTORY ,operation/set-default-directory)
+ (SET-DEFAULT-ENVIRONMENT ,operation/set-default-environment)
+ (SET-DEFAULT-SYNTAX-TABLE ,operation/set-default-syntax-table)
+ (PEEK-CHAR ,operation/peek-char)
+ (READ-CHAR ,operation/read-char)
+ (READ ,operation/read))
+ false))
\ No newline at end of file
projects / mit-scheme.git / commitdiff