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

debugger expands linearly

Browse Source 
svn: r1373
This commit is contained in:
Matthew Flatt 2005-11-22 19:46:07 +00:00
parent cc8598cb4d
commit b172954a54
3 changed files with 57 additions and 41 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

65
collects/mztake/annotator.ss
View File

@ -135,6 +135,11 @@
(define (annotate-stx stx break-wrap record-bound-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
@ -160,10 +165,14 @@
stx #f
[(define-values (var ...) expr)
#`(define-values (var ...)
#,(annotate #`expr (syntax->list #`(var ...)) #t))]
#,(annotate #`expr null #;(syntax->list #`(var ...)) #t))]
[(define-syntaxes (var ...) expr)
stx]
[(define-values-for-syntax (var ...) expr)
stx
;; define-values-for-syntax's RHS is compile time, so treat it
;; like define-syntaxes
#;
#`(define-values-for-syntax (var ...)
#,(annotate #`expr #`(syntax->list #'(var ...)) #t))]
[(begin . top-level-exprs)
@ -212,26 +221,42 @@
(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 ...))))]
[all-bindings (append new-bindings bound-vars)]
[new-rhs (map (lambda (expr)
(annotate expr
(if letrec? all-bindings 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))
(annotate expr all-bindings #f))
all-but-last-body)
(list (annotate
last-body
(append new-bindings bound-vars) is-tail?)))])
all-bindings
is-tail?)))]
[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])
(quasisyntax/loc expr
(label (((var ...) new-rhs/trans) ...)
#,@bodies))))]))
(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
@ -246,7 +271,13 @@
(loop (cdr bodies)))))])
(for-each (lambda (id) (record-bound-id 'bind id id)) new-bound-vars)
(quasisyntax/loc clause
(arg-list #,@new-bodies)))]))
(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
@ -320,7 +351,7 @@
(syntax->list #'exprs))])
(if is-tail?
(quasisyntax/loc expr #,subexprs)
(wcm-wrap (make-debug-info expr bound-vars bound-vars 'normal #f)
(wcm-wrap (make-debug-info expr bound-vars bound-vars 'normal #f (previous-bindings bound-vars))
(quasisyntax/loc expr #,subexprs))))]
[(#%datum . _) expr]
@ -335,7 +366,7 @@
(if annotate-break?
(break-wrap
(make-debug-info expr bound-vars bound-vars 'at-break #f)
(make-debug-info expr bound-vars bound-vars 'at-break #f (previous-bindings bound-vars))
annotated
expr
is-tail?)

26
collects/mztake/marks.ss
View File

@ -22,6 +22,7 @@
(provide
make-debug-info
assemble-debug-info
wcm-wrap
skipto-mark?
skipto-mark
@ -67,13 +68,13 @@
; the 'varargs' creator is used to avoid an extra cons cell in every mark:
(define (make-make-full-mark-varargs source label bindings)
(lambda values
(lambda (values)
(make-full-mark-struct source label bindings values)))
; see module top for type
(define (make-full-mark location label bindings)
(define (make-full-mark location label bindings assembled-info-stx)
(datum->syntax-object #'here `(lambda () (,(make-make-full-mark-varargs location label bindings)
,@(map make-mark-binding-stx bindings)))))
,assembled-info-stx))))
(define (mark-source mark)
(full-mark-struct-source (mark)))
@ -165,22 +166,11 @@
;;
;;;;;;;;;;
(define (make-debug-info source tail-bound free-vars label lifting?)
(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)
((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)))))
kept-vars)]
[lifter-syms (map get-lifted-var let-bindings)])
(make-full-mark source label (append kept-vars lifter-syms)))
(make-full-mark source label kept-vars))))
(define (make-debug-info source tail-bound free-vars label lifting? assembled-info-stx)
(make-full-mark source label free-vars assembled-info-stx))
(define (assemble-debug-info tail-bound free-vars label lifting?)
(map make-mark-binding-stx free-vars))
(define (make-top-level-mark source-expr)
(make-full-mark source-expr 'top-level null)))

7
collects/plai/private/datatype-core.ss
View File

@ -14,13 +14,8 @@
cases-core
provide-datatype-core)
;; Temporary workaround for problem in debugger:
(define-for-syntax (generate-dt-temporaries l)
(if (list? l)
(map (lambda (x)
(gensym (if (symbol? x) x (syntax-e x))))
l)
(generate-dt-temporaries (syntax->list l))))
(generate-temporaries l))
(define (projection-contract name proc)
(let ([name `(,(car name) ,@(map (lambda (c)