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

Macro stepper: improved frontier tracking and macro hiding

Browse Source 
svn: r5724

original commit: bb937c80a1437dc598772414491dc886f13b02d8
This commit is contained in:
Ryan Culpepper 2007-03-03 09:08:23 +00:00
parent a4731a40e8
commit be8ce288fa
1 changed files with 29 additions and 5 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

34
collects/macro-debugger/model/reductions.ss
View File

@ -166,7 +166,9 @@
[Block (?body ...) (map cdr renames+bodies)]) [Block (?body ...) (map cdr renames+bodies)])
(with-syntax ([(?case-lambda [?formals . ?body] ...) e1] (with-syntax ([(?case-lambda [?formals . ?body] ...) e1]
[((?formals* . ?body*) ...) (map car renames+bodies)]) [((?formals* . ?body*) ...) (map car renames+bodies)])
(add-frontier (apply append (map stx->list (syntax->list #'(?body ...)))))
(let ([mid (syntax/skeleton e1 (?case-lambda [?formals* . ?body*] ...))]) (let ([mid (syntax/skeleton e1 (?case-lambda [?formals* . ?body*] ...))])
(rename-frontier #'(?formals ...) #'(?formals* ...))
(cons (walk/foci (syntax->list #'(?formals ...)) (cons (walk/foci (syntax->list #'(?formals ...))
(syntax->list #'(?formals* ...)) (syntax->list #'(?formals* ...))
e1 mid 'rename-case-lambda) e1 mid 'rename-case-lambda)
@ -272,6 +274,24 @@
;; These have their own subterm replacement mechanisms ;; These have their own subterm replacement mechanisms
;; FIXME: Frontier ;; FIXME: Frontier
[(and d (AnyQ p:synth (e1 e2 rs subterms))) [(and d (AnyQ p:synth (e1 e2 rs subterms)))
;; First, compute the frontier based on the expanded subterms
;; Run through the renames in reverse order to get the pre-renamed terms
(define synth-frontier
(parameterize ((current-frontier null))
(let floop ([subterms subterms])
(cond [(null? subterms)
(void)]
[(s:subterm? (car subterms))
(floop (cdr subterms))
(add-frontier
(list (lift/deriv-e1 (s:subterm-deriv (car subterms)))))]
[(s:rename? (car subterms))
(floop (cdr subterms))
(rename-frontier (s:rename-after (car subterms))
(s:rename-before (car subterms)))]))
(current-frontier)))
(add-frontier synth-frontier)
;; Then compute the reductions
(let loop ([term e1] [subterms subterms]) (let loop ([term e1] [subterms subterms])
(cond [(null? subterms) (cond [(null? subterms)
(let ([exn (and (error-wrap? d) (error-wrap-exn d))]) (let ([exn (and (error-wrap? d) (error-wrap-exn d))])
@ -292,6 +312,8 @@
(let* ([subterm0 (car subterms)]) (let* ([subterm0 (car subterms)])
;; FIXME: add renaming steps? ;; FIXME: add renaming steps?
;; FIXME: if so, coalesce? ;; FIXME: if so, coalesce?
(rename-frontier (s:rename-before subterm0)
(s:rename-after subterm0))
(loop (path-replace term (loop (path-replace term
(s:rename-path subterm0) (s:rename-path subterm0)
(s:rename-after subterm0)) (s:rename-after subterm0))
@ -299,7 +321,7 @@
;; FIXME ;; FIXME
[(IntQ p:rename (e1 e2 rs rename inner)) [(IntQ p:rename (e1 e2 rs rename inner))
;; FIXME: frontier (rename-frontier (car rename) (cdr rename))
(reductions* inner)] (reductions* inner)]
;; Error ;; Error
@ -314,11 +336,13 @@
;; Lifts ;; Lifts
;; FIXME: frontier
[(IntQ lift-deriv (e1 e2 first lifted-stx second)) [(IntQ lift-deriv (e1 e2 first lifted-stx second))
(append (reductions* first) (blaze-frontier e1)
(list (walk (deriv-e2 first) lifted-stx 'capture-lifts)) (let ([rs1 (reductions* first)])
(reductions* second))] (add-frontier (list lifted-stx))
(append rs1
(list (walk (deriv-e2 first) lifted-stx 'capture-lifts))
(reductions* second)))]
;; Skipped ;; Skipped