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

implementing top-level-ids

Browse Source 
svn: r2071
This commit is contained in:
Guillaume Marceau 2006-02-01 19:05:04 +00:00
parent 8e4b5d3f3b
commit e862bb520a
3 changed files with 57 additions and 38 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

82
collects/mztake/annotator.ss
View File

@ -54,8 +54,9 @@
;; normally. If BREAK-AFTER returns some value, the
;; return value of the expression is replaced by that value.
;;
;; RECORD-BOUND-ID is simply passed to ANNOTATE-STX.
(define (annotate-for-single-stepping stx break? break-before break-after record-bound-id)
;; 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?)
@ -94,7 +95,8 @@
#,debug-info
(current-continuation-marks) value-list)
(apply values value-list)))))))
record-bound-id))
record-bound-id
record-top-level-id ))
; annotate-stx : (syntax?
@ -134,7 +136,7 @@
;;
;; Naturally, when USE-CASE is 'bind, BOUND-STX and BINDING-STX are equal.
;;
(define (annotate-stx stx break-wrap record-bound-id)
(define (annotate-stx stx break-wrap record-bound-id record-top-level-id)
(define breakpoints (make-hash-table))
@ -149,37 +151,43 @@
[(module identifier name (#%plain-module-begin . module-level-exprs))
(quasisyntax/loc stx (module identifier name
(#%plain-module-begin
#,@(map module-level-expr-iterator
#,@(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)]))
(general-top-level-expr-iterator stx #f )]))
(define (module-level-expr-iterator stx)
(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)]))
(general-top-level-expr-iterator stx module-name )]))
(define (general-top-level-expr-iterator stx)
(define (general-top-level-expr-iterator stx module-name )
(kernel:kernel-syntax-case
stx #f
[(define-values (var ...) expr)
#`(define-values (var ...)
#,(annotate #`expr null #;(syntax->list #`(var ...)) #t))]
(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 var) ...)
#'(void))
(void))))
]
[(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))]
;; 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-level-expr-iterator expr module-name ))
(syntax->list #'top-level-exprs))))]
[(require . require-specs)
stx]
@ -187,9 +195,9 @@
stx]
[(require-for-template dot require-specs) stx]
[else
(annotate stx '() #f)]))
(annotate stx '() #f module-name )]))
(define (annotate expr bound-vars is-tail?)
(define (annotate expr bound-vars is-tail? module-name )
(define annotate-break?
(let ([pos (syntax-position expr)]
@ -227,17 +235,17 @@
[new-rhs (map (lambda (expr)
(annotate expr
(if letrec? all-bindings bound-vars)
#f))
#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))
(annotate expr all-bindings #f module-name ))
all-but-last-body)
(list (annotate
last-body
all-bindings
is-tail?)))]
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)
@ -268,8 +276,8 @@
[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)
(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
@ -302,26 +310,26 @@
(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?)))]
(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)
#,(annotate #'then bound-vars is-tail?)
#,(annotate #'else bound-vars is-tail?)))]
(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?))
(cons (annotate (car lst) bound-vars #f)
`(,(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))
(annotate expr bound-vars #f module-name ))
(syntax->list #'bodies))))]
[(let-values . clause)
@ -336,7 +344,7 @@
(when binder
(let ([f (first binder)])
(record-bound-id 'set expr f)))
(quasisyntax/loc expr (set! var #,(annotate #`val bound-vars #f))))]
(quasisyntax/loc expr (set! var #,(annotate #`val bound-vars #f module-name ))))]
[(quote _) expr]
@ -344,12 +352,12 @@
[(with-continuation-mark key mark body)
(quasisyntax/loc expr (with-continuation-mark key
#,(annotate #'mark bound-vars #f)
#,(annotate #'body bound-vars is-tail?)))]
#,(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))
(annotate expr bound-vars #f module-name ))
(syntax->list #'exprs))])
(if is-tail?
(quasisyntax/loc expr #,subexprs)

12
collects/mztake/engine.ss
View File

@ -240,6 +240,13 @@
(debug-process-clients process))
true))
(define ((record-top-level-id process) module-name var-name val)
(let* ([modules (debug-process-top-level process)]
[bindings (hash-get modules module-name (lambda () (make-hash)))])
(unless (hash-mem? modules module-name)
(hash-put! modules module-name bindings))
(printf "record-top-level-id ~a ~a ~a ~n" module-name var-name val)
(hash-put! bindings var-name val)))
(define (launch-sandbox process)
(unless (debug-process-main-client process)
@ -274,7 +281,8 @@
(break? process client)
(break-before process client)
(break-after process client)
(lambda (kind bound binding) (void)))])
(lambda (kind bound binding) (void))
(record-top-level-id process))])
annotated-stx))))))
(define (process:new->running process)
@ -337,6 +345,8 @@
(frp:event-receiver) ; exceptions
false ; main-client
empty ; clients
(make-hash 'equal ) ; top-level
false ; where
false)]) ; marks
(set! all-debug-processes (cons process all-debug-processes))

1
collects/mztake/mztake-structs.ss
View File

@ -45,6 +45,7 @@
exceptions ; (an event stream) Exceptions thrown during the evaluation of the target
main-client ; the main client module that will be run
clients ; list of all the clients attached to this process
top-level
where ; a behavior signaling each position where we pause
marks)) ; while paused, the marks at the point of the pause (else false)