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

...

Browse Source 
svn: r1818
This commit is contained in:
John Clements 2006-01-12 23:57:44 +00:00
parent b5d041c429
commit de85dc16e7
5 changed files with 82 additions and 71 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -259,7 +259,7 @@
;
(define (annotate main-exp break track-inferred-names?)
(define _ (fprintf (current-error-port) "input to annotate: ~v\n" (syntax-object->datum main-exp)))
#;(define _ (fprintf (current-error-port) "input to annotate: ~v\n" (syntax-object->datum main-exp)))
(define binding-indexer
(let ([binding-index 0])
@ -415,19 +415,21 @@
;; no pre-break, non-tail w.r.t. new bindings
[let-body-recur/first
(lambda (exp)
(normal-break/values-wrap
(apply-to-first-of-2vals
normal-break/values-wrap
(non-tail-recur exp)))]
;; yes pre-break, non-tail w.r.t. new bindings
[let-body-recur/middle
(lambda (exp)
(normal-break/values-wrap
(apply-to-first-of-2vals
normal-break/values-wrap
(annotate/inner exp null #t #f)))]
;; yes pre-break, tail w.r.t. new bindings:
[let-body-recur/last
(lambda (exp bindings)
(annotate/inner exp (binding-set-union (list tail-bound bindings)) #f procedure-name-info))]
(annotate/inner exp (binding-set-union (list tail-bound bindings)) #t procedure-name-info))]
;; different flavors of make-debug-info allow users to provide only the needed fields:
@ -598,14 +600,10 @@
[(first* fv-first) (let-body-recur/first first)]
[(middle* fv-middle) (2vals-map let-body-recur/middle middle)]
[(last* fv-last) (let-body-recur/last last binding-list)]
[first** (return-value-wrap first*)]
[middle** (map return-value-wrap middle*)]
[last** last*])
[(last* fv-last) (let-body-recur/last last binding-list)])
(2vals (quasisyntax/loc exp
(begin #,first** #,@middle** #,last**))
(begin #,first* #,@middle* #,last*))
(varref-set-union (cons fv-first (cons fv-last fv-middle))))))])
((2vals (quasisyntax/loc
@ -785,11 +783,10 @@
[recertifier
(lambda (vals)
(let*-2vals ([(new-exp bindings) vals])
(2vals (stepper-recertify new-exp exp)
bindings
#;(map (lambda (b)
(syntax-recertify b exp (current-code-inspector) #f))
bindings))))]
(2vals (stepper-recertify new-exp exp)
(map (lambda (b)
(syntax-recertify b exp (current-code-inspector) #f))
bindings))))]
)
; find the source expression and associate it with the parsed expression
@ -1070,12 +1067,11 @@
[defined-name (if (and (pair? name-list) (null? (cdr name-list)))
(car name-list)
#f)])
(stepper-recertify
#`(begin
#`(begin
(define-values (new-var ...)
#,(top-level-annotate/inner (top-level-rewrite #`e) exp defined-name))
;; 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 ...))))))))]
(#,exp-finished-break (list (list #,(lambda () exp) #f (lambda () (list new-var ...)))))))]
[(define-syntaxes (new-vars ...) e)
exp]
[(require specs ...)

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

@ -171,7 +171,7 @@
x)
(define break
(opt-lambda (mark-set break-kind [returned-value-list null])
(opt-lambda (mark-set break-kind [returned-value-list #f])
(let* ([mark-list (and mark-set (extract-mark-list mark-set))])
@ -194,15 +194,23 @@
(error 'double-redivide "reconstructed after defs are not equal."))
(values (append finished-exps before) current current-2 after)))
#;(printf "break called with break-kind: ~a ..." break-kind)
(if (r:skip-step? break-kind mark-list render-settings)
(when (eq? break-kind 'normal-break)
(set! held-exp-list skipped-step))
(begin
#;(printf " but it was skipped!\n")
(when (or (eq? break-kind 'normal-break)
(eq? break-kind 'nomal-break/values)) ;; not sure about this...
(set! held-exp-list skipped-step)))
(begin
#;(printf "and it wasn't skipped.\n")
(case break-kind
[(normal-break)
[(normal-break normal-break/values)
(begin
(when (and (eq? break-kind 'normal-break) returned-value-list)
(error 'break "broken invariant: normal-break can't have returned values"))
(set! held-finished-list (reconstruct-all-completed))
(set! held-exp-list (r:reconstruct-left-side mark-list render-settings))
(set! held-exp-list (r:reconstruct-left-side mark-list returned-value-list render-settings))
(set! held-step-was-app? (r:step-was-app? mark-list)))]
[(result-exp-break result-value-break)
@ -264,7 +272,7 @@
(apply add-to-finished source/index/getter))
returned-value-list)]
[else (error 'break "unknown label on break")])))))
[else (error 'break "unknown label on break")]))))))
@ -285,8 +293,8 @@
(program-expander
(lambda ()
; swap these to allow errors to escape (e.g., when debugging)
(error-display-handler err-display-handler)
#;(void)
#;(error-display-handler err-display-handler)
(void)
)
(lambda (expanded continue-thunk) ; iter
(if (eof-object? expanded)

10
collects/stepper/private/my-macros.ss
View File

@ -42,7 +42,7 @@
;;
;;;;;;;;;;
(provide 2vals let*-2vals 2vals-first 2vals-second 2vals-map)
(provide 2vals let*-2vals 2vals-first 2vals-second 2vals-map apply-to-first-of-2vals)
(define 2vals vector)
@ -54,8 +54,8 @@
(syntax/loc stx (let* ([_a rhs] [id-a (vector-ref _a 0)] [id-b (vector-ref _a 1)])
(let*-2vals (binding ...) . bodies)))]
[(let*-2vals ([id-a rhs] binding ...) . bodies) ; just 1 value
(syntax/loc stx (let* ([id-a rhs])
(let*-2vals (binding ...) . bodies)))]))
(quasisyntax/loc stx (let* ([id-a rhs])
#,(syntax/loc stx (let*-2vals (binding ...) . bodies))))]))
(define-syntax (2vals-first stx)
(syntax-case stx (2vals-first)
@ -66,6 +66,10 @@
(syntax-case stx (2vals-second)
[(2vals-second a)
(syntax (vector-ref a 1))]))
(define (apply-to-first-of-2vals proc 2vals)
(vector (proc (vector-ref 2vals 0))
(vector-ref 2vals 1)))
; 2vals-map : (('a -> (2vals 'b 'c)) ('a list)) -> (2vals ('b list) ('c list))
; dual-map is like map, only for a procedure that returns (values a b), and its

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

@ -24,11 +24,12 @@
;; front ends for reconstruct-current
[reconstruct-left-side (mark-list?
(union (listof any/c) false/c)
render-settings?
. -> .
(listof syntax?))]
[reconstruct-right-side (mark-list?
(listof any/c)
(union (listof any/c) false/c)
render-settings?
. -> .
(listof syntax?))]
@ -148,7 +149,7 @@
(let ([and/or-clauses-consumed (syntax-property (mark-source (car mark-list)) 'stepper-and/or-clauses-consumed)])
(and and/or-clauses-consumed
(> and/or-clauses-consumed 0)))]
[(normal-break)
[(normal-break normal-break/values)
(skip-redex-step? mark-list render-settings)]
[(double-break)
(or
@ -820,8 +821,8 @@
;; front ends for reconstruct-current:
(define (reconstruct-left-side mark-list render-settings)
(reconstruct-current mark-list 'left-side null render-settings))
(define (reconstruct-left-side mark-list returned-value-list render-settings)
(reconstruct-current mark-list 'left-side returned-value-list render-settings))
(define (reconstruct-right-side mark-list returned-value-list render-settings)
@ -967,25 +968,24 @@
; if
[(if test then else)
(attach-info
(let ([test-exp (if (eq? so-far nothing-so-far)
(recon-value (lookup-binding mark-list if-temp) render-settings)
so-far)])
#`(if #,test-exp
(begin
(when (eq? so-far nothing-so-far)
(error 'reconstruct "breakpoint before an if reduction should have a result value"))
(attach-info
#`(if #,so-far
#,(recon-source-current-marks (syntax then))
#,(recon-source-current-marks (syntax else))))
exp)]
#,(recon-source-current-marks (syntax else)))
exp))]
; one-armed if
[(if test then)
(attach-info
(let ([test-exp (if (eq? so-far nothing-so-far)
(recon-value (lookup-binding mark-list if-temp) render-settings)
so-far)])
#`(if #,test-exp
#,(recon-source-current-marks (syntax then))))
exp)]
(begin
(when (eq? so-far nothing-so-far)
(error 'reconstruct "breakpoint before an if reduction should have a result value"))
(attach-info
#`(if #,so-far #,(recon-source-current-marks (syntax then)))
exp))]
; quote : there is no break on a quote.
@ -1054,14 +1054,14 @@
[(letrec-values . rest) (recon-let)]
[(set! var rhs)
(attach-info
(let ([rhs-exp (if (eq? so-far nothing-so-far)
(recon-value (lookup-binding mark-list set!-temp) render-settings)
so-far)]
[rendered-var (reconstruct-set!-var mark-list #`var)])
#`(set! #,rendered-var #,rhs-exp))
exp)]
[(set! var rhs)
(begin
(when (eq? so-far nothing-so-far)
(error 'reconstruct "breakpoint before an if reduction should have a result value"))
(attach-info
(let ([rendered-var (reconstruct-set!-var mark-list #`var)])
#`(set! #,rendered-var #,so-far))
exp))]
; lambda : there is no break on a lambda
@ -1094,18 +1094,27 @@
#f))])]))
; uncomment to see all breaks coming in:
#;(define _ (printf "break-kind: ~a\ninnermost source: ~a\n" break-kind
(and (pair? mark-list)
(syntax-object->datum (mark-source (car mark-list))))))
#;(define _ (printf "break-kind: ~a\ninnermost source: ~a\nreturned-value-list: ~a\n"
break-kind
(and (pair? mark-list)
(syntax-object->datum (mark-source (car mark-list))))
returned-value-list))
(define answer
(case break-kind
((left-side)
(unwind (recon nothing-so-far mark-list #t) #f))
(let* ([innermost (if returned-value-list ; is it a normal-break/values?
(begin (unless (and (pair? returned-value-list) (null? (cdr returned-value-list)))
(error 'reconstruct "context expected one value, given ~v" returned-value-list))
(recon-value (car returned-value-list) render-settings))
nothing-so-far)])
(unwind (recon innermost mark-list #t) #f)))
((right-side)
(let* ([innermost (if (null? returned-value-list) ; is it an expr -> expr reduction?
(recon-source-expr (mark-source (car mark-list)) mark-list null null render-settings)
(recon-value (car returned-value-list) render-settings))])
(let* ([innermost (if returned-value-list ; is it an expr -> value reduction?
(begin (unless (and (pair? returned-value-list) (null? (cdr returned-value-list)))
(error 'reconstruct "context expected one value, given ~v" returned-value-list))
(recon-value (car returned-value-list) render-settings))
(recon-source-expr (mark-source (car mark-list)) mark-list null null render-settings))])
(unwind (recon (mark-as-highlight innermost) (cdr mark-list) #f) #f)))
((double-break)
(let* ([source-expr (mark-source (car mark-list))]

10
collects/stepper/private/shared.ss
View File

@ -71,9 +71,6 @@
binding-set? ; predicate
; get-binding-name
; bogus-binding?
if-temp
begin-temp
set!-temp
; get-lifted-gensym
; expr-read
; set-expr-read!
@ -225,10 +222,6 @@
(weak-assoc-add assoc-table stx new-binding)
new-binding)))))))
(define if-temp (syntax-property (datum->syntax-object #`here `if-temp) 'stepper-binding-type 'stepper-temp))
(define begin-temp (syntax-property (datum->syntax-object #`here `begin-temp) 'stepper-binding-type 'stepper-temp))
(define set!-temp (syntax-property (datum->syntax-object #`here `set!-temp) 'stepper-binding-type 'stepper-temp))
; gensyms needed by many modules:
; no-sexp is used to indicate no sexpression for display.
@ -365,7 +358,8 @@
#f))
(define break-kind?
(symbols 'normal-break 'result-exp-break 'result-value-break 'double-break 'late-let-break 'expr-finished-break 'define-struct-break))
(symbols 'normal-break 'normal-break/values 'result-exp-break 'result-value-break
'double-break 'late-let-break 'expr-finished-break 'define-struct-break))
; functional update package