* Misc reformatting in model.ss
* A much improved display-break gadget svn: r4012
This commit is contained in:
Eli Barzilay
parent
96846c44ff
commit
d8d91aff0b
|
|
@ -1,38 +1,67 @@
|
|||
(module display-break-stuff mzscheme
|
||||
|
||||
(require (lib "mred.ss" "mred")
|
||||
(lib "class.ss")
|
||||
"marks.ss")
|
||||
|
||||
|
||||
(require (lib "mred.ss" "mred") (lib "class.ss") "marks.ss")
|
||||
|
||||
(provide display-break-stuff)
|
||||
|
||||
;; display-break-stuff : show the information associated with a breakpoint. Useful for
|
||||
;; people building steppers for new languages
|
||||
(define (display-break-stuff break-number mark-set break-kind returned-value-list)
|
||||
(define f (instantiate frame% () [label "breakpoint information"] [width 300] [height 500]))
|
||||
(define ec (instantiate editor-canvas% () [parent f]))
|
||||
(define t (instantiate text% ()))
|
||||
(send ec set-editor t)
|
||||
(send f show #t)
|
||||
(send t insert (format "breakpoint number: ~v\n\n" break-number))
|
||||
(send t insert (format "break-kind: ~v \n\n" break-kind))
|
||||
(send t insert "marks:\n")
|
||||
(if mark-set
|
||||
(map (display-breakpoint-mark t) (extract-mark-list mark-set))
|
||||
(send t insert " no mark-set!\n"))
|
||||
(send t insert "\nreturned-value-list:\n")
|
||||
(send t insert (format " ~v\n" returned-value-list)))
|
||||
|
||||
(define ((display-breakpoint-mark t) mark)
|
||||
(let* ([em (expose-mark mark)]
|
||||
[source (car em)]
|
||||
[label (cadr em)]
|
||||
[binding-set (caddr em)])
|
||||
(send t insert "\n")
|
||||
(send t insert (format " label: ~v\n" label))
|
||||
;; we really want one of those nice collapsible syntax-viewer thingies here:
|
||||
(send t insert (format " source : ~v\n" (syntax-object->datum source)))
|
||||
;; here too, though this isn't a syntax object.
|
||||
(send t insert (format " bindings: ~v\n" binding-set))))
|
||||
)
|
||||
|
||||
(define f
|
||||
(new frame%
|
||||
[label (format "Breakpoints Inspector")]
|
||||
[width 400] [height 500]))
|
||||
(define sel (new choice% [label "Breakpoint#"] [choices '()] [parent f]
|
||||
[callback (lambda (c e) (show-sel))] [stretchable-width #t]))
|
||||
(define ec (new editor-canvas% [parent f]))
|
||||
(define t (new text%))
|
||||
(send ec set-editor t)
|
||||
|
||||
(define selections '())
|
||||
(define (add-sel num mset bkind retvals)
|
||||
(set! selections (cons (list num mset bkind retvals) selections))
|
||||
(let ([num (number->string num)])
|
||||
(send sel append num)
|
||||
(send sel set-string-selection num)
|
||||
(show-sel)))
|
||||
|
||||
(define (show-sel)
|
||||
(let* ([num (string->number (send sel get-string-selection))]
|
||||
[bpt (assq num selections)])
|
||||
(send* t (lock #f) (erase))
|
||||
(if (not bpt)
|
||||
(send* t (insert (format "Breakpoint #~a not found!\n" num)))
|
||||
(let-values ([(mset bkind retvals) (apply values (cdr bpt))])
|
||||
(send* t
|
||||
(insert (format "Breakpoint #~a:\n" num))
|
||||
(insert (format " break-kind: ~v\n" bkind))
|
||||
(insert "marks:\n"))
|
||||
(if mset
|
||||
(for-each
|
||||
(lambda (mark)
|
||||
(let* ([em (expose-mark mark)]
|
||||
[source (car em)]
|
||||
[label (cadr em)]
|
||||
[binding-set (caddr em)])
|
||||
(send* t
|
||||
(insert (format " label: ~v\n" label))
|
||||
;; we really want one of those nice collapsible
|
||||
;; syntax-viewer thingies here:
|
||||
(insert (format " source : ~v\n"
|
||||
(syntax-object->datum source)))
|
||||
;; here too, though this isn't a syntax object.
|
||||
(insert (format " bindings: ~v\n" binding-set)))))
|
||||
(extract-mark-list mset))
|
||||
(send t insert " nothing!\n"))
|
||||
(send t insert "returned-value-list:\n")
|
||||
(if retvals
|
||||
(for-each (lambda (v) (send t insert (format " ~v\n" v)))
|
||||
retvals)
|
||||
(send t insert " nothing!\n"))))
|
||||
(send* t (lock #t))))
|
||||
|
||||
;; display-break-stuff : show the information associated with a breakpoint.
|
||||
;; Useful for people building steppers for new languages
|
||||
(define (display-break-stuff break-number mark-set break-kind
|
||||
returned-value-list)
|
||||
(add-sel break-number mark-set break-kind returned-value-list)
|
||||
(send f show #t))
|
||||
|
||||
)
|
||||
|
|
|
|||
|
|
@ -1,25 +1,28 @@
|
|||
;step collector state machine (not yet implemented):
|
||||
;
|
||||
;
|
||||
; datatype held-type = NO-HELD-STEP | SKIPPED-STEP | HELD(args)
|
||||
;
|
||||
; states: global state of held
|
||||
; global: held : held-type
|
||||
; edge-names: first, skipped-first, second, skipped-second, double, late-let
|
||||
; edge-names: first, skipped-first, second, skipped-second, double, late-let
|
||||
;
|
||||
;transitions (& actions):
|
||||
;
|
||||
; held = NO-HELD-STEP :
|
||||
; held = NO-HELD-STEP :
|
||||
; first(x) : held := HELD(x)
|
||||
; skipped-first : held := SKIPPED-STEP
|
||||
; second(x) : trigger(NO-HELD-STEP, x), held := NO-HELD-STEP ; this happens when evaluating unannotated code
|
||||
; skipped-second : held := NO-HELD-STEP ; I believe this can also arise in unannotated code
|
||||
; second(x) : trigger(NO-HELD-STEP, x), held := NO-HELD-STEP
|
||||
; this happens when evaluating unannotated code
|
||||
; skipped-second : held := NO-HELD-STEP
|
||||
; I believe this can also arise in unannotated code
|
||||
; double(x) : double-trigger(x), held := NO-HELD-STEP
|
||||
; late-let(x) : late-let-trigger(x), held := NO-HELD-STEP
|
||||
;
|
||||
; held = SOME(SKIPPED-STEP) :
|
||||
; first(x) : ERROR
|
||||
; skipped-first : ERROR
|
||||
; second(x) : held := NO-HELD-STEP ; this happens e.g. for evaluation of top-level var bound to a procedure
|
||||
; second(x) : held := NO-HELD-STEP
|
||||
; this happens e.g. for evaluation of top-level var bound to a procedure
|
||||
; skipped-second : held := NO-HELD-STEP
|
||||
; double(x) : ERROR
|
||||
; late-let(x) : ERROR
|
||||
|
|
@ -43,95 +46,108 @@
|
|||
"marks.ss"
|
||||
"model-settings.ss"
|
||||
"macro-unwind.ss"
|
||||
|
||||
;; for breakpoint display
|
||||
"display-break-stuff.ss")
|
||||
|
||||
|
||||
|
||||
(define program-expander-contract
|
||||
((-> void?) ; init
|
||||
((or/c eof-object? syntax? (cons/c string? any/c)) (-> void?) . -> . void?) ; iter
|
||||
((or/c eof-object? syntax? (cons/c string? any/c)) (-> void?)
|
||||
. -> . void?) ; iter
|
||||
. -> .
|
||||
void?))
|
||||
|
||||
|
||||
(provide/contract [go (program-expander-contract ; program-expander
|
||||
(step-result? . -> . void?) ; receive-result
|
||||
(or/c render-settings? false/c) ; render-settings
|
||||
boolean? ; track-inferred-names?
|
||||
string? ; language-level-name
|
||||
(procedure? . -> . void?) ; run-on-drscheme-side
|
||||
. -> .
|
||||
void?)])
|
||||
|
||||
|
||||
(provide/contract
|
||||
[go (program-expander-contract ; program-expander
|
||||
(step-result? . -> . void?) ; receive-result
|
||||
(or/c render-settings? false/c) ; render-settings
|
||||
boolean? ; track-inferred-names?
|
||||
string? ; language-level-name
|
||||
(procedure? . -> . void?) ; run-on-drscheme-side
|
||||
. -> .
|
||||
void?)])
|
||||
|
||||
; go starts a stepper instance
|
||||
; see provide stmt for contract
|
||||
(define (go program-expander receive-result render-settings track-inferred-names? language-level-name run-on-drscheme-side)
|
||||
|
||||
;; finished-exps: (listof (list/c syntax-object? (or/c number? false?)( -> any)))
|
||||
;; because of mutation, these cannot be fixed renderings, but must be re-rendered at each step.
|
||||
; see provide stmt for contract
|
||||
(define (go program-expander receive-result render-settings
|
||||
track-inferred-names? language-level-name run-on-drscheme-side)
|
||||
|
||||
;; finished-exps:
|
||||
;; (listof (list/c syntax-object? (or/c number? false?)( -> any)))
|
||||
;; because of mutation, these cannot be fixed renderings, but must be
|
||||
;; re-rendered at each step.
|
||||
(define finished-exps null)
|
||||
(define/contract add-to-finished
|
||||
((-> syntax?) (or/c (listof natural-number/c) false/c) (-> any) . -> . void?)
|
||||
((-> syntax?) (or/c (listof natural-number/c) false/c) (-> any)
|
||||
. -> . void?)
|
||||
(lambda (exp-thunk lifting-indices getter)
|
||||
(set! finished-exps (append finished-exps (list (list exp-thunk lifting-indices getter))))))
|
||||
|
||||
;; the "held" variables are used to store the "before" step.
|
||||
(set! finished-exps
|
||||
(append finished-exps
|
||||
(list (list exp-thunk lifting-indices getter))))))
|
||||
|
||||
;; the "held" variables are used to store the "before" step.
|
||||
(define held-exp-list no-sexp)
|
||||
(define held-step-was-app? #f)
|
||||
(define held-finished-list null)
|
||||
|
||||
;; highlight-mutated-expressions :
|
||||
;; ((listof (list/c syntax? syntax?)) (listof (list/c syntax? syntax?)) . -> . (list/c (listof syntax?) (listof syntax?)))
|
||||
;; highlights changes occurring due to mutation. This function accepts the left-hand-side
|
||||
;; expressions and the right-hand-side expressions, and matches them against each other
|
||||
;; to see which ones have changed due to mutation, and highlights these.
|
||||
;; POSSIBLE RESEARCH POINT: if, say, (list 3 4) is mutated to (list 4 5), should the 4 & 5 be
|
||||
;; highlighted individually or should the list as a whole be highlighted. Is either one "wrong?"
|
||||
;; equivalences between reduction semantics?
|
||||
;;
|
||||
;; 2005-11-14: punting. just highlight the whole damn thing if there are any differences.
|
||||
;; in fact, just test for eq?-ness.
|
||||
|
||||
#;(define (highlight-mutated-expressions lefts rights)
|
||||
(if (or (null? lefts) (null? rights))
|
||||
(list lefts rights)
|
||||
(let ([left-car (car lefts)]
|
||||
[right-car (car rights)])
|
||||
(if (eq? (syntax-property left-car 'user-source)
|
||||
(syntax-property right-car 'user-source))
|
||||
(let ([highlights-added (highlight-mutated-expression left-car right-car)]
|
||||
[rest (highlight-mutated-expressions (cdr lefts) (cdr rights))])
|
||||
(cons (cons (car highlights-added) (car rest))
|
||||
(cons (cadr highlights-added) (cadr rest))))))))
|
||||
|
||||
;; highlight-mutated-expression: syntax? syntax? -> syntax?
|
||||
;; given two expressions, highlight 'em both if they differ at all.
|
||||
|
||||
;; notes: wanted to use simple "eq?" test... but this will fail when a being-stepped definition (e.g.
|
||||
;; in a let) turns into a permanent one. We pay a terrible price for the lifting thing. And, for the fact
|
||||
;; that the highlighting follows from the reductions but can't obviously be deduced from them.
|
||||
|
||||
#;(define (highlight-mutated-expression left right)
|
||||
(cond
|
||||
;; if either one is already highlighted, leave them alone.
|
||||
[(or (syntax-property left 'stepper-highlight)
|
||||
(syntax-property right 'stepper-highlight))
|
||||
(list left right)]
|
||||
|
||||
;; first pass: highlight if not eq?. Should be broken for local-bound things
|
||||
;; as they pass into permanence.
|
||||
[(eq? left right)
|
||||
(list left right)]
|
||||
|
||||
[else (list (syntax-property left 'stepper-highlight)
|
||||
(syntax-property right 'stepper-highlight))]))
|
||||
|
||||
|
||||
;; highlight-mutated-expressions :
|
||||
;; ((listof (list/c syntax? syntax?)) (listof (list/c syntax? syntax?))
|
||||
;; -> (list/c (listof syntax?) (listof syntax?)))
|
||||
;; highlights changes occurring due to mutation. This function accepts the
|
||||
;; left-hand-side expressions and the right-hand-side expressions, and
|
||||
;; matches them against each other to see which ones have changed due to
|
||||
;; mutation, and highlights these.
|
||||
;; POSSIBLE RESEARCH POINT: if, say, (list 3 4) is mutated to (list 4 5),
|
||||
;; should the 4 & 5 be highlighted individually or should the list as a
|
||||
;; whole be highlighted. Is either one "wrong?" equivalences between
|
||||
;; reduction semantics?
|
||||
;;
|
||||
;; 2005-11-14: punting. just highlight the whole damn thing if there are
|
||||
;; any differences. In fact, just test for eq?-ness.
|
||||
|
||||
#;
|
||||
(define (highlight-mutated-expressions lefts rights)
|
||||
(if (or (null? lefts) (null? rights))
|
||||
(list lefts rights)
|
||||
(let ([left-car (car lefts)]
|
||||
[right-car (car rights)])
|
||||
(if (eq? (syntax-property left-car 'user-source)
|
||||
(syntax-property right-car 'user-source))
|
||||
(let ([highlights-added
|
||||
(highlight-mutated-expression left-car right-car)]
|
||||
[rest (highlight-mutated-expressions
|
||||
(cdr lefts) (cdr rights))])
|
||||
(cons (cons (car highlights-added) (car rest))
|
||||
(cons (cadr highlights-added) (cadr rest))))))))
|
||||
|
||||
;; highlight-mutated-expression: syntax? syntax? -> syntax?
|
||||
;; given two expressions, highlight 'em both if they differ at all.
|
||||
|
||||
;; notes: wanted to use simple "eq?" test... but this will fail when a
|
||||
;; being-stepped definition (e.g. in a let) turns into a permanent one.
|
||||
;; We pay a terrible price for the lifting thing. And, for the fact that
|
||||
;; the highlighting follows from the reductions but can't obviously be
|
||||
;; deduced from them.
|
||||
|
||||
#;
|
||||
(define (highlight-mutated-expression left right)
|
||||
(cond
|
||||
;; if either one is already highlighted, leave them alone.
|
||||
[(or (syntax-property left 'stepper-highlight)
|
||||
(syntax-property right 'stepper-highlight))
|
||||
(list left right)]
|
||||
|
||||
;; first pass: highlight if not eq?. Should be broken for local-bound
|
||||
;; things as they pass into permanence.
|
||||
[(eq? left right)
|
||||
(list left right)]
|
||||
|
||||
[else (list (syntax-property left 'stepper-highlight)
|
||||
(syntax-property right 'stepper-highlight))]))
|
||||
|
||||
;; mutated on receipt of a break, used in displaying breakpoint stuff.
|
||||
(define steps-received 0)
|
||||
|
||||
(define break
|
||||
|
||||
(define break
|
||||
(opt-lambda (mark-set break-kind [returned-value-list #f])
|
||||
|
||||
(set! steps-received (+ steps-received 1))
|
||||
|
|
@ -140,144 +156,173 @@
|
|||
(let ([steps-received/current steps-received])
|
||||
(run-on-drscheme-side
|
||||
(lambda ()
|
||||
(display-break-stuff steps-received/current mark-set break-kind returned-value-list)))))
|
||||
(display-break-stuff
|
||||
steps-received/current
|
||||
mark-set break-kind returned-value-list)))))
|
||||
|
||||
;; bizarrely, this causes something in the test tool startup to fail with
|
||||
;; current-eventspace: expects argument of type <eventspace>; given #f
|
||||
;; bizarrely, this causes something in the test tool startup to fail
|
||||
;; with:
|
||||
;; current-eventspace: expects argument of type <eventspace>; given #f
|
||||
|
||||
;; === context ===
|
||||
;; /Users/clements/plt/collects/drscheme/private/rep.ss:1183:10: queue-user/wait method in ...cheme/private/rep.ss:480:8
|
||||
;; /Users/clements/plt/collects/drscheme/private/rep.ss:1094:10: init-evaluation-thread method in ...cheme/private/rep.ss:480:8
|
||||
;; /Users/clements/plt/collects/drscheme/private/rep.ss:1346:10: reset-console method in ...cheme/private/rep.ss:480:8
|
||||
;; /Users/clements/plt/collects/mztake/debug-tool.ss:510:10: reset-console method in ...mztake/debug-tool.ss:428:8
|
||||
;; /Users/clements/plt/collects/test-suite/tool.ss:162:10: reset-console method in ...s/test-suite/tool.ss:137:8
|
||||
;; /Users/clements/plt/collects/drscheme/private/rep.ss:1413:10: initialize-console method in ...cheme/private/rep.ss:480:8
|
||||
;; /Users/clements/plt/collects/drscheme/private/unit.ss:3200:6: create-new-drscheme-frame
|
||||
;; /Users/clements/plt/collects/drscheme/private/main.ss:372:6: make-basic
|
||||
;; ...collects/drscheme/private/rep.ss:1183:10: queue-user/wait method in ...cheme/private/rep.ss:480:8
|
||||
;; ...collects/drscheme/private/rep.ss:1094:10: init-evaluation-thread method in ...cheme/private/rep.ss:480:8
|
||||
;; ...collects/drscheme/private/rep.ss:1346:10: reset-console method in ...cheme/private/rep.ss:480:8
|
||||
;; ...collects/mztake/debug-tool.ss:510:10: reset-console method in ...mztake/debug-tool.ss:428:8
|
||||
;; ...collects/test-suite/tool.ss:162:10: reset-console method in ...s/test-suite/tool.ss:137:8
|
||||
;; ...collects/drscheme/private/rep.ss:1413:10: initialize-console method in ...cheme/private/rep.ss:480:8
|
||||
;; ...collects/drscheme/private/unit.ss:3200:6: create-new-drscheme-frame
|
||||
;; ...collects/drscheme/private/main.ss:372:6: make-basic
|
||||
|
||||
;; ... okay, the error was transient. wonder what caused it?
|
||||
|
||||
|
||||
(let* ([mark-list (and mark-set (extract-mark-list mark-set))])
|
||||
|
||||
|
||||
(define (reconstruct-all-completed)
|
||||
(map (match-lambda
|
||||
(map (match-lambda
|
||||
[`(,source-thunk ,lifting-indices ,getter)
|
||||
(match (r:reconstruct-completed (source-thunk) lifting-indices getter render-settings)
|
||||
(match (r:reconstruct-completed
|
||||
(source-thunk) lifting-indices
|
||||
getter render-settings)
|
||||
[#(exp #f) (first-of-one (unwind-no-highlight exp))]
|
||||
[#(exp #t) exp])])
|
||||
[#(exp #t) exp])])
|
||||
finished-exps))
|
||||
|
||||
#;(printf "break called with break-kind: ~a ..." break-kind)
|
||||
|
||||
;; (printf "break called with break-kind: ~a ..." break-kind)
|
||||
(if (r:skip-step? break-kind mark-list render-settings)
|
||||
(begin
|
||||
#;(printf " but it was skipped!\n")
|
||||
(when (or (eq? break-kind 'normal-break)
|
||||
(eq? break-kind 'nomal-break/values)) ;; not sure about this...
|
||||
(set! held-exp-list skipped-step)))
|
||||
|
||||
(begin
|
||||
#;(printf "and it wasn't skipped.\n")
|
||||
(case break-kind
|
||||
[(normal-break normal-break/values)
|
||||
(begin
|
||||
(when (and (eq? break-kind 'normal-break) returned-value-list)
|
||||
(error 'break "broken invariant: normal-break can't have returned values"))
|
||||
(set! held-finished-list (reconstruct-all-completed))
|
||||
(set! held-exp-list (unwind (r:reconstruct-left-side mark-list returned-value-list render-settings) #f))
|
||||
(set! held-step-was-app? (r:step-was-app? mark-list)))]
|
||||
|
||||
[(result-exp-break result-value-break)
|
||||
(if (eq? held-exp-list skipped-step)
|
||||
; don't render if before step was a skipped-step
|
||||
(set! held-exp-list no-sexp)
|
||||
|
||||
(let* ([new-finished-list (reconstruct-all-completed)]
|
||||
[reconstructed (unwind (r:reconstruct-right-side mark-list returned-value-list render-settings) #f)]
|
||||
[result
|
||||
(if (eq? held-exp-list no-sexp)
|
||||
;; in this case, there was no "before" step, due to
|
||||
;; unannotated code. In this case, we make the
|
||||
;; optimistic guess that none of the finished expressions
|
||||
;; were mutated. It would be somewhat painful to do a better
|
||||
;; job, and the stepper makes no guarantees in this case.
|
||||
(make-before-after-result
|
||||
(list #`(... ...))
|
||||
(append new-finished-list reconstructed)
|
||||
'normal)
|
||||
|
||||
(let*-values
|
||||
([(step-kind) (if (and held-step-was-app?
|
||||
(eq? break-kind 'result-exp-break))
|
||||
'user-application
|
||||
'normal)]
|
||||
[(left-exps right-exps)
|
||||
;; write this later:
|
||||
#;(identify-changed (append held-finished-list held-exps) (append new-finished-list reconstructed))
|
||||
(values (append held-finished-list held-exp-list)
|
||||
(append new-finished-list reconstructed))])
|
||||
|
||||
(make-before-after-result left-exps right-exps step-kind)))])
|
||||
(set! held-exp-list no-sexp)
|
||||
(receive-result result)))]
|
||||
|
||||
[(double-break)
|
||||
;; a double-break occurs at the beginning of a let's evaluation.
|
||||
(when (not (eq? held-exp-list no-sexp))
|
||||
(error 'break-reconstruction
|
||||
"held-exp-list not empty when a double-break occurred"))
|
||||
(let* ([new-finished-list (reconstruct-all-completed)]
|
||||
[reconstruct-result (r:reconstruct-double-break mark-list render-settings)]
|
||||
[left-side (unwind (car reconstruct-result) #f)]
|
||||
[right-side (unwind (cadr reconstruct-result) #t)])
|
||||
;; add highlighting code as for other cases...
|
||||
(receive-result (make-before-after-result (append new-finished-list left-side)
|
||||
(append new-finished-list right-side)
|
||||
'normal)))]
|
||||
|
||||
|
||||
[(expr-finished-break)
|
||||
(unless (not mark-list)
|
||||
(error 'break "expected no mark-list with expr-finished-break"))
|
||||
;; in an expr-finished-break, the returned-vals hold (listof (list/c source lifting-index getter))
|
||||
;; this will now include define-struct breaks, for which the source is the source and the getter
|
||||
;; causes an error.
|
||||
(for-each (lambda (source/index/getter)
|
||||
(apply add-to-finished source/index/getter))
|
||||
returned-value-list)]
|
||||
|
||||
[else (error 'break "unknown label on break")]))))))
|
||||
|
||||
|
||||
|
||||
|
||||
(begin
|
||||
;; (printf " but it was skipped!\n")
|
||||
(when (or (eq? break-kind 'normal-break)
|
||||
;; not sure about this...
|
||||
(eq? break-kind 'nomal-break/values))
|
||||
(set! held-exp-list skipped-step)))
|
||||
|
||||
(begin
|
||||
;; (printf "and it wasn't skipped.\n")
|
||||
(case break-kind
|
||||
[(normal-break normal-break/values)
|
||||
(begin
|
||||
(when (and (eq? break-kind 'normal-break)
|
||||
returned-value-list)
|
||||
(error 'break
|
||||
"broken invariant: normal-break can't have returned values"))
|
||||
(set! held-finished-list (reconstruct-all-completed))
|
||||
(set! held-exp-list
|
||||
(unwind
|
||||
(r:reconstruct-left-side
|
||||
mark-list returned-value-list render-settings)
|
||||
#f))
|
||||
(set! held-step-was-app? (r:step-was-app? mark-list)))]
|
||||
|
||||
[(result-exp-break result-value-break)
|
||||
(if (eq? held-exp-list skipped-step)
|
||||
;; don't render if before step was a skipped-step
|
||||
(set! held-exp-list no-sexp)
|
||||
|
||||
(let* ([new-finished-list (reconstruct-all-completed)]
|
||||
[reconstructed
|
||||
(unwind
|
||||
(r:reconstruct-right-side
|
||||
mark-list returned-value-list render-settings)
|
||||
#f)]
|
||||
[result
|
||||
(if (eq? held-exp-list no-sexp)
|
||||
;; in this case, there was no "before" step, due
|
||||
;; to unannotated code. In this case, we make the
|
||||
;; optimistic guess that none of the finished
|
||||
;; expressions were mutated. It would be somewhat
|
||||
;; painful to do a better job, and the stepper
|
||||
;; makes no guarantees in this case.
|
||||
(make-before-after-result
|
||||
(list #`(... ...))
|
||||
(append new-finished-list reconstructed)
|
||||
'normal)
|
||||
|
||||
(let*-values
|
||||
([(step-kind)
|
||||
(if (and held-step-was-app?
|
||||
(eq? break-kind 'result-exp-break))
|
||||
'user-application
|
||||
'normal)]
|
||||
[(left-exps right-exps)
|
||||
;; write this later:
|
||||
;; (identify-changed
|
||||
;; (append held-finished-list held-exps)
|
||||
;; (append new-finished-list reconstructed))
|
||||
(values (append held-finished-list
|
||||
held-exp-list)
|
||||
(append new-finished-list
|
||||
reconstructed))])
|
||||
|
||||
(make-before-after-result
|
||||
left-exps right-exps step-kind)))])
|
||||
(set! held-exp-list no-sexp)
|
||||
(receive-result result)))]
|
||||
|
||||
[(double-break)
|
||||
;; a double-break occurs at the beginning of a let's
|
||||
;; evaluation.
|
||||
(when (not (eq? held-exp-list no-sexp))
|
||||
(error
|
||||
'break-reconstruction
|
||||
"held-exp-list not empty when a double-break occurred"))
|
||||
(let* ([new-finished-list (reconstruct-all-completed)]
|
||||
[reconstruct-result
|
||||
(r:reconstruct-double-break mark-list render-settings)]
|
||||
[left-side (unwind (car reconstruct-result) #f)]
|
||||
[right-side (unwind (cadr reconstruct-result) #t)])
|
||||
;; add highlighting code as for other cases...
|
||||
(receive-result
|
||||
(make-before-after-result
|
||||
(append new-finished-list left-side)
|
||||
(append new-finished-list right-side)
|
||||
'normal)))]
|
||||
|
||||
[(expr-finished-break)
|
||||
(unless (not mark-list)
|
||||
(error 'break
|
||||
"expected no mark-list with expr-finished-break"))
|
||||
;; in an expr-finished-break, the returned-vals hold (listof
|
||||
;; (list/c source lifting-index getter)) this will now include
|
||||
;; define-struct breaks, for which the source is the source
|
||||
;; and the getter causes an error.
|
||||
(for-each (lambda (source/index/getter)
|
||||
(apply add-to-finished source/index/getter))
|
||||
returned-value-list)]
|
||||
|
||||
[else (error 'break "unknown label on break")]))))))
|
||||
|
||||
|
||||
(define (step-through-expression expanded expand-next-expression)
|
||||
(let* ([annotated (a:annotate expanded break track-inferred-names? language-level-name)])
|
||||
(let* ([annotated (a:annotate expanded break track-inferred-names?
|
||||
language-level-name)])
|
||||
(eval-syntax annotated)
|
||||
(expand-next-expression)))
|
||||
|
||||
|
||||
(define (err-display-handler message exn)
|
||||
(if (not (eq? held-exp-list no-sexp))
|
||||
(begin
|
||||
(receive-result (make-before-error-result (append held-finished-list held-exp-list)
|
||||
message))
|
||||
(set! held-exp-list no-sexp))
|
||||
(receive-result (make-error-result message))))
|
||||
|
||||
(begin
|
||||
(receive-result
|
||||
(make-before-error-result (append held-finished-list held-exp-list)
|
||||
message))
|
||||
(set! held-exp-list no-sexp))
|
||||
(receive-result (make-error-result message))))
|
||||
|
||||
(program-expander
|
||||
(lambda ()
|
||||
; swap these to allow errors to escape (e.g., when debugging)
|
||||
(lambda ()
|
||||
;; swap these to allow errors to escape (e.g., when debugging)
|
||||
(error-display-handler err-display-handler)
|
||||
#;(void)
|
||||
;; (void)
|
||||
)
|
||||
(lambda (expanded continue-thunk) ; iter
|
||||
(r:reset-special-values)
|
||||
(if (eof-object? expanded)
|
||||
(begin
|
||||
(receive-result (make-finished-stepping)))
|
||||
(step-through-expression expanded continue-thunk)))))
|
||||
|
||||
|
||||
(define (first-of-one x)
|
||||
(begin
|
||||
(receive-result (make-finished-stepping)))
|
||||
(step-through-expression expanded continue-thunk)))))
|
||||
|
||||
|
||||
(define (first-of-one x)
|
||||
(unless (and (pair? x) (null? (cdr x)))
|
||||
(error 'first-of-one "expected a list of length one in: ~v" x))
|
||||
(car x)))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user