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
|
||||
|
||||
(require (prefix kernel: (lib "kerncase.ss" "syntax"))
|
||||
(lib "class.ss")
|
||||
(lib "list.ss")
|
||||
(lib "marks.ss" "mztake")
|
||||
(lib "mred.ss" "mred")
|
||||
(lib "pretty.ss")
|
||||
(lib "base-gm.ss" "frtime")
|
||||
(lib "load-sandbox.ss" "mztake")
|
||||
(lib "etc.ss")
|
||||
(prefix srfi: (lib "search.ss" "srfi" "1"))
|
||||
)
|
||||
(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.
|
||||
|
||||
(define (annotate-for-single-stepping stx break? break-before break-after record-bound-id record-top-level-id )
|
||||
(annotate-stx
|
||||
stx
|
||||
(lambda (debug-info annotated raw is-tail?)
|
||||
(let* ([start (syntax-position raw)]
|
||||
[end (+ start (syntax-span raw) -1)])
|
||||
(if is-tail?
|
||||
#`(let-values ([(value-list) #f])
|
||||
(if (#,break? #,start)
|
||||
(set! value-list (#,break-before
|
||||
#,debug-info
|
||||
(current-continuation-marks))))
|
||||
(if (not value-list)
|
||||
#,annotated
|
||||
(apply values value-list)))
|
||||
#`(let-values ([(value-list) #f])
|
||||
(if (#,break? #,start)
|
||||
(set! value-list (#,break-before
|
||||
#,debug-info
|
||||
(current-continuation-marks))))
|
||||
(if (not value-list)
|
||||
(call-with-values
|
||||
(lambda () #,annotated)
|
||||
(case-lambda
|
||||
[(val) (if (#,break? #,end)
|
||||
(#,break-after
|
||||
#,debug-info
|
||||
(current-continuation-marks) val)
|
||||
val)]
|
||||
[vals (if (#,break? #,end)
|
||||
(apply #,break-after
|
||||
#,debug-info
|
||||
(current-continuation-marks) vals)
|
||||
(apply values vals))]))
|
||||
(if (#,break? #,end)
|
||||
(apply #,break-after
|
||||
#,debug-info
|
||||
(current-continuation-marks) value-list)
|
||||
(apply values value-list)))))))
|
||||
record-bound-id
|
||||
record-top-level-id ))
|
||||
(define annotate-for-single-stepping
|
||||
(opt-lambda (stx break? break-before break-after record-bound-id record-top-level-id [source #f])
|
||||
(annotate-stx
|
||||
stx
|
||||
(lambda (debug-info annotated raw is-tail?)
|
||||
(let* ([start (syntax-position raw)]
|
||||
[end (+ start (syntax-span raw) -1)])
|
||||
(if is-tail?
|
||||
#`(let-values ([(value-list) #f])
|
||||
(if (#,break? #,start)
|
||||
(set! value-list (#,break-before
|
||||
#,debug-info
|
||||
(current-continuation-marks))))
|
||||
(if (not value-list)
|
||||
#,annotated
|
||||
(apply values value-list)))
|
||||
#`(let-values ([(value-list) #f])
|
||||
(if (#,break? #,start)
|
||||
(set! value-list (#,break-before
|
||||
#,debug-info
|
||||
(current-continuation-marks))))
|
||||
(if (not value-list)
|
||||
(call-with-values
|
||||
(lambda () #,annotated)
|
||||
(case-lambda
|
||||
[(val) (if (#,break? #,end)
|
||||
(#,break-after
|
||||
#,debug-info
|
||||
(current-continuation-marks) val)
|
||||
val)]
|
||||
[vals (if (#,break? #,end)
|
||||
(apply #,break-after
|
||||
#,debug-info
|
||||
(current-continuation-marks) vals)
|
||||
(apply values vals))]))
|
||||
(if (#,break? #,end)
|
||||
(apply #,break-after
|
||||
#,debug-info
|
||||
(current-continuation-marks) value-list)
|
||||
(apply values value-list)))))))
|
||||
record-bound-id
|
||||
record-top-level-id
|
||||
source)))
|
||||
|
||||
|
||||
; annotate-stx : (syntax?
|
||||
|
|
@ -138,260 +136,261 @@
|
|||
;;
|
||||
;; 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 breakpoints (make-hash-table))
|
||||
|
||||
(define (previous-bindings bound-vars)
|
||||
(if (null? bound-vars)
|
||||
#'null
|
||||
#'(debugger-local-bindings)))
|
||||
|
||||
(define (top-level-annotate stx)
|
||||
(kernel:kernel-syntax-case
|
||||
stx #f
|
||||
[(module identifier name (#%plain-module-begin . module-level-exprs))
|
||||
(quasisyntax/loc stx (module identifier name
|
||||
(#%plain-module-begin
|
||||
#,@(map (lambda (e) (module-level-expr-iterator
|
||||
e (list (syntax-e #'identifier)
|
||||
(syntax-source #'identifier))))
|
||||
(syntax->list #'module-level-exprs)))))]
|
||||
[else-stx
|
||||
(general-top-level-expr-iterator stx #f )]))
|
||||
|
||||
(define (module-level-expr-iterator stx module-name )
|
||||
(kernel:kernel-syntax-case
|
||||
stx #f
|
||||
[(provide . provide-specs)
|
||||
stx]
|
||||
[else-stx
|
||||
(general-top-level-expr-iterator stx module-name )]))
|
||||
|
||||
(define (general-top-level-expr-iterator stx module-name )
|
||||
(kernel:kernel-syntax-case
|
||||
stx #f
|
||||
[(define-values (var ...) expr)
|
||||
(define annotate-stx
|
||||
(opt-lambda (stx break-wrap record-bound-id record-top-level-id [source #f])
|
||||
|
||||
(define breakpoints (make-hash-table))
|
||||
|
||||
(define (previous-bindings bound-vars)
|
||||
(if (null? bound-vars)
|
||||
#'null
|
||||
#'(debugger-local-bindings)))
|
||||
|
||||
(define (top-level-annotate stx)
|
||||
(kernel:kernel-syntax-case
|
||||
stx #f
|
||||
[(module identifier name (#%plain-module-begin . module-level-exprs))
|
||||
(quasisyntax/loc stx (module identifier name
|
||||
(#%plain-module-begin
|
||||
#,@(map (lambda (e) (module-level-expr-iterator
|
||||
e (list (syntax-e #'identifier)
|
||||
(syntax-source #'identifier))))
|
||||
(syntax->list #'module-level-exprs)))))]
|
||||
[else-stx
|
||||
(general-top-level-expr-iterator stx #f )]))
|
||||
|
||||
(define (module-level-expr-iterator stx module-name )
|
||||
(kernel:kernel-syntax-case
|
||||
stx #f
|
||||
[(provide . provide-specs)
|
||||
stx]
|
||||
[else-stx
|
||||
(general-top-level-expr-iterator stx module-name )]))
|
||||
|
||||
(define (general-top-level-expr-iterator stx module-name )
|
||||
(kernel:kernel-syntax-case
|
||||
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
|
||||
(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 )
|
||||
|
||||
(define annotate-break?
|
||||
(let ([pos (syntax-position expr)]
|
||||
[src (syntax-source expr)])
|
||||
(and src
|
||||
(eq? src (syntax-source stx))
|
||||
; (is-a? src object%) ; FIX THIS
|
||||
pos
|
||||
(hash-table-get breakpoints pos (lambda () #t))
|
||||
(kernel:kernel-syntax-case
|
||||
expr #f
|
||||
[(if test then) #t]
|
||||
[(if test then else) #t]
|
||||
[(begin . bodies) #t]
|
||||
[(begin0 . bodies) #t]
|
||||
[(let-values . clause) #t]
|
||||
[(letrec-values . clause) #t]
|
||||
[(set! var val) #t]
|
||||
[(with-continuation-mark key mark body) #t]
|
||||
[(#%app . exprs) #t]
|
||||
[_ #f])
|
||||
(begin
|
||||
(hash-table-put! breakpoints pos #f)
|
||||
(when (not is-tail?)
|
||||
(hash-table-put! breakpoints (+ pos (syntax-span expr) -1) #f))
|
||||
#t))))
|
||||
|
||||
(define (let/rec-values-annotator letrec?)
|
||||
(kernel:kernel-syntax-case
|
||||
expr #f
|
||||
[(label (((var ...) rhs) ...) . bodies)
|
||||
(let* ([new-bindings (apply append
|
||||
(map syntax->list
|
||||
(syntax->list #`((var ...) ...))))]
|
||||
[all-bindings (append new-bindings bound-vars)]
|
||||
[new-rhs (map (lambda (expr)
|
||||
(annotate expr
|
||||
(if letrec? all-bindings bound-vars)
|
||||
#f module-name ))
|
||||
(syntax->list #'(rhs ...)))]
|
||||
[last-body (car (reverse (syntax->list #'bodies)))]
|
||||
[all-but-last-body (reverse (cdr (reverse (syntax->list #'bodies))))]
|
||||
[bodies (append (map (lambda (expr)
|
||||
(annotate expr all-bindings #f module-name ))
|
||||
all-but-last-body)
|
||||
(list (annotate
|
||||
last-body
|
||||
all-bindings
|
||||
is-tail? module-name )))]
|
||||
[local-debug-info (assemble-debug-info new-bindings new-bindings 'normal #f)]
|
||||
[previous-bindings (previous-bindings bound-vars)])
|
||||
(for-each (lambda (id) (record-bound-id 'bind id id)) new-bindings)
|
||||
(with-syntax ([(new-rhs/trans ...) new-rhs]
|
||||
[previous-bindings previous-bindings])
|
||||
(if letrec?
|
||||
(quasisyntax/loc expr
|
||||
(let ([old-bindings previous-bindings])
|
||||
(label (((debugger-local-bindings) (lambda ()
|
||||
(list*
|
||||
#,@local-debug-info
|
||||
old-bindings)))
|
||||
((var ...) new-rhs/trans) ...)
|
||||
#,@bodies)))
|
||||
(quasisyntax/loc expr
|
||||
(label (((var ...) new-rhs/trans) ...)
|
||||
(let ([debugger-local-bindings (lambda ()
|
||||
(list*
|
||||
#,@local-debug-info
|
||||
previous-bindings))])
|
||||
#,@bodies))))))]))
|
||||
|
||||
(define (lambda-clause-annotator clause)
|
||||
(kernel:kernel-syntax-case
|
||||
clause #f
|
||||
[(arg-list . bodies)
|
||||
(let* ([new-bound-vars (arglist-bindings #'arg-list)]
|
||||
[all-bound-vars (append new-bound-vars bound-vars)]
|
||||
[new-bodies (let loop ([bodies (syntax->list #'bodies)])
|
||||
(if (equal? '() (cdr bodies))
|
||||
(list (annotate (car bodies) all-bound-vars #t module-name ))
|
||||
(cons (annotate (car bodies) all-bound-vars #f module-name )
|
||||
(loop (cdr bodies)))))])
|
||||
(for-each (lambda (id) (record-bound-id 'bind id id)) new-bound-vars)
|
||||
(quasisyntax/loc clause
|
||||
(arg-list
|
||||
(let ([debugger-local-bindings
|
||||
(lambda ()
|
||||
(list*
|
||||
#,@(assemble-debug-info new-bound-vars new-bound-vars 'normal #f)
|
||||
#,(previous-bindings bound-vars)))])
|
||||
#,@new-bodies))))]))
|
||||
|
||||
(define annotated
|
||||
(syntax-recertify
|
||||
(kernel:kernel-syntax-case
|
||||
expr #f
|
||||
[var-stx (identifier? (syntax var-stx))
|
||||
(let ([binder (and (syntax-original? expr)
|
||||
(srfi:member expr bound-vars module-identifier=?))])
|
||||
(if binder
|
||||
(let ([f (first binder)])
|
||||
(record-bound-id 'ref expr f))
|
||||
(record-bound-id 'top-level expr expr))
|
||||
expr)]
|
||||
|
||||
[(lambda . clause)
|
||||
(quasisyntax/loc expr
|
||||
(lambda #,@(lambda-clause-annotator #'clause)))]
|
||||
|
||||
[(case-lambda . clauses)
|
||||
(quasisyntax/loc expr
|
||||
(case-lambda #,@(map lambda-clause-annotator (syntax->list #'clauses))))]
|
||||
|
||||
[(if test then)
|
||||
(quasisyntax/loc expr (if #,(annotate #'test bound-vars #f module-name )
|
||||
#,(annotate #'then bound-vars is-tail? module-name )))]
|
||||
|
||||
[(if test then else)
|
||||
(quasisyntax/loc expr (if #,(annotate #'test bound-vars #f module-name )
|
||||
#,(annotate #'then bound-vars is-tail? module-name )
|
||||
#,(annotate #'else bound-vars is-tail? module-name )))]
|
||||
|
||||
[(begin . bodies)
|
||||
(letrec ([traverse
|
||||
(lambda (lst)
|
||||
(if (and (pair? lst) (equal? '() (cdr lst)))
|
||||
`(,(annotate (car lst) bound-vars is-tail? module-name ))
|
||||
(cons (annotate (car lst) bound-vars #f module-name )
|
||||
(traverse (cdr lst)))))])
|
||||
(quasisyntax/loc expr (begin #,@(traverse (syntax->list #'bodies)))))]
|
||||
|
||||
[(begin0 . bodies)
|
||||
(quasisyntax/loc expr (begin0 #,@(map (lambda (expr)
|
||||
(annotate expr bound-vars #f module-name ))
|
||||
(syntax->list #'bodies))))]
|
||||
|
||||
[(let-values . clause)
|
||||
(let/rec-values-annotator #f)]
|
||||
|
||||
[(letrec-values . clause)
|
||||
(let/rec-values-annotator #t)]
|
||||
|
||||
[(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
|
||||
(define annotate-break?
|
||||
(let ([pos (syntax-position expr)]
|
||||
[src (syntax-source expr)])
|
||||
(and (or (not source)
|
||||
(eq? src source #;(syntax-source stx)))
|
||||
; (is-a? src object%) ; FIX THIS
|
||||
pos
|
||||
(hash-table-get breakpoints pos (lambda () #t))
|
||||
(kernel:kernel-syntax-case
|
||||
expr #f
|
||||
[(if test then) #t]
|
||||
[(if test then else) #t]
|
||||
[(begin . bodies) #t]
|
||||
[(begin0 . bodies) #t]
|
||||
[(let-values . clause) #t]
|
||||
[(letrec-values . clause) #t]
|
||||
[(set! var val) #t]
|
||||
[(with-continuation-mark key mark body) #t]
|
||||
[(#%app . exprs) #t]
|
||||
[_ #f])
|
||||
(begin
|
||||
(hash-table-put! breakpoints pos #f)
|
||||
(when (not is-tail?)
|
||||
(hash-table-put! breakpoints (+ pos (syntax-span expr) -1) #f))
|
||||
#t))))
|
||||
|
||||
(define (let/rec-values-annotator letrec?)
|
||||
(kernel:kernel-syntax-case
|
||||
expr #f
|
||||
[(label (((var ...) rhs) ...) . bodies)
|
||||
(let* ([new-bindings (apply append
|
||||
(map syntax->list
|
||||
(syntax->list #`((var ...) ...))))]
|
||||
[all-bindings (append new-bindings bound-vars)]
|
||||
[new-rhs (map (lambda (expr)
|
||||
(annotate expr
|
||||
(if letrec? all-bindings bound-vars)
|
||||
#f module-name ))
|
||||
(syntax->list #'(rhs ...)))]
|
||||
[last-body (car (reverse (syntax->list #'bodies)))]
|
||||
[all-but-last-body (reverse (cdr (reverse (syntax->list #'bodies))))]
|
||||
[bodies (append (map (lambda (expr)
|
||||
(annotate expr all-bindings #f module-name ))
|
||||
all-but-last-body)
|
||||
(list (annotate
|
||||
last-body
|
||||
all-bindings
|
||||
is-tail? module-name )))]
|
||||
[local-debug-info (assemble-debug-info new-bindings new-bindings 'normal #f)]
|
||||
[previous-bindings (previous-bindings bound-vars)])
|
||||
(for-each (lambda (id) (record-bound-id 'bind id id)) new-bindings)
|
||||
(with-syntax ([(new-rhs/trans ...) new-rhs]
|
||||
[previous-bindings previous-bindings])
|
||||
(if letrec?
|
||||
(quasisyntax/loc expr
|
||||
(let ([old-bindings previous-bindings])
|
||||
(label (((debugger-local-bindings) (lambda ()
|
||||
(list*
|
||||
#,@local-debug-info
|
||||
old-bindings)))
|
||||
((var ...) new-rhs/trans) ...)
|
||||
#,@bodies)))
|
||||
(quasisyntax/loc expr
|
||||
(label (((var ...) new-rhs/trans) ...)
|
||||
(let ([debugger-local-bindings (lambda ()
|
||||
(list*
|
||||
#,@local-debug-info
|
||||
previous-bindings))])
|
||||
#,@bodies))))))]))
|
||||
|
||||
(define (lambda-clause-annotator clause)
|
||||
(kernel:kernel-syntax-case
|
||||
clause #f
|
||||
[(arg-list . bodies)
|
||||
(let* ([new-bound-vars (arglist-bindings #'arg-list)]
|
||||
[all-bound-vars (append new-bound-vars bound-vars)]
|
||||
[new-bodies (let loop ([bodies (syntax->list #'bodies)])
|
||||
(if (equal? '() (cdr bodies))
|
||||
(list (annotate (car bodies) all-bound-vars #t module-name ))
|
||||
(cons (annotate (car bodies) all-bound-vars #f module-name )
|
||||
(loop (cdr bodies)))))])
|
||||
(for-each (lambda (id) (record-bound-id 'bind id id)) new-bound-vars)
|
||||
(quasisyntax/loc clause
|
||||
(arg-list
|
||||
(let ([debugger-local-bindings
|
||||
(lambda ()
|
||||
(list*
|
||||
#,@(assemble-debug-info new-bound-vars new-bound-vars 'normal #f)
|
||||
#,(previous-bindings bound-vars)))])
|
||||
#,@new-bodies))))]))
|
||||
|
||||
(define annotated
|
||||
(syntax-recertify
|
||||
(kernel:kernel-syntax-case
|
||||
expr #f
|
||||
[var-stx (identifier? (syntax var-stx))
|
||||
(let ([binder (and (syntax-original? expr)
|
||||
(srfi:member expr bound-vars module-identifier=?))])
|
||||
(if binder
|
||||
(let ([f (first binder)])
|
||||
(record-bound-id 'ref expr f))
|
||||
(record-bound-id 'top-level expr expr))
|
||||
expr)]
|
||||
|
||||
[(lambda . clause)
|
||||
(quasisyntax/loc expr
|
||||
(lambda #,@(lambda-clause-annotator #'clause)))]
|
||||
|
||||
[(case-lambda . clauses)
|
||||
(quasisyntax/loc expr
|
||||
(case-lambda #,@(map lambda-clause-annotator (syntax->list #'clauses))))]
|
||||
|
||||
[(if test then)
|
||||
(quasisyntax/loc expr (if #,(annotate #'test bound-vars #f module-name )
|
||||
#,(annotate #'then bound-vars is-tail? module-name )))]
|
||||
|
||||
[(if test then else)
|
||||
(quasisyntax/loc expr (if #,(annotate #'test bound-vars #f module-name )
|
||||
#,(annotate #'then bound-vars is-tail? module-name )
|
||||
#,(annotate #'else bound-vars is-tail? module-name )))]
|
||||
|
||||
[(begin . bodies)
|
||||
(letrec ([traverse
|
||||
(lambda (lst)
|
||||
(if (and (pair? lst) (equal? '() (cdr lst)))
|
||||
`(,(annotate (car lst) bound-vars is-tail? module-name ))
|
||||
(cons (annotate (car lst) bound-vars #f module-name )
|
||||
(traverse (cdr lst)))))])
|
||||
(quasisyntax/loc expr (begin #,@(traverse (syntax->list #'bodies)))))]
|
||||
|
||||
[(begin0 . bodies)
|
||||
(quasisyntax/loc expr (begin0 #,@(map (lambda (expr)
|
||||
(annotate expr bound-vars #f module-name ))
|
||||
(syntax->list #'bodies))))]
|
||||
|
||||
[(let-values . clause)
|
||||
(let/rec-values-annotator #f)]
|
||||
|
||||
[(letrec-values . clause)
|
||||
(let/rec-values-annotator #t)]
|
||||
|
||||
[(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
|
||||
is-tail?)
|
||||
annotated))
|
||||
|
||||
(values (top-level-annotate stx) (hash-table-map breakpoints (lambda (k v) k))))
|
||||
(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
|
||||
is-tail?)
|
||||
annotated))
|
||||
|
||||
(values (top-level-annotate stx) (hash-table-map breakpoints (lambda (k v) k)))))
|
||||
|
||||
#;
|
||||
(define (tests)
|
||||
|
|
|
|||
|
|
@ -279,15 +279,15 @@
|
|||
[f (get-top-level-window)]
|
||||
[rendered-value (if (cons? stat)
|
||||
(if (= 2 (length stat))
|
||||
(render (cadr stat))
|
||||
(format "~a" (cons 'values
|
||||
(map (lambda (v) (render v)) (rest stat)))))
|
||||
(render (cadr stat))
|
||||
(format "~a" (cons 'values
|
||||
(map (lambda (v) (render v)) (rest stat)))))
|
||||
"")])
|
||||
(when (cons? stat)
|
||||
#;(send (make-object menu-item%
|
||||
(clean-status (format "expr -> ~a" rendered-value))
|
||||
menu
|
||||
void) enable #f)
|
||||
(clean-status (format "expr -> ~a" rendered-value))
|
||||
menu
|
||||
void) enable #f)
|
||||
(make-object menu-item%
|
||||
"Print return value to console"
|
||||
menu
|
||||
|
|
@ -451,72 +451,56 @@
|
|||
;; adds debugging information to `sexp' and calls `oe'
|
||||
(define/private (make-debug-eval-handler oe break? break-before break-after)
|
||||
(lambda (orig-exp)
|
||||
(if (or (compiled-expression? (if (syntax? orig-exp)
|
||||
(if (compiled-expression? (if (syntax? orig-exp)
|
||||
(syntax-e 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)
|
||||
(let loop ([exp (if (syntax? orig-exp)
|
||||
orig-exp
|
||||
(namespace-syntax-introduce
|
||||
(datum->syntax-object #f orig-exp)))])
|
||||
(let ([top-e (expand-syntax-to-top-form exp)])
|
||||
(syntax-case top-e (begin)
|
||||
[(begin expr ...)
|
||||
;; Found a `begin', so expand/eval each contained
|
||||
;; expression one at a time
|
||||
(let i-loop ([exprs (syntax->list #'(expr ...))]
|
||||
[last-one (list (void))])
|
||||
(cond
|
||||
[(null? exprs) (apply values last-one)]
|
||||
[else (i-loop (cdr exprs)
|
||||
(call-with-values
|
||||
(lambda () (loop (car exprs)))
|
||||
list))]))]
|
||||
[_else
|
||||
;; Not `begin', so proceed with normal expand and eval
|
||||
(parameterize ([current-eval oe])
|
||||
(eval/annotations
|
||||
top-e
|
||||
(lambda (fn m) #f) ; TODO: multiple file support
|
||||
(lambda (stx)
|
||||
(let*-values ([(breakpoints) (send (get-tab) get-breakpoints)]
|
||||
[(pos-vec) (send (get-tab) get-pos-vec)]
|
||||
[(annotated break-posns)
|
||||
(annotate-for-single-stepping
|
||||
(expand-syntax top-e)
|
||||
break?
|
||||
break-before
|
||||
break-after
|
||||
(lambda (type bound binding)
|
||||
;(display-results (list bound))
|
||||
(when (eq? (robust-syntax-source bound)
|
||||
(robust-syntax-source exp))
|
||||
(let loop ([i 0])
|
||||
(when (< i (syntax-span bound))
|
||||
(vector-set! pos-vec (+ i (syntax-position bound)) binding)
|
||||
(loop (add1 i))))))
|
||||
(lambda (mod var val)
|
||||
(send (get-tab) add-top-level-binding var val)
|
||||
#;
|
||||
(printf "top-level binding: ~a ~a ~a~n" mod var val)))])
|
||||
(hash-table-for-each
|
||||
breakpoints
|
||||
(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))))]))))))
|
||||
(parameterize ([current-eval oe])
|
||||
(eval/annotations
|
||||
top-e
|
||||
(lambda (fn m) #f) ; TODO: multiple file support
|
||||
(lambda (stx)
|
||||
(let*-values ([(breakpoints) (send (get-tab) get-breakpoints)]
|
||||
[(pos-vec) (send (get-tab) get-pos-vec)]
|
||||
[(annotated break-posns)
|
||||
(annotate-for-single-stepping
|
||||
(expand-syntax top-e)
|
||||
break?
|
||||
break-before
|
||||
break-after
|
||||
(lambda (type bound binding)
|
||||
;(display-results (list bound))
|
||||
(when (eq? (robust-syntax-source bound)
|
||||
(robust-syntax-source exp))
|
||||
(let loop ([i 0])
|
||||
(when (< i (syntax-span bound))
|
||||
(vector-set! pos-vec (+ i (syntax-position bound)) binding)
|
||||
(loop (add1 i))))))
|
||||
(lambda (mod var val)
|
||||
(send (get-tab) add-top-level-binding var val)
|
||||
#;
|
||||
(printf "top-level binding: ~a ~a ~a~n" mod var val))
|
||||
(send (get-tab) get-defs))])
|
||||
(hash-table-for-each
|
||||
breakpoints
|
||||
(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)
|
||||
(super reset-console)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user