annotator now takes an optional parameter to restrict (by source)
which syntax objects will have breakpoint annotations installed; this is the "right way" (for now, with a single file), so i've removed a bunch of the old hacky restrictions that didn't really work top-level begins are no longer handled specially by the tool---just passed on to the annotator, which should do the right thing svn: r4206
This commit is contained in:
Greg Cooper
parent
3353d9a58d
commit
489e9c6ed9
|
|
@ -1,13 +1,9 @@
|
||||||
(module annotator mzscheme
|
(module annotator mzscheme
|
||||||
|
|
||||||
(require (prefix kernel: (lib "kerncase.ss" "syntax"))
|
(require (prefix kernel: (lib "kerncase.ss" "syntax"))
|
||||||
(lib "class.ss")
|
|
||||||
(lib "list.ss")
|
(lib "list.ss")
|
||||||
(lib "marks.ss" "mztake")
|
(lib "marks.ss" "mztake")
|
||||||
(lib "mred.ss" "mred")
|
(lib "etc.ss")
|
||||||
(lib "pretty.ss")
|
|
||||||
(lib "base-gm.ss" "frtime")
|
|
||||||
(lib "load-sandbox.ss" "mztake")
|
|
||||||
(prefix srfi: (lib "search.ss" "srfi" "1"))
|
(prefix srfi: (lib "search.ss" "srfi" "1"))
|
||||||
)
|
)
|
||||||
(provide annotate-stx annotate-for-single-stepping)
|
(provide annotate-stx annotate-for-single-stepping)
|
||||||
|
|
@ -58,47 +54,49 @@
|
||||||
;;
|
;;
|
||||||
;; RECORD-BOUND-ID and RECORD-TOP-LEVEL-ID are simply passed to ANNOTATE-STX.
|
;; RECORD-BOUND-ID and RECORD-TOP-LEVEL-ID are simply passed to ANNOTATE-STX.
|
||||||
|
|
||||||
(define (annotate-for-single-stepping stx break? break-before break-after record-bound-id record-top-level-id )
|
(define annotate-for-single-stepping
|
||||||
(annotate-stx
|
(opt-lambda (stx break? break-before break-after record-bound-id record-top-level-id [source #f])
|
||||||
stx
|
(annotate-stx
|
||||||
(lambda (debug-info annotated raw is-tail?)
|
stx
|
||||||
(let* ([start (syntax-position raw)]
|
(lambda (debug-info annotated raw is-tail?)
|
||||||
[end (+ start (syntax-span raw) -1)])
|
(let* ([start (syntax-position raw)]
|
||||||
(if is-tail?
|
[end (+ start (syntax-span raw) -1)])
|
||||||
#`(let-values ([(value-list) #f])
|
(if is-tail?
|
||||||
(if (#,break? #,start)
|
#`(let-values ([(value-list) #f])
|
||||||
(set! value-list (#,break-before
|
(if (#,break? #,start)
|
||||||
#,debug-info
|
(set! value-list (#,break-before
|
||||||
(current-continuation-marks))))
|
#,debug-info
|
||||||
(if (not value-list)
|
(current-continuation-marks))))
|
||||||
#,annotated
|
(if (not value-list)
|
||||||
(apply values value-list)))
|
#,annotated
|
||||||
#`(let-values ([(value-list) #f])
|
(apply values value-list)))
|
||||||
(if (#,break? #,start)
|
#`(let-values ([(value-list) #f])
|
||||||
(set! value-list (#,break-before
|
(if (#,break? #,start)
|
||||||
#,debug-info
|
(set! value-list (#,break-before
|
||||||
(current-continuation-marks))))
|
#,debug-info
|
||||||
(if (not value-list)
|
(current-continuation-marks))))
|
||||||
(call-with-values
|
(if (not value-list)
|
||||||
(lambda () #,annotated)
|
(call-with-values
|
||||||
(case-lambda
|
(lambda () #,annotated)
|
||||||
[(val) (if (#,break? #,end)
|
(case-lambda
|
||||||
(#,break-after
|
[(val) (if (#,break? #,end)
|
||||||
#,debug-info
|
(#,break-after
|
||||||
(current-continuation-marks) val)
|
#,debug-info
|
||||||
val)]
|
(current-continuation-marks) val)
|
||||||
[vals (if (#,break? #,end)
|
val)]
|
||||||
(apply #,break-after
|
[vals (if (#,break? #,end)
|
||||||
#,debug-info
|
(apply #,break-after
|
||||||
(current-continuation-marks) vals)
|
#,debug-info
|
||||||
(apply values vals))]))
|
(current-continuation-marks) vals)
|
||||||
(if (#,break? #,end)
|
(apply values vals))]))
|
||||||
(apply #,break-after
|
(if (#,break? #,end)
|
||||||
#,debug-info
|
(apply #,break-after
|
||||||
(current-continuation-marks) value-list)
|
#,debug-info
|
||||||
(apply values value-list)))))))
|
(current-continuation-marks) value-list)
|
||||||
record-bound-id
|
(apply values value-list)))))))
|
||||||
record-top-level-id ))
|
record-bound-id
|
||||||
|
record-top-level-id
|
||||||
|
source)))
|
||||||
|
|
||||||
|
|
||||||
; annotate-stx : (syntax?
|
; annotate-stx : (syntax?
|
||||||
|
|
@ -138,260 +136,261 @@
|
||||||
;;
|
;;
|
||||||
;; Naturally, when USE-CASE is 'bind, BOUND-STX and BINDING-STX are equal.
|
;; Naturally, when USE-CASE is 'bind, BOUND-STX and BINDING-STX are equal.
|
||||||
;;
|
;;
|
||||||
(define (annotate-stx stx break-wrap record-bound-id record-top-level-id)
|
(define annotate-stx
|
||||||
|
(opt-lambda (stx break-wrap record-bound-id record-top-level-id [source #f])
|
||||||
(define breakpoints (make-hash-table))
|
|
||||||
|
(define breakpoints (make-hash-table))
|
||||||
(define (previous-bindings bound-vars)
|
|
||||||
(if (null? bound-vars)
|
(define (previous-bindings bound-vars)
|
||||||
#'null
|
(if (null? bound-vars)
|
||||||
#'(debugger-local-bindings)))
|
#'null
|
||||||
|
#'(debugger-local-bindings)))
|
||||||
(define (top-level-annotate stx)
|
|
||||||
(kernel:kernel-syntax-case
|
(define (top-level-annotate stx)
|
||||||
stx #f
|
(kernel:kernel-syntax-case
|
||||||
[(module identifier name (#%plain-module-begin . module-level-exprs))
|
stx #f
|
||||||
(quasisyntax/loc stx (module identifier name
|
[(module identifier name (#%plain-module-begin . module-level-exprs))
|
||||||
(#%plain-module-begin
|
(quasisyntax/loc stx (module identifier name
|
||||||
#,@(map (lambda (e) (module-level-expr-iterator
|
(#%plain-module-begin
|
||||||
e (list (syntax-e #'identifier)
|
#,@(map (lambda (e) (module-level-expr-iterator
|
||||||
(syntax-source #'identifier))))
|
e (list (syntax-e #'identifier)
|
||||||
(syntax->list #'module-level-exprs)))))]
|
(syntax-source #'identifier))))
|
||||||
[else-stx
|
(syntax->list #'module-level-exprs)))))]
|
||||||
(general-top-level-expr-iterator stx #f )]))
|
[else-stx
|
||||||
|
(general-top-level-expr-iterator stx #f )]))
|
||||||
(define (module-level-expr-iterator stx module-name )
|
|
||||||
(kernel:kernel-syntax-case
|
(define (module-level-expr-iterator stx module-name )
|
||||||
stx #f
|
(kernel:kernel-syntax-case
|
||||||
[(provide . provide-specs)
|
stx #f
|
||||||
stx]
|
[(provide . provide-specs)
|
||||||
[else-stx
|
stx]
|
||||||
(general-top-level-expr-iterator stx module-name )]))
|
[else-stx
|
||||||
|
(general-top-level-expr-iterator stx module-name )]))
|
||||||
(define (general-top-level-expr-iterator stx module-name )
|
|
||||||
(kernel:kernel-syntax-case
|
(define (general-top-level-expr-iterator stx module-name )
|
||||||
stx #f
|
(kernel:kernel-syntax-case
|
||||||
[(define-values (var ...) expr)
|
stx #f
|
||||||
|
[(define-values (var ...) expr)
|
||||||
|
|
||||||
|
(begin
|
||||||
|
(for-each (lambda (v) (record-bound-id 'bind v v))
|
||||||
|
(syntax->list #'(var ...)))
|
||||||
|
(quasisyntax/loc stx
|
||||||
|
(begin (define-values (var ...) #,(annotate #`expr empty #t module-name))
|
||||||
|
#,(if (syntax-source stx)
|
||||||
|
#`(begin (#,record-top-level-id '#,module-name #'var (case-lambda
|
||||||
|
[() var]
|
||||||
|
[(v) (set! var v)])) ...)
|
||||||
|
#'(void))
|
||||||
|
(void)))
|
||||||
|
)
|
||||||
|
]
|
||||||
|
[(define-syntaxes (var ...) expr)
|
||||||
|
stx]
|
||||||
|
[(define-values-for-syntax (var ...) expr)
|
||||||
|
;; define-values-for-syntax's RHS is compile time, so treat it
|
||||||
|
;; like define-syntaxes
|
||||||
|
stx]
|
||||||
|
[(begin . top-level-exprs)
|
||||||
|
(quasisyntax/loc stx (begin #,@(map (lambda (expr)
|
||||||
|
(module-level-expr-iterator expr module-name ))
|
||||||
|
(syntax->list #'top-level-exprs))))]
|
||||||
|
[(require . require-specs)
|
||||||
|
stx]
|
||||||
|
[(require-for-syntax . require-specs)
|
||||||
|
stx]
|
||||||
|
[(require-for-template dot require-specs) stx]
|
||||||
|
[else
|
||||||
|
(annotate stx '() #f module-name )]))
|
||||||
|
|
||||||
|
(define (annotate expr bound-vars is-tail? module-name )
|
||||||
|
|
||||||
(begin
|
(define annotate-break?
|
||||||
(for-each (lambda (v) (record-bound-id 'bind v v))
|
(let ([pos (syntax-position expr)]
|
||||||
(syntax->list #'(var ...)))
|
[src (syntax-source expr)])
|
||||||
(quasisyntax/loc stx
|
(and (or (not source)
|
||||||
(begin (define-values (var ...) #,(annotate #`expr empty #t module-name))
|
(eq? src source #;(syntax-source stx)))
|
||||||
#,(if (syntax-source stx)
|
; (is-a? src object%) ; FIX THIS
|
||||||
#`(begin (#,record-top-level-id '#,module-name #'var (case-lambda
|
pos
|
||||||
[() var]
|
(hash-table-get breakpoints pos (lambda () #t))
|
||||||
[(v) (set! var v)])) ...)
|
(kernel:kernel-syntax-case
|
||||||
#'(void))
|
expr #f
|
||||||
(void)))
|
[(if test then) #t]
|
||||||
)
|
[(if test then else) #t]
|
||||||
]
|
[(begin . bodies) #t]
|
||||||
[(define-syntaxes (var ...) expr)
|
[(begin0 . bodies) #t]
|
||||||
stx]
|
[(let-values . clause) #t]
|
||||||
[(define-values-for-syntax (var ...) expr)
|
[(letrec-values . clause) #t]
|
||||||
;; define-values-for-syntax's RHS is compile time, so treat it
|
[(set! var val) #t]
|
||||||
;; like define-syntaxes
|
[(with-continuation-mark key mark body) #t]
|
||||||
stx]
|
[(#%app . exprs) #t]
|
||||||
[(begin . top-level-exprs)
|
[_ #f])
|
||||||
(quasisyntax/loc stx (begin #,@(map (lambda (expr)
|
(begin
|
||||||
(module-level-expr-iterator expr module-name ))
|
(hash-table-put! breakpoints pos #f)
|
||||||
(syntax->list #'top-level-exprs))))]
|
(when (not is-tail?)
|
||||||
[(require . require-specs)
|
(hash-table-put! breakpoints (+ pos (syntax-span expr) -1) #f))
|
||||||
stx]
|
#t))))
|
||||||
[(require-for-syntax . require-specs)
|
|
||||||
stx]
|
(define (let/rec-values-annotator letrec?)
|
||||||
[(require-for-template dot require-specs) stx]
|
(kernel:kernel-syntax-case
|
||||||
[else
|
expr #f
|
||||||
(annotate stx '() #f module-name )]))
|
[(label (((var ...) rhs) ...) . bodies)
|
||||||
|
(let* ([new-bindings (apply append
|
||||||
(define (annotate expr bound-vars is-tail? module-name )
|
(map syntax->list
|
||||||
|
(syntax->list #`((var ...) ...))))]
|
||||||
(define annotate-break?
|
[all-bindings (append new-bindings bound-vars)]
|
||||||
(let ([pos (syntax-position expr)]
|
[new-rhs (map (lambda (expr)
|
||||||
[src (syntax-source expr)])
|
(annotate expr
|
||||||
(and src
|
(if letrec? all-bindings bound-vars)
|
||||||
(eq? src (syntax-source stx))
|
#f module-name ))
|
||||||
; (is-a? src object%) ; FIX THIS
|
(syntax->list #'(rhs ...)))]
|
||||||
pos
|
[last-body (car (reverse (syntax->list #'bodies)))]
|
||||||
(hash-table-get breakpoints pos (lambda () #t))
|
[all-but-last-body (reverse (cdr (reverse (syntax->list #'bodies))))]
|
||||||
(kernel:kernel-syntax-case
|
[bodies (append (map (lambda (expr)
|
||||||
expr #f
|
(annotate expr all-bindings #f module-name ))
|
||||||
[(if test then) #t]
|
all-but-last-body)
|
||||||
[(if test then else) #t]
|
(list (annotate
|
||||||
[(begin . bodies) #t]
|
last-body
|
||||||
[(begin0 . bodies) #t]
|
all-bindings
|
||||||
[(let-values . clause) #t]
|
is-tail? module-name )))]
|
||||||
[(letrec-values . clause) #t]
|
[local-debug-info (assemble-debug-info new-bindings new-bindings 'normal #f)]
|
||||||
[(set! var val) #t]
|
[previous-bindings (previous-bindings bound-vars)])
|
||||||
[(with-continuation-mark key mark body) #t]
|
(for-each (lambda (id) (record-bound-id 'bind id id)) new-bindings)
|
||||||
[(#%app . exprs) #t]
|
(with-syntax ([(new-rhs/trans ...) new-rhs]
|
||||||
[_ #f])
|
[previous-bindings previous-bindings])
|
||||||
(begin
|
(if letrec?
|
||||||
(hash-table-put! breakpoints pos #f)
|
(quasisyntax/loc expr
|
||||||
(when (not is-tail?)
|
(let ([old-bindings previous-bindings])
|
||||||
(hash-table-put! breakpoints (+ pos (syntax-span expr) -1) #f))
|
(label (((debugger-local-bindings) (lambda ()
|
||||||
#t))))
|
(list*
|
||||||
|
#,@local-debug-info
|
||||||
(define (let/rec-values-annotator letrec?)
|
old-bindings)))
|
||||||
(kernel:kernel-syntax-case
|
((var ...) new-rhs/trans) ...)
|
||||||
expr #f
|
#,@bodies)))
|
||||||
[(label (((var ...) rhs) ...) . bodies)
|
(quasisyntax/loc expr
|
||||||
(let* ([new-bindings (apply append
|
(label (((var ...) new-rhs/trans) ...)
|
||||||
(map syntax->list
|
(let ([debugger-local-bindings (lambda ()
|
||||||
(syntax->list #`((var ...) ...))))]
|
(list*
|
||||||
[all-bindings (append new-bindings bound-vars)]
|
#,@local-debug-info
|
||||||
[new-rhs (map (lambda (expr)
|
previous-bindings))])
|
||||||
(annotate expr
|
#,@bodies))))))]))
|
||||||
(if letrec? all-bindings bound-vars)
|
|
||||||
#f module-name ))
|
(define (lambda-clause-annotator clause)
|
||||||
(syntax->list #'(rhs ...)))]
|
(kernel:kernel-syntax-case
|
||||||
[last-body (car (reverse (syntax->list #'bodies)))]
|
clause #f
|
||||||
[all-but-last-body (reverse (cdr (reverse (syntax->list #'bodies))))]
|
[(arg-list . bodies)
|
||||||
[bodies (append (map (lambda (expr)
|
(let* ([new-bound-vars (arglist-bindings #'arg-list)]
|
||||||
(annotate expr all-bindings #f module-name ))
|
[all-bound-vars (append new-bound-vars bound-vars)]
|
||||||
all-but-last-body)
|
[new-bodies (let loop ([bodies (syntax->list #'bodies)])
|
||||||
(list (annotate
|
(if (equal? '() (cdr bodies))
|
||||||
last-body
|
(list (annotate (car bodies) all-bound-vars #t module-name ))
|
||||||
all-bindings
|
(cons (annotate (car bodies) all-bound-vars #f module-name )
|
||||||
is-tail? module-name )))]
|
(loop (cdr bodies)))))])
|
||||||
[local-debug-info (assemble-debug-info new-bindings new-bindings 'normal #f)]
|
(for-each (lambda (id) (record-bound-id 'bind id id)) new-bound-vars)
|
||||||
[previous-bindings (previous-bindings bound-vars)])
|
(quasisyntax/loc clause
|
||||||
(for-each (lambda (id) (record-bound-id 'bind id id)) new-bindings)
|
(arg-list
|
||||||
(with-syntax ([(new-rhs/trans ...) new-rhs]
|
(let ([debugger-local-bindings
|
||||||
[previous-bindings previous-bindings])
|
(lambda ()
|
||||||
(if letrec?
|
(list*
|
||||||
(quasisyntax/loc expr
|
#,@(assemble-debug-info new-bound-vars new-bound-vars 'normal #f)
|
||||||
(let ([old-bindings previous-bindings])
|
#,(previous-bindings bound-vars)))])
|
||||||
(label (((debugger-local-bindings) (lambda ()
|
#,@new-bodies))))]))
|
||||||
(list*
|
|
||||||
#,@local-debug-info
|
(define annotated
|
||||||
old-bindings)))
|
(syntax-recertify
|
||||||
((var ...) new-rhs/trans) ...)
|
(kernel:kernel-syntax-case
|
||||||
#,@bodies)))
|
expr #f
|
||||||
(quasisyntax/loc expr
|
[var-stx (identifier? (syntax var-stx))
|
||||||
(label (((var ...) new-rhs/trans) ...)
|
(let ([binder (and (syntax-original? expr)
|
||||||
(let ([debugger-local-bindings (lambda ()
|
(srfi:member expr bound-vars module-identifier=?))])
|
||||||
(list*
|
(if binder
|
||||||
#,@local-debug-info
|
(let ([f (first binder)])
|
||||||
previous-bindings))])
|
(record-bound-id 'ref expr f))
|
||||||
#,@bodies))))))]))
|
(record-bound-id 'top-level expr expr))
|
||||||
|
expr)]
|
||||||
(define (lambda-clause-annotator clause)
|
|
||||||
(kernel:kernel-syntax-case
|
[(lambda . clause)
|
||||||
clause #f
|
(quasisyntax/loc expr
|
||||||
[(arg-list . bodies)
|
(lambda #,@(lambda-clause-annotator #'clause)))]
|
||||||
(let* ([new-bound-vars (arglist-bindings #'arg-list)]
|
|
||||||
[all-bound-vars (append new-bound-vars bound-vars)]
|
[(case-lambda . clauses)
|
||||||
[new-bodies (let loop ([bodies (syntax->list #'bodies)])
|
(quasisyntax/loc expr
|
||||||
(if (equal? '() (cdr bodies))
|
(case-lambda #,@(map lambda-clause-annotator (syntax->list #'clauses))))]
|
||||||
(list (annotate (car bodies) all-bound-vars #t module-name ))
|
|
||||||
(cons (annotate (car bodies) all-bound-vars #f module-name )
|
[(if test then)
|
||||||
(loop (cdr bodies)))))])
|
(quasisyntax/loc expr (if #,(annotate #'test bound-vars #f module-name )
|
||||||
(for-each (lambda (id) (record-bound-id 'bind id id)) new-bound-vars)
|
#,(annotate #'then bound-vars is-tail? module-name )))]
|
||||||
(quasisyntax/loc clause
|
|
||||||
(arg-list
|
[(if test then else)
|
||||||
(let ([debugger-local-bindings
|
(quasisyntax/loc expr (if #,(annotate #'test bound-vars #f module-name )
|
||||||
(lambda ()
|
#,(annotate #'then bound-vars is-tail? module-name )
|
||||||
(list*
|
#,(annotate #'else bound-vars is-tail? module-name )))]
|
||||||
#,@(assemble-debug-info new-bound-vars new-bound-vars 'normal #f)
|
|
||||||
#,(previous-bindings bound-vars)))])
|
[(begin . bodies)
|
||||||
#,@new-bodies))))]))
|
(letrec ([traverse
|
||||||
|
(lambda (lst)
|
||||||
(define annotated
|
(if (and (pair? lst) (equal? '() (cdr lst)))
|
||||||
(syntax-recertify
|
`(,(annotate (car lst) bound-vars is-tail? module-name ))
|
||||||
(kernel:kernel-syntax-case
|
(cons (annotate (car lst) bound-vars #f module-name )
|
||||||
expr #f
|
(traverse (cdr lst)))))])
|
||||||
[var-stx (identifier? (syntax var-stx))
|
(quasisyntax/loc expr (begin #,@(traverse (syntax->list #'bodies)))))]
|
||||||
(let ([binder (and (syntax-original? expr)
|
|
||||||
(srfi:member expr bound-vars module-identifier=?))])
|
[(begin0 . bodies)
|
||||||
(if binder
|
(quasisyntax/loc expr (begin0 #,@(map (lambda (expr)
|
||||||
(let ([f (first binder)])
|
(annotate expr bound-vars #f module-name ))
|
||||||
(record-bound-id 'ref expr f))
|
(syntax->list #'bodies))))]
|
||||||
(record-bound-id 'top-level expr expr))
|
|
||||||
expr)]
|
[(let-values . clause)
|
||||||
|
(let/rec-values-annotator #f)]
|
||||||
[(lambda . clause)
|
|
||||||
(quasisyntax/loc expr
|
[(letrec-values . clause)
|
||||||
(lambda #,@(lambda-clause-annotator #'clause)))]
|
(let/rec-values-annotator #t)]
|
||||||
|
|
||||||
[(case-lambda . clauses)
|
[(set! var val)
|
||||||
(quasisyntax/loc expr
|
(let ([binder (and (syntax-original? #'var)
|
||||||
(case-lambda #,@(map lambda-clause-annotator (syntax->list #'clauses))))]
|
(srfi:member #'var bound-vars module-identifier=?))])
|
||||||
|
(when binder
|
||||||
[(if test then)
|
(let ([f (first binder)])
|
||||||
(quasisyntax/loc expr (if #,(annotate #'test bound-vars #f module-name )
|
(record-bound-id 'set expr f)))
|
||||||
#,(annotate #'then bound-vars is-tail? module-name )))]
|
(quasisyntax/loc expr (set! var #,(annotate #`val bound-vars #f module-name ))))]
|
||||||
|
|
||||||
[(if test then else)
|
[(quote _) expr]
|
||||||
(quasisyntax/loc expr (if #,(annotate #'test bound-vars #f module-name )
|
|
||||||
#,(annotate #'then bound-vars is-tail? module-name )
|
[(quote-syntax _) expr]
|
||||||
#,(annotate #'else bound-vars is-tail? module-name )))]
|
|
||||||
|
[(with-continuation-mark key mark body)
|
||||||
[(begin . bodies)
|
(quasisyntax/loc expr (with-continuation-mark key
|
||||||
(letrec ([traverse
|
#,(annotate #'mark bound-vars #f module-name )
|
||||||
(lambda (lst)
|
#,(annotate #'body bound-vars is-tail? module-name )))]
|
||||||
(if (and (pair? lst) (equal? '() (cdr lst)))
|
|
||||||
`(,(annotate (car lst) bound-vars is-tail? module-name ))
|
[(#%app . exprs)
|
||||||
(cons (annotate (car lst) bound-vars #f module-name )
|
(let ([subexprs (map (lambda (expr)
|
||||||
(traverse (cdr lst)))))])
|
(annotate expr bound-vars #f module-name ))
|
||||||
(quasisyntax/loc expr (begin #,@(traverse (syntax->list #'bodies)))))]
|
(syntax->list #'exprs))])
|
||||||
|
(if is-tail?
|
||||||
[(begin0 . bodies)
|
(quasisyntax/loc expr #,subexprs)
|
||||||
(quasisyntax/loc expr (begin0 #,@(map (lambda (expr)
|
(wcm-wrap (make-debug-info module-name expr bound-vars bound-vars 'normal #f (previous-bindings bound-vars))
|
||||||
(annotate expr bound-vars #f module-name ))
|
(quasisyntax/loc expr #,subexprs))))]
|
||||||
(syntax->list #'bodies))))]
|
|
||||||
|
[(#%datum . _) expr]
|
||||||
[(let-values . clause)
|
|
||||||
(let/rec-values-annotator #f)]
|
[(#%top . var) expr]
|
||||||
|
|
||||||
[(letrec-values . clause)
|
[else (error 'expr-syntax-object-iterator "unknown expr: ~a"
|
||||||
(let/rec-values-annotator #t)]
|
(syntax-object->datum expr))])
|
||||||
|
|
||||||
[(set! var val)
|
|
||||||
(let ([binder (and (syntax-original? #'var)
|
|
||||||
(srfi:member #'var bound-vars module-identifier=?))])
|
|
||||||
(when binder
|
|
||||||
(let ([f (first binder)])
|
|
||||||
(record-bound-id 'set expr f)))
|
|
||||||
(quasisyntax/loc expr (set! var #,(annotate #`val bound-vars #f module-name ))))]
|
|
||||||
|
|
||||||
[(quote _) expr]
|
|
||||||
|
|
||||||
[(quote-syntax _) expr]
|
|
||||||
|
|
||||||
[(with-continuation-mark key mark body)
|
|
||||||
(quasisyntax/loc expr (with-continuation-mark key
|
|
||||||
#,(annotate #'mark bound-vars #f module-name )
|
|
||||||
#,(annotate #'body bound-vars is-tail? module-name )))]
|
|
||||||
|
|
||||||
[(#%app . exprs)
|
|
||||||
(let ([subexprs (map (lambda (expr)
|
|
||||||
(annotate expr bound-vars #f module-name ))
|
|
||||||
(syntax->list #'exprs))])
|
|
||||||
(if is-tail?
|
|
||||||
(quasisyntax/loc expr #,subexprs)
|
|
||||||
(wcm-wrap (make-debug-info module-name expr bound-vars bound-vars 'normal #f (previous-bindings bound-vars))
|
|
||||||
(quasisyntax/loc expr #,subexprs))))]
|
|
||||||
|
|
||||||
[(#%datum . _) expr]
|
|
||||||
|
|
||||||
[(#%top . var) expr]
|
|
||||||
|
|
||||||
[else (error 'expr-syntax-object-iterator "unknown expr: ~a"
|
|
||||||
(syntax-object->datum expr))])
|
|
||||||
expr
|
|
||||||
(current-code-inspector)
|
|
||||||
#f))
|
|
||||||
|
|
||||||
(if annotate-break?
|
|
||||||
(break-wrap
|
|
||||||
(make-debug-info module-name expr bound-vars bound-vars 'at-break #f (previous-bindings bound-vars))
|
|
||||||
annotated
|
|
||||||
expr
|
expr
|
||||||
is-tail?)
|
(current-code-inspector)
|
||||||
annotated))
|
#f))
|
||||||
|
|
||||||
(values (top-level-annotate stx) (hash-table-map breakpoints (lambda (k v) k))))
|
(if annotate-break?
|
||||||
|
(break-wrap
|
||||||
|
(make-debug-info module-name expr bound-vars bound-vars 'at-break #f (previous-bindings bound-vars))
|
||||||
|
annotated
|
||||||
|
expr
|
||||||
|
is-tail?)
|
||||||
|
annotated))
|
||||||
|
|
||||||
|
(values (top-level-annotate stx) (hash-table-map breakpoints (lambda (k v) k)))))
|
||||||
|
|
||||||
#;
|
#;
|
||||||
(define (tests)
|
(define (tests)
|
||||||
|
|
|
||||||
|
|
@ -279,15 +279,15 @@
|
||||||
[f (get-top-level-window)]
|
[f (get-top-level-window)]
|
||||||
[rendered-value (if (cons? stat)
|
[rendered-value (if (cons? stat)
|
||||||
(if (= 2 (length stat))
|
(if (= 2 (length stat))
|
||||||
(render (cadr stat))
|
(render (cadr stat))
|
||||||
(format "~a" (cons 'values
|
(format "~a" (cons 'values
|
||||||
(map (lambda (v) (render v)) (rest stat)))))
|
(map (lambda (v) (render v)) (rest stat)))))
|
||||||
"")])
|
"")])
|
||||||
(when (cons? stat)
|
(when (cons? stat)
|
||||||
#;(send (make-object menu-item%
|
#;(send (make-object menu-item%
|
||||||
(clean-status (format "expr -> ~a" rendered-value))
|
(clean-status (format "expr -> ~a" rendered-value))
|
||||||
menu
|
menu
|
||||||
void) enable #f)
|
void) enable #f)
|
||||||
(make-object menu-item%
|
(make-object menu-item%
|
||||||
"Print return value to console"
|
"Print return value to console"
|
||||||
menu
|
menu
|
||||||
|
|
@ -451,72 +451,56 @@
|
||||||
;; adds debugging information to `sexp' and calls `oe'
|
;; adds debugging information to `sexp' and calls `oe'
|
||||||
(define/private (make-debug-eval-handler oe break? break-before break-after)
|
(define/private (make-debug-eval-handler oe break? break-before break-after)
|
||||||
(lambda (orig-exp)
|
(lambda (orig-exp)
|
||||||
(if (or (compiled-expression? (if (syntax? orig-exp)
|
(if (compiled-expression? (if (syntax? orig-exp)
|
||||||
(syntax-e orig-exp)
|
(syntax-e orig-exp)
|
||||||
orig-exp))
|
orig-exp))
|
||||||
(not (robust-syntax-source orig-exp))
|
|
||||||
(not (eq? (robust-syntax-source orig-exp)
|
|
||||||
(send (get-tab) get-defs))))
|
|
||||||
(oe orig-exp)
|
(oe orig-exp)
|
||||||
(let loop ([exp (if (syntax? orig-exp)
|
(let loop ([exp (if (syntax? orig-exp)
|
||||||
orig-exp
|
orig-exp
|
||||||
(namespace-syntax-introduce
|
(namespace-syntax-introduce
|
||||||
(datum->syntax-object #f orig-exp)))])
|
(datum->syntax-object #f orig-exp)))])
|
||||||
(let ([top-e (expand-syntax-to-top-form exp)])
|
(let ([top-e (expand-syntax-to-top-form exp)])
|
||||||
(syntax-case top-e (begin)
|
(parameterize ([current-eval oe])
|
||||||
[(begin expr ...)
|
(eval/annotations
|
||||||
;; Found a `begin', so expand/eval each contained
|
top-e
|
||||||
;; expression one at a time
|
(lambda (fn m) #f) ; TODO: multiple file support
|
||||||
(let i-loop ([exprs (syntax->list #'(expr ...))]
|
(lambda (stx)
|
||||||
[last-one (list (void))])
|
(let*-values ([(breakpoints) (send (get-tab) get-breakpoints)]
|
||||||
(cond
|
[(pos-vec) (send (get-tab) get-pos-vec)]
|
||||||
[(null? exprs) (apply values last-one)]
|
[(annotated break-posns)
|
||||||
[else (i-loop (cdr exprs)
|
(annotate-for-single-stepping
|
||||||
(call-with-values
|
(expand-syntax top-e)
|
||||||
(lambda () (loop (car exprs)))
|
break?
|
||||||
list))]))]
|
break-before
|
||||||
[_else
|
break-after
|
||||||
;; Not `begin', so proceed with normal expand and eval
|
(lambda (type bound binding)
|
||||||
(parameterize ([current-eval oe])
|
;(display-results (list bound))
|
||||||
(eval/annotations
|
(when (eq? (robust-syntax-source bound)
|
||||||
top-e
|
(robust-syntax-source exp))
|
||||||
(lambda (fn m) #f) ; TODO: multiple file support
|
(let loop ([i 0])
|
||||||
(lambda (stx)
|
(when (< i (syntax-span bound))
|
||||||
(let*-values ([(breakpoints) (send (get-tab) get-breakpoints)]
|
(vector-set! pos-vec (+ i (syntax-position bound)) binding)
|
||||||
[(pos-vec) (send (get-tab) get-pos-vec)]
|
(loop (add1 i))))))
|
||||||
[(annotated break-posns)
|
(lambda (mod var val)
|
||||||
(annotate-for-single-stepping
|
(send (get-tab) add-top-level-binding var val)
|
||||||
(expand-syntax top-e)
|
#;
|
||||||
break?
|
(printf "top-level binding: ~a ~a ~a~n" mod var val))
|
||||||
break-before
|
(send (get-tab) get-defs))])
|
||||||
break-after
|
(hash-table-for-each
|
||||||
(lambda (type bound binding)
|
breakpoints
|
||||||
;(display-results (list bound))
|
(lambda (pos status)
|
||||||
(when (eq? (robust-syntax-source bound)
|
; possible efficiency problem for large files with many breakpoints
|
||||||
(robust-syntax-source exp))
|
(when (and (syntax-position top-e)
|
||||||
(let loop ([i 0])
|
(>= pos (syntax-position top-e))
|
||||||
(when (< i (syntax-span bound))
|
(< pos (+ (syntax-position top-e) (syntax-span top-e)))
|
||||||
(vector-set! pos-vec (+ i (syntax-position bound)) binding)
|
(not (memq pos break-posns)))
|
||||||
(loop (add1 i))))))
|
(hash-table-remove! breakpoints pos))))
|
||||||
(lambda (mod var val)
|
(for-each (lambda (posn)
|
||||||
(send (get-tab) add-top-level-binding var val)
|
(hash-table-put!
|
||||||
#;
|
breakpoints posn
|
||||||
(printf "top-level binding: ~a ~a ~a~n" mod var val)))])
|
(hash-table-get breakpoints posn (lambda () #f)))) break-posns)
|
||||||
(hash-table-for-each
|
;(display-results (list orig-exp))
|
||||||
breakpoints
|
annotated)))))))))
|
||||||
(lambda (pos status)
|
|
||||||
; possible efficiency problem for large files with many breakpoints
|
|
||||||
(when (and (syntax-position top-e)
|
|
||||||
(>= pos (syntax-position top-e))
|
|
||||||
(< pos (+ (syntax-position top-e) (syntax-span top-e)))
|
|
||||||
(not (memq pos break-posns)))
|
|
||||||
(hash-table-remove! breakpoints pos))))
|
|
||||||
(for-each (lambda (posn)
|
|
||||||
(hash-table-put!
|
|
||||||
breakpoints posn
|
|
||||||
(hash-table-get breakpoints posn (lambda () #f)))) break-posns)
|
|
||||||
;(display-results (list orig-exp))
|
|
||||||
annotated))))]))))))
|
|
||||||
|
|
||||||
(define/override (reset-console)
|
(define/override (reset-console)
|
||||||
(super reset-console)
|
(super reset-console)
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue
Block a user