diff --git a/collects/stepper/private/annotate.ss b/collects/stepper/private/annotate.ss index 760f634892..543c178dbe 100644 --- a/collects/stepper/private/annotate.ss +++ b/collects/stepper/private/annotate.ss @@ -445,6 +445,9 @@ [make-debug-info-fake-exp (lambda (exp free-bindings) (make-debug-info (stepper-syntax-property exp 'stepper-fake-exp #t) tail-bound free-bindings 'none #t))] + [make-debug-info-fake-exp/tail-bound (lambda (exp tail-bound free-bindings) + (make-debug-info (stepper-syntax-property exp 'stepper-fake-exp #t) + tail-bound free-bindings 'none #t))] [outer-wcm-wrap (if pre-break? wcm-pre-break-wrap @@ -843,47 +846,33 @@ (quasisyntax/loc exp (begin0 #,annotated-body))) free-vars-body))] - #;(let unroll-loop ([bodies-list bodies-list] [outermost? #t]) - (cond [(null? bodies-list) - (error 'annotate "no bodies in let")] - [(null? (cdr bodies-list)) - (tail-recur (car bodies-list))] - [else - (let*-2vals - ([(rest free-vars-rest) (unroll-loop (cdr bodies-list) #f)] - [(this-one free-vars-this) (non-tail-recur (car bodies-list))] - [free-vars-all (varref-set-union (list free-vars-rest free-vars-this))] - [debug-info (make-debug-info-fake-exp - #`(begin #,@bodies-list) - free-vars-all)] - [begin-form #`(begin #,(normal-break/values-wrap this-one) #,rest)]) - (2vals (if outermost? - (wcm-wrap debug-info begin-form) - (wcm-pre-break-wrap debug-info begin-form)) - free-vars-all))])) - - ;; temporary hack for ProfJ stepper, 2006-12-4, JBC - [(begin0 first-body . bodies-stx) - #`(error "shouldn't get evaluated, please.\n")] - #;[(begin0 first-body . bodies-stx) - (let*-2vals ([(annotated-first free-vars-first) (result-recur first-body)]) - #`(let ([,begin0-temp #,annotated-first]) - #,unrolled-rest)) - (let unroll-loop ([bodies-list (syntax->list #`(first-body . bodies-stx))] [outermost? #t]) - (cond [(null? bodies-list) - (error 'annotate "this case should have been handled by the zero-body annotation")] - [(null? (cdr bodies-list)) - (let*-2vals - ([(this-one free-vars-this) (non-tail-recur)]))])) - (let*-2vals - ([bodies (syntax->list (syntax bodies-stx))] - [(annotated-first free-varrefs-first) - (result-recur (car bodies))] - [(annotated-bodies free-varref-sets) - (2vals-map non-tail-recur (cdr bodies))]) - (normal-bundle (varref-set-union (cons free-varrefs-first free-varref-sets)) - (quasisyntax/loc exp (begin0 #,annotated-first #,@annotated-bodies))))] + [(begin0 first-body . bodies-stx) + (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))] + [wrapped-rest (map normal-break/values-wrap annotated-rest)] + [all-free-vars (varref-set-union (cons free-vars-first free-vars-rest))] + [early-debug-info (make-debug-info-normal all-free-vars)] + [tagged-temp (stepper-syntax-property begin0-temp 'stepper-binding-type 'stepper-temp)] + [debug-info-maker + (lambda (rest-exps) + (make-debug-info-fake-exp/tail-bound + #`(begin0 #,@rest-exps) + (binding-set-union (list (list tagged-temp) tail-bound)) + (varref-set-union (list (list tagged-temp) all-free-vars))))] + [rolled-into-fakes (let loop ([remaining-wrapped wrapped-rest] + [remaining-src (syntax->list #`bodies-stx)] + [first-time? #t]) + ((if first-time? wcm-wrap wcm-pre-break-wrap) + (debug-info-maker remaining-src) + (cond [(null? remaining-src) begin0-temp] + [else #`(begin #,(car remaining-wrapped) #,(loop (cdr remaining-wrapped) + (cdr remaining-src) + #f))])))]) + (2vals (wcm-wrap early-debug-info + #`(let ([#,begin0-temp #,annotated-first]) + #,rolled-into-fakes)) + all-free-vars))] diff --git a/collects/stepper/private/model.ss b/collects/stepper/private/model.ss index f7fa3aa4fa..175aceb950 100644 --- a/collects/stepper/private/model.ss +++ b/collects/stepper/private/model.ss @@ -162,22 +162,6 @@ 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 ; given #f - - ;; === context === - ;; ...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) diff --git a/collects/stepper/private/reconstruct.ss b/collects/stepper/private/reconstruct.ss index f40f8b5099..3c6e3ed72b 100644 --- a/collects/stepper/private/reconstruct.ss +++ b/collects/stepper/private/reconstruct.ss @@ -11,7 +11,8 @@ "marks.ss" "model-settings.ss" "shared.ss" - "my-macros.ss") + "my-macros.ss" + (file "~/clements/scheme-scraps/eli-debug.ss")) (provide/contract [reconstruct-completed (syntax? @@ -365,7 +366,14 @@ [(if test then else) (recon-basic)] [(if test then) (recon-basic)] [(begin . bodies) (recon-basic)] - [(begin0 . bodies) (recon-basic)] + [(begin0 . bodies) + (if (stepper-syntax-property expr 'stepper-fake-exp) + (if (null? (syntax->list #`bodies)) + (recon-value (lookup-binding mark-list begin0-temp) render-settings) + ;; prepend the computed value of the first arg: + #`(begin0 #,(recon-value (lookup-binding mark-list begin0-temp) render-settings) + #,@(map recur (filter-skipped (syntax->list #`bodies))))) + (recon-basic))] ; let-values, letrec-values [(let-values . rest) (recon-let/rec #f)] @@ -440,7 +448,9 @@ (syntax var)] [else - (error 'recon-source "no matching clause for syntax: ~a" expr)])]) + (error 'recon-source "no matching clause for syntax: ~a" (if (syntax? expr) + (syntax-object->datum expr) + expr))])]) (attach-info recon expr))))))) ;; reconstruct-set!-var @@ -686,11 +696,17 @@ (attach-info #`(label #,recon-bindings #,@rectified-bodies) exp))))]) (if (stepper-syntax-property exp 'stepper-fake-exp) - (syntax-case exp () + (kernel:kernel-syntax-case exp #f [(begin . bodies) (if (eq? so-far nothing-so-far) (error 'recon-inner "breakpoint before a begin reduction should have a result value in exp: ~a" (syntax-object->datum exp)) #`(begin #,so-far #,@(map recon-source-current-marks (cdr (syntax->list #'bodies)))))] + [(begin0 first-body . rest-bodies) + (if (eq? so-far nothing-so-far) + (error 'recon-inner "breakpoint before a begin0 reduction should have a result value in exp: ~a" (syntax-object->datum exp)) + #`(begin0 #,(recon-value (lookup-binding mark-list begin0-temp) render-settings) + #,so-far + #,@(map recon-source-current-marks (syntax->list #`rest-bodies))))] [else (error 'recon-inner "unexpected fake-exp expression: ~a" (syntax-object->datum exp))]) @@ -812,6 +828,14 @@ (recon-source-current-marks exp) (error 'recon-inner "one-body begin0 given as context: ~a" exp))] + ;; the only time begin0 shows up other than in a fake-exp is when the first + ;; term is being evaluated + [(begin0 first-body . rest-bodies) + (if (eq? so-far nothing-so-far) + (error 'foo "not implemented") + ;; don't know what goes hereyet + #`(begin0 #,so-far #,@(map recon-source-current-marks (syntax->list #`rest-bodies))))] + ; let-values [(let-values . rest) (recon-let)]