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

...

Browse Source 
svn: r1813
This commit is contained in:
John Clements 2006-01-12 08:34:10 +00:00
parent 723bf14c5b
commit 8012ebb396
1 changed files with 39 additions and 16 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -277,6 +277,9 @@
(define (result-value-break vals-list) (define (result-value-break vals-list)
(break (current-continuation-marks) 'result-value-break vals-list)) (break (current-continuation-marks) 'result-value-break vals-list))
(define (result-value-break/begin vals-list)
(break (current-continuation-marks) 'result-value-break/begin vals-list))
(define (exp-finished-break info-list) (define (exp-finished-break info-list)
(break #f 'expr-finished-break info-list)) (break #f 'expr-finished-break info-list))
@ -287,21 +290,34 @@
(define (wcm-pre-break-wrap debug-info exp) (define (wcm-pre-break-wrap debug-info exp)
(wcm-wrap debug-info (pre-break-wrap exp))) (wcm-wrap debug-info (pre-break-wrap exp)))
;; wrap a pre-break around stx
(define (pre-break-wrap stx) (define (pre-break-wrap stx)
#`(begin (#,result-exp-break) #,stx)) #`(begin (#,result-exp-break) #,stx))
;; wrap a normal break around stx
(define (break-wrap exp) (define (break-wrap exp)
#`(begin (#,normal-break) #,exp)) #`(begin (#,normal-break) #,exp))
;; wrap a double-break around exp
(define (double-break-wrap exp) (define (double-break-wrap exp)
#`(begin (#,double-break) #,exp)) #`(begin (#,double-break) #,exp))
(define (return-value-wrap exp) ;; abstraction used in the next two defs
#`(call-with-values (define (return-value-wrap-maker break-proc)
(lambda () #,exp) (lambda (exp)
(lambda args #`(call-with-values
(#,result-value-break args) (lambda () #,exp)
(apply values args)))) (lambda args
(#,break-proc args)
(apply values args)))))
;; wrap a return-value-break around exp
(define return-value-wrap
(return-value-wrap-maker result-value-break))
;; wrap a return-value-break/begin around exp
(define return-value-wrap/begin
(return-value-wrap-maker result-value-break/begin))
(define (make-define-struct-break exp) (define (make-define-struct-break exp)
@ -399,13 +415,15 @@
;; no pre-break, non-tail w.r.t. new bindings ;; no pre-break, non-tail w.r.t. new bindings
[let-body-recur/first [let-body-recur/first
;; whoops! this one is just "non-tail-recur" (lambda (exp)
non-tail-recur] (return-value-wrap/begin
(non-tail-recur exp)))]
;; yes pre-break, non-tail w.r.t. new bindings ;; yes pre-break, non-tail w.r.t. new bindings
[let-body-recur/middle [let-body-recur/middle
(lambda (exp) (lambda (exp)
(annotate/inner exp null #t #f))] (return-value-wrap/begin
(annotate/inner exp null #t #f)))]
;; yes pre-break, tail w.r.t. new bindings: ;; yes pre-break, tail w.r.t. new bindings:
[let-body-recur/last [let-body-recur/last
@ -730,8 +748,9 @@
[recertifier [recertifier
(lambda (vals) (lambda (vals)
(let*-2vals ([(new-exp bindings) vals]) (let*-2vals ([(new-exp bindings) vals])
(2vals (syntax-recertify new-exp exp (current-code-inspector) #f) (2vals (stepper-recertify new-exp exp)
(map (lambda (b) bindings
#;(map (lambda (b)
(syntax-recertify b exp (current-code-inspector) #f)) (syntax-recertify b exp (current-code-inspector) #f))
bindings))))] bindings))))]
@ -924,6 +943,9 @@
[else [else
(error 'annotate "unexpected syntax for expression: ~v" (syntax-object->datum exp))])))]))) (error 'annotate "unexpected syntax for expression: ~v" (syntax-object->datum exp))])))])))
(define (stepper-recertify new-stx old-stx)
(syntax-recertify new-stx old-stx (current-code-inspector) #f))
;; annotate/top-level : syntax-> syntax ;; annotate/top-level : syntax-> syntax
;; expansion of teaching level language programs produces two kinds of ;; expansion of teaching level language programs produces two kinds of
@ -966,11 +988,12 @@
[defined-name (if (and (pair? name-list) (null? (cdr name-list))) [defined-name (if (and (pair? name-list) (null? (cdr name-list)))
(car name-list) (car name-list)
#f)]) #f)])
#`(begin (stepper-recertify
(define-values (new-var ...) #`(begin
#,(top-level-annotate/inner (top-level-rewrite #`e) exp defined-name)) (define-values (new-var ...)
;; this next expression should deliver the newly computed values to an exp-finished-break #,(top-level-annotate/inner (top-level-rewrite #`e) exp defined-name))
(#,exp-finished-break (list (list #,(lambda () exp) #f (lambda () (list new-var ...)))))))] ;; this next expression should deliver the newly computed values to an exp-finished-break
(#,exp-finished-break (list (list #,(lambda () exp) #f (lambda () (list new-var ...))))))))]
[(define-syntaxes (new-vars ...) e) [(define-syntaxes (new-vars ...) e)
exp] exp]
[(require specs ...) [(require specs ...)