--- /dev/null
+;;; -*-Scheme-*-
+;;;
+;;; $Id: eystep.scm,v 1.1 1994/10/12 07:54:09 cph Exp $
+;;;
+;;; Copyright (c) 1994 Massachusetts Institute of Technology
+;;;
+;;; This material was developed by the Scheme project at the
+;;; Massachusetts Institute of Technology, Department of
+;;; Electrical Engineering and Computer Science. Permission to
+;;; copy this software, to redistribute it, and to use it for any
+;;; purpose is granted, subject to the following restrictions and
+;;; understandings.
+;;;
+;;; 1. Any copy made of this software must include this copyright
+;;; notice in full.
+;;;
+;;; 2. Users of this software agree to make their best efforts (a)
+;;; to return to the MIT Scheme project any improvements or
+;;; extensions that they make, so that these may be included in
+;;; future releases; and (b) to inform MIT of noteworthy uses of
+;;; this software.
+;;;
+;;; 3. All materials developed as a consequence of the use of this
+;;; software shall duly acknowledge such use, in accordance with
+;;; the usual standards of acknowledging credit in academic
+;;; research.
+;;;
+;;; 4. MIT has made no warrantee or representation that the
+;;; operation of this software will be error-free, and MIT is
+;;; under no obligation to provide any services, by way of
+;;; maintenance, update, or otherwise.
+;;;
+;;; 5. In conjunction with products arising from the use of this
+;;; material, there shall be no use of the name of the
+;;; Massachusetts Institute of Technology nor of any adaptation
+;;; thereof in any advertising, promotional, or sales literature
+;;; without prior written consent from MIT in each case.
+;;;
+;;; NOTE: Parts of this program (Edwin) were created by translation
+;;; from corresponding parts of GNU Emacs. Users should be aware that
+;;; the GNU GENERAL PUBLIC LICENSE may apply to these parts. A copy
+;;; of that license should have been included along with this file.
+;;;
+
+;;;; Edwin Interface to YStep
+
+(declare (usual-integrations))
+\f
+(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 ()
+ (with-input-from-port dummy-i/o-port
+ (lambda ()
+ (with-output-to-transcript-buffer thunk))))))
+\f
+;;;; 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 intevening 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)))))
+\f
+;;;; 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/put! 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/remove! 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/get stepper-buffers state #f)
+ (get-stepper-buffer state)))
+
+(define stepper-buffers
+ (make-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-eq-hash-table)))
+ (buffer-put! buffer 'YNODE-REGIONS table)
+ table)))
+
+(define (clear-ynode-regions! regions)
+ (for-each mark-temporary! (hash-table/datum-list regions))
+ (hash-table/clear! regions))
+
+(define (ynode-start-mark regions node)
+ (hash-table/get regions node #f))
+
+(define (save-ynode-region! regions node start end)
+ (hash-table/put! regions node (mark-temporary-copy start))
+ (add-text-property (mark-group start) (mark-index start) (mark-index end)
+ 'STEPPER-NODE node))
+\f
+(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 ()
+ (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
+ #t))))
+ (insert-string (if (ynode-hidden-children? node)
+ " ===> "
+ " => ")
+ point)
+ (let ((value-node (ynode-value-node node)))
+ (output-and-mung-region point
+ (lambda ()
+ (write
+ (ynode-result
+ (if (eq? (ynode-type node) 'STEP-OVER)
+ value-node
+ node))))
+ (and last-event
+ (eq? (car last-event) 'RETURN)
+ (eq? (cadr last-event) value-node)
+ (lambda (region)
+ (highlight-region region #t)))))
+ (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! #f)))
+
+(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!)
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: ystep.scm,v 1.1 1994/10/12 07:54:00 cph Exp $
+
+Copyright (c) 1994 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; YStep - a step away from ZStep
+;;; package: (runtime stepper)
+
+(declare (usual-integrations))
+\f
+(define-structure (stepper (constructor make-stepper (stack)))
+ (stack '())
+ (run? #f) ;#t => run; #f => step
+ (step-over #f) ;#f or top node of step-over
+ (step-until? #f) ;the step-over is really a step-until
+ next ;continuation of stepped program
+ continuation
+ last-event ;last thing that happened
+ (finished #f) ;when completed, stack is
+ ;empty and this points to top node
+ hooks ;low-level stepper hooks
+ (trace '()) ;low-level trace recording
+ )
+
+(define (stack-push! state node)
+ (set-stepper-stack! state (cons node (stepper-stack state))))
+
+(define (stack-pop! state)
+ (set-stepper-stack! state (cdr (stepper-stack state))))
+
+(define (stack-top state)
+ (car (stepper-stack state)))
+
+(define (stack-bottom state)
+ (car (last-pair (stepper-stack state))))
+
+(define (stack-empty? state)
+ (null? (stepper-stack state)))
+
+(define (stepper-root-node state)
+ (if (stack-empty? state)
+ (stepper-finished state)
+ (stack-bottom state)))
+
+;;; The magic numbers here represent the number of eval and return
+;;; events that occur during the startup process. They will very
+;;; likely have to change when the system changes.
+
+(define (step-form expression environment)
+ ;; start a new evaluation
+ (step-start (make-ynode #f 'TOP ynode-exp:top-level)
+ (lambda () (eval expression environment))
+ (if (stepper-compiled?) 0 6)
+ (if (stepper-compiled?) 1 5)))
+
+(define (step-proceed)
+ ;; proceed from breakpoint
+ (step-start (make-ynode #f 'PROCEED ynode-exp:proceed)
+ (lambda () (continue))
+ (if (stepper-compiled?) 0 4)
+ (if (stepper-compiled?) 5 7)))
+
+(define (stepper-compiled?)
+ (compiled-procedure? (lambda () unspecific)))
+
+(define (step-start top-node thunk skip-evals skip-returns)
+ (if (not (step-hooks-present?))
+ (error "Sorry, this copy of Scheme does not support stepping."))
+ (let ((state (make-stepper (list top-node))))
+ (set-stepper-hooks! state (make-stepper-hooks state))
+ (set-stepper-next! state
+ (lambda ()
+ (dummy-eval-step
+ (make-starting-hooks state skip-evals skip-returns))
+ (thunk)))
+ (step-output-initialize state)
+ (step state)))
+\f
+(define (step state)
+ (set-stepper-run?! state #f)
+ (raw-step state))
+
+(define (step-run state)
+ (set-stepper-run?! state #t)
+ (raw-step state))
+
+(define (step-quit state)
+ ;; [entry] not working yet
+ (dummy-eval-step no-step-hooks)
+ ((stepper-next state)))
+
+(define (step-n state n)
+ (do ((n n (- n 1))
+ (value unspecific (step state)))
+ ((<= n 0) value)))
+
+(define (step-over state)
+ (set-stepper-step-until?! state #f)
+ (step-over-1 state))
+
+(define (step-until state)
+ (set-stepper-step-until?! state #t)
+ (step-over-1 state))
+
+(define (step-until-visibly state)
+ (set-stepper-step-until?! state 'ANIMATE)
+ (step-over-1 state))
+
+(define (step-over-1 state)
+ (if (not (eq? (car (stepper-last-event state)) 'CALL))
+ (error "Last event was not a call:" (stepper-last-event state)))
+ (set-stepper-step-over! state (stack-top state))
+ (new-ynode-type! (stack-top state)
+ (if (stepper-step-until? state) 'EVAL 'STEP-OVER))
+ (raw-step state))
+
+(define (raw-step state)
+ ;; the workhorse
+ (if (stepper-finished state)
+ (step-output-final-result state (ynode-result (stepper-finished state)))
+ (begin
+ (set-stepper-next! state
+ (call-with-current-continuation
+ (lambda (kk)
+ (set-stepper-continuation! state kk)
+ ((stepper-next state)))))
+ (if (stepper-run? state)
+ (raw-step state)
+ (step-output state #f)))))
+
+;;; Output Stubs:
+
+(define (step-output-initialize state)
+ state
+ unspecific)
+
+(define (step-output state redisplay?)
+ state redisplay?
+ unspecific)
+
+(define (step-output-final-result state value)
+ state
+ value)
+\f
+;;;; Low-level Hooks
+
+(define (make-stepper-hooks state)
+ (letrec
+ ((hooks
+ (hunk3-cons
+ (lambda (expr env)
+ (hook-record state
+ (list 'EVAL (map-reference-trap (lambda () expr)) env))
+ (process-eval state (map-reference-trap (lambda () expr)))
+ (primitive-eval-step expr env hooks))
+ (lambda (proc . args)
+ (hook-record state
+ (list 'APPLY
+ proc
+ (map (lambda (arg)
+ (map-reference-trap (lambda () arg)))
+ args)))
+ (process-apply state proc)
+ (primitive-apply-step proc args hooks))
+ (lambda (value)
+ (hook-record state
+ (list 'RETURN (map-reference-trap (lambda () value))))
+ (process-return state (map-reference-trap (lambda () value)))
+ (primitive-return-step value hooks)))))
+ hooks))
+
+(define (make-starting-hooks state skip-evals skip-returns)
+ (letrec
+ ((hooks
+ (hunk3-cons
+ (lambda (expr env)
+ (if (and (<= skip-evals 0) (<= skip-returns 0))
+ ((system-hunk3-cxr0 (stepper-hooks state)) expr env)
+ (begin
+ (set! skip-evals (- skip-evals 1))
+ (hook-record state (list 'EVAL expr env))
+ (primitive-eval-step expr env hooks))))
+ #f
+ (lambda (result)
+ (if (and (<= skip-evals 0) (<= skip-returns 0))
+ ((system-hunk3-cxr2 (stepper-hooks state)) result)
+ (begin
+ (set! skip-returns (- skip-returns 1))
+ (hook-record state (list 'RESULT result))
+ (primitive-return-step result hooks)))))))
+ hooks))
+
+(define no-step-hooks
+ (hunk3-cons #f #f #f))
+
+(define-integrable primitive-eval-step
+ (ucode-primitive primitive-eval-step))
+
+(define-integrable primitive-apply-step
+ (ucode-primitive primitive-apply-step))
+
+(define-integrable primitive-return-step
+ (ucode-primitive primitive-return-step))
+\f
+;;;; Worker Bees
+
+(define (process-eval state exp)
+ (if (reduction? exp (ynode-exp (stack-top state)))
+ (process-reduction state))
+ (let ((node
+ (make-ynode (and (not (stack-empty? state))
+ (stack-top state))
+ (if (and (stepper-step-over state)
+ (not (stepper-step-until? state)))
+ 'STEPPED-OVER
+ 'EVAL)
+ exp)))
+ (stack-push! state node)
+ (set-stepper-last-event! state `(CALL ,node))
+ (maybe-redisplay state)))
+
+(define (process-apply state proc)
+ (if (compound-procedure? proc)
+ (process-reduction state)))
+
+(define (process-return state result)
+ (if (stepper-step-over state)
+ (maybe-end-step-over state))
+ (let ((node
+ (let ((node (stack-top state)))
+ (if (eq? (ynode-type node) 'PROCEED)
+ (ynode-splice-under node)
+ (begin
+ (stack-pop! state)
+ node)))))
+ (new-ynode-result! node result)
+ (if (stack-empty? state)
+ (set-stepper-finished! state node))
+ (set-stepper-last-event! state `(RETURN ,node))
+ (maybe-redisplay state)))
+
+(define (maybe-redisplay state)
+ (if (stepper-step-over state)
+ (if (eq? (stepper-step-until? state) 'ANIMATE)
+ (step-output state #t))
+ (call-with-current-continuation
+ (lambda (k)
+ ((stepper-continuation state) (lambda () (k unspecific)))))))
+
+(define (maybe-end-step-over state)
+ (if (ynode-reduces-to? (stack-top state) (stepper-step-over state))
+ (begin
+ (set-stepper-step-over! state #f)
+ (set-stepper-step-until?! state #f))))
+
+(define (process-reduction state)
+ (new-ynode-result! (stack-top state) ynode-result:reduced)
+ (stack-pop! state))
+
+(define (reduction? f1 f2)
+ ;; Args are SCode expressions. True if F2 is a reduction of F1.
+ (cond ((conditional? f2)
+ (or (eq? f1 (conditional-consequent f2))
+ (eq? f1 (conditional-alternative f2))))
+ ((sequence? f2)
+ (eq? f1 (car (last-pair (sequence-actions f2)))))
+ (else #f)))
+\f
+;;;; Stepper nodes
+
+(define-structure (ynode (constructor make-ynode-1 (parent type exp)))
+ ;; Could easily store environment as well.
+ parent
+ type
+ (exp #f read-only #t)
+ (children '())
+ (result #f)
+ (redisplay-flags (cons #t (if parent (ynode-redisplay-flags parent) '()))
+ read-only #t))
+
+(define ynode-exp:top-level (list 'STEPPER-TOP-LEVEL))
+(define ynode-exp:proceed (list 'STEPPER-PROCEED))
+
+(define ynode-result:waiting (list '<WAITING>))
+(define ynode-result:reduced (list '<REDUCED>))
+(define ynode-result:unknown (list '<UNKNOWN>))
+
+(define (ynode-reduced? node)
+ (eq? (ynode-result node) ynode-result:reduced))
+
+(define (make-ynode parent type exp)
+ (let ((node (make-ynode-1 parent type exp)))
+ (set-ynode-result! node ynode-result:waiting)
+ (if parent
+ (set-ynode-children! parent (cons node (ynode-children parent))))
+ (ynode-needs-redisplay! node)
+ node))
+
+(define (ynode-previous node)
+ (let loop ((sibs (ynode-children (ynode-parent node))))
+ (cond ((null? sibs)
+ #f)
+ ((eq? (car sibs) node)
+ (and (not (null? (cdr sibs)))
+ (cadr sibs)))
+ (else
+ (loop (cdr sibs))))))
+
+(define (ynode-next node)
+ (let loop ((sibs (ynode-children (ynode-parent node))))
+ (cond ((or (null? sibs) (null? (cdr sibs)))
+ #f)
+ ((eq? (cadr sibs) node)
+ (car sibs))
+ (else
+ (loop (cdr sibs))))))
+
+(define (ynode-value-node node)
+ (if (ynode-reduced? node)
+ (let ((next (ynode-next node)))
+ (and next
+ (ynode-value-node next)))
+ node))
+
+(define (ynode-reduces-to? node reduces-to)
+ (and node
+ (or (eq? node reduces-to)
+ (let ((previous (ynode-previous node)))
+ (and previous
+ (ynode-reduced? previous)
+ (ynode-reduces-to? previous reduces-to))))))
+
+(define (ynode-splice-under node)
+ (let ((children (ynode-children node)))
+ (set-ynode-children! node '())
+ (let ((new-node (make-ynode node 'EVAL ynode-result:unknown)))
+ (set-ynode-children! new-node children)
+ (for-each (lambda (c) (set-ynode-parent! c new-node)) children)
+ (let loop ((node new-node))
+ (ynode-needs-redisplay! ynode)
+ (for-each loop (ynode-children node)))
+ new-node)))
+\f
+(define (ynode-reductions node)
+ (if (ynode-reduced? node)
+ (let ((next (ynode-next node)))
+ (cons next (ynode-reductions next)))
+ '()))
+
+(define (ynode-dependents node)
+ ;; A dependent (misnomer) roughly means nodes that are directly
+ ;; called by another node (which is not the same as children,
+ ;; because reductions muck things up).
+ (if (ynode-reduced? node)
+ (cons (ynode-next node)
+ (ynode-direct-children node))
+ (ynode-direct-children node)))
+
+(define (ynode-direct-children node)
+ ;; A "direct" child is one that is not a reduction of another child...
+ (let loop ((children (ynode-children node)) (dependents '()))
+ (if (null? children)
+ dependents
+ (loop (cdr children)
+ (if (and (not (null? (cdr children)))
+ (ynode-reduced? (cadr children)))
+ dependents
+ (cons (car children) dependents))))))
+
+(define (ynode-hidden-children? node)
+ ;; used to control drawing of arrow
+ (and (eq? (ynode-type node) 'STEP-OVER)
+ (not (null? (ynode-children node)))))
+
+(define (ynode-needs-redisplay! ynode)
+ (if (not (car (ynode-redisplay-flags ynode)))
+ (begin
+ (set-car! (ynode-redisplay-flags ynode) #t)
+ (if (ynode-parent ynode)
+ (ynode-needs-redisplay! (ynode-parent ynode))))))
+
+(define (ynode-needs-redisplay? ynode)
+ (car (ynode-redisplay-flags ynode)))
+
+(define (ynode-doesnt-need-redisplay! ynode)
+ (set-car! (ynode-redisplay-flags ynode) #f))
+
+(define (new-ynode-type! ynode type)
+ (set-ynode-type! ynode type)
+ (ynode-needs-redisplay! ynode))
+
+(define (new-ynode-result! ynode result)
+ (set-ynode-result! ynode result)
+ (ynode-needs-redisplay! ynode))
+
+(define (ynode-expand! node)
+ (new-ynode-type! node 'EVAL)
+ (for-each (lambda (dependent)
+ (if (eq? (ynode-type dependent) 'STEPPED-OVER)
+ (new-ynode-type! dependent 'STEP-OVER)))
+ (ynode-dependents node)))
+
+(define (ynode-contract! node)
+ (new-ynode-type! node 'STEP-OVER)
+ (for-each (lambda (dependent)
+ (new-ynode-type! dependent 'STEPPED-OVER))
+ (ynode-reductions node)))
+\f
+;;;; Miscellaneous
+
+(define (dummy-eval-step hooks)
+ (primitive-eval-step #f system-global-environment hooks))
+
+(define (step-hooks-present?)
+ (let ((flag #f))
+ (dummy-eval-step
+ (hunk3-cons #f
+ #f
+ (lambda (value)
+ (set! flag #t)
+ (primitive-return-step value no-step-hooks))))
+ flag))
+
+;;; Debugging trace:
+
+;;; disabled, see next definition
+;;; (define (hook-record state item)
+;;; (set-stepper-trace! state (cons item (stepper-trace state))))
+
+(define-integrable (hook-record state item)
+ ;; DEFINE-INTEGRABLE guarantees that argument in ITEM position is
+ ;; not evaluated.
+ state item
+ unspecific)
+
+(define (print-hook-trace state)
+ (pp (let loop ((thing (stepper-trace state)))
+ (cond ((list? thing) (map loop thing))
+ ((symbol? thing) thing)
+ (else (unsyntax thing))))))
\ No newline at end of file
projects / mit-scheme.git / commitdiff