Added events for lift-to-let

Added rename-tracking to macro hiding

svn: r4339

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

@@ -78,6 +78,20 @@
               [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
        [() #f])
@@ -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/hide.ss

@@ -12,10 +12,11 @@
   #;
   (provide hide/policy
            hide
-           seek/syntax
+           #;seek/syntax
-           macro-policy)
+           macro-policy
+           current-hiding-warning-handler)
 
-  ;; hide : Derivation (identifier -> boolean) -> (values Derivation syntax)
+  ;; hide/policy : Derivation (identifier -> boolean) -> (values Derivation syntax)
   (define (hide/policy deriv show-macro?)
     (parameterize ((macro-policy show-macro?))
       (hide deriv)))
@@ -200,29 +201,43 @@
                                #f)]))))]
         [(AnyQ p:lambda (e1 e2 rs renames body))
          (>>P d (make-p:lambda renames body)
-              (lambda formals . BODY)
+              (lambda FORMALS . BODY)
-              ([for-bderiv BODY body]))]
+              ([for-rename (FORMALS . _B) renames]
+               [for-bderiv BODY body]))]
 
         [(AnyQ p:case-lambda (e1 e2 rs renames+bodies))
+         (let ([var-renames (map car renames+bodies)])
            (>>P d (make-p:case-lambda renames+bodies)
-              (case-lambda [formals . BODY] ...)
+                (case-lambda [FORMALS . BODY] ...)
-              ([for-cdr-bderivs (BODY ...) renames+bodies]))]
+                ([for-renames (FORMALS ...) var-renames]
+                 [for-cdr-bderivs (BODY ...) renames+bodies])))]
 
         [(AnyQ p:let-values (e1 e2 rs renames rhss body))
+         (let ([var-renames (map stx-car (stx-car renames))])
            (>>P d (make-p:let-values renames rhss body)
                 (let-values ([VARS RHS] ...) . BODY)
-              ([for-derivs (RHS ...) rhss] [for-bderiv BODY body]))]
+                ([for-renames (VARS ...) var-renames]
+                 [for-derivs (RHS ...) rhss] 
+                 [for-bderiv BODY body])))]
+
         [(AnyQ p:letrec-values (e1 e2 rs renames rhss body))
+         (let ([var-renames (map stx-car (stx-car renames))])
            (>>P d (make-p:letrec-values renames rhss body)
                 (letrec-values ([VARS RHS] ...) . BODY)
-              ([for-derivs (RHS ...) rhss] [for-bderiv BODY body]))]
+                ([for-renames (VARS ...) var-renames]
+                 [for-derivs (RHS ...) rhss]
+                 [for-bderiv BODY body])))]
 
         [(AnyQ p:letrec-syntaxes+values (e1 e2 rs srenames srhss vrenames vrhss body))
+         (let ([svar-renames (map stx-car (stx-car srenames))]
+               [vvar-renames (map stx-car (stx-car vrenames))])
            (>>Pn d (make-p:letrec-syntaxes+values srenames srhss vrenames vrhss body)
                  (letrec-syntaxes+values ([SVARS SRHS] ...) ([VVARS VRHS] ...) . BODY)
-               ([for-derivs (SRHS ...) srhss]
+                 ([for-renames (SVARS ...) svar-renames]
+                  [for-renames (VVARS ...) vvar-renames]
+                  [for-derivs (SRHS ...) srhss]
                   [for-derivs (VRHS ...) vrhss]
-                [for-bderiv BODY body]))]
+                  [for-bderiv BODY body])))]
         [(AnyQ p:#%datum (e1 e2 rs tagged-stx))
          (cond [(or (eq? tagged-stx e1) (show-macro? #'#%datum))
                 (values d e2)]
@@ -279,6 +294,14 @@
 
         [#f (values #f #f)]))
 
+    ;; for-rename : Rename -> (values Rename syntax)
+    (define (for-rename rename)
+      (values rename rename))
+
+    ;; for-renames : (list-of Rename) -> (values (list-of Rename) syntaxes)
+    (define (for-renames renames)
+      (values renames renames))
+
     ;; for-derivs : (list-of Derivation) -> (values (list-of Derivation) (list-of syntax))
     (define (for-derivs derivs)
       (let ([results 
@@ -342,6 +365,7 @@
   ;; Does track the syntax through renaming, however.
   ;; Returns the whole derivation followed by the subterm derivation.
   ;; If there is no subderivation for that syntax, returns #f.
+  #;
   (define (seek/syntax stx deriv)
     (let ([subterms (gather-one-subterm (deriv-e1 deriv) stx)])
       (parameterize ((subterms-table subterms))
@@ -379,14 +403,14 @@
 
   ;; create-synth-deriv : syntax (list-of Subterm) -> Derivation
   (define (create-synth-deriv e1 subterm-derivs)
+    (define (error? x) (and (s:subterm? x) (not (s:subterm-path x))))
     (let ([errors
-           (map s:subterm-deriv
+           (map s:subterm-deriv (filter error? subterm-derivs))]
-                (filter (lambda (x) (not (s:subterm-path x))) subterm-derivs))]
+          [subterms (filter (lambda (x) (not (error? x))) subterm-derivs)])
-          [subterm-derivs (filter s:subterm-path subterm-derivs)])
       ;(printf "subterm paths:~n~s~n" (map s:subterm-path subterm-derivs))
       ;(printf "subterms:~n~s~n" subterm-derivs)
-      (let ([e2 (substitute-subterms e1 subterm-derivs)])
+      (let ([e2 (substitute-subterms e1 subterms)])
-        (let ([d (make-p:synth e1 e2 null subterm-derivs)])
+        (let ([d (make-p:synth e1 e2 null subterms)])
           (if (pair? errors)
               (make-error-wrap (error-wrap-exn (car errors))
                                (error-wrap-tag (car errors))
@@ -455,48 +479,48 @@
                  (for-lderiv lderiv))]
         [(AnyQ p:#%app (e1 e2 rs tagges-stx lderiv))
          (>>Seek (for-lderiv lderiv))]
-        [(AnyQ p:lambda (e1 e2 rs renames body))
+        [(AnyQ p:lambda (e1 e2 rs renames body) exni)
          ;; 1 Make a new table
          ;;   Can narrow table to things that only occur in the renames
          ;; 2 Search body
          ;; 3 Make a "renaming" step... FIXME, how to represent?
-         (>>Seek [#:table (table-restrict/lambda e1 renames)]
+         (>>Seek [! exni]
+                 [#:rename (do-rename/lambda e1 renames)]
                  (for-bderiv body))]
         [(AnyQ p:case-lambda (e1 e2 rs renames+bodies))
-         ;; Like lambda
          (with-syntax ([(?case-lambda ?clause ...) e1])
-           (apply append
+           (let ()
-                  (map (lambda (rename+body clause-stx)
+             (define (handle-clause clause-stx rename body)
-                         (let ([new-table (table-restrict/case-lambda clause-stx (car rename+body))])
+               (>>Seek [#:rename (do-rename/case-lambda clause-stx rename)]
-                           (parameterize ((subterms-table new-table))
+                       (for-bderiv body)))
-                             (for-bderiv (cdr rename+body)))))
+             (let loop ([clauses (syntax->list #'(?clause ...))]
-                       renames+bodies
+                        [renames+bodies renames+bodies])
-                       (syntax->list #'(?clause ...)))))]
+               (if (pair? renames+bodies)
+                   (append (handle-clause (car clauses)
+                                          (caar renames+bodies)
+                                          (cdar renames+bodies))
+                           (loop (cdr clauses) (cdr renames+bodies)))
+                   null))))]
         [(AnyQ p:let-values (e1 e2 rs renames rhss body))
-         (append (apply append (map for-deriv rhss))
+         (>>Seek [#:append (map for-deriv rhss)]
-                 (let ([new-table (table-restrict/let e1 renames)])
+                 [#:rename (do-rename/let e1 renames)]
-                   (parameterize ((subterms-table new-table))
+                 (for-bderiv body))]
-                     (for-bderiv body))))]
         [(AnyQ p:letrec-values (e1 e2 rs renames rhss body))
-         (let ([new-table (table-restrict/let e1 renames)])
+         (>>Seek [#:rename (do-rename/let e1 renames)]
-           (parameterize ((subterms-table new-table))
+                 [#:append (map for-deriv rhss)]
-             (append (apply append (map for-deriv rhss))
+                 (for-bderiv body))]
-                     (for-bderiv body))))]
         [(AnyQ p:letrec-syntaxes+values (e1 e2 rs srenames srhss vrenames vrhss body))
-         (let ([new-table (table-restrict/lsv1 e1 srenames)])
+         (>>Seek [#:rename (do-rename/lsv1 e1 srenames)]
-           (parameterize ((subterms-table new-table))
+                 [#:append (map for-deriv srhss)]
-             (append (apply append (map for-deriv srhss))
+                 [#:rename (do-rename/lsv2 srenames vrenames)]
-                     (let ([new-table (table-restrict/lsv2 e1 vrenames)])
+                 [#:append (map for-deriv vrhss)]
-                       (parameterize ((subterms-table new-table))
+                 (for-bderiv body))]
-                         (append (apply append (map for-deriv vrhss))
-                                 (for-bderiv body)))))))]
         [(AnyQ p::STOP (e1 e2 rs))
          null]
         ;; synth (should synth be idempotent?... heh, no point for now)
         [(AnyQ p:rename (e1 e2 rs rename inner))
-         (let ([new-table (table-restrict/rename (car rename) (cdr rename))])
+         (>>Seek [#:rename (do-rename (car rename) (cdr rename))]
-           (parameterize ((subterms-table new-table))
+                 (for-deriv inner))]
-             (for-deriv inner)))]
 
         ;; Macros
 
@@ -523,22 +547,31 @@
          ;; FIXME: and we'll also need to account for *that* marking, too...
          (unless (null? locals)
            (raise (make-localactions)))
-         (parameterize ((subterms-table (table-restrict/rename e1 me1)))
+         ;(let* ([table-at-end #f]
+         ;       [subterms
+         ;        (>>Seek [#:rename (do-rename e1 me1)]
+         ;                [#:append (map for-local locals)]
+         ;                [#:rename (do-rename me2 e2)]
+         ;                (begin (set! table-at-end (subterms-table))
+         ;                       null))])
+         ;  (values subterms table-at-end))
+         (let-values ([(rename-subterms1 table1) (do-rename e1 me1)])
+           (parameterize ((subterms-table table1))
              (let ([sss (map for-local locals)])
-             (values (apply append sss)
+               (let-values ([(rename-subterms2 table2) (do-rename me2 e2)])
-                     (table-restrict/rename me2 e2))))]))
+                 ;; FIXME: Including these seems to produce evil results
+                 ;; ie, parts of the hidden macro use appear as marked
+                 ;;     when they shouldn't
+                 (values (append #;rename-subterms1
+                                 (apply append sss)
+                                 #;rename-subterms2)
+                         table2)))))]))
 
     ;; for-local : LocalAction -> (list-of Subterm)
     (define (for-local local)
       (match local
         [(IntQ local-expansion (e1 e2 me1 me2 deriv))
-         (parameterize ((subterms-table (table-restrict/rename e1 me1)))
+         (error 'unimplemented)]
-           (let ([ss (for-deriv deriv)])
-             ;; 
-             '(for-each (lambda (s) (s:subterm-deriv s))
-                        ss)
-             '(table-restrict/rename me2 e2)
-             ss))]
         ;; Also need to handle local-bind
         ;; ...
         [else null]))
@@ -561,12 +594,12 @@
 
 
   ;; check-nonlinear-subterms : (list-of Subterm) -> void
-  ;; FIXME: How to handle nonlinear subterms?
+  ;; FIXME: No checking on renamings... need to add
-  ;;   Option 1: escape and recover by making the macro transparent (include explanation?)
-  ;;   Option 2: return special composite *thing* and somehow display both parts?
   ;; Note: Make sure subterm contexts are *disjoint*, not just *distinct*
   (define (check-nonlinear-subterms subterm-derivs)
-    (check-nonlinear-paths (map s:subterm-path subterm-derivs)))
+    (check-nonlinear-paths
+     (map s:subterm-path
+          (filter s:subterm? subterm-derivs))))
 
   ;; check-nonlinear-paths : (list-of Path) -> void
   ;; FIXME: This is overly conservative for now, but probably 
@@ -612,19 +645,27 @@
       (hash-table-map t (lambda (k v) v))))
 
   ;; substitute-subterms : Syntax (list-of Subterm) -> Syntax
-  ;; List of subterm contexts is guaranteed to be disjoint.
+  ;; - s:subterm contexts guaranteed to be disjoint.
+  ;; - s:renames replace syntax with syntax of same structure
   ;; FIXME: Could do this more efficiently using the structure of contexts...
   (define (substitute-subterms stx subterm-derivs)
     (cond [(null? subterm-derivs)
            stx]
-          [else
+          [(s:subterm? (car subterm-derivs))
            (let* ([subterm0 (car subterm-derivs)]
                   [path0 (s:subterm-path subterm0)]
                   [deriv0 (s:subterm-deriv subterm0)])
-             (substitute-subterms (if path0
+             (substitute-subterms
-                                      (path-replace stx path0 (deriv-e2 deriv0))
+              (if path0 (path-replace stx path0 (deriv-e2 deriv0)) stx)
-                                      stx)
+              (cdr subterm-derivs)))]
-                                  (cdr subterm-derivs)))]))
+          [(s:rename? (car subterm-derivs))
+           (let ([subterm0 (car subterm-derivs)])
+             (substitute-subterms
+              (path-replace stx
+                            (s:rename-path subterm0)
+                            (s:rename-after subterm0))
+              (cdr subterm-derivs)))]
+          [else (error 'substitute-subterms)]))
 
   ;; gather-one-subterm : syntax syntax -> SubtermTable
   (define (gather-one-subterm whole part)
@@ -1120,46 +1161,55 @@
   (define (table-get table stx)
     (hash-table-get table stx (lambda () null)))
 
-  ;; table-restrict/rename : syntax syntax -> Table
+  ;; do-rename : syntax syntax -> (values (list-of Subterm) Table)
-  (define (table-restrict/rename stx rename)
+  (define (do-rename stx rename)
     (let ([t (make-hash-table)]
           [old (subterms-table)])
-      ;; loop : syntax syntax -> void
+      ;; loop : syntax syntax -> (list-of Subterm)
-      (define (loop stx rename)
+      ;; Puts things into the new table, too
+      ;; If active? is #f, always returns null
+      (define (loop stx rename active?)
         (cond [(and (syntax? stx) (syntax? rename))
                (let ([paths (table-get old stx)])
-                 (when (pair? paths)
+                 (if (pair? paths)
-                   (hash-table-put! t rename paths)))
+                     (begin (hash-table-put! t rename paths)
-               (loop (syntax-e stx) (syntax-e rename))]
+                            (loop (syntax-e stx) (syntax-e rename) #f)
+                            (if active?
+                                (map (lambda (p) (make-s:rename p stx rename))
+                                     paths)
+                                null))
+                     (loop (syntax-e stx) (syntax-e rename) active?)))]
               [(syntax? rename)
-               (loop stx (syntax-e rename))]
+               (loop stx (syntax-e rename) active?)]
               [(and (pair? stx) (pair? rename))
-               (loop (car stx) (car rename))
+               (append
-               (loop (cdr stx) (cdr rename))]
+                (loop (car stx) (car rename) active?)
+                (loop (cdr stx) (cdr rename) active?))]
               [else
-               (void)]))
+               null]))
-      (loop stx rename)
+      (let ([subterms (loop stx rename #t)])
-      t))
+        (values subterms t))))
 
-  (define (table-restrict/lambda stx rename)
+  (define (do-rename/lambda stx rename)
     (with-syntax ([(?lambda ?formals . ?body) stx])
-      (table-restrict/rename (cons #'?formals #'?body) rename)))
+      (do-rename (cons #'?formals #'?body) rename)))
 
-  (define (table-restrict/let stx rename)
+  (define (do-rename/let stx rename)
     (with-syntax ([(?let ?bindings . ?body) stx])
-      (table-restrict/rename (cons #'?bindings #'?body) rename)))
+      (do-rename (cons #'?bindings #'?body) rename)))
 
-  (define (table-restrict/case-lambda stx rename)
+  (define (do-rename/case-lambda stx rename)
     (with-syntax ([(?formals . ?body) stx])
-      (table-restrict/rename (cons #'?formals #'?body) rename)))
+      (do-rename (cons #'?formals #'?body) rename)))
 
-  (define (table-restrict/lsv1 stx rename) 
+  (define (do-rename/lsv1 stx rename) 
     (with-syntax ([(?lsv ?sbindings ?vbindings . ?body) stx])
-      (table-restrict/rename (cons #'?sbindings (cons #'?vbindings #'?body)) rename)))
+      (do-rename (cons #'?sbindings (cons #'?vbindings #'?body)) rename)))
 
-  (define (table-restrict/lsv2 stx rename)
+  (define (do-rename/lsv2 old-rename rename)
     (if rename
-        (with-syntax ([(?lsv ?sbindings ?vbindings . ?body) stx])
+        (with-syntax ([(?sbindings ?vbindings . ?body) old-rename])
-          (table-restrict/rename (cons #'?vbindings #'?body) rename))
+          (do-rename (cons #'?vbindings #'?body) rename))
-        (subterms-table)))
+        (values null
+                (subterms-table))))
   )

collects/macro-debugger/model/reductions.ss

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

collects/macro-debugger/model/synth-engine.ss

@@ -87,14 +87,22 @@
                                new-e2))))))))]))
 
   (define-syntax >>Seek
-    (syntax-rules (!)
+    (syntax-rules (! =>)
       [(>>Seek) null]
       [(>>Seek [! tag exni] . more)
        (if (and (pair? exni) (eq? tag (car exni)))
            null
            (>>Seek . more))]
+      [(>>Seek [! exni] . more)
+       (if (pair? exni) null (>>Seek . more))]
+      [(>>Seek [#:append expr] . more)
+       (append (apply append expr) (>>Seek . more))]
       [(>>Seek [#:table t] . more)
        (parameterize ((subterms-table t)) (>>Seek . more))]
+      [(>>Seek [#:rename expr] . more)
+       (let-values ([(subterms new-table) expr])
+         (parameterize ((subterms-table new-table))
+           (append subterms (>>Seek . more))))]
       [(>>Seek expr . more)
        (append expr (>>Seek . more))]))