diff --git a/collects/stepper/private/annotate.ss b/collects/stepper/private/annotate.ss index b93946a6a9..46f620d983 100644 --- a/collects/stepper/private/annotate.ss +++ b/collects/stepper/private/annotate.ss @@ -259,7 +259,7 @@ ; (define (annotate main-exp break track-inferred-names?) - (define _ (fprintf (current-error-port) "input to annotate: ~v\n" (syntax-object->datum main-exp))) + #;(define _ (fprintf (current-error-port) "input to annotate: ~v\n" (syntax-object->datum main-exp))) (define binding-indexer (let ([binding-index 0]) @@ -415,19 +415,21 @@ ;; no pre-break, non-tail w.r.t. new bindings [let-body-recur/first (lambda (exp) - (normal-break/values-wrap + (apply-to-first-of-2vals + normal-break/values-wrap (non-tail-recur exp)))] ;; yes pre-break, non-tail w.r.t. new bindings [let-body-recur/middle (lambda (exp) - (normal-break/values-wrap + (apply-to-first-of-2vals + normal-break/values-wrap (annotate/inner exp null #t #f)))] ;; yes pre-break, tail w.r.t. new bindings: [let-body-recur/last (lambda (exp bindings) - (annotate/inner exp (binding-set-union (list tail-bound bindings)) #f procedure-name-info))] + (annotate/inner exp (binding-set-union (list tail-bound bindings)) #t procedure-name-info))] ;; different flavors of make-debug-info allow users to provide only the needed fields: @@ -598,14 +600,10 @@ [(first* fv-first) (let-body-recur/first first)] [(middle* fv-middle) (2vals-map let-body-recur/middle middle)] - [(last* fv-last) (let-body-recur/last last binding-list)] - - [first** (return-value-wrap first*)] - [middle** (map return-value-wrap middle*)] - [last** last*]) + [(last* fv-last) (let-body-recur/last last binding-list)]) (2vals (quasisyntax/loc exp - (begin #,first** #,@middle** #,last**)) + (begin #,first* #,@middle* #,last*)) (varref-set-union (cons fv-first (cons fv-last fv-middle))))))]) ((2vals (quasisyntax/loc @@ -785,11 +783,10 @@ [recertifier (lambda (vals) (let*-2vals ([(new-exp bindings) vals]) - (2vals (stepper-recertify new-exp exp) - bindings - #;(map (lambda (b) - (syntax-recertify b exp (current-code-inspector) #f)) - bindings))))] + (2vals (stepper-recertify new-exp exp) + (map (lambda (b) + (syntax-recertify b exp (current-code-inspector) #f)) + bindings))))] ) ; find the source expression and associate it with the parsed expression @@ -1070,12 +1067,11 @@ [defined-name (if (and (pair? name-list) (null? (cdr name-list))) (car name-list) #f)]) - (stepper-recertify - #`(begin + #`(begin (define-values (new-var ...) #,(top-level-annotate/inner (top-level-rewrite #`e) exp defined-name)) ;; this next expression should deliver the newly computed values to an exp-finished-break - (#,exp-finished-break (list (list #,(lambda () exp) #f (lambda () (list new-var ...))))))))] + (#,exp-finished-break (list (list #,(lambda () exp) #f (lambda () (list new-var ...)))))))] [(define-syntaxes (new-vars ...) e) exp] [(require specs ...) diff --git a/collects/stepper/private/model.ss b/collects/stepper/private/model.ss index a16ed2dd2e..39057fcffa 100644 --- a/collects/stepper/private/model.ss +++ b/collects/stepper/private/model.ss @@ -171,7 +171,7 @@ x) (define break - (opt-lambda (mark-set break-kind [returned-value-list null]) + (opt-lambda (mark-set break-kind [returned-value-list #f]) (let* ([mark-list (and mark-set (extract-mark-list mark-set))]) @@ -194,15 +194,23 @@ (error 'double-redivide "reconstructed after defs are not equal.")) (values (append finished-exps before) current current-2 after))) + #;(printf "break called with break-kind: ~a ..." break-kind) (if (r:skip-step? break-kind mark-list render-settings) - (when (eq? break-kind 'normal-break) - (set! held-exp-list skipped-step)) + (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 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 (r:reconstruct-left-side mark-list render-settings)) + (set! held-exp-list (r:reconstruct-left-side mark-list returned-value-list render-settings)) (set! held-step-was-app? (r:step-was-app? mark-list)))] [(result-exp-break result-value-break) @@ -264,7 +272,7 @@ (apply add-to-finished source/index/getter)) returned-value-list)] - [else (error 'break "unknown label on break")]))))) + [else (error 'break "unknown label on break")])))))) @@ -285,8 +293,8 @@ (program-expander (lambda () ; swap these to allow errors to escape (e.g., when debugging) - (error-display-handler err-display-handler) - #;(void) + #;(error-display-handler err-display-handler) + (void) ) (lambda (expanded continue-thunk) ; iter (if (eof-object? expanded) diff --git a/collects/stepper/private/my-macros.ss b/collects/stepper/private/my-macros.ss index 2277da0a9f..7bd1eccdf4 100644 --- a/collects/stepper/private/my-macros.ss +++ b/collects/stepper/private/my-macros.ss @@ -42,7 +42,7 @@ ;; ;;;;;;;;;; - (provide 2vals let*-2vals 2vals-first 2vals-second 2vals-map) + (provide 2vals let*-2vals 2vals-first 2vals-second 2vals-map apply-to-first-of-2vals) (define 2vals vector) @@ -54,8 +54,8 @@ (syntax/loc stx (let* ([_a rhs] [id-a (vector-ref _a 0)] [id-b (vector-ref _a 1)]) (let*-2vals (binding ...) . bodies)))] [(let*-2vals ([id-a rhs] binding ...) . bodies) ; just 1 value - (syntax/loc stx (let* ([id-a rhs]) - (let*-2vals (binding ...) . bodies)))])) + (quasisyntax/loc stx (let* ([id-a rhs]) + #,(syntax/loc stx (let*-2vals (binding ...) . bodies))))])) (define-syntax (2vals-first stx) (syntax-case stx (2vals-first) @@ -66,6 +66,10 @@ (syntax-case stx (2vals-second) [(2vals-second a) (syntax (vector-ref a 1))])) + + (define (apply-to-first-of-2vals proc 2vals) + (vector (proc (vector-ref 2vals 0)) + (vector-ref 2vals 1))) ; 2vals-map : (('a -> (2vals 'b 'c)) ('a list)) -> (2vals ('b list) ('c list)) ; dual-map is like map, only for a procedure that returns (values a b), and its diff --git a/collects/stepper/private/reconstruct.ss b/collects/stepper/private/reconstruct.ss index b92620489a..69db69bc00 100644 --- a/collects/stepper/private/reconstruct.ss +++ b/collects/stepper/private/reconstruct.ss @@ -24,11 +24,12 @@ ;; front ends for reconstruct-current [reconstruct-left-side (mark-list? + (union (listof any/c) false/c) render-settings? . -> . (listof syntax?))] [reconstruct-right-side (mark-list? - (listof any/c) + (union (listof any/c) false/c) render-settings? . -> . (listof syntax?))] @@ -148,7 +149,7 @@ (let ([and/or-clauses-consumed (syntax-property (mark-source (car mark-list)) 'stepper-and/or-clauses-consumed)]) (and and/or-clauses-consumed (> and/or-clauses-consumed 0)))] - [(normal-break) + [(normal-break normal-break/values) (skip-redex-step? mark-list render-settings)] [(double-break) (or @@ -820,8 +821,8 @@ ;; front ends for reconstruct-current: - (define (reconstruct-left-side mark-list render-settings) - (reconstruct-current mark-list 'left-side null render-settings)) + (define (reconstruct-left-side mark-list returned-value-list render-settings) + (reconstruct-current mark-list 'left-side returned-value-list render-settings)) (define (reconstruct-right-side mark-list returned-value-list render-settings) @@ -967,25 +968,24 @@ ; if [(if test then else) - (attach-info - (let ([test-exp (if (eq? so-far nothing-so-far) - (recon-value (lookup-binding mark-list if-temp) render-settings) - so-far)]) - #`(if #,test-exp + (begin + (when (eq? so-far nothing-so-far) + (error 'reconstruct "breakpoint before an if reduction should have a result value")) + (attach-info + #`(if #,so-far #,(recon-source-current-marks (syntax then)) - #,(recon-source-current-marks (syntax else)))) - exp)] + #,(recon-source-current-marks (syntax else))) + exp))] ; one-armed if [(if test then) - (attach-info - (let ([test-exp (if (eq? so-far nothing-so-far) - (recon-value (lookup-binding mark-list if-temp) render-settings) - so-far)]) - #`(if #,test-exp - #,(recon-source-current-marks (syntax then)))) - exp)] + (begin + (when (eq? so-far nothing-so-far) + (error 'reconstruct "breakpoint before an if reduction should have a result value")) + (attach-info + #`(if #,so-far #,(recon-source-current-marks (syntax then))) + exp))] ; quote : there is no break on a quote. @@ -1054,14 +1054,14 @@ [(letrec-values . rest) (recon-let)] - [(set! var rhs) - (attach-info - (let ([rhs-exp (if (eq? so-far nothing-so-far) - (recon-value (lookup-binding mark-list set!-temp) render-settings) - so-far)] - [rendered-var (reconstruct-set!-var mark-list #`var)]) - #`(set! #,rendered-var #,rhs-exp)) - exp)] + [(set! var rhs) + (begin + (when (eq? so-far nothing-so-far) + (error 'reconstruct "breakpoint before an if reduction should have a result value")) + (attach-info + (let ([rendered-var (reconstruct-set!-var mark-list #`var)]) + #`(set! #,rendered-var #,so-far)) + exp))] ; lambda : there is no break on a lambda @@ -1094,18 +1094,27 @@ #f))])])) ; uncomment to see all breaks coming in: - #;(define _ (printf "break-kind: ~a\ninnermost source: ~a\n" break-kind - (and (pair? mark-list) - (syntax-object->datum (mark-source (car mark-list)))))) - + #;(define _ (printf "break-kind: ~a\ninnermost source: ~a\nreturned-value-list: ~a\n" + break-kind + (and (pair? mark-list) + (syntax-object->datum (mark-source (car mark-list)))) + returned-value-list)) + (define answer (case break-kind ((left-side) - (unwind (recon nothing-so-far mark-list #t) #f)) + (let* ([innermost (if returned-value-list ; is it a normal-break/values? + (begin (unless (and (pair? returned-value-list) (null? (cdr returned-value-list))) + (error 'reconstruct "context expected one value, given ~v" returned-value-list)) + (recon-value (car returned-value-list) render-settings)) + nothing-so-far)]) + (unwind (recon innermost mark-list #t) #f))) ((right-side) - (let* ([innermost (if (null? returned-value-list) ; is it an expr -> expr reduction? - (recon-source-expr (mark-source (car mark-list)) mark-list null null render-settings) - (recon-value (car returned-value-list) render-settings))]) + (let* ([innermost (if returned-value-list ; is it an expr -> value reduction? + (begin (unless (and (pair? returned-value-list) (null? (cdr returned-value-list))) + (error 'reconstruct "context expected one value, given ~v" returned-value-list)) + (recon-value (car returned-value-list) render-settings)) + (recon-source-expr (mark-source (car mark-list)) mark-list null null render-settings))]) (unwind (recon (mark-as-highlight innermost) (cdr mark-list) #f) #f))) ((double-break) (let* ([source-expr (mark-source (car mark-list))] diff --git a/collects/stepper/private/shared.ss b/collects/stepper/private/shared.ss index 2e7081a981..030d1d08fb 100644 --- a/collects/stepper/private/shared.ss +++ b/collects/stepper/private/shared.ss @@ -71,9 +71,6 @@ binding-set? ; predicate ; get-binding-name ; bogus-binding? - if-temp - begin-temp - set!-temp ; get-lifted-gensym ; expr-read ; set-expr-read! @@ -225,10 +222,6 @@ (weak-assoc-add assoc-table stx new-binding) new-binding))))))) - (define if-temp (syntax-property (datum->syntax-object #`here `if-temp) 'stepper-binding-type 'stepper-temp)) - (define begin-temp (syntax-property (datum->syntax-object #`here `begin-temp) 'stepper-binding-type 'stepper-temp)) - (define set!-temp (syntax-property (datum->syntax-object #`here `set!-temp) 'stepper-binding-type 'stepper-temp)) - ; gensyms needed by many modules: ; no-sexp is used to indicate no sexpression for display. @@ -365,7 +358,8 @@ #f)) (define break-kind? - (symbols 'normal-break 'result-exp-break 'result-value-break 'double-break 'late-let-break 'expr-finished-break 'define-struct-break)) + (symbols 'normal-break 'normal-break/values 'result-exp-break 'result-value-break + 'double-break 'late-let-break 'expr-finished-break 'define-struct-break)) ; functional update package