commit 0b5b000078fc8a162744f0400cf16b2ac5aaf969
parent c9d748d3f88abeadcdfa32eaaa22785d94e73263
Author: Ryan Culpepper <ryanc@racket-lang.org>
Date: Tue, 8 May 2007 20:56:37 +0000
Macro stepper:
- removed dead seek-syntax code
- fixed bug related to hiding + errors
- fixed bug finding bindings in interrrupted expansion
svn: r6182
original commit: e4e5ec407498cbe36faa26ff37c55c445a236748
Diffstat:
3 files changed, 22 insertions(+), 14 deletions(-)
diff --git a/collects/macro-debugger/model/debug.ss b/collects/macro-debugger/model/debug.ss
@@ -5,12 +5,14 @@
"deriv-util.ss"
"hide.ss"
"hiding-policies.ss"
- "deriv.ss")
+ "deriv.ss"
+ "steps.ss")
(provide (all-from "trace.ss")
(all-from "deriv.ss")
(all-from "deriv-util.ss")
(all-from "hiding-policies.ss")
(all-from "hide.ss")
+ (all-from "steps.ss")
(all-from (lib "plt-match.ss")))
)
diff --git a/collects/macro-debugger/model/deriv-util.ss b/collects/macro-debugger/model/deriv-util.ss
@@ -272,7 +272,11 @@
;; FIXME: Missing case-lambda
(define (extract-all-fresh-names d)
(define (renaming-node? x)
- (or (p:lambda? x)
+ (or (and (error-wrap? x)
+ (renaming-node? (error-wrap-inner x)))
+ (and (interrupted-wrap? x)
+ (renaming-node? (interrupted-wrap-inner x)))
+ (p:lambda? x)
(p:case-lambda? x)
(p:let-values? x)
(p:letrec-values? x)
@@ -284,22 +288,22 @@
(p:define-syntaxes? x)))
(define (extract-fresh-names d)
(match d
- [(struct p:lambda (e1 e2 rs renames body))
+ [(AnyQ p:lambda (e1 e2 rs renames body))
(if renames
(with-syntax ([(?formals . ?body) renames])
#'?formals)
null)]
- [(struct p:let-values (e1 e2 rs renames rhss body))
+ [(AnyQ p:let-values (e1 e2 rs renames rhss body))
(if renames
(with-syntax ([(((?vars ?rhs) ...) . ?body) renames])
#'(?vars ...))
null)]
- [(struct p:letrec-values (e1 e2 rs renames rhss body))
+ [(AnyQ p:letrec-values (e1 e2 rs renames rhss body))
(if renames
(with-syntax ([(((?vars ?rhs) ...) . ?body) renames])
#'(?vars ...))
null)]
- [(struct p:letrec-syntaxes+values (e1 e2 rs srenames srhss vrenames vrhss body))
+ [(AnyQ p:letrec-syntaxes+values (e1 e2 rs srenames srhss vrenames vrhss body))
(cons
(if srenames
(with-syntax ([(((?svars ?srhs) ...) ((?vvars ?vrhs) ...) . ?body)
@@ -310,24 +314,24 @@
(with-syntax ([(((?vvars ?vrhs) ...) . ?body) vrenames])
#'(?vvars ...))
null))]
- [(struct b:defvals (rename head))
+ [(AnyQ b:defvals (rename head))
(let ([head-e2 (lift/deriv-e2 head)])
(if head-e2
(with-syntax ([(?dv ?vars ?rhs) head-e2])
#'?vars)
null))]
- [(struct b:defstx (rename head rhs))
+ [(AnyQ b:defstx (rename head rhs))
(let ([head-e2 (lift/deriv-e2 head)])
(if head-e2
(with-syntax ([(?ds ?svars ?rhs) head-e2])
#'?svars)
null))]
- [(struct p:define-values (e1 e2 rs rhs))
+ [(AnyQ p:define-values (e1 e2 rs rhs))
(if rhs
(with-syntax ([(?dv ?vars ?rhs) e1])
#'?vars)
null)]
- [(struct p:define-syntaxes (e1 e2 rs rhs))
+ [(AnyQ p:define-syntaxes (e1 e2 rs rhs))
(if rhs
(with-syntax ([(?ds ?svars ?srhs) e1])
#'?svars)
diff --git a/collects/macro-debugger/model/reductions.ss b/collects/macro-debugger/model/reductions.ss
@@ -317,7 +317,8 @@
(let ([ctx (lambda (x) (path-replace term path0 x))])
(append (with-context ctx
(reductions* deriv0))
- (loop (and (deriv? deriv0)
+ (loop (and term
+ (deriv? deriv0)
(path-replace term path0 (deriv-e2 deriv0)))
(cdr subterms)))))]
[(s:rename? (car subterms))
@@ -326,9 +327,10 @@
;; FIXME: if so, coalesce?
(rename-frontier (s:rename-before subterm0)
(s:rename-after subterm0))
- (loop (path-replace term
- (s:rename-path subterm0)
- (s:rename-after subterm0))
+ (loop (and term
+ (path-replace term
+ (s:rename-path subterm0)
+ (s:rename-after subterm0)))
(cdr subterms)))]))]
;; FIXME
