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,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)

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

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)

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))

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*
+                    #'?formals #'?formals*
-                         "Rename formal parameters"]
+                    "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))