Merged in changes from branch: generalizations and improvements.
svn: r3967
This commit is contained in:
Eli Barzilay
parent
ff59f38105
commit
3852135b8b
38
collects/stepper/private/display-break-stuff.ss
Normal file
38
collects/stepper/private/display-break-stuff.ss
Normal 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))))
|
||||
)
|
||||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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))))
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -127,51 +127,35 @@
|
|||
[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 <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))])
|
||||
|
||||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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]))
|
||||
|
||||
|
|
|
|||
|
|
@ -307,7 +307,7 @@
|
|||
(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])
|
||||
|
|
@ -321,14 +321,17 @@
|
|||
(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):
|
||||
|
|
@ -350,10 +353,10 @@
|
|||
|
||||
(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)))
|
||||
|
|
@ -365,8 +368,9 @@
|
|||
#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
|
||||
|
||||
|
|
@ -391,19 +395,20 @@
|
|||
[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)
|
||||
=>
|
||||
(cut update <> stx (cut skipto/auto <> traversal transformer) traversal)]
|
||||
[else (transformer stx)]))
|
||||
|
||||
|
||||
; small test case:
|
||||
;(equal? (syntax-object->datum
|
||||
; (skipto/auto (syntax-property #`(a #,(syntax-property #`(b c)
|
||||
|
|
@ -430,21 +435,20 @@
|
|||
(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)))))
|
||||
|
||||
(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)))
|
||||
|
||||
|
||||
; 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?
|
||||
;; until this remove* goes into list.ss?
|
||||
|
||||
(define (set-pair-union a-set b-set comparator)
|
||||
(cond [(null? b-set) a-set]
|
||||
|
|
@ -469,7 +473,6 @@
|
|||
(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
|
||||
|
||||
|
|
@ -489,8 +492,9 @@
|
|||
(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 <begin> and ending just before element <end>.
|
||||
; (-> number? number? list? list?)
|
||||
;; sublist returns the list beginning with element <begin> and ending just
|
||||
;; before element <end>.
|
||||
;; (-> number? number? list? list?)
|
||||
(define (sublist begin end lst)
|
||||
(if (= end 0)
|
||||
null
|
||||
|
|
@ -499,10 +503,10 @@
|
|||
(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)
|
||||
|
|
@ -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
|
||||
;; 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)
|
||||
;; 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)
|
||||
|
|
@ -530,14 +536,15 @@
|
|||
[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))]
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user