From 89ccab4d4b9d20fcb143d6af9271f4fc2ebac0bd Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Thu, 14 Sep 2006 19:13:26 +0000 Subject: [PATCH] Added events for lift-to-let Added rename-tracking to macro hiding svn: r4339 original commit: 4c41e5515d03ddd02e3e709056be8d8ae565ea2f --- collects/macro-debugger/model/deriv-c.ss | 6 +++-- collects/macro-debugger/model/deriv-parser.ss | 22 +++++++++++++++---- collects/macro-debugger/model/deriv-tokens.ss | 2 ++ collects/macro-debugger/model/deriv.ss | 8 +++++++ collects/macro-debugger/model/reductions.ss | 16 ++++++++++---- 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 index 9c5380c..23b5294 100644 --- 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 index 45a291b..51c6c34 100644 --- 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 index 68a0940..ad7324e 100644 --- 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 index 45f67fa..7eb517f 100644 --- 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 index 8992e24..b4d09db 100644 --- 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))