suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

...

Browse Source 
svn: r9999
This commit is contained in:
John Clements 2008-05-28 07:55:42 +00:00
parent a299e333ba
commit b180fe980c
3 changed files with 328 additions and 301 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
collects/stepper/internal-docs.txt
View File

@ -241,7 +241,11 @@ stepper-args-of-call [ADDED BY RECONSTRUCTOR] :
stepper-hide-completed : don't show the final top-level expression binding stepper-hide-completed : don't show the final top-level expression binding
for this identifier. for this identifier.
stepper-hide-reduction : don't show the "before" step for this term. stepper-hide-reduction : don't show any reductions where this term is
associated with the topmost mark
stepper-use-val-as-final : use the return value of this expression as a
"completed" val in the stepper. Used for test cases.
STEPPER-HINT COLLISIONS STEPPER-HINT COLLISIONS

611
collects/stepper/private/annotate.ss
View File

@ -253,9 +253,9 @@
; h e h o m e o f t h e b r a v e ? . . . . ; h e h o m e o f t h e b r a v e ? . . . .
; .. . . . . . . . . . . . . . . . . . ............................................................ ; .. . . . . . . . . . . . . . . . . . ............................................................
; . . . . . . . . . . . . . . . . . . . . . ; . . . . . . . . . . . . . . . . . . . . .
; ................................................................................................. ; .........you-know,-this-flag-doesn't-feel-quite-as...............................................
; . . ; . .
; ................................................................................................. ; ..........lighthearted-as-it-did-when-I-created-it-in-1998.......................................
; . . ; . .
; ................................................................................................. ; .................................................................................................
; . . ; . .
@ -774,6 +774,22 @@
(syntax-recertify b exp (current-code-inspector) #f)) (syntax-recertify b exp (current-code-inspector) #f))
bindings))))] bindings))))]
;; this is a terrible hack... until some other language form needs it. It wraps the
;; given annotated expression with a break that adds the result to the list of completed
;; expressions
[maybe-final-val-wrap
(match-lambda
[(vector annotated free-vars)
(vector (if (stepper-syntax-property exp 'stepper-use-val-as-final)
#`(call-with-values
(lambda () #,annotated)
(lambda results
(#,exp-finished-break (list (list #,(lambda () exp) #f (lambda () results))))
(values results)))
annotated)
free-vars)]
[error 'maybe-final-val-wrap "stepper internal error 20080527"])]
) )
; find the source expression and associate it with the parsed expression ; find the source expression and associate it with the parsed expression
; (when (and red-exprs foot-wrap?) ; (when (and red-exprs foot-wrap?)
@ -781,301 +797,302 @@
(recertifier (recertifier
(kernel:kernel-syntax-case exp #f (maybe-final-val-wrap
(kernel:kernel-syntax-case exp #f
[(#%plain-lambda . clause)
(let*-2vals ([(annotated-clause free-varrefs) [(#%plain-lambda . clause)
(lambda-clause-abstraction (syntax clause))] (let*-2vals ([(annotated-clause free-varrefs)
[annotated-lambda (lambda-clause-abstraction (syntax clause))]
(with-syntax ([annotated-clause annotated-clause]) [annotated-lambda
(syntax/loc exp (#%plain-lambda . annotated-clause)))]) (with-syntax ([annotated-clause annotated-clause])
(outer-lambda-abstraction annotated-lambda free-varrefs))] (syntax/loc exp (#%plain-lambda . annotated-clause)))])
(outer-lambda-abstraction annotated-lambda free-varrefs))]
[(case-lambda . clauses)
(let*-2vals ([(annotated-cases free-varrefs-cases) [(case-lambda . clauses)
(2vals-map lambda-clause-abstraction (syntax->list (syntax clauses)))] (let*-2vals ([(annotated-cases free-varrefs-cases)
[annotated-case-lambda (with-syntax ([annotated-cases annotated-cases]) (2vals-map lambda-clause-abstraction (syntax->list (syntax clauses)))]
(syntax/loc exp (case-lambda . annotated-cases)))] [annotated-case-lambda (with-syntax ([annotated-cases annotated-cases])
[free-varrefs (varref-set-union free-varrefs-cases)]) (syntax/loc exp (case-lambda . annotated-cases)))]
(outer-lambda-abstraction annotated-case-lambda free-varrefs))] [free-varrefs (varref-set-union free-varrefs-cases)])
(outer-lambda-abstraction annotated-case-lambda free-varrefs))]
[(if test then else) (if-abstraction (syntax test) (syntax then) (syntax else))]
[(if test then else) (if-abstraction (syntax test) (syntax then) (syntax else))]
;
; ;
; ; ; ;
; ; ; ; ;
; ; ; ;
; ; ;; ;;; ;;;; ;;; ; ;; ; ;
; ;; ; ; ; ; ; ; ;; ; ; ; ;; ;;; ;;;; ;;; ; ;;
; ; ; ;;;;; ; ; ; ; ; ; ;; ; ; ; ; ; ; ;; ;
; ; ; ; ; ; ; ; ; ; ; ; ;;;;; ; ; ; ; ;
; ; ; ; ; ;; ; ; ; ; ; ; ; ; ; ; ; ;
; ;;;; ;;;; ;; ; ;;; ; ; ; ; ; ; ; ;; ; ; ;
; ; ; ;;;; ;;;; ;; ; ;;; ; ;
; ;;;; ; ;
; ; ;;;;
;
[(begin . bodies-stx)
(begin [(begin . bodies-stx)
(error 'annotate-inner "nothing expands into begin! : ~v" (syntax->datum exp)) (begin
#;(begin-abstraction (syntax->list #`bodies-stx)))] (error 'annotate-inner "nothing expands into begin! : ~v" (syntax->datum exp))
#;(begin-abstraction (syntax->list #`bodies-stx)))]
;
; ;
; ; ; ;; ;
; ; ; ; ; ; ; ;;
; ; ; ;; ; ; ; ;
; ; ;; ;;; ;;;; ;;; ; ;; ; ; ; ; ; ; ;;
; ;; ; ; ; ; ; ; ;; ; ; ; ; ; ; ;; ;;; ;;;; ;;; ; ;; ; ; ;
; ; ; ;;;;; ; ; ; ; ; ; ; ; ; ;; ; ; ; ; ; ; ;; ; ; ; ;
; ; ; ; ; ; ; ; ; ;; ; ; ; ; ;;;;; ; ; ; ; ; ; ; ;
; ; ; ; ; ;; ; ; ; ;; ; ; ; ; ; ; ; ; ; ; ;; ;
; ;;;; ;;;; ;; ; ;;; ; ; ;; ; ; ; ; ; ;; ; ; ; ;; ;
; ; ; ;;;; ;;;; ;; ; ;;; ; ; ;;
; ;;;; ; ;
; ; ;;;;
;
;; one-element begin0 is a special case, because in this case only
;; the body of the begin0 is in tail position. ;; one-element begin0 is a special case, because in this case only
;; the body of the begin0 is in tail position.
[(begin0 body)
(let*-2vals ([(annotated-body free-vars-body) [(begin0 body)
(tail-recur #'body)]) (let*-2vals ([(annotated-body free-vars-body)
(2vals (wcm-break-wrap (make-debug-info-normal free-vars-body) (tail-recur #'body)])
(quasisyntax/loc exp (begin0 #,annotated-body))) (2vals (wcm-break-wrap (make-debug-info-normal free-vars-body)
free-vars-body))] (quasisyntax/loc exp (begin0 #,annotated-body)))
free-vars-body))]
[(begin0 first-body . bodies-stx)
(let*-2vals ([(annotated-first free-vars-first) (result-recur #'first-body)] [(begin0 first-body . bodies-stx)
[(annotated-rest free-vars-rest) (2vals-map non-tail-recur (syntax->list #`bodies-stx))] (let*-2vals ([(annotated-first free-vars-first) (result-recur #'first-body)]
[wrapped-rest (map normal-break/values-wrap annotated-rest)] [(annotated-rest free-vars-rest) (2vals-map non-tail-recur (syntax->list #`bodies-stx))]
[all-free-vars (varref-set-union (cons free-vars-first free-vars-rest))] [wrapped-rest (map normal-break/values-wrap annotated-rest)]
[early-debug-info (make-debug-info-normal all-free-vars)] [all-free-vars (varref-set-union (cons free-vars-first free-vars-rest))]
[tagged-temp (stepper-syntax-property begin0-temp 'stepper-binding-type 'stepper-temp)] [early-debug-info (make-debug-info-normal all-free-vars)]
[debug-info-maker [tagged-temp (stepper-syntax-property begin0-temp 'stepper-binding-type 'stepper-temp)]
(lambda (rest-exps) [debug-info-maker
(make-debug-info-fake-exp/tail-bound (lambda (rest-exps)
#`(begin0 #,@rest-exps) (make-debug-info-fake-exp/tail-bound
(binding-set-union (list (list tagged-temp) tail-bound)) #`(begin0 #,@rest-exps)
(varref-set-union (list (list tagged-temp) all-free-vars))))] (binding-set-union (list (list tagged-temp) tail-bound))
[rolled-into-fakes (let loop ([remaining-wrapped wrapped-rest] (varref-set-union (list (list tagged-temp) all-free-vars))))]
[remaining-src (syntax->list #`bodies-stx)] [rolled-into-fakes (let loop ([remaining-wrapped wrapped-rest]
[first-time? #t]) [remaining-src (syntax->list #`bodies-stx)]
((if first-time? wcm-wrap wcm-pre-break-wrap) [first-time? #t])
(debug-info-maker remaining-src) ((if first-time? wcm-wrap wcm-pre-break-wrap)
(cond [(null? remaining-src) begin0-temp] (debug-info-maker remaining-src)
[else #`(begin #,(car remaining-wrapped) #,(loop (cdr remaining-wrapped) (cond [(null? remaining-src) begin0-temp]
(cdr remaining-src) [else #`(begin #,(car remaining-wrapped) #,(loop (cdr remaining-wrapped)
#f))])))]) (cdr remaining-src)
(2vals (wcm-wrap early-debug-info #f))])))])
#`(let ([#,begin0-temp #,annotated-first]) (2vals (wcm-wrap early-debug-info
#,rolled-into-fakes)) #`(let ([#,begin0-temp #,annotated-first])
all-free-vars))] #,rolled-into-fakes))
all-free-vars))]
;
; ;
; ;;; ;;; ;
; ; ; ; ; ;;; ;;;
; ; ; ; ; ; ; ;
; ; ;;; ;;;;; ; ; ;;;; ; ; ; ;;; ;;; ; ; ; ;
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;;; ;;;;; ; ; ;;;; ; ; ; ;;; ;;;
; ; ;;;;; ; ;;;;; ; ; ; ; ; ; ; ;;;;; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;;;;; ; ;;;;; ; ; ; ; ; ; ; ;;;;; ;;
; ; ; ; ; ; ; ;; ; ; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
; ;;; ;;;; ;; ; ;; ; ;;; ;; ; ;;;; ;;; ; ; ; ; ; ; ; ;; ; ; ;; ; ; ;
; ; ;;; ;;;; ;; ; ;; ; ;;; ;; ; ;;;; ;;;
; ;
; ;
[(let-values . _) ;
(let-abstraction exp [(let-values . _)
#`let-values (let-abstraction exp
(lambda (bindings) #`let-values
(map (lambda (_) *unevaluated*) bindings)))] (lambda (bindings)
(map (lambda (_) *unevaluated*) bindings)))]
[(letrec-values . _)
(let-abstraction exp [(letrec-values . _)
#`letrec-values (let-abstraction exp
(lambda (bindings) (map (lambda (b) #`#,b) bindings)))] #`letrec-values
(lambda (bindings) (map (lambda (b) #`#,b) bindings)))]
; $
; @ @ ; $
; :@@+@ -@@$ @@@@@ @ ; @ @
; @$ -@ $ -$ @ @ ; :@@+@ -@@$ @@@@@ @
; :@@$- @@@@@ @ @ ; @$ -@ $ -$ @ @
; *@ $ @ ; :@@$- @@@@@ @ @
; @ :@ +: @: :$ ; *@ $ @
; $+@@: $@@+ :@@$- $ ; @ :@ +: @: :$
; $+@@: $@@+ :@@$- $
[(set! var val)
(let*-2vals [(set! var val)
([(annotated-val val-free-varrefs) (let*-2vals
(set!-rhs-recur (syntax val) (syntax-case (syntax var) (#%top) ([(annotated-val val-free-varrefs)
[(#%top . real-var) (syntax-e (syntax real-var))] (set!-rhs-recur (syntax val) (syntax-case (syntax var) (#%top)
[else (syntax var)]))] [(#%top . real-var) (syntax-e (syntax real-var))]
[free-varrefs (varref-set-union (list val-free-varrefs (list #`var)))] [else (syntax var)]))]
[annotated-set! [free-varrefs (varref-set-union (list val-free-varrefs (list #`var)))]
(return-value-wrap [annotated-set!
(quasisyntax/loc exp (set! var #,(normal-break/values-wrap annotated-val))))]) (return-value-wrap
(2vals (quasisyntax/loc exp (set! var #,(normal-break/values-wrap annotated-val))))])
(outer-wcm-wrap (make-debug-info-normal free-varrefs) annotated-set!) (2vals
free-varrefs))] (outer-wcm-wrap (make-debug-info-normal free-varrefs) annotated-set!)
free-varrefs))]
; @
; $@-@@@@ @@ $@$ @@@@@ -@@$ ; @
; $- :@ @ @ $- -$ @ $ -$ ; $@-@@@@ @@ $@$ @@@@@ -@@$
; @ @ @ @ @ @ @ @@@@@ ; $- :@ @ @ $- -$ @ $ -$
; @ @ @ @ @ @ @ $ ; @ @ @ @ @ @ @ @@@@@
; $- :@ @: +@ $- -$ @: :$ +: ; @ @ @ @ @ @ @ $
; $@-@ :@$-@@ $@$ :@@$- $@@+ ; $- :@ @: +@ $- -$ @: :$ +:
; @ ; $@-@ :@$-@@ $@$ :@@$- $@@+
; @@@ ; @
; @@@
[(quote _)
(normal-bundle null exp)] [(quote _)
(normal-bundle null exp)]
[(quote-syntax _)
(normal-bundle null exp)] [(quote-syntax _)
(normal-bundle null exp)]
; @@@ @@@ $@+@ @@+-$:
; @ @ $+ -@ @+@$@ ; @@@ @@@ $@+@ @@+-$:
; $-@ @ @@@@@ @ @@@@@ @ @ @ ; @ @ $+ -@ @+@$@
; ++@+$ @ @ @ @ ; $-@ @ @@@@@ @ @@@@@ @ @ @
; :@@$+ $* -$ @ @ @ ; ++@+$ @ @ @ @
; -@$@* $@$- @@@@@@@ ; :@@$+ $* -$ @ @ @
; -@$@* $@$- @@@@@@@
[(with-continuation-mark key mark body)
;(let*-2vals ([(annotated-key free-varrefs-key) [(with-continuation-mark key mark body)
; (non-tail-recur (syntax key))] ;(let*-2vals ([(annotated-key free-varrefs-key)
; [(annotated-mark free-varrefs-mark) ; (non-tail-recur (syntax key))]
; (non-tail-recur (syntax mark))] ; [(annotated-mark free-varrefs-mark)
; [(annotated-body dc_free-varrefs-body) ; (non-tail-recur (syntax mark))]
; (result-recur (syntax body))]) ; [(annotated-body dc_free-varrefs-body)
(error 'annotate/inner "this region of code is still under construction") ; (result-recur (syntax body))])
(error 'annotate/inner "this region of code is still under construction")
; [annotated #`(let-values ([key-temp #,*unevaluated*]
; [mark-temp #,*unevaluated*] ; [annotated #`(let-values ([key-temp #,*unevaluated*]
;) ; [mark-temp #,*unevaluated*]
] ;)
]
; @@ @ @
; @ @ ; @@ @ @
; $@$: @@:@$- @@:@$- @ -@@ $@+@ $@$: @@@@@ -@@ $@$ @@:@@: ; @ @
; -@ @: -$ @: -$ @ @ $+ -@ -@ @ @ $- -$ @+ :@ ; $@$: @@:@$- @@:@$- @ -@@ $@+@ $@$: @@@@@ -@@ $@$ @@:@@:
; -$@$@ @ @ @ @ @ @ @ -$@$@ @ @ @ @ @ @ ; -@ @: -$ @: -$ @ @ $+ -@ -@ @ @ $- -$ @+ :@
; $* @ @ @ @ @ @ @ @ $* @ @ @ @ @ @ @ ; -$@$@ @ @ @ @ @ @ @ -$@$@ @ @ @ @ @ @
; @- *@ @: -$ @: -$ @ @ $* -$ @- *@ @: :$ @ $- -$ @ @ ; $* @ @ @ @ @ @ @ @ $* @ @ @ @ @ @ @
; -$$-@@ @-@$ @-@$ @@@@@ @@@@@ $@$- -$$-@@ :@@$- @@@@@ $@$ @@@ @@@ ; @- *@ @: -$ @: -$ @ @ $* -$ @- *@ @: :$ @ $- -$ @ @
; @ @ ; -$$-@@ @-@$ @-@$ @@@@@ @@@@@ $@$- -$$-@@ :@@$- @@@@@ $@$ @@@ @@@
; @@@ @@@ ; @ @
; @@@ @@@
; [foot-wrap?
; (wcm-wrap debug-info annotated)]) ; [foot-wrap?
; free-bindings))] ; (wcm-wrap debug-info annotated)])
; free-bindings))]
; the app form's elaboration looks like this, where M0 etc. stand for expressions, and t0 etc
; are temp identifiers that do not occur in the program: ; the app form's elaboration looks like this, where M0 etc. stand for expressions, and t0 etc
; (M0 ...) ; are temp identifiers that do not occur in the program:
; ; (M0 ...)
; goes to ;
; ; goes to
;(let ([t0 *unevaluated*] ;
; ...) ;(let ([t0 *unevaluated*]
; (with-continuation-mark ; ...)
; debug-key ; (with-continuation-mark
; huge-value ; debug-key
; (set! t0 M0) ; huge-value
; ... ; (set! t0 M0)
; (with-continuation-mark ; ...
; debug-key ; (with-continuation-mark
; much-smaller-value ; debug-key
; (t0 ...)))) ; much-smaller-value
; ; (t0 ...))))
; 'break's are not illustrated. An optimization is possible when all expressions M0 ... are ;
; varrefs. In particular (where v0 ... are varrefs): ; 'break's are not illustrated. An optimization is possible when all expressions M0 ... are
; (v0 ...) ; varrefs. In particular (where v0 ... are varrefs):
; ; (v0 ...)
; goes to ;
; ; goes to
; (with-continuation-mark ;
; debug-key ; (with-continuation-mark
; debug-value ; debug-key
; (v0 ...)) ; debug-value
; ; (v0 ...))
; in other words, no real elaboration occurs. Note that this doesn't work as-is for the ;
; stepper, because there's nowhere to hang the breakpoint; you want to see the break ; in other words, no real elaboration occurs. Note that this doesn't work as-is for the
; occur after all vars have been evaluated. I suppose you could do (wcm ... (begin v0 ... (v0 ...))) ; stepper, because there's nowhere to hang the breakpoint; you want to see the break
; where the second set are not annotated ... but stepper runtime is not at a premium. ; occur after all vars have been evaluated. I suppose you could do (wcm ... (begin v0 ... (v0 ...)))
; where the second set are not annotated ... but stepper runtime is not at a premium.
;; the call/cc-safe version of this appears to work, and it lives in the definition of let. I should
;; transfer that knowledge to here. -- JBC, 2006-10-11 ;; the call/cc-safe version of this appears to work, and it lives in the definition of let. I should
;; transfer that knowledge to here. -- JBC, 2006-10-11
[(#%plain-app . terms)
(let*-2vals [(#%plain-app . terms)
([(annotated-terms free-varrefs-terms) (let*-2vals
(2vals-map non-tail-recur (syntax->list (syntax terms)))] ([(annotated-terms free-varrefs-terms)
[free-varrefs (varref-set-union free-varrefs-terms)]) (2vals-map non-tail-recur (syntax->list (syntax terms)))]
(2vals [free-varrefs (varref-set-union free-varrefs-terms)])
(let* ([arg-temps (build-list (length annotated-terms) get-arg-var)] (2vals
[tagged-arg-temps (map (lambda (var) (stepper-syntax-property var 'stepper-binding-type 'stepper-temp)) (let* ([arg-temps (build-list (length annotated-terms) get-arg-var)]
arg-temps)] [tagged-arg-temps (map (lambda (var) (stepper-syntax-property var 'stepper-binding-type 'stepper-temp))
[let-clauses #`((#,tagged-arg-temps arg-temps)]
(values #,@(map (lambda (_) *unevaluated*) tagged-arg-temps))))] [let-clauses #`((#,tagged-arg-temps
[set!-list (map (lambda (arg-symbol annotated-sub-exp) (values #,@(map (lambda (_) *unevaluated*) tagged-arg-temps))))]
#`(set! #,arg-symbol #,annotated-sub-exp)) [set!-list (map (lambda (arg-symbol annotated-sub-exp)
tagged-arg-temps annotated-terms)] #`(set! #,arg-symbol #,annotated-sub-exp))
[new-tail-bound (binding-set-union (list tail-bound tagged-arg-temps))] tagged-arg-temps annotated-terms)]
[app-debug-info (make-debug-info-app new-tail-bound tagged-arg-temps 'called)] [new-tail-bound (binding-set-union (list tail-bound tagged-arg-temps))]
[app-term (quasisyntax/loc exp #,tagged-arg-temps)] [app-debug-info (make-debug-info-app new-tail-bound tagged-arg-temps 'called)]
[debug-info (make-debug-info-app new-tail-bound [app-term (quasisyntax/loc exp #,tagged-arg-temps)]
(varref-set-union (list free-varrefs tagged-arg-temps)) ; NB using bindings as vars [debug-info (make-debug-info-app new-tail-bound
'not-yet-called)] (varref-set-union (list free-varrefs tagged-arg-temps)) ; NB using bindings as vars
[let-body (outer-wcm-wrap debug-info #`(begin #,@set!-list 'not-yet-called)]
#,(break-wrap [let-body (outer-wcm-wrap debug-info #`(begin #,@set!-list
(wcm-wrap #,(break-wrap
app-debug-info (wcm-wrap
#`(if (#,in-closure-table #,(car tagged-arg-temps)) app-debug-info
#,app-term #`(if (#,in-closure-table #,(car tagged-arg-temps))
#,(return-value-wrap app-term))))))]) #,app-term
#`(let-values #,let-clauses #,let-body)) #,(return-value-wrap app-term))))))])
;) #`(let-values #,let-clauses #,let-body))
free-varrefs))] ;)
free-varrefs))]
; @@
; @ @ ; @@
; $@:@ $@$: @@@@@ @@ @@ @@+-$: ; @ @
; $* *@ -@ @ @ @ @+@$@ ; $@:@ $@$: @@@@@ @@ @@ @@+-$:
; @ @ -$@$@ @ @ @ @ @ @ ; $* *@ -@ @ @ @ @+@$@
; @ @ $* @ @ @ @ @ @ @ ; @ @ -$@$@ @ @ @ @ @ @
; $* *@ @- *@ @: :$ @: +@ @ @ @ ; @ @ $* @ @ @ @ @ @ @
; $@:@@ -$$-@@ :@@$- :@$-@@@@@@@@@ ; $* *@ @- *@ @: :$ @: +@ @ @ @
; $@:@@ -$$-@@ :@@$- :@$-@@@@@@@@@
[(#%top . var-stx)
(varref-abstraction #`var-stx)] [(#%top . var-stx)
(varref-abstraction #`var-stx)]
[var-stx
(identifier? #`var-stx) [var-stx
(varref-abstraction #`var-stx)] (identifier? #`var-stx)
(varref-abstraction #`var-stx)]
[else
(error 'annotate "unexpected syntax for expression: ~v" (syntax->datum exp))])))]))) [else
(error 'annotate "unexpected syntax for expression: ~v" (syntax->datum exp))]))))])))
(define (stepper-recertify new-stx old-stx) (define (stepper-recertify new-stx old-stx)
(syntax-recertify new-stx old-stx (current-code-inspector) #f)) (syntax-recertify new-stx old-stx (current-code-inspector) #f))

12
collects/stepper/private/reconstruct.ss
View File

@ -148,7 +148,9 @@
(define (skip-step? break-kind mark-list render-settings) (define (skip-step? break-kind mark-list render-settings)
(case break-kind (case break-kind
[(result-value-break) [(result-value-break)
#f] (and (pair? mark-list)
(let ([expr (mark-source (car mark-list))])
(stepper-syntax-property expr 'stepper-hide-reduction)))]
[(result-exp-break) [(result-exp-break)
;; skip if clauses that are the result of and/or reductions ;; skip if clauses that are the result of and/or reductions
(let ([and/or-clauses-consumed (stepper-syntax-property (mark-source (car mark-list)) 'stepper-and/or-clauses-consumed)]) (let ([and/or-clauses-consumed (stepper-syntax-property (mark-source (car mark-list)) 'stepper-and/or-clauses-consumed)])
@ -521,8 +523,9 @@
; Accepts the source expression, a lifting-index which is either a number (indicating ; Accepts the source expression, a lifting-index which is either a number (indicating
; a lifted binding) or false (indicating a top-level expression), a list of values ; a lifted binding) or false (indicating a top-level expression), a list of values
; currently bound to the bindings, and the language level's render-settings. ; currently bound to the bindings, and the language level's render-settings.
;; returns a vectory containing a reconstructed expression and a boolean indicating whether this is source syntax ;; returns a vector containing a reconstructed expression and a boolean indicating
;; from a define-struct and therefore should not be unwound. ;; whether this should not be unwound (e.g., is source syntax
;; from a define-struct).
(define (reconstruct-completed exp lifting-indices vals-getter render-settings) (define (reconstruct-completed exp lifting-indices vals-getter render-settings)
(if lifting-indices (if lifting-indices
@ -537,6 +540,9 @@
[(stepper-syntax-property exp 'stepper-define-struct-hint) [(stepper-syntax-property exp 'stepper-define-struct-hint)
;; the hint contains the original syntax ;; the hint contains the original syntax
(vector (stepper-syntax-property exp 'stepper-define-struct-hint) #t)] (vector (stepper-syntax-property exp 'stepper-define-struct-hint) #t)]
;; for test cases, use the result here as the final result of the expression:
[(stepper-syntax-property exp 'stepper-use-val-as-final)
(vector (recon-value (car (vals-getter)) render-settings) #f)]
[else [else
(vector (vector
(kernel:kernel-syntax-case exp #f (kernel:kernel-syntax-case exp #f