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

changed syntax-property to stepper-syntax-property

Browse Source 
svn: r4762
This commit is contained in:
John Clements 2006-11-03 18:15:16 +00:00
parent 0d7c25bbb8
commit 96d857dcd0
11 changed files with 152 additions and 149 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

48
collects/stepper/private/annotate.ss
View File

@ -115,14 +115,14 @@
; it flags if's which could come from cond's, it labels the begins in conds with 'stepper-skip annotations ; it flags if's which could come from cond's, it labels the begins in conds with 'stepper-skip annotations
; label-var-types returns a syntax object which is identical to the original except that the variable references are labeled ; label-var-types returns a syntax object which is identical to the original except that the variable references are labeled
; with the syntax-property 'stepper-binding-type, which is set to either let-bound, lambda-bound, or non-lexical. ; with the stepper-syntax-property 'stepper-binding-type, which is set to either let-bound, lambda-bound, or non-lexical.
(define (top-level-rewrite stx) (define (top-level-rewrite stx)
(let loop ([stx stx] (let loop ([stx stx]
[let-bound-bindings null] [let-bound-bindings null]
[cond-test (lx #f)]) [cond-test (lx #f)])
(if (or (syntax-property stx 'stepper-skip-completely) (if (or (stepper-syntax-property stx 'stepper-skip-completely)
(syntax-property stx 'stepper-define-struct-hint)) (stepper-syntax-property stx 'stepper-define-struct-hint))
stx stx
(let* ([recur-regular (let* ([recur-regular
(lambda (stx) (lambda (stx)
@ -162,7 +162,7 @@
[rebuild-if [rebuild-if
(lambda (new-cond-test) (lambda (new-cond-test)
(let* ([new-then (recur-regular (syntax then))] (let* ([new-then (recur-regular (syntax then))]
[rebuilt (syntax-property [rebuilt (stepper-syntax-property
(rebuild-stx `(if ,(recur-regular (syntax test)) (rebuild-stx `(if ,(recur-regular (syntax test))
,new-then ,new-then
,(recur-in-cond (syntax else-stx) new-cond-test)) ,(recur-in-cond (syntax else-stx) new-cond-test))
@ -170,8 +170,8 @@
'stepper-hint 'stepper-hint
'comes-from-cond)]) 'comes-from-cond)])
; move the stepper-else mark to the if, if it's present: ; move the stepper-else mark to the if, if it's present:
(if (syntax-property (syntax test) 'stepper-else) (if (stepper-syntax-property (syntax test) 'stepper-else)
(syntax-property rebuilt 'stepper-else #t) (stepper-syntax-property rebuilt 'stepper-else #t)
rebuilt)))]) rebuilt)))])
(cond [(cond-test stx) ; continuing an existing 'cond' (cond [(cond-test stx) ; continuing an existing 'cond'
(rebuild-if cond-test)] (rebuild-if cond-test)]
@ -183,17 +183,17 @@
(rebuild-stx `(if ,@(map recur-regular (list (syntax test) (syntax (begin then)) (syntax else-stx)))) stx)]))] (rebuild-stx `(if ,@(map recur-regular (list (syntax test) (syntax (begin then)) (syntax else-stx)))) stx)]))]
[(begin body) ; else clauses of conds; ALWAYS AN ERROR CALL [(begin body) ; else clauses of conds; ALWAYS AN ERROR CALL
(cond-test stx) (cond-test stx)
(syntax-property stx 'stepper-skip-completely #t)] (stepper-syntax-property stx 'stepper-skip-completely #t)]
; wrapper on a local. This is necessary because teach.ss expands local into a trivial let wrapping a bunch of ; wrapper on a local. This is necessary because teach.ss expands local into a trivial let wrapping a bunch of
; internal defines, and therefore the letrec-values on which I want to hang the 'stepper-hint doesn't yet ; internal defines, and therefore the letrec-values on which I want to hang the 'stepper-hint doesn't yet
; exist. So we patch it up after expansion. And we discard the outer 'let' at the same time. ; exist. So we patch it up after expansion. And we discard the outer 'let' at the same time.
[(let-values () expansion-of-local) [(let-values () expansion-of-local)
(eq? (syntax-property stx 'stepper-hint) 'comes-from-local) (eq? (stepper-syntax-property stx 'stepper-hint) 'comes-from-local)
(syntax-case #`expansion-of-local (letrec-values) (syntax-case #`expansion-of-local (letrec-values)
[(letrec-values (bogus-clause clause ...) . bodies) [(letrec-values (bogus-clause clause ...) . bodies)
(recur-regular (recur-regular
(syntax-property #`(letrec-values (clause ...) . bodies) 'stepper-hint 'comes-from-local))] (stepper-syntax-property #`(letrec-values (clause ...) . bodies) 'stepper-hint 'comes-from-local))]
[else (error 'top-level-rewrite "expected a letrec-values inside a local, given: ~e" [else (error 'top-level-rewrite "expected a letrec-values inside a local, given: ~e"
(syntax-object->datum #`expansion-of-local))])] (syntax-object->datum #`expansion-of-local))])]
@ -204,7 +204,7 @@
; varref : ; varref :
[var [var
(identifier? (syntax var)) (identifier? (syntax var))
(syntax-property (stepper-syntax-property
(syntax var) (syntax var)
'stepper-binding-type 'stepper-binding-type
(if (eq? (identifier-binding (syntax var)) 'lexical) (if (eq? (identifier-binding (syntax var)) 'lexical)
@ -220,8 +220,8 @@
(rebuild-stx (syntax-pair-map content recur-regular) stx) (rebuild-stx (syntax-pair-map content recur-regular) stx)
stx))])]) stx))])])
(if (eq? (syntax-property stx 'stepper-xml-hint) 'from-xml-box) (if (eq? (stepper-syntax-property stx 'stepper-xml-hint) 'from-xml-box)
(syntax-property #`(#,put-into-xml-table #,rewritten) (stepper-syntax-property #`(#,put-into-xml-table #,rewritten)
'stepper-skipto 'stepper-skipto
(list syntax-e cdr car)) (list syntax-e cdr car))
(syntax-recertify rewritten stx (current-code-inspector) #f)))))) (syntax-recertify rewritten stx (current-code-inspector) #f))))))
@ -383,9 +383,9 @@
. -> . (vector/p syntax? binding-set?)) . -> . (vector/p syntax? binding-set?))
(lambda (exp tail-bound pre-break? procedure-name-info) (lambda (exp tail-bound pre-break? procedure-name-info)
(cond [(syntax-property exp 'stepper-skipto) (cond [(stepper-syntax-property exp 'stepper-skipto)
(let* ([free-vars-captured #f] ; this will be set!'ed (let* ([free-vars-captured #f] ; this will be set!'ed
;[dont-care (printf "expr: ~a\nskipto: ~a\n" expr (syntax-property expr 'stepper-skipto))] ;[dont-care (printf "expr: ~a\nskipto: ~a\n" expr (stepper-syntax-property expr 'stepper-skipto))]
; WARNING! I depend on the order of evaluation in application arguments here: ; WARNING! I depend on the order of evaluation in application arguments here:
[annotated (skipto/auto [annotated (skipto/auto
exp exp
@ -399,7 +399,7 @@
annotated) annotated)
free-vars-captured))] free-vars-captured))]
[(syntax-property exp 'stepper-skip-completely) [(stepper-syntax-property exp 'stepper-skip-completely)
(2vals (wcm-wrap 13 exp) null)] (2vals (wcm-wrap 13 exp) null)]
[else [else
@ -443,7 +443,7 @@
'let-body 'let-body
#t))] #t))]
[make-debug-info-fake-exp (lambda (exp free-bindings) [make-debug-info-fake-exp (lambda (exp free-bindings)
(make-debug-info (syntax-property exp 'stepper-fake-exp #t) (make-debug-info (stepper-syntax-property exp 'stepper-fake-exp #t)
tail-bound free-bindings 'none #t))] tail-bound free-bindings 'none #t))]
[outer-wcm-wrap (if pre-break? [outer-wcm-wrap (if pre-break?
@ -476,7 +476,7 @@
; wrap bodies in explicit begin if more than 1 user-introduced (non-skipped) bodies ; wrap bodies in explicit begin if more than 1 user-introduced (non-skipped) bodies
; NB: CAN'T HAPPEN in beginner up through int/lambda ; NB: CAN'T HAPPEN in beginner up through int/lambda
(if (> (length (filter (lambda (clause) (if (> (length (filter (lambda (clause)
(not (syntax-property clause 'stepper-skip-completely))) (not (stepper-syntax-property clause 'stepper-skip-completely)))
(syntax->list (syntax bodies)))) 1) (syntax->list (syntax bodies)))) 1)
(lambda-body-recur (syntax (begin . bodies))) (lambda-body-recur (syntax (begin . bodies)))
(let*-2vals ([(annotated-bodies free-var-sets) (let*-2vals ([(annotated-bodies free-var-sets)
@ -728,7 +728,7 @@
(varref-break-wrap) (varref-break-wrap)
(varref-no-break-wrap)))]) (varref-no-break-wrap)))])
(2vals (2vals
(case (syntax-property var 'stepper-binding-type) (case (stepper-syntax-property var 'stepper-binding-type)
((lambda-bound macro-bound) (varref-no-break-wrap)) ((lambda-bound macro-bound) (varref-no-break-wrap))
((let-bound) (varref-break-wrap)) ((let-bound) (varref-break-wrap))
((non-lexical) ;; is it from this module or not? ((non-lexical) ;; is it from this module or not?
@ -836,7 +836,7 @@
;; more efficient, but disabled because of difficulties in threading it through the ;; more efficient, but disabled because of difficulties in threading it through the
;; reconstruction. Easier to undo in the macro-unwind phase. ;; reconstruction. Easier to undo in the macro-unwind phase.
#;[(let-values () . bodies-stx) #;[(let-values () . bodies-stx)
(eq? (syntax-property exp 'stepper-hint) 'comes-from-begin) (eq? (stepper-syntax-property exp 'stepper-hint) 'comes-from-begin)
(begin-abstraction (syntax->list #`bodies-stx))] (begin-abstraction (syntax->list #`bodies-stx))]
[(let-values . _) [(let-values . _)
@ -976,7 +976,7 @@
[free-varrefs (varref-set-union free-varrefs-terms)]) [free-varrefs (varref-set-union free-varrefs-terms)])
(2vals (2vals
(let* ([arg-temps (build-list (length annotated-terms) get-arg-var)] (let* ([arg-temps (build-list (length annotated-terms) get-arg-var)]
[tagged-arg-temps (map (lambda (var) (syntax-property var 'stepper-binding-type 'stepper-temp)) [tagged-arg-temps (map (lambda (var) (stepper-syntax-property var 'stepper-binding-type 'stepper-temp))
arg-temps)] arg-temps)]
[let-clauses #`((#,tagged-arg-temps [let-clauses #`((#,tagged-arg-temps
(values #,@(map (lambda (_) *unevaluated*) tagged-arg-temps))))] (values #,@(map (lambda (_) *unevaluated*) tagged-arg-temps))))]
@ -1090,11 +1090,11 @@
(define/contract annotate/module-top-level (define/contract annotate/module-top-level
(syntax? . -> . syntax?) (syntax? . -> . syntax?)
(lambda (exp) (lambda (exp)
(cond [(syntax-property exp 'stepper-skip-completely) exp] (cond [(stepper-syntax-property exp 'stepper-skip-completely) exp]
[(syntax-property exp 'stepper-define-struct-hint) [(stepper-syntax-property exp 'stepper-define-struct-hint)
#`(begin #,exp #`(begin #,exp
(#,(make-define-struct-break exp)))] (#,(make-define-struct-break exp)))]
[(syntax-property exp 'stepper-skipto) [(stepper-syntax-property exp 'stepper-skipto)
(skipto/auto exp 'rebuild annotate/module-top-level)] (skipto/auto exp 'rebuild annotate/module-top-level)]
[else [else
(syntax-case exp (#%app call-with-values define-values define-syntaxes require require-for-syntax provide begin lambda) (syntax-case exp (#%app call-with-values define-values define-syntaxes require require-for-syntax provide begin lambda)
@ -1127,7 +1127,7 @@
(call-with-values (lambda () vals) (call-with-values (lambda () vals)
print-values))))] print-values))))]
[any [any
(syntax-property exp 'stepper-test-suite-hint) (stepper-syntax-property exp 'stepper-test-suite-hint)
(top-level-annotate/inner (top-level-rewrite exp) exp #f)] (top-level-annotate/inner (top-level-rewrite exp) exp #f)]
[else [else
(top-level-annotate/inner (top-level-rewrite exp) exp #f) (top-level-annotate/inner (top-level-rewrite exp) exp #f)

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

@ -91,7 +91,7 @@
(expr-iterator stx context-so-far)]))) (expr-iterator stx context-so-far)])))
(define (expr-iterator stx context-so-far) (define (expr-iterator stx context-so-far)
(when (syntax-property stx 'stepper-highlight) (when (stepper-syntax-property stx 'stepper-highlight)
(success-escape (2vals context-so-far stx))) (success-escape (2vals context-so-far stx)))
(let* ([try (make-try-all-subexprs stx 'expr context-so-far)] (let* ([try (make-try-all-subexprs stx 'expr context-so-far)]
[try-exprs (lambda (index-mangler exprs) (try index-mangler (map (lambda (expr) (list expr-iterator expr)) [try-exprs (lambda (index-mangler exprs) (try index-mangler (map (lambda (expr) (list expr-iterator expr))
@ -243,9 +243,9 @@
(lift-helper highlighted #f null) (lift-helper highlighted #f null)
(values null highlighted))]) (values null highlighted))])
(let loop ([ctx-list ctx-list] (let loop ([ctx-list ctx-list]
[so-far-defs (map (lambda (x) (syntax-property x 'stepper-highlight #t)) [so-far-defs (map (lambda (x) (stepper-syntax-property x 'stepper-highlight #t))
highlighted-defs)] highlighted-defs)]
[body (syntax-property highlighted-body 'stepper-highlight #t)]) [body (stepper-syntax-property highlighted-body 'stepper-highlight #t)])
(if (null? ctx-list) (if (null? ctx-list)
(append so-far-defs (list body)) (append so-far-defs (list body))
(let*-values ([(ctx) (car ctx-list)] (let*-values ([(ctx) (car ctx-list)]
@ -280,7 +280,7 @@
[else (error 'lift-helper "let or letrec does not have expected shape: ~v\n" (syntax-object->datum stx))]))]) [else (error 'lift-helper "let or letrec does not have expected shape: ~v\n" (syntax-object->datum stx))]))])
(kernel:kernel-syntax-case stx #f (kernel:kernel-syntax-case stx #f
[(let-values . dc) [(let-values . dc)
(not (eq? (syntax-property stx 'user-stepper-hint) 'comes-from-or)) (not (eq? (stepper-syntax-property stx 'stepper-hint) 'comes-from-or))
(lift)] (lift)]
[(letrec-values . dc) [(letrec-values . dc)
(lift)] (lift)]

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

@ -52,7 +52,7 @@
(kernel:kernel-syntax-case stx #f (kernel:kernel-syntax-case stx #f
[id [id
(identifier? stx) (identifier? stx)
(or (syntax-property stx 'stepper-lifted-name) (or (stepper-syntax-property stx 'stepper-lifted-name)
stx)] stx)]
[(define-values dc ...) [(define-values dc ...)
(unwind-define stx settings)] (unwind-define stx settings)]
@ -65,7 +65,7 @@
[(letrec-values . rest) [(letrec-values . rest)
(unwind-mz-let stx settings)] (unwind-mz-let stx settings)]
[(set! var rhs) [(set! var rhs)
(with-syntax ([unwound-var (or (syntax-property (with-syntax ([unwound-var (or (stepper-syntax-property
#`var 'stepper-lifted-name) #`var 'stepper-lifted-name)
#`var)] #`var)]
[unwound-body (unwind #`rhs settings)]) [unwound-body (unwind #`rhs settings)])
@ -74,7 +74,7 @@
(define (unwind stx settings) (define (unwind stx settings)
(transfer-info (transfer-info
(let ([hint (syntax-property stx 'user-stepper-hint)]) (let ([hint (stepper-syntax-property stx 'stepper-hint)])
(if (procedure? hint) (if (procedure? hint)
(hint stx (lambda (stx) (recur-on-pieces stx settings))) (hint stx (lambda (stx) (recur-on-pieces stx settings)))
(let ([process (case hint (let ([process (case hint
@ -89,8 +89,8 @@
stx)) stx))
(define (transfer-highlight from to) (define (transfer-highlight from to)
(if (syntax-property from 'stepper-highlight) (if (stepper-syntax-property from 'stepper-highlight)
(syntax-property to 'stepper-highlight #t) (stepper-syntax-property to 'stepper-highlight #t)
to)) to))
(define (unwind-recur stx settings) (define (unwind-recur stx settings)
@ -118,29 +118,29 @@
"reconstruct fails on multiple-values define: ~v\n" "reconstruct fails on multiple-values define: ~v\n"
(syntax-object->datum stx))) (syntax-object->datum stx)))
(let* ([printed-name (let* ([printed-name
(or (syntax-property #`name 'stepper-lifted-name) (or (stepper-syntax-property #`name 'stepper-lifted-name)
(syntax-property #'name 'stepper-orig-name) (stepper-syntax-property #'name 'stepper-orig-name)
#'name)] #'name)]
[unwound-body (unwind #'body settings)] [unwound-body (unwind #'body settings)]
;; see notes in internal-docs.txt ;; see notes in internal-docs.txt
[define-type (syntax-property [define-type (stepper-syntax-property
unwound-body 'user-stepper-define-type)]) unwound-body 'stepper-define-type)])
(if define-type (if define-type
(kernel:kernel-syntax-case unwound-body #f (kernel:kernel-syntax-case unwound-body #f
[(lambda arglist lam-body ...) [(lambda arglist lam-body ...)
(case define-type (case define-type
[(shortened-proc-define) [(shortened-proc-define)
(let ([proc-define-name (let ([proc-define-name
(syntax-property (stepper-syntax-property
unwound-body unwound-body
'user-stepper-proc-define-name)]) 'stepper-proc-define-name)])
(if (or (module-identifier=? proc-define-name (if (or (module-identifier=? proc-define-name
#'name) #'name)
(and (syntax-property #'name (and (stepper-syntax-property #'name
'stepper-orig-name) 'stepper-orig-name)
(module-identifier=? (module-identifier=?
proc-define-name proc-define-name
(syntax-property (stepper-syntax-property
#'name 'stepper-orig-name)))) #'name 'stepper-orig-name))))
#`(define (#,printed-name . arglist) #`(define (#,printed-name . arglist)
lam-body ...) lam-body ...)
@ -149,7 +149,7 @@
[(lambda-define) [(lambda-define)
#`(define #,printed-name #,unwound-body)] #`(define #,printed-name #,unwound-body)]
[else (error 'unwind-define [else (error 'unwind-define
"unknown value for syntax property 'user-stepper-define-type: ~e" "unknown value for syntax property 'stepper-define-type: ~e"
define-type)])] define-type)])]
[else (error 'unwind-define [else (error 'unwind-define
"expr with stepper-define-type is not a lambda: ~e" "expr with stepper-define-type is not a lambda: ~e"
@ -164,8 +164,8 @@
(with-syntax ([(rhs2 ...) (map (lambda (rhs) (unwind rhs settings)) (syntax->list #'(rhs ...)))] (with-syntax ([(rhs2 ...) (map (lambda (rhs) (unwind rhs settings)) (syntax->list #'(rhs ...)))]
[new-label [new-label
(if (improper-member 'comes-from-let* (if (improper-member 'comes-from-let*
(syntax-property (stepper-syntax-property
stx 'user-stepper-hint)) stx 'stepper-hint))
#`let* #`let*
(case (syntax-e #'label) (case (syntax-e #'label)
[(let-values) #'let] [(let-values) #'let]
@ -176,13 +176,13 @@
[((let* bindings inner-body ...)) [((let* bindings inner-body ...))
(and (and
(improper-member 'comes-from-let* (improper-member 'comes-from-let*
(syntax-property stx 'user-stepper-hint)) (stepper-syntax-property stx 'stepper-hint))
(eq? (syntax-property stx 'user-stepper-source) (eq? (stepper-syntax-property stx 'stepper-source)
(syntax-property (car (syntax->list #`new-bodies)) (stepper-syntax-property (car (syntax->list #`new-bodies))
'user-stepper-source)) 'stepper-source))
(eq? (syntax-property stx 'user-stepper-position) (eq? (stepper-syntax-property stx 'stepper-position)
(syntax-property (car (syntax->list #`new-bodies)) (stepper-syntax-property (car (syntax->list #`new-bodies))
'user-stepper-position))) 'stepper-position)))
#`(let* #,(append (syntax->list #`([var rhs2] ...)) #`(let* #,(append (syntax->list #`([var rhs2] ...))
(syntax->list #`bindings)) (syntax->list #`bindings))
inner-body ...)] inner-body ...)]
@ -212,7 +212,7 @@
; "unexpected result for unwinding the-cons application")])) ; "unexpected result for unwinding the-cons application")]))
(define (unwind-cond-clause stx test-stx result-stx settings) (define (unwind-cond-clause stx test-stx result-stx settings)
(with-syntax ([new-test (if (syntax-property stx 'user-stepper-else) (with-syntax ([new-test (if (stepper-syntax-property stx 'stepper-else)
#`else #`else
(unwind test-stx settings))] (unwind test-stx settings))]
[result (unwind result-stx settings)]) [result (unwind result-stx settings)])
@ -266,8 +266,8 @@
(with-syntax (with-syntax
([clauses ([clauses
(append (append
(build-list (syntax-property (build-list (stepper-syntax-property
stx 'user-stepper-and/or-clauses-consumed) stx 'stepper-and/or-clauses-consumed)
(lambda (dc) clause-padder)) (lambda (dc) clause-padder))
(let loop ([stx stx]) (let loop ([stx stx])
(if (and (eq? user-source (if (and (eq? user-source

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

@ -79,7 +79,7 @@
; : identifier -> identifier ; : identifier -> identifier
(define (make-mark-binding-stx id) (define (make-mark-binding-stx id)
#`(lambda () #,(syntax-property id 'stepper-dont-check-for-function #t))) #`(lambda () #,(stepper-syntax-property id 'stepper-dont-check-for-function #t)))
(define (mark-bindings mark) (define (mark-bindings mark)
(map list (map list
@ -163,13 +163,13 @@
(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)
(case (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)
(syntax-property var 'stepper-binding-type))))) (stepper-syntax-property var 'stepper-binding-type)))))
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)))

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

@ -49,7 +49,8 @@
"macro-unwind.ss" "macro-unwind.ss"
"lifting.ss" "lifting.ss"
;; for breakpoint display ;; for breakpoint display
"display-break-stuff.ss") "display-break-stuff.ss"
(file "/Users/clements/clements/scheme-scraps/eli-debug.ss"))
(define program-expander-contract (define program-expander-contract
((-> void?) ; init ((-> void?) ; init
@ -134,8 +135,8 @@
(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 (syntax-property left 'stepper-highlight) [(or (stepper-syntax-property left 'stepper-highlight)
(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
@ -143,8 +144,8 @@
[(eq? left right) [(eq? left right)
(list left right)] (list left right)]
[else (list (syntax-property left 'stepper-highlight) [else (list (stepper-syntax-property left 'stepper-highlight)
(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)
@ -311,6 +312,7 @@
(define (step-through-expression expanded expand-next-expression) (define (step-through-expression expanded expand-next-expression)
(let* ([annotated (a:annotate expanded break track-inferred-names? (let* ([annotated (a:annotate expanded break track-inferred-names?
language-level)]) language-level)])
(>>> "annotation complete")
(eval-syntax annotated) (eval-syntax annotated)
(expand-next-expression))) (expand-next-expression)))
@ -326,8 +328,8 @@
(program-expander (program-expander
(lambda () (lambda ()
;; swap these to allow errors to escape (e.g., when debugging) ;; swap these to allow errors to escape (e.g., when debugging)
(error-display-handler err-display-handler) ;;(error-display-handler err-display-handler)
;;(void) (void)
) )
(lambda (expanded continue-thunk) ; iter (lambda (expanded continue-thunk) ; iter
(r:reset-special-values) (r:reset-special-values)

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

@ -4,6 +4,7 @@
(prefix f: (lib "framework.ss" "framework")) (prefix f: (lib "framework.ss" "framework"))
(lib "pretty.ss") (lib "pretty.ss")
"testing-shared.ss" "testing-shared.ss"
"shared.ss"
(lib "string-constant.ss" "string-constants") (lib "string-constant.ss" "string-constants")
(lib "bitmap-label.ss" "mrlib")) (lib "bitmap-label.ss" "mrlib"))
@ -487,7 +488,7 @@
(define (strip-to-sexp stx highlight-table) (define (strip-to-sexp stx highlight-table)
(define (strip-regular stx) (define (strip-regular stx)
(let* ([it (if (and (syntax? stx) (let* ([it (if (and (syntax? stx)
(eq? (syntax-property stx 'stepper-hint) 'from-xml)) (eq? (stepper-syntax-property stx 'stepper-hint) 'from-xml))
(strip-xml stx) (strip-xml stx)
stx)] stx)]
[it [it
@ -499,7 +500,7 @@
[else it])] [else it])]
[it [it
(if (and (syntax? stx) (if (and (syntax? stx)
(syntax-property stx 'stepper-highlight)) (stepper-syntax-property stx 'stepper-highlight))
(if (pair? it) (if (pair? it)
(begin (begin
(hash-table-put! highlight-table it 'non-confusable) (hash-table-put! highlight-table it 'non-confusable)

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

@ -87,7 +87,7 @@
(define (mark-as-highlight stx) (define (mark-as-highlight stx)
(syntax-property stx 'stepper-highlight #t)) (stepper-syntax-property stx 'stepper-highlight #t))
; ;
; ;
; ;; ;;; ;;; ;;; ; ;; ; ; ;;; ; ; ; ;;; ; ;; ;;; ;;; ;;; ; ;; ; ; ;;; ; ; ; ;;;
@ -106,7 +106,7 @@
(define recon-value (define recon-value
(opt-lambda (val render-settings [assigned-name #f]) (opt-lambda (val render-settings [assigned-name #f])
(if (hash-table-get finished-xml-box-table val (lambda () #f)) (if (hash-table-get finished-xml-box-table val (lambda () #f))
(syntax-property #`(#%datum . #,val) 'stepper-xml-value-hint 'from-xml-box) (stepper-syntax-property #`(#%datum . #,val) 'stepper-xml-value-hint 'from-xml-box)
(let ([closure-record (closure-table-lookup val (lambda () #f))]) (let ([closure-record (closure-table-lookup val (lambda () #f))])
(if closure-record (if closure-record
(let* ([mark (closure-record-mark closure-record)] (let* ([mark (closure-record-mark closure-record)]
@ -147,7 +147,7 @@
#f] #f]
[(result-exp-break) [(result-exp-break)
;; skip if clauses that are the result of and/or reductions ;; skip if clauses that are the result of and/or reductions
(let ([and/or-clauses-consumed (syntax-property (mark-source (car mark-list)) 'stepper-and/or-clauses-consumed)]) (let ([and/or-clauses-consumed (stepper-syntax-property (mark-source (car mark-list)) 'stepper-and/or-clauses-consumed)])
(and and/or-clauses-consumed (and and/or-clauses-consumed
(> and/or-clauses-consumed 0)))] (> and/or-clauses-consumed 0)))]
[(normal-break normal-break/values) [(normal-break normal-break/values)
@ -156,8 +156,8 @@
(or (or
;; don't stop for a double-break on a let that is the expansion of a 'begin' ;; don't stop for a double-break on a let that is the expansion of a 'begin'
(let ([expr (mark-source (car mark-list))]) (let ([expr (mark-source (car mark-list))])
(or (eq? (syntax-property expr 'stepper-hint) 'comes-from-begin) (or (eq? (stepper-syntax-property expr 'stepper-hint) 'comes-from-begin)
(syntax-property expr 'stepper-skip-double-break))) (stepper-syntax-property expr 'stepper-skip-double-break)))
(not (render-settings-lifting? render-settings)))] (not (render-settings-lifting? render-settings)))]
[(expr-finished-break define-struct-break late-let-break) #f])) [(expr-finished-break define-struct-break late-let-break) #f]))
@ -167,14 +167,14 @@
(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-object->interned-datum (recon-value val render-settings))
(syntax-object->interned-datum (case (syntax-property varref 'stepper-binding-type) (syntax-object->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]
varref) varref)
(else (else
(error 'varref-skip-step? "unexpected value for stepper-binding-type: ~e for variable: ~e\n" (error 'varref-skip-step? "unexpected value for stepper-binding-type: ~e for variable: ~e\n"
(syntax-property varref 'stepper-binding-type) (stepper-syntax-property varref 'stepper-binding-type)
varref)))))))) varref))))))))
(and (pair? mark-list) (and (pair? mark-list)
@ -182,7 +182,7 @@
(or (kernel:kernel-syntax-case expr #f (or (kernel:kernel-syntax-case expr #f
[id [id
(identifier? expr) (identifier? expr)
(case (syntax-property expr 'stepper-binding-type) (case (stepper-syntax-property expr 'stepper-binding-type)
[(lambda-bound) #t] ; don't halt for lambda-bound vars [(lambda-bound) #t] ; don't halt for lambda-bound vars
[(let-bound) [(let-bound)
(varref-skip-step? expr)] (varref-skip-step? expr)]
@ -308,8 +308,8 @@
expr expr
'discard 'discard
(lambda (expr) (lambda (expr)
(if (syntax-property expr 'stepper-prim-name) (if (stepper-syntax-property expr 'stepper-prim-name)
(syntax-property expr 'stepper-prim-name) (stepper-syntax-property expr 'stepper-prim-name)
(let* ([recur (lambda (expr) (recon-source-expr expr mark-list dont-lookup use-lifted-names render-settings))] (let* ([recur (lambda (expr) (recon-source-expr expr mark-list dont-lookup use-lifted-names render-settings))]
[let-recur (lambda (expr bindings) [let-recur (lambda (expr bindings)
(recon-source-expr expr mark-list (append bindings dont-lookup) use-lifted-names render-settings))] (recon-source-expr expr mark-list (append bindings dont-lookup) use-lifted-names render-settings))]
@ -335,7 +335,7 @@
[(new-vars ...) (map (lx (map (lx (if (ormap (lambda (binding) [(new-vars ...) (map (lx (map (lx (if (ormap (lambda (binding)
(bound-identifier=? binding _)) (bound-identifier=? binding _))
use-lifted-names) use-lifted-names)
(syntax-property _ (stepper-syntax-property _
'stepper-lifted-name 'stepper-lifted-name
(binding-lifted-name mark-list _)) (binding-lifted-name mark-list _))
_)) _))
@ -414,14 +414,14 @@
use-lifted-names))) use-lifted-names)))
var var
(case (syntax-property var 'stepper-binding-type) (case (stepper-syntax-property var 'stepper-binding-type)
((lambda-bound) ((lambda-bound)
(recon-value (lookup-binding mark-list var) render-settings)) (recon-value (lookup-binding mark-list var) render-settings))
((macro-bound) ((macro-bound)
; for the moment, let-bound vars occur only in and/or : ; for the moment, let-bound vars occur only in and/or :
(recon-value (lookup-binding mark-list var) render-settings)) (recon-value (lookup-binding mark-list var) render-settings))
((let-bound) ((let-bound)
(syntax-property var (stepper-syntax-property var
'stepper-lifted-name 'stepper-lifted-name
(binding-lifted-name mark-list var))) (binding-lifted-name mark-list var)))
((stepper-temp) ((stepper-temp)
@ -430,7 +430,7 @@
(error 'recon-source-expr "can't get here: lexical identifier labeled as non-lexical")) (error 'recon-source-expr "can't get here: lexical identifier labeled as non-lexical"))
(else (else
(error 'recon-source-expr "unknown 'stepper-binding-type property: ~a" (error 'recon-source-expr "unknown 'stepper-binding-type property: ~a"
(syntax-property var 'stepper-binding-type)))))] (stepper-syntax-property var 'stepper-binding-type)))))]
[else ; top-level-varref [else ; top-level-varref
(fixup-name (fixup-name
var)]))] var)]))]
@ -444,7 +444,7 @@
;; reconstruct-set!-var ;; reconstruct-set!-var
(define (reconstruct-set!-var mark-list var) (define (reconstruct-set!-var mark-list var)
(case (syntax-property var 'stepper-binding-type) (case (stepper-syntax-property var 'stepper-binding-type)
((lambda-bound) ((lambda-bound)
(error 'reconstruct-inner "lambda-bound variables can't be mutated")) (error 'reconstruct-inner "lambda-bound variables can't be mutated"))
((macro-bound) ((macro-bound)
@ -452,21 +452,21 @@
(error 'reconstruct-inner "macro-bound variables can't occur in a set!")) (error 'reconstruct-inner "macro-bound variables can't occur in a set!"))
((non-lexical) var) ((non-lexical) var)
((let-bound) ((let-bound)
(syntax-property var (stepper-syntax-property var
'stepper-lifted-name 'stepper-lifted-name
(binding-lifted-name mark-list var))) (binding-lifted-name mark-list var)))
((stepper-temp) ((stepper-temp)
(error 'recon-source-expr "stepper-temp showed up in source?!?")) (error 'recon-source-expr "stepper-temp showed up in source?!?"))
(else (else
(error 'recon-source-expr "unknown 'stepper-binding-type property: ~a" (error 'recon-source-expr "unknown 'stepper-binding-type property: ~a"
(syntax-property var 'stepper-binding-type))))) (stepper-syntax-property var 'stepper-binding-type)))))
;; filter-skipped : (listof syntax?) -> (listof syntax?) ;; filter-skipped : (listof syntax?) -> (listof syntax?)
;; filter out any elements of the list with 'stepper-skip-completely set, except those with stepper-prim-name set. (HACK). ;; filter out any elements of the list with 'stepper-skip-completely set, except those with stepper-prim-name set. (HACK).
(define (filter-skipped los) (define (filter-skipped los)
(filter (lambda (stx) (filter (lambda (stx)
(or (syntax-property stx 'stepper-prim-name) (or (stepper-syntax-property stx 'stepper-prim-name)
(not (syntax-property stx 'stepper-skip-completely)))) (not (stepper-syntax-property stx 'stepper-skip-completely))))
los)) los))
@ -513,15 +513,15 @@
(if lifting-indices (if lifting-indices
(syntax-case exp () (syntax-case exp ()
[(vars-stx rhs ...) [(vars-stx rhs ...)
(let* ([vars (map (lambda (var index) (syntax-property var 'stepper-lifted-name (construct-lifted-name var index))) (let* ([vars (map (lambda (var index) (stepper-syntax-property var 'stepper-lifted-name (construct-lifted-name var index)))
(syntax->list #`vars-stx) (syntax->list #`vars-stx)
lifting-indices)]) lifting-indices)])
(vector (reconstruct-completed-define exp vars (vals-getter) render-settings) #f))]) (vector (reconstruct-completed-define exp vars (vals-getter) render-settings) #f))])
(let ([exp (skipto/auto exp 'discard (lambda (exp) exp))]) (let ([exp (skipto/auto exp 'discard (lambda (exp) exp))])
(cond (cond
[(syntax-property exp 'stepper-define-struct-hint) [(stepper-syntax-property exp 'stepper-define-struct-hint)
;; the hint contains the original syntax ;; the hint contains the original syntax
(vector (syntax-property exp 'stepper-define-struct-hint) #t)] (vector (stepper-syntax-property exp 'stepper-define-struct-hint) #t)]
[else [else
(vector (vector
(kernel:kernel-syntax-case exp #f (kernel:kernel-syntax-case exp #f
@ -625,7 +625,7 @@
(map (lambda (binding-set rhs) (map (lambda (binding-set rhs)
(make-let-glump (make-let-glump
(map (lambda (binding) (map (lambda (binding)
(syntax-property binding (stepper-syntax-property binding
'stepper-lifted-name 'stepper-lifted-name
(binding-lifted-name mark-list binding))) (binding-lifted-name mark-list binding)))
binding-set) binding-set)
@ -669,10 +669,10 @@
null)] null)]
[recon-bindings (append before-bindings after-bindings)] [recon-bindings (append before-bindings after-bindings)]
;; there's a terrible tangle of invariants here. Among them: ;; there's a terrible tangle of invariants here. Among them:
;; num-defns-done = (length binding-sets) IFF the so-far has a 'user-stepper-offset' index ;; num-defns-done = (length binding-sets) IFF the so-far has a 'stepper-offset' index
;; that is not #f (that is, we're evaluating the body...) ;; that is not #f (that is, we're evaluating the body...)
[so-far-offset-index (and (not (eq? so-far nothing-so-far)) [so-far-offset-index (and (not (eq? so-far nothing-so-far))
(syntax-property so-far 'user-stepper-offset-index))] (stepper-syntax-property so-far 'stepper-offset-index))]
[bodies (syntax->list (syntax bodies))] [bodies (syntax->list (syntax bodies))]
[rectified-bodies [rectified-bodies
(map (lambda (body offset-index) (map (lambda (body offset-index)
@ -682,7 +682,7 @@
bodies bodies
(iota (length bodies)))]) (iota (length bodies)))])
(attach-info #`(label #,recon-bindings #,@rectified-bodies) exp))))]) (attach-info #`(label #,recon-bindings #,@rectified-bodies) exp))))])
(if (syntax-property exp 'stepper-fake-exp) (if (stepper-syntax-property exp 'stepper-fake-exp)
(syntax-case exp () (syntax-case exp ()
[(begin . bodies) [(begin . bodies)

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

@ -88,8 +88,26 @@
get-set-pair-union-stats ; profiling info get-set-pair-union-stats ; profiling info
re-intern-identifier re-intern-identifier
finished-xml-box-table finished-xml-box-table
language-level->name) language-level->name
stepper-syntax-property)
;; stepper-syntax-property : like syntax property, but adds properties to an association
;; list associated with the syntax property 'stepper-properties
(define stepper-syntax-property
(case-lambda
[(stx tag) (let ([stepper-props (syntax-property stx 'stepper-properties)])
(if stepper-props
(let ([table-lookup (assq tag stepper-props)])
(if table-lookup
(cadr table-lookup)
#f))
#f))]
[(stx tag new-val) (syntax-property stx 'stepper-properties
(cons (list tag new-val)
(or (syntax-property stx 'stepper-properties)
null)))]))
; A step-result is either: ; A step-result is either:
; (make-before-after-result finished-exps exp redex reduct) ; (make-before-after-result finished-exps exp redex reduct)
@ -325,7 +343,7 @@
(apply map list args))) (apply map list args)))
(define let-counter (define let-counter
(syntax-property #'let-counter 'stepper-binding-type 'stepper-temp)) (stepper-syntax-property #'let-counter 'stepper-binding-type 'stepper-temp))
; syntax-pair-map (using the def'ns of the MzScheme docs): ; syntax-pair-map (using the def'ns of the MzScheme docs):
@ -432,14 +450,14 @@
;; traversal argument is 'discard, the result of the transformation is the ;; traversal argument is 'discard, the result of the transformation is the
;; result of this function ;; result of this function
(define (skipto/auto stx traversal transformer) (define (skipto/auto stx traversal transformer)
(cond [(syntax-property stx 'stepper-skipto) (cond [(stepper-syntax-property stx 'stepper-skipto)
=> =>
(cut update <> stx (cut skipto/auto <> traversal transformer) traversal)] (cut update <> stx (cut skipto/auto <> traversal transformer) traversal)]
[else (transformer stx)])) [else (transformer stx)]))
; small test case: ; small test case:
#;(display (equal? (syntax-object->datum #;(display (equal? (syntax-object->datum
(skipto/auto (syntax-property #`(a #,(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)))
'stepper-skipto 'stepper-skipto
@ -531,54 +549,25 @@
(sublist 0 (- end 1) (cdr lst))) (sublist 0 (- end 1) (cdr lst)))
(sublist (- begin 1) (- end 1) (cdr lst))))) (sublist (- begin 1) (- end 1) (cdr lst)))))
; attach-info : SYNTAX-OBJECT SYNTAX-OBJECT -> SYNTAX-OBJECT
; attach-info attaches to a generated piece of syntax the origin & source
; information of another. we do this so that macro unwinding can tell what
; reconstructed syntax came from what original syntax
(define labels-to-attach
`((user-origin origin)
(user-stepper-hint stepper-hint)
(user-stepper-else stepper-else)
(user-stepper-define-type stepper-define-type)
(user-stepper-proc-define-name stepper-proc-define-name)
(user-stepper-and/or-clauses-consumed stepper-and/or-clauses-consumed)
(user-stepper-offset-index stepper-offset-index)
;; I find it mildly worrisome that this breaks the pattern
;; by failing to preface the identifier with 'user-'. JBC, 2005-08
(stepper-xml-hint stepper-xml-hint)))
;; take info from source expressions to reconstructed expressions ;; take info from source expressions to reconstructed expressions
;; (from native property names to 'user-' style property names)
(define (attach-info to-exp from-exp) (define (attach-info to-exp from-exp)
;; (if (syntax-property from-exp 'stepper-offset-index) ;; (if (stepper-syntax-property from-exp 'stepper-offset-index)
;; (>>> (syntax-property from-exp 'stepper-offset-index))) ;; (>>> (stepper-syntax-property from-exp 'stepper-offset-index)))
(let* ([attached (foldl (lambda (labels stx) (let* ([attached (syntax-property to-exp 'stepper-properties (syntax-property from-exp 'stepper-properties))]
(match labels
[`(,new-label ,old-label)
(syntax-property stx new-label (syntax-property from-exp old-label))]))
to-exp
labels-to-attach)]
[attached (syntax-property attached 'user-source (syntax-source from-exp))] [attached (syntax-property attached 'user-source (syntax-source from-exp))]
[attached (syntax-property attached 'user-position (syntax-position from-exp))]) [attached (syntax-property attached 'user-position (syntax-position from-exp))])
attached)) attached))
;; transfer info from reconstructed expressions to other reconstructed ;; transfer info from reconstructed expressions to other reconstructed
;; expressions ;; expressions
;; (from 'user-' style names to 'user-' style names)
(define (transfer-info to-stx from-exp) (define (transfer-info to-exp from-exp)
(let* ([attached (foldl (lambda (labels stx) (let* ([attached (syntax-property to-exp 'stepper-properties (append (syntax-property from-exp 'stepper-properties)
(match labels (or (syntax-property to-exp 'stepper-properties)
[`(,new-label ,old-label) null)))]
(syntax-property stx new-label (syntax-property from-exp new-label))]))
to-stx
labels-to-attach)]
[attached (syntax-property attached 'user-source (syntax-property from-exp 'user-source))] [attached (syntax-property attached 'user-source (syntax-property from-exp 'user-source))]
[attached (syntax-property attached 'user-position (syntax-property from-exp 'user-position))] [attached (syntax-property attached 'user-position (syntax-property from-exp 'user-position))])
[attached (syntax-property attached 'stepper-highlight (or (syntax-property from-exp 'stepper-highlight)
(syntax-property attached 'stepper-highlight)))])
attached)) attached))
(define (values-map fn . lsts) (define (values-map fn . lsts)
@ -624,16 +613,16 @@
[else (if (syntax? stx) [else (if (syntax? stx)
(syntax-object->datum stx) (syntax-object->datum stx)
stx)])]) stx)])])
(let* ([it (case (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 (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?)
(syntax-property stx 'stepper-highlight)) (stepper-syntax-property stx 'stepper-highlight))
`(hilite ,it) `(hilite ,it)
it)]) it)])
it)))) it))))
@ -703,11 +692,14 @@
(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))))
) )
; test cases ; test cases
;(require shared) ;(require shared)
;(load "/Users/clements/plt/tests/mzscheme/testing.ss") ;(write (collection-path "tests" "mzscheme"))
;(load (build-path (collection-path "tests" "mzscheme") "testing.ss"))
; ;
;(define (a sym) ;(define (a sym)
; (syntax-object->datum (get-lifted-var sym))) ; (syntax-object->datum (get-lifted-var sym)))
@ -755,3 +747,10 @@
; (list sums diffs))) ; (list sums diffs)))
; `((10 10 10 10 10) ; `((10 10 10 10 10)
; (-8 -6 -4 -2 0))) ; (-8 -6 -4 -2 0)))
;(test #f stepper-syntax-property #`13 '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 'yes) 'def 'arg) 'abc)
;(test 13 syntax-object->datum (stepper-syntax-property (stepper-syntax-property #`13 'abc 'yes) 'def 'arg))

10
collects/stepper/private/testing-shared.ss
View File

@ -25,7 +25,7 @@
(let stx-loop ([stx stx]) (let stx-loop ([stx stx])
(syntax-case stx (hilite) (syntax-case stx (hilite)
[(hilite x) [(hilite x)
(syntax-property (stx-loop #`x) 'stepper-highlight #t)] (stepper-syntax-property (stx-loop #`x) 'stepper-highlight #t)]
[(a . rest) (datum->syntax-object stx (cons (stx-loop #`a) (stx-loop #`rest)) stx stx)] [(a . rest) (datum->syntax-object stx (cons (stx-loop #`a) (stx-loop #`rest)) stx stx)]
[else stx])) [else stx]))
(read-loop (read-syntax temp-file file-port)))))) (read-loop (read-syntax temp-file file-port))))))
@ -43,13 +43,13 @@
; (let ([test-stx (car test-run)]) ; (let ([test-stx (car test-run)])
; (test `(+ x (+ 13 (a b))) ; (test `(+ x (+ 13 (a b)))
; syntax-object->datum test-stx) ; syntax-object->datum test-stx)
; (test #f syntax-property test-stx 'stepper-highlight) ; (test #f stepper-syntax-property test-stx 'stepper-highlight)
; (test #t syntax-property (car (syntax-e (cdr (syntax-e test-stx)))) 'stepper-highlight) ; (test #t stepper-syntax-property (car (syntax-e (cdr (syntax-e test-stx)))) 'stepper-highlight)
; (test #t syntax-property (syntax-case test-stx () ; (test #t stepper-syntax-property (syntax-case test-stx ()
; [(+ x target) ; [(+ x target)
; #`target]) ; #`target])
; 'stepper-highlight) ; 'stepper-highlight)
; (test #t syntax-property (syntax-case test-stx (#%app) ; (test #t stepper-syntax-property (syntax-case test-stx (#%app)
; [(+ x (a target d)) ; [(+ x (a target d))
; #`target]) ; #`target])
; 'stepper-highlight))) ; 'stepper-highlight)))

6
collects/stepper/private/xml-box.ss
View File

@ -17,10 +17,10 @@
(define (rewrite-xml-error) (define (rewrite-xml-error)
(error 'rewrite-xml-box "unexpected syntax in expansion of xml box: ~e" stx)) (error 'rewrite-xml-box "unexpected syntax in expansion of xml box: ~e" stx))
(case (syntax-property stx 'stepper-hint) (case (stepper-syntax-property stx 'stepper-hint)
[(from-scheme-box from-splice-box) (rewrite-other stx)] [(from-scheme-box from-splice-box) (rewrite-other stx)]
[(from-xml-box #f) [(from-xml-box #f)
(syntax-property (stepper-syntax-property
(kernel:kernel-syntax-case stx #f (kernel:kernel-syntax-case stx #f
[var-stx (identifier? (syntax var-stx)) (rewrite-xml-error)] [var-stx (identifier? (syntax var-stx)) (rewrite-xml-error)]
@ -61,7 +61,7 @@
[else [else
(error 'rewrite-xml-box "unexpected stepper-hint \"~v\" on syntax from xml box: ~e" (error 'rewrite-xml-box "unexpected stepper-hint \"~v\" on syntax from xml box: ~e"
(syntax-property stx 'stepper-hint) (stepper-syntax-property stx 'stepper-hint)
stx)]))) stx)])))

9
collects/stepper/private/xml-snip-helpers.ss
View File

@ -4,7 +4,8 @@
(lib "readerr.ss" "syntax") (lib "readerr.ss" "syntax")
(lib "mred.ss" "mred") (lib "mred.ss" "mred")
(lib "class.ss") (lib "class.ss")
(lib "list.ss")) (lib "list.ss")
"shared.ss")
(provide xml-read-special (provide xml-read-special
xml-snip<%> xml-snip<%>
@ -53,7 +54,7 @@
[expd-xexpr (expand-embedded clean-xexpr)] [expd-xexpr (expand-embedded clean-xexpr)]
[qq-body (datum->syntax-object #'here expd-xexpr (list editor #f #f #f #f))]) [qq-body (datum->syntax-object #'here expd-xexpr (list editor #f #f #f #f))])
(with-syntax ([qq-body qq-body]) (with-syntax ([qq-body qq-body])
(syntax-property (syntax (quasiquote qq-body)) (stepper-syntax-property (syntax (quasiquote qq-body))
'stepper-xml-hint 'stepper-xml-hint
'from-xml-box)))) 'from-xml-box))))
(lambda () (send editor lock old-locked))))) (lambda () (send editor lock old-locked)))))
@ -111,13 +112,13 @@
(with-syntax ([err (syntax/loc (with-syntax ([err (syntax/loc
(car (last-pair raw-stxs)) (car (last-pair raw-stxs))
(error 'scheme-splice-box "expected a list, found: ~e" lst))]) (error 'scheme-splice-box "expected a list, found: ~e" lst))])
#`,@#,(syntax-property #`(let ([lst (begin stxs ...)]) #`,@#,(stepper-syntax-property #`(let ([lst (begin stxs ...)])
(if (list? lst) (if (list? lst)
lst lst
err)) err))
'stepper-xml-hint 'stepper-xml-hint
'from-splice-box)) 'from-splice-box))
#`,#,(syntax-property #`(begin stxs ...) #`,#,(stepper-syntax-property #`(begin stxs ...)
'stepper-xml-hint 'stepper-xml-hint
'from-scheme-box))))] 'from-scheme-box))))]
[else xexpr]))) [else xexpr])))