make macro stepper recover from jumps within expansion

original commit: 678fc4d6f894df87c79a4277eb41c46ace1ea9b3

collects/macro-debugger/model/deriv-c.rkt

@@ -47,6 +47,7 @@
 (define-struct track-origin (before after) #:transparent)
 (define-struct local-remark (contents) #:transparent)
   ;; contents : (listof (U string syntax))
+(define-struct local-mess (events) #:transparent)
 
 ;; A PrimDeriv is one of
 (define-struct (prule base) () #:transparent)

collects/macro-debugger/model/deriv-parser.rkt

@@ -42,7 +42,7 @@
     enter-list exit-list
     enter-check exit-check
     local-post exit-local exit-local/expr
-    local-bind enter-bind exit-bind
+    local-bind enter-bind exit-bind exit-local-bind
     local-value-result local-value-binding
     phase-up module-body
     renames-lambda
@@ -173,8 +173,9 @@
      (#:args e1 rs next)
      [(enter-macro ! macro-pre-transform (? LocalActions)
                    macro-post-transform ! exit-macro)
-      (make mrule e1 (and next (wderiv-e2 next)) rs $2
+      (let ([e2 (and next (wderiv-e2 next))])
-            $3 $4 $5 $6 $7 next)])
+        (make mrule e1 e2 rs $2
+              $3 $4 (and $5 (car $5)) $6 $7 next))])
 
     ;; Keyword resolution
     (Resolves
@@ -202,9 +203,9 @@
       (make local-lift-require (car $1) (cadr $1) (cddr $1))]
      [(lift-provide)
       (make local-lift-provide $1)]
-     [(local-bind ! rename-list next)
+     [(local-bind ! rename-list exit-local-bind)
       (make local-bind $1 $2 $3 #f)]
-     [(local-bind rename-list (? BindSyntaxes) next)
+     [(local-bind rename-list (? BindSyntaxes) exit-local-bind)
       (make local-bind $1 #f $2 $3)]
      [(track-origin)
       (make track-origin (car $1) (cdr $1))]
@@ -224,6 +225,10 @@
                 before null after #f mafter
                 (make p:stop mafter mafter null #f))
           #f after #f))]
+     [(local-mess)
+      ;; Represents subsequence of event stream incoherent due to
+      ;; jump (eg, macro catches exn raised from within local-expand).
+      (make local-mess $1)]
      ;; -- Not really local actions, but can occur during evaluation
      ;; called 'expand' (not 'local-expand') within transformer
      [(start (? EE)) #f]

collects/macro-debugger/model/deriv-tokens.rkt

@@ -15,6 +15,7 @@
    EOF                  ; .
    enter-bind           ; .
    exit-bind            ; .
+   exit-local-bind      ; .
    IMPOSSIBLE           ; useful for error-handling clauses that have no
                         ; NoError counterpart
    top-non-begin        ; .
@@ -26,7 +27,7 @@
    resolve              ; identifier
    enter-macro          ; syntax
    macro-pre-transform  ; syntax
-   macro-post-transform ; syntax
+   macro-post-transform ; (cons syntax syntax)
    exit-macro           ; syntax
    enter-prim           ; syntax
    exit-prim            ; syntax
@@ -73,6 +74,7 @@
    local-value          ; identifier
    local-value-result   ; boolean
    local-value-binding  ; result of identifier-binding; added by trace.rkt, not expander
+   local-mess           ; (listof event)
    ))
 
 (define-tokens renames-tokens
@@ -113,6 +115,7 @@
     (#f  local-remark            ,token-local-remark)
     (#f  local-artificial-step   ,token-local-artificial-step)
     (#f  local-value-binding     ,token-local-value-binding)
+    (#f  local-mess              ,token-local-mess)
 
     ;; Standard signals
     (0   visit                   ,token-visit)
@@ -198,6 +201,7 @@
     (157 prepare-env)
     (158 prim-submodule)
     (159 prim-submodule*)
+    (160 exit-local-bind)
     ))
 
 (define (signal->symbol sig)

collects/macro-debugger/model/reductions.rkt

@@ -1,6 +1,7 @@
 #lang racket/base
 (require (for-syntax racket/base)
          racket/match
+         racket/format
          syntax/stx
          "../util/eomap.rkt"
          "deriv-util.rkt"
@@ -505,7 +506,17 @@
         ]]
     [(struct local-remark (contents))
      (R [#:reductions (list (walk/talk 'remark contents))])]
-
+    [(struct local-mess (events))
+     ;; FIXME: While it is not generally possible to parse tokens as one or more
+     ;; interrupted derivations (possibly interleaved with successful derivs),
+     ;; it should be possible to recover *some* information and display it.
+     (R [#:reductions
+         (let ([texts
+                (list (~a "Some expansion history has been lost due to a jump "
+                          "within expansion.")
+                      (~a "For example, a macro may have caught an "
+                          "exception coming from within a call to `local-expand'."))])
+           (list (walk/talk 'remark texts)))])]
     [#f
      (R)]))
 

collects/macro-debugger/model/trace.rkt

@@ -1,5 +1,6 @@
 #lang racket/base
 (require racket/promise
+         racket/list
          syntax/modcode
          syntax/modresolve
          parser-tools/lex
@@ -76,20 +77,58 @@
 ;; expand/events : stx (stx -> stx) -> stx/exn (list-of event)
 (define (expand/events sexpr expander)
   (define events null)
+  ;; Problem: jumps within expansion (eg, macro catches error thrown from within
+  ;; call to 'local-expand') can result in ill-formed event stream.
+  ;; In general, not possible to detect jump endpoints, but we can at least isolate
+  ;; the bad parts by watching for mismatched bracketing events
+  ;; (eg, macro-{pre,post}-transform).
+  (define counter 0)        ;; = (length events)
+  (define macro-stack null) ;; (listof (cons (U stx 'local-bind) nat))
   (define (add! x y)
+    (set! counter (add1 counter))
     (set! events (cons (cons (signal->symbol x) y) events)))
   (define add!/check
     (let ([limit (trace-macro-limit)]
           [handler (trace-limit-handler)]
-          [counter 0]
+          [limit-counter 0]
           [last-local-value-id #f])
       (lambda (x y)
         (add! x y)
         (case x
           ((8) ;; enter-macro
-           (set! counter (add1 counter))
+           (set! limit-counter (add1 limit-counter))
-           (when (>= counter limit)
+           (when (>= limit-counter limit)
-             (set! limit (handler counter))))
+             (set! limit (handler limit-counter))))
+          ((21) ;; macro-pre-transform
+           (let ([rec (cons y counter)])
+             (set! macro-stack (cons rec macro-stack))))
+          ((22) ;; macro-post-transform
+           (cond [(and (pair? macro-stack)
+                       (eq? (car (car macro-stack)) (cdr y)))
+                  (set! macro-stack (cdr macro-stack))]
+                 [else ;; Jumped!
+                  (let loop ([ms macro-stack])
+                    (let ([top (car ms)])
+                      (cond [(eq? (car top) (cdr y))
+                             (let* ([reset-to (cdr top)]
+                                    [len (- counter reset-to 1)]
+                                    [pfx (take (cdr events) len)]
+                                    [sfx (drop (cdr events) len)])
+                               (set! macro-stack (cdr ms))
+                               (set! events sfx)
+                               (set! counter (cdr top))
+                               (add! 'local-mess (reverse pfx))
+                               (add! 'macro-post-transform y))]
+                            [else (loop (cdr ms))])))]))
+          ((143) ;; local-bind
+           (let ([rec (cons 'local-bind counter)])
+             (set! macro-stack (cons rec macro-stack))))
+          ((160) ;; exit-local-bind
+           (let ([top (car macro-stack)])
+             (cond [(eq? (car top) 'local-bind)
+                    (set! macro-stack (cdr macro-stack))]
+                   [else ;; Jumped!
+                    (error 'trace "internal error: cannot handle catch within bind")])))
           ((153) ;; local-value
            (set! last-local-value-id y))
           ((154) ;; local-value-result
@@ -107,7 +146,6 @@
       (values result
               (reverse events)))))
 
-
 (require syntax/stx
          syntax/kerncase)
 

collects/tests/macro-debugger/tests/regression.rkt

@@ -223,4 +223,17 @@
                           (define-values (y) 2))))])
         (check-pred deriv? d)
         (check-pred ok-node? d)))
+
+    ;; Added 10/11/2012 based on bug from mflatt,shriram
+    (test-case "recover from jump"
+      (let ([d (trace '(module m racket/base
+                         (require (for-syntax racket/base))
+                         (define-syntax (convert-error stx)
+                           (syntax-case stx ()
+                             [(convert-error expr)
+                              (with-handlers ([exn? (lambda (e) #'(quote error))])
+                                (local-expand #'expr 'expression null))]))
+                         (convert-error (lambda))))])
+        (check-pred deriv? d)
+        (check-pred ok-node? d)))
     ))