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

521
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) [(#%plain-lambda . clause)
(let*-2vals ([(annotated-clause free-varrefs) (let*-2vals ([(annotated-clause free-varrefs)
(lambda-clause-abstraction (syntax clause))] (lambda-clause-abstraction (syntax clause))]
[annotated-lambda [annotated-lambda
(with-syntax ([annotated-clause annotated-clause]) (with-syntax ([annotated-clause annotated-clause])
(syntax/loc exp (#%plain-lambda . annotated-clause)))]) (syntax/loc exp (#%plain-lambda . annotated-clause)))])
(outer-lambda-abstraction annotated-lambda free-varrefs))] (outer-lambda-abstraction annotated-lambda free-varrefs))]
[(case-lambda . clauses) [(case-lambda . clauses)
(let*-2vals ([(annotated-cases free-varrefs-cases) (let*-2vals ([(annotated-cases free-varrefs-cases)
(2vals-map lambda-clause-abstraction (syntax->list (syntax clauses)))] (2vals-map lambda-clause-abstraction (syntax->list (syntax clauses)))]
[annotated-case-lambda (with-syntax ([annotated-cases annotated-cases]) [annotated-case-lambda (with-syntax ([annotated-cases annotated-cases])
(syntax/loc exp (case-lambda . annotated-cases)))] (syntax/loc exp (case-lambda . annotated-cases)))]
[free-varrefs (varref-set-union free-varrefs-cases)]) [free-varrefs (varref-set-union free-varrefs-cases)])
(outer-lambda-abstraction annotated-case-lambda free-varrefs))] (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 . bodies-stx)
(begin (begin
(error 'annotate-inner "nothing expands into begin! : ~v" (syntax->datum exp)) (error 'annotate-inner "nothing expands into begin! : ~v" (syntax->datum exp))
#;(begin-abstraction (syntax->list #`bodies-stx)))] #;(begin-abstraction (syntax->list #`bodies-stx)))]
; ;
; ;
; ; ; ;; ; ; ; ;;
; ; ; ; ; ; ; ;
; ; ; ;; ; ; ; ;;
; ; ;; ;;; ;;;; ;;; ; ;; ; ; ; ; ; ;; ;;; ;;;; ;;; ; ;; ; ; ;
; ;; ; ; ; ; ; ; ;; ; ; ; ; ; ;; ; ; ; ; ; ; ;; ; ; ; ;
; ; ; ;;;;; ; ; ; ; ; ; ; ; ; ; ; ;;;;; ; ; ; ; ; ; ; ;
; ; ; ; ; ; ; ; ; ;; ; ; ; ; ; ; ; ; ; ; ;; ;
; ; ; ; ; ;; ; ; ; ;; ; ; ; ; ; ; ;; ; ; ; ;; ;
; ;;;; ;;;; ;; ; ;;; ; ; ;; ; ;;;; ;;;; ;; ; ;;; ; ; ;;
; ; ; ;
; ;;;; ; ;;;;
; ;
;; one-element begin0 is a special case, because in this case only ;; one-element begin0 is a special case, because in this case only
;; the body of the begin0 is in tail position. ;; the body of the begin0 is in tail position.
[(begin0 body) [(begin0 body)
(let*-2vals ([(annotated-body free-vars-body) (let*-2vals ([(annotated-body free-vars-body)
(tail-recur #'body)]) (tail-recur #'body)])
(2vals (wcm-break-wrap (make-debug-info-normal free-vars-body) (2vals (wcm-break-wrap (make-debug-info-normal free-vars-body)
(quasisyntax/loc exp (begin0 #,annotated-body))) (quasisyntax/loc exp (begin0 #,annotated-body)))
free-vars-body))] free-vars-body))]
[(begin0 first-body . bodies-stx) [(begin0 first-body . bodies-stx)
(let*-2vals ([(annotated-first free-vars-first) (result-recur #'first-body)] (let*-2vals ([(annotated-first free-vars-first) (result-recur #'first-body)]
[(annotated-rest free-vars-rest) (2vals-map non-tail-recur (syntax->list #`bodies-stx))] [(annotated-rest free-vars-rest) (2vals-map non-tail-recur (syntax->list #`bodies-stx))]
[wrapped-rest (map normal-break/values-wrap annotated-rest)] [wrapped-rest (map normal-break/values-wrap annotated-rest)]
[all-free-vars (varref-set-union (cons free-vars-first free-vars-rest))] [all-free-vars (varref-set-union (cons free-vars-first free-vars-rest))]
[early-debug-info (make-debug-info-normal all-free-vars)] [early-debug-info (make-debug-info-normal all-free-vars)]
[tagged-temp (stepper-syntax-property begin0-temp 'stepper-binding-type 'stepper-temp)] [tagged-temp (stepper-syntax-property begin0-temp 'stepper-binding-type 'stepper-temp)]
[debug-info-maker [debug-info-maker
(lambda (rest-exps) (lambda (rest-exps)
(make-debug-info-fake-exp/tail-bound (make-debug-info-fake-exp/tail-bound
#`(begin0 #,@rest-exps) #`(begin0 #,@rest-exps)
(binding-set-union (list (list tagged-temp) tail-bound)) (binding-set-union (list (list tagged-temp) tail-bound))
(varref-set-union (list (list tagged-temp) all-free-vars))))] (varref-set-union (list (list tagged-temp) all-free-vars))))]
[rolled-into-fakes (let loop ([remaining-wrapped wrapped-rest] [rolled-into-fakes (let loop ([remaining-wrapped wrapped-rest]
[remaining-src (syntax->list #`bodies-stx)] [remaining-src (syntax->list #`bodies-stx)]
[first-time? #t]) [first-time? #t])
((if first-time? wcm-wrap wcm-pre-break-wrap) ((if first-time? wcm-wrap wcm-pre-break-wrap)
(debug-info-maker remaining-src) (debug-info-maker remaining-src)
(cond [(null? remaining-src) begin0-temp] (cond [(null? remaining-src) begin0-temp]
[else #`(begin #,(car remaining-wrapped) #,(loop (cdr remaining-wrapped) [else #`(begin #,(car remaining-wrapped) #,(loop (cdr remaining-wrapped)
(cdr remaining-src) (cdr remaining-src)
#f))])))]) #f))])))])
(2vals (wcm-wrap early-debug-info (2vals (wcm-wrap early-debug-info
#`(let ([#,begin0-temp #,annotated-first]) #`(let ([#,begin0-temp #,annotated-first])
#,rolled-into-fakes)) #,rolled-into-fakes))
all-free-vars))] all-free-vars))]
; ;
; ;
; ;;; ;;; ; ;;; ;;;
; ; ; ; ; ; ; ;
; ; ; ; ; ; ; ;
; ; ;;; ;;;;; ; ; ;;;; ; ; ; ;;; ;;; ; ; ;;; ;;;;; ; ; ;;;; ; ; ; ;;; ;;;
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
; ; ;;;;; ; ;;;;; ; ; ; ; ; ; ; ;;;;; ;; ; ; ;;;;; ; ;;;;; ; ; ; ; ; ; ; ;;;;; ;;
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
; ; ; ; ; ; ; ;; ; ; ;; ; ; ; ; ; ; ; ; ; ; ;; ; ; ;; ; ; ;
; ;;; ;;;; ;; ; ;; ; ;;; ;; ; ;;;; ;;; ; ;;; ;;;; ;; ; ;; ; ;;; ;; ; ;;;; ;;;
; ;
; ;
; ;
[(let-values . _) [(let-values . _)
(let-abstraction exp (let-abstraction exp
#`let-values #`let-values
(lambda (bindings) (lambda (bindings)
(map (lambda (_) *unevaluated*) bindings)))] (map (lambda (_) *unevaluated*) bindings)))]
[(letrec-values . _) [(letrec-values . _)
(let-abstraction exp (let-abstraction exp
#`letrec-values #`letrec-values
(lambda (bindings) (map (lambda (b) #`#,b) bindings)))] (lambda (bindings) (map (lambda (b) #`#,b) bindings)))]
; $ ; $
; @ @ ; @ @
; :@@+@ -@@$ @@@@@ @ ; :@@+@ -@@$ @@@@@ @
; @$ -@ $ -$ @ @ ; @$ -@ $ -$ @ @
; :@@$- @@@@@ @ @ ; :@@$- @@@@@ @ @
; *@ $ @ ; *@ $ @
; @ :@ +: @: :$ ; @ :@ +: @: :$
; $+@@: $@@+ :@@$- $ ; $+@@: $@@+ :@@$- $
[(set! var val) [(set! var val)
(let*-2vals (let*-2vals
([(annotated-val val-free-varrefs) ([(annotated-val val-free-varrefs)
(set!-rhs-recur (syntax val) (syntax-case (syntax var) (#%top) (set!-rhs-recur (syntax val) (syntax-case (syntax var) (#%top)
[(#%top . real-var) (syntax-e (syntax real-var))] [(#%top . real-var) (syntax-e (syntax real-var))]
[else (syntax var)]))] [else (syntax var)]))]
[free-varrefs (varref-set-union (list val-free-varrefs (list #`var)))] [free-varrefs (varref-set-union (list val-free-varrefs (list #`var)))]
[annotated-set! [annotated-set!
(return-value-wrap (return-value-wrap
(quasisyntax/loc exp (set! var #,(normal-break/values-wrap annotated-val))))]) (quasisyntax/loc exp (set! var #,(normal-break/values-wrap annotated-val))))])
(2vals (2vals
(outer-wcm-wrap (make-debug-info-normal free-varrefs) annotated-set!) (outer-wcm-wrap (make-debug-info-normal free-varrefs) annotated-set!)
free-varrefs))] free-varrefs))]
; @ ; @
; $@-@@@@ @@ $@$ @@@@@ -@@$ ; $@-@@@@ @@ $@$ @@@@@ -@@$
; $- :@ @ @ $- -$ @ $ -$ ; $- :@ @ @ $- -$ @ $ -$
; @ @ @ @ @ @ @ @@@@@ ; @ @ @ @ @ @ @ @@@@@
; @ @ @ @ @ @ @ $ ; @ @ @ @ @ @ @ $
; $- :@ @: +@ $- -$ @: :$ +: ; $- :@ @: +@ $- -$ @: :$ +:
; $@-@ :@$-@@ $@$ :@@$- $@@+ ; $@-@ :@$-@@ $@$ :@@$- $@@+
; @ ; @
; @@@ ; @@@
[(quote _) [(quote _)
(normal-bundle null exp)] (normal-bundle null exp)]
[(quote-syntax _) [(quote-syntax _)
(normal-bundle null exp)] (normal-bundle null exp)]
; @@@ @@@ $@+@ @@+-$: ; @@@ @@@ $@+@ @@+-$:
; @ @ $+ -@ @+@$@ ; @ @ $+ -@ @+@$@
; $-@ @ @@@@@ @ @@@@@ @ @ @ ; $-@ @ @@@@@ @ @@@@@ @ @ @
; ++@+$ @ @ @ @ ; ++@+$ @ @ @ @
; :@@$+ $* -$ @ @ @ ; :@@$+ $* -$ @ @ @
; -@$@* $@$- @@@@@@@ ; -@$@* $@$- @@@@@@@
[(with-continuation-mark key mark body) [(with-continuation-mark key mark body)
;(let*-2vals ([(annotated-key free-varrefs-key) ;(let*-2vals ([(annotated-key free-varrefs-key)
; (non-tail-recur (syntax key))] ; (non-tail-recur (syntax key))]
; [(annotated-mark free-varrefs-mark) ; [(annotated-mark free-varrefs-mark)
; (non-tail-recur (syntax mark))] ; (non-tail-recur (syntax mark))]
; [(annotated-body dc_free-varrefs-body) ; [(annotated-body dc_free-varrefs-body)
; (result-recur (syntax body))]) ; (result-recur (syntax body))])
(error 'annotate/inner "this region of code is still under construction") (error 'annotate/inner "this region of code is still under construction")
; [annotated #`(let-values ([key-temp #,*unevaluated*] ; [annotated #`(let-values ([key-temp #,*unevaluated*]
; [mark-temp #,*unevaluated*] ; [mark-temp #,*unevaluated*]
;) ;)
] ]
; @@ @ @ ; @@ @ @
; @ @ ; @ @
; $@$: @@:@$- @@:@$- @ -@@ $@+@ $@$: @@@@@ -@@ $@$ @@:@@: ; $@$: @@:@$- @@:@$- @ -@@ $@+@ $@$: @@@@@ -@@ $@$ @@:@@:
; -@ @: -$ @: -$ @ @ $+ -@ -@ @ @ $- -$ @+ :@ ; -@ @: -$ @: -$ @ @ $+ -@ -@ @ @ $- -$ @+ :@
; -$@$@ @ @ @ @ @ @ @ -$@$@ @ @ @ @ @ @ ; -$@$@ @ @ @ @ @ @ @ -$@$@ @ @ @ @ @ @
; $* @ @ @ @ @ @ @ @ $* @ @ @ @ @ @ @ ; $* @ @ @ @ @ @ @ @ $* @ @ @ @ @ @ @
; @- *@ @: -$ @: -$ @ @ $* -$ @- *@ @: :$ @ $- -$ @ @ ; @- *@ @: -$ @: -$ @ @ $* -$ @- *@ @: :$ @ $- -$ @ @
; -$$-@@ @-@$ @-@$ @@@@@ @@@@@ $@$- -$$-@@ :@@$- @@@@@ $@$ @@@ @@@ ; -$$-@@ @-@$ @-@$ @@@@@ @@@@@ $@$- -$$-@@ :@@$- @@@@@ $@$ @@@ @@@
; @ @ ; @ @
; @@@ @@@ ; @@@ @@@
; [foot-wrap? ; [foot-wrap?
; (wcm-wrap debug-info annotated)]) ; (wcm-wrap debug-info annotated)])
; free-bindings))] ; free-bindings))]
; the app form's elaboration looks like this, where M0 etc. stand for expressions, and t0 etc ; 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: ; are temp identifiers that do not occur in the program:
; (M0 ...) ; (M0 ...)
; ;
; goes to ; goes to
; ;
;(let ([t0 *unevaluated*] ;(let ([t0 *unevaluated*]
; ...) ; ...)
; (with-continuation-mark ; (with-continuation-mark
; debug-key ; debug-key
; huge-value ; huge-value
; (set! t0 M0) ; (set! t0 M0)
; ... ; ...
; (with-continuation-mark ; (with-continuation-mark
; debug-key ; debug-key
; much-smaller-value ; much-smaller-value
; (t0 ...)))) ; (t0 ...))))
; ;
; 'break's are not illustrated. An optimization is possible when all expressions M0 ... are ; 'break's are not illustrated. An optimization is possible when all expressions M0 ... are
; varrefs. In particular (where v0 ... are varrefs): ; varrefs. In particular (where v0 ... are varrefs):
; (v0 ...) ; (v0 ...)
; ;
; goes to ; goes to
; ;
; (with-continuation-mark ; (with-continuation-mark
; debug-key ; debug-key
; debug-value ; debug-value
; (v0 ...)) ; (v0 ...))
; ;
; in other words, no real elaboration occurs. Note that this doesn't work as-is for the ; 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 ; stepper, because there's nowhere to hang the breakpoint; you want to see the break
; occur after all vars have been evaluated. I suppose you could do (wcm ... (begin v0 ... (v0 ...))) ; 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. ; 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 ;; 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 ;; transfer that knowledge to here. -- JBC, 2006-10-11
[(#%plain-app . terms) [(#%plain-app . terms)
(let*-2vals (let*-2vals
([(annotated-terms free-varrefs-terms) ([(annotated-terms free-varrefs-terms)
(2vals-map non-tail-recur (syntax->list (syntax terms)))] (2vals-map non-tail-recur (syntax->list (syntax terms)))]
[free-varrefs (varref-set-union free-varrefs-terms)]) [free-varrefs (varref-set-union free-varrefs-terms)])
(2vals (2vals
(let* ([arg-temps (build-list (length annotated-terms) get-arg-var)] (let* ([arg-temps (build-list (length annotated-terms) get-arg-var)]
[tagged-arg-temps (map (lambda (var) (stepper-syntax-property var 'stepper-binding-type 'stepper-temp)) [tagged-arg-temps (map (lambda (var) (stepper-syntax-property var 'stepper-binding-type 'stepper-temp))
arg-temps)] arg-temps)]
[let-clauses #`((#,tagged-arg-temps [let-clauses #`((#,tagged-arg-temps
(values #,@(map (lambda (_) *unevaluated*) tagged-arg-temps))))] (values #,@(map (lambda (_) *unevaluated*) tagged-arg-temps))))]
[set!-list (map (lambda (arg-symbol annotated-sub-exp) [set!-list (map (lambda (arg-symbol annotated-sub-exp)
#`(set! #,arg-symbol #,annotated-sub-exp)) #`(set! #,arg-symbol #,annotated-sub-exp))
tagged-arg-temps annotated-terms)] tagged-arg-temps annotated-terms)]
[new-tail-bound (binding-set-union (list tail-bound tagged-arg-temps))] [new-tail-bound (binding-set-union (list tail-bound tagged-arg-temps))]
[app-debug-info (make-debug-info-app new-tail-bound tagged-arg-temps 'called)] [app-debug-info (make-debug-info-app new-tail-bound tagged-arg-temps 'called)]
[app-term (quasisyntax/loc exp #,tagged-arg-temps)] [app-term (quasisyntax/loc exp #,tagged-arg-temps)]
[debug-info (make-debug-info-app new-tail-bound [debug-info (make-debug-info-app new-tail-bound
(varref-set-union (list free-varrefs tagged-arg-temps)) ; NB using bindings as vars (varref-set-union (list free-varrefs tagged-arg-temps)) ; NB using bindings as vars
'not-yet-called)] 'not-yet-called)]
[let-body (outer-wcm-wrap debug-info #`(begin #,@set!-list [let-body (outer-wcm-wrap debug-info #`(begin #,@set!-list
#,(break-wrap #,(break-wrap
(wcm-wrap (wcm-wrap
app-debug-info app-debug-info
#`(if (#,in-closure-table #,(car tagged-arg-temps)) #`(if (#,in-closure-table #,(car tagged-arg-temps))
#,app-term #,app-term
#,(return-value-wrap app-term))))))]) #,(return-value-wrap app-term))))))])
#`(let-values #,let-clauses #,let-body)) #`(let-values #,let-clauses #,let-body))
;) ;)
free-varrefs))] free-varrefs))]
; @@ ; @@
; @ @ ; @ @
; $@:@ $@$: @@@@@ @@ @@ @@+-$: ; $@:@ $@$: @@@@@ @@ @@ @@+-$:
; $* *@ -@ @ @ @ @+@$@ ; $* *@ -@ @ @ @ @+@$@
; @ @ -$@$@ @ @ @ @ @ @ ; @ @ -$@$@ @ @ @ @ @ @
; @ @ $* @ @ @ @ @ @ @ ; @ @ $* @ @ @ @ @ @ @
; $* *@ @- *@ @: :$ @: +@ @ @ @ ; $* *@ @- *@ @: :$ @: +@ @ @ @
; $@:@@ -$$-@@ :@@$- :@$-@@@@@@@@@ ; $@:@@ -$$-@@ :@@$- :@$-@@@@@@@@@
[(#%top . var-stx) [(#%top . var-stx)
(varref-abstraction #`var-stx)] (varref-abstraction #`var-stx)]
[var-stx [var-stx
(identifier? #`var-stx) (identifier? #`var-stx)
(varref-abstraction #`var-stx)] (varref-abstraction #`var-stx)]
[else [else
(error 'annotate "unexpected syntax for expression: ~v" (syntax->datum exp))])))]))) (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