Macro stepper:

- removed dead seek-syntax code
  - fixed bug related to hiding + errors
  - fixed bug finding bindings in interrrupted expansion

svn: r6182

collects/macro-debugger/model/debug.ss

@@ -5,12 +5,14 @@
            "deriv-util.ss"
            "hide.ss"
            "hiding-policies.ss"
-           "deriv.ss")
+           "deriv.ss"
+           "steps.ss")
 
   (provide (all-from "trace.ss")
            (all-from "deriv.ss")
            (all-from "deriv-util.ss")
            (all-from "hiding-policies.ss")
            (all-from "hide.ss")
+           (all-from "steps.ss")
            (all-from (lib "plt-match.ss")))
   )

collects/macro-debugger/model/deriv-util.ss

@@ -272,7 +272,11 @@
   ;; FIXME: Missing case-lambda
   (define (extract-all-fresh-names d)
     (define (renaming-node? x)
-      (or (p:lambda? x)
+      (or (and (error-wrap? x)
+               (renaming-node? (error-wrap-inner x)))
+          (and (interrupted-wrap? x)
+               (renaming-node? (interrupted-wrap-inner x)))
+          (p:lambda? x)
           (p:case-lambda? x)
           (p:let-values? x)
           (p:letrec-values? x)
@@ -284,22 +288,22 @@
           (p:define-syntaxes? x)))
     (define (extract-fresh-names d)
       (match d
-        [(struct p:lambda (e1 e2 rs renames body))
+        [(AnyQ 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))
+        [(AnyQ 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))
+        [(AnyQ 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))
+        [(AnyQ p:letrec-syntaxes+values (e1 e2 rs srenames srhss vrenames vrhss body))
          (cons
           (if srenames
               (with-syntax ([(((?svars ?srhs) ...) ((?vvars ?vrhs) ...) . ?body)
@@ -310,24 +314,24 @@
               (with-syntax ([(((?vvars ?vrhs) ...) . ?body) vrenames])
                 #'(?vvars ...))
               null))]
-        [(struct b:defvals (rename head))
+        [(AnyQ b:defvals (rename head))
          (let ([head-e2 (lift/deriv-e2 head)])
            (if head-e2
                (with-syntax ([(?dv ?vars ?rhs) head-e2])
                  #'?vars)
                null))]
-        [(struct b:defstx (rename head rhs))
+        [(AnyQ b:defstx (rename head rhs))
          (let ([head-e2 (lift/deriv-e2 head)])
            (if head-e2
                (with-syntax ([(?ds ?svars ?rhs) head-e2])
                  #'?svars)
                null))]
-        [(struct p:define-values (e1 e2 rs rhs))
+        [(AnyQ p:define-values (e1 e2 rs rhs))
          (if rhs
              (with-syntax ([(?dv ?vars ?rhs) e1])
                #'?vars)
              null)]
-        [(struct p:define-syntaxes (e1 e2 rs rhs))
+        [(AnyQ p:define-syntaxes (e1 e2 rs rhs))
          (if rhs
              (with-syntax ([(?ds ?svars ?srhs) e1])
                #'?svars)

collects/macro-debugger/model/hide.ss

@@ -12,7 +12,6 @@
   (provide hide/policy
            macro-policy
            force-letrec-transformation
-           seek-syntax
            current-hiding-warning-handler
            (struct nonlinearity (message paths))
            (struct localactions ()))
@@ -547,18 +546,22 @@
   (define (create-synth-deriv e1 subterm-derivs)
     (define (error? x)
       (and (s:subterm? x) 
-           (or (interrupted-wrap? (s:subterm-deriv x))
+           (error-wrap? (s:subterm-deriv x))
-               (error-wrap? (s:subterm-deriv x)))))
+           (not (s:subterm-path x))))
-    (let ([errors
+    (define (interrupted? x)
-           (map s:subterm-deriv (filter error? subterm-derivs))]
+      (and (s:subterm? x)
-          [subterms (filter (lambda (x) (not (error? x))) subterm-derivs)])
+           (interrupted-wrap? (s:subterm-deriv x))))
-      ;(printf "subterm paths:~n~s~n" (map s:subterm-path subterm-derivs))
+    (let* ([errors (map s:subterm-deriv (filter error? subterm-derivs))]
-      ;(printf "subterms:~n~s~n" subterm-derivs)
+           [subterms (filter (lambda (x) (not (error? x))) subterm-derivs)]
-      (let ([e2 (and (null? errors) (substitute-subterms e1 subterms))])
+           [interrupted (filter interrupted? subterms)])
-        (let ([d (make-p:synth e1 e2 null subterms)])
+      (let ([e2 (and (null? errors)
-          (if (pair? errors)
+                     (null? interrupted)
-              (rewrap (car errors) d)
+                     (substitute-subterms e1 subterms))])
-              d)))))
+        (let ([d (make-p:synth e1 e2 null subterms)]
+              [wrap (cond [(pair? errors) (car errors)]
+                          [(pair? interrupted) (car interrupted)]
+                          [else #f])])
+          (if wrap (rewrap wrap d) d)))))
 
   ;; subterm-derivations : Derivation -> (list-of Subterm)
   (define (subterm-derivations d)
@@ -570,7 +573,7 @@
             (let-values ([(d _) (hide d)])
               (list (make-s:subterm path d)))
             (for-unlucky-deriv/record-error d))))
-
+    
     ;; for-deriv/phase-up : Derivation -> (list-of Subterm)
     (define (for-deriv/phase-up d)
       (parameterize ((phase (add1 (phase))))
@@ -594,7 +597,7 @@
                     "nonlinearity in original term" paths))]))]
         [#f #f]))
 
-    ;; for-unluck-deriv/record-error -> (list-of Subterm)
+    ;; for-unlucky-deriv/record-error -> (list-of Subterm)
     ;; Guarantee: (deriv-e1 deriv) is not in subterms table
     (define (for-unlucky-deriv/record-error d)
       (if (error-wrap? d)
@@ -650,12 +653,7 @@
         [(AnyQ p:#%app (e1 e2 rs tagges-stx lderiv))
          (>>Seek (for-lderiv lderiv))]
         [(AnyQ p:lambda (e1 e2 rs renames body) exni)
-         ;; 1 Make a new table
+         (>>Seek [#:rename (do-rename/lambda e1 renames)]
-         ;;   Can narrow table to things that only occur in the renames
-         ;; 2 Search body
-         ;; 3 Make a "renaming" step... FIXME, how to represent?
-         (>>Seek [! exni]
-                 [#:rename (do-rename/lambda e1 renames)]
                  (for-bderiv body))]
         [(AnyQ p:case-lambda (e1 e2 rs renames+bodies))
          (with-syntax ([(?case-lambda ?clause ...) e1])
@@ -917,218 +915,33 @@
         (values subterms t))))
 
   (define (do-rename/lambda stx rename)
-    (with-syntax ([(?lambda ?formals . ?body) stx])
+    (if rename
-      (do-rename (cons #'?formals #'?body) rename)))
+        (with-syntax ([(?lambda ?formals . ?body) stx])
+          (do-rename (cons #'?formals #'?body) rename))
+        (values null (subterms-table))))
 
   (define (do-rename/let stx rename)
-    (with-syntax ([(?let ?bindings . ?body) stx])
+    (if rename 
-      (do-rename (cons #'?bindings #'?body) rename)))
+        (with-syntax ([(?let ?bindings . ?body) stx])
+          (do-rename (cons #'?bindings #'?body) rename))
+        (values null (subterms-table))))
 
   (define (do-rename/case-lambda stx rename)
-    (with-syntax ([(?formals . ?body) stx])
+    (if rename
-      (do-rename (cons #'?formals #'?body) rename)))
+        (with-syntax ([(?formals . ?body) stx])
+          (do-rename (cons #'?formals #'?body) rename))
+        (values null (subterms-table))))
 
   (define (do-rename/lsv1 stx rename) 
-    (with-syntax ([(?lsv ?sbindings ?vbindings . ?body) stx])
+    (if rename
-      (do-rename (cons #'?sbindings (cons #'?vbindings #'?body)) rename)))
+        (with-syntax ([(?lsv ?sbindings ?vbindings . ?body) stx])
+          (do-rename (cons #'?sbindings (cons #'?vbindings #'?body)) rename))
+        (values null (subterms-table))))
 
   (define (do-rename/lsv2 old-rename rename)
     (if rename
         (with-syntax ([(?sbindings ?vbindings . ?body) old-rename])
           (do-rename (cons #'?vbindings #'?body) rename))
-        (values null
+        (values null (subterms-table))))
-                (subterms-table))))
-
-  
-  
-
-;                                                                 
-;                                                                 
-;                                                                 
-;                              ;;                                 
-;                              ;;                                 
-;                               ;                  ;              
-;                               ;                  ;              
-;    ;;;;;     ;;;;     ;;;;    ;  ;;;   ;;;;;   ;;;;;;  ;;;;  ;; 
-;   ;;   ;    ;   ;    ;   ;    ;  ;    ;;   ;     ;       ;   ;  
-;   ;;       ;;   ;;  ;;   ;;   ; ;     ;;         ;        ; ;   
-;    ;;;     ;;;;;;;  ;;;;;;;   ;;;      ;;;       ;        ;;;   
-;      ;;;;  ;        ;         ;;;        ;;;;    ;        ;;;   
-;   ;    ;;  ;;       ;;        ; ;;    ;    ;;    ;        ; ;   
-;   ;    ;;   ;;       ;;       ;  ;;   ;    ;;    ;;      ;   ;  
-;   ;;;;;;     ;;;;     ;;;;   ;;;  ;;; ;;;;;;      ;;;  ;;;  ;;; 
-;                                                                 
-;                                                                 
-;                                                                 
-;                                                                 
-  
-  (define-syntax proptable
-    (syntax-rules ()
-      [(proptable expr)
-       (let-values ([(subterms table) expr]
-                    [(old-table) (subterms-table)])
-         (hash-table-for-each
-          old-table
-          (lambda (k v) (hash-table-put! table k v)))
-         (printf "** New table: ~s~n" (hash-table-count table))
-         (begin (printf "  > ")
-                (hash-table-for-each table (lambda (k v) (write (syntax-object->datum k)) (display " ")))
-                (printf "~n"))
-         (values subterms table))]))
-
-  ;; seek-syntax : Syntax Derivation -> (list-of Derivation)
-  (define (seek-syntax stx d)
-
-    ;; for-deriv : Derivation -> (list-of Derivation)
-    (define (for-deriv d)
-      (cond [(hash-table-get (subterms-table) (lift/deriv-e1 d) #f)
-             (list d)]
-            [else (for-unlucky-deriv d)]))
-
-    ;; for-unlucky-deriv : Derivation -> (list-of Derivation)
-    (define (for-unlucky-deriv d)
-      (parameterize ((print-struct #f)) 
-        (printf "unlucky with ~s[[~s]]~n" d (syntax-object->datum (lift/deriv-e1 d))))
-      (match d
-        ;; Primitives
-        [(AnyQ p:module (e1 e2 rs one-body-form? body))
-         (cond [one-body-form?
-                ;; FIXME: tricky... how to do renaming?
-                (for-deriv body)]
-               [else
-                (with-syntax ([(?module ?name ?lang . ?body) e1]
-                              [(?module-begin . ?body*) (lift/deriv-e1 body)])
-                  (>>Seek [#:rename (proptable (do-rename #'?body #'?body*))]
-                          (for-deriv body)))])]
-        [(AnyQ p:#%module-begin (e1 e2 rs pass1 pass2))
-         ;; FIXME: No new allocation!
-         (let ([lderiv (module-begin->lderiv d)])
-           (for-lderiv lderiv))]
-        [(AnyQ p:variable (e1 e2 rs))
-         null]
-        [(AnyQ p:define-syntaxes (e1 e2 rs rhs))
-         (>>Seek (for-deriv rhs))]
-        [(AnyQ p:define-values (e1 e2 rs rhs))
-         (>>Seek (for-deriv rhs))]
-        [(AnyQ p:if (e1 e2 rs full? test then else))
-         (>>Seek (for-deriv test)
-                 (for-deriv then)
-                 (if full?
-                     (for-deriv else)
-                     null))]
-        [(AnyQ p:wcm (e1 e2 rs key value body))
-         (>>Seek (for-deriv key)
-                 (for-deriv value)
-                 (for-deriv body))]
-        [(AnyQ p:set! (e1 e2 rs id-resolves rhs))
-         (>>Seek (for-deriv rhs))]
-        [(AnyQ p:set!-macro (e1 e2 rs deriv))
-         (>>Seek (for-deriv deriv))]
-        [(AnyQ p:begin (e1 e2 rs lderiv))
-         (>>Seek (for-lderiv lderiv))]
-        [(AnyQ p:begin0 (e1 e2 rs head lderiv))
-         (>>Seek (for-deriv head)
-                 (for-lderiv lderiv))]
-        [(AnyQ p:#%app (e1 e2 rs tagges-stx lderiv))
-         (>>Seek (for-lderiv lderiv))]
-        [(AnyQ p:lambda (e1 e2 rs renames body) exni)
-         (>>Seek [! exni]
-                 [#:rename (proptable (do-rename/lambda e1 renames))]
-                 (for-bderiv body))]
-        [(AnyQ p:case-lambda (e1 e2 rs renames+bodies))
-         (with-syntax ([(?case-lambda ?clause ...) e1])
-           (let ()
-             (define (handle-clause clause-stx rename body)
-               (>>Seek [#:rename (proptable (do-rename/case-lambda clause-stx rename))]
-                       (for-bderiv body)))
-             (let loop ([clauses (syntax->list #'(?clause ...))]
-                        [renames+bodies renames+bodies])
-               (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))
-         (>>Seek [#:rename (proptable (do-rename/let e1 renames))]
-                 [#:append (map for-deriv rhss)]
-                 (for-bderiv body))]
-        [(AnyQ p:letrec-values (e1 e2 rs renames rhss body))
-         (>>Seek [#:rename (proptable (do-rename/let e1 renames))]
-                 [#:append (map for-deriv rhss)]
-                 (for-bderiv body))]
-        [(AnyQ p:letrec-syntaxes+values (e1 e2 rs srenames srhss vrenames vrhss body))
-         (>>Seek [#:rename (proptable (do-rename/lsv1 e1 srenames))]
-                 [#:append (map for-deriv srhss)]
-                 [#:rename (proptable (do-rename/lsv2 srenames vrenames))]
-                 [#:append (map for-deriv vrhss)]
-                 (for-bderiv body))]
-        [(AnyQ p::STOP (e1 e2 rs))
-         null]
-        [(AnyQ p:synth (e1 e2 rs ss))
-         (let loop ([ss ss])
-           (if (null? ss)
-               null
-               (let ([s0 (car ss)])
-                 (parameterize ((print-struct #f)) (printf "subterm: ~s~n" s0))
-                 (cond [(s:subterm? s0)
-                        (>>Seek (for-deriv (s:subterm-deriv s0))
-                                (loop (cdr ss)))]
-                       [(s:rename? s0)
-                        (>>Seek [#:rename (proptable 
-                                           (do-rename (s:rename-before s0)
-                                                      (s:rename-after s0)))]
-                                (loop (cdr ss)))]
-                       [else
-                        (loop (cdr ss))]))))]
-        [(AnyQ p:rename (e1 e2 rs rename inner))
-         (>>Seek [#:rename (proptable (do-rename (car rename) (cdr rename)))]
-                 (for-deriv inner))]
-        
-        ;; Macros
-
-        [(AnyQ mrule (e1 e2 (? transformation? tx) next))
-         (recv [(subterms table) (for-transformation tx)]
-               (parameterize ((subterms-table table))
-                 (append subterms (for-deriv next))))]
-        
-        [(AnyQ lift-deriv (e1 e2 first lifted-stx next))
-         (>>Seek (for-deriv first)
-                 (for-deriv next))]
-        
-        [#f null]
-        ))
-
-    ;; for-transformation : Transformation -> (values (list-of Subterm) Table)
-    (define (for-transformation tx)
-      (match tx
-        [(struct transformation (e1 e2 rs me1 me2 locals _seq))
-         ;; FIXME: We'll need to use e1/e2/me1/me2 to synth locals, perhaps
-         ;; FIXME: and we'll also need to account for *that* marking, too...
-         (let-values ([(rename-subterms1 table1) (proptable (do-rename e1 me1))])
-           (parameterize ((subterms-table table1))
-             (let-values ([(rename-subterms2 table2) (proptable (do-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 null table2))))]))
-
-    ;; for-lderiv : ListDerivation -> (list-of Subterm)
-    (define (for-lderiv ld)
-      (match ld
-        [(IntQ lderiv (es1 es2 derivs))
-         (apply append (map for-deriv derivs))]
-        [(struct error-wrap (exn tag inner))
-         (for-lderiv inner)]
-        [#f null]))
-
-    ;; for-bderiv : BlockDerivation -> (list-of Subterm)
-    (define (for-bderiv bd)
-      (for-lderiv (bderiv->lderiv bd)))
-
-    (let ([table0 (make-hash-table)])
-      (hash-table-put! table0 stx #t)
-      (parameterize ((subterms-table table0))
-        (for-deriv d))))
 
     )

collects/macro-debugger/model/reductions.ss

@@ -317,7 +317,8 @@
                   (let ([ctx (lambda (x) (path-replace term path0 x))])
                     (append (with-context ctx
                               (reductions* deriv0))
-                            (loop (and (deriv? deriv0)
+                            (loop (and term
+                                       (deriv? deriv0)
                                        (path-replace term path0 (deriv-e2 deriv0)))
                                   (cdr subterms)))))]
                [(s:rename? (car subterms))
@@ -326,9 +327,10 @@
                   ;; FIXME: if so, coalesce?
                   (rename-frontier (s:rename-before subterm0)
                                    (s:rename-after subterm0))
-                  (loop (path-replace term
+                  (loop (and term
-                                      (s:rename-path subterm0)
+                             (path-replace term
-                                      (s:rename-after subterm0))
+                                           (s:rename-path subterm0)
+                                           (s:rename-after subterm0)))
                         (cdr subterms)))]))]
 
       ;; FIXME