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

jump-to-beginning-of-selected

Browse Source 
svn: r14501
This commit is contained in:
John Clements 2009-04-13 23:48:15 +00:00
parent 09bec206d6
commit 9c93191241
7 changed files with 962 additions and 1286 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -1,183 +1,183 @@
(module marks scheme/base
#lang scheme/base
(require mzlib/list
mzlib/contract
"my-macros.ss"
"shared.ss"
#;(file "/Users/clements/clements/scheme-scraps/eli-debug.ss"))
(require mzlib/list
mzlib/contract
"my-macros.ss"
"shared.ss"
#;(file "/Users/clements/clements/scheme-scraps/eli-debug.ss"))
(define-struct full-mark-struct (source label bindings values))
(define-struct full-mark-struct (source label bindings values))
; CONTRACTS
(define mark? (-> ; no args
full-mark-struct?))
(define mark-list? (listof procedure?))
(provide/contract
;[make-debug-info (any/c binding-set? varref-set? any/c boolean? . -> . syntax?)] ; (location tail-bound free label lifting? -> mark-stx)
[expose-mark (-> mark? (list/c any/c symbol? (listof (list/c identifier? any/c))))]
[make-top-level-mark (syntax? . -> . syntax?)]
[lookup-all-bindings ((identifier? . -> . boolean?) mark-list? . -> . (listof any/c))]
[lookup-first-binding ((identifier? . -> . boolean?) mark-list? ( -> any) . -> . any/c)]
[lookup-binding (mark-list? identifier? . -> . any)])
(provide
make-debug-info
wcm-wrap
skipto-mark?
skipto-mark
strip-skiptos
mark-list?
mark-source
mark-bindings
mark-label
mark-binding-value
mark-binding-binding
display-mark
all-bindings
#;lookup-binding-list
debug-key
extract-mark-list
(struct-out normal-breakpoint-info)
(struct-out error-breakpoint-info)
(struct-out breakpoint-halt)
(struct-out expression-finished))
; BREAKPOINT STRUCTURES
(define-struct normal-breakpoint-info (mark-list kind))
(define-struct error-breakpoint-info (message))
(define-struct breakpoint-halt ())
(define-struct expression-finished (returned-value-list))
(define-struct skipto-mark-struct ())
(define skipto-mark? skipto-mark-struct?)
(define skipto-mark (make-skipto-mark-struct))
(define (strip-skiptos mark-list)
(filter (lx (not (skipto-mark? _))) mark-list))
; debug-key: this key will be used as a key for the continuation marks.
(define-struct debug-key-struct ())
(define debug-key (make-debug-key-struct))
(define (extract-mark-list mark-set)
(strip-skiptos (continuation-mark-set->list mark-set debug-key)))
; the 'varargs' creator is used to avoid an extra cons cell in every mark:
(define (make-make-full-mark-varargs source label bindings)
(lambda values
(make-full-mark-struct source label bindings values)))
; see module top for type
(define (make-full-mark location label bindings)
(datum->syntax #'here `(#%plain-lambda () (#%plain-app ,(make-make-full-mark-varargs location label bindings)
,@(map make-mark-binding-stx bindings)))))
(define (mark-source mark)
(full-mark-struct-source (mark)))
(define (make-mark-binding-stx id)
#`(#%plain-lambda () #,id))
(define (mark-bindings mark)
(map list
(full-mark-struct-bindings (mark))
(full-mark-struct-values (mark))))
(define (mark-label mark)
(full-mark-struct-label (mark)))
(define (mark-binding-value mark-binding)
((cadr mark-binding)))
(define (mark-binding-binding mark-binding)
(car mark-binding))
; CONTRACTS
(define mark? (-> ; no args
full-mark-struct?))
(define mark-list? (listof procedure?))
(define (expose-mark mark)
(let ([source (mark-source mark)]
[label (mark-label mark)]
[bindings (mark-bindings mark)])
(list source
label
(map (lambda (binding)
(list (mark-binding-binding binding)
(mark-binding-value binding)))
bindings))))
(define (display-mark mark)
(apply
string-append
(format "source: ~a\n" (syntax->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))
(mark-binding-value binding)))
(mark-bindings mark))))
; possible optimization: rig the mark-maker to guarantee statically that a
; variable can occur at most once in a mark.
(define (binding-matches matcher mark)
(filter (lambda (binding-pair) (matcher (mark-binding-binding binding-pair))) (mark-bindings mark)))
(define (lookup-all-bindings matcher mark-list)
(apply append (map (lambda (m) (binding-matches matcher m)) mark-list)))
(define (lookup-first-binding matcher mark-list fail-thunk)
(let ([all-bindings (lookup-all-bindings matcher mark-list)])
(if (null? all-bindings)
(fail-thunk)
(car all-bindings))))
(define (lookup-binding mark-list id)
(mark-binding-value
(lookup-first-binding (lambda (id2) (free-identifier=? id id2))
mark-list
(lambda ()
(error 'lookup-binding "variable not found in environment: ~a~n" (if (syntax? id)
(syntax->datum id)
id))))))
(define (all-bindings mark)
(map mark-binding-binding (mark-bindings mark)))
(define (wcm-wrap debug-info expr)
#`(with-continuation-mark #,debug-key #,debug-info #,expr))
(provide/contract
;[make-debug-info (any/c binding-set? varref-set? any/c boolean? . -> . syntax?)] ; (location tail-bound free label lifting? -> mark-stx)
[expose-mark (-> mark? (list/c any/c symbol? (listof (list/c identifier? any/c))))]
[make-top-level-mark (syntax? . -> . syntax?)]
[lookup-all-bindings ((identifier? . -> . boolean?) mark-list? . -> . (listof any/c))]
[lookup-first-binding ((identifier? . -> . boolean?) mark-list? ( -> any) . -> . any/c)]
[lookup-binding (mark-list? identifier? . -> . any)])
; DEBUG-INFO STRUCTURES
;;;;;;;;;;
;;
;; make-debug-info builds the thunk which will be the mark at runtime. It contains
;; a source expression and a set of binding/value pairs.
;; (syntax-object BINDING-SET VARREF-SET any boolean (union/c false/c integer?)) -> debug-info)
;;
;;;;;;;;;;
(define (make-debug-info source tail-bound free-vars label lifting?)
(let*-2vals ([kept-vars (binding-set-varref-set-intersect tail-bound free-vars)])
(if lifting?
(let*-2vals ([let-bindings (filter (lambda (var)
(and
(case (stepper-syntax-property var 'stepper-binding-type)
((let-bound macro-bound) #t)
((lambda-bound stepper-temp non-lexical) #f)
(else (error 'make-debug-info
"varref ~a's binding-type info was not recognized: ~a"
(syntax-e var)
(stepper-syntax-property var 'stepper-binding-type))))
(not (stepper-syntax-property var 'stepper-no-lifting-info))))
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))))
(define (make-top-level-mark source-expr)
(make-full-mark source-expr 'top-level null)))
(provide
make-debug-info
wcm-wrap
skipto-mark?
skipto-mark
strip-skiptos
mark-list?
mark-source
mark-bindings
mark-label
mark-binding-value
mark-binding-binding
display-mark
all-bindings
#;lookup-binding-list
debug-key
extract-mark-list
(struct-out normal-breakpoint-info)
(struct-out error-breakpoint-info)
(struct-out breakpoint-halt)
(struct-out expression-finished))
; BREAKPOINT STRUCTURES
(define-struct normal-breakpoint-info (mark-list kind))
(define-struct error-breakpoint-info (message))
(define-struct breakpoint-halt ())
(define-struct expression-finished (returned-value-list))
(define-struct skipto-mark-struct ())
(define skipto-mark? skipto-mark-struct?)
(define skipto-mark (make-skipto-mark-struct))
(define (strip-skiptos mark-list)
(filter (lx (not (skipto-mark? _))) mark-list))
; debug-key: this key will be used as a key for the continuation marks.
(define-struct debug-key-struct ())
(define debug-key (make-debug-key-struct))
(define (extract-mark-list mark-set)
(strip-skiptos (continuation-mark-set->list mark-set debug-key)))
; the 'varargs' creator is used to avoid an extra cons cell in every mark:
(define (make-make-full-mark-varargs source label bindings)
(lambda values
(make-full-mark-struct source label bindings values)))
; see module top for type
(define (make-full-mark location label bindings)
(datum->syntax #'here `(#%plain-lambda () (#%plain-app ,(make-make-full-mark-varargs location label bindings)
,@(map make-mark-binding-stx bindings)))))
(define (mark-source mark)
(full-mark-struct-source (mark)))
(define (make-mark-binding-stx id)
#`(#%plain-lambda () #,id))
(define (mark-bindings mark)
(map list
(full-mark-struct-bindings (mark))
(full-mark-struct-values (mark))))
(define (mark-label mark)
(full-mark-struct-label (mark)))
(define (mark-binding-value mark-binding)
((cadr mark-binding)))
(define (mark-binding-binding mark-binding)
(car mark-binding))
(define (expose-mark mark)
(let ([source (mark-source mark)]
[label (mark-label mark)]
[bindings (mark-bindings mark)])
(list source
label
(map (lambda (binding)
(list (mark-binding-binding binding)
(mark-binding-value binding)))
bindings))))
(define (display-mark mark)
(apply
string-append
(format "source: ~a\n" (syntax->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))
(mark-binding-value binding)))
(mark-bindings mark))))
; possible optimization: rig the mark-maker to guarantee statically that a
; variable can occur at most once in a mark.
(define (binding-matches matcher mark)
(filter (lambda (binding-pair) (matcher (mark-binding-binding binding-pair))) (mark-bindings mark)))
(define (lookup-all-bindings matcher mark-list)
(apply append (map (lambda (m) (binding-matches matcher m)) mark-list)))
(define (lookup-first-binding matcher mark-list fail-thunk)
(let ([all-bindings (lookup-all-bindings matcher mark-list)])
(if (null? all-bindings)
(fail-thunk)
(car all-bindings))))
(define (lookup-binding mark-list id)
(mark-binding-value
(lookup-first-binding (lambda (id2) (free-identifier=? id id2))
mark-list
(lambda ()
(error 'lookup-binding "variable not found in environment: ~a~n" (if (syntax? id)
(syntax->datum id)
id))))))
(define (all-bindings mark)
(map mark-binding-binding (mark-bindings mark)))
(define (wcm-wrap debug-info expr)
#`(with-continuation-mark #,debug-key #,debug-info #,expr))
; DEBUG-INFO STRUCTURES
;;;;;;;;;;
;;
;; make-debug-info builds the thunk which will be the mark at runtime. It contains
;; a source expression and a set of binding/value pairs.
;; (syntax-object BINDING-SET VARREF-SET any boolean (union/c false/c integer?)) -> debug-info)
;;
;;;;;;;;;;
(define (make-debug-info source tail-bound free-vars label lifting?)
(let*-2vals ([kept-vars (binding-set-varref-set-intersect tail-bound free-vars)])
(if lifting?
(let*-2vals ([let-bindings (filter (lambda (var)
(and
(case (stepper-syntax-property var 'stepper-binding-type)
((let-bound macro-bound) #t)
((lambda-bound stepper-temp non-lexical) #f)
(else (error 'make-debug-info
"varref ~a's binding-type info was not recognized: ~a"
(syntax-e var)
(stepper-syntax-property var 'stepper-binding-type))))
(not (stepper-syntax-property var 'stepper-no-lifting-info))))
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))))
(define (make-top-level-mark source-expr)
(make-full-mark source-expr 'top-level null))

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

@ -35,165 +35,167 @@
; double(x) : ERROR
; late-let(x) : ERROR
#lang scheme/base
(module model scheme/base
(require scheme/contract
scheme/match
scheme/class
scheme/list
(prefix-in a: "annotate.ss")
(prefix-in r: "reconstruct.ss")
"shared.ss"
"marks.ss"
"model-settings.ss"
"macro-unwind.ss"
"lifting.ss"
(prefix-in test-engine: test-engine/scheme-tests)
#;(file "/Users/clements/clements/scheme-scraps/eli-debug.ss")
;; for breakpoint display
;; (commented out to allow nightly testing)
#;"display-break-stuff.ss")
(require scheme/contract
scheme/match
scheme/class
scheme/list
(prefix-in a: "annotate.ss")
(prefix-in r: "reconstruct.ss")
"shared.ss"
"marks.ss"
"model-settings.ss"
"macro-unwind.ss"
"lifting.ss"
(prefix-in test-engine: test-engine/scheme-tests)
#;(file "/Users/clements/clements/scheme-scraps/eli-debug.ss")
;; for breakpoint display
;; (commented out to allow nightly testing)
#;"display-break-stuff.ss")
(define program-expander-contract
((-> void?) ; init
((or/c eof-object? syntax? (cons/c string? any/c)) (-> void?)
. -> . void?) ; iter
. -> .
void?))
(define program-expander-contract
((-> void?) ; init
((or/c eof-object? syntax? (cons/c string? any/c)) (-> void?)
. -> . void?) ; iter
. -> .
void?))
(provide/contract
[go (program-expander-contract ; program-expander
(step-result? . -> . void?) ; receive-result
(or/c render-settings? false/c) ; render-settings
boolean? ; track-inferred-names?
(or/c object? (symbols 'testing)) ;; FIXME: can do better: subclass of language% ; the language level
(procedure? . -> . void?) ; run-on-drscheme-side
boolean? ; disable-error-handling (to allow debugging)
. -> .
void?)])
(provide/contract
[go (program-expander-contract ; program-expander
(step-result? . -> . void?) ; receive-result
(or/c render-settings? false/c) ; render-settings
boolean? ; track-inferred-names?
(or/c object? (symbols 'testing)) ;; FIXME: can do better: subclass of language% ; the language level
(procedure? . -> . void?) ; run-on-drscheme-side
boolean? ; disable-error-handling (to allow debugging)
. -> .
void?)])
; go starts a stepper instance
; see provide stmt for contract
(define (go program-expander receive-result render-settings
show-lambdas-as-lambdas? language-level run-on-drscheme-side
disable-error-handling)
;; 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.
(define finished-exps null)
(define/contract add-to-finished
((-> syntax?) (or/c (listof natural-number/c) false/c) (-> any)
. -> . void?)
(lambda (exp-thunk lifting-indices getter)
(set! finished-exps
(append finished-exps
(list (list exp-thunk lifting-indices getter))))))
;; the "held" variables are used to store the "before" step.
(define held-exp-list no-sexp)
(define held-step-was-app? #f)
(define held-finished-list null)
;; 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 darn 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))
; go starts a stepper instance
; see provide stmt for contract
(define (go program-expander receive-result render-settings
show-lambdas-as-lambdas? language-level run-on-drscheme-side
disable-error-handling)
;; 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.
(define finished-exps null)
(define/contract add-to-finished
((-> syntax?) (or/c (listof natural-number/c) false/c) (-> any)
. -> . void?)
(lambda (exp-thunk lifting-indices getter)
(set! finished-exps
(append finished-exps
(list (list exp-thunk lifting-indices getter))))))
;; the "held" variables are used to store the "before" step.
(define held-exp-list the-no-sexp)
(define-struct held (exps was-app? source-pos))
(define held-finished-list null)
;; 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 darn 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 (stepper-syntax-property left 'stepper-highlight)
(stepper-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 (stepper-syntax-property left 'stepper-highlight)
(stepper-syntax-property right 'stepper-highlight))]))
;; mutated on receipt of a break, used in displaying breakpoint stuff.
(define steps-received 0)
(define break
(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:
;; (commented out to allow nightly tests to proceed, 2007-09-04
#;(when (getenv "PLTSTEPPERUNSAFE")
(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 (stepper-syntax-property left 'stepper-highlight)
(stepper-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 (stepper-syntax-property left 'stepper-highlight)
(stepper-syntax-property right 'stepper-highlight))]))
;; mutated on receipt of a break, used in displaying breakpoint stuff.
(define steps-received 0)
(define break
(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:
;; (commented out to allow nightly tests to proceed, 2007-09-04
#;(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)))))
(let* ([mark-list (and mark-set (extract-mark-list mark-set))])
(define (reconstruct-all-completed)
(filter-map
(match-lambda
[(list source-thunk lifting-indices getter)
(let ([source (source-thunk)])
(if (r:hide-completed? source)
#f
(match (r:reconstruct-completed
source lifting-indices
getter render-settings)
[(vector exp #f) (unwind exp render-settings)]
[(vector exp #t) exp])))])
finished-exps))
#;(>>> break-kind)
#;(fprintf (current-error-port) "break called with break-kind: ~a ..." break-kind)
(if (r:skip-step? break-kind mark-list render-settings)
(let* ([mark-list (and mark-set (extract-mark-list mark-set))])
(define (reconstruct-all-completed)
(filter-map
(match-lambda
[(list source-thunk lifting-indices getter)
(let ([source (source-thunk)])
(if (r:hide-completed? source)
#f
(match (r:reconstruct-completed
source lifting-indices
getter render-settings)
[(vector exp #f) (unwind exp render-settings)]
[(vector exp #t) exp])))])
finished-exps))
#;(>>> break-kind)
#;(fprintf (current-error-port) "break called with break-kind: ~a ..." break-kind)
(if (r:skip-step? break-kind mark-list render-settings)
(begin
#;(fprintf (current-error-port) " but it was skipped!\n")
(when (or (eq? break-kind 'normal-break)
;; not sure about this...
(eq? break-kind 'nomal-break/values))
(set! held-exp-list skipped-step)))
(set! held-exp-list the-skipped-step)))
(begin
#;(fprintf (current-error-port) "and it wasn't skipped.\n")
(case break-kind
@ -205,67 +207,73 @@
"broken invariant: normal-break can't have returned values"))
(set! held-finished-list (reconstruct-all-completed))
(set! held-exp-list
(map (lambda (exp)
(unwind exp render-settings))
(maybe-lift
(r:reconstruct-left-side
mark-list returned-value-list render-settings)
#f)))
(set! held-step-was-app? (r:step-was-app? mark-list)))]
(make-held
(map (lambda (exp)
(unwind exp render-settings))
(maybe-lift
(r:reconstruct-left-side
mark-list returned-value-list render-settings)
#f))
(r:step-was-app? mark-list)
(syntax-position (mark-source (car mark-list))))))]
[(result-exp-break result-value-break)
(if (eq? held-exp-list skipped-step)
;; don't render if before step was a skipped-step
(set! held-exp-list no-sexp)
(let* ([new-finished-list (reconstruct-all-completed)]
[reconstructed
(map (lambda (exp)
(unwind exp render-settings))
(maybe-lift
(r:reconstruct-right-side
mark-list returned-value-list render-settings)
#f))]
[result
(if (eq? held-exp-list no-sexp)
;; in this case, there was no "before" step, due
;; to unannotated code. In this case, we make the
;; optimistic guess that none of the finished
;; expressions were mutated. It would be somewhat
;; painful to do a better job, and the stepper
;; makes no guarantees in this case.
(make-before-after-result
;; NB: this (... ...) IS UNRELATED TO
;; THE MACRO IDIOM OF THE SAME NAME
(list #`(... ...))
(append new-finished-list reconstructed)
'normal)
(let*-values
([(step-kind)
(if (and held-step-was-app?
(eq? break-kind 'result-exp-break))
'user-application
'normal)]
[(left-exps right-exps)
;; write this later:
;; (identify-changed
;; (append held-finished-list held-exps)
;; (append new-finished-list reconstructed))
(values (append held-finished-list
held-exp-list)
(append new-finished-list
reconstructed))])
(make-before-after-result
left-exps right-exps step-kind)))])
(set! held-exp-list no-sexp)
(receive-result result)))]
(let ([reconstruct
(lambda ()
(map (lambda (exp)
(unwind exp render-settings))
(maybe-lift
(r:reconstruct-right-side
mark-list returned-value-list render-settings)
#f)))]
[send-result (lambda (result)
(set! held-exp-list the-no-sexp)
(receive-result result))])
(match held-exp-list
[(struct skipped-step ())
;; don't render if before step was a skipped-step
(set! held-exp-list the-no-sexp)]
[(struct no-sexp ())
;; in this case, there was no "before" step, due
;; to unannotated code. In this case, we make the
;; optimistic guess that none of the finished
;; expressions were mutated. It would be somewhat
;; painful to do a better job, and the stepper
;; makes no guarantees in this case.
(send-result
(make-before-after-result
;; NB: this (... ...) IS UNRELATED TO
;; THE MACRO IDIOM OF THE SAME NAME
(list #`(... ...))
(append (reconstruct-all-completed) (reconstruct))
'normal
#f #f))]
[(struct held (held-exps held-step-was-app? held-source-pos))
(let*-values
([(step-kind)
(if (and held-step-was-app?
(eq? break-kind 'result-exp-break))
'user-application
'normal)]
[(left-exps right-exps)
;; write this later:
;; (identify-changed
;; (append held-finished-list held-exps)
;; (append new-finished-list reconstructed))
(values (append held-finished-list
held-exps)
(append (reconstruct-all-completed)
(reconstruct)))])
(send-result
(make-before-after-result
left-exps right-exps step-kind held-source-pos
(syntax-position (mark-source (car mark-list))))))]))]
[(double-break)
;; a double-break occurs at the beginning of a let's
;; evaluation.
(when (not (eq? held-exp-list no-sexp))
(when (not (eq? held-exp-list the-no-sexp))
(error
'break-reconstruction
"held-exp-list not empty when a double-break occurred"))
@ -273,16 +281,17 @@
[reconstruct-result
(r:reconstruct-double-break mark-list render-settings)]
[left-side (map (lambda (exp) (unwind exp render-settings))
(maybe-lift (car reconstruct-result) #f))]
(maybe-lift (car reconstruct-result) #f))]
[right-side (map (lambda (exp) (unwind exp render-settings))
(maybe-lift (cadr reconstruct-result) #t))])
(maybe-lift (cadr reconstruct-result) #t))])
;; add highlighting code as for other cases...
(receive-result
(make-before-after-result
(append new-finished-list left-side)
(append new-finished-list right-side)
'normal)))]
'normal
#f #f)))]
[(expr-finished-break)
(unless (not mark-list)
(error 'break
@ -294,39 +303,52 @@
(for-each (lambda (source/index/getter)
(apply add-to-finished source/index/getter))
returned-value-list)]
[else (error 'break "unknown label on break")]))))))
(define maybe-lift
(if (render-settings-lifting? render-settings)
lift
;; ... oh dear; model.ss should disable the double-break & late-let break when lifting is off.
(lambda (stx dont-care) (list stx))))
(define (step-through-expression expanded expand-next-expression)
(let* ([annotated (a:annotate expanded break show-lambdas-as-lambdas?
language-level)])
(parameterize ([test-engine:test-silence #t])
(eval-syntax annotated))
(expand-next-expression)))
(define (err-display-handler message exn)
(if (not (eq? held-exp-list no-sexp))
(begin
(receive-result
(make-before-error-result (append held-finished-list held-exp-list)
message))
(set! held-exp-list no-sexp))
(receive-result (make-error-result message))))
(program-expander
(lambda ()
(unless disable-error-handling
(error-display-handler err-display-handler)))
(lambda (expanded continue-thunk) ; iter
(r:reset-special-values)
(if (eof-object? expanded)
(define maybe-lift
(if (render-settings-lifting? render-settings)
lift
;; ... oh dear; model.ss should disable the double-break & late-let break when lifting is off.
(lambda (stx dont-care) (list stx))))
(define (step-through-expression expanded expand-next-expression)
(let* ([annotated (a:annotate expanded break show-lambdas-as-lambdas?
language-level)])
(parameterize ([test-engine:test-silence #t])
(eval-syntax annotated))
(expand-next-expression)))
(define (err-display-handler message exn)
(match held-exp-list
[(struct no-sexp ())
(receive-result (make-error-result message))]
[(struct held (exps dc source-pos))
(begin
(receive-result
(make-before-error-result (append held-finished-list exps)
message
#f
source-pos))
(set! held-exp-list the-no-sexp))]))
(program-expander
(lambda ()
(unless disable-error-handling
(error-display-handler err-display-handler)))
(lambda (expanded continue-thunk) ; iter
(r:reset-special-values)
(if (eof-object? expanded)
(begin
(receive-result (make-finished-stepping)))
(step-through-expression expanded continue-thunk))))))
(step-through-expression expanded continue-thunk)))))
; no-sexp is used to indicate no sexpression for display.
; e.g., on an error message, there's no sexp.
(define-struct no-sexp ())
(define the-no-sexp (make-no-sexp))
; skipped-step is used to indicate that the "before" step was skipped.
(define-struct skipped-step ())
(define the-skipped-step (make-skipped-step))

12
collects/stepper/private/mred-extensions.ss
View File

@ -3,10 +3,8 @@
mred
(prefix f: framework)
mzlib/pretty
"testing-shared.ss"
"shared.ss"
string-constants
mrlib/bitmap-label)
#;"testing-shared.ss"
"shared.ss")
(provide
foot-img/horizontal
@ -528,12 +526,6 @@
;; the bitmap to use in a vertical toolbar:
(define foot-img/vertical (make-object bitmap% (build-path (collection-path
"icons") "foot-up.png") 'png/mask))
;; stepper-bitmap : the image used for the stepper button
#;(define stepper-bitmap
(bitmap-label-maker
(string-constant stepper-button-label)
(build-path (collection-path "icons") "foot.png")))
;; testing code

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

@ -173,8 +173,8 @@
(define (varref-skip-step? varref)
(with-handlers ([exn:fail:contract:variable? (lambda (dc-exn) #f)])
(let ([val (lookup-binding mark-list varref)])
(equal? (syntax-object->interned-datum (recon-value val render-settings))
(syntax-object->interned-datum (case (stepper-syntax-property varref 'stepper-binding-type)
(equal? (syntax->interned-datum (recon-value val render-settings))
(syntax->interned-datum (case (stepper-syntax-property varref 'stepper-binding-type)
([let-bound]
(binding-lifted-name mark-list varref))
([non-lexical]
@ -497,7 +497,7 @@
(define re:beginner: (regexp "^beginner:(.*)$"))
;; eval-quoted : take a syntax-object that is an application of quote, and evaluate it (for display)
;; eval-quoted : take a syntax 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)
@ -878,7 +878,7 @@
"stepper:reconstruct: unknown object to reconstruct: ~a" (syntax->datum exp))]))))
; the main recursive reconstruction loop is in recon:
; recon : (syntax-object mark-list boolean -> syntax-object)
; recon : (syntax mark-list boolean -> syntax)
(define (recon so-far mark-list first)
(cond [(null? mark-list) ; now taken to indicate a callback:

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

@ -1,14 +1,10 @@
(module shared mzscheme
(require "my-macros.ss"
mzlib/contract
mzlib/list
mzlib/etc
mzlib/match
srfi/26
mzlib/class)
(require (for-syntax mzlib/list))
#lang scheme
(require "my-macros.ss"
srfi/26
scheme/class)
#;(require (for-syntax mzlib/list))
; CONTRACTS
@ -36,73 +32,75 @@
[arglist->ilist (-> arglist? any)]
[arglist-flatten (-> arglist? (listof identifier?))])
(provide
skipto/auto
in-closure-table
sublist
attach-info
transfer-info
arglist->ilist
arglist-flatten
binding-set-union
binding-set-pair-union
varref-set-union
varref-set-pair-union
varref-set-remove-bindings
binding-set-varref-set-intersect
step-result?
(struct before-after-result (pre-exps post-exps kind))
(struct before-error-result (pre-exps err-msg))
(struct error-result (err-msg))
(struct finished-stepping ())
list-take
list-partition
(struct closure-record (name mark constructor? lifted-index))
*unevaluated*
no-sexp
skipped-step
struct-flag
multiple-highlight
flatten-take
closure-table-put!
closure-table-lookup
get-lifted-var
get-arg-var
begin0-temp
zip
let-counter
syntax-pair-map
make-queue ; -> queue
queue-push ; queue val ->
queue-pop ; queue -> val
queue-length ; queue -> num
rebuild-stx ; datum syntax-object -> syntax-object
break-kind? ; predicate
varref-set? ; predicate
binding-set? ; predicate
; get-binding-name
; bogus-binding?
; get-lifted-gensym
; expr-read
; set-expr-read!
values-map
a...b ; a list of numbers from a to b
reset-profiling-table ; profiling info
get-set-pair-union-stats ; profiling info
re-intern-identifier
finished-xml-box-table
language-level->name
stepper-syntax-property
with-stepper-syntax-properties
(provide
skipto/auto
in-closure-table
sublist
attach-info
transfer-info
arglist->ilist
arglist-flatten
binding-set-union
binding-set-pair-union
varref-set-union
varref-set-pair-union
varref-set-remove-bindings
binding-set-varref-set-intersect
step-result?
(struct-out before-after-result)
(struct-out before-error-result)
(struct-out error-result)
(struct-out finished-stepping)
list-take
list-partition
(struct-out closure-record)
*unevaluated*
struct-flag
multiple-highlight
flatten-take
closure-table-put!
closure-table-lookup
get-lifted-var
get-arg-var
begin0-temp
zip
let-counter
syntax-pair-map
make-queue ; -> queue
queue-push ; queue val ->
queue-pop ; queue -> val
queue-length ; queue -> num
rebuild-stx ; datum syntax -> syntax
break-kind? ; predicate
varref-set? ; predicate
binding-set? ; predicate
; get-binding-name
; bogus-binding?
; get-lifted-gensym
; expr-read
; set-expr-read!
values-map
a...b ; a list of numbers from a to b
reset-profiling-table ; profiling info
get-set-pair-union-stats ; profiling info
re-intern-identifier
finished-xml-box-table
language-level->name
stepper-syntax-property
with-stepper-syntax-properties
skipto/cdr
skipto/cddr
skipto/first
skipto/second
skipto/third
skipto/fourth
skipto/firstarg
skipto/cdr
skipto/cddr
skipto/first
skipto/second
skipto/third
skipto/fourth
skipto/firstarg)
view-controller^
stepper-frame^
)
;; stepper-syntax-property : like syntax property, but adds properties to an association
;; list associated with the syntax property 'stepper-properties
@ -135,10 +133,10 @@
; or (make-error-result finished-exps err-msg)
; or (make-finished-result finished-exps)
(define-struct before-after-result (pre-exps post-exps kind) (make-inspector))
(define-struct before-error-result (pre-exps err-msg) (make-inspector))
(define-struct error-result (err-msg) (make-inspector))
(define-struct finished-stepping () (make-inspector))
(define-struct before-after-result (pre-exps post-exps kind pre-src post-src) #:transparent)
(define-struct before-error-result (pre-exps err-msg pre-src) #:transparent)
(define-struct error-result (err-msg) #:transparent)
(define-struct finished-stepping () #:transparent)
(define step-result? (or/c before-after-result? before-error-result? error-result? finished-stepping?))
@ -150,7 +148,7 @@
(define (create-bogus-binding name)
(let* ([gensymed-name (gensym name)]
[binding (datum->syntax-object #'here gensymed-name)])
[binding (datum->syntax #'here gensymed-name)])
binding))
; make-binding-source creates a pool of bindings, indexed by arbitrary keys. These bindings
@ -162,14 +160,14 @@
; make-gensym-source : (string -> (key -> binding))
(define (make-binding-source id-string binding-maker key-displayer)
(let ([assoc-table (make-hash-table 'weak)])
(let ([assoc-table (make-weak-hash)])
(lambda (key)
(let ([maybe-fetch (hash-table-get assoc-table key (lambda () #f))])
(let ([maybe-fetch (hash-ref assoc-table key (lambda () #f))])
(or maybe-fetch
(begin
(let* ([new-binding (binding-maker
(string-append id-string (key-displayer key) "-"))])
(hash-table-put! assoc-table key new-binding)
(hash-set! assoc-table key new-binding)
new-binding)))))))
@ -249,27 +247,21 @@
(define (next-lifted-symbol str)
(let ([index lifted-index])
(set! lifted-index (+ lifted-index 1))
(datum->syntax-object #'here (string->symbol (string-append str (number->string index))))))
(datum->syntax #'here (string->symbol (string-append str (number->string index))))))
(define get-lifted-var
(let ([assoc-table (box null)])
(lambda (stx)
(let ([maybe-fetch (weak-assoc-search assoc-table stx module-identifier=?)])
(let ([maybe-fetch (weak-assoc-search assoc-table stx free-identifier=?)])
(or maybe-fetch
(begin
(let* ([new-binding (next-lifted-symbol
(string-append "lifter-" (format "~a" (syntax-object->datum stx)) "-"))])
(string-append "lifter-" (format "~a" (syntax->datum stx)) "-"))])
(weak-assoc-add assoc-table stx new-binding)
new-binding)))))))
; gensyms needed by many modules:
; no-sexp is used to indicate no sexpression for display.
; e.g., on an error message, there's no sexp.
(define no-sexp (gensym "no-sexp-"))
; skipped-step is used to indicate that the "before" step was skipped.
(define skipped-step (gensym "skipped-step-"))
; multiple-highlight is used to indicate multiple highlighted expressions
(define multiple-highlight (gensym "multiple-highlight-"))
@ -306,16 +298,16 @@
(apply append (list-take n a-list)))
(define-values (closure-table-put! closure-table-lookup in-closure-table)
(let ([closure-table (make-hash-table 'weak)])
(let ([closure-table (make-weak-hash)])
(values
(lambda (key value)
(hash-table-put! closure-table key value)
(hash-set! closure-table key value)
key) ; this return allows a run-time-optimization
(lambda args ; key or key & failure-thunk
(apply hash-table-get closure-table args))
(apply hash-ref closure-table args))
(lambda (key)
(let/ec k
(hash-table-get closure-table key (lambda () (k #f)))
(hash-ref closure-table key (lambda () (k #f)))
#t)))))
;(begin (closure-table-put! 'foo 'bar)
@ -395,7 +387,7 @@
(length (unbox queue)))
(define (rebuild-stx new old)
(syntax-recertify (datum->syntax-object old new old old)
(syntax-recertify (datum->syntax old new old old)
old
(current-code-inspector)
#f))
@ -472,9 +464,9 @@
(define skipto/fourth `(syntax-e cdr cdr cdr car))
(define skipto/firstarg (append skipto/cdr skipto/second))
;; skipto/auto : syntax-object?
;; skipto/auto : syntax?
;; (symbols 'rebuild 'discard)
;; (syntax-object? . -> . syntax-object?)
;; (syntax? . -> . syntax?)
;; "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
@ -488,7 +480,7 @@
[else (transformer stx)]))
; small test case:
#;(display (equal? (syntax-object->datum
#;(display (equal? (syntax->datum
(skipto/auto (stepper-syntax-property #`(a #,(stepper-syntax-property #`(b c)
'stepper-skipto
'(syntax-e cdr car)))
@ -509,12 +501,12 @@
; binding-set-union: (listof BINDING-SET) -> BINDING-SET
; varref-set-union: (listof VARREF-SET) -> VARREF-SET
(define profiling-table (make-hash-table 'equal))
(define profiling-table (make-hash))
(define (reset-profiling-table)
(set! profiling-table (make-hash-table 'equal)))
(set! profiling-table (make-hash)))
(define (get-set-pair-union-stats)
(hash-table-map profiling-table (lambda (k v) (list k (unbox v)))))
(hash-map profiling-table (lambda (k v) (list k (unbox v)))))
;; test cases :
;; (profiling-table-incr 1 2)
@ -623,12 +615,10 @@
#`#,(string->symbol (symbol->string (syntax-e identifier))))
(provide/contract [syntax-object->hilite-datum ((syntax?) ; input
(boolean?) ; ignore-highlight?
. opt-> .
any/c)]) ; sexp with explicit tags
(provide/contract [syntax->hilite-datum
((syntax?) (#:ignore-highlight? boolean?) . ->* . any)]) ; sexp with explicit tags
;; syntax-object->hilite-datum : takes a syntax object with zero or more
;; syntax->hilite-datum : takes a syntax object with zero or more
;; subexpressions tagged with the 'stepper-highlight', 'stepper-xml-hint', and 'stepper-xml-value-hint' syntax-properties
;; and turns it into a datum, where expressions with the named
;; properties result in (hilite <datum>), (xml-box <datum>), (scheme-box <datum>) and (splice-box <datum>) rather than <datum>. It also
@ -637,52 +627,51 @@
;;
;; this procedure is useful in checking the output of the stepper.
(define syntax-object->hilite-datum
(opt-lambda (stx [ignore-highlight? #f])
(let ([datum (syntax-case stx ()
[(a . rest) (cons (syntax-object->hilite-datum #`a) (syntax-object->hilite-datum #`rest))]
[id
(identifier? stx)
(string->symbol (symbol->string (syntax-e stx)))]
[else (if (syntax? stx)
(syntax-object->datum stx)
stx)])])
(let* ([it (case (stepper-syntax-property stx 'stepper-xml-hint)
[(from-xml-box) `(xml-box ,datum)]
[(from-scheme-box) `(scheme-box ,datum)]
[(from-splice-box) `(splice-box ,datum)]
[else datum])]
[it (case (stepper-syntax-property stx 'stepper-xml-value-hint)
[(from-xml-box) `(xml-box-value ,it)]
[else it])]
[it (if (and (not ignore-highlight?)
(stepper-syntax-property stx 'stepper-highlight))
`(hilite ,it)
it)])
it))))
(define (syntax->hilite-datum stx #:ignore-highlight? [ignore-highlight? #f])
(let ([datum (syntax-case stx ()
[(a . rest) (cons (syntax->hilite-datum #`a) (syntax->hilite-datum #`rest))]
[id
(identifier? stx)
(string->symbol (symbol->string (syntax-e stx)))]
[else (if (syntax? stx)
(syntax->datum stx)
stx)])])
(let* ([it (case (stepper-syntax-property stx 'stepper-xml-hint)
[(from-xml-box) `(xml-box ,datum)]
[(from-scheme-box) `(scheme-box ,datum)]
[(from-splice-box) `(splice-box ,datum)]
[else datum])]
[it (case (stepper-syntax-property stx 'stepper-xml-value-hint)
[(from-xml-box) `(xml-box-value ,it)]
[else it])]
[it (if (and (not ignore-highlight?)
(stepper-syntax-property stx 'stepper-highlight))
`(hilite ,it)
it)])
it)))
;; finished-xml-box-table : this table tracks values that are the result
;; of evaluating xml boxes. These values should be rendered as xml boxes,
;; and not as simple lists.
(define finished-xml-box-table (make-hash-table 'weak))
(define finished-xml-box-table (make-weak-hash))
(provide/contract [syntax-object->interned-datum (syntax? ; input
(provide/contract [syntax->interned-datum (syntax? ; input
. -> .
any)]) ; sexp
;; syntax-object->interned-datum : like syntax-object->datum, except
;; syntax->interned-datum : like syntax->datum, except
;; that it re-interns all identifiers. Useful in checking whether
;; two sexps will have the same printed representation.
(define (syntax-object->interned-datum stx)
(define (syntax->interned-datum stx)
(syntax-case stx ()
[(a . rest) (cons (syntax-object->interned-datum #`a) (syntax-object->interned-datum #`rest))]
[(a . rest) (cons (syntax->interned-datum #`a) (syntax->interned-datum #`rest))]
[id
(identifier? stx)
(string->symbol (symbol->string (syntax-e stx)))]
[else (if (syntax? stx)
(syntax-object->datum stx)
(syntax->datum stx)
stx)]))
@ -727,7 +716,11 @@
(define (language-level->name language)
(car (last-pair (send language get-language-position))))
)
(define-signature view-controller^ (go))
(define-signature stepper-frame^ (stepper-frame%))
; test cases
@ -736,12 +729,12 @@
;(load (build-path (collection-path "tests" "mzscheme") "testing.ss"))
;
;(define (a sym)
; (syntax-object->datum (get-lifted-var sym)))
; (syntax->datum (get-lifted-var sym)))
;(define cd-stx
; (datum->syntax-object #f 'cd))
;(test 'lifter-ab-0 a (datum->syntax-object #f 'ab))
; (datum->syntax #f 'cd))
;(test 'lifter-ab-0 a (datum->syntax #f 'ab))
;(test 'lifter-cd-1 a cd-stx)
;(test 'lifter-ef-2 a (datum->syntax-object #f 'ef))
;(test 'lifter-ef-2 a (datum->syntax #f 'ef))
;(test 'lifter-cd-1 a cd-stx)
;
;(test '(a b c) map syntax-e (arglist->ilist #'(a b c)))
@ -786,5 +779,6 @@
;(test 'yes stepper-syntax-property (stepper-syntax-property #`13 'abc 'yes) 'abc)
;(test 'yes stepper-syntax-property (stepper-syntax-property (stepper-syntax-property #`13 'abc 'no) 'abc 'yes) 'abc)
;(test 'yes stepper-syntax-property (stepper-syntax-property (stepper-syntax-property #`13 'abc 'yes) 'def 'arg) 'abc)
;(test 13 syntax-object->datum (stepper-syntax-property (stepper-syntax-property #`13 'abc 'yes) 'def 'arg))
;(test 13 syntax->datum (stepper-syntax-property (stepper-syntax-property #`13 'abc 'yes) 'def 'arg))

7
collects/stepper/stepper+xml-tool.ss
View File

@ -2,7 +2,9 @@
(require mzlib/unit
drscheme/tool
"stepper-tool.ss"
"xml-tool.ss")
"xml-tool.ss"
"view-controller.ss"
"private/shared.ss")
(provide tool@)
@ -19,4 +21,5 @@
(import drscheme:tool^)
(export STEPPER-TOOL)
(link xml-tool@
(((STEPPER-TOOL : drscheme:tool-exports^)) stepper-tool@)))))
view-controller@
[((STEPPER-TOOL : drscheme:tool-exports^)) stepper-tool@]))))

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

File diff suppressed because it is too large Load Diff