300 lines
12 KiB
Scheme
300 lines
12 KiB
Scheme
(module annotator mzscheme
|
|
|
|
(require (prefix kernel: (lib "kerncase.ss" "syntax"))
|
|
(lib "class.ss")
|
|
(lib "list.ss")
|
|
(lib "marks.ss" "mztake" "private")
|
|
(lib "mred.ss" "mred")
|
|
(lib "load-annotator.ss" "mztake" "private")
|
|
(prefix srfi: (lib "search.ss" "srfi" "1"))
|
|
)
|
|
(provide annotate-stx annotate-for-single-stepping)
|
|
|
|
(define (arglist-bindings arglist-stx)
|
|
(syntax-case arglist-stx ()
|
|
[var
|
|
(identifier? arglist-stx)
|
|
(list arglist-stx)]
|
|
[(var ...)
|
|
(syntax->list arglist-stx)]
|
|
[(var . others)
|
|
(cons #'var (arglist-bindings #'others))]))
|
|
|
|
|
|
|
|
|
|
;; Retreives the binding of a variable from a normal-breakpoint-info.
|
|
;; Returns a list of pairs `(,variable-name-stx ,variable-value). Each
|
|
;; item in the list is a shadowed instance of a variable with the given
|
|
;; name, with the first item being the one in scope.
|
|
#;
|
|
(define (bindings top-mark marks sym)
|
|
(let ([mark-list (cons top-mark (continuation-mark-set->list marks debug-key))])
|
|
(map (lambda (binding) (list (mark-binding-binding binding)
|
|
(mark-binding-value binding)))
|
|
(lookup-all-bindings (lambda (id) (eq? (syntax-e id) sym))
|
|
mark-list))))
|
|
|
|
|
|
|
|
(define (annotate-for-single-stepping stx break? break-before break-after record-bound-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))
|
|
|
|
|
|
; annotate-stx : (syntax? (syntax? . -> . syntax?)
|
|
; (symbol? syntax? syntax? . -> . void?) . -> . syntax?)
|
|
(define (annotate-stx stx break-wrap record-bound-id)
|
|
|
|
(define breakpoints (make-hash-table))
|
|
|
|
(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 module-level-expr-iterator
|
|
(syntax->list #'module-level-exprs)))))]
|
|
[else-stx
|
|
(general-top-level-expr-iterator stx)]))
|
|
|
|
(define (module-level-expr-iterator stx)
|
|
(kernel:kernel-syntax-case
|
|
stx #f
|
|
[(provide . provide-specs)
|
|
stx]
|
|
[else-stx
|
|
(general-top-level-expr-iterator stx)]))
|
|
|
|
(define (general-top-level-expr-iterator stx)
|
|
(kernel:kernel-syntax-case
|
|
stx #f
|
|
[(define-values (var ...) expr)
|
|
#`(define-values (var ...)
|
|
#,(annotate #`expr (syntax->list #`(var ...)) #t))]
|
|
[(define-syntaxes (var ...) expr)
|
|
stx]
|
|
[(begin . top-level-exprs)
|
|
(quasisyntax/loc stx (begin #,@(map (lambda (expr)
|
|
(module-level-expr-iterator expr))
|
|
(syntax->list #'top-level-exprs))))]
|
|
[(require . require-specs)
|
|
stx]
|
|
[(require-for-syntax . require-specs)
|
|
stx]
|
|
[else
|
|
(annotate stx '() #f)]))
|
|
|
|
(define (annotate expr bound-vars is-tail?)
|
|
|
|
(define annotate-break?
|
|
(let ([pos (syntax-position expr)]
|
|
[src (syntax-source expr)])
|
|
(and src
|
|
; (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 ...) ...))))]
|
|
[new-rhs (if letrec?
|
|
(map (lambda (expr)
|
|
(annotate expr (append new-bindings bound-vars) #f))
|
|
(syntax->list #'(rhs ...)))
|
|
(map (lambda (expr) (annotate expr bound-vars #f))
|
|
(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
|
|
(append new-bindings bound-vars) #f))
|
|
all-but-last-body)
|
|
(list (annotate
|
|
last-body
|
|
(append new-bindings bound-vars) is-tail?)))])
|
|
(for-each (lambda (id) (record-bound-id 'bind id id)) new-bindings)
|
|
(with-syntax ([(new-rhs/trans ...) new-rhs])
|
|
(quasisyntax/loc expr
|
|
(label (((var ...) new-rhs/trans) ...)
|
|
#,@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))
|
|
(cons (annotate (car bodies) all-bound-vars #f)
|
|
(loop (cdr bodies)))))])
|
|
(for-each (lambda (id) (record-bound-id 'bind id id)) new-bound-vars)
|
|
(quasisyntax/loc clause
|
|
(arg-list #,@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=?))])
|
|
(when binder
|
|
(let ([f (first binder)])
|
|
(record-bound-id 'ref expr f)))
|
|
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)
|
|
#,(annotate #'then bound-vars is-tail?)))]
|
|
|
|
[(if test then else)
|
|
(quasisyntax/loc expr (if #,(annotate #'test bound-vars #f)
|
|
#,(annotate #'then bound-vars is-tail?)
|
|
#,(annotate #'else bound-vars is-tail?)))]
|
|
|
|
[(begin . bodies)
|
|
(letrec ([traverse
|
|
(lambda (lst)
|
|
(if (and (pair? lst) (equal? '() (cdr lst)))
|
|
`(,(annotate (car lst) bound-vars is-tail?))
|
|
(cons (annotate (car lst) bound-vars #f)
|
|
(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))
|
|
(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))))]
|
|
|
|
[(quote _) expr]
|
|
|
|
[(quote-syntax _) expr]
|
|
|
|
[(with-continuation-mark key mark body)
|
|
(quasisyntax/loc expr (with-continuation-mark key
|
|
#,(annotate #'mark bound-vars #f)
|
|
#,(annotate #'body bound-vars is-tail?)))]
|
|
|
|
[(#%app . exprs)
|
|
(let ([subexprs (map (lambda (expr)
|
|
(annotate expr bound-vars #f))
|
|
(syntax->list #'exprs))])
|
|
(if is-tail?
|
|
(quasisyntax/loc expr #,subexprs)
|
|
(wcm-wrap (make-debug-info expr bound-vars bound-vars 'normal #f)
|
|
(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 expr bound-vars bound-vars 'at-break #f)
|
|
annotated
|
|
expr
|
|
is-tail?)
|
|
annotated))
|
|
|
|
(values (top-level-annotate stx) (hash-table-map breakpoints (lambda (k v) k))))
|
|
|
|
#;
|
|
(define (tests)
|
|
(run/single-stepping-annotation
|
|
(current-custodian) "a.ss"
|
|
(map string->path '("/home/gmarceau/projects/mztake/collects/mztake/a.ss"
|
|
"/home/gmarceau/projects/mztake/collects/mztake/b.ss"))
|
|
(lambda (fn pos)
|
|
(printf "break?: ~a ~a~n" fn pos) #t)
|
|
(lambda (bp-info) (printf "break: ~a~n" bp-info) #f)))
|
|
) |