commit a169d49e04ff5cd826d90aced7f283305ab8d071
parent 41538c81f5e006613093b416347b8d166d933c96
Author: Ryan Culpepper <ryanc@racket-lang.org>
Date: Fri, 23 Feb 2007 08:01:33 +0000
Macro stepper: added env/renaming tracking
svn: r5669
original commit: 0a194c3eae0582026112b294e05fe32565af0b71
Diffstat:
4 files changed, 107 insertions(+), 16 deletions(-)
diff --git a/collects/macro-debugger/model/deriv-util.ss b/collects/macro-debugger/model/deriv-util.ss
@@ -19,7 +19,9 @@
find-derivs
find-deriv
- find-derivs/syntax)
+ find-derivs/syntax
+ extract-all-fresh-names
+ flatten-identifiers)
;; IntW
;; Matches only interrupted wraps
@@ -138,20 +140,25 @@
;; find-derivs : (deriv -> boolean) (deriv -> boolean) deriv -> (list-of deriv)
(define (find-derivs pred stop-short d)
- (find-deriv/unit+join+zero pred stop-short d list append null))
+ (let ([stop (lambda (x) (or (pred x) (stop-short x)))])
+ (find-deriv/unit+join+zero pred stop d list append null)))
;; find-deriv : (deriv -> boolean) (deriv -> boolean) deriv -> deriv/#f
;; Finds the first deriv that matches; throws the rest away
(define (find-deriv pred stop-short d)
- (let/ec return (find-deriv/unit+join+zero pred stop-short d return (lambda _ #f) #f)))
+ (let ([stop (lambda (x) (or (pred x) (stop-short x)))])
+ (let/ec return (find-deriv/unit+join+zero pred stop d return (lambda _ #f) #f))))
;; find-deriv/unit+join+zero
;; Parameterized over monad operations for combining the results
;; For example, <list, append, null> collects the results into a list
(define (find-deriv/unit+join+zero pred stop-short d unit join zero)
(define (loop d)
+ (if (pred d)
+ (join (unit d) (loop-inner d))
+ (loop-inner d)))
+ (define (loop-inner d)
(match d
- [(? pred d) (unit d)]
[(? stop-short d) zero]
[(AnyQ mrule (_ _ tx next))
(join (loop tx) (loop next))]
@@ -246,4 +253,66 @@
[(AnyQ lift-deriv (_ _ _ _ _)) #t]
[_ #f])
d))
- )
+
+ ;; extract-all-fresh-names : Derivation -> syntaxlike
+ ;; FIXME: Missing case-lambda
+ (define (extract-all-fresh-names d)
+ (define (renaming-node? x)
+ (or (p:lambda? x)
+ (p:case-lambda? x)
+ (p:let-values? x)
+ (p:letrec-values? x)
+ (p:letrec-syntaxes+values? x)
+ (p:rename? x)))
+ (define (extract-fresh-names d)
+ (match d
+ [(struct 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))
+ (if renames
+ (with-syntax ([(((?vars ?rhs) ...) . ?body) renames])
+ #'(?vars ...))
+ null)]
+ [(struct 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))
+ (cons
+ (if srenames
+ (with-syntax ([(((?svars ?srhs) ...) ((?vvars ?vrhs) ...) . ?body)
+ srenames])
+ #'(?svars ... ?vvars ...))
+ null)
+ (if vrenames
+ (with-syntax ([(((?vvars ?vrhs) ...) . ?body) vrenames])
+ #'(?vvars ...))
+ null))]
+ [_ null]))
+
+ (let ([all-renaming-forms
+ (find-deriv/unit+join+zero
+ renaming-node?
+ (lambda (d) #f)
+ d
+ list
+ append
+ null)])
+ (flatten-identifiers (map extract-fresh-names all-renaming-forms))))
+
+ ;; flatten-identifiers : syntaxlike -> (list-of identifier)
+ (define (flatten-identifiers stx)
+ (syntax-case stx ()
+ [id (identifier? #'id) (list #'id)]
+ [() null]
+ [(x . y) (append (flatten-identifiers #'x) (flatten-identifiers #'y))]
+ [else (error 'flatten-identifers "neither syntax list nor identifier: ~s"
+ (if (syntax? stx)
+ (syntax-object->datum stx)
+ stx))]))
+
+)
diff --git a/collects/macro-debugger/model/reductions-engine.ss b/collects/macro-debugger/model/reductions-engine.ss
@@ -27,7 +27,7 @@
;; current-derivation : parameter of Derivation
(define current-derivation (make-parameter #f))
-
+
(define-syntax with-context
(syntax-rules ()
[(with-context f . body)
@@ -95,10 +95,11 @@
#'(let-values ([(form2-var foci1-var foci2-var description-var)
(with-syntax ([p f])
(values form2 foci1 foci2 description))])
- (cons (walk/foci foci1-var foci2-var
- f form2-var
- description-var)
- (R** form2-var p . more)))]
+ (with-context (make-renames foci1-var foci2-var)
+ (cons (walk/foci foci1-var foci2-var
+ f form2-var
+ description-var)
+ (R** form2-var p . more))))]
[(R** f p [#:walk form2 description] . more)
#'(let-values ([(form2-var description-var)
(with-syntax ([p f])
diff --git a/collects/macro-debugger/model/reductions.ss b/collects/macro-debugger/model/reductions.ss
@@ -143,6 +143,7 @@
(cons (walk/foci (syntax->list #'(?formals ...))
(syntax->list #'(?formals* ...))
e1 mid 'rename-case-lambda)
+ ;; FIXME: Missing renames frames here
(R mid (CASE-LAMBDA [FORMALS . BODY] ...)
[Block (BODY ...) (map cdr renames+bodies)]))))]
[(AnyQ p:let-values (e1 e2 rs renames rhss body) exni)
diff --git a/collects/macro-debugger/model/steps.ss b/collects/macro-debugger/model/steps.ss
@@ -1,13 +1,18 @@
(module steps mzscheme
- (require "deriv.ss")
+ (require "deriv.ss"
+ "deriv-util.ss")
;; A ReductionSequence is a (list-of Reduction)
;; A ProtoStep is (make-protostep Derivation BigContext StepType Context)
;; A Context is a list of Frames
- ;; A Frame is (syntax -> syntax)
+ ;; A Frame is either:
+ ;; - (syntax -> syntax)
+ ;; - (make-renames syntax syntax)
+ ;; - 'phase-up
+ (define-struct renames (old new))
;; A BigContext is (list-of BigFrame)
;; A BigFrame is (make-bigframe Derivation Context Syntaxes Syntax)
@@ -16,9 +21,9 @@
;; A Reduction is one of
;; - (make-step ... Syntaxes Syntaxes Syntax Syntax)
;; - (make-misstep ... Syntax Syntax Exception)
-
+
(define-struct protostep (deriv lctx type ctx) #f)
-
+
(define-struct (step protostep) (foci1 foci2 e1 e2) #f)
(define-struct (misstep protostep) (foci1 e1 exn) #f)
@@ -27,7 +32,22 @@
(let loop ([ctx ctx] [stx stx])
(if (null? ctx)
stx
- (loop (cdr ctx) ((car ctx) stx)))))
+ (let ([frame0 (car ctx)])
+ (if (procedure? frame0)
+ (loop (cdr ctx) (frame0 stx))
+ (loop (cdr ctx) stx))))))
+
+ ;; context-env : Context -> (list-of identifier)
+ (define (context-env ctx)
+ (let loop ([ctx ctx] [env null])
+ (if (null? ctx)
+ env
+ (let ([frame0 (car ctx)])
+ (if (renames? frame0)
+ (loop (cdr ctx)
+ (append (flatten-identifiers (renames-new frame0))
+ env))
+ (loop (cdr ctx) env))))))
(define (step-term1 s)
(context-fill (protostep-ctx s) (step-e1 s)))
@@ -39,7 +59,7 @@
(define (bigframe-term bf)
(context-fill (bigframe-ctx bf) (bigframe-e bf)))
-
+
;; A StepType is a simple in the following alist.
(define step-type-meanings
