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 ;; normally. If BREAK-AFTER returns some value, the
;; return value of the expression is replaced by that value. ;; return value of the expression is replaced by that value.
;; ;;
;; RECORD-BOUND-ID is 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)
(define (annotate-for-single-stepping stx break? break-before break-after record-bound-id record-top-level-id )
(annotate-stx (annotate-stx
stx stx
(lambda (debug-info annotated raw is-tail?) (lambda (debug-info annotated raw is-tail?)
@ -94,7 +95,8 @@
#,debug-info #,debug-info
(current-continuation-marks) value-list) (current-continuation-marks) value-list)
(apply values value-list))))))) (apply values value-list)))))))
record-bound-id)) record-bound-id
record-top-level-id ))
; annotate-stx : (syntax? ; annotate-stx : (syntax?
@ -134,7 +136,7 @@
;; ;;
;; 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) (define (annotate-stx stx break-wrap record-bound-id record-top-level-id)
(define breakpoints (make-hash-table)) (define breakpoints (make-hash-table))
@ -149,37 +151,43 @@
[(module identifier name (#%plain-module-begin . module-level-exprs)) [(module identifier name (#%plain-module-begin . module-level-exprs))
(quasisyntax/loc stx (module identifier name (quasisyntax/loc stx (module identifier name
(#%plain-module-begin (#%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)))))] (syntax->list #'module-level-exprs)))))]
[else-stx [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 (kernel:kernel-syntax-case
stx #f stx #f
[(provide . provide-specs) [(provide . provide-specs)
stx] stx]
[else-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 (kernel:kernel-syntax-case
stx #f stx #f
[(define-values (var ...) expr) [(define-values (var ...) expr)
#`(define-values (var ...) (begin (for-each (lambda (v) (record-bound-id 'bind v v))
#,(annotate #`expr null #;(syntax->list #`(var ...)) #t))] (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) [(define-syntaxes (var ...) expr)
stx] stx]
[(define-values-for-syntax (var ...) expr) [(define-values-for-syntax (var ...) expr)
stx ;; define-values-for-syntax's RHS is compile time, so treat it
;; define-values-for-syntax's RHS is compile time, so treat it ;; like define-syntaxes
;; like define-syntaxes stx]
#;
#`(define-values-for-syntax (var ...)
#,(annotate #`expr #`(syntax->list #'(var ...)) #t))]
[(begin . top-level-exprs) [(begin . top-level-exprs)
(quasisyntax/loc stx (begin #,@(map (lambda (expr) (quasisyntax/loc stx (begin #,@(map (lambda (expr)
(module-level-expr-iterator expr)) (module-level-expr-iterator expr module-name ))
(syntax->list #'top-level-exprs))))] (syntax->list #'top-level-exprs))))]
[(require . require-specs) [(require . require-specs)
stx] stx]
@ -187,9 +195,9 @@
stx] stx]
[(require-for-template dot require-specs) stx] [(require-for-template dot require-specs) stx]
[else [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? (define annotate-break?
(let ([pos (syntax-position expr)] (let ([pos (syntax-position expr)]
@ -227,17 +235,17 @@
[new-rhs (map (lambda (expr) [new-rhs (map (lambda (expr)
(annotate expr (annotate expr
(if letrec? all-bindings bound-vars) (if letrec? all-bindings bound-vars)
#f)) #f module-name ))
(syntax->list #'(rhs ...)))] (syntax->list #'(rhs ...)))]
[last-body (car (reverse (syntax->list #'bodies)))] [last-body (car (reverse (syntax->list #'bodies)))]
[all-but-last-body (reverse (cdr (reverse (syntax->list #'bodies))))] [all-but-last-body (reverse (cdr (reverse (syntax->list #'bodies))))]
[bodies (append (map (lambda (expr) [bodies (append (map (lambda (expr)
(annotate expr all-bindings #f)) (annotate expr all-bindings #f module-name ))
all-but-last-body) all-but-last-body)
(list (annotate (list (annotate
last-body last-body
all-bindings all-bindings
is-tail?)))] is-tail? module-name )))]
[local-debug-info (assemble-debug-info new-bindings new-bindings 'normal #f)] [local-debug-info (assemble-debug-info new-bindings new-bindings 'normal #f)]
[previous-bindings (previous-bindings bound-vars)]) [previous-bindings (previous-bindings bound-vars)])
(for-each (lambda (id) (record-bound-id 'bind id id)) new-bindings) (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)] [all-bound-vars (append new-bound-vars bound-vars)]
[new-bodies (let loop ([bodies (syntax->list #'bodies)]) [new-bodies (let loop ([bodies (syntax->list #'bodies)])
(if (equal? '() (cdr bodies)) (if (equal? '() (cdr bodies))
(list (annotate (car bodies) all-bound-vars #t)) (list (annotate (car bodies) all-bound-vars #t module-name ))
(cons (annotate (car bodies) all-bound-vars #f) (cons (annotate (car bodies) all-bound-vars #f module-name )
(loop (cdr bodies)))))]) (loop (cdr bodies)))))])
(for-each (lambda (id) (record-bound-id 'bind id id)) new-bound-vars) (for-each (lambda (id) (record-bound-id 'bind id id)) new-bound-vars)
(quasisyntax/loc clause (quasisyntax/loc clause
@ -302,26 +310,26 @@
(case-lambda #,@(map lambda-clause-annotator (syntax->list #'clauses))))] (case-lambda #,@(map lambda-clause-annotator (syntax->list #'clauses))))]
[(if test then) [(if test then)
(quasisyntax/loc expr (if #,(annotate #'test bound-vars #f) (quasisyntax/loc expr (if #,(annotate #'test bound-vars #f module-name )
#,(annotate #'then bound-vars is-tail?)))] #,(annotate #'then bound-vars is-tail? module-name )))]
[(if test then else) [(if test then else)
(quasisyntax/loc expr (if #,(annotate #'test bound-vars #f) (quasisyntax/loc expr (if #,(annotate #'test bound-vars #f module-name )
#,(annotate #'then bound-vars is-tail?) #,(annotate #'then bound-vars is-tail? module-name )
#,(annotate #'else bound-vars is-tail?)))] #,(annotate #'else bound-vars is-tail? module-name )))]
[(begin . bodies) [(begin . bodies)
(letrec ([traverse (letrec ([traverse
(lambda (lst) (lambda (lst)
(if (and (pair? lst) (equal? '() (cdr lst))) (if (and (pair? lst) (equal? '() (cdr lst)))
`(,(annotate (car lst) bound-vars is-tail?)) `(,(annotate (car lst) bound-vars is-tail? module-name ))
(cons (annotate (car lst) bound-vars #f) (cons (annotate (car lst) bound-vars #f module-name )
(traverse (cdr lst)))))]) (traverse (cdr lst)))))])
(quasisyntax/loc expr (begin #,@(traverse (syntax->list #'bodies)))))] (quasisyntax/loc expr (begin #,@(traverse (syntax->list #'bodies)))))]
[(begin0 . bodies) [(begin0 . bodies)
(quasisyntax/loc expr (begin0 #,@(map (lambda (expr) (quasisyntax/loc expr (begin0 #,@(map (lambda (expr)
(annotate expr bound-vars #f)) (annotate expr bound-vars #f module-name ))
(syntax->list #'bodies))))] (syntax->list #'bodies))))]
[(let-values . clause) [(let-values . clause)
@ -336,7 +344,7 @@
(when binder (when binder
(let ([f (first binder)]) (let ([f (first binder)])
(record-bound-id 'set expr f))) (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] [(quote _) expr]
@ -344,12 +352,12 @@
[(with-continuation-mark key mark body) [(with-continuation-mark key mark body)
(quasisyntax/loc expr (with-continuation-mark key (quasisyntax/loc expr (with-continuation-mark key
#,(annotate #'mark bound-vars #f) #,(annotate #'mark bound-vars #f module-name )
#,(annotate #'body bound-vars is-tail?)))] #,(annotate #'body bound-vars is-tail? module-name )))]
[(#%app . exprs) [(#%app . exprs)
(let ([subexprs (map (lambda (expr) (let ([subexprs (map (lambda (expr)
(annotate expr bound-vars #f)) (annotate expr bound-vars #f module-name ))
(syntax->list #'exprs))]) (syntax->list #'exprs))])
(if is-tail? (if is-tail?
(quasisyntax/loc expr #,subexprs) (quasisyntax/loc expr #,subexprs)

12
collects/mztake/engine.ss
View File

@ -240,6 +240,13 @@
(debug-process-clients process)) (debug-process-clients process))
true)) 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) (define (launch-sandbox process)
(unless (debug-process-main-client process) (unless (debug-process-main-client process)
@ -274,7 +281,8 @@
(break? process client) (break? process client)
(break-before process client) (break-before process client)
(break-after process client) (break-after process client)
(lambda (kind bound binding) (void)))]) (lambda (kind bound binding) (void))
(record-top-level-id process))])
annotated-stx)))))) annotated-stx))))))
(define (process:new->running process) (define (process:new->running process)
@ -337,6 +345,8 @@
(frp:event-receiver) ; exceptions (frp:event-receiver) ; exceptions
false ; main-client false ; main-client
empty ; clients empty ; clients
(make-hash 'equal ) ; top-level
false ; where false ; where
false)]) ; marks false)]) ; marks
(set! all-debug-processes (cons process all-debug-processes)) (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 exceptions ; (an event stream) Exceptions thrown during the evaluation of the target
main-client ; the main client module that will be run main-client ; the main client module that will be run
clients ; list of all the clients attached to this process clients ; list of all the clients attached to this process
top-level
where ; a behavior signaling each position where we pause where ; a behavior signaling each position where we pause
marks)) ; while paused, the marks at the point of the pause (else false) marks)) ; while paused, the marks at the point of the pause (else false)