290 lines
9.2 KiB
Scheme
290 lines
9.2 KiB
Scheme
#| -*-Scheme-*-
|
||
|
||
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
|
||
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
|
||
2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
|
||
2017, 2018, 2019, 2020 Massachusetts Institute of Technology
|
||
|
||
This file is part of MIT/GNU Scheme.
|
||
|
||
MIT/GNU Scheme is free software; you can redistribute it and/or modify
|
||
it under the terms of the GNU General Public License as published by
|
||
the Free Software Foundation; either version 2 of the License, or (at
|
||
your option) any later version.
|
||
|
||
MIT/GNU Scheme is distributed in the hope that it will be useful, but
|
||
WITHOUT ANY WARRANTY; without even the implied warranty of
|
||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
||
General Public License for more details.
|
||
|
||
You should have received a copy of the GNU General Public License
|
||
along with MIT/GNU Scheme; if not, write to the Free Software
|
||
Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
|
||
USA.
|
||
|
||
|#
|
||
|
||
;;;; Edwin Interface to YStep
|
||
|
||
|
||
|
||
(define-command step-expression
|
||
"Single-step an expression."
|
||
"xExpression to step"
|
||
(lambda (expression)
|
||
(with-stepper-evaluation-context
|
||
(lambda ()
|
||
(step-form expression (evaluation-environment #f))))))
|
||
|
||
(define-command step-last-sexp
|
||
"Single-step the expression preceding point."
|
||
()
|
||
(lambda ()
|
||
(step-region (let ((point (current-point)))
|
||
(make-region (backward-sexp point 1 'ERROR) point))
|
||
(evaluation-environment #f))))
|
||
|
||
(define-command step-defun
|
||
"Single-step the definition that the point is in or before."
|
||
()
|
||
(lambda ()
|
||
(step-region (let ((start (current-definition-start)))
|
||
(make-region start (forward-sexp start 1 'ERROR)))
|
||
(evaluation-environment #f))))
|
||
|
||
(define (step-region region environment)
|
||
(with-stepper-evaluation-context
|
||
(lambda ()
|
||
(step-form (with-input-from-region region read) environment))))
|
||
|
||
(define (with-stepper-evaluation-context thunk)
|
||
(bind-condition-handler (list condition-type:error)
|
||
evaluation-error-handler
|
||
(lambda ()
|
||
(parameterize ((current-input-port dummy-i/o-port))
|
||
(with-output-to-transcript-buffer thunk)))))
|
||
|
||
;;;; Stepper Mode
|
||
|
||
(define-major-mode stepper read-only-noarg "Stepper"
|
||
"Major mode for the stepper.
|
||
space advances the computation by one step
|
||
o steps over the current expression
|
||
u step over, but show the intervening events
|
||
U step over, show and animate intervening events
|
||
r run current expression to completion without stepping
|
||
e expand the step under the cursor
|
||
c contract the step under the cursor")
|
||
|
||
(define-key 'stepper #\space 'stepper-step)
|
||
(define-key 'stepper #\o 'stepper-step-over)
|
||
(define-key 'stepper #\u 'stepper-step-until)
|
||
(define-key 'stepper #\U 'stepper-step-until-visible)
|
||
(define-key 'stepper #\r 'stepper-run)
|
||
(define-key 'stepper #\e 'stepper-expand)
|
||
(define-key 'stepper #\c 'stepper-contract)
|
||
(define-key 'stepper #\? 'stepper-summary)
|
||
|
||
(define-command stepper-summary
|
||
"Summarize the stepper commands in the typein window."
|
||
()
|
||
(lambda ()
|
||
(message "Space: single step, o: step over, e: expand, c: contract")))
|
||
|
||
(define-command stepper-step
|
||
"Single step. With argument, step multiple times."
|
||
"p"
|
||
(lambda (argument) (step-n (current-stepper-state) argument)))
|
||
|
||
(define-command stepper-run
|
||
"Run current eval to completion without stepping."
|
||
()
|
||
(lambda () (step-run (current-stepper-state))))
|
||
|
||
(define-command stepper-step-until
|
||
"Step until current eval completes."
|
||
()
|
||
(lambda () (step-until (current-stepper-state))))
|
||
|
||
(define-command stepper-step-until-visibly
|
||
"Step until current eval completes, showing each step as it happens."
|
||
()
|
||
(lambda () (step-until-visibly (current-stepper-state))))
|
||
|
||
(define-command stepper-step-over
|
||
"Step over the current eval."
|
||
()
|
||
(lambda () (step-over (current-stepper-state))))
|
||
|
||
(define-command stepper-expand
|
||
"Expand the current step."
|
||
()
|
||
(lambda ()
|
||
(let ((state (current-stepper-state))
|
||
(node (current-node)))
|
||
(ynode-expand! node)
|
||
(edwin-step-output state #f `(EXPAND ,node)))))
|
||
|
||
(define-command stepper-contract
|
||
"Contract the current step."
|
||
()
|
||
(lambda ()
|
||
(let ((state (current-stepper-state))
|
||
(node (current-node)))
|
||
(ynode-contract! node)
|
||
(edwin-step-output state #f `(CONTRACT ,node)))))
|
||
|
||
;;;; Stepper Output Interface
|
||
|
||
(define (initialize-package!)
|
||
;; Load the stepper and grab its output hooks.
|
||
(load-option 'STEPPER)
|
||
(set! step-output-initialize edwin-step-output-initialize)
|
||
(set! step-output edwin-step-output)
|
||
(set! step-output-final-result edwin-step-output-final-result)
|
||
unspecific)
|
||
|
||
(define (edwin-step-output-initialize state)
|
||
(select-buffer-other-window (get-stepper-buffer state)))
|
||
|
||
(define (get-stepper-buffer state)
|
||
(let ((buffer (new-buffer "*Stepper*")))
|
||
(add-kill-buffer-hook buffer kill-stepper-buffer)
|
||
(buffer-put! buffer 'STEPPER-STATE state)
|
||
(hash-table-set! stepper-buffers state buffer)
|
||
(set-buffer-read-only! buffer)
|
||
(set-buffer-major-mode! buffer (ref-mode-object stepper))
|
||
buffer))
|
||
|
||
(define (kill-stepper-buffer buffer)
|
||
(let ((state (buffer-get buffer 'STEPPER-STATE)))
|
||
(if state
|
||
(hash-table-delete! stepper-buffers state)))
|
||
(buffer-remove! buffer 'STEPPER-STATE))
|
||
|
||
(define (buffer->stepper-state buffer)
|
||
(or (buffer-get buffer 'STEPPER-STATE)
|
||
(error:bad-range-argument buffer 'BUFFER->STEPPER-STATE)))
|
||
|
||
(define (stepper-state->buffer state)
|
||
(or (hash-table-ref/default stepper-buffers state #f)
|
||
(get-stepper-buffer state)))
|
||
|
||
(define stepper-buffers
|
||
(make-key-weak-eq-hash-table))
|
||
|
||
(define (current-stepper-state)
|
||
(buffer->stepper-state (current-buffer)))
|
||
|
||
(define (edwin-step-output-final-result state result)
|
||
state
|
||
(editor-error
|
||
(string-append "Stepping terminated with result "
|
||
(write-to-string result))))
|
||
|
||
(define (current-node)
|
||
(let ((point (current-point)))
|
||
(or (get-text-property (mark-group point)
|
||
(mark-index point)
|
||
'STEPPER-NODE
|
||
#f)
|
||
(editor-error "Point not pointing to stepper node."))))
|
||
|
||
(define (get-buffer-ynode-regions buffer)
|
||
(or (buffer-get buffer 'YNODE-REGIONS)
|
||
(let ((table (make-key-weak-eq-hash-table)))
|
||
(buffer-put! buffer 'YNODE-REGIONS table)
|
||
table)))
|
||
|
||
(define (clear-ynode-regions! regions)
|
||
(for-each mark-temporary! (hash-table-values regions))
|
||
(hash-table-clear! regions))
|
||
|
||
(define (ynode-start-mark regions node)
|
||
(hash-table-ref/default regions node #f))
|
||
|
||
(define (save-ynode-region! regions node start end)
|
||
(hash-table-set! regions node (mark-temporary-copy start))
|
||
(add-text-property (mark-group start) (mark-index start) (mark-index end)
|
||
'STEPPER-NODE node))
|
||
|
||
(define (edwin-step-output state redisplay? #!optional last-event)
|
||
(let ((buffer (stepper-state->buffer state))
|
||
(last-event
|
||
(if (default-object? last-event)
|
||
(stepper-last-event state)
|
||
last-event)))
|
||
(let ((regions (get-buffer-ynode-regions buffer)))
|
||
(clear-ynode-regions! regions)
|
||
(with-read-only-defeated (buffer-start buffer)
|
||
(lambda ()
|
||
(delete-string (buffer-start buffer) (buffer-end buffer))
|
||
(let ((node (stepper-root-node state))
|
||
(start (mark-right-inserting-copy (buffer-start buffer)))
|
||
(point (mark-left-inserting-copy (buffer-start buffer))))
|
||
(let loop ((node node) (level 0))
|
||
(if (not (eq? (ynode-type node) 'STEPPED-OVER))
|
||
(begin
|
||
(move-mark-to! start point)
|
||
(output-and-mung-region point
|
||
(lambda ()
|
||
(let ((special (ynode-exp-special node)))
|
||
(if special
|
||
(begin
|
||
(write-string ";")
|
||
(write special))
|
||
(debugger-pp (ynode-exp node)
|
||
(* 2 level)
|
||
(current-output-port)))))
|
||
(and last-event
|
||
(eq? (car last-event) 'CALL)
|
||
(eq? (cadr last-event) node)
|
||
(lambda (region)
|
||
(highlight-region-excluding-indentation
|
||
region (highlight-face)))))
|
||
(insert-string (if (ynode-hidden-children? node)
|
||
" ===> "
|
||
" => ")
|
||
point)
|
||
(let ((value-node (ynode-value-node node)))
|
||
(output-and-mung-region point
|
||
(lambda ()
|
||
(let ((node
|
||
(if (eq? (ynode-type node) 'STEP-OVER)
|
||
value-node
|
||
node)))
|
||
(let ((special (ynode-result-special node)))
|
||
(if special
|
||
(begin
|
||
(write-string ";")
|
||
(write special))
|
||
(write (ynode-result node))))))
|
||
(and last-event
|
||
(eq? (car last-event) 'RETURN)
|
||
(eq? (cadr last-event) value-node)
|
||
(lambda (region)
|
||
(highlight-region region (highlight-face))))))
|
||
(insert-newline point)
|
||
(save-ynode-region! regions node start point)
|
||
(if (not (eq? 'STEP-OVER (ynode-type node)))
|
||
(for-each (lambda (n) (loop n (+ level 1)))
|
||
(reverse (ynode-children node)))))))
|
||
(mark-temporary! point)
|
||
(mark-temporary! start))))
|
||
(buffer-not-modified! buffer)
|
||
(if last-event
|
||
(let ((start (ynode-start-mark regions (cadr last-event))))
|
||
(if start
|
||
(set-buffer-point! buffer start))))))
|
||
(if redisplay? (update-screens! '(IGNORE-INPUT))))
|
||
|
||
(define (output-and-mung-region point thunk region-munger)
|
||
;; Display something in the stepper buffer and then run something on
|
||
;; it. REGION-MUNGER takes one argument, a region.
|
||
(let ((start (mark-right-inserting-copy point)))
|
||
(with-output-to-mark point thunk)
|
||
(if region-munger (region-munger (make-region start point)))
|
||
(mark-temporary! start)))
|
||
|
||
(initialize-package!)
|