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

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

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

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

@ -35,132 +35,134 @@
; double(x) : ERROR ; double(x) : ERROR
; late-let(x) : ERROR ; late-let(x) : ERROR
#lang scheme/base
(module model scheme/base (require scheme/contract
(require scheme/contract scheme/match
scheme/match scheme/class
scheme/class scheme/list
scheme/list (prefix-in a: "annotate.ss")
(prefix-in a: "annotate.ss") (prefix-in r: "reconstruct.ss")
(prefix-in r: "reconstruct.ss") "shared.ss"
"shared.ss" "marks.ss"
"marks.ss" "model-settings.ss"
"model-settings.ss" "macro-unwind.ss"
"macro-unwind.ss" "lifting.ss"
"lifting.ss" (prefix-in test-engine: test-engine/scheme-tests)
(prefix-in test-engine: test-engine/scheme-tests) #;(file "/Users/clements/clements/scheme-scraps/eli-debug.ss")
#;(file "/Users/clements/clements/scheme-scraps/eli-debug.ss") ;; for breakpoint display
;; for breakpoint display ;; (commented out to allow nightly testing)
;; (commented out to allow nightly testing) #;"display-break-stuff.ss")
#;"display-break-stuff.ss")
(define program-expander-contract (define program-expander-contract
((-> void?) ; init ((-> void?) ; init
((or/c eof-object? syntax? (cons/c string? any/c)) (-> void?) ((or/c eof-object? syntax? (cons/c string? any/c)) (-> void?)
. -> . void?) ; iter . -> . void?) ; iter
. -> . . -> .
void?)) void?))
(provide/contract (provide/contract
[go (program-expander-contract ; program-expander [go (program-expander-contract ; program-expander
(step-result? . -> . void?) ; receive-result (step-result? . -> . void?) ; receive-result
(or/c render-settings? false/c) ; render-settings (or/c render-settings? false/c) ; render-settings
boolean? ; track-inferred-names? boolean? ; track-inferred-names?
(or/c object? (symbols 'testing)) ;; FIXME: can do better: subclass of language% ; the language level (or/c object? (symbols 'testing)) ;; FIXME: can do better: subclass of language% ; the language level
(procedure? . -> . void?) ; run-on-drscheme-side (procedure? . -> . void?) ; run-on-drscheme-side
boolean? ; disable-error-handling (to allow debugging) boolean? ; disable-error-handling (to allow debugging)
. -> . . -> .
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 (define (go program-expander receive-result render-settings
show-lambdas-as-lambdas? language-level run-on-drscheme-side show-lambdas-as-lambdas? language-level run-on-drscheme-side
disable-error-handling) disable-error-handling)
;; finished-exps: ;; finished-exps:
;; (listof (list/c syntax-object? (or/c number? false?)( -> any))) ;; (listof (list/c syntax-object? (or/c number? false?)( -> any)))
;; because of mutation, these cannot be fixed renderings, but must be ;; because of mutation, these cannot be fixed renderings, but must be
;; re-rendered at each step. ;; re-rendered at each step.
(define finished-exps null) (define finished-exps null)
(define/contract add-to-finished (define/contract add-to-finished
((-> syntax?) (or/c (listof natural-number/c) false/c) (-> any) ((-> syntax?) (or/c (listof natural-number/c) false/c) (-> any)
. -> . void?) . -> . void?)
(lambda (exp-thunk lifting-indices getter) (lambda (exp-thunk lifting-indices getter)
(set! finished-exps (set! finished-exps
(append finished-exps (append finished-exps
(list (list exp-thunk lifting-indices getter)))))) (list (list exp-thunk lifting-indices getter))))))
;; the "held" variables are used to store the "before" step. ;; the "held" variables are used to store the "before" step.
(define held-exp-list no-sexp) (define held-exp-list the-no-sexp)
(define held-step-was-app? #f)
(define held-finished-list null)
;; highlight-mutated-expressions : (define-struct held (exps was-app? source-pos))
;; ((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 held-finished-list null)
(define (highlight-mutated-expressions lefts rights)
(if (or (null? lefts) (null? rights)) ;; 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) (list lefts rights)
(let ([left-car (car lefts)] (let ([left-car (car lefts)]
[right-car (car rights)]) [right-car (car rights)])
(if (eq? (syntax-property left-car 'user-source) (if (eq? (syntax-property left-car 'user-source)
(syntax-property right-car 'user-source)) (syntax-property right-car 'user-source))
(let ([highlights-added (let ([highlights-added
(highlight-mutated-expression left-car right-car)] (highlight-mutated-expression left-car right-car)]
[rest (highlight-mutated-expressions [rest (highlight-mutated-expressions
(cdr lefts) (cdr rights))]) (cdr lefts) (cdr rights))])
(cons (cons (car highlights-added) (car rest)) (cons (cons (car highlights-added) (car rest))
(cons (cadr highlights-added) (cadr rest)))))))) (cons (cadr highlights-added) (cadr rest))))))))
;; highlight-mutated-expression: syntax? syntax? -> syntax? ;; highlight-mutated-expression: syntax? syntax? -> syntax?
;; given two expressions, highlight 'em both if they differ at all. ;; given two expressions, highlight 'em both if they differ at all.
;; notes: wanted to use simple "eq?" test... but this will fail when a ;; 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. ;; 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 ;; 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 ;; the highlighting follows from the reductions but can't obviously be
;; deduced from them. ;; deduced from them.
#; #;
(define (highlight-mutated-expression left right) (define (highlight-mutated-expression left right)
(cond (cond
;; if either one is already highlighted, leave them alone. ;; if either one is already highlighted, leave them alone.
[(or (stepper-syntax-property left 'stepper-highlight) [(or (stepper-syntax-property left 'stepper-highlight)
(stepper-syntax-property right 'stepper-highlight)) (stepper-syntax-property right 'stepper-highlight))
(list left right)] (list left right)]
;; first pass: highlight if not eq?. Should be broken for local-bound ;; first pass: highlight if not eq?. Should be broken for local-bound
;; things as they pass into permanence. ;; things as they pass into permanence.
[(eq? left right) [(eq? left right)
(list left right)] (list left right)]
[else (list (stepper-syntax-property left 'stepper-highlight) [else (list (stepper-syntax-property left 'stepper-highlight)
(stepper-syntax-property right 'stepper-highlight))])) (stepper-syntax-property right 'stepper-highlight))]))
;; mutated on receipt of a break, used in displaying breakpoint stuff. ;; mutated on receipt of a break, used in displaying breakpoint stuff.
(define steps-received 0) (define steps-received 0)
(define break (define break
(lambda (mark-set break-kind [returned-value-list #f]) (lambda (mark-set break-kind [returned-value-list #f])
(set! steps-received (+ steps-received 1)) (set! steps-received (+ steps-received 1))
;; have to be careful else this won't be looked up right away: ;; have to be careful else this won't be looked up right away:
;; (commented out to allow nightly tests to proceed, 2007-09-04 ;; (commented out to allow nightly tests to proceed, 2007-09-04
#;(when (getenv "PLTSTEPPERUNSAFE") #;(when (getenv "PLTSTEPPERUNSAFE")
(let ([steps-received/current steps-received]) (let ([steps-received/current steps-received])
(run-on-drscheme-side (run-on-drscheme-side
(lambda () (lambda ()
@ -168,31 +170,31 @@
steps-received/current steps-received/current
mark-set break-kind returned-value-list))))) mark-set break-kind returned-value-list)))))
(let* ([mark-list (and mark-set (extract-mark-list mark-set))]) (let* ([mark-list (and mark-set (extract-mark-list mark-set))])
(define (reconstruct-all-completed) (define (reconstruct-all-completed)
(filter-map (filter-map
(match-lambda (match-lambda
[(list source-thunk lifting-indices getter) [(list source-thunk lifting-indices getter)
(let ([source (source-thunk)]) (let ([source (source-thunk)])
(if (r:hide-completed? source) (if (r:hide-completed? source)
#f #f
(match (r:reconstruct-completed (match (r:reconstruct-completed
source lifting-indices source lifting-indices
getter render-settings) getter render-settings)
[(vector exp #f) (unwind exp render-settings)] [(vector exp #f) (unwind exp render-settings)]
[(vector exp #t) exp])))]) [(vector exp #t) exp])))])
finished-exps)) finished-exps))
#;(>>> break-kind) #;(>>> break-kind)
#;(fprintf (current-error-port) "break called with break-kind: ~a ..." break-kind) #;(fprintf (current-error-port) "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
#;(fprintf (current-error-port) " but it was skipped!\n") #;(fprintf (current-error-port) " but it was skipped!\n")
(when (or (eq? break-kind 'normal-break) (when (or (eq? break-kind 'normal-break)
;; not sure about this... ;; not sure about this...
(eq? break-kind 'nomal-break/values)) (eq? break-kind 'nomal-break/values))
(set! held-exp-list skipped-step))) (set! held-exp-list the-skipped-step)))
(begin (begin
#;(fprintf (current-error-port) "and it wasn't skipped.\n") #;(fprintf (current-error-port) "and it wasn't skipped.\n")
@ -205,67 +207,73 @@
"broken invariant: normal-break can't have returned values")) "broken invariant: normal-break can't have returned values"))
(set! held-finished-list (reconstruct-all-completed)) (set! held-finished-list (reconstruct-all-completed))
(set! held-exp-list (set! held-exp-list
(map (lambda (exp) (make-held
(unwind exp render-settings)) (map (lambda (exp)
(maybe-lift (unwind exp render-settings))
(r:reconstruct-left-side (maybe-lift
mark-list returned-value-list render-settings) (r:reconstruct-left-side
#f))) mark-list returned-value-list render-settings)
(set! held-step-was-app? (r:step-was-app? mark-list)))] #f))
(r:step-was-app? mark-list)
(syntax-position (mark-source (car mark-list))))))]
[(result-exp-break result-value-break) [(result-exp-break result-value-break)
(if (eq? held-exp-list skipped-step) (let ([reconstruct
;; don't render if before step was a skipped-step (lambda ()
(set! held-exp-list no-sexp) (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)))])
(let* ([new-finished-list (reconstruct-all-completed)] (send-result
[reconstructed (make-before-after-result
(map (lambda (exp) left-exps right-exps step-kind held-source-pos
(unwind exp render-settings)) (syntax-position (mark-source (car mark-list))))))]))]
(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)))]
[(double-break) [(double-break)
;; a double-break occurs at the beginning of a let's ;; a double-break occurs at the beginning of a let's
;; evaluation. ;; evaluation.
(when (not (eq? held-exp-list no-sexp)) (when (not (eq? held-exp-list the-no-sexp))
(error (error
'break-reconstruction 'break-reconstruction
"held-exp-list not empty when a double-break occurred")) "held-exp-list not empty when a double-break occurred"))
@ -273,15 +281,16 @@
[reconstruct-result [reconstruct-result
(r:reconstruct-double-break mark-list render-settings)] (r:reconstruct-double-break mark-list render-settings)]
[left-side (map (lambda (exp) (unwind exp 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)) [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... ;; add highlighting code as for other cases...
(receive-result (receive-result
(make-before-after-result (make-before-after-result
(append new-finished-list left-side) (append new-finished-list left-side)
(append new-finished-list right-side) (append new-finished-list right-side)
'normal)))] 'normal
#f #f)))]
[(expr-finished-break) [(expr-finished-break)
(unless (not mark-list) (unless (not mark-list)
@ -297,36 +306,49 @@
[else (error 'break "unknown label on break")])))))) [else (error 'break "unknown label on break")]))))))
(define maybe-lift (define maybe-lift
(if (render-settings-lifting? render-settings) (if (render-settings-lifting? render-settings)
lift lift
;; ... oh dear; model.ss should disable the double-break & late-let break when lifting is off. ;; ... oh dear; model.ss should disable the double-break & late-let break when lifting is off.
(lambda (stx dont-care) (list stx)))) (lambda (stx dont-care) (list stx))))
(define (step-through-expression expanded expand-next-expression) (define (step-through-expression expanded expand-next-expression)
(let* ([annotated (a:annotate expanded break show-lambdas-as-lambdas? (let* ([annotated (a:annotate expanded break show-lambdas-as-lambdas?
language-level)]) language-level)])
(parameterize ([test-engine:test-silence #t]) (parameterize ([test-engine:test-silence #t])
(eval-syntax annotated)) (eval-syntax annotated))
(expand-next-expression))) (expand-next-expression)))
(define (err-display-handler message exn) (define (err-display-handler message exn)
(if (not (eq? held-exp-list no-sexp)) (match held-exp-list
(begin [(struct no-sexp ())
(receive-result (receive-result (make-error-result message))]
(make-before-error-result (append held-finished-list held-exp-list) [(struct held (exps dc source-pos))
message)) (begin
(set! held-exp-list no-sexp)) (receive-result
(receive-result (make-error-result message)))) (make-before-error-result (append held-finished-list exps)
message
#f
source-pos))
(set! held-exp-list the-no-sexp))]))
(program-expander (program-expander
(lambda () (lambda ()
(unless disable-error-handling (unless disable-error-handling
(error-display-handler err-display-handler))) (error-display-handler err-display-handler)))
(lambda (expanded continue-thunk) ; iter (lambda (expanded continue-thunk) ; iter
(r:reset-special-values) (r:reset-special-values)
(if (eof-object? expanded) (if (eof-object? expanded)
(begin (begin
(receive-result (make-finished-stepping))) (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 mred
(prefix f: framework) (prefix f: framework)
mzlib/pretty mzlib/pretty
"testing-shared.ss" #;"testing-shared.ss"
"shared.ss" "shared.ss")
string-constants
mrlib/bitmap-label)
(provide (provide
foot-img/horizontal foot-img/horizontal
@ -529,12 +527,6 @@
(define foot-img/vertical (make-object bitmap% (build-path (collection-path (define foot-img/vertical (make-object bitmap% (build-path (collection-path
"icons") "foot-up.png") 'png/mask)) "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 ;; testing code

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

@ -173,8 +173,8 @@
(define (varref-skip-step? varref) (define (varref-skip-step? varref)
(with-handlers ([exn:fail:contract:variable? (lambda (dc-exn) #f)]) (with-handlers ([exn:fail:contract:variable? (lambda (dc-exn) #f)])
(let ([val (lookup-binding mark-list varref)]) (let ([val (lookup-binding mark-list varref)])
(equal? (syntax-object->interned-datum (recon-value val render-settings)) (equal? (syntax->interned-datum (recon-value val render-settings))
(syntax-object->interned-datum (case (stepper-syntax-property varref 'stepper-binding-type) (syntax->interned-datum (case (stepper-syntax-property varref 'stepper-binding-type)
([let-bound] ([let-bound]
(binding-lifted-name mark-list varref)) (binding-lifted-name mark-list varref))
([non-lexical] ([non-lexical]
@ -497,7 +497,7 @@
(define re:beginner: (regexp "^beginner:(.*)$")) (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. ;; Frankly, I'm worried by the fact that this isn't done at expansion time.
(define (eval-quoted stx) (define (eval-quoted stx)
@ -878,7 +878,7 @@
"stepper:reconstruct: unknown object to reconstruct: ~a" (syntax->datum exp))])))) "stepper:reconstruct: unknown object to reconstruct: ~a" (syntax->datum exp))]))))
; the main recursive reconstruction loop is in recon: ; 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) (define (recon so-far mark-list first)
(cond [(null? mark-list) ; now taken to indicate a callback: (cond [(null? mark-list) ; now taken to indicate a callback:

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

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

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

File diff suppressed because it is too large Load Diff