changed syntax-property to stepper-syntax-property
svn: r4762
This commit is contained in:
John Clements
parent
0d7c25bbb8
commit
96d857dcd0
|
|
@ -115,14 +115,14 @@
|
|||
; 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
|
||||
; 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)
|
||||
(let loop ([stx stx]
|
||||
[let-bound-bindings null]
|
||||
[cond-test (lx #f)])
|
||||
(if (or (syntax-property stx 'stepper-skip-completely)
|
||||
(syntax-property stx 'stepper-define-struct-hint))
|
||||
(if (or (stepper-syntax-property stx 'stepper-skip-completely)
|
||||
(stepper-syntax-property stx 'stepper-define-struct-hint))
|
||||
stx
|
||||
(let* ([recur-regular
|
||||
(lambda (stx)
|
||||
|
|
@ -162,7 +162,7 @@
|
|||
[rebuild-if
|
||||
(lambda (new-cond-test)
|
||||
(let* ([new-then (recur-regular (syntax then))]
|
||||
[rebuilt (syntax-property
|
||||
[rebuilt (stepper-syntax-property
|
||||
(rebuild-stx `(if ,(recur-regular (syntax test))
|
||||
,new-then
|
||||
,(recur-in-cond (syntax else-stx) new-cond-test))
|
||||
|
|
@ -170,8 +170,8 @@
|
|||
'stepper-hint
|
||||
'comes-from-cond)])
|
||||
; move the stepper-else mark to the if, if it's present:
|
||||
(if (syntax-property (syntax test) 'stepper-else)
|
||||
(syntax-property rebuilt 'stepper-else #t)
|
||||
(if (stepper-syntax-property (syntax test) 'stepper-else)
|
||||
(stepper-syntax-property rebuilt 'stepper-else #t)
|
||||
rebuilt)))])
|
||||
(cond [(cond-test stx) ; continuing an existing 'cond'
|
||||
(rebuild-if cond-test)]
|
||||
|
|
@ -183,17 +183,17 @@
|
|||
(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
|
||||
(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
|
||||
; 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.
|
||||
[(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)
|
||||
[(letrec-values (bogus-clause clause ...) . bodies)
|
||||
(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"
|
||||
(syntax-object->datum #`expansion-of-local))])]
|
||||
|
||||
|
|
@ -204,7 +204,7 @@
|
|||
; varref :
|
||||
[var
|
||||
(identifier? (syntax var))
|
||||
(syntax-property
|
||||
(stepper-syntax-property
|
||||
(syntax var)
|
||||
'stepper-binding-type
|
||||
(if (eq? (identifier-binding (syntax var)) 'lexical)
|
||||
|
|
@ -220,8 +220,8 @@
|
|||
(rebuild-stx (syntax-pair-map content recur-regular) stx)
|
||||
stx))])])
|
||||
|
||||
(if (eq? (syntax-property stx 'stepper-xml-hint) 'from-xml-box)
|
||||
(syntax-property #`(#,put-into-xml-table #,rewritten)
|
||||
(if (eq? (stepper-syntax-property stx 'stepper-xml-hint) 'from-xml-box)
|
||||
(stepper-syntax-property #`(#,put-into-xml-table #,rewritten)
|
||||
'stepper-skipto
|
||||
(list syntax-e cdr car))
|
||||
(syntax-recertify rewritten stx (current-code-inspector) #f))))))
|
||||
|
|
@ -383,9 +383,9 @@
|
|||
. -> . (vector/p syntax? binding-set?))
|
||||
(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
|
||||
;[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:
|
||||
[annotated (skipto/auto
|
||||
exp
|
||||
|
|
@ -399,7 +399,7 @@
|
|||
annotated)
|
||||
free-vars-captured))]
|
||||
|
||||
[(syntax-property exp 'stepper-skip-completely)
|
||||
[(stepper-syntax-property exp 'stepper-skip-completely)
|
||||
(2vals (wcm-wrap 13 exp) null)]
|
||||
|
||||
[else
|
||||
|
|
@ -443,7 +443,7 @@
|
|||
'let-body
|
||||
#t))]
|
||||
[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))]
|
||||
|
||||
[outer-wcm-wrap (if pre-break?
|
||||
|
|
@ -476,7 +476,7 @@
|
|||
; wrap bodies in explicit begin if more than 1 user-introduced (non-skipped) bodies
|
||||
; NB: CAN'T HAPPEN in beginner up through int/lambda
|
||||
(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)
|
||||
(lambda-body-recur (syntax (begin . bodies)))
|
||||
(let*-2vals ([(annotated-bodies free-var-sets)
|
||||
|
|
@ -728,7 +728,7 @@
|
|||
(varref-break-wrap)
|
||||
(varref-no-break-wrap)))])
|
||||
(2vals
|
||||
(case (syntax-property var 'stepper-binding-type)
|
||||
(case (stepper-syntax-property var 'stepper-binding-type)
|
||||
((lambda-bound macro-bound) (varref-no-break-wrap))
|
||||
((let-bound) (varref-break-wrap))
|
||||
((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
|
||||
;; reconstruction. Easier to undo in the macro-unwind phase.
|
||||
#;[(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))]
|
||||
|
||||
[(let-values . _)
|
||||
|
|
@ -976,7 +976,7 @@
|
|||
[free-varrefs (varref-set-union free-varrefs-terms)])
|
||||
(2vals
|
||||
(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)]
|
||||
[let-clauses #`((#,tagged-arg-temps
|
||||
(values #,@(map (lambda (_) *unevaluated*) tagged-arg-temps))))]
|
||||
|
|
@ -1090,11 +1090,11 @@
|
|||
(define/contract annotate/module-top-level
|
||||
(syntax? . -> . syntax?)
|
||||
(lambda (exp)
|
||||
(cond [(syntax-property exp 'stepper-skip-completely) exp]
|
||||
[(syntax-property exp 'stepper-define-struct-hint)
|
||||
(cond [(stepper-syntax-property exp 'stepper-skip-completely) exp]
|
||||
[(stepper-syntax-property exp 'stepper-define-struct-hint)
|
||||
#`(begin #,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)]
|
||||
[else
|
||||
(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)
|
||||
print-values))))]
|
||||
[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)]
|
||||
[else
|
||||
(top-level-annotate/inner (top-level-rewrite exp) exp #f)
|
||||
|
|
|
|||
|
|
@ -91,7 +91,7 @@
|
|||
(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)))
|
||||
(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))
|
||||
|
|
@ -243,9 +243,9 @@
|
|||
(lift-helper highlighted #f null)
|
||||
(values null highlighted))])
|
||||
(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)]
|
||||
[body (syntax-property highlighted-body 'stepper-highlight #t)])
|
||||
[body (stepper-syntax-property highlighted-body 'stepper-highlight #t)])
|
||||
(if (null? ctx-list)
|
||||
(append so-far-defs (list body))
|
||||
(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))]))])
|
||||
(kernel:kernel-syntax-case stx #f
|
||||
[(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)]
|
||||
[(letrec-values . dc)
|
||||
(lift)]
|
||||
|
|
|
|||
|
|
@ -52,7 +52,7 @@
|
|||
(kernel:kernel-syntax-case stx #f
|
||||
[id
|
||||
(identifier? stx)
|
||||
(or (syntax-property stx 'stepper-lifted-name)
|
||||
(or (stepper-syntax-property stx 'stepper-lifted-name)
|
||||
stx)]
|
||||
[(define-values dc ...)
|
||||
(unwind-define stx settings)]
|
||||
|
|
@ -65,7 +65,7 @@
|
|||
[(letrec-values . rest)
|
||||
(unwind-mz-let stx settings)]
|
||||
[(set! var rhs)
|
||||
(with-syntax ([unwound-var (or (syntax-property
|
||||
(with-syntax ([unwound-var (or (stepper-syntax-property
|
||||
#`var 'stepper-lifted-name)
|
||||
#`var)]
|
||||
[unwound-body (unwind #`rhs settings)])
|
||||
|
|
@ -74,7 +74,7 @@
|
|||
|
||||
(define (unwind stx settings)
|
||||
(transfer-info
|
||||
(let ([hint (syntax-property stx 'user-stepper-hint)])
|
||||
(let ([hint (stepper-syntax-property stx 'stepper-hint)])
|
||||
(if (procedure? hint)
|
||||
(hint stx (lambda (stx) (recur-on-pieces stx settings)))
|
||||
(let ([process (case hint
|
||||
|
|
@ -89,8 +89,8 @@
|
|||
stx))
|
||||
|
||||
(define (transfer-highlight from to)
|
||||
(if (syntax-property from 'stepper-highlight)
|
||||
(syntax-property to 'stepper-highlight #t)
|
||||
(if (stepper-syntax-property from 'stepper-highlight)
|
||||
(stepper-syntax-property to 'stepper-highlight #t)
|
||||
to))
|
||||
|
||||
(define (unwind-recur stx settings)
|
||||
|
|
@ -118,29 +118,29 @@
|
|||
"reconstruct fails on multiple-values define: ~v\n"
|
||||
(syntax-object->datum stx)))
|
||||
(let* ([printed-name
|
||||
(or (syntax-property #`name 'stepper-lifted-name)
|
||||
(syntax-property #'name 'stepper-orig-name)
|
||||
(or (stepper-syntax-property #`name 'stepper-lifted-name)
|
||||
(stepper-syntax-property #'name 'stepper-orig-name)
|
||||
#'name)]
|
||||
[unwound-body (unwind #'body settings)]
|
||||
;; see notes in internal-docs.txt
|
||||
[define-type (syntax-property
|
||||
unwound-body 'user-stepper-define-type)])
|
||||
[define-type (stepper-syntax-property
|
||||
unwound-body 'stepper-define-type)])
|
||||
(if define-type
|
||||
(kernel:kernel-syntax-case unwound-body #f
|
||||
[(lambda arglist lam-body ...)
|
||||
(case define-type
|
||||
[(shortened-proc-define)
|
||||
(let ([proc-define-name
|
||||
(syntax-property
|
||||
(stepper-syntax-property
|
||||
unwound-body
|
||||
'user-stepper-proc-define-name)])
|
||||
'stepper-proc-define-name)])
|
||||
(if (or (module-identifier=? proc-define-name
|
||||
#'name)
|
||||
(and (syntax-property #'name
|
||||
(and (stepper-syntax-property #'name
|
||||
'stepper-orig-name)
|
||||
(module-identifier=?
|
||||
proc-define-name
|
||||
(syntax-property
|
||||
(stepper-syntax-property
|
||||
#'name 'stepper-orig-name))))
|
||||
#`(define (#,printed-name . arglist)
|
||||
lam-body ...)
|
||||
|
|
@ -149,7 +149,7 @@
|
|||
[(lambda-define)
|
||||
#`(define #,printed-name #,unwound-body)]
|
||||
[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)])]
|
||||
[else (error 'unwind-define
|
||||
"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 ...)))]
|
||||
[new-label
|
||||
(if (improper-member 'comes-from-let*
|
||||
(syntax-property
|
||||
stx 'user-stepper-hint))
|
||||
(stepper-syntax-property
|
||||
stx 'stepper-hint))
|
||||
#`let*
|
||||
(case (syntax-e #'label)
|
||||
[(let-values) #'let]
|
||||
|
|
@ -176,13 +176,13 @@
|
|||
[((let* bindings inner-body ...))
|
||||
(and
|
||||
(improper-member 'comes-from-let*
|
||||
(syntax-property stx 'user-stepper-hint))
|
||||
(eq? (syntax-property stx 'user-stepper-source)
|
||||
(syntax-property (car (syntax->list #`new-bodies))
|
||||
'user-stepper-source))
|
||||
(eq? (syntax-property stx 'user-stepper-position)
|
||||
(syntax-property (car (syntax->list #`new-bodies))
|
||||
'user-stepper-position)))
|
||||
(stepper-syntax-property stx 'stepper-hint))
|
||||
(eq? (stepper-syntax-property stx 'stepper-source)
|
||||
(stepper-syntax-property (car (syntax->list #`new-bodies))
|
||||
'stepper-source))
|
||||
(eq? (stepper-syntax-property stx 'stepper-position)
|
||||
(stepper-syntax-property (car (syntax->list #`new-bodies))
|
||||
'stepper-position)))
|
||||
#`(let* #,(append (syntax->list #`([var rhs2] ...))
|
||||
(syntax->list #`bindings))
|
||||
inner-body ...)]
|
||||
|
|
@ -212,7 +212,7 @@
|
|||
; "unexpected result for unwinding the-cons application")]))
|
||||
|
||||
(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
|
||||
(unwind test-stx settings))]
|
||||
[result (unwind result-stx settings)])
|
||||
|
|
@ -266,8 +266,8 @@
|
|||
(with-syntax
|
||||
([clauses
|
||||
(append
|
||||
(build-list (syntax-property
|
||||
stx 'user-stepper-and/or-clauses-consumed)
|
||||
(build-list (stepper-syntax-property
|
||||
stx 'stepper-and/or-clauses-consumed)
|
||||
(lambda (dc) clause-padder))
|
||||
(let loop ([stx stx])
|
||||
(if (and (eq? user-source
|
||||
|
|
|
|||
|
|
@ -79,7 +79,7 @@
|
|||
|
||||
; : identifier -> identifier
|
||||
(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)
|
||||
(map list
|
||||
|
|
@ -163,13 +163,13 @@
|
|||
(let*-2vals ([kept-vars (binding-set-varref-set-intersect tail-bound free-vars)])
|
||||
(if lifting?
|
||||
(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)
|
||||
((lambda-bound stepper-temp non-lexical) #f)
|
||||
(else (error 'make-debug-info
|
||||
"varref ~a's binding-type info was not recognized: ~a"
|
||||
(syntax-e var)
|
||||
(syntax-property var 'stepper-binding-type)))))
|
||||
(stepper-syntax-property var 'stepper-binding-type)))))
|
||||
kept-vars)]
|
||||
[lifter-syms (map get-lifted-var let-bindings)])
|
||||
(make-full-mark source label (append kept-vars lifter-syms)))
|
||||
|
|
|
|||
|
|
@ -49,7 +49,8 @@
|
|||
"macro-unwind.ss"
|
||||
"lifting.ss"
|
||||
;; for breakpoint display
|
||||
"display-break-stuff.ss")
|
||||
"display-break-stuff.ss"
|
||||
(file "/Users/clements/clements/scheme-scraps/eli-debug.ss"))
|
||||
|
||||
(define program-expander-contract
|
||||
((-> void?) ; init
|
||||
|
|
@ -134,8 +135,8 @@
|
|||
(define (highlight-mutated-expression left right)
|
||||
(cond
|
||||
;; if either one is already highlighted, leave them alone.
|
||||
[(or (syntax-property left 'stepper-highlight)
|
||||
(syntax-property right 'stepper-highlight))
|
||||
[(or (stepper-syntax-property left 'stepper-highlight)
|
||||
(stepper-syntax-property right 'stepper-highlight))
|
||||
(list left right)]
|
||||
|
||||
;; first pass: highlight if not eq?. Should be broken for local-bound
|
||||
|
|
@ -143,8 +144,8 @@
|
|||
[(eq? left right)
|
||||
(list left right)]
|
||||
|
||||
[else (list (syntax-property left 'stepper-highlight)
|
||||
(syntax-property right 'stepper-highlight))]))
|
||||
[else (list (stepper-syntax-property left 'stepper-highlight)
|
||||
(stepper-syntax-property right 'stepper-highlight))]))
|
||||
|
||||
;; mutated on receipt of a break, used in displaying breakpoint stuff.
|
||||
(define steps-received 0)
|
||||
|
|
@ -311,6 +312,7 @@
|
|||
(define (step-through-expression expanded expand-next-expression)
|
||||
(let* ([annotated (a:annotate expanded break track-inferred-names?
|
||||
language-level)])
|
||||
(>>> "annotation complete")
|
||||
(eval-syntax annotated)
|
||||
(expand-next-expression)))
|
||||
|
||||
|
|
@ -326,8 +328,8 @@
|
|||
(program-expander
|
||||
(lambda ()
|
||||
;; swap these to allow errors to escape (e.g., when debugging)
|
||||
(error-display-handler err-display-handler)
|
||||
;;(void)
|
||||
;;(error-display-handler err-display-handler)
|
||||
(void)
|
||||
)
|
||||
(lambda (expanded continue-thunk) ; iter
|
||||
(r:reset-special-values)
|
||||
|
|
|
|||
|
|
@ -4,6 +4,7 @@
|
|||
(prefix f: (lib "framework.ss" "framework"))
|
||||
(lib "pretty.ss")
|
||||
"testing-shared.ss"
|
||||
"shared.ss"
|
||||
(lib "string-constant.ss" "string-constants")
|
||||
(lib "bitmap-label.ss" "mrlib"))
|
||||
|
||||
|
|
@ -487,7 +488,7 @@
|
|||
(define (strip-to-sexp stx highlight-table)
|
||||
(define (strip-regular 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)
|
||||
stx)]
|
||||
[it
|
||||
|
|
@ -499,7 +500,7 @@
|
|||
[else it])]
|
||||
[it
|
||||
(if (and (syntax? stx)
|
||||
(syntax-property stx 'stepper-highlight))
|
||||
(stepper-syntax-property stx 'stepper-highlight))
|
||||
(if (pair? it)
|
||||
(begin
|
||||
(hash-table-put! highlight-table it 'non-confusable)
|
||||
|
|
|
|||
|
|
@ -87,7 +87,7 @@
|
|||
|
||||
|
||||
(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
|
||||
(opt-lambda (val render-settings [assigned-name #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))])
|
||||
(if closure-record
|
||||
(let* ([mark (closure-record-mark closure-record)]
|
||||
|
|
@ -147,7 +147,7 @@
|
|||
#f]
|
||||
[(result-exp-break)
|
||||
;; 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/or-clauses-consumed 0)))]
|
||||
[(normal-break normal-break/values)
|
||||
|
|
@ -156,8 +156,8 @@
|
|||
(or
|
||||
;; don't stop for a double-break on a let that is the expansion of a 'begin'
|
||||
(let ([expr (mark-source (car mark-list))])
|
||||
(or (eq? (syntax-property expr 'stepper-hint) 'comes-from-begin)
|
||||
(syntax-property expr 'stepper-skip-double-break)))
|
||||
(or (eq? (stepper-syntax-property expr 'stepper-hint) 'comes-from-begin)
|
||||
(stepper-syntax-property expr 'stepper-skip-double-break)))
|
||||
(not (render-settings-lifting? render-settings)))]
|
||||
[(expr-finished-break define-struct-break late-let-break) #f]))
|
||||
|
||||
|
|
@ -167,14 +167,14 @@
|
|||
(with-handlers ([exn:fail:contract:variable? (lambda (dc-exn) #f)])
|
||||
(let ([val (lookup-binding mark-list varref)])
|
||||
(equal? (syntax-object->interned-datum (recon-value val render-settings))
|
||||
(syntax-object->interned-datum (case (syntax-property varref 'stepper-binding-type)
|
||||
(syntax-object->interned-datum (case (stepper-syntax-property varref 'stepper-binding-type)
|
||||
([let-bound]
|
||||
(binding-lifted-name mark-list varref))
|
||||
([non-lexical]
|
||||
varref)
|
||||
(else
|
||||
(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))))))))
|
||||
|
||||
(and (pair? mark-list)
|
||||
|
|
@ -182,7 +182,7 @@
|
|||
(or (kernel:kernel-syntax-case expr #f
|
||||
[id
|
||||
(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
|
||||
[(let-bound)
|
||||
(varref-skip-step? expr)]
|
||||
|
|
@ -308,8 +308,8 @@
|
|||
expr
|
||||
'discard
|
||||
(lambda (expr)
|
||||
(if (syntax-property expr 'stepper-prim-name)
|
||||
(syntax-property expr 'stepper-prim-name)
|
||||
(if (stepper-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 bindings)
|
||||
(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)
|
||||
(bound-identifier=? binding _))
|
||||
use-lifted-names)
|
||||
(syntax-property _
|
||||
(stepper-syntax-property _
|
||||
'stepper-lifted-name
|
||||
(binding-lifted-name mark-list _))
|
||||
_))
|
||||
|
|
@ -414,14 +414,14 @@
|
|||
use-lifted-names)))
|
||||
var
|
||||
|
||||
(case (syntax-property var 'stepper-binding-type)
|
||||
(case (stepper-syntax-property var 'stepper-binding-type)
|
||||
((lambda-bound)
|
||||
(recon-value (lookup-binding mark-list var) render-settings))
|
||||
((macro-bound)
|
||||
; for the moment, let-bound vars occur only in and/or :
|
||||
(recon-value (lookup-binding mark-list var) render-settings))
|
||||
((let-bound)
|
||||
(syntax-property var
|
||||
(stepper-syntax-property var
|
||||
'stepper-lifted-name
|
||||
(binding-lifted-name mark-list var)))
|
||||
((stepper-temp)
|
||||
|
|
@ -430,7 +430,7 @@
|
|||
(error 'recon-source-expr "can't get here: lexical identifier labeled as non-lexical"))
|
||||
(else
|
||||
(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
|
||||
(fixup-name
|
||||
var)]))]
|
||||
|
|
@ -444,7 +444,7 @@
|
|||
;; reconstruct-set!-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)
|
||||
(error 'reconstruct-inner "lambda-bound variables can't be mutated"))
|
||||
((macro-bound)
|
||||
|
|
@ -452,21 +452,21 @@
|
|||
(error 'reconstruct-inner "macro-bound variables can't occur in a set!"))
|
||||
((non-lexical) var)
|
||||
((let-bound)
|
||||
(syntax-property var
|
||||
(stepper-syntax-property var
|
||||
'stepper-lifted-name
|
||||
(binding-lifted-name mark-list var)))
|
||||
((stepper-temp)
|
||||
(error 'recon-source-expr "stepper-temp showed up in source?!?"))
|
||||
(else
|
||||
(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 out any elements of the list with 'stepper-skip-completely set, except those with stepper-prim-name set. (HACK).
|
||||
(define (filter-skipped los)
|
||||
(filter (lambda (stx)
|
||||
(or (syntax-property stx 'stepper-prim-name)
|
||||
(not (syntax-property stx 'stepper-skip-completely))))
|
||||
(or (stepper-syntax-property stx 'stepper-prim-name)
|
||||
(not (stepper-syntax-property stx 'stepper-skip-completely))))
|
||||
los))
|
||||
|
||||
|
||||
|
|
@ -513,15 +513,15 @@
|
|||
(if lifting-indices
|
||||
(syntax-case exp ()
|
||||
[(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)
|
||||
lifting-indices)])
|
||||
(vector (reconstruct-completed-define exp vars (vals-getter) render-settings) #f))])
|
||||
(let ([exp (skipto/auto exp 'discard (lambda (exp) exp))])
|
||||
(cond
|
||||
[(syntax-property exp 'stepper-define-struct-hint)
|
||||
[(stepper-syntax-property exp 'stepper-define-struct-hint)
|
||||
;; 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
|
||||
(vector
|
||||
(kernel:kernel-syntax-case exp #f
|
||||
|
|
@ -625,7 +625,7 @@
|
|||
(map (lambda (binding-set rhs)
|
||||
(make-let-glump
|
||||
(map (lambda (binding)
|
||||
(syntax-property binding
|
||||
(stepper-syntax-property binding
|
||||
'stepper-lifted-name
|
||||
(binding-lifted-name mark-list binding)))
|
||||
binding-set)
|
||||
|
|
@ -669,10 +669,10 @@
|
|||
null)]
|
||||
[recon-bindings (append before-bindings after-bindings)]
|
||||
;; 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...)
|
||||
[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))]
|
||||
[rectified-bodies
|
||||
(map (lambda (body offset-index)
|
||||
|
|
@ -682,7 +682,7 @@
|
|||
bodies
|
||||
(iota (length bodies)))])
|
||||
(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 ()
|
||||
[(begin . bodies)
|
||||
|
|
|
|||
|
|
@ -88,8 +88,26 @@
|
|||
get-set-pair-union-stats ; profiling info
|
||||
re-intern-identifier
|
||||
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:
|
||||
; (make-before-after-result finished-exps exp redex reduct)
|
||||
|
|
@ -325,7 +343,7 @@
|
|||
(apply map list args)))
|
||||
|
||||
(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):
|
||||
|
|
@ -432,14 +450,14 @@
|
|||
;; traversal argument is 'discard, the result of the transformation is the
|
||||
;; result of this function
|
||||
(define (skipto/auto stx traversal transformer)
|
||||
(cond [(syntax-property stx 'stepper-skipto)
|
||||
(cond [(stepper-syntax-property stx 'stepper-skipto)
|
||||
=>
|
||||
(cut update <> stx (cut skipto/auto <> traversal transformer) traversal)]
|
||||
[else (transformer stx)]))
|
||||
|
||||
; small test case:
|
||||
#;(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
|
||||
'(syntax-e cdr car)))
|
||||
'stepper-skipto
|
||||
|
|
@ -531,54 +549,25 @@
|
|||
(sublist 0 (- end 1) (cdr lst)))
|
||||
(sublist (- begin 1) (- end 1) (cdr lst)))))
|
||||
|
||||
; attach-info : SYNTAX-OBJECT SYNTAX-OBJECT -> SYNTAX-OBJECT
|
||||
; attach-info attaches to a generated piece of syntax the origin & source
|
||||
; information of another. we do this so that macro unwinding can tell what
|
||||
; reconstructed syntax came from what original syntax
|
||||
|
||||
(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
|
||||
;; (from native property names to 'user-' style property names)
|
||||
|
||||
(define (attach-info to-exp from-exp)
|
||||
;; (if (syntax-property from-exp 'stepper-offset-index)
|
||||
;; (>>> (syntax-property from-exp 'stepper-offset-index)))
|
||||
(let* ([attached (foldl (lambda (labels stx)
|
||||
(match labels
|
||||
[`(,new-label ,old-label)
|
||||
(syntax-property stx new-label (syntax-property from-exp old-label))]))
|
||||
to-exp
|
||||
labels-to-attach)]
|
||||
;; (if (stepper-syntax-property from-exp 'stepper-offset-index)
|
||||
;; (>>> (stepper-syntax-property from-exp 'stepper-offset-index)))
|
||||
(let* ([attached (syntax-property to-exp 'stepper-properties (syntax-property from-exp 'stepper-properties))]
|
||||
[attached (syntax-property attached 'user-source (syntax-source from-exp))]
|
||||
[attached (syntax-property attached 'user-position (syntax-position from-exp))])
|
||||
attached))
|
||||
|
||||
;; transfer info from reconstructed expressions to other reconstructed
|
||||
;; expressions
|
||||
;; (from 'user-' style names to 'user-' style names)
|
||||
|
||||
(define (transfer-info to-stx from-exp)
|
||||
(let* ([attached (foldl (lambda (labels stx)
|
||||
(match labels
|
||||
[`(,new-label ,old-label)
|
||||
(syntax-property stx new-label (syntax-property from-exp new-label))]))
|
||||
to-stx
|
||||
labels-to-attach)]
|
||||
(define (transfer-info to-exp from-exp)
|
||||
(let* ([attached (syntax-property to-exp 'stepper-properties (append (syntax-property from-exp 'stepper-properties)
|
||||
(or (syntax-property to-exp 'stepper-properties)
|
||||
null)))]
|
||||
[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 'stepper-highlight (or (syntax-property from-exp 'stepper-highlight)
|
||||
(syntax-property attached 'stepper-highlight)))])
|
||||
[attached (syntax-property attached 'user-position (syntax-property from-exp 'user-position))])
|
||||
attached))
|
||||
|
||||
(define (values-map fn . lsts)
|
||||
|
|
@ -624,16 +613,16 @@
|
|||
[else (if (syntax? stx)
|
||||
(syntax-object->datum 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-scheme-box) `(scheme-box ,datum)]
|
||||
[(from-splice-box) `(splice-box ,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)]
|
||||
[else it])]
|
||||
[it (if (and (not ignore-highlight?)
|
||||
(syntax-property stx 'stepper-highlight))
|
||||
(stepper-syntax-property stx 'stepper-highlight))
|
||||
`(hilite ,it)
|
||||
it)])
|
||||
it))))
|
||||
|
|
@ -703,11 +692,14 @@
|
|||
|
||||
(define (language-level->name language)
|
||||
(car (last-pair (send language get-language-position))))
|
||||
|
||||
)
|
||||
|
||||
|
||||
; test cases
|
||||
;(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)
|
||||
; (syntax-object->datum (get-lifted-var sym)))
|
||||
|
|
@ -755,3 +747,10 @@
|
|||
; (list sums diffs)))
|
||||
; `((10 10 10 10 10)
|
||||
; (-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))
|
||||
|
||||
|
|
|
|||
|
|
@ -25,7 +25,7 @@
|
|||
(let stx-loop ([stx stx])
|
||||
(syntax-case stx (hilite)
|
||||
[(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)]
|
||||
[else stx]))
|
||||
(read-loop (read-syntax temp-file file-port))))))
|
||||
|
|
@ -43,13 +43,13 @@
|
|||
; (let ([test-stx (car test-run)])
|
||||
; (test `(+ x (+ 13 (a b)))
|
||||
; syntax-object->datum test-stx)
|
||||
; (test #f syntax-property test-stx 'stepper-highlight)
|
||||
; (test #t syntax-property (car (syntax-e (cdr (syntax-e test-stx)))) 'stepper-highlight)
|
||||
; (test #t syntax-property (syntax-case test-stx ()
|
||||
; (test #f stepper-syntax-property test-stx 'stepper-highlight)
|
||||
; (test #t stepper-syntax-property (car (syntax-e (cdr (syntax-e test-stx)))) 'stepper-highlight)
|
||||
; (test #t stepper-syntax-property (syntax-case test-stx ()
|
||||
; [(+ x target)
|
||||
; #`target])
|
||||
; '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))
|
||||
; #`target])
|
||||
; 'stepper-highlight)))
|
||||
|
|
|
|||
|
|
@ -17,10 +17,10 @@
|
|||
(define (rewrite-xml-error)
|
||||
(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-xml-box #f)
|
||||
(syntax-property
|
||||
(stepper-syntax-property
|
||||
(kernel:kernel-syntax-case stx #f
|
||||
[var-stx (identifier? (syntax var-stx)) (rewrite-xml-error)]
|
||||
|
||||
|
|
@ -61,7 +61,7 @@
|
|||
|
||||
[else
|
||||
(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)])))
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -4,7 +4,8 @@
|
|||
(lib "readerr.ss" "syntax")
|
||||
(lib "mred.ss" "mred")
|
||||
(lib "class.ss")
|
||||
(lib "list.ss"))
|
||||
(lib "list.ss")
|
||||
"shared.ss")
|
||||
|
||||
(provide xml-read-special
|
||||
xml-snip<%>
|
||||
|
|
@ -53,7 +54,7 @@
|
|||
[expd-xexpr (expand-embedded clean-xexpr)]
|
||||
[qq-body (datum->syntax-object #'here expd-xexpr (list editor #f #f #f #f))])
|
||||
(with-syntax ([qq-body qq-body])
|
||||
(syntax-property (syntax (quasiquote qq-body))
|
||||
(stepper-syntax-property (syntax (quasiquote qq-body))
|
||||
'stepper-xml-hint
|
||||
'from-xml-box))))
|
||||
(lambda () (send editor lock old-locked)))))
|
||||
|
|
@ -111,13 +112,13 @@
|
|||
(with-syntax ([err (syntax/loc
|
||||
(car (last-pair raw-stxs))
|
||||
(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)
|
||||
lst
|
||||
err))
|
||||
'stepper-xml-hint
|
||||
'from-splice-box))
|
||||
#`,#,(syntax-property #`(begin stxs ...)
|
||||
#`,#,(stepper-syntax-property #`(begin stxs ...)
|
||||
'stepper-xml-hint
|
||||
'from-scheme-box))))]
|
||||
[else xexpr])))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user