From 3852135b8b90968618dec3d4ab865a21ecb10d77 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Fri, 4 Aug 2006 20:00:31 +0000 Subject: [PATCH] Merged in changes from branch: generalizations and improvements. svn: r3967 --- .../stepper/private/display-break-stuff.ss | 38 ++++ collects/stepper/private/macro-unwind.ss | 156 +++++++-------- collects/stepper/private/marks.ss | 8 +- collects/stepper/private/model.ss | 92 +++------ collects/stepper/private/reconstruct.ss | 3 +- collects/stepper/private/shared.ss | 189 +++++++++--------- collects/stepper/stepper-tool.ss | 47 +++-- 7 files changed, 270 insertions(+), 263 deletions(-) create mode 100644 collects/stepper/private/display-break-stuff.ss diff --git a/collects/stepper/private/display-break-stuff.ss b/collects/stepper/private/display-break-stuff.ss new file mode 100644 index 0000000000..2a7a1e51f2 --- /dev/null +++ b/collects/stepper/private/display-break-stuff.ss @@ -0,0 +1,38 @@ +(module display-break-stuff mzscheme + + (require (lib "mred.ss" "mred") + (lib "class.ss") + "marks.ss") + + + (provide display-break-stuff) + + ;; display-break-stuff : show the information associated with a breakpoint. Useful for + ;; people building steppers for new languages + (define (display-break-stuff break-number mark-set break-kind returned-value-list) + (define f (instantiate frame% () [label "breakpoint information"] [width 300] [height 500])) + (define ec (instantiate editor-canvas% () [parent f])) + (define t (instantiate text% ())) + (send ec set-editor t) + (send f show #t) + (send t insert (format "breakpoint number: ~v\n\n" break-number)) + (send t insert (format "break-kind: ~v \n\n" break-kind)) + (send t insert "marks:\n") + (if mark-set + (map (display-breakpoint-mark t) (extract-mark-list mark-set)) + (send t insert " no mark-set!\n")) + (send t insert "\nreturned-value-list:\n") + (send t insert (format " ~v\n" returned-value-list))) + + (define ((display-breakpoint-mark t) mark) + (let* ([em (expose-mark mark)] + [source (car em)] + [label (cadr em)] + [binding-set (caddr em)]) + (send t insert "\n") + (send t insert (format " label: ~v\n" label)) + ;; we really want one of those nice collapsible syntax-viewer thingies here: + (send t insert (format " source : ~v\n" (syntax-object->datum source))) + ;; here too, though this isn't a syntax object. + (send t insert (format " bindings: ~v\n" binding-set)))) + ) \ No newline at end of file diff --git a/collects/stepper/private/macro-unwind.ss b/collects/stepper/private/macro-unwind.ss index 245a0a4d12..7535db6ba2 100644 --- a/collects/stepper/private/macro-unwind.ss +++ b/collects/stepper/private/macro-unwind.ss @@ -65,64 +65,44 @@ stx (syntax-pair-map (syntax-e stx) inner) stx stx) stx)) + (define (fall-through stx) + (kernel:kernel-syntax-case stx #f + [id + (identifier? stx) + (or (syntax-property stx 'stepper-lifted-name) + stx)] + [(define-values dc ...) + (unwind-define stx)] + [(#%app exp ...) + (recur-on-pieces #'(exp ...))] + [(#%datum . datum) + #'datum] + [(let-values . rest) + (unwind-mz-let stx)] + [(letrec-values . rest) + (unwind-mz-let stx)] + [(set! var rhs) + (with-syntax ([unwound-var (or (syntax-property + #`var 'stepper-lifted-name) + #`var)] + [unwound-body (inner #`rhs)]) + #`(set! unwound-var unwound-body))] + [else (recur-on-pieces stx)])) + (define (inner stx) - (define (fall-through) - (kernel:kernel-syntax-case stx #f - [id - (identifier? stx) - (or (syntax-property stx 'stepper-lifted-name) - stx)] - [(define-values dc ...) - (unwind-define stx)] - [(#%app exp ...) - (recur-on-pieces #'(exp ...))] - [(#%datum . datum) - #'datum] - [(let-values . rest) - (unwind-mz-let stx)] - [(letrec-values . rest) - (unwind-mz-let stx)] - [(set! var rhs) - (with-syntax ([unwound-var (or (syntax-property - #`var 'stepper-lifted-name) - #`var)] - [unwound-body (inner #`rhs)]) - #`(set! unwound-var unwound-body))] - [else - (recur-on-pieces stx)])) - (transfer-info - (if (syntax-property stx 'user-stepper-hint) - (case (syntax-property stx 'user-stepper-hint) - - [(comes-from-cond) - (unwind-cond stx - (syntax-property stx 'user-source) - (syntax-property stx 'user-position))] - - [(comes-from-and) - (unwind-and/or stx - (syntax-property stx 'user-source) - (syntax-property stx 'user-position) - 'and)] - - [(comes-from-or) - (unwind-and/or stx - (syntax-property stx 'user-source) - (syntax-property stx 'user-position) - 'or)] - - [(comes-from-local) - (unwind-local stx)] - - [(comes-from-recur) - (unwind-recur stx)] - - [(comes-from-begin) - (unwind-begin stx)] - - (else (fall-through))) - (fall-through)) + (let ([hint (syntax-property stx 'user-stepper-hint)]) + (if (procedure? hint) + (hint stx recur-on-pieces) + (let ([process (case hint + [(comes-from-cond) unwind-cond] + [(comes-from-and) (unwind-and/or 'and)] + [(comes-from-or) (unwind-and/or 'or)] + [(comes-from-local) unwind-local] + [(comes-from-recur) unwind-recur] + [(comes-from-begin) unwind-begin] + [else fall-through])]) + (process stx)))) stx)) (define (transfer-highlight from to) @@ -254,33 +234,35 @@ [result (inner result-stx)]) #`(new-test result))) - (define (unwind-cond stx user-source user-position) - (with-syntax - ([clauses - (let loop ([stx stx]) - (if (and (eq? user-source - (syntax-property stx 'user-source)) - (eq? user-position - (syntax-property stx 'user-position))) - (syntax-case stx (if begin #%app) - ;; the else clause disappears when it's a - ;; language-inserted else clause - [(if test result) - (list (unwind-cond-clause stx #`test #`result))] - [(if test result else-clause) - (cons (unwind-cond-clause stx #`test #`result) - (loop (syntax else-clause)))] - ;; else clause appears momentarily in 'before,' even - ;; though it's a 'skip-completely' - [(begin . rest) null] - [else-stx - (error 'unwind-cond - "expected an if, got: ~e" - (syntax-object->datum (syntax else-stx)))]) - (error 'unwind-cond - "expected a cond clause expansion, got: ~e" - (syntax-object->datum stx))))]) - (syntax (cond . clauses)))) + (define (unwind-cond stx) + (let ([user-source (syntax-property stx 'user-source)] + [user-position (syntax-property stx 'user-position)]) + (with-syntax + ([clauses + (let loop ([stx stx]) + (if (and (eq? user-source + (syntax-property stx 'user-source)) + (eq? user-position + (syntax-property stx 'user-position))) + (syntax-case stx (if begin #%app) + ;; the else clause disappears when it's a + ;; language-inserted else clause + [(if test result) + (list (unwind-cond-clause stx #`test #`result))] + [(if test result else-clause) + (cons (unwind-cond-clause stx #`test #`result) + (loop (syntax else-clause)))] + ;; else clause appears momentarily in 'before,' even + ;; though it's a 'skip-completely' + [(begin . rest) null] + [else-stx + (error 'unwind-cond + "expected an if, got: ~e" + (syntax-object->datum (syntax else-stx)))]) + (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) @@ -289,10 +271,10 @@ (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] - [(or) #`false])]) + (define ((unwind-and/or label) stx user-source user-position) + (let ([user-source (syntax-property stx 'user-source)] + [user-position (syntax-property stx 'user-position)] + [clause-padder (case label [(and) #`true] [(or) #`false])]) (with-syntax ([clauses (append diff --git a/collects/stepper/private/marks.ss b/collects/stepper/private/marks.ss index ca4d86674d..182a6db992 100644 --- a/collects/stepper/private/marks.ss +++ b/collects/stepper/private/marks.ss @@ -109,11 +109,11 @@ (define (display-mark mark) (apply string-append - (format "source: ~a~n" (syntax-object->datum (mark-source mark))) - (format "label: ~a~n" (mark-label mark)) - (format "bindings:~n") + (format "source: ~a\n" (syntax-object->datum (mark-source mark))) + (format "label: ~a\n" (mark-label mark)) + (format "bindings:\n") (map (lambda (binding) - (format " ~a : ~a~n" (syntax-e (mark-binding-binding binding)) + (format " ~a : ~a\n" (syntax-e (mark-binding-binding binding)) (mark-binding-value binding))) (mark-bindings mark)))) diff --git a/collects/stepper/private/model.ss b/collects/stepper/private/model.ss index d91c6b5687..039bf44fa6 100644 --- a/collects/stepper/private/model.ss +++ b/collects/stepper/private/model.ss @@ -42,7 +42,10 @@ "shared.ss" "marks.ss" "model-settings.ss" - "macro-unwind.ss") + "macro-unwind.ss" + + ;; for breakpoint display + "display-break-stuff.ss") (define program-expander-contract @@ -57,14 +60,13 @@ (or/c render-settings? false/c) ; render-settings boolean? ; track-inferred-names? string? ; language-level-name + (procedure? . -> . void?) ; run-on-drscheme-side . -> . void?)]) ; go starts a stepper instance ; see provide stmt for contract - (define (go program-expander receive-result render-settings track-inferred-names? language-level-name) - - + (define (go program-expander receive-result render-settings track-inferred-names? language-level-name run-on-drscheme-side) ;; finished-exps: (listof (list/c syntax-object? (or/c number? false?)( -> any))) ;; because of mutation, these cannot be fixed renderings, but must be re-rendered at each step. @@ -79,8 +81,6 @@ (define held-step-was-app? #f) (define held-finished-list null) - (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 @@ -126,52 +126,36 @@ [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 - ; a highlight-placeholder - ; (->* ((listof syntax)) (list/c syntax syntax syntax)) - #;(define (redivide exprs) - (letrec ([contains-highlight - (lambda (expr) - (or (syntax-property expr 'stepper-highlight) - (syntax-case expr () - [(a . rest) (or (contains-highlight #`a) (contains-highlight #`rest))] - [else #f])))]) - (let* ([list-length (length exprs)] - [split-point-a (- list-length (length (or (memf contains-highlight exprs) null)))] - [split-point-b (length (or (memf contains-highlight (reverse exprs)) null))]) - (if (<= split-point-b split-point-a) - (error 'redivide-exprs "s-expressions did not contain the highlight-placeholder: ~v" (map syntax-object->hilite-datum exprs)) - (values (sublist 0 split-point-a exprs) ; before - (sublist split-point-a split-point-b exprs) ; during - (sublist split-point-b list-length exprs)))))) ; after - - - ; (redivide `(3 4 (+ (define ,highlight-placeholder) 13) 5 6)) - ; (values `(3 4) `((+ (define ,highlight-placeholder) 13)) `(5 6)) - ; - ; (redivide `(,highlight-placeholder 5 6)) - ; (values `() `(,highlight-placeholder) `(5 6)) - ; - ; (redivide `(4 5 ,highlight-placeholder ,highlight-placeholder)) - ; (values `(4 5) `(,highlight-placeholder ,highlight-placeholder) `()) - ; - ; (printf "will be errors:~n") - ; (equal? (redivide `(1 2 3 4)) - ; error-value) - ; - ; (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) + ;; mutated on receipt of a break, used in displaying breakpoint stuff. + (define steps-received 0) (define break (opt-lambda (mark-set break-kind [returned-value-list #f]) - + + (set! steps-received (+ steps-received 1)) + ;; have to be careful else this won't be looked up right away: + (when (getenv "PLTSTEPPERUNSAFE") + (let ([steps-received/current steps-received]) + (run-on-drscheme-side + (lambda () + (display-break-stuff 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 === + ;; /Users/clements/plt/collects/drscheme/private/rep.ss:1183:10: queue-user/wait method in ...cheme/private/rep.ss:480:8 + ;; /Users/clements/plt/collects/drscheme/private/rep.ss:1094:10: init-evaluation-thread method in ...cheme/private/rep.ss:480:8 + ;; /Users/clements/plt/collects/drscheme/private/rep.ss:1346:10: reset-console method in ...cheme/private/rep.ss:480:8 + ;; /Users/clements/plt/collects/mztake/debug-tool.ss:510:10: reset-console method in ...mztake/debug-tool.ss:428:8 + ;; /Users/clements/plt/collects/test-suite/tool.ss:162:10: reset-console method in ...s/test-suite/tool.ss:137:8 + ;; /Users/clements/plt/collects/drscheme/private/rep.ss:1413:10: initialize-console method in ...cheme/private/rep.ss:480:8 + ;; /Users/clements/plt/collects/drscheme/private/unit.ss:3200:6: create-new-drscheme-frame + ;; /Users/clements/plt/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))]) @@ -183,18 +167,6 @@ [#(exp #t) exp])]) finished-exps)) - ;; TO BE SCRAPPED - #;(define (double-redivide finished-exps new-exprs-before new-exprs-after) - (let*-values ([(before current after) (redivide new-exprs-before)] - [(before-2 current-2 after-2) (redivide new-exprs-after)]) - (unless (equal? (map syntax-object->hilite-datum before) - (map syntax-object->hilite-datum before-2)) - (error 'double-redivide "reconstructed before defs are not equal.")) - (unless (equal? (map syntax-object->hilite-datum after) - (map syntax-object->hilite-datum after-2)) - (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) (begin diff --git a/collects/stepper/private/reconstruct.ss b/collects/stepper/private/reconstruct.ss index e2bcbaf3e9..826936d76a 100644 --- a/collects/stepper/private/reconstruct.ss +++ b/collects/stepper/private/reconstruct.ss @@ -156,7 +156,8 @@ (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)) + (or (eq? (syntax-property expr 'stepper-hint) 'comes-from-begin) + (syntax-property expr 'stepper-skip-double-break))) (not (render-settings-lifting? render-settings)))] [(expr-finished-break define-struct-break late-let-break) #f])) diff --git a/collects/stepper/private/shared.ss b/collects/stepper/private/shared.ss index 5e3dd095b8..c7c60c76b5 100644 --- a/collects/stepper/private/shared.ss +++ b/collects/stepper/private/shared.ss @@ -306,8 +306,8 @@ [(and (syntax? ilist) (pair? (syntax-e ilist))) (loop (syntax-e ilist))] [(null? ilist) null]))) - - ; arglist-flatten : produces a list containing the elements of the ilist + + ;; arglist-flatten : produces a list containing the elements of the ilist (define (arglist-flatten arglist) (let loop ([ilist arglist]) @@ -320,19 +320,22 @@ [(and (syntax? ilist) (pair? (syntax-e ilist))) (loop (syntax-e ilist))]))) - - ; zip : (listof 'a) (listof 'b) (listof 'c) ... -> (listof (list 'a 'b 'c ...)) - ; zip reshuffles lists of items into a list of item-lists. Look at the contract, okay? - + + ;; zip : (listof 'a) (listof 'b) (listof 'c) ... + ;; -> (listof (list 'a 'b 'c ...)) + ;; zip reshuffles lists of items into a list of item-lists. Look at the + ;; contract, okay? + (define zip (lambda args (apply map list args))) - - (define let-counter (syntax-property #'let-counter 'stepper-binding-type 'stepper-temp)) - - + + (define let-counter + (syntax-property #'let-counter 'stepper-binding-type 'stepper-temp)) + + ; syntax-pair-map (using the def'ns of the MzScheme docs): - + (define (syntax-pair-map pair fn) (cons (fn (car pair)) (cond [(syntax? (cdr pair)) @@ -341,41 +344,42 @@ (syntax-pair-map (cdr pair) fn)] [(null? (cdr pair)) null]))) - + (define (make-queue) (box null)) - + (define (queue-push queue new) (set-box! queue (append (unbox queue) (list new)))) (define (queue-pop queue) (if (null? (unbox queue)) - (error 'queue-pop "no elements in queue") - (let ([first (car (unbox queue))]) - (set-box! queue (cdr (unbox queue))) - first))) - + (error 'queue-pop "no elements in queue") + (let ([first (car (unbox queue))]) + (set-box! queue (cdr (unbox queue))) + first))) + (define (queue-length queue) (length (unbox queue))) - + (define (rebuild-stx new old) (syntax-recertify (datum->syntax-object old new old old) old (current-code-inspector) #f)) - + (define break-kind? - (symbols 'normal-break 'normal-break/values '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 (define (swap-args 2-arg-fun) (lambda (x y) (2-arg-fun y x))) - + (define second-arg (lambda (dc y) y)) - + (define up-mappings `((rebuild ((,car ,(lambda (stx new) (cons new (cdr stx)))) (,cdr ,(lambda (stx new) (cons (car stx) new))) @@ -383,28 +387,29 @@ (discard ((,car ,second-arg) (,cdr ,second-arg) (,syntax-e ,second-arg))))) - + (define (update fn-list val fn traversal) (if (null? fn-list) (fn val) (let* ([down (car fn-list)] [up (cadr (assq down (cadr (assq traversal up-mappings))))]) (up val (update (cdr fn-list) (down val) fn traversal))))) - - - ;; skipto/auto : syntax-object? (symbols 'rebuild 'discard) (syntax-object? . -> . syntax-object?) - ;; "skips over" part of a tree to find a subtree indicated by the stepper-skipto property. If the - ;; traversal argument is 'rebuild, the result of transformation is embedded again in the same tree. - ;; if the traversal argument is 'discard, the result of the transformation is the result of this - ;; function + + ;; skipto/auto : syntax-object? + ;; (symbols 'rebuild 'discard) + ;; (syntax-object? . -> . syntax-object?) + ;; "skips over" part of a tree to find a subtree indicated by the + ;; stepper-skipto property. If the traversal argument is 'rebuild, the + ;; result of transformation is embedded again in the same tree. if the + ;; traversal argument is 'discard, the result of the transformation is the + ;; result of this function (define (skipto/auto stx traversal transformer) - (cond [(syntax-property stx 'stepper-skipto) + (cond [(syntax-property stx 'stepper-skipto) => (cut update <> stx (cut skipto/auto <> traversal transformer) traversal)] [else (transformer stx)])) - - - ; small test case: + + ; small test case: ;(equal? (syntax-object->datum ; (skipto/auto (syntax-property #`(a #,(syntax-property #`(b c) ; 'stepper-skipto @@ -414,65 +419,63 @@ ; 'discard ; (lambda (x) x))) ; 'c) - - + + ; BINDING-/VARREF-SET FUNCTIONS - + ; note: a BINDING-SET which is not 'all may be used as a VARREF-SET. ; this is because they both consist of syntax objects, and a binding ; answers true to bound-identifier=? with itself, just like a varref ; in the scope of that binding would. - + ; binding-set-union: (listof BINDING-SET) -> BINDING-SET ; varref-set-union: (listof VARREF-SET) -> VARREF-SET - + (define profiling-table (make-hash-table 'equal)) (define (reset-profiling-table) (set! profiling-table (make-hash-table 'equal))) - - - (define (get-set-pair-union-stats) (hash-table-map profiling-table (lambda (k v) (list k (unbox v))))) - - - ; test cases : - ; (profiling-table-incr 1 2) - ; (profiling-table-incr 2 3) - ; (profiling-table-incr 2 1) - ; (profiling-table-incr 1 2) - ; (profiling-table-incr 2 1) - ; - ; (equal? (get-set-pair-union-stats) - ; `(((2 . 3) 1) ((2 . 1) 2) ((1 . 2) 2))) - - ; until this remove* goes into list.ss? - + + (define (get-set-pair-union-stats) + (hash-table-map profiling-table (lambda (k v) (list k (unbox v))))) + + ;; test cases : + ;; (profiling-table-incr 1 2) + ;; (profiling-table-incr 2 3) + ;; (profiling-table-incr 2 1) + ;; (profiling-table-incr 1 2) + ;; (profiling-table-incr 2 1) + ;; + ;; (equal? (get-set-pair-union-stats) + ;; `(((2 . 3) 1) ((2 . 1) 2) ((1 . 2) 2))) + + ;; until this remove* goes into list.ss? + (define (set-pair-union a-set b-set comparator) (cond [(null? b-set) a-set] [(null? a-set) b-set] [else (append (remove* a-set b-set comparator) a-set)])) - + (define (varref-set-pair-union a-set b-set) (set-pair-union a-set b-set free-identifier=?)) - + (define (binding-set-pair-union a-set b-set) (cond [(eq? a-set 'all) 'all] [(eq? b-set 'all) 'all] [else (set-pair-union a-set b-set eq?)])) - + (define (pair-union->many-union fn) (lambda (args) (foldl fn null args))) - + (define binding-set-union (pair-union->many-union binding-set-pair-union)) - + (define varref-set-union (pair-union->many-union varref-set-pair-union)) - ; binding-set-varref-set-intersect : BINDING-SET VARREF-SET -> BINDING-SET ; return the subset of varrefs that appear in the bindings - + (define (binding-set-varref-set-intersect bindings varrefs) (cond [(eq? bindings 'all) varrefs] [else (filter (lambda (varref) @@ -480,30 +483,31 @@ (bound-identifier=? binding varref)) bindings)) varrefs)])) - + ; varref-set-remove-bindings : VARREF-SET (BINDING-SET - 'all) -> VARREF-SET ; remove bindings from varrefs - + (define (varref-set-remove-bindings varrefs bindings) (cond [(eq? bindings 'all) (error 'varref-set-remove-bindings "binding-set 'all passed as second argument, first argument was: ~s" varrefs)] [else (remove* bindings varrefs bound-identifier=?)])) - - ; sublist returns the list beginning with element and ending just before element . - ; (-> number? number? list? list?) - (define (sublist begin end lst) - (if (= end 0) + + ;; sublist returns the list beginning with element and ending just + ;; before element . + ;; (-> number? number? list? list?) + (define (sublist begin end lst) + (if (= end 0) null (if (= begin 0) (cons (car lst) (sublist 0 (- end 1) (cdr lst))) (sublist (- begin 1) (- end 1) (cdr lst))))) - - + ; attach-info : SYNTAX-OBJECT SYNTAX-OBJECT -> SYNTAX-OBJECT - ; attach-info attaches to a generated piece of syntax the origin & source information of another. - ; we do this so that macro unwinding can tell what reconstructed syntax came from what original syntax - + ; attach-info attaches to a generated piece of syntax the origin & source + ; information of another. we do this so that macro unwinding can tell what + ; reconstructed syntax came from what original syntax + (define labels-to-attach `((user-origin origin) (user-stepper-hint stepper-hint) @@ -512,14 +516,16 @@ (user-stepper-proc-define-name stepper-proc-define-name) (user-stepper-and/or-clauses-consumed stepper-and/or-clauses-consumed) (user-stepper-offset-index stepper-offset-index) - (stepper-xml-hint stepper-xml-hint))) ; I find it mildly worrisome that this breaks the pattern - ; by failing to preface the identifier with 'user-'. JBC, 2005-08 - - ; take info from source expressions to reconstructed expressions - ; (from native property names to 'user-' style property names) - + ;; I find it mildly worrisome that this breaks the pattern + ;; by failing to preface the identifier with 'user-'. JBC, 2005-08 + (stepper-xml-hint stepper-xml-hint))) + + ;; take info from source expressions to reconstructed expressions + ;; (from native property names to 'user-' style property names) + (define (attach-info to-exp from-exp) - (if (syntax-property from-exp 'stepper-offset-index) (>>> (syntax-property from-exp 'stepper-offset-index))) + (if (syntax-property from-exp 'stepper-offset-index) + (>>> (syntax-property from-exp 'stepper-offset-index))) (let* ([attached (foldl (lambda (labels stx) (match labels [`(,new-label ,old-label) @@ -529,15 +535,16 @@ [attached (syntax-property attached 'user-source (syntax-source from-exp))] [attached (syntax-property attached 'user-position (syntax-position from-exp))]) attached)) - - ; transfer info from reconstructed expressions to other reconstructed expressions - ; (from 'user-' style names to 'user-' style names) - + + ;; transfer info from reconstructed expressions to other reconstructed + ;; expressions + ;; (from 'user-' style names to 'user-' style names) + (define (transfer-info to-stx from-exp) (let* ([attached (foldl (lambda (labels stx) (match labels - [`(,new-label ,old-label) - (syntax-property stx new-label (syntax-property from-exp new-label))])) + [`(,new-label ,old-label) + (syntax-property stx new-label (syntax-property from-exp new-label))])) to-stx labels-to-attach)] [attached (syntax-property attached 'user-source (syntax-property from-exp 'user-source))] @@ -545,7 +552,7 @@ [attached (syntax-property attached 'stepper-highlight (or (syntax-property from-exp 'stepper-highlight) (syntax-property attached 'stepper-highlight)))]) attached)) - + (define (values-map fn . lsts) (apply values (apply map list (apply map (lambda args (call-with-values (lambda () (apply fn args)) list)) diff --git a/collects/stepper/stepper-tool.ss b/collects/stepper/stepper-tool.ss index 0f03fffc5f..48e4141774 100644 --- a/collects/stepper/stepper-tool.ss +++ b/collects/stepper/stepper-tool.ss @@ -226,25 +226,31 @@ (define (hand-off-and-block step-text step-kind) (let ([new-semaphore (make-semaphore)]) - (parameterize ([current-eventspace drscheme-eventspace]) - (queue-callback - (lambda () - (async-channel-put view-channel (list step-text new-semaphore step-kind)) - (when stepper-is-waiting? - (let ([try-get (async-channel-try-get view-channel)]) - (unless try-get - (error 'check-for-stepper-waiting "queue is empty, even though a step was just added.")) - (add-view-triple try-get) - (if (right-kind-of-step? (caddr try-get)) - ; got the desired step; show the user: - (begin - (set! stepper-is-waiting? #f) - (update-view/existing (- (length view-history) 1))) - ; nope, keep running: - (begin - (en/dis-able-buttons) - (semaphore-post new-semaphore))))))) - (semaphore-wait new-semaphore)))) + (run-on-drscheme-side + (lambda () + (async-channel-put view-channel (list step-text new-semaphore step-kind)) + (when stepper-is-waiting? + (let ([try-get (async-channel-try-get view-channel)]) + (unless try-get + (error 'check-for-stepper-waiting "queue is empty, even though a step was just added.")) + (add-view-triple try-get) + (if (right-kind-of-step? (caddr try-get)) + ; got the desired step; show the user: + (begin + (set! stepper-is-waiting? #f) + (update-view/existing (- (length view-history) 1))) + ; nope, keep running: + (begin + (en/dis-able-buttons) + (semaphore-post new-semaphore))))))) + (semaphore-wait new-semaphore))) + + ;; run-on-drscheme-side : runs a thunk in the drscheme eventspace. + ;; Passed to 'go' so that display-break-stuff can work. This would be + ;; cleaner with two-way provides. + (define (run-on-drscheme-side thunk) + (parameterize ([current-eventspace drscheme-eventspace]) + (queue-callback thunk))) ; right-kind-of-step? : (boolean? . -> . boolean?) ; is this step the kind of step that the gui is waiting for? @@ -430,7 +436,8 @@ (not (member language-level-name (list (string-constant intermediate-student/lambda) (string-constant advanced-student)))) - language-level-name) + language-level-name + run-on-drscheme-side) (send s-frame show #t) s-frame)