From 5bc397e6b2d56cfc08efe857ac4cc1ace604b843 Mon Sep 17 00:00:00 2001 From: John Clements Date: Wed, 7 Dec 2005 10:27:27 +0000 Subject: [PATCH] smushed with branch, preserving changes made to stepper-tool. In sync now. svn: r1555 --- collects/stepper/internal-docs.txt | 5 + collects/stepper/private/annotate.ss | 892 +++++++++++---------- collects/stepper/private/marks.ss | 1 + collects/stepper/private/model-settings.ss | 4 +- collects/stepper/private/model.ss | 55 +- collects/stepper/private/reconstruct.ss | 92 ++- collects/stepper/private/shared.ss | 2 + collects/stepper/stepper-tool.ss | 4 + 8 files changed, 619 insertions(+), 436 deletions(-) diff --git a/collects/stepper/internal-docs.txt b/collects/stepper/internal-docs.txt index 3ad1afda32..2090349fde 100644 --- a/collects/stepper/internal-docs.txt +++ b/collects/stepper/internal-docs.txt @@ -215,6 +215,11 @@ stepper-test-suite-hint : be annotated, even though it's not in one of the expected top-level shapes. +stepper-highlight : + this expression will be highlighted. + (Not currently tranferred...?) + + STEPPER-HINT COLLISIONS The major concern with the stepper-hint is that two of them may diff --git a/collects/stepper/private/annotate.ss b/collects/stepper/private/annotate.ss index 2bc84e30b8..bcfd61a145 100644 --- a/collects/stepper/private/annotate.ss +++ b/collects/stepper/private/annotate.ss @@ -9,6 +9,11 @@ "my-macros.ss" "xml-box.ss" (prefix beginner-defined: "beginner-defined.ss")) + + (define-syntax (where stx) + (syntax-case stx () + [(_ body bindings) + (syntax/loc stx (letrec bindings body))])) ; CONTRACTS @@ -277,15 +282,12 @@ (define (double-break) (break (current-continuation-marks) 'double-break)) - ; here are the possible configurations of wcm's, pre-breaks, and breaks (not including late-let & double-breaks): - - ; (for full-on stepper) - ; wcm, result-break, normal-break - ; wcm, normal-break - ; wcm-pre-break-wrap : call wcm-wrap with a pre-break on the expr (define (wcm-pre-break-wrap debug-info exp) - (wcm-wrap debug-info #`(begin (#,result-exp-break) #,exp))) + (wcm-wrap debug-info (pre-break-wrap exp))) + + (define (pre-break-wrap stx) + #`(begin (#,result-exp-break) #,stx)) (define (break-wrap exp) #`(begin (#,normal-break) #,exp)) @@ -373,271 +375,317 @@ (2vals (wcm-wrap 13 exp) null)] [else - (let* ([tail-recur (lambda (exp) (annotate/inner exp tail-bound #t procedure-name-info))] - [non-tail-recur (lambda (exp) (annotate/inner exp null #f #f))] - [result-recur (lambda (exp) (annotate/inner exp null #f procedure-name-info))] - [set!-rhs-recur (lambda (exp name) (annotate/inner exp null #f name))] - [let-rhs-recur (lambda (exp binding-names dyn-index-syms) - (let* ([proc-name-info - (if (not (null? binding-names)) - (list (car binding-names) (car dyn-index-syms)) - #f)]) - (annotate/inner exp null #f proc-name-info)))] - [lambda-body-recur (lambda (exp) (annotate/inner exp 'all #t #f))] - ; note: no pre-break for the body of a let; it's handled by the break for the - ; let itself. - [let-body-recur (lambda (bindings) - (lambda (exp) - (annotate/inner exp (binding-set-union (list tail-bound bindings)) #f procedure-name-info)))] - [make-debug-info-normal (lambda (free-bindings) - (make-debug-info exp tail-bound free-bindings 'none #t))] - [make-debug-info-app (lambda (tail-bound free-bindings label) - (make-debug-info exp tail-bound free-bindings label #t))] - [make-debug-info-let (lambda (free-bindings binding-list let-counter) - (make-debug-info exp - (binding-set-union (list tail-bound - binding-list - (list let-counter))) - (varref-set-union (list free-bindings - binding-list - (list let-counter))) ; NB using bindings as varrefs - 'let-body - #t))] - [outer-wcm-wrap (if pre-break? - wcm-pre-break-wrap - wcm-wrap)] - [wcm-break-wrap (lambda (debug-info exp) - (outer-wcm-wrap debug-info (break-wrap exp)))] - - [normal-bundle - (lambda (free-vars annotated) - (2vals (outer-wcm-wrap (make-debug-info-normal free-vars) - annotated) - free-vars))] - - [lambda-clause-abstraction - (lambda (clause) - (with-syntax ([(args-stx . bodies) clause]) - (let*-2vals ([(annotated-body free-varrefs) - ; wrap bodies in explicit begin if more than 1 user-introduced (non-skipped) bodies - ; NB: CAN'T HAPPEN in beginner up through int/lambda - (if (> (length (filter (lambda (clause) - (not (syntax-property clause 'stepper-skip-completely))) - (syntax->list (syntax bodies)))) 1) - (lambda-body-recur (syntax (begin . bodies))) - (let*-2vals ([(annotated-bodies free-var-sets) - (2vals-map lambda-body-recur (syntax->list #`bodies))]) - (2vals #`(begin . #,annotated-bodies) (varref-set-union free-var-sets))))] - [new-free-varrefs (varref-set-remove-bindings free-varrefs - (arglist-flatten #'args-stx))]) - (2vals (datum->syntax-object #'here `(,#'args-stx ,annotated-body) #'clause) new-free-varrefs))))] - - [outer-lambda-abstraction - (lambda (annotated-lambda free-varrefs) + (let* + ([tail-recur (lambda (exp) (annotate/inner exp tail-bound #t procedure-name-info))] + [non-tail-recur (lambda (exp) (annotate/inner exp null #f #f))] + [result-recur (lambda (exp) (annotate/inner exp null #f procedure-name-info))] + [set!-rhs-recur (lambda (exp name) (annotate/inner exp null #f name))] + [let-rhs-recur (lambda (exp binding-names dyn-index-syms) + (let* ([proc-name-info + (if (not (null? binding-names)) + (list (car binding-names) (car dyn-index-syms)) + #f)]) + (annotate/inner exp null #f proc-name-info)))] + [lambda-body-recur (lambda (exp) (annotate/inner exp 'all #t #f))] + ; note: no pre-break for the body of a let; it's handled by the break for the + ; let itself. + [let-body-recur (lambda (bindings) + (lambda (exp) + (annotate/inner exp (binding-set-union (list tail-bound bindings)) #f procedure-name-info)))] + [make-debug-info-normal (lambda (free-bindings) + (make-debug-info exp tail-bound free-bindings 'none #t))] + [make-debug-info-app (lambda (tail-bound free-bindings label) + (make-debug-info exp tail-bound free-bindings label #t))] + [make-debug-info-let (lambda (free-bindings binding-list let-counter) + (make-debug-info exp + (binding-set-union (list tail-bound + binding-list + (list let-counter))) + (varref-set-union (list free-bindings + binding-list + (list let-counter))) ; NB using bindings as varrefs + 'let-body + #t))] + [outer-wcm-wrap (if pre-break? + wcm-pre-break-wrap + wcm-wrap)] + [wcm-break-wrap (lambda (debug-info exp) + (outer-wcm-wrap debug-info (break-wrap exp)))] + + [normal-bundle + (lambda (free-vars annotated) + (2vals (outer-wcm-wrap (make-debug-info-normal free-vars) + annotated) + free-vars))] + + [lambda-clause-abstraction + (lambda (clause) + (with-syntax ([(args-stx . bodies) clause]) + (let*-2vals ([(annotated-body free-varrefs) + ; wrap bodies in explicit begin if more than 1 user-introduced (non-skipped) bodies + ; NB: CAN'T HAPPEN in beginner up through int/lambda + (if (> (length (filter (lambda (clause) + (not (syntax-property clause 'stepper-skip-completely))) + (syntax->list (syntax bodies)))) 1) + (lambda-body-recur (syntax (begin . bodies))) + (let*-2vals ([(annotated-bodies free-var-sets) + (2vals-map lambda-body-recur (syntax->list #`bodies))]) + (2vals #`(begin . #,annotated-bodies) (varref-set-union free-var-sets))))] + [new-free-varrefs (varref-set-remove-bindings free-varrefs + (arglist-flatten #'args-stx))]) + (2vals (datum->syntax-object #'here `(,#'args-stx ,annotated-body) #'clause) new-free-varrefs))))] + + [outer-lambda-abstraction + (lambda (annotated-lambda free-varrefs) + (let*-2vals + ([closure-info (make-debug-info-app 'all free-varrefs 'none)] + [closure-name (if track-inferred-names? + (cond [(syntax? procedure-name-info) procedure-name-info] + [(pair? procedure-name-info) (car procedure-name-info)] + [else #f]) + #f)] + [closure-storing-proc + (opt-lambda (closure debug-info [lifted-index #f]) + (closure-table-put! closure (make-closure-record + closure-name + debug-info + #f + lifted-index)) + closure)] + [inferred-name-lambda + (if closure-name + (syntax-property annotated-lambda 'inferred-name (syntax-e closure-name)) + annotated-lambda)] + [captured + (cond [(pair? procedure-name-info) + #`(#,closure-storing-proc #,inferred-name-lambda #,closure-info + #,(cadr procedure-name-info))] + [else + #`(#,closure-storing-proc #,inferred-name-lambda #,closure-info)])]) + + (normal-bundle free-varrefs captured)))] + + ; The let transformation is complicated. + ; here's a sample transformation (not including 'break's): + ;(let-values ([(a b c) e1] [(d e) e2]) e3) + ; + ;turns into + ; + ;(let ([counter ()]) + ;(let-values ([(a b c d e lifter-a-1 lifter-b-2 lifter-c-3 lifter-d-4 lifter-e-5 let-counter) + ; (values *unevaluated* *unevaluated* *unevaluated* *unevaluated* *unevaluated* + ; counter counter counter counter counter 0)]) + ; (with-continuation-mark + ; key huge-value + ; (begin + ; (set!-values (a b c) e1) + ; (set! let-counter 1) + ; (set!-values (d e) e2) + ; (set! let-counter 2) + ; e3)))) + ; + ; note that this elaboration looks exactly like the one for letrec, and that's + ; okay, becuase expand guarantees that reordering them will not cause capture. + ; this is because a bound variable answers is considered bound by a binding only when + ; the pair answers true to bound-identifier=?, which is determined during (the first) + ; expand. + + ; another irritating point: the mark and the break that must go immediately + ; around the body. Irritating because they will be instantly replaced by + ; the mark and the break produced by the annotated body itself. However, + ; they're necessary, because the body may not contain free references to + ; all of the variables defined in the let, and thus their values are not + ; known otherwise. + ; whoops! hold the phone. I think I can get away with a break before, and + ; a mark after, so only one of each. groovy, eh? + + ; 2005-08: note that the set!-based approach on the let-counter is broken in the presence of + ; continuations; backing up a computation using a set! will not revert the + ; counter, and the stepper may think that the computation is in a different + ; place. To fix this, we must go to a pure let* with nested marks at each right-hand-side. + + + [let-abstraction + (lambda (stx output-identifier make-init-list) + (with-syntax ([(_ ([(var ...) val] ...) . bodies) stx]) (let*-2vals - ([closure-info (make-debug-info-app 'all free-varrefs 'none)] - [closure-name (if track-inferred-names? - (cond [(syntax? procedure-name-info) procedure-name-info] - [(pair? procedure-name-info) (car procedure-name-info)] - [else #f]) - #f)] - [closure-storing-proc - (opt-lambda (closure debug-info [lifted-index #f]) - (closure-table-put! closure (make-closure-record - closure-name - debug-info - #f - lifted-index)) - closure)] - [inferred-name-lambda - (if closure-name - (syntax-property annotated-lambda 'inferred-name (syntax-e closure-name)) - annotated-lambda)] - [captured - (cond [(pair? procedure-name-info) - #`(#,closure-storing-proc #,inferred-name-lambda #,closure-info - #,(cadr procedure-name-info))] - [else - #`(#,closure-storing-proc #,inferred-name-lambda #,closure-info)])]) - - (normal-bundle free-varrefs captured)))] - - ; The let transformation is complicated. - ; here's a sample transformation (not including 'break's): - ;(let-values ([(a b c) e1] [(d e) e2]) e3) - ; - ;turns into - ; - ;(let ([counter ()]) - ;(let-values ([(a b c d e lifter-a-1 lifter-b-2 lifter-c-3 lifter-d-4 lifter-e-5 let-counter) - ; (values *unevaluated* *unevaluated* *unevaluated* *unevaluated* *unevaluated* - ; counter counter counter counter counter 0)]) - ; (with-continuation-mark - ; key huge-value - ; (begin - ; (set!-values (a b c) e1) - ; (set! let-counter 1) - ; (set!-values (d e) e2) - ; (set! let-counter 2) - ; e3)))) - ; - ; note that this elaboration looks exactly like the one for letrec, and that's - ; okay, becuase expand guarantees that reordering them will not cause capture. - ; this is because a bound variable answers is considered bound by a binding only when - ; the pair answers true to bound-identifier=?, which is determined during (the first) - ; expand. - - ; another irritating point: the mark and the break that must go immediately - ; around the body. Irritating because they will be instantly replaced by - ; the mark and the break produced by the annotated body itself. However, - ; they're necessary, because the body may not contain free references to - ; all of the variables defined in the let, and thus their values are not - ; known otherwise. - ; whoops! hold the phone. I think I can get away with a break before, and - ; a mark after, so only one of each. groovy, eh? - - ; 2005-08: note that the set!-based approach on the let-counter is broken in the presence of - ; continuations; backing up a computation using a set! will not revert the - ; counter, and the stepper may think that the computation is in a different - ; place. To fix this, we must go to a pure let* with nested marks at each right-hand-side. - - - [let-abstraction - (lambda (stx output-identifier make-init-list) - (with-syntax ([(_ ([(var ...) val] ...) . bodies) stx]) - (let*-2vals - ([binding-sets (map syntax->list (syntax->list #'((var ...) ...)))] - [binding-list (apply append binding-sets)] - [vals (syntax->list #'(val ...))] - [lifted-var-sets (map (lx (map get-lifted-var _)) binding-sets)] - [lifted-vars (apply append lifted-var-sets)] - [(annotated-vals free-varref-sets-vals) - (2vals-map let-rhs-recur vals binding-sets lifted-var-sets)] - [(annotated-body free-varrefs-body) - ((let-body-recur binding-list) - (if (= (length (syntax->list (syntax bodies))) 1) - (car (syntax->list (syntax bodies))) - (syntax (begin . bodies))))] - [free-varrefs (varref-set-remove-bindings - (varref-set-union (cons free-varrefs-body - free-varref-sets-vals)) - binding-list)]) - - - (let* ([counter-id #`lifting-counter] - [unevaluated-list (make-init-list binding-list)] - [outer-initialization - #`([(#,@lifted-vars #,@binding-list #,let-counter) - (values #,@(append (map (lambda (dc_binding) counter-id) - binding-list) - unevaluated-list - (list 0)))])] - [counter-clauses (build-list - (length binding-sets) - (lambda (num) - #`(set! #,let-counter #,(+ num 1))))] - [set!-clauses - (map (lambda (binding-set val) - #`(set!-values #,binding-set #,val)) - binding-sets - annotated-vals)] - [exp-finished-clauses - - (with-syntax ([(_ let-clauses . dc) stx] - [((lifted-var ...) ...) lifted-var-sets]) - (with-syntax ([(exp-thunk ...) (map (lx (lambda () _)) - (syntax->list #`let-clauses))]) - #`(list (list exp-thunk - (list lifted-var ...) - (lambda () (list var ...))) ...)))] - ; time to work from the inside out again - ; without renaming, this would all be much much simpler. - [wrapped-begin (outer-wcm-wrap (make-debug-info-let free-varrefs - binding-list - let-counter) - (double-break-wrap - #`(begin #,@(apply append (zip set!-clauses counter-clauses)) - (#,exp-finished-break #,exp-finished-clauses) - #,annotated-body)))]) - (2vals (quasisyntax/loc + ([binding-sets (map syntax->list (syntax->list #'((var ...) ...)))] + [binding-list (apply append binding-sets)] + [vals (syntax->list #'(val ...))] + [lifted-var-sets (map (lx (map get-lifted-var _)) binding-sets)] + [lifted-vars (apply append lifted-var-sets)] + [(annotated-vals free-varref-sets-vals) + (2vals-map let-rhs-recur vals binding-sets lifted-var-sets)] + [(annotated-body free-varrefs-body) + ((let-body-recur binding-list) + (if (= (length (syntax->list (syntax bodies))) 1) + (car (syntax->list (syntax bodies))) + (syntax (begin . bodies))))] + [free-varrefs (varref-set-remove-bindings + (varref-set-union (cons free-varrefs-body + free-varref-sets-vals)) + binding-list)]) + + + (let* ([counter-id #`lifting-counter] + [unevaluated-list (make-init-list binding-list)] + [outer-initialization + #`([(#,@lifted-vars #,@binding-list #,let-counter) + (values #,@(append (map (lambda (dc_binding) counter-id) + binding-list) + unevaluated-list + (list 0)))])] + [counter-clauses (build-list + (length binding-sets) + (lambda (num) + #`(set! #,let-counter #,(+ num 1))))] + [set!-clauses + (map (lambda (binding-set val) + #`(set!-values #,binding-set #,val)) + binding-sets + annotated-vals)] + [exp-finished-clauses + + (with-syntax ([(_ let-clauses . dc) stx] + [((lifted-var ...) ...) lifted-var-sets]) + (with-syntax ([(exp-thunk ...) (map (lx (lambda () _)) + (syntax->list #`let-clauses))]) + #`(list (list exp-thunk + (list lifted-var ...) + (lambda () (list var ...))) ...)))] + ; time to work from the inside out again + ; without renaming, this would all be much much simpler. + [wrapped-begin (outer-wcm-wrap (make-debug-info-let free-varrefs + binding-list + let-counter) + (double-break-wrap + #`(begin #,@(apply append (zip set!-clauses counter-clauses)) + (#,exp-finished-break #,exp-finished-clauses) + #,annotated-body)))]) + (2vals (quasisyntax/loc exp - (let ([#,counter-id (#,binding-indexer)]) - (#,output-identifier #,outer-initialization #,wrapped-begin))) - free-varrefs)))))] - - ; if-abstraction: (-> syntax? syntax? (union false/c syntax?) (values syntax? varref-set?)) - [if-abstraction - (lambda (test then else) - (let*-2vals - ([(annotated-test free-varrefs-test) - (non-tail-recur test)] - [(annotated-then free-varrefs-then) - (tail-recur then)] - [(annotated-else free-varrefs-else) - (if else - (tail-recur else) - (2vals #f null))] - [free-varrefs (varref-set-union (list free-varrefs-test - free-varrefs-then - free-varrefs-else))] - [annotated-if - #`(begin (set! #,if-temp #,annotated-test) - (#,normal-break) - #,(if else - (quasisyntax/loc exp (if #,if-temp #,annotated-then #,annotated-else)) - (quasisyntax/loc exp (if #,if-temp #,annotated-then))))] - [wrapped (outer-wcm-wrap (make-debug-info-app (binding-set-union (list tail-bound (list if-temp))) - (varref-set-union (list free-varrefs (list if-temp))) - 'none) - annotated-if)]) - (2vals - (with-syntax ([test-var if-temp] - [wrapped-stx wrapped] - [unevaluated-stx *unevaluated*]) - (syntax/loc exp (let ([test-var unevaluated-stx]) wrapped-stx))) - free-varrefs)))] - - [varref-abstraction - (lambda (var) - (let*-2vals ([free-varrefs (list var)] - [varref-break-wrap - (lambda () - (wcm-break-wrap (make-debug-info-normal free-varrefs) - (return-value-wrap var)))] - [varref-no-break-wrap - (lambda () - (outer-wcm-wrap (make-debug-info-normal free-varrefs) var))] - [top-level-varref-break-wrap - (lambda () - (if (memq (syntax-e var) beginner-defined:must-reduce) - (varref-break-wrap) - (varref-no-break-wrap)))]) - (2vals - (case (syntax-property var 'stepper-binding-type) - ((lambda-bound macro-bound) (varref-no-break-wrap)) - ((let-bound) (varref-break-wrap)) - ((non-lexical) ;; is it from this module or not? - (match (identifier-binding var) - (#f (top-level-varref-break-wrap)) - [`(,path-index-or-symbol ,dc1 ,dc2 ,dc3 ,dc4) - (if (module-path-index? path-index-or-symbol) - (let-values ([(module-path dc5) (module-path-index-split path-index-or-symbol)]) - (if module-path - ;; not a module-local variable: - (top-level-varref-break-wrap) - ;; a module-local-variable: - (varref-break-wrap))) - (top-level-varref-break-wrap))] - [else (error 'annotate "unexpected value for identifier-binding: ~v" identifier-binding)]))) - free-varrefs)))] - - [recertifier - (lambda (vals) - (let*-2vals ([(new-exp bindings) vals]) - (2vals (syntax-recertify new-exp exp (current-code-inspector) #f) - bindings)))] - - ) + (let ([#,counter-id (#,binding-indexer)]) + (#,output-identifier #,outer-initialization #,wrapped-begin))) + free-varrefs)))))] + + ;; pulling out begin abstraction! + [begin-abstraction + (lambda (bodies) + + (if + (null? bodies) + (normal-bundle null exp) + + ((outer-begin-wrap + (foldl another-body-wrap wrapped-final remaining-reversed-bodies index-list)) + + . where . + + ([another-body-wrap + (lambda (next-body index stx-n-freevars) + (let*-2vals + ([(seed-stx free-vars-so-far) stx-n-freevars] + [(annotated-next-body free-vars-next-body) (non-tail-recur next-body)] + [free-vars-union (varref-set-union (list free-vars-so-far free-vars-next-body))] + [inner-wrapped (wcm-wrap + (make-debug-info-app (binding-set-union (list tail-bound (list begin-temp))) + (varref-set-union (list free-vars-so-far (list begin-temp))) + (list 'begin index)) + (break-wrap (pre-break-wrap seed-stx)))]) + (2vals #`(let ([#,begin-temp #,annotated-next-body]) + #,inner-wrapped) + free-vars-union)))] + + [outer-begin-wrap + (lambda (stx-n-free-vars) + (let*-2vals ([(stx free-vars) stx-n-free-vars]) + (2vals (wcm-wrap + (make-debug-info-app tail-bound free-vars (list 'begin (length bodies))) + stx) + free-vars)))] + + [all-bodies-reversed (reverse bodies)] + [final-body (car all-bodies-reversed)] + [remaining-reversed-bodies (cdr all-bodies-reversed)] + [index-list (build-list (length remaining-reversed-bodies) (lambda (x) (+ x 1)))] + + [wrapped-final (tail-recur final-body)]))) + + )] + + ; if-abstraction: (-> syntax? syntax? (union false/c syntax?) (values syntax? varref-set?)) + [if-abstraction + (lambda (test then else) + (let*-2vals + ([(annotated-test free-varrefs-test) + (non-tail-recur test)] + [(annotated-then free-varrefs-then) + (tail-recur then)] + [(annotated-else free-varrefs-else) + (if else + (tail-recur else) + (2vals #f null))] + [free-varrefs (varref-set-union (list free-varrefs-test + free-varrefs-then + free-varrefs-else))] + [annotated-if + #`(begin (set! #,if-temp #,annotated-test) + (#,normal-break) + #,(if else + (quasisyntax/loc exp (if #,if-temp #,annotated-then #,annotated-else)) + (quasisyntax/loc exp (if #,if-temp #,annotated-then))))] + [wrapped (outer-wcm-wrap (make-debug-info-app (binding-set-union (list tail-bound (list if-temp))) + (varref-set-union (list free-varrefs (list if-temp))) + 'none) + annotated-if)]) + (2vals + (with-syntax ([test-var if-temp] + [wrapped-stx wrapped] + [unevaluated-stx *unevaluated*]) + (syntax/loc exp (let ([test-var unevaluated-stx]) wrapped-stx))) + free-varrefs)))] + + [varref-abstraction + (lambda (var) + (let*-2vals ([free-varrefs (list var)] + [varref-break-wrap + (lambda () + (wcm-break-wrap (make-debug-info-normal free-varrefs) + (return-value-wrap var)))] + [varref-no-break-wrap + (lambda () + (outer-wcm-wrap (make-debug-info-normal free-varrefs) var))] + [top-level-varref-break-wrap + (lambda () + (if (memq (syntax-e var) beginner-defined:must-reduce) + (varref-break-wrap) + (varref-no-break-wrap)))]) + (2vals + (case (syntax-property var 'stepper-binding-type) + ((lambda-bound macro-bound) (varref-no-break-wrap)) + ((let-bound) (varref-break-wrap)) + ((non-lexical) ;; is it from this module or not? + (match (identifier-binding var) + (#f (top-level-varref-break-wrap)) + [`(,path-index-or-symbol ,dc1 ,dc2 ,dc3 ,dc4) + (if (module-path-index? path-index-or-symbol) + (let-values ([(module-path dc5) (module-path-index-split path-index-or-symbol)]) + (if module-path + ;; not a module-local variable: + (top-level-varref-break-wrap) + ;; a module-local-variable: + (varref-break-wrap))) + (top-level-varref-break-wrap))] + [else (error 'annotate "unexpected value for identifier-binding: ~v" identifier-binding)]))) + free-varrefs)))] + + [recertifier + (lambda (vals) + (let*-2vals ([(new-exp bindings) vals]) + (2vals (syntax-recertify new-exp exp (current-code-inspector) #f) + bindings)))] + + ) ; find the source expression and associate it with the parsed expression ; (when (and red-exprs foot-wrap?) ; (set-exp-read! exp (find-read-expr exp))) @@ -645,156 +693,152 @@ (recertifier (kernel:kernel-syntax-case exp #f + + [(lambda . clause) + (let*-2vals ([(annotated-clause free-varrefs) + (lambda-clause-abstraction (syntax clause))] + [annotated-lambda + (with-syntax ([annotated-clause annotated-clause]) + (syntax/loc exp (lambda . annotated-clause)))]) + (outer-lambda-abstraction annotated-lambda free-varrefs))] + + [(case-lambda . clauses) + (let*-2vals ([(annotated-cases free-varrefs-cases) + (2vals-map lambda-clause-abstraction (syntax->list (syntax clauses)))] + [annotated-case-lambda (with-syntax ([annotated-cases annotated-cases]) + (syntax/loc exp (case-lambda . annotated-cases)))] + [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) (if-abstraction (syntax test) (syntax then) #f)] - [(lambda . clause) - (let*-2vals ([(annotated-clause free-varrefs) - (lambda-clause-abstraction (syntax clause))] - [annotated-lambda - (with-syntax ([annotated-clause annotated-clause]) - (syntax/loc exp (lambda . annotated-clause)))]) - (outer-lambda-abstraction annotated-lambda free-varrefs))] - - [(case-lambda . clauses) - (let*-2vals ([(annotated-cases free-varrefs-cases) - (2vals-map lambda-clause-abstraction (syntax->list (syntax clauses)))] - [annotated-case-lambda (with-syntax ([annotated-cases annotated-cases]) - (syntax/loc exp (case-lambda . annotated-cases)))] - [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) (if-abstraction (syntax test) (syntax then) #f)] - - [(begin . bodies-stx) - (if (null? (syntax->list (syntax bodies-stx))) - (normal-bundle null exp) - (let*-2vals - ([reversed-bodies (reverse (syntax->list (syntax bodies-stx)))] - [last-body (car reversed-bodies)] - [all-but-last (reverse (cdr reversed-bodies))] - [(annotated-a free-varrefs-a) - (2vals-map non-tail-recur all-but-last)] - [(annotated-final free-varrefs-final) - (tail-recur last-body)]) - (normal-bundle (varref-set-union (cons free-varrefs-final free-varrefs-a)) - (quasisyntax/loc exp (begin #,@annotated-a #,annotated-final)))))] - - [(begin0 . bodies-stx) - (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))]) + [(begin . bodies-stx) + (begin-abstraction (syntax->list #`bodies-stx))] + + [(begin0 . bodies-stx) + (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))))] - - [(let-values . _) - (let-abstraction exp - #`let-values - (lambda (bindings) - (map (lambda (_) *unevaluated*) bindings)))] - - [(letrec-values . _) - (let-abstraction exp - #`letrec-values - (lambda (bindings) (map (lambda (b) #`#,b) bindings)))] - - [(set! var val) - (let*-2vals - ([(annotated-val val-free-varrefs) - (set!-rhs-recur (syntax val) (syntax-case (syntax var) (#%top) - [(#%top . real-var) (syntax-e (syntax real-var))] - [else (syntax var)]))] - [free-varrefs (varref-set-union (list val-free-varrefs (list #`var)))] - [annotated-set! - #`(begin (set! #,set!-temp #,annotated-val) - (#,normal-break) - #,(return-value-wrap - (quasisyntax/loc exp (set! var #,set!-temp))))] - [wrapped (outer-wcm-wrap (make-debug-info-app (binding-set-union (list tail-bound (list set!-temp))) - (varref-set-union (list free-varrefs (list set!-temp))) - 'none) - annotated-set!)]) - (2vals - (with-syntax ([test-var set!-temp] - [wrapped-stx wrapped] - [unevaluated-stx *unevaluated*]) - (quasisyntax/loc exp (let ([test-var unevaluated-stx]) wrapped-stx))) - free-varrefs))] - - - [(quote _) - (normal-bundle null exp)] - - [(quote-syntax _) - (normal-bundle null exp)] - - [(with-continuation-mark key mark body) - ;(let*-2vals ([(annotated-key free-varrefs-key) - ; (non-tail-recur (syntax key))] - ; [(annotated-mark free-varrefs-mark) - ; (non-tail-recur (syntax mark))] - ; [(annotated-body dc_free-varrefs-body) - ; (result-recur (syntax body))]) - (error 'annotate/inner "this region of code is still under construction") - ; [annotated #`(let-values ([key-temp #,*unevaluated*] - ; [mark-temp #,*unevaluated*] - ;) - ] - - ; [foot-wrap? - ; (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: - ; (M0 ...) - ; - ; goes to - ; - ;(let ([t0 *unevaluated*] - ; ...) - ; (with-continuation-mark - ; debug-key - ; huge-value - ; (set! t0 M0) - ; ... - ; (with-continuation-mark - ; debug-key - ; 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): - ; (v0 ...) - ; - ; goes to - ; - ; (with-continuation-mark - ; debug-key - ; 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 - ; 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. - - [(#%app . terms) - (let*-2vals - ([(annotated-terms free-varrefs-terms) - (2vals-map non-tail-recur (syntax->list (syntax terms)))] - [free-varrefs (varref-set-union free-varrefs-terms)]) + ;; special case for the expansion of begin. + ;; more efficient, but disabled because of difficulties in threading it through the + ;; reconstruction. Easier to undo in the macro-unwind phase. + #;[(let-values () . bodies-stx) + (eq? (syntax-property exp 'stepper-hint) 'comes-from-begin) + (begin-abstraction (syntax->list #`bodies-stx))] + + [(let-values . _) + (let-abstraction exp + #`let-values + (lambda (bindings) + (map (lambda (_) *unevaluated*) bindings)))] + + [(letrec-values . _) + (let-abstraction exp + #`letrec-values + (lambda (bindings) (map (lambda (b) #`#,b) bindings)))] + + [(set! var val) + (let*-2vals + ([(annotated-val val-free-varrefs) + (set!-rhs-recur (syntax val) (syntax-case (syntax var) (#%top) + [(#%top . real-var) (syntax-e (syntax real-var))] + [else (syntax var)]))] + [free-varrefs (varref-set-union (list val-free-varrefs (list #`var)))] + [annotated-set! + #`(begin (set! #,set!-temp #,annotated-val) + (#,normal-break) + #,(return-value-wrap + (quasisyntax/loc exp (set! var #,set!-temp))))] + [wrapped (outer-wcm-wrap (make-debug-info-app (binding-set-union (list tail-bound (list set!-temp))) + (varref-set-union (list free-varrefs (list set!-temp))) + 'none) + annotated-set!)]) + (2vals + (with-syntax ([test-var set!-temp] + [wrapped-stx wrapped] + [unevaluated-stx *unevaluated*]) + (quasisyntax/loc exp (let ([test-var unevaluated-stx]) wrapped-stx))) + free-varrefs))] + + + [(quote _) + (normal-bundle null exp)] + + [(quote-syntax _) + (normal-bundle null exp)] + + [(with-continuation-mark key mark body) + ;(let*-2vals ([(annotated-key free-varrefs-key) + ; (non-tail-recur (syntax key))] + ; [(annotated-mark free-varrefs-mark) + ; (non-tail-recur (syntax mark))] + ; [(annotated-body dc_free-varrefs-body) + ; (result-recur (syntax body))]) + (error 'annotate/inner "this region of code is still under construction") + + ; [annotated #`(let-values ([key-temp #,*unevaluated*] + ; [mark-temp #,*unevaluated*] + ;) + ] + + ; [foot-wrap? + ; (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: + ; (M0 ...) + ; + ; goes to + ; + ;(let ([t0 *unevaluated*] + ; ...) + ; (with-continuation-mark + ; debug-key + ; huge-value + ; (set! t0 M0) + ; ... + ; (with-continuation-mark + ; debug-key + ; 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): + ; (v0 ...) + ; + ; goes to + ; + ; (with-continuation-mark + ; debug-key + ; 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 + ; 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. + + [(#%app . terms) + (let*-2vals + ([(annotated-terms free-varrefs-terms) + (2vals-map non-tail-recur (syntax->list (syntax terms)))] + [free-varrefs (varref-set-union free-varrefs-terms)]) (2vals (let* ([arg-temps (build-list (length annotated-terms) get-arg-var)] [tagged-arg-temps (map (lambda (var) (syntax-property var 'stepper-binding-type 'stepper-temp)) 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! #,arg-symbol #,annotated-sub-exp)) tagged-arg-temps annotated-terms)] @@ -814,19 +858,19 @@ #`(let-values #,let-clauses #,let-body)) ;) free-varrefs))] - - [(#%datum . _) - (normal-bundle null exp)] - - [(#%top . var-stx) - (varref-abstraction #`var-stx)] - - [var-stx - (identifier? #`var-stx) - (varref-abstraction #`var-stx)] - - [else - (error 'annotate "unexpected syntax for expression: ~v" (syntax-object->datum exp))])))]))) + + [(#%datum . _) + (normal-bundle null exp)] + + [(#%top . var-stx) + (varref-abstraction #`var-stx)] + + [var-stx + (identifier? #`var-stx) + (varref-abstraction #`var-stx)] + + [else + (error 'annotate "unexpected syntax for expression: ~v" (syntax-object->datum exp))])))]))) ;; annotate/top-level : syntax-> syntax diff --git a/collects/stepper/private/marks.ss b/collects/stepper/private/marks.ss index aa77b8dcd8..b5af1f5e9d 100644 --- a/collects/stepper/private/marks.ss +++ b/collects/stepper/private/marks.ss @@ -173,6 +173,7 @@ kept-vars)] [lifter-syms (map get-lifted-var let-bindings)]) (make-full-mark source label (append kept-vars lifter-syms))) + ;; I'm not certain that non-lifting is currently tested: 2005-12, JBC (make-full-mark source label kept-vars)))) diff --git a/collects/stepper/private/model-settings.ss b/collects/stepper/private/model-settings.ss index 5862a8605e..3a7f2ff6e9 100644 --- a/collects/stepper/private/model-settings.ss +++ b/collects/stepper/private/model-settings.ss @@ -53,8 +53,8 @@ (or (and (procedure? val) (object-name val)) (print-convert val))))) - - ; FIXME : #f totally unacceptable as 'render-to-string' + + ; FIXME : #f totally unacceptable as 'render-to-string' (define fake-beginner-render-settings (make-render-settings #t #t #f (make-fake-render-to-sexp #t #t #f) #t)) diff --git a/collects/stepper/private/model.ss b/collects/stepper/private/model.ss index a0db64c9f0..a16d603ae6 100644 --- a/collects/stepper/private/model.ss +++ b/collects/stepper/private/model.ss @@ -82,6 +82,52 @@ (define basic-eval (current-eval)) + ;; 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))])) + ;; REDIVIDE MAKES NO SENSE IN THE NEW INTERFACE. THIS WILL BE DELETED AFTER BEING PARTED OUT. ; redivide takes a list of sexps and divides them into the 'before', 'during', and 'after' lists, ; where the before and after sets are maximal-length lists where none of the s-expressions contain @@ -120,9 +166,13 @@ ; (redivide `(1 2 ,highlight-placeholder 3 ,highlight-placeholder 4 5)) ; (values `(1 2) `(,highlight-placeholder 3 ,highlight-placeholder) `(4 5)) + (define (>>> x) + (fprintf (current-output-port) ">>> ~v\n" x) + x) (define break (opt-lambda (mark-set break-kind [returned-value-list null]) + (let* ([mark-list (and mark-set (extract-mark-list mark-set))]) @@ -190,7 +240,7 @@ (receive-result result)))] [(double-break) - ; a double-break occurs at the beginning of a let's evaluation. + ;; 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")) @@ -216,6 +266,9 @@ [else (error 'break "unknown label on break")]))))) + + + (define (step-through-expression expanded expand-next-expression) (let* ([annotated (a:annotate expanded break track-inferred-names?)]) (eval-syntax annotated) diff --git a/collects/stepper/private/reconstruct.ss b/collects/stepper/private/reconstruct.ss index 0642a18e4d..2ec5b49976 100644 --- a/collects/stepper/private/reconstruct.ss +++ b/collects/stepper/private/reconstruct.ss @@ -101,6 +101,10 @@ ; prints the name attached to the procedure, unless we're on the right-hand-side ; of a let, or unless there _is_ no name. + (define (>>> x) + (fprintf (current-error-port) ">>> ~v\n" x) + x) + (define recon-value (opt-lambda (val render-settings [assigned-name #f]) (if (hash-table-get finished-xml-box-table val (lambda () #f)) @@ -151,7 +155,11 @@ [(normal-break) (skip-redex-step? mark-list render-settings)] [(double-break) - (not (render-settings-lifting? render-settings))] + (or + ;; don't stop for a double-break on a let that is the expansion of a 'begin' + (let ([expr (mark-source (car mark-list))]) + (eq? (syntax-property expr 'stepper-hint) 'comes-from-begin)) + (not (render-settings-lifting? render-settings)))] [(expr-finished-break define-struct-break late-let-break) #f])) (define (skip-redex-step? mark-list render-settings) @@ -362,6 +370,9 @@ [(comes-from-recur) (unwind-recur stx)] + [(comes-from-begin) + (unwind-begin stx)] + (else (fall-through))) (fall-through)) stx)) @@ -471,6 +482,12 @@ (error 'unwind-cond "expected a cond clause expansion, got: ~e" (syntax-object->datum stx))))]) (syntax (cond . clauses)))) + (define (unwind-begin stx) + (syntax-case stx (let-values) + [(let-values () body ...) + (with-syntax ([(new-body ...) (map inner (syntax->list #`(body ...)))]) + #`(begin new-body ...))])) + (define (unwind-and/or stx user-source user-position label) (let ([clause-padder (case label [(and) #`true] @@ -543,16 +560,18 @@ #`(label #,@(map recur (filter-skipped (syntax->list (syntax bodies)))))))] [recon-let/rec (lambda (rec?) - (with-syntax ([(label ((vars val) ...) body) expr]) + + (with-syntax ([(label ((vars val) ...) body ...) expr]) (let* ([bindings (map syntax->list (syntax->list (syntax (vars ...))))] [binding-list (apply append bindings)] [recur-fn (if rec? (lambda (expr) (let-recur expr binding-list)) recur)] [right-sides (map recur-fn (syntax->list (syntax (val ...))))] - [recon-body (let-recur (syntax body) binding-list)]) + [recon-bodies (map (lambda (x) (let-recur x binding-list)) + (syntax->list #`(body ...)))]) (with-syntax ([(recon-val ...) right-sides] - [recon-body recon-body] + [(recon-body ...) recon-bodies] [(new-vars ...) (map (lx (map (lx (if (ormap (lambda (binding) (bound-identifier=? binding _)) use-lifted-names) @@ -562,7 +581,7 @@ _)) _)) bindings)]) - (syntax (label ((new-vars recon-val) ...) recon-body))))))] + (syntax (label ((new-vars recon-val) ...) recon-body ...))))))] [recon-lambda-clause (lambda (clause) (with-syntax ([(args . bodies-stx) clause]) @@ -606,7 +625,7 @@ #`(set! #,rendered-var #,(recur #'rhs)))] ; quote - [(quote body) (recon-value (syntax-e (syntax body)) render-settings)] + [(quote body) (recon-value (eval-quoted expr) render-settings)] ; quote-syntax : like set!, the current stepper cannot handle quote-syntax @@ -699,7 +718,18 @@ (datum->syntax-object s (string->symbol (cadr m)) s s) s))) (define re:beginner: (regexp "^beginner:(.*)$")) - ; ; + + + ;; eval-quoted : take a syntax-object that is an application of quote, and evaluate it (for display) + ;; Frankly, I'm worried by the fact that this isn't done at expansion time. + + (define (eval-quoted stx) + (syntax-case stx (quote) + [(quote . dont-care) (eval stx)] + [else (error 'eval-quoted "eval-quoted called with syntax that is not a quote: ~v" stx)])) + + + ; ; ; ; ; ; ; ; ;; ;;; ;;; ;;; ; ;; ;;; ;;;; ; ;; ; ; ;;; ;;;; ;;; ;;; ; ;;; ;; ; ;;; ; ;;; ;;;; ;;; ;;; ; ;; ; ; ; ; ; ;; ; ; ; ;; ; ; ; ; ; ; ; ;; ;; ; ;; ; ; ; ; ; ; ; ; ;; @@ -962,9 +992,45 @@ exp)] ; quote : there is no break on a quote. + + ;; advanced-begin : okay, here comes advanced-begin. - ; begin : may not occur directly, but will occur in the expansion of cond, now that I'm no longer - ; masking that out with stepper-skipto. Furthermore, exactly one expression can occur inside it. + [(begin . terms) + ;; copied from app: + + (attach-info + (let* ([sub-exprs (syntax->list (syntax terms))] + [arg-temps (build-list (length sub-exprs) get-arg-var)] + [arg-vals (map (lambda (arg-temp) + (lookup-binding mark-list arg-temp)) + arg-temps)]) + (case (mark-label (car mark-list)) + ((not-yet-called) + (let*-2vals ([(evaluated unevaluated) (split-list (lambda (x) (eq? (cadr x) *unevaluated*)) + (zip sub-exprs arg-vals))] + [rectified-evaluated (map (lx (recon-value _ render-settings)) (map cadr evaluated))]) + (if (null? unevaluated) + #`(#%app . #,rectified-evaluated) + #`(#%app + #,@rectified-evaluated + #,so-far + #,@(map recon-source-current-marks (cdr (map car unevaluated))))))) + ((called) + (if (eq? so-far nothing-so-far) + (datum->syntax-object #'here `(,#'#%app ...)) ; in unannotated code + (datum->syntax-object #'here `(,#'#%app ... ,so-far ...)))) + (else + (error "bad label in application mark in expr: ~a" exp)))) + exp)] + + ; begin : in the current expansion of begin, there are only two-element begin's, one-element begins, and + ;; zero-element begins + + [(begin stx-a stx-b) + (attach-info + (if (eq? so-far nothing-so-far) + #`(begin #,(recon-source-current-marks #`stx-a) #,(recon-source-current-marks #`stx-b)) + #`(begin #,so-far #,(recon-source-current-marks #`stx-b))))] [(begin clause) (attach-info @@ -975,6 +1041,14 @@ "stepper:reconstruct: one-clause begin appeared as context: ~a" (syntax-object->datum exp))) exp)] + [(begin) + (attach-info + (if (eq? so-far nothing-so-far) + #`(begin) + (error + 'recon-inner + "stepper-reconstruct: zero-clause begin appeared as context: ~a" (syntax-object->datum exp))))] + ; begin0 : may not occur directly except in advanced ; let-values diff --git a/collects/stepper/private/shared.ss b/collects/stepper/private/shared.ss index bcc28aad6b..bb1cb414d6 100644 --- a/collects/stepper/private/shared.ss +++ b/collects/stepper/private/shared.ss @@ -72,6 +72,7 @@ ; get-binding-name ; bogus-binding? if-temp + begin-temp set!-temp ; get-lifted-gensym ; expr-read @@ -216,6 +217,7 @@ 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: diff --git a/collects/stepper/stepper-tool.ss b/collects/stepper/stepper-tool.ss index 317b3f9b98..d019e950a5 100644 --- a/collects/stepper/stepper-tool.ss +++ b/collects/stepper/stepper-tool.ss @@ -197,6 +197,10 @@ (lambda () (simple-module-based-language-convert-value val simple-settings))))) + (define (>>> x) + (fprintf (current-error-port) ">>> ~v\n" x) + x) + ; channel for incoming views (define view-channel (make-async-channel))