commit 89ccab4d4b9d20fcb143d6af9271f4fc2ebac0bd
parent 1c1a9c1e880d76fb700cd61eeeec4ebfb13e491c
Author: Ryan Culpepper <ryanc@racket-lang.org>
Date: Thu, 14 Sep 2006 19:13:26 +0000
Added events for lift-to-let
Added rename-tracking to macro hiding
svn: r4339
original commit: 4c41e5515d03ddd02e3e709056be8d8ae565ea2f
Diffstat:
5 files changed, 44 insertions(+), 10 deletions(-)
diff --git a/collects/macro-debugger/model/deriv-c.ss b/collects/macro-debugger/model/deriv-c.ss
@@ -6,9 +6,11 @@
;; - a PRule
;; - (make-mrule syntax syntax Transformation Derivation)
;; - (make-lift-deriv syntax syntax Derivation syntax Derivation)
+ ;; - (make-lift/let-deriv syntax syntax Derivation syntax Derivation)
(define-struct deriv (e1 e2) #f)
(define-struct (mrule deriv) (transformation next) #f)
(define-struct (lift-deriv deriv) (first lift-stx second) #f)
+ (define-struct (lift/let-deriv deriv) (first lift-stx second) #f)
;; A Transformation is
;; (make-transformation syntax syntax (listof identifier) syntax syntax (listof LocalAction))
@@ -85,9 +87,9 @@
;; A Subterm is one of
;; - (make-s:subterm Path Derivation)
+ ;; - (make-s:rename Path Syntax Syntax)
(define-struct s:subterm (path deriv) #f)
-
-
+ (define-struct s:rename (path before after) #f)
;; A ListDerivation is (make-lderiv Syntaxes Syntaxes (listof Derivation))
(define-struct lderiv (es1 es2 derivs) #f)
diff --git a/collects/macro-debugger/model/deriv-parser.ss b/collects/macro-debugger/model/deriv-parser.ss
@@ -77,6 +77,20 @@
(let ([initial (deriv-e1 $1)]
[final (and (deriv? $3) (deriv-e2 $3))])
(make-lift-deriv initial final $1 $2 $3))])
+
+
+ ;; Expand/LetLifts
+ ;; Expand/LetLifts Answer = Derivation (I)
+ ;; Used for expand_lift_to_let (rhs of define-syntaxes, mostly)
+ (EE/LetLifts
+ (#:no-wrap)
+ [((? EE)) $1]
+ [((? EE/LetLifts+)) $1])
+ (EE/LetLifts+
+ [(EE lift/let-loop (? EE/LetLifts))
+ (let ([initial (deriv-e1 $1)]
+ [final (and (deriv? $3) (deriv-e2 $3))])
+ (make-lift/let-deriv initial final $1 $2 $3))])
;; Evaluation
(Eval
@@ -133,7 +147,7 @@
(make-local-lift (car $1) (cdr $1))]
[(lift-statement)
(make-local-lift-end $1)]
- [(phase-up (? EE/Lifts))
+ [(phase-up (? EE/LetLifts))
(make-local-bind $2)])
;; Multiple calls to local-expand
@@ -240,7 +254,7 @@
(ModulePass1/Prim
[(enter-prim prim-define-values ! exit-prim)
(make-p:define-values $1 $4 null #f)]
- [(enter-prim prim-define-syntaxes ! phase-up (? EE/Lifts) exit-prim)
+ [(enter-prim prim-define-syntaxes ! phase-up (? EE/LetLifts) exit-prim)
(make-p:define-syntaxes $1 $6 null $5)]
[(enter-prim prim-require ! exit-prim)
(make-p:require $1 $4 null)]
@@ -276,7 +290,7 @@
;; Definitions
(PrimDefineSyntaxes
(#:args e1 e2 rs)
- [(prim-define-syntaxes ! (? EE/Lifts))
+ [(prim-define-syntaxes ! (? EE/LetLifts))
(make-p:define-syntaxes e1 e2 rs $3)])
(PrimDefineValues
@@ -447,7 +461,7 @@
;; BindSyntaxes Answer = Derivation
(BindSyntaxes
- [(phase-up (? EE/Lifts) Eval) $2])
+ [(phase-up (? EE/LetLifts) Eval) $2])
;; NextBindSyntaxess Answer = (list-of Derivation)
(NextBindSyntaxess
diff --git a/collects/macro-debugger/model/deriv-tokens.ss b/collects/macro-debugger/model/deriv-tokens.ss
@@ -30,6 +30,7 @@
EOF ; .
syntax-error ; exn
lift-loop ; syntax
+ lift/let-loop ; syntax
lift-end-loop ; syntax
lift ; (cons syntax id)
lift-statement ; syntax
@@ -128,6 +129,7 @@
(133 . ,token-local-post)
(134 . ,token-lift-statement)
(135 . ,token-lift-end-loop)
+ (136 . ,token-lift/let-loop)
))
(define (tokenize sig-n val pos)
diff --git a/collects/macro-debugger/model/deriv.ss b/collects/macro-debugger/model/deriv.ss
@@ -51,6 +51,12 @@
[first deriv?]
[lift-stx syntax?]
[second (anyq deriv?)]))
+ (struct (lift/let-deriv deriv)
+ ([e1 syntax?]
+ [e2 syntax/f]
+ [first deriv?]
+ [lift-stx syntax?]
+ [second (anyq deriv?)]))
(struct transformation
([e1 syntax?]
[e2 syntax/f]
@@ -86,6 +92,7 @@
(provide ;(struct deriv (e1 e2))
;(struct mrule (transformation next))
;(struct lift-deriv (first lift-stx second))
+ ;(struct lift/let-deriv (first lift-stx second))
;(struct transformation (e1 e2 resolves me1 me2 locals))
@@ -127,6 +134,7 @@
(struct p:synth (subterms))
(struct s:subterm (path deriv))
+ (struct s:rename (path before after))
;(struct lderiv (es1 es2 derivs))
(struct bderiv (es1 es2 pass1 trans pass2))
diff --git a/collects/macro-debugger/model/reductions.ss b/collects/macro-debugger/model/reductions.ss
@@ -105,8 +105,8 @@
[#:bind (?formals* . ?body*) renames]
[#:pattern (?lambda ?formals . ?body)]
[#:rename (syntax/skeleton e1 (?lambda ?formals* . ?body*))
- #'?formals #'?formals*
- "Rename formal parameters"]
+ #'?formals #'?formals*
+ "Rename formal parameters"]
[Block ?body body])]
[(struct p:case-lambda (e1 e2 rs renames+bodies))
#;
@@ -221,7 +221,7 @@
(if exn
(list (stumble term exn))
null))]
- [(pair? subterms)
+ [(s:subterm? (car subterms))
(let* ([subterm0 (car subterms)]
[path0 (s:subterm-path subterm0)]
[deriv0 (s:subterm-deriv subterm0)])
@@ -229,7 +229,15 @@
(append (with-context ctx
(reductions deriv0))
(loop (path-replace term path0 (deriv-e2 deriv0))
- (cdr subterms)))))]))]
+ (cdr subterms)))))]
+ [(s:rename? (car subterms))
+ (let* ([subterm0 (car subterms)])
+ ;; FIXME: add renaming steps?
+ ;; FIXME: if so, coalesce?
+ (loop (path-replace term
+ (s:rename-path subterm0)
+ (s:rename-after subterm0))
+ (cdr subterms)))]))]
;; FIXME
[(IntQ p:rename (e1 e2 rs rename inner))
