From a2cafcdd6165e332260e6edba2dcbfedb969e359 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Tue, 26 Nov 1991 08:03:42 +0000 Subject: [PATCH] Requires runtime 14.142 * Replace scheme-interaction mode by new inferior-repl mode. The new mode runs a standard REP loop as an inferior coprocess, and supports both the runtime system's debugger and edwin's debugger. * Transcript buffer used to be same as interaction buffer; now it is a separate buffer. In addition, it records input expressions as well as the output. * Extensive reorganization of debugger. Only substantive change is for compatibility with changes to debugger in runtime system. However, the code is now organized in a somewhat top-down fashion, which should aid comprehension. * Delete FRESH-LINE and FRESH-LINES procedures. Former is supported in runtime system, latter is random. * Editor cmdl changed to use new interface. --- v7/src/edwin/artdebug.scm | 1659 +++++++++++++++++-------------------- v7/src/edwin/bufout.scm | 66 +- v7/src/edwin/ed-ffi.scm | 2 +- v7/src/edwin/editor.scm | 172 ++-- v7/src/edwin/edtstr.scm | 4 +- v7/src/edwin/edwin.ldr | 4 +- v7/src/edwin/edwin.pkg | 65 +- v7/src/edwin/evlcom.scm | 112 +-- v7/src/edwin/intmod.scm | 562 ++++++++++++- v7/src/edwin/make.scm | 4 +- v7/src/edwin/modefs.scm | 9 +- v7/src/edwin/tterm.scm | 13 +- v7/src/edwin/winout.scm | 33 +- v7/src/edwin/xterm.scm | 28 +- 14 files changed, 1506 insertions(+), 1227 deletions(-) diff --git a/v7/src/edwin/artdebug.scm b/v7/src/edwin/artdebug.scm index a2ea99dd0..27cfcf4ce 100644 --- a/v7/src/edwin/artdebug.scm +++ b/v7/src/edwin/artdebug.scm @@ -1,6 +1,6 @@ ;;; -*-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 ;;; @@ -62,7 +62,7 @@ environment-browsing command. By default, when the debugger starts, don't show history levels inside the system. To detect system code, see -~arthur/new6001/detect.scm. Predicate SYSTEM-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. @@ -212,7 +212,6 @@ or #F meaning no limit." "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 @@ -222,74 +221,57 @@ or #F meaning no limit." (define-integrable (buffer-dstate buffer) (buffer-get buffer 'DEBUG-STATE)) +;;;; 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)))) @@ -305,29 +287,25 @@ or #F meaning no limit." (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. @@ -343,490 +321,227 @@ or #F meaning no limit." (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))))) - -(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 - #\-))))) - -(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))) -;; 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)))) -(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")))) - -(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))) + +;;;; 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))))) - -;; 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")))) - -(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)))) - -(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))) @@ -834,70 +549,107 @@ or #F meaning no limit." 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)))))) + +;;;; 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))))))) + +;;;; 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." @@ -910,52 +662,27 @@ region includes part of any subproblem or reduction marker." (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)))))))) - -(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." @@ -963,152 +690,33 @@ subproblem number is too high." (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)) -(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. @@ -1119,178 +727,463 @@ Prefix argument means do not kill the debugger buffer." (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"))) + +;;;; 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)))))))) + +(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))) + +;;;; 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)))) + +(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)) - -(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]+\\|\\)") + +;;;; 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)))))) + +;;;; 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 diff --git a/v7/src/edwin/bufout.scm b/v7/src/edwin/bufout.scm index f41442418..cabfdaa78 100644 --- a/v7/src/edwin/bufout.scm +++ b/v7/src/edwin/bufout.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/bufout.scm,v 1.6 1991/08/16 01:31:00 arthur Exp $ +;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/bufout.scm,v 1.7 1991/11/26 08:02:36 cph Exp $ ;;; ;;; Copyright (c) 1986, 1989-91 Massachusetts Institute of Technology ;;; @@ -58,35 +58,15 @@ false buffer)))) -(define (fresh-line #!optional port) - (let ((port (if (default-object? port) (current-output-port) port))) - (let ((operation (output-port/custom-operation port 'fresh-line))) - (if operation - (operation port) - (output-port/write-char port #\newline)) - (output-port/flush-output port)))) +(define-integrable (port/mark port) + (car (port/state port))) -(define (fresh-lines n #!optional port) - (let ((port (if (default-object? port) (current-output-port) port))) - (let ((operation (output-port/custom-operation port 'fresh-lines))) - (if operation - (operation port n) - (let loop ((n n)) - (if (positive? n) - (begin - (output-port/write-char port #\newline) - (loop (-1+ n)))))) - (output-port/flush-output port)))) - -(define-integrable (output-port/mark port) - (car (output-port/state port))) - -(define-integrable (output-port/buffer port) - (cdr (output-port/state port))) +(define-integrable (port/buffer port) + (cdr (port/state port))) (define (operation/flush-output port) - (let ((mark (output-port/mark port)) - (buffer (output-port/buffer port))) + (let ((mark (port/mark port)) + (buffer (port/buffer port))) (if buffer (for-each (if (mark= mark (buffer-point buffer)) (lambda (window) @@ -97,42 +77,34 @@ (buffer-windows buffer))))) (define (operation/fresh-line port) - (guarantee-newline (output-port/mark port))) - -(define (operation/fresh-lines port n) - (guarantee-newlines n (output-port/mark port))) + (guarantee-newline (port/mark port))) (define (operation/print-self state port) (unparse-string state "to buffer at ") - (unparse-object state (output-port/mark port))) + (unparse-object state (port/mark port))) (define (operation/write-char port char) - (region-insert-char! (output-port/mark port) char)) + (region-insert-char! (port/mark port) char)) -(define (operation/write-string port string) - (region-insert-string! (output-port/mark port) string)) +(define (operation/write-substring port string start end) + (region-insert-substring! (port/mark port) string start end)) (define (operation/close port) - (mark-temporary! (output-port/mark port))) - -(define default-window-width false) + (mark-temporary! (port/mark port))) (define (operation/x-size port) - (let ((sizes - (map window-x-size - (buffer-windows - (mark-buffer (output-port/mark port)))))) - (if (null? sizes) - (or default-window-width 79) - (apply min sizes)))) + (let ((buffer (mark-buffer (port/mark port)))) + (and buffer + (let ((windows (buffer-windows buffer))) + (and (not (null? windows)) + (apply min (map window-x-size windows))))))) (define mark-output-port-template (make-output-port `((CLOSE ,operation/close) (FLUSH-OUTPUT ,operation/flush-output) (FRESH-LINE ,operation/fresh-line) - (FRESH-LINES ,operation/fresh-lines) (PRINT-SELF ,operation/print-self) (WRITE-CHAR ,operation/write-char) - (WRITE-STRING ,operation/write-string) + (WRITE-SUBSTRING ,operation/write-substring) (X-SIZE ,operation/x-size)) false)) \ No newline at end of file diff --git a/v7/src/edwin/ed-ffi.scm b/v7/src/edwin/ed-ffi.scm index deff74352..d8753f4a2 100644 --- a/v7/src/edwin/ed-ffi.scm +++ b/v7/src/edwin/ed-ffi.scm @@ -93,7 +93,7 @@ edwin-syntax-table) ("input" (edwin keyboard) edwin-syntax-table) - ("intmod" (edwin) + ("intmod" (edwin inferior-repl) edwin-syntax-table) ("iserch" (edwin incremental-search) edwin-syntax-table) diff --git a/v7/src/edwin/editor.scm b/v7/src/edwin/editor.scm index fe8f4ae33..7eedb943a 100644 --- a/v7/src/edwin/editor.scm +++ b/v7/src/edwin/editor.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/editor.scm,v 1.208 1991/11/04 20:47:33 cph Exp $ +;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/editor.scm,v 1.209 1991/11/26 08:02:55 cph Exp $ ;;; ;;; Copyright (c) 1986, 1989-91 Massachusetts Institute of Technology ;;; @@ -58,59 +58,24 @@ (recursive-edit-continuation false) (recursive-edit-level 0)) (editor-grab-display edwin-editor - (lambda (with-editor-ungrabbed) + (lambda (with-editor-ungrabbed operations) (let ((message (cmdl-message/null))) - (push-cmdl - (lambda (cmdl) - cmdl ;ignore - (bind-condition-handler (list condition-type:error) - internal-error-handler - (lambda () - (top-level-command-reader edwin-initialization))) - message) - false - message - (editor-spawn-child-cmdl with-editor-ungrabbed)))))))) + (cmdl/start + (push-cmdl + (lambda (cmdl) + cmdl ;ignore + (bind-condition-handler (list condition-type:error) + internal-error-handler + (lambda () + (top-level-command-reader edwin-initialization))) + message) + false + `((START-CHILD ,(editor-start-child-cmdl with-editor-ungrabbed)) + ,@operations)) + message))))))) (if edwin-finalization (edwin-finalization)) unspecific) -(define (editor-grab-display editor receiver) - (display-type/with-display-grabbed (editor-display-type editor) - (lambda (with-display-ungrabbed) - (with-current-local-bindings! - (lambda () - (let ((enter - (lambda () - (let ((screen (selected-screen))) - (screen-enter! screen) - (update-screen! screen true)))) - (exit (lambda () (screen-exit! (selected-screen))))) - (dynamic-wind enter - (lambda () - (receiver - (lambda (thunk) - (dynamic-wind exit - (lambda () - (with-display-ungrabbed thunk)) - enter)))) - exit))))))) - -(define (editor-spawn-child-cmdl with-editor-ungrabbed) - (lambda (editor-cmdl input-port output-port driver state message spawn-child) - (with-editor-ungrabbed - (lambda () - (make-cmdl editor-cmdl - (if (eq? input-port (cmdl/input-port editor-cmdl)) - (cmdl/input-port (cmdl/parent editor-cmdl)) - input-port) - (if (eq? output-port (cmdl/output-port editor-cmdl)) - (cmdl/output-port (cmdl/parent editor-cmdl)) - output-port) - driver - state - message - spawn-child))))) - (define (edwin . args) (apply edit args)) (define (within-editor?) (not (unassigned? current-editor))) @@ -158,34 +123,37 @@ (set! edwin-initialization (lambda () (set! edwin-initialization false) - (with-editor-interrupts-disabled standard-editor-initialization))) + (standard-editor-initialization))) unspecific)) (define (standard-editor-initialization) - (if (not init-file-loaded?) - (begin - (let ((filename (os/init-file-name))) - (if (file-exists? filename) - (let ((buffer (temporary-buffer " *dummy*"))) - (with-selected-buffer buffer - (lambda () - (load-edwin-file filename '(EDWIN) true))) - (kill-buffer buffer)))) - (set! init-file-loaded? true))) - (if (not (ref-variable inhibit-startup-message)) - (let ((window (current-window))) - (let ((buffer (window-buffer window))) - (dynamic-wind - (lambda () unspecific) - (lambda () - (with-output-to-mark (window-point window) - write-initial-buffer-greeting!) - (set-window-start-mark! window (buffer-start buffer) false) - (buffer-not-modified! buffer) - (sit-for 120000)) - (lambda () - (region-delete! (buffer-unclipped-region buffer)) - (buffer-not-modified! buffer))))))) + (start-inferior-repl! + (current-buffer) + user-initial-environment + user-initial-syntax-table + (and (not (ref-variable inhibit-startup-message)) + (cmdl-message/append + (cmdl-message/active + (lambda (port) + (identify-world port) + (newline port) + (newline port))) + (cmdl-message/strings + "You are in an interaction window of the Edwin editor." + "Type C-h for help. C-h m will describe some commands.")))) + (with-editor-interrupts-disabled + (lambda () + (if (not init-file-loaded?) + (begin + (let ((filename (os/init-file-name))) + (if (file-exists? filename) + (let ((buffer (temporary-buffer " *dummy*"))) + (with-selected-buffer buffer + (lambda () + (load-edwin-file filename '(EDWIN) true))) + (kill-buffer buffer)))) + (set! init-file-loaded? true) + unspecific))))) (define inhibit-editor-init-file? false) (define init-file-loaded? false) @@ -195,18 +163,6 @@ This is for use in your personal init file, once you are familiar with the contents of the startup message." false) - -(define (write-initial-buffer-greeting!) - (identify-world) - (write-string initial-buffer-greeting)) - -(define initial-buffer-greeting - " - -;You are in an interaction window of the Edwin editor. -;Type C-h for help. C-h m will describe some commands. - -") (define (reset-editor) (without-interrupts @@ -320,24 +276,48 @@ This does not affect editor errors or evaluation errors." (editor-beep) (abort-current-command)) +(define *^G-interrupt-handler*) + (define (^G-signal) - (let ((continuations *^G-interrupt-continuations*)) - (if (not (pair? continuations)) - (error "can't signal ^G interrupt")) - ((car continuations)))) + (*^G-interrupt-handler*)) (define (intercept-^G-interrupts interceptor thunk) (let ((signal-tag "signal-tag")) (let ((value (call-with-current-continuation (lambda (continuation) - (fluid-let ((*^G-interrupt-continuations* - (cons (lambda () (continuation signal-tag)) - *^G-interrupt-continuations*))) + (fluid-let ((*^G-interrupt-handler* + (lambda () (continuation signal-tag)))) (thunk)))))) (if (eq? value signal-tag) (interceptor) value)))) -(define *^G-interrupt-continuations* - '()) \ No newline at end of file +(define (editor-grab-display editor receiver) + (display-type/with-display-grabbed (editor-display-type editor) + (lambda (with-display-ungrabbed operations) + (with-current-local-bindings! + (lambda () + (let ((enter + (lambda () + (let ((screen (selected-screen))) + (screen-enter! screen) + (update-screen! screen true)))) + (exit + (lambda () + (screen-exit! (selected-screen))))) + (dynamic-wind enter + (lambda () + (receiver + (lambda (thunk) + (dynamic-wind exit + (lambda () + (with-display-ungrabbed thunk)) + enter)) + operations)) + exit))))))) + +(define (editor-start-child-cmdl with-editor-ungrabbed) + (lambda (cmdl thunk) + cmdl + (with-editor-ungrabbed thunk))) \ No newline at end of file diff --git a/v7/src/edwin/edtstr.scm b/v7/src/edwin/edtstr.scm index 5295b6898..96c587325 100644 --- a/v7/src/edwin/edtstr.scm +++ b/v7/src/edwin/edtstr.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/edtstr.scm,v 1.17 1991/11/19 19:44:15 markf Exp $ +;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/edtstr.scm,v 1.18 1991/11/26 08:02:59 cph Exp $ ;;; ;;; Copyright (c) 1989-91 Massachusetts Institute of Technology ;;; @@ -63,7 +63,7 @@ (define (make-editor name display-type make-screen-args) (let ((initial-buffer (make-buffer initial-buffer-name - initial-buffer-mode + (ref-mode-object fundamental) (working-directory-pathname)))) (let ((bufferset (make-bufferset initial-buffer)) (screen (display-type/make-screen display-type make-screen-args))) diff --git a/v7/src/edwin/edwin.ldr b/v7/src/edwin/edwin.ldr index eed9f4465..882a5f85a 100644 --- a/v7/src/edwin/edwin.ldr +++ b/v7/src/edwin/edwin.ldr @@ -1,5 +1,5 @@ ;;; -*-Scheme-*- -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/edwin.ldr,v 1.18 1991/08/06 22:54:20 bal Exp $ +;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/edwin.ldr,v 1.19 1991/11/26 08:03:04 cph Exp $ ;;; program to load package contents ;;; **** This program (unlike most .ldr files) is not generated by a program. @@ -95,7 +95,7 @@ (load "fill" environment) (load "hlpcom" environment) (load "info" (->environment '(EDWIN INFO))) - (load "intmod" environment) + (load "intmod" (->environment '(EDWIN INFERIOR-REPL))) (load "keymap" (->environment '(EDWIN COMMAND-SUMMARY))) (load "kilcom" environment) (load "kmacro" environment) diff --git a/v7/src/edwin/edwin.pkg b/v7/src/edwin/edwin.pkg index ffc4a8596..9e57764d7 100644 --- a/v7/src/edwin/edwin.pkg +++ b/v7/src/edwin/edwin.pkg @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/edwin.pkg,v 1.67 1991/10/29 13:44:08 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/edwin.pkg,v 1.68 1991/11/26 08:03:08 cph Exp $ Copyright (c) 1989-91 Massachusetts Institute of Technology @@ -77,7 +77,6 @@ MIT in each case. |# "filcom" ; file commands "fill" ; text fill commands "hlpcom" ; help commands - "intmod" ; interaction mode "kilcom" ; kill commands "kmacro" ; keyboard macros "lincom" ; line commands @@ -344,8 +343,6 @@ MIT in each case. |# terminal-raw-input terminal-raw-output terminal-set-state) - (import (runtime interrupt-handler) - hook/^g-interrupt) (import (runtime transcript) transcript-port) (initialization (initialize-package!))) @@ -473,7 +470,10 @@ MIT in each case. |# set-command-argument! set-command-message! set-current-command! - top-level-command-reader)) + top-level-command-reader) + (export (edwin inferior-repl) + *command-continuation* + command-reader-reset-continuation)) (define-package (edwin keyboard) (files "input") @@ -549,6 +549,7 @@ MIT in each case. |# (files "bufinp") (parent (edwin)) (export (edwin) + make-buffer-input-port with-input-from-mark with-input-from-region)) @@ -556,9 +557,6 @@ MIT in each case. |# (files "bufout") (parent (edwin)) (export (edwin) - default-window-width - fresh-line - fresh-lines mark->output-port with-output-to-mark)) @@ -566,7 +564,7 @@ MIT in each case. |# (files "winout") (parent (edwin)) (export (edwin) - with-interactive-output-port + window-output-port with-output-to-current-point with-output-to-window-point)) @@ -682,7 +680,10 @@ MIT in each case. |# (files "debug") (parent (edwin)) (export (edwin) + continuation-browser debug-scheme-error + edwin-command$browse-continuation + edwin-mode$continuation-browser edwin-variable$debugger-confirm-return? edwin-variable$debugger-debug-evaluations? edwin-variable$debugger-expand-reductions? @@ -699,25 +700,12 @@ MIT in each case. |# (import (runtime continuation-parser) stack-frame/reductions) (import (runtime debugger) - command/condition-report command/condition-restart - command/earlier-reduction - command/earlier-subproblem command/frame - command/goto - command/later-reduction - command/later-subproblem - command/move-to-child-environment - command/move-to-parent-environment command/print-environment-procedure command/print-expression - command/print-reductions - command/print-subproblem-or-reduction - command/return-from - command/return-to command/show-all-frames command/show-current-frame - command/summarize-subproblems debugger-pp dstate/environment-list dstate/expression @@ -728,13 +716,11 @@ MIT in each case. |# dstate/subproblem dstate/subproblem-number dstate/using-history? - hook/debugger-before-return improper-list-length invalid-expression? make-initial-dstate - output-to-string - print-environment print-reduction-expression + print-subproblem-environment print-subproblem-expression reduction-environment reduction-expression @@ -742,18 +728,10 @@ MIT in each case. |# set-dstate/environment-list! set-dstate/reduction-number! show-environment-name - show-environment-bindings stack-frame/compiled-code? write-restarts) - (import (runtime debugger-utilities) - hook/debugger-failure - hook/debugger-message - hook/presentation) (import (runtime error-handler) - hook/before-restart) - (import (runtime rep) - hook/prompt-for-confirmation - hook/prompt-for-expression) + hook/invoke-restart) (import (runtime unparser) *unparse-primitives-by-name?*)) @@ -981,4 +959,21 @@ MIT in each case. |# edwin-variable$rmail-mode-hook edwin-variable$rmail-primary-inbox-list edwin-variable$rmail-reply-with-re - rmail-spool-directory)) \ No newline at end of file + rmail-spool-directory)) + +(define-package (edwin inferior-repl) + (files "intmod") + (parent (edwin)) + (export (edwin) + edwin-command$inferior-debugger-self-insert + edwin-command$inferior-repl-abort-nearest + edwin-command$inferior-repl-abort-previous + edwin-command$inferior-repl-abort-top-level + edwin-command$inferior-repl-breakpoint + edwin-command$inferior-repl-eval-defun + edwin-command$inferior-repl-eval-last-sexp + edwin-command$inferior-repl-eval-region + edwin-command$repl + edwin-mode$inferior-debugger + edwin-mode$inferior-repl + start-inferior-repl!)) \ No newline at end of file diff --git a/v7/src/edwin/evlcom.scm b/v7/src/edwin/evlcom.scm index 00290d0bb..9f6cb806a 100644 --- a/v7/src/edwin/evlcom.scm +++ b/v7/src/edwin/evlcom.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/evlcom.scm,v 1.30 1991/11/04 20:47:47 cph Exp $ +;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/evlcom.scm,v 1.31 1991/11/26 08:03:13 cph Exp $ ;;; ;;; Copyright (c) 1986, 1989-91 Massachusetts Institute of Technology ;;; @@ -73,20 +73,20 @@ This does not affect editor errors." (define-variable transcript-buffer-name "Name of evaluation transcript buffer. This can also be a buffer object." - "*scratch*") + "*transcript*") (define-variable transcript-buffer-mode "Mode of evaluation transcript buffer. This can be either a mode object or the name of one." - 'scheme-interaction) + 'scheme) (define-variable transcript-input-recorder - "A procedure which receives each input region before evaluation. + "A procedure that receives each input region before evaluation. If #F, disables input recording." false) (define-variable transcript-output-wrapper - "A procedure which is called to setup transcript output. + "A procedure that is called to setup transcript output. It is passed a thunk as its only argument. If #F, normal transcript output is done." false) @@ -143,10 +143,16 @@ With an argument, prompts for the evaluation environment." (evaluate-region (buffer-region (current-buffer)) argument))) (define-command eval-expression - "Read an evaluate an expression in the typein window. + "Read and evaluate an expression in the typein window. With an argument, prompts for the evaluation environment." "xEvaluate expression\nP" (lambda (expression argument) + (let ((enable-transcript-buffer (ref-variable enable-transcript-buffer))) + (if enable-transcript-buffer + (insert-string + (fluid-let ((*unparse-with-maximum-readability?* true)) + (write-to-string expression)) + (buffer-end (transcript-buffer))))) (editor-eval expression (evaluation-environment argument)))) (define-command set-environment @@ -252,6 +258,11 @@ may be available. The following commands are special to this mode: (let ((transcript-input-recorder (ref-variable transcript-input-recorder))) (if transcript-input-recorder (transcript-input-recorder region))) + (let ((enable-transcript-buffer (ref-variable enable-transcript-buffer))) + (if enable-transcript-buffer + (insert-region (region-start region) + (region-end region) + (buffer-end (transcript-buffer))))) (let ((environment (evaluation-environment argument))) (with-input-from-region region (lambda () @@ -315,17 +326,18 @@ kludge the mode line." boolean?) (define (editor-eval sexp environment) - (let* ((to-transcript? (ref-variable enable-transcript-buffer)) - (core - (lambda () - (with-output-to-transcript-buffer + (let ((core + (lambda () + (with-input-from-string "" (lambda () - (let* ((buffer (transcript-buffer)) - (value (eval-with-history sexp environment))) - (transcript-write value - buffer - to-transcript?) - value)))))) + (with-output-to-transcript-buffer + (lambda () + (let ((value (eval-with-history sexp environment))) + (transcript-write + value + (and (ref-variable enable-transcript-buffer) + (transcript-buffer))) + value)))))))) (if (ref-variable enable-run-light?) (dynamic-wind (lambda () @@ -348,7 +360,7 @@ kludge the mode line." (bind-condition-handler (list condition-type:error) evaluation-error-handler (lambda () - (hook/repl-eval (nearest-repl) expression environment syntax-table))))) + (hook/repl-eval expression environment syntax-table))))) (define (evaluation-error-handler condition) (default-report-error condition "evaluation") @@ -367,17 +379,19 @@ kludge the mode line." report-string))) (error-buffer-report (lambda () - (string->temporary-buffer report-string "*Error*") + (string->temporary-buffer report-string "*error*") (message (string-capitalize error-type-name) " error")))) (case (ref-variable error-display-mode) ((TRANSCRIPT) - (with-output-to-transcript-buffer - (lambda () - (fresh-line) - (display ";Error: ") - (display report-string) - (newline) - (newline)))) + (if (ref-variable enable-transcript-buffer) + (with-output-to-transcript-buffer + (lambda () + (fresh-line) + (write-string ";Error: ") + (write-string report-string) + (newline) + (newline))) + (error-buffer-report))) ((ERROR-BUFFER) (error-buffer-report)) ((TYPEIN) @@ -392,10 +406,10 @@ kludge the mode line." (define-variable error-display-mode "Value of this variable controls the way evaluation errors are displayed: TRANSCRIPT Error messages appear in transcript buffer. -ERROR-BUFFER Error messages appear in *Error* buffer. +ERROR-BUFFER Error messages appear in *error* buffer. TYPEIN Error messages appear in typein window. FIT Error messages appear in typein window if they fit; - in *Error* buffer if they don't." + in *error* buffer if they don't." 'TRANSCRIPT (lambda (value) (memq value '(TRANSCRIPT ERROR-BUFFER TYPEIN FIT)))) @@ -409,28 +423,19 @@ FIT Error messages appear in typein window if they fit; (let ((output-port (let ((buffer (transcript-buffer))) (mark->output-port (buffer-end buffer) buffer)))) - (fresh-lines 1 output-port) - (with-standard-output-port output-port thunk)))) + (fresh-line output-port) + (with-output-to-port output-port thunk)))) (let ((value)) (let ((output - (with-string-output-port - (lambda (output-port) - (with-standard-output-port output-port - (lambda () - (set! value (thunk)) - unspecific)))))) + (with-output-to-string + (lambda () + (set! value (thunk)) + unspecific)))) (if (not (string-null? output)) (string->temporary-buffer output "*Unsolicited-Output*"))) value))) -(define (with-standard-output-port output-port thunk) - (with-output-to-port output-port - (lambda () - (with-cmdl/output-port (nearest-cmdl) output-port - (lambda () - (thunk)))))) - -(define (transcript-write value buffer to-transcript?) +(define (transcript-write value buffer) (let ((value-string (if (undefined-value? value) "No value" @@ -441,18 +446,15 @@ FIT Error messages appear in typein window if they fit; (*unparser-list-breadth-limit* (ref-variable transcript-list-breadth-limit))) (write-to-string value)))))) - (let ((value-message (lambda () (message value-string)))) - (if to-transcript? - (with-output-to-mark - (buffer-point buffer) - (lambda () - (fresh-lines 1) - (write-char #\;) - (write-string value-string) - (fresh-lines 2) - (if (null? (buffer-windows buffer)) - (value-message)))) - (value-message))))) + (if buffer + (let ((point (mark-left-inserting-copy (buffer-end buffer)))) + (guarantee-newlines 1 point) + (insert-char #\; point) + (insert-string value-string point) + (insert-newlines 2 point) + (mark-temporary! point))) + (if (or (not buffer) (null? (buffer-windows buffer))) + (message value-string)))) (define (transcript-buffer) (let ((name (ref-variable transcript-buffer-name))) diff --git a/v7/src/edwin/intmod.scm b/v7/src/edwin/intmod.scm index 8d5235c61..6ca52f8d9 100644 --- a/v7/src/edwin/intmod.scm +++ b/v7/src/edwin/intmod.scm @@ -1,6 +1,6 @@ ;;; -*-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 ;;; @@ -42,55 +42,529 @@ ;;; 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)) -(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))))))))) + +(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))) + +;;;; 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) + +;;;; 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)))) + +(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)))) + +;;;; 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))))) + +;;;; 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)) + +;;; 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)))) + +;;; 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)))) + +;;; 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 diff --git a/v7/src/edwin/make.scm b/v7/src/edwin/make.scm index 4f087c12c..26714d19c 100644 --- a/v7/src/edwin/make.scm +++ b/v7/src/edwin/make.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/make.scm,v 3.62 1991/11/04 20:51:20 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/make.scm,v 3.63 1991/11/26 08:03:23 cph Exp $ Copyright (c) 1989-91 Massachusetts Institute of Technology @@ -37,4 +37,4 @@ MIT in each case. |# (declare (usual-integrations)) (package/system-loader "edwin" '() 'QUERY) -(add-system! (make-system "Edwin" 3 62 '())) \ No newline at end of file +(add-system! (make-system "Edwin" 3 63 '())) \ No newline at end of file diff --git a/v7/src/edwin/modefs.scm b/v7/src/edwin/modefs.scm index 267b4377a..06f4a0658 100644 --- a/v7/src/edwin/modefs.scm +++ b/v7/src/edwin/modefs.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/modefs.scm,v 1.135 1991/10/11 03:46:26 cph Exp $ +;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/modefs.scm,v 1.136 1991/11/26 08:03:27 cph Exp $ ;;; ;;; Copyright (c) 1985, 1989-91 Massachusetts Institute of Technology ;;; @@ -62,10 +62,7 @@ Most other major modes are defined by comparison to this one.") (ref-mode-object fundamental)) (define initial-buffer-name - (ref-variable transcript-buffer-name)) - -(define initial-buffer-mode - (->mode (ref-variable transcript-buffer-mode))) + "*repl*") (define-variable file-type-to-major-mode "Specifies the major mode for new buffers based on file type. @@ -236,7 +233,7 @@ Like Fundamental mode, but no self-inserting characters.") (define-key 'fundamental #\c-m-w 'append-next-kill) (define-key 'fundamental #\c-m-rubout 'backward-kill-sexp) -(define-key 'fundamental '(#\c-c #\c-s) 'select-transcript-buffer) +(define-key 'fundamental '(#\c-c #\c-s) 'repl) (define-key 'fundamental '(#\c-h #\a) 'command-apropos) (define-key 'fundamental '(#\c-h #\b) 'describe-bindings) diff --git a/v7/src/edwin/tterm.scm b/v7/src/edwin/tterm.scm index 0523230a8..56a45c07a 100644 --- a/v7/src/edwin/tterm.scm +++ b/v7/src/edwin/tterm.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/tterm.scm,v 1.8 1991/05/09 03:26:15 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/tterm.scm,v 1.9 1991/11/26 08:03:32 cph Exp $ Copyright (c) 1990-91 Massachusetts Institute of Technology @@ -188,8 +188,7 @@ MIT in each case. |# (set! start (fix:+ start 1)) char))))))) -(define (signal-interrupt! interrupt-enables) - interrupt-enables ; ignored +(define (signal-interrupt!) ;; (editor-beep) ; kbd beeps by itself (temporary-message "Quit") (^G-signal)) @@ -234,14 +233,14 @@ MIT in each case. |# (input-port/channel console-input-port)) (terminal-operation terminal-raw-output (output-port/channel console-output-port)) - (set! hook/^g-interrupt signal-interrupt!) (tty-set-interrupt-enables 2) (receiver (lambda (thunk) (bind-console-state (get-outside-state) (lambda (get-inside-state) get-inside-state - (thunk)))))))) + (thunk)))) + `((INTERRUPT/ABORT-TOP-LEVEL ,signal-interrupt!)))))) (define (bind-console-state state receiver) (let ((outside-state) @@ -263,7 +262,6 @@ MIT in each case. |# (define (console-state) (vector (channel-state (input-port/channel console-input-port)) (channel-state (output-port/channel console-output-port)) - hook/^g-interrupt (tty-get-interrupt-enables))) (define (set-console-state! state) @@ -271,8 +269,7 @@ MIT in each case. |# (vector-ref state 0)) (set-channel-state! (output-port/channel console-output-port) (vector-ref state 1)) - (set! hook/^g-interrupt (vector-ref state 2)) - (tty-set-interrupt-enables (vector-ref state 3))) + (tty-set-interrupt-enables (vector-ref state 2))) (define (channel-state channel) (and channel diff --git a/v7/src/edwin/winout.scm b/v7/src/edwin/winout.scm index 3dea2cbd6..a9bbeba9d 100644 --- a/v7/src/edwin/winout.scm +++ b/v7/src/edwin/winout.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/winout.scm,v 1.6 1991/06/18 20:30:48 arthur Exp $ +;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/winout.scm,v 1.7 1991/11/26 08:03:38 cph Exp $ ;;; ;;; Copyright (c) 1986, 1989-91 Massachusetts Institute of Technology ;;; @@ -46,36 +46,22 @@ ;;; package: (edwin window-output-port) (declare (usual-integrations)) - + (define (with-output-to-current-point thunk) (with-output-to-window-point (current-window) thunk)) (define (with-output-to-window-point window thunk) - (with-interactive-output-port (window-output-port window) thunk)) + (with-output-to-port (window-output-port window) thunk)) -(define (with-interactive-output-port port thunk) - (with-output-to-port port - (lambda () - (with-cmdl/output-port (nearest-cmdl) port thunk)))) - (define (window-output-port window) (output-port/copy window-output-port-template window)) (define (operation/fresh-line port) - (if (not (line-start? (window-point (output-port/state port)))) + (if (not (line-start? (window-point (port/state port)))) (operation/write-char port #\newline))) -(define (operation/fresh-lines port n) - (let loop - ((n - (if (line-start? (window-point (output-port/state port))) (-1+ n) n))) - (if (positive? n) - (begin - (operation/write-char port #\newline) - (loop (-1+ n)))))) - (define (operation/write-char port char) - (let ((window (output-port/state port))) + (let ((window (port/state port))) (let ((buffer (window-buffer window)) (point (window-point window))) (if (and (null? (cdr (buffer-windows buffer))) @@ -95,7 +81,7 @@ (region-insert-char! point char))))) (define (operation/write-string port string) - (let ((window (output-port/state port))) + (let ((window (port/state port))) (let ((buffer (window-buffer window)) (point (window-point window))) (if (and (null? (cdr (buffer-windows buffer))) @@ -117,21 +103,20 @@ ;; chance to do refresh if it needs to (e.g. if an X exposure event ;; is received). ((editor-char-ready? current-editor)) - (let ((window (output-port/state port))) + (let ((window (port/state port))) (if (window-needs-redisplay? window) (window-direct-update! window false)))) (define (operation/x-size port) - (window-x-size (output-port/state port))) + (window-x-size (port/state port))) (define (operation/print-self state port) (unparse-string state "to window ") - (unparse-object state (output-port/state port))) + (unparse-object state (port/state port))) (define window-output-port-template (make-output-port `((FLUSH-OUTPUT ,operation/flush-output) (FRESH-LINE ,operation/fresh-line) - (FRESH-LINES ,operation/fresh-lines) (PRINT-SELF ,operation/print-self) (WRITE-CHAR ,operation/write-char) (WRITE-STRING ,operation/write-string) diff --git a/v7/src/edwin/xterm.scm b/v7/src/edwin/xterm.scm index ac51fecfa..d78a216cb 100644 --- a/v7/src/edwin/xterm.scm +++ b/v7/src/edwin/xterm.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/xterm.scm,v 1.23 1991/10/02 21:22:08 jinx Exp $ +;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/xterm.scm,v 1.24 1991/11/26 08:03:42 cph Exp $ ;;; ;;; Copyright (c) 1989-91 Massachusetts Institute of Technology ;;; @@ -477,18 +477,15 @@ (select-screen screen)))))) (define signal-interrupts?) -(define pending-interrupt?) (define timer-interval 1000) (define (signal-interrupt!) (editor-beep) (temporary-message "Quit") - (set! pending-interrupt? false) (^G-signal)) (define (with-editor-interrupts-from-x receiver) (fluid-let ((signal-interrupts? true) - (pending-interrupt? false) (timer-interrupt timer-interrupt-handler)) (dynamic-wind start-timer-interrupt (lambda () @@ -496,7 +493,8 @@ (lambda (thunk) (dynamic-wind stop-timer-interrupt thunk - start-timer-interrupt)))) + start-timer-interrupt)) + '())) stop-timer-interrupt))) (define (set-x-timer-interval! interval) @@ -520,24 +518,10 @@ (clear-interrupts! interrupt-bit/timer)) (define (with-x-interrupts-enabled thunk) - (bind-signal-interrupts? true thunk)) + (fluid-let ((signal-interrupts? true)) (thunk))) (define (with-x-interrupts-disabled thunk) - (bind-signal-interrupts? false thunk)) - -(define (bind-signal-interrupts? new-mask thunk) - (let ((old-mask)) - (dynamic-wind (lambda () - (set! old-mask signal-interrupts?) - (set! signal-interrupts? new-mask) - (if (and new-mask pending-interrupt?) - (signal-interrupt!))) - thunk - (lambda () - (set! new-mask signal-interrupts?) - (set! signal-interrupts? old-mask) - (if (and old-mask pending-interrupt?) - (signal-interrupt!)))))) + (fluid-let ((signal-interrupts? false)) (thunk))) (define x-display-type) (define x-display-data) @@ -569,4 +553,4 @@ with-x-interrupts-disabled)) (set! x-display-data false) (set! x-display-events) - unspecific) + unspecific) \ No newline at end of file -- 2.25.1