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

support for begin0. Whew.

Browse Source 
svn: r5522
This commit is contained in:
John Clements 2007-02-01 00:18:42 +00:00
parent 6caa70e84b
commit 05bdd7e0c5
3 changed files with 57 additions and 60 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

69
collects/stepper/private/annotate.ss
View File

@ -445,6 +445,9 @@
[make-debug-info-fake-exp (lambda (exp free-bindings)
(make-debug-info (stepper-syntax-property exp 'stepper-fake-exp #t)
tail-bound free-bindings 'none #t))]
[make-debug-info-fake-exp/tail-bound (lambda (exp tail-bound free-bindings)
(make-debug-info (stepper-syntax-property exp 'stepper-fake-exp #t)
tail-bound free-bindings 'none #t))]
[outer-wcm-wrap (if pre-break?
wcm-pre-break-wrap
@ -843,47 +846,33 @@
(quasisyntax/loc exp (begin0 #,annotated-body)))
free-vars-body))]
#;(let unroll-loop ([bodies-list bodies-list] [outermost? #t])
(cond [(null? bodies-list)
(error 'annotate "no bodies in let")]
[(null? (cdr bodies-list))
(tail-recur (car bodies-list))]
[else
(let*-2vals
([(rest free-vars-rest) (unroll-loop (cdr bodies-list) #f)]
[(this-one free-vars-this) (non-tail-recur (car bodies-list))]
[free-vars-all (varref-set-union (list free-vars-rest free-vars-this))]
[debug-info (make-debug-info-fake-exp
#`(begin #,@bodies-list)
free-vars-all)]
[begin-form #`(begin #,(normal-break/values-wrap this-one) #,rest)])
(2vals (if outermost?
(wcm-wrap debug-info begin-form)
(wcm-pre-break-wrap debug-info begin-form))
free-vars-all))]))
;; temporary hack for ProfJ stepper, 2006-12-4, JBC
[(begin0 first-body . bodies-stx)
#`(error "shouldn't get evaluated, please.\n")]
#;[(begin0 first-body . bodies-stx)
(let*-2vals ([(annotated-first free-vars-first) (result-recur first-body)])
#`(let ([,begin0-temp #,annotated-first])
#,unrolled-rest))
(let unroll-loop ([bodies-list (syntax->list #`(first-body . bodies-stx))] [outermost? #t])
(cond [(null? bodies-list)
(error 'annotate "this case should have been handled by the zero-body annotation")]
[(null? (cdr bodies-list))
(let*-2vals
([(this-one free-vars-this) (non-tail-recur)]))]))
(let*-2vals
([bodies (syntax->list (syntax bodies-stx))]
[(annotated-first free-varrefs-first)
(result-recur (car bodies))]
[(annotated-bodies free-varref-sets)
(2vals-map non-tail-recur (cdr bodies))])
(normal-bundle (varref-set-union (cons free-varrefs-first free-varref-sets))
(quasisyntax/loc exp (begin0 #,annotated-first #,@annotated-bodies))))]
[(begin0 first-body . bodies-stx)
(let*-2vals ([(annotated-first free-vars-first) (result-recur #'first-body)]
[(annotated-rest free-vars-rest) (2vals-map non-tail-recur (syntax->list #`bodies-stx))]
[wrapped-rest (map normal-break/values-wrap annotated-rest)]
[all-free-vars (varref-set-union (cons free-vars-first free-vars-rest))]
[early-debug-info (make-debug-info-normal all-free-vars)]
[tagged-temp (stepper-syntax-property begin0-temp 'stepper-binding-type 'stepper-temp)]
[debug-info-maker
(lambda (rest-exps)
(make-debug-info-fake-exp/tail-bound
#`(begin0 #,@rest-exps)
(binding-set-union (list (list tagged-temp) tail-bound))
(varref-set-union (list (list tagged-temp) all-free-vars))))]
[rolled-into-fakes (let loop ([remaining-wrapped wrapped-rest]
[remaining-src (syntax->list #`bodies-stx)]
[first-time? #t])
((if first-time? wcm-wrap wcm-pre-break-wrap)
(debug-info-maker remaining-src)
(cond [(null? remaining-src) begin0-temp]
[else #`(begin #,(car remaining-wrapped) #,(loop (cdr remaining-wrapped)
(cdr remaining-src)
#f))])))])
(2vals (wcm-wrap early-debug-info
#`(let ([#,begin0-temp #,annotated-first])
#,rolled-into-fakes))
all-free-vars))]

16
collects/stepper/private/model.ss
View File

@ -162,22 +162,6 @@
steps-received/current
mark-set break-kind returned-value-list)))))
;; bizarrely, this causes something in the test tool startup to fail
;; with:
;; current-eventspace: expects argument of type <eventspace>; given #f
;; === context ===
;; ...collects/drscheme/private/rep.ss:1183:10: queue-user/wait method in ...cheme/private/rep.ss:480:8
;; ...collects/drscheme/private/rep.ss:1094:10: init-evaluation-thread method in ...cheme/private/rep.ss:480:8
;; ...collects/drscheme/private/rep.ss:1346:10: reset-console method in ...cheme/private/rep.ss:480:8
;; ...collects/mztake/debug-tool.ss:510:10: reset-console method in ...mztake/debug-tool.ss:428:8
;; ...collects/test-suite/tool.ss:162:10: reset-console method in ...s/test-suite/tool.ss:137:8
;; ...collects/drscheme/private/rep.ss:1413:10: initialize-console method in ...cheme/private/rep.ss:480:8
;; ...collects/drscheme/private/unit.ss:3200:6: create-new-drscheme-frame
;; ...collects/drscheme/private/main.ss:372:6: make-basic
;; ... okay, the error was transient. wonder what caused it?
(let* ([mark-list (and mark-set (extract-mark-list mark-set))])
(define (reconstruct-all-completed)

32
collects/stepper/private/reconstruct.ss
View File

@ -11,7 +11,8 @@
"marks.ss"
"model-settings.ss"
"shared.ss"
"my-macros.ss")
"my-macros.ss"
(file "~/clements/scheme-scraps/eli-debug.ss"))
(provide/contract
[reconstruct-completed (syntax?
@ -365,7 +366,14 @@
[(if test then else) (recon-basic)]
[(if test then) (recon-basic)]
[(begin . bodies) (recon-basic)]
[(begin0 . bodies) (recon-basic)]
[(begin0 . bodies)
(if (stepper-syntax-property expr 'stepper-fake-exp)
(if (null? (syntax->list #`bodies))
(recon-value (lookup-binding mark-list begin0-temp) render-settings)
;; prepend the computed value of the first arg:
#`(begin0 #,(recon-value (lookup-binding mark-list begin0-temp) render-settings)
#,@(map recur (filter-skipped (syntax->list #`bodies)))))
(recon-basic))]
; let-values, letrec-values
[(let-values . rest) (recon-let/rec #f)]
@ -440,7 +448,9 @@
(syntax var)]
[else
(error 'recon-source "no matching clause for syntax: ~a" expr)])])
(error 'recon-source "no matching clause for syntax: ~a" (if (syntax? expr)
(syntax-object->datum expr)
expr))])])
(attach-info recon expr)))))))
;; reconstruct-set!-var
@ -686,11 +696,17 @@
(attach-info #`(label #,recon-bindings #,@rectified-bodies) exp))))])
(if (stepper-syntax-property exp 'stepper-fake-exp)
(syntax-case exp ()
(kernel:kernel-syntax-case exp #f
[(begin . bodies)
(if (eq? so-far nothing-so-far)
(error 'recon-inner "breakpoint before a begin reduction should have a result value in exp: ~a" (syntax-object->datum exp))
#`(begin #,so-far #,@(map recon-source-current-marks (cdr (syntax->list #'bodies)))))]
[(begin0 first-body . rest-bodies)
(if (eq? so-far nothing-so-far)
(error 'recon-inner "breakpoint before a begin0 reduction should have a result value in exp: ~a" (syntax-object->datum exp))
#`(begin0 #,(recon-value (lookup-binding mark-list begin0-temp) render-settings)
#,so-far
#,@(map recon-source-current-marks (syntax->list #`rest-bodies))))]
[else
(error 'recon-inner "unexpected fake-exp expression: ~a" (syntax-object->datum exp))])
@ -812,6 +828,14 @@
(recon-source-current-marks exp)
(error 'recon-inner "one-body begin0 given as context: ~a" exp))]
;; the only time begin0 shows up other than in a fake-exp is when the first
;; term is being evaluated
[(begin0 first-body . rest-bodies)
(if (eq? so-far nothing-so-far)
(error 'foo "not implemented")
;; don't know what goes hereyet
#`(begin0 #,so-far #,@(map recon-source-current-marks (syntax->list #`rest-bodies))))]
; let-values
[(let-values . rest) (recon-let)]