suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Merged in changes from branch: generalizations and improvements.

Browse Source 
svn: r3967
This commit is contained in:
Eli Barzilay 2006-08-04 20:00:31 +00:00
parent ff59f38105
commit 3852135b8b
7 changed files with 270 additions and 263 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

38
collects/stepper/private/display-break-stuff.ss Normal file
View File

@ -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))))
)

156
collects/stepper/private/macro-unwind.ss
View File

@ -65,64 +65,44 @@
stx (syntax-pair-map (syntax-e stx) inner) stx stx) stx (syntax-pair-map (syntax-e stx) inner) stx 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 (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 (transfer-info
(if (syntax-property stx 'user-stepper-hint) (let ([hint (syntax-property stx 'user-stepper-hint)])
(case (syntax-property stx 'user-stepper-hint) (if (procedure? hint)
(hint stx recur-on-pieces)
[(comes-from-cond) (let ([process (case hint
(unwind-cond stx [(comes-from-cond) unwind-cond]
(syntax-property stx 'user-source) [(comes-from-and) (unwind-and/or 'and)]
(syntax-property stx 'user-position))] [(comes-from-or) (unwind-and/or 'or)]
[(comes-from-local) unwind-local]
[(comes-from-and) [(comes-from-recur) unwind-recur]
(unwind-and/or stx [(comes-from-begin) unwind-begin]
(syntax-property stx 'user-source) [else fall-through])])
(syntax-property stx 'user-position) (process stx))))
'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))
stx)) stx))
(define (transfer-highlight from to) (define (transfer-highlight from to)
@ -254,33 +234,35 @@
[result (inner result-stx)]) [result (inner result-stx)])
#`(new-test result))) #`(new-test result)))
(define (unwind-cond stx user-source user-position) (define (unwind-cond stx)
(with-syntax (let ([user-source (syntax-property stx 'user-source)]
([clauses [user-position (syntax-property stx 'user-position)])
(let loop ([stx stx]) (with-syntax
(if (and (eq? user-source ([clauses
(syntax-property stx 'user-source)) (let loop ([stx stx])
(eq? user-position (if (and (eq? user-source
(syntax-property stx 'user-position))) (syntax-property stx 'user-source))
(syntax-case stx (if begin #%app) (eq? user-position
;; the else clause disappears when it's a (syntax-property stx 'user-position)))
;; language-inserted else clause (syntax-case stx (if begin #%app)
[(if test result) ;; the else clause disappears when it's a
(list (unwind-cond-clause stx #`test #`result))] ;; language-inserted else clause
[(if test result else-clause) [(if test result)
(cons (unwind-cond-clause stx #`test #`result) (list (unwind-cond-clause stx #`test #`result))]
(loop (syntax else-clause)))] [(if test result else-clause)
;; else clause appears momentarily in 'before,' even (cons (unwind-cond-clause stx #`test #`result)
;; though it's a 'skip-completely' (loop (syntax else-clause)))]
[(begin . rest) null] ;; else clause appears momentarily in 'before,' even
[else-stx ;; though it's a 'skip-completely'
(error 'unwind-cond [(begin . rest) null]
"expected an if, got: ~e" [else-stx
(syntax-object->datum (syntax else-stx)))]) (error 'unwind-cond
(error 'unwind-cond "expected an if, got: ~e"
"expected a cond clause expansion, got: ~e" (syntax-object->datum (syntax else-stx)))])
(syntax-object->datum stx))))]) (error 'unwind-cond
(syntax (cond . clauses)))) "expected a cond clause expansion, got: ~e"
(syntax-object->datum stx))))])
(syntax (cond . clauses)))))
(define (unwind-begin stx) (define (unwind-begin stx)
(syntax-case stx (let-values) (syntax-case stx (let-values)
@ -289,10 +271,10 @@
(map inner (syntax->list #`(body ...)))]) (map inner (syntax->list #`(body ...)))])
#`(begin new-body ...))])) #`(begin new-body ...))]))
(define (unwind-and/or stx user-source user-position label) (define ((unwind-and/or label) stx user-source user-position)
(let ([clause-padder (case label (let ([user-source (syntax-property stx 'user-source)]
[(and) #`true] [user-position (syntax-property stx 'user-position)]
[(or) #`false])]) [clause-padder (case label [(and) #`true] [(or) #`false])])
(with-syntax (with-syntax
([clauses ([clauses
(append (append

8
collects/stepper/private/marks.ss
View File

@ -109,11 +109,11 @@
(define (display-mark mark) (define (display-mark mark)
(apply (apply
string-append string-append
(format "source: ~a~n" (syntax-object->datum (mark-source mark))) (format "source: ~a\n" (syntax-object->datum (mark-source mark)))
(format "label: ~a~n" (mark-label mark)) (format "label: ~a\n" (mark-label mark))
(format "bindings:~n") (format "bindings:\n")
(map (lambda (binding) (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-binding-value binding)))
(mark-bindings mark)))) (mark-bindings mark))))

88
collects/stepper/private/model.ss
View File

@ -42,7 +42,10 @@
"shared.ss" "shared.ss"
"marks.ss" "marks.ss"
"model-settings.ss" "model-settings.ss"
"macro-unwind.ss") "macro-unwind.ss"
;; for breakpoint display
"display-break-stuff.ss")
(define program-expander-contract (define program-expander-contract
@ -57,14 +60,13 @@
(or/c render-settings? false/c) ; render-settings (or/c render-settings? false/c) ; render-settings
boolean? ; track-inferred-names? boolean? ; track-inferred-names?
string? ; language-level-name string? ; language-level-name
(procedure? . -> . void?) ; run-on-drscheme-side
. -> . . -> .
void?)]) void?)])
; go starts a stepper instance ; go starts a stepper instance
; see provide stmt for contract ; 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))) ;; 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. ;; 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-step-was-app? #f)
(define held-finished-list null) (define held-finished-list null)
(define basic-eval (current-eval))
;; highlight-mutated-expressions : ;; highlight-mutated-expressions :
;; ((listof (list/c syntax? syntax?)) (listof (list/c syntax? syntax?)) . -> . (list/c (listof syntax?) (listof syntax?))) ;; ((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 ;; highlights changes occurring due to mutation. This function accepts the left-hand-side
@ -127,51 +127,35 @@
[else (list (syntax-property left 'stepper-highlight) [else (list (syntax-property left 'stepper-highlight)
(syntax-property right '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
;; mutated on receipt of a break, used in displaying breakpoint stuff.
; (redivide `(3 4 (+ (define ,highlight-placeholder) 13) 5 6)) (define steps-received 0)
; (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)
(define break (define break
(opt-lambda (mark-set break-kind [returned-value-list #f]) (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 <eventspace>; 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))]) (let* ([mark-list (and mark-set (extract-mark-list mark-set))])
@ -183,18 +167,6 @@
[#(exp #t) exp])]) [#(exp #t) exp])])
finished-exps)) 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) #;(printf "break called with break-kind: ~a ..." break-kind)
(if (r:skip-step? break-kind mark-list render-settings) (if (r:skip-step? break-kind mark-list render-settings)
(begin (begin

3
collects/stepper/private/reconstruct.ss
View File

@ -156,7 +156,8 @@
(or (or
;; don't stop for a double-break on a let that is the expansion of a 'begin' ;; don't stop for a double-break on a let that is the expansion of a 'begin'
(let ([expr (mark-source (car mark-list))]) (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)))] (not (render-settings-lifting? render-settings)))]
[(expr-finished-break define-struct-break late-let-break) #f])) [(expr-finished-break define-struct-break late-let-break) #f]))

97
collects/stepper/private/shared.ss
View File

@ -307,7 +307,7 @@
(loop (syntax-e ilist))] (loop (syntax-e ilist))]
[(null? ilist) null]))) [(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) (define (arglist-flatten arglist)
(let loop ([ilist arglist]) (let loop ([ilist arglist])
@ -321,14 +321,17 @@
(pair? (syntax-e ilist))) (pair? (syntax-e ilist)))
(loop (syntax-e ilist))]))) (loop (syntax-e ilist))])))
; zip : (listof 'a) (listof 'b) (listof 'c) ... -> (listof (list 'a 'b 'c ...)) ;; zip : (listof 'a) (listof 'b) (listof 'c) ...
; zip reshuffles lists of items into a list of item-lists. Look at the contract, okay? ;; -> (listof (list 'a 'b 'c ...))
;; zip reshuffles lists of items into a list of item-lists. Look at the
;; contract, okay?
(define zip (define zip
(lambda args (lambda args
(apply map list 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): ; syntax-pair-map (using the def'ns of the MzScheme docs):
@ -350,10 +353,10 @@
(define (queue-pop queue) (define (queue-pop queue)
(if (null? (unbox queue)) (if (null? (unbox queue))
(error 'queue-pop "no elements in queue") (error 'queue-pop "no elements in queue")
(let ([first (car (unbox queue))]) (let ([first (car (unbox queue))])
(set-box! queue (cdr (unbox queue))) (set-box! queue (cdr (unbox queue)))
first))) first)))
(define (queue-length queue) (define (queue-length queue)
(length (unbox queue))) (length (unbox queue)))
@ -365,8 +368,9 @@
#f)) #f))
(define break-kind? (define break-kind?
(symbols 'normal-break 'normal-break/values 'result-exp-break 'result-value-break (symbols 'normal-break 'normal-break/values 'result-exp-break
'double-break 'late-let-break 'expr-finished-break 'define-struct-break)) 'result-value-break 'double-break 'late-let-break
'expr-finished-break 'define-struct-break))
; functional update package ; functional update package
@ -391,19 +395,20 @@
[up (cadr (assq down (cadr (assq traversal up-mappings))))]) [up (cadr (assq down (cadr (assq traversal up-mappings))))])
(up val (update (cdr fn-list) (down val) fn traversal))))) (up val (update (cdr fn-list) (down val) fn traversal)))))
;; skipto/auto : syntax-object?
;; skipto/auto : syntax-object? (symbols 'rebuild 'discard) (syntax-object? . -> . syntax-object?) ;; (symbols 'rebuild 'discard)
;; "skips over" part of a tree to find a subtree indicated by the stepper-skipto property. If the ;; (syntax-object? . -> . syntax-object?)
;; traversal argument is 'rebuild, the result of transformation is embedded again in the same tree. ;; "skips over" part of a tree to find a subtree indicated by the
;; if the traversal argument is 'discard, the result of the transformation is the result of this ;; stepper-skipto property. If the traversal argument is 'rebuild, the
;; function ;; 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) (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)] (cut update <> stx (cut skipto/auto <> traversal transformer) traversal)]
[else (transformer stx)])) [else (transformer stx)]))
; small test case: ; small test case:
;(equal? (syntax-object->datum ;(equal? (syntax-object->datum
; (skipto/auto (syntax-property #`(a #,(syntax-property #`(b c) ; (skipto/auto (syntax-property #`(a #,(syntax-property #`(b c)
@ -430,21 +435,20 @@
(define (reset-profiling-table) (define (reset-profiling-table)
(set! profiling-table (make-hash-table 'equal))) (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)))))
(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?
; 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) (define (set-pair-union a-set b-set comparator)
(cond [(null? b-set) a-set] (cond [(null? b-set) a-set]
@ -469,7 +473,6 @@
(define varref-set-union (define varref-set-union
(pair-union->many-union varref-set-pair-union)) (pair-union->many-union varref-set-pair-union))
; binding-set-varref-set-intersect : BINDING-SET VARREF-SET -> BINDING-SET ; binding-set-varref-set-intersect : BINDING-SET VARREF-SET -> BINDING-SET
; return the subset of varrefs that appear in the bindings ; return the subset of varrefs that appear in the bindings
@ -489,8 +492,9 @@
(error 'varref-set-remove-bindings "binding-set 'all passed as second argument, first argument was: ~s" varrefs)] (error 'varref-set-remove-bindings "binding-set 'all passed as second argument, first argument was: ~s" varrefs)]
[else (remove* bindings varrefs bound-identifier=?)])) [else (remove* bindings varrefs bound-identifier=?)]))
; sublist returns the list beginning with element <begin> and ending just before element <end>. ;; sublist returns the list beginning with element <begin> and ending just
; (-> number? number? list? list?) ;; before element <end>.
;; (-> number? number? list? list?)
(define (sublist begin end lst) (define (sublist begin end lst)
(if (= end 0) (if (= end 0)
null null
@ -499,10 +503,10 @@
(sublist 0 (- end 1) (cdr lst))) (sublist 0 (- end 1) (cdr lst)))
(sublist (- begin 1) (- end 1) (cdr lst))))) (sublist (- begin 1) (- end 1) (cdr lst)))))
; attach-info : SYNTAX-OBJECT SYNTAX-OBJECT -> SYNTAX-OBJECT ; attach-info : SYNTAX-OBJECT SYNTAX-OBJECT -> SYNTAX-OBJECT
; attach-info attaches to a generated piece of syntax the origin & source information of another. ; attach-info attaches to a generated piece of syntax the origin & source
; we do this so that macro unwinding can tell what reconstructed syntax came from what original syntax ; information of another. we do this so that macro unwinding can tell what
; reconstructed syntax came from what original syntax
(define labels-to-attach (define labels-to-attach
`((user-origin origin) `((user-origin origin)
@ -512,14 +516,16 @@
(user-stepper-proc-define-name stepper-proc-define-name) (user-stepper-proc-define-name stepper-proc-define-name)
(user-stepper-and/or-clauses-consumed stepper-and/or-clauses-consumed) (user-stepper-and/or-clauses-consumed stepper-and/or-clauses-consumed)
(user-stepper-offset-index stepper-offset-index) (user-stepper-offset-index stepper-offset-index)
(stepper-xml-hint stepper-xml-hint))) ; I find it mildly worrisome that this breaks the pattern ;; I find it mildly worrisome that this breaks the pattern
; by failing to preface the identifier with 'user-'. JBC, 2005-08 ;; 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 ;; take info from source expressions to reconstructed expressions
; (from native property names to 'user-' style property names) ;; (from native property names to 'user-' style property names)
(define (attach-info to-exp from-exp) (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) (let* ([attached (foldl (lambda (labels stx)
(match labels (match labels
[`(,new-label ,old-label) [`(,new-label ,old-label)
@ -530,14 +536,15 @@
[attached (syntax-property attached 'user-position (syntax-position from-exp))]) [attached (syntax-property attached 'user-position (syntax-position from-exp))])
attached)) attached))
; transfer info from reconstructed expressions to other reconstructed expressions ;; transfer info from reconstructed expressions to other reconstructed
; (from 'user-' style names to 'user-' style names) ;; expressions
;; (from 'user-' style names to 'user-' style names)
(define (transfer-info to-stx from-exp) (define (transfer-info to-stx from-exp)
(let* ([attached (foldl (lambda (labels stx) (let* ([attached (foldl (lambda (labels stx)
(match labels (match labels
[`(,new-label ,old-label) [`(,new-label ,old-label)
(syntax-property stx new-label (syntax-property from-exp new-label))])) (syntax-property stx new-label (syntax-property from-exp new-label))]))
to-stx to-stx
labels-to-attach)] labels-to-attach)]
[attached (syntax-property attached 'user-source (syntax-property from-exp 'user-source))] [attached (syntax-property attached 'user-source (syntax-property from-exp 'user-source))]

47
collects/stepper/stepper-tool.ss
View File

@ -226,25 +226,31 @@
(define (hand-off-and-block step-text step-kind) (define (hand-off-and-block step-text step-kind)
(let ([new-semaphore (make-semaphore)]) (let ([new-semaphore (make-semaphore)])
(parameterize ([current-eventspace drscheme-eventspace]) (run-on-drscheme-side
(queue-callback (lambda ()
(lambda () (async-channel-put view-channel (list step-text new-semaphore step-kind))
(async-channel-put view-channel (list step-text new-semaphore step-kind)) (when stepper-is-waiting?
(when stepper-is-waiting? (let ([try-get (async-channel-try-get view-channel)])
(let ([try-get (async-channel-try-get view-channel)]) (unless try-get
(unless try-get (error 'check-for-stepper-waiting "queue is empty, even though a step was just added."))
(error 'check-for-stepper-waiting "queue is empty, even though a step was just added.")) (add-view-triple try-get)
(add-view-triple try-get) (if (right-kind-of-step? (caddr try-get))
(if (right-kind-of-step? (caddr try-get)) ; got the desired step; show the user:
; got the desired step; show the user: (begin
(begin (set! stepper-is-waiting? #f)
(set! stepper-is-waiting? #f) (update-view/existing (- (length view-history) 1)))
(update-view/existing (- (length view-history) 1))) ; nope, keep running:
; nope, keep running: (begin
(begin (en/dis-able-buttons)
(en/dis-able-buttons) (semaphore-post new-semaphore)))))))
(semaphore-post new-semaphore))))))) (semaphore-wait 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?) ; right-kind-of-step? : (boolean? . -> . boolean?)
; is this step the kind of step that the gui is waiting for? ; is this step the kind of step that the gui is waiting for?
@ -430,7 +436,8 @@
(not (member language-level-name (not (member language-level-name
(list (string-constant intermediate-student/lambda) (list (string-constant intermediate-student/lambda)
(string-constant advanced-student)))) (string-constant advanced-student))))
language-level-name) language-level-name
run-on-drscheme-side)
(send s-frame show #t) (send s-frame show #t)
s-frame) s-frame)